diff --git a/src/Applications/GEOSdas_App/GEOSdas.csm b/src/Applications/GEOSdas_App/GEOSdas.csm index e2fdfd5f..363bf613 100755 --- a/src/Applications/GEOSdas_App/GEOSdas.csm +++ b/src/Applications/GEOSdas_App/GEOSdas.csm @@ -78,6 +78,7 @@ # - Revise multi-incremental approach for 4d-analysis # (cost goes down with successive updates) # - Temporarily leaving test lines commented out +# 8Dec2021 Sienkiewicz - add option for 'cleanup_tail' for aircraft bias correction #----------------------------------------------------------------------------- # @@ -115,6 +116,7 @@ if ( !($?BOOTSTRAP) ) setenv BOOTSTRAP 0 if ( !($?CENTRAL_AGCM_PARALLEL) ) setenv CENTRAL_AGCM_PARALLEL 0 if ( !($?CHECK_DMF) ) setenv CHECK_DMF 1 + if ( !($?CLEANUP_TAIL) ) setenv CLEANUP_TAIL 0 if ( !($?CONVPROG) ) setenv CONVPROG 0 if ( !($?CONVSFC) ) setenv CONVSFC 0 if ( !($?CONVUPA) ) setenv CONVUPA 0 @@ -913,11 +915,15 @@ exit 1 echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc_pof=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: @@ -1128,11 +1134,15 @@ exit 1 echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc_pof.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: diff --git a/src/Applications/GEOSdas_App/fvsetup b/src/Applications/GEOSdas_App/fvsetup index f7d8d041..3777b1bf 100755 --- a/src/Applications/GEOSdas_App/fvsetup +++ b/src/Applications/GEOSdas_App/fvsetup @@ -801,17 +801,14 @@ sub defaults { gsi_sens.rc.tmpl noreplay.acq odsmatch.rc - prepobs_acarsqc.merra.parm prepobs_cqc_statbge prepobs_cqcbufr.merra.parm prepobs_errtable.global - prepobs_landc prepobs_oiqc.oberrs prepobs_prep.bufrtable prepobs_prepacqc.merra.parm prepobs_prevents.merra.parm prepobs_profcqc.merra.parm - prepobs_waypoints sac.nl.tmpl vtrack.ctl.tmpl vtrack.rc diff --git a/src/Applications/GSI_App/fvssi b/src/Applications/GSI_App/fvssi index 05793097..7afdbc05 100755 --- a/src/Applications/GSI_App/fvssi +++ b/src/Applications/GSI_App/fvssi @@ -53,6 +53,7 @@ if ( !($?ANA4DUPD_IAU0_ONLY) ) setenv ANA4DUPD_IAU0_ONLY 0 # assume 4d increment if ( !($?ANGLEBC) ) setenv ANGLEBC 0 if ( !($?BATCH_SUBCMD) ) setenv BATCH_SUBCMD "sbatch" + if ( !($?CLEANUP_TAIL) ) setenv CLEANUP_TAIL 0 if ( !($?DATAMOVE_CONSTRAINT) ) setenv DATAMOVE_CONSTRAINT NULL if ( !($?INCSENS) ) setenv INCSENS 0 if ( !($?GSI_NETCDF_DIAG) ) setenv GSI_NETCDF_DIAG 0 @@ -742,11 +743,15 @@ echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc_pof=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: @@ -842,11 +847,15 @@ echo 'Setting aircraft_t_bc_ext to true, using external bias correction' breaksw case 2: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc to true, using VV.VV^2 bias correction' breaksw case 3: - echo "s/>>>AIRCFT_BIAS<<> sed_file + set cftstring = "aircraft_t_bc_pof=.true.," + if ( $CLEANUP_TAIL ) set cftstring = "$cftstring cleanup_tail=.true.," + echo "s/>>>AIRCFT_BIAS<<> sed_file echo 'Setting aircraft_t_bc_pof to true, using POF bias correction' breaksw default: @@ -984,6 +993,7 @@ ENVIRONMENT VARIABLES ENVIRONMENT VARIABLES (optional) ACFTBIAS sets aircraft bias correction + CLEANUP_TAIL triggers cleanup of aircraft coefficient file ANASENS trigger for analysis sensitivity (obs impact) INCSENS allows running adjoint GSI with analysis increment for input DO4DVAR trigger for 4DVAR-related features diff --git a/src/Applications/GSI_App/prepobs_prep.bufrtable b/src/Applications/GSI_App/prepobs_prep.bufrtable index d4d21346..670f493d 100755 --- a/src/Applications/GSI_App/prepobs_prep.bufrtable +++ b/src/Applications/GSI_App/prepobs_prep.bufrtable @@ -7,134 +7,176 @@ * | * THE FOLLOWING ARE TABLE A ENTRIES FOR PREPBUFR MESSAGE TYPES | * | -| ADPUPA | A60240 | UPPER-AIR (RAOB, PIBAL, RECCO, DROPS) REPORTS | -| AIRCAR | A60241 | ACARS AIRCRAFT REPORTS | -| AIRCFT | A60242 | CONVENTIONAL (AIREP, PIREP) AND ASDAR AIRCRAFT REPORTS | -| SATWND | A60243 | SATELLITE-DERIVED WIND REPORTS | -| PROFLR | A60244 | WIND PROFILER REPORTS | -| VADWND | A60245 | VAD (NEXRAD) WIND REPORTS | -| SATEMP | A60246 | TOVS SATELLITE DATA (SOUNDINGS, RETRIEVALS, RADIANCES) | -| ADPSFC | A60247 | SURFACE LAND (SYNOPTIC, METAR) REPORTS | -| SFCSHP | A60248 | SURFACE MARINE (SHIP, BUOY, C-MAN PLATFORM) REPORTS | -| SFCBOG | A60249 | MEAN SEA-LEVEL PRESSURE BOGUS REPORTS | -| SPSSMI | A60250 | SSM/I RETRIEVAL PRODUCTS (REPROCESSED WIND SPEED, TPW) | -| SYNDAT | A60251 | SYNTHETIC TROPICAL CYCLONE BOGUS REPORTS | -| ERS1DA | A60252 | ERS SCATTEROMETER DATA (REPROCESSED WIND SPEED) | -| GOESND | A60253 | GOES SATELLITE DATA (SOUNDINGS, RETRIEVALS, RADIANCES) | -| QKSWND | A60254 | QUIKSCAT SCATTEROMETER DATA (REPROCESSED WIND SPEED) | +| ADPUPA | A48102 | UPPER-AIR (RAOB, PIBAL, RECCO, DROPS) REPORTS | +| AIRCAR | A48103 | MDCRS ACARS AIRCRAFT REPORTS | +| AIRCFT | A48104 | AIREP, PIREP, AMDAR, TAMDAR AIRCRAFT REPORTS | +| SATWND | A48105 | SATELLITE-DERIVED WIND REPORTS | +| PROFLR | A48106 | WIND PROFILER REPORTS | +| VADWND | A48107 | VAD (NEXRAD) WIND REPORTS | +| SATEMP | A48108 | TOVS SATELLITE DATA (SOUNDINGS, RETRIEVALS, RADIANCES) | +| ADPSFC | A48109 | SURFACE LAND (SYNOPTIC, METAR) REPORTS | +| SFCSHP | A48110 | SURFACE MARINE (SHIP, BUOY, C-MAN PLATFORM) REPORTS | +| SFCBOG | A48111 | MEAN SEA-LEVEL PRESSURE BOGUS REPORTS | +| SPSSMI | A48112 | SSM/I RETRIEVAL PRODUCTS (REPROCESSED WIND SPEED, TPW) | +| SYNDAT | A48113 | SYNTHETIC TROPICAL CYCLONE BOGUS REPORTS | +| ERS1DA | A48114 | ERS SCATTEROMETER DATA (REPROCESSED WIND SPEED) | +| GOESND | A48115 | GOES SATELLITE DATA (SOUNDINGS, RETRIEVALS, RADIANCES) | +| QKSWND | A48116 | QUIKSCAT SCATTEROMETER DATA (REPROCESSED) | +| MSONET | A48117 | MESONET SURFACE REPORTS (COOPERATIVE NETWORKS) | +| GPSIPW | A48118 | GLOBAL POSITIONING SATELLITE-INTEGRATED PRECIP. WATER | +| RASSDA | A48119 | RADIO ACOUSTIC SOUNDING SYSTEM (RASS) TEMP PROFILE RPTS | +| WDSATR | A48120 | WINDSAT SCATTEROMETER DATA (REPROCESSED) | +| ASCATW | A48121 | ASCAT SCATTEROMETER DATA (REPROCESSED) | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR SEQUENCES DEFINED IN TABLE A ENTRIES | * | -| HEADR | 361001 | REPORT HEADER SEQUENCE | -| PLEVL | 361002 | PRESSURE LEVEL SEQUENCE (ALL TYPES EXCEPT GOESND) | -| PMSL | 361003 | MEAN SEA LEVEL PRESSURE SEQUENCE | -| BTLEVL | 361004 | BRIGHTNESS TEMPERATURE "LEVEL" SEQUENCE | -| ALTMSQ | 361005 | ALTIMETER SETTING SEQUENCE | -| TURB1SQ | 361006 | AIREP, PIREP, AMDAR AIRCRAFT DEGREE OF TURBULENCE SEQ | -| TURB2SQ | 361007 | ACARS AIRCRAFT DEGREE OF TURBULENCE SEQUENCE | -| ACFSUP | 361008 | AIRCRAFT SUPPLEMENTARY DATA SEQUENCE | -| RFFLSQ | 361009 | NESDIS RECURSIVE FILTER FLAG SEQUENCE | -| WSPDSQ | 361010 | WIND SPEED SEQUENCE | -| PLEVLG | 361011 | GOESND PRESSURE LEVEL SEQUENCE | +| HEADR | 348001 | REPORT HEADER SEQUENCE | +| PRSLEVEL | 348002 | PRESSURE LEVEL SEQUENCE (EXCEPT GOESND, AIRCFT/AIRCAR) | +| PMSL_SEQ | 348003 | MEAN SEA LEVEL PRESSURE SEQUENCE | +| BTMPLEVL | 348004 | BRIGHTNESS TEMPERATURE "LEVEL" SEQUENCE | +| ALTIMSEQ | 348005 | ALTIMETER SETTING SEQUENCE | +| TURB1SEQ | 348006 | TURBULENCE SEQUENCE # 1 | +| TURB2SEQ | 348007 | TURBULENCE SEQUENCE # 2 | +| ACFT_SEQ | 348008 | AIRCRAFT SUPPLEMENTARY DATA SEQUENCE | +| PCCF_SEQ | 348009 | SATELLITE WIND PERCENT CONFIDENCE SEQUENCE | +| PRSLEVLG | 348011 | GOESND PRESSURE LEVEL SEQUENCE | +| TOPC_SEQ | 348012 | TOTAL PRECIPITATION/TOTAL WATER EQUIVALENT SEQUENCE | +| PREWXSEQ | 348013 | PRESENT WEATHER SEQUENCE | +| CLOUDSEQ | 348014 | OBSERVED CLOUD SEQUENCE # 1 | +| HOCT_SEQ | 348015 | HEIGHT OF TOP OF CLOUD SEQUENCE | +| TMXMNSEQ | 348016 | MAXIMUM/MINIMUM TEMPERATURE SEQUENCE | +| SWELLSEQ | 348017 | SWELL WAVE SEQUENCE | +| DBSS_SEQ | 348018 | DEPTH BELOW SEA SURFACE SEQUENCE | +| VISB1SEQ | 348019 | VISIBILITY SEQUENCE # 1 | +| VISB2SEQ | 348020 | VISIBILITY SEQUENCE # 2 | +| VTVI_SEQ | 348021 | VERTICAL VISIBILITY SEQUENCE | +| PSTWXSEQ | 348022 | PAST WEATHER SEQUENCE | +| PKWNDSEQ | 348023 | PEAK WIND SEQUENCE | +| GUST1SEQ | 348024 | MAXIMUM WIND GUST SEQUENCE # 1 | +| GUST2SEQ | 348025 | MAXIMUM WIND GUST SEQUENCE # 2 | +| TPRECSEQ | 348026 | TOTAL PRECIPITATION SEQUENCE | +| TP12_SEQ | 348027 | TOTAL PRECIPITATION PAST 12 HOURS SEQUENCE | +| SUNSHSEQ | 348028 | TOTAL SUNSHINE SEQUENCE | +| CLOU2SEQ | 348029 | OBSERVED CLOUD SEQUENCE # 2 | +| XWSPDSEQ | 348030 | EXTRAPOLATED WIND SPEED SEQUENCE | +| SWINDSEQ | 348031 | SURFACE WIND SEQUENCE | +| SNOW_SEQ | 348032 | SNOW DEPTH SEQUENCE | +| WAVE_SEQ | 348033 | WAVE SEQUENCE | +| SHIP_SEQ | 348034 | SHIP DIRECTION/SPEED SEQUENCE | +| PTENDSEQ | 348035 | PRESSURE TENDENCY SEQUENCE | +| PTE24SEQ | 348036 | 24 HOUR PRESSURE TENDENCY SEQUENCE | +| ACID_SEQ | 348037 | AIRCRAFT FLIGHT NUMBER SEQUENCE | +| AFIC_SEQ | 348038 | AIRCRAFT ICING SEQUENCE | +| TURB3SEQ | 348039 | TURBULENCE SEQUENCE # 3 | +| PRSLEVLA | 348040 | AIRCRAFT (AIRCFT/AIRCAR) PRESSURE LEVEL SEQUENCE | +| LATCORSQ | 348041 | LATITUDE CORRECTION SEQUENCE | +| LONCORSQ | 348042 | LONGITUDE CORRECTION SEQUENCE | +| CLOU3SEQ | 348043 | OBSERVED CLOUD SEQUENCE # 3 (CEILING) | +| APDS_SEQ | 348044 | ATMOSPHERIC PATH DELAY SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR SEQUENCES IN REPORT HEADER | * | -| RSRDSQ | 361012 | RESTRICTIONS ON REDISTRIBUTION SEQUENCE | +| RSRD_SEQ | 348081 | RESTRICTIONS ON REDISTRIBUTION SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR DATA "INFORMATION" SEQUENCES | * | -| PINFO | 362001 | PRESSURE INFORMATION | -| QINFO | 362002 | SPECIFIC HUMIDITY INFORMATION | -| TINFO | 362003 | TEMPERATURE INFORMATION | -| ZINFO | 362004 | HEIGHT INFORMATION | -| WINFO | 362005 | WIND INFORMATION | -| PWINFO | 362006 | PRECIPITABLE WATER INFORMATION | -| PWTINF | 362007 | TOTAL PRECIPITABLE WATER INFORMATION | -| PWLINF | 362008 | LAYER PRECIPITABLE WATER INFORMATION | -| PW1INF | 362009 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER INFORMATION | -| PW2INF | 362010 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER INFORMATION | -| PW3INF | 362011 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER INFORMATION | -| PW4INF | 362012 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER INFORMATION | -| BTINFO | 362014 | TOVS OR GOES BRIGHTNESS TEMPERATURE INFORMATION | -| SCINFO | 362015 | SCATTEROMETER DATA INFORMATION | -| DRINFO | 362016 | RADIOSONDE DRIFT INFORMATION | -| RRINFO | 362017 | RAIN RATE INFORMATION | -| CTINFO | 362018 | CLOUD TOP INFORMATION | +| P___INFO | 348141 | PRESSURE INFORMATION | +| Q___INFO | 348142 | SPECIFIC HUMIDITY INFORMATION | +| T___INFO | 348143 | TEMPERATURE INFORMATION | +| Z___INFO | 348144 | HEIGHT INFORMATION | +| W___INFO | 348145 | WIND INFORMATION | +| PW__INFO | 348146 | PRECIPITABLE WATER INFORMATION | +| PWT_INFO | 348147 | TOTAL PRECIPITABLE WATER INFORMATION | +| PWL_INFO | 348148 | LAYER PRECIPITABLE WATER INFORMATION | +| PW1_INFO | 348149 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER INFORMATION | +| PW2_INFO | 348150 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER INFORMATION | +| PW3_INFO | 348151 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER INFORMATION | +| PW4_INFO | 348152 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER INFORMATION | +| BTMPINFO | 348153 | TOVS OR GOES BRIGHTNESS TEMPERATURE INFORMATION | +| SCATINFO | 348154 | SCATTEROMETER DATA INFORMATION | +| DRFTINFO | 348155 | PROFILE LEVEL TIME/LOCATION INFORMATION | +| RRT_INFO | 348156 | RAIN RATE INFORMATION | +| CTP_INFO | 348157 | CLOUD TOP INFORMATION | +| SST_INFO | 348158 | SEA TEMPERATURE INFORMATION | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR DATA "EVENT" SEQUENCES | * | -| PEVN | 362101 | PRESSURE EVENT SEQUENCE | -| QEVN | 362102 | SPECIFIC HUMIDITY EVENT SEQUENCE | -| TEVN | 362103 | TEMPERATURE EVENT SEQUENCE | -| ZEVN | 362104 | HEIGHT EVENT SEQUENCE | -| WEVN | 362105 | WIND EVENT SEQUENCE | -| DFEVN | 362106 | WIND (DIRECTION/SPEED) EVENT SEQUENCE | -| PWTEVN | 362107 | TOTAL PRECIPITABLE WATER EVENT SEQUENCE | -| PW1EVN | 362108 | 1.0 TO 0.9 PRECIPITABLE WATER EVENT SEQUENCE | -| PW2EVN | 362109 | 0.9 TO 0.7 PRECIPITABLE WATER EVENT SEQUENCE | -| PW3EVN | 362110 | 0.7 TO 0.3 PRECIPITABLE WATER EVENT SEQUENCE | -| PW4EVN | 362111 | 0.3 TO 0.0 PRECIPITABLE WATER EVENT SEQUENCE | -| RREVN | 362112 | RATE RATE EVENT SEQUENCE | -| CTPEVN | 362113 | CLOUD TOP PRESSURE EVENT SEQUENCE | +| P__EVENT | 348171 | PRESSURE EVENT SEQUENCE | +| Q__EVENT | 348172 | SPECIFIC HUMIDITY EVENT SEQUENCE | +| T__EVENT | 348173 | TEMPERATURE EVENT SEQUENCE | +| Z__EVENT | 348174 | HEIGHT EVENT SEQUENCE | +| W__EVENT | 348175 | WIND EVENT SEQUENCE | +| PWTEVENT | 348177 | TOTAL PRECIPITABLE WATER EVENT SEQUENCE | +| PW1EVENT | 348178 | 1.0 TO 0.9 PRECIPITABLE WATER EVENT SEQUENCE | +| PW2EVENT | 348179 | 0.9 TO 0.7 PRECIPITABLE WATER EVENT SEQUENCE | +| PW3EVENT | 348180 | 0.7 TO 0.3 PRECIPITABLE WATER EVENT SEQUENCE | +| PW4EVENT | 348181 | 0.3 TO 0.0 PRECIPITABLE WATER EVENT SEQUENCE | +| RRTEVENT | 348182 | RATE RATE EVENT SEQUENCE | +| CTPEVENT | 348183 | CLOUD TOP PRESSURE EVENT SEQUENCE | +| SSTEVENT | 348184 | SEA TEMPERATURE EVENT SEQUENCE | +| W1_EVENT | 348185 | WIND {DIRECTION/SPEED(kts)} EVENT SEQUENCE | +| W2_EVENT | 348186 | WIND {DIRECTION/SPEED(m/s)} EVENT SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR DATA "BACKGROUND" SEQUENCES | * | -| PBACKG | 362201 | PRESSURE BACKGROUND SEQUENCE | -| QBACKG | 362202 | SPECIFIC HUMIDITY BACKGROUND SEQUENCE | -| TBACKG | 362203 | TEMPERATURE BACKGROUND SEQUENCE | -| ZBACKG | 362204 | HEIGHT BACKGROUND SEQUENCE | -| WBACKG | 362205 | WIND BACKGROUND SEQUENCE | -| PWTBAK | 362206 | TOTAL PRECIPITABLE WATER BACKGROUND SEQUENCE | -| PW1BAK | 362207 | 1.0 TO 0.9 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | -| PW2BAK | 362208 | 0.9 TO 0.7 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | -| PW3BAK | 362209 | 0.7 TO 0.3 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | -| PW4BAK | 362210 | 0.3 TO 0.0 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | -| RRBACKG | 362211 | RAIN RATE BACKGROUND SEQUENCE | -| CTPBAK | 362212 | CLOUD TOP PRESSURE BACKGROUND SEQUENCE | +| P__BACKG | 348191 | PRESSURE BACKGROUND SEQUENCE | +| Q__BACKG | 348192 | SPECIFIC HUMIDITY BACKGROUND SEQUENCE | +| T__BACKG | 348193 | TEMPERATURE BACKGROUND SEQUENCE | +| Z__BACKG | 348194 | HEIGHT BACKGROUND SEQUENCE | +| W__BACKG | 348195 | WIND BACKGROUND SEQUENCE | +| PWTBACKG | 348196 | TOTAL PRECIPITABLE WATER BACKGROUND SEQUENCE | +| PW1BACKG | 348197 | 1.0 TO 0.9 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | +| PW2BACKG | 348198 | 0.9 TO 0.7 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | +| PW3BACKG | 348199 | 0.7 TO 0.3 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | +| PW4BACKG | 348200 | 0.3 TO 0.0 SIGMA LAYER PRECIP WATER BACKGROUND SEQUENCE | +| RRTBACKG | 348201 | RAIN RATE BACKGROUND SEQUENCE | +| CTPBACKG | 348202 | CLOUD TOP PRESSURE BACKGROUND SEQUENCE | +| SSTBACKG | 348203 | SEA TEMPERATURE BACKGROUND SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR DATA "POSTPROCESSING" SEQUENCES | * | -| PPOSTP | 362221 | PRESSURE POSTPROCESSING SEQUENCE | -| QPOSTP | 362222 | SPECIFIC HUMIDITY POSTPROCESSING SEQUENCE | -| TPOSTP | 362223 | TEMPERATURE POSTPROCESSING SEQUENCE | -| ZPOSTP | 362224 | HEIGHT POSTPROCESSING SEQUENCE | -| WPOSTP | 362225 | WIND POSTPROCESSING SEQUENCE | -| PWTPST | 362226 | TOTAL PRECIPITABLE WATER POSTPROCESSING SEQUENCE | -| PW1PST | 362227 | 1.0 TO 0.9 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | -| PW2PST | 362228 | 0.9 TO 0.7 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | -| PW3PST | 362229 | 0.7 TO 0.3 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | -| PW4PST | 362230 | 0.3 TO 0.0 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | -| RRPOSTP | 362231 | RAIN RATE POSTPROCESSING SEQUENCE | -| CTPPST | 362232 | CLOUD TOP PRESSURE POSTPROCESSING SEQUENCE | +| P__POSTP | 348211 | PRESSURE POSTPROCESSING SEQUENCE | +| Q__POSTP | 348212 | SPECIFIC HUMIDITY POSTPROCESSING SEQUENCE | +| T__POSTP | 348213 | TEMPERATURE POSTPROCESSING SEQUENCE | +| Z__POSTP | 348214 | HEIGHT POSTPROCESSING SEQUENCE | +| W__POSTP | 348215 | WIND POSTPROCESSING SEQUENCE | +| PWTPOSTP | 348216 | TOTAL PRECIPITABLE WATER POSTPROCESSING SEQUENCE | +| PW1POSTP | 348217 | 1.0 TO 0.9 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | +| PW2POSTP | 348218 | 0.9 TO 0.7 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | +| PW3POSTP | 348219 | 0.7 TO 0.3 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | +| PW4POSTP | 348220 | 0.3 TO 0.0 SIGMA LAYER PRECIP WATER POSTPROCESSING SEQ. | +| RRTPOSTP | 348221 | RAIN RATE POSTPROCESSING SEQUENCE | +| CTPPOSTP | 348222 | CLOUD TOP PRESSURE POSTPROCESSING SEQUENCE | +| SSTPOSTP | 348223 | SEA TEMPERATURE POSTPROCESSING SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR DATA "CLIMATOLOGY" SEQUENCES | * | -| PCLIM | 362241 | PRESSURE CLIMATOLOGY SEQUENCE | -| QCLIM | 362242 | SPECIFIC HUMIDITY CLIMATOLOGY SEQUENCE | -| TCLIM | 362243 | TEMPERATURE CLIMATOLOGY SEQUENCE | -| ZCLIM | 362244 | HEIGHT CLIMATOLOGY SEQUENCE | -| WCLIM | 362245 | WIND CLIMATOLOGY SEQUENCE | +| PCLIMATO | 348231 | PRESSURE CLIMATOLOGY SEQUENCE | +| QCLIMATO | 348232 | SPECIFIC HUMIDITY CLIMATOLOGY SEQUENCE | +| TCLIMATO | 348233 | TEMPERATURE CLIMATOLOGY SEQUENCE | +| ZCLIMATO | 348234 | HEIGHT CLIMATOLOGY SEQUENCE | +| WCLIMATO | 348235 | WIND CLIMATOLOGY SEQUENCE | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR TEMPRY CURRENT MODEL GUESS SEQUENCES | * | -| PFC_MSQ | 363201 | MODEL PRESSURE FORECAST SEQUENCE | -| QFC_MSQ | 363202 | MODEL SPECIFIC HUMIDITY FORECAST SEQUENCE | -| TFC_MSQ | 363203 | MODEL TEMPERATURE FORECAST SEQUENCE | -| ZFC_MSQ | 363204 | MODEL HEIGHT FORECAST SEQUENCE | -| WFC_MSQ | 363205 | MODEL WIND FORECAST SEQUENCE | -| PWF_MSQ | 363206 | MODEL TOTAL PRECIPITABLE WATER FORECAST SEQUENCE | -| PW1F_MSQ | 363207 | MODEL 1.0 TO 0.9 SIGMA LAYER PRECIP WATER FORECAST SEQ. | -| PW2F_MSQ | 363208 | MODEL 0.9 TO 0.7 SIGMA LAYER PRECIP WATER FORECAST SEQ. | -| PW3F_MSQ | 363209 | MODEL 0.7 TO 0.3 SIGMA LAYER PRECIP WATER FORECAST SEQ. | -| PW4F_MSQ | 363210 | MODEL 0.3 TO 0.0 SIGMA LAYER PRECIP WATER FORECAST SEQ. | +| PFC__MSQ | 348241 | MODEL PRESSURE FORECAST SEQUENCE | +| QFC__MSQ | 348242 | MODEL SPECIFIC HUMIDITY FORECAST SEQUENCE | +| TFC__MSQ | 348243 | MODEL TEMPERATURE FORECAST SEQUENCE | +| ZFC__MSQ | 348244 | MODEL HEIGHT FORECAST SEQUENCE | +| WFC__MSQ | 348245 | MODEL WIND FORECAST SEQUENCE | +| PWF__MSQ | 348246 | MODEL TOTAL PRECIPITABLE WATER FORECAST SEQUENCE | +| PW1F_MSQ | 348247 | MODEL 1.0 TO 0.9 SIGMA LAYER PRECIP WATER FORECAST SEQ. | +| PW2F_MSQ | 348248 | MODEL 0.9 TO 0.7 SIGMA LAYER PRECIP WATER FORECAST SEQ. | +| PW3F_MSQ | 348249 | MODEL 0.7 TO 0.3 SIGMA LAYER PRECIP WATER FORECAST SEQ. | +| PW4F_MSQ | 348250 | MODEL 0.3 TO 0.0 SIGMA LAYER PRECIP WATER FORECAST SEQ. | * | * | * THE FOLLOWING ARE TABLE D ENTRIES FOR EVENTS CODES FOR THE VARIOUS | @@ -142,574 +184,924 @@ * THE LAST THREE DIGITS OF THE DESCRIPTOR NUMBER BECOMES THE "PROGRAM CODE" | * | | PREPRO | 363001 | INITIAL PREPBUFR PROCESSING STEP | -* | | (PREPDATA PROGRAM, PRIOR TO PREVENTS OR VTPEVN SUBR.) | +* | | (PREPDATA program, prior to PREVENTS program or VTPEVN | +* subr. in subr. GBLEVENTS) | | SYNDATA | 363002 | SYNTHETIC TROPICAL CYCLONE BOGUS PROCESSING STEP | -* | | (SYNDATA PROGRAM, PRIOR TO PREVENTS SUBROUTINE) | -| CLIMO | 363003 | CLIMO PROGRAM | -* | -| PREVENT | 363004 | PRE-EVENTS BACKGROUND/OBS. ERROR PROCESSING STEP | -* | | (PREVENTS SUBROUTINE IN PREPDATA OR SYNDATA PROGRAM; | -* | | PREVENTS PROGRAM IN CDAS NETWORK RUNS) | +* | | (SYNDATA program, prior to PREVENTS program or VTPEVN | +* subr. in subr. GBLEVENTS) | +| CLIMO | 363003 | CLIMOTOLOGICAL PROCESSING STEP | +* (not yet available) | +| PREVENT | 363004 | PRE-EVENTS BACKGROUND/OBSERVATION ERROR PROCESSING STEP | +* | | (PREVENTS program or GBLEVENTS subroutine in PREPDATA | +* or SYNDATA program) | | CQCHT | 363005 | RAWINSONDE HEIGHT/TEMP COMPLEX QUALITY CONTROL STEP | -* | | (CQCBUFR PROGRAM) | -| RADCOR | 363006 | RAWINSONDE HEIGHT/TEMP RADIATION CORRECTION STEP | -* | | (RADEVN SUBROUTINE IN CQCBUFR PROGRAM) | -| PREPACQC | 363007 | AIREP/PIREP/AMDAR/ASDAR AIRCRAFT QUALITY CONTROL STEP | -* | | (PREPACQC PROGRAM) | +* | | (CQCBUFR program) | +| RADCOR | 363006 | RAWINSONDE HEIGHT/TEMP INTERSONDE(RADIATION) CORR. STEP | +* | | (RADEVN subroutine in CQCBUFR program) | +| PREPACQC | 363007 | AIRCRAFT QUALITY CONTROL STEP (NOT INCL. MDCRS ACARS) | +* | | (obsolete PREPACQC program) | | VIRTMP | 363008 | VIRTUAL TEMPERATURE/SPECIFIC HUMIDITY PROCESSING STEP | -* | | (VTPEVN SUBROUTINE IN PREPDATA, CQCBUFR OR PREVENTS | -* | | PROGRAM; DEPENDING UPON DATA TYPE) | +* | | (PREVENTS program or VTPEVN subr. in subr. GBLEVENTS in | +* PREPDATA program for all obs. types except RAOBS/DROPS;| +* VTPEVN subr. in CQCBUFR program for RAOBS/DROPS) | | CQCPROF | 363009 | WIND PROFILER QUALITY CONTROL STEP | -* | | (PROFCQC PROGRAM) | -| OIQC | 363010 | OI-QUALITY CONTROL STEP | -* | | (OIQCBUFR PROGRAM - GLOBAL VERSION ONLY) | -| SSI | 363011 | SSI ANALYSIS STEP | -* | | (SSIANL PROGRAM - GLOBAL VERSION ONLY) | +* | | (PROFCQC program) | +| OIQC | 363010 | OI-QUALITY MULTI-PLATFROM CONTROL STEP | +* | | (OIQCBUFR program) | +| SSI | 363011 | SSI GLOBAL ANALYSIS STEP | +* | | (SSIANL program) | | CQCVAD | 363012 | VAD WIND QUALITY CONTROL STEP | -* | | (CQCVAD PROGRAM) | -| R3DVAR | 363013 | 3DVAR ANALYSIS STEP | -* | | (R3DVAR PROGRAM - ETA VERSION ONLY) | -| ACARSQC | 363014 | ACARS AIRCRAFT QUALITY CONTROL STEP | -* | | (ACARSQC PROGRAM) | +* | | (CQCVAD program) | +| R3DVAR | 363013 | 3DVAR REGIONAL ANALYSIS STEP | +* | | (R3DVAR program) | +| ACARSQC | 363014 | MDCRS ACARS AIRCRAFT QUALITY CONTROL STEP | +* | | (ACARSQC program) | +| NRLACQC | 363015 | NRL AIRCRAFT QUALITY CONTROL STEP | +* | | (PREPACQC program) | +| GSI | 363016 | GSI ANALYSIS STEP | +* | | (various GSI programs) | +| GLERL | 363017 | GLERL OBSERVATION ADJUSTMENT PROCESSING STEP | +* | | (GLERLADJ program) | +| DEFAULT | 363099 | NON-DEFINED STEP (DEFAULT) | * | * | * THE FOLLOWING ARE TABLE B ENTRIES FOR THE REPORT HEADER | * | -| SID | 001192 | STATION IDENTIFICATION | -| TYP | 001193 | PREPBUFR REPORT TYPE | -| ITP | 002001 | INSTRUMENT TYPE | +| ACID | 001006 | AIRCRAFT FLIGHT NUMBER | +| SAID | 001007 | SATELLITE IDENTIFIER (SATELLITE REPORTS ONLY) | +| SID | 001194 | STATION IDENTIFICATION | +| | | | | SIRC | 002013 | RAWINSONDE SOLAR & INFRARED RADIATION CORR. INDICATOR | -| RPT | 004194 | REPORTED OBSERVATION TIME | -| DHR | 004192 | OBSERVATION TIME MINUS CYCLE TIME | -| TCOR | 004195 | INDICATOR WHETHER OBS. TIME IN "DHR" WAS CORRECTED | -| RCT | 004193 | RECEIPT TIME | +| MSST | 002038 | METHOD OF SEA SURFACE TEMPERATURE MEASUREMENT | +| ITP | 002195 | INSTRUMENT TYPE | +| | | | +| RPT | 004214 | REPORTED OBSERVATION TIME | +| DHR | 004215 | OBSERVATION TIME MINUS CYCLE TIME | +| TCOR | 004216 | INDICATOR WHETHER OBS. TIME IN "DHR" WAS CORRECTED | +| | | | | YOB | 005002 | LATITUDE | -| XOB | 006002 | LONGITUDE | -| ELV | 010194 | STATION ELEVATION | -| SQN | 050001 | REPORT SEQUENCE NUMBER | -| PROCN | 050002 | PROCESS NUMBER FOR THIS MPI RUN (OBTAINED FROM SCRIPT) | -| T29 | 055006 | INPUT REPORT TYPE | -| TSB | 055192 | REPORT SUBTYPE (HAS VARIOUS MEANINGS DEPENDING ON TYPE) | -| ACAV | 008022 | TOTAL # W.R.T. ACCUMULATION OR AVGE (GOES SNDGS ONLY) | +| BEARAZ | 005021 | BEARING OR AZIMUTH | | ATRN | 005034 | ALONG TRACK ROW NUMBER (QUIKSCAT REPORTS ONLY) | -| CTCN | 006034 | CROSS TRACK CELL NUMBER (QUIKSCAT REPORTS ONLY) | +| | | | +| CTCN | 006034 | CROSS TRACK CELL NUMBER (QUIKSCAT & ASCAT REPORTS ONLY) | +| XOB | 006240 | LONGITUDE | +| | | | +| VSSO | 008002 | VERT. SIGNIFICANCE (SFC OBSERVATION) | +| ACAV | 008022 | TOTAL NUMBER WITH RESPECT TO ACCUMULATION OR AVERAGE | +| | | | +| IALR | 010082 | INSTANTANEOUS ALTITUDE RATE | +| ELV | 010199 | STATION ELEVATION | +| | | | | SPRR | 021120 | SEAWINDS PROBABILITY OF RAIN (QUIKSCAT REPORTS ONLY) | -| SAID | 001007 | SATELLITE IDENTIFIER (SATELLITE REPORTS ONLY) | +| | | | +| NRLQMS | 033249 | NRL AIRCRAFT QUALITY CNTRL MARK (ADDED BY PGM PREPACQC) | +| | | | | RSRD | 035200 | RESTRICTIONS ON REDISTRIBUTION | | EXPRSRD | 035201 | EXPIRATION OF RESTRICTIONS ON REDISTRIBUTION | +| | | | +| SQN | 050001 | REPORT SEQUENCE NUMBER | +| PROCN | 050003 | PROCESS NUMBER FOR THIS MPI RUN (OBTAINED FROM SCRIPT) | +| | | | +| TYP | 055007 | PREPBUFR REPORT TYPE | +| T29 | 055008 | DATA DUMP REPORT TYPE | +| TSB | 055009 | REPORT SUBTYPE (HAS VARIOUS MEANINGS DEPENDING ON TYPE) | +| | | | +| PRVSTG | 058009 | MESONET PROVIDER ID STRING | +| SPRVSTG | 058010 | MESONET SUBPROVIDER ID STRING | * | * | * THE FOLLOWING ARE TABLE B ENTRIES FOR THE REPORT LEVEL DATA | * | -| CAT | 001194 | PREPBUFR DATA LEVEL CATEGORY | +| TDMP | 001193 | TRUE DIRECTION OF SHIP DURING PAST 3 HOURS | +| ASMP | 001200 | AVG SPD OF SHIP DURING PAST 3 HOURS | | | | | | PCAT | 002005 | PRECISION OF TEMPERATURE OBSERVATION | +| ROLF | 002199 | AIRCRAFT ROLL ANGLE FLAG | +| AFIC | 020041 | AIRFRAME ICING | +| HBOI | 020194 | HEIGHT OF BASE OF ICING | +| HTOI | 020195 | HEIGHT OF TOP OF ICING | | | | | -| POB | 007192 | PRESSURE OBSERVATION | -| PQM | 007193 | PRESSURE (QUALITY) MARKER | -| PPC | 007194 | PRESSURE PROGRAM CODE | -| PRC | 007195 | PRESSURE REASON CODE | -| PFC | 007196 | PRESSURE FORECAST VALUE | -| POE | 007197 | PRESSURE OBSERVATION ERROR | -| PAN | 007198 | PRESSURE ANALYZED VALUE | -| PCL | 007199 | PRESSURE CLIMATOLOGY | -| PCS | 007200 | PRESSURE CLIMATOLOGY STANDARD DEVIATION | +| .DTH.... | 004031 | DURATION OF TIME IN HOURS RELATED TO FOLLOWING VALUE | +| .DTM.... | 004032 | DURATION OF TIME IN MINS RELATED TO FOLLOWING VALUE | +| RCT | 004217 | RECEIPT TIME | +| HRDR | 004218 | PROFILE LVL TIME-CYCLE (FOR RAOB/PIBAL, BASED ON B DFT) | +| | | | +| CHNM | 005042 | CHANNEL NUMBER | +| YORG | 005214 | REPORTED (ORIGINAL) LATITUDE | +| YCOR | 005216 | INDICATOR WHETHER LAT IN "YOB" WAS CORRECTED FRM "YORG" | +| YDR | 005241 | PROFILE LEVEL LAT (FOR RAOB/PIBAL BASED ON BALLOON DFT) | +| | | | +| XORG | 006214 | REPORTED (ORIGINAL) LONGITUDE | +| XCOR | 006216 | INDICATOR WHETHER LON IN "XOB" WAS CORRECTED FRM "XORG" | +| XDR | 006241 | PROFILE LEVEL LON (FOR RAOB/PIBAL BASED ON BALLOON DFT) | +| | | | +| ELEV | 007021 | SATELLITE ELEVATION (ZENITH ANGLE) | +| SOEL | 007022 | SOLAR ELEVATION (ZENITH ANGLE) | +| SAZA | 007024 | SATELLITE ZENITH ANGLE | +| DBSS | 007062 | DEPTH BELOW SEA SURFACE | +| POB | 007245 | PRESSURE OBSERVATION | +| PQM | 007246 | PRESSURE (QUALITY) MARKER | +| PPC | 007247 | PRESSURE EVENT PROGRAM CODE | +| PRC | 007248 | PRESSURE EVENT REASON CODE | +| PFC | 007249 | FORECAST (BACKGROUND) PRESSURE VALUE | +| POE | 007250 | PRESSURE OBSERVATION ERROR | +| PAN | 007251 | ANALYZED PRESSURE VALUE | +| PCL | 007252 | CLIMATOLOGICAL PRESSURE VALUE | +| PCS | 007253 | STANDARD DEVIATION OF CLIMATOLOGICAL PRESSURE VALUE | +| POETU | 007254 | ANALYSIS-TUNED PRESSURE OBSERVATION ERROR | | | | | | POAF | 008004 | PHASE OF AIRCRAFT FLIGHT | +| CAT | 008193 | PREPBUFR DATA LEVEL CATEGORY | +| .RE.... | 008201 | RELATIONSHIP TO THE FOLLOWING VALUE | | | | | +| ZOB | 010007 | HEIGHT OBSERVATION | | ALSE | 010052 | ALTIMETER SETTING OBSERVATION | -| PMO | 010192 | MEAN SEA-LEVEL PRESSURE OBSERVATION | -| PMQ | 010193 | MEAN SEA-LVL PRESSURE (QUALITY) MARKER | +| 3HPC | 010061 | 3 HOUR PRESSURE CHANGE | +| 24PC | 010062 | 24 HOUR PRESSURE CHANGE | +| CHPT | 010063 | CHARACTERISTIC OF PRESSURE TENDENCY | | PRSS | 010195 | SURFACE PRESSURE OBSERVATION | -| ZOB | 010196 | HEIGHT OBSERVATION | -| ZQM | 010197 | HEIGHT (QUALITY) MARKER | -| ZPC | 010198 | HEIGHT PROGRAM CODE | -| ZRC | 010199 | HEIGHT REASON CODE | -| ZFC | 010200 | HEIGHT FORECAST VALUE | -| ZAN | 010201 | HEIGHT ANALYZED VALUE | -| ZOE | 010202 | HEIGHT OBSERVATION ERROR | -| ZCL | 010203 | HEIGHT CLIMATOLOGY | -| ZCS | 010204 | HEIGHT CLIMATOLOGY STANDARD DEVIATION | +| PMO | 010243 | MEAN SEA-LEVEL PRESSURE OBSERVATION | +| PMQ | 010244 | MEAN SEA-LEVEL PRESSURE (QUALITY) MARKER | +| PMIN | 010245 | MEAN SEA-LEVEL PRESSURE INDICATOR | +| ZQM | 010246 | HEIGHT (QUALITY) MARKER | +| ZPC | 010247 | HEIGHT EVENT PROGRAM CODE | +| ZRC | 010248 | HEIGHT EVENT REASON CODE | +| ZFC | 010249 | FORECAST (BACKGROUND) HEIGHT VALUE | +| ZOE | 010250 | HEIGHT OBSERVATION ERROR | +| ZAN | 010251 | ANALYZED HEIGHT VALUE | +| ZCL | 010252 | CLIMATOLOGICAL HEIGHT VALUE | +| ZCS | 010253 | STANDARD DEVIATION OF CLIMATOLOGICAL HEIGHT VALUE | | | | | +| DDO | 011001 | WIND DIRECTION OBSERVATION (NOT ASSIMILATED) | +* | | (stored for all reports, currently used only by | +* | | "NRLACQC" step for aircraft reports, but will some | +* | | day be used by analysis for surface reports) | +| SOB | 011002 | WIND SPEED OBSERVATION (m/s) (NOT ASSIMILATED) | +* | | (stored only for surface reports, will some day be | +* | | used by analysis) | | UOB | 011003 | U-COMPONENT WIND OBSERVATION | | VOB | 011004 | V-COMPONENT WIND OBSERVATION | -| WQM | 011192 | WIND (QUALITY) MARKER | -| WPC | 011193 | WIND PROGRAM CODE | -| WRC | 011194 | WIND REASON CODE | -| UFC | 011195 | U-COMPONENT FORECAST VALUE | -| VFC | 011196 | V-COMPONENT FORECAST VALUE | -| UAN | 011197 | U-COMPONENT ANALYZED VALUE | -| VAN | 011198 | V-COMPONENT ANALYZED VALUE | -| WOE | 011199 | WIND OBSERVATION ERROR | -| UCL | 011200 | U-COMPONENT CLIMATOLOGY | -| VCL | 011201 | V-COMPONENT CLIMATOLOGY | -| UCS | 011202 | U-COMPONENT CLIMATOLOGY STANDARD DEVIATION | -| VCS | 011203 | V-COMPONENT CLIMATOLOGY STANDARD DEVIATION | -| | | | -| DDO | 011001 | WIND DIRECTION OBSERVATION (NOT ASSIMILATED) | -* | | (AFTER "PREPACQC" STEP ONLY - SUBSEQUENT CODES DO NOT | -* | | PROCESS) | -| SOB | 011002 | WIND SPEED OBSERVATION | -* | | (STORED WHEN DIRECTION IS MISSING; E.G. METARS) | -| FFO | 011191 | WIND SPEED OBSERVATION (NOT ASSIMILATED) | -* | | (AFTER "PREPACQC" STEP ONLY - SUBSEQUENT CODES DO NOT | -* | | PROCESS) | -| DFQ | 011204 | WIND (DIRECTION/SPEED) (QUALITY) MARKER | -| DFP | 011205 | WIND (DIRECTION/SPEED) PROGRAM CODE | -| DFR | 011206 | WIND (DIRECTION/SPEED) REASON CODE | -| | | | -| SQM | 011209 | WIND SPEED (QUALITY) MARKER | -* | | (STORED WHEN DIRECTION IS MISSING; E.G. METARS) | -| | | | | DGOT | 011031 | DEGREE OF TURBULENCE | +| HBOT | 011032 | HEIGHT OF BASE OF TURBULENCE | +| HTOT | 011033 | HEIGHT OF TOP OF TURBULENCE | +| MXGS | 011041 | MAXIMUM WIND SPEED (GUSTS) | +| MXGD | 011043 | MAXIMUM WIND GUST DIRECTION | +| MWD10 | 011081 | MODEL WIND DIRECTION AT 10 M | +| MWS10 | 011082 | MODEL WIND SPEED AT 10 M | +| WDIR1 | 011200 | SURFACE WIND DIRECTION | +| WSPD1 | 011201 | SURFACE WIND SPEED | +| PKWDDR | 011202 | PEAK WIND DIRECTION | +| PKWDSP | 011203 | PEAK WIND SPEED | +| DFQ | 011218 | WIND DIRECTION(DDO)/SPEED(FFO or SOB) (QUALITY) MARKER | +| DFP | 011219 | WIND DIRECTION(DDO)/SPEED(FFO or SOB) EVENT PGM CODE | +| DFR | 011220 | WIND DIRECTION(DDO)/SPEED(FFO or SOB) EVENT REASON CODE | +| XS10 | 011223 | 10 METER EXTRAPOLATED WIND SPEED | +| XS20 | 011224 | 20 METER EXTRAPOLATED WIND SPEED | +| RF10M | 011225 | 10 METER WIND REDUCTION FACTOR | +| TRBX | 011235 | TURBULENCE INDEX | | TRBX10 | 011236 | TURBULENCE INDEX FOR PERIOD (TOB-1 MIN) -> TOB | | TRBX21 | 011237 | TURBULENCE INDEX FOR PERIOD (TOB-2 MIN) -> (TOB-1 MIN) | | TRBX32 | 011238 | TURBULENCE INDEX FOR PERIOD (TOB-3 MIN) -> (TOB-2 MIN) | | TRBX43 | 011239 | TURBULENCE INDEX FOR PERIOD (TOB-4 MIN) -> (TOB-3 MIN) | +| WQM | 011240 | U-, V-COMPONENT WIND (UOB/VOB) (QUALITY) MARKER | +| WPC | 011241 | U-, V-COMPONENT WIND (UOB/VOB) EVENT PROGRAM CODE | +| WRC | 011242 | U-, V-COMPONENT WIND (UOB/VOB) EVENT REASON CODE | +| UFC | 011243 | FORECAST (BACKGROUND) U-COMPONENT WIND VALUE | +| VFC | 011244 | FORECAST (BACKGROUND) V-COMPONENT WIND VALUE | +| WOE | 011245 | U-, V-COMPONENT WIND (UOB/VOB) OBSERVATION ERROR | +| UAN | 011246 | ANALYZED U-COMPONENT WIND VALUE | +| VAN | 011247 | ANALYZED V-COMPONENT WIND VALUE | +| UCL | 011248 | CLIMATOLOGICAL U-COMPONENT WIND VALUE | +| VCL | 011249 | CLIMATOLOGICAL V-COMPONENT WIND VALUE | +| UCS | 011250 | STANDARD DEVIATION OF CLIMATOLOGICAL U-COMP WIND VALUE | +| VCS | 011251 | STANDARD DEVIATION OF CLIMATOLOGICAL V-COMP WIND VALUE | +| FFO | 011252 | WIND SPEED OBSERVATION (kts) (NOT ASSIMILATED) | +* | | (stored only for all non-surface reports, currently | +* | | used only by "NRLACQC" step for aircraft reports) | +| WOETU | 011253 | ANALYSIS-TUNED WIND OBSERVATION ERROR | | | | | -| TOB | 012192 | TEMPERATURE OBSERVATION | -* | | (AFTER "PREPRO" STEP - REPORTED TEMP, EITHER SENSIBLE | -* | | OR VIRTUAL DEPENDING UPON DATA TYPE; | -* | | AFTER "VIRTMP" STEP - VIRTUAL TEMPERATURE IF MOISTURE | -* | | AVAILABLE, OTHERWISE SENSIBLE) | -| TQM | 012195 | TEMPERATURE (QUALITY) MARKER | -| TPC | 012196 | TEMPERATURE PROGRAM CODE | -| TRC | 012197 | TEMPERATURE REASON CODE | -| TFC | 012198 | TEMPERATURE FORECAST VALUE | -| TAN | 012199 | TEMPERATURE ANALYZED VALUE | -| TOE | 012200 | TEMPERATURE OBSERVATION ERROR | -| TCL | 012201 | TEMPERATURE CLIMATOLOGY | -| TCS | 012202 | TEMPERATURE CLIMATOLOGY STANDARD DEVIATION | -| | | | -| TDO | 012194 | DEWPOINT TEMPERATURE OBSERVATION (NOT ASSIMILATED) | -* | | (AFTER "VIRTMP" STEP ONLY - SUBSEQUENT CODES DO NOT | -* | | PROCESS) | -| TVO | 012193 | NON-Q. CONTROLLED VIRTUAL TEMP OBS (NOT ASSIMILATED) | -* | | (AFTER "PREPRO" STEP ONLY - SUBSEQUENT CODES DO NOT | -* | | PROCESS) | +| MXTM | 012111 | MAXIMUM TEMPERATURE | +| MITM | 012112 | MINIMUM TEMPERATURE | +| TMSK | 012161 | SKIN TEMPERATURE | +| TMBR | 012163 | BRIGHTNESS TEMPERATURE | | GCDTT | 012210 | GOES CLOUD TOP TEMPERATURE OBSERVATION | +| TVO | 012243 | NON-Q. CONTROLLED VIRTUAL TEMP OBS (NOT ASSIMILATED) | +* | | (currently not used by any steps beyond "PREPRO") | +| TDO | 012244 | DEWPOINT TEMPERATURE OBSERVATION (NOT ASSIMILATED) | +* | | (used only by "VIRTMP" step) | +| TOB | 012245 | TEMPERATURE OBSERVATION | +* | | {after "PREPRO" step: reported T, either Ts or Tv | +* | | depending upon data type; after "VIRTMP" step: Tv if | +* | | moisture available and T after "PREPRO" step is Ts | +* | | (except for aircraft), otherwise as defined after | +* | | "PREPRO" step} | +| TQM | 012246 | TEMPERATURE (QUALITY) MARKER | +| TPC | 012247 | TEMPERATURE EVENT PROGRAM CODE | +| TRC | 012248 | TEMPERATURE EVENT REASON CODE | +| TFC | 012249 | FORECAST (BACKGROUND) TEMPERATURE VALUE | +| TOE | 012250 | TEMPERATURE OBSERVATION ERROR | +| TAN | 012251 | ANALYZED TEMPERATURE VALUE | +| TCL | 012252 | CLIMATOLOGICAL TEMPERATURE VALUE | +| TCS | 012253 | STANDARD DEVIATION OF CLIMATOLOGICAL TEMPERATURE VALUE | +| TOETU | 012254 | ANALYSIS-TUNED TEMPERATURE OBSERVATION ERROR | | | | | -| QOB | 013192 | SPECIFIC HUMIDITY OBSERVATION | -* | | (AFTER "VIRTMP" STEP - ALWAYS RECALCULATED FROM QUALITY | -* | | CONTROLLED VIRTUAL TEMPERATURE DATA) | -| QQM | 013193 | SPECIFIC HUMIDITY (QUALITY) MARKER | -| QPC | 013194 | SPECIFIC HUMIDITY PROGRAM CODE | -| QRC | 013195 | SPECIFIC HUMIDITY REASON CODE | -| QFC | 013196 | SPECIFIC HUMIDITY FORECAST VALUE | -| QAN | 013197 | SPECIFIC HUMIDITY ANALYZED VALUE | -| QOE | 013198 | RELATIVE HUMIDITY OBSERVATION ERROR | -| QCL | 013199 | SPECIFIC HUMIDITY CLIMATOLOGY | -| QCS | 013200 | SPECIFIC HUMIDITY CLIMATOLOGY STANDARD DEVIATION | -| | | | -| REQ6 | 013206 | RAINFALL/WATER EQUIVALENT OF SNOW (AVERAGE RATE) | -| REQ6_QM | 013207 | RAINFALL (AVERAGE RATE) (QUALITY) MARKER | -| REQ6_PC | 013208 | RAINFALL (AVERAGE RATE) PROGRAM CODE | -| REQ6_RC | 013209 | RAINFALL (AVERAGE RATE) REASON CODE | -| REQ6_FC | 013210 | RAINFALL (AVERAGE RATE) FORECAST VALUE | -| REQ6_AN | 013211 | RAINFALL (AVERAGE RATE) ANALYZED VALUE | -| REQ6_OE | 013212 | RAINFALL (AVERAGE RATE) OBSERVATION ERROR | -| | | | -| PWO | 013213 | TOTAL PRECIPITABLE WATER OBSERVATION | -| PWQ | 013214 | TOTAL PRECIPITABLE WATER (QUALITY) MARKER | -| PWP | 013215 | TOTAL PRECIPITABLE WATER PROGRAM CODE | -| PWR | 013216 | TOTAL PRECIPITABLE WATER REASON CODE | -| PWF | 013217 | TOTAL PRECIPITABLE WATER FORECAST VALUE | -| PWA | 013218 | TOTAL PRECIPITABLE WATER ANALYZED VALUE | -| PWE | 013219 | TOTAL PRECIPITABLE WATER OBSERVATION ERROR | -| PW1O | 013220 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | -| PW1Q | 013221 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER MARKER | -| PW1P | 013222 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER PROGRAM CODE | -| PW1R | 013223 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER REASON CODE | -| PW1F | 013224 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER FORECAST VAL | -| PW1A | 013225 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER ANALYZED VAL | -| PW1E | 013226 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER OBS. ERROR | -| PW2O | 013227 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | -| PW2Q | 013228 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER MARKER | -| PW2P | 013229 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER PROGRAM CODE | -| PW2R | 013230 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER REASON CODE | -| PW2F | 013231 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER FORECAST VAL | -| PW2A | 013232 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER ANALYZED VAL | -| PW2E | 013233 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER OBS. ERROR | -| PW3O | 013234 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | -| PW3Q | 013235 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER MARKER | -| PW3P | 013236 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER PROGRAM CODE | -| PW3R | 013237 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER REASON CODE | -| PW3F | 013238 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER FORECAST VAL | -| PW3A | 013239 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER ANALYZED VAL | -| PW3E | 013240 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER OBS. ERROR | -| PW4O | 013241 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | -| PW4Q | 013242 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER MARKER | -| PW4P | 013243 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER PROGRAM CODE | -| PW4R | 013244 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER REASON CODE | -| PW4F | 013245 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER FORECAST VAL | -| PW4A | 013246 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER ANALYZED VAL | -| PW4E | 013247 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER OBS. ERROR | -| | | | -| TOCC | 020010 | CLOUD COVER (TOTAL) | -| CDTP | 020016 | CLOUD TOP PRESSURE OBSERVATION | -| CDTP_QM | 020207 | CLOUD TOP PRESSURE (QUALITY) MARKER | -| CDTP_PC | 020208 | CLOUD TOP PRESSURE PROGRAM CODE | -| CDTP_RC | 020209 | CLOUD TOP PRESSURE REASON CODE | -| CDTP_FC | 020210 | CLOUD TOP PRESSURE FORECAST VALUE | -| CDTP_AN | 020211 | CLOUD TOP PRESSURE ANALYZED VALUE | -| CDTP_OE | 020212 | CLOUD TOP PRESSURE OBSERVATION ERROR | +| TOPC | 013011 | TOTAL PRECIPITATION/TOTAL WATER EQUIVALENT | +| DOFS | 013012 | DEPTH OF FRESH SNOW | +| TOSD | 013013 | TOTAL SNOW DEPTH | +| REQV | 013014 | RAINFALL (AVERAGE RATE) OBSERVATION | +| TP01 | 013019 | TOTAL PRECIPITATION PAST 1 HOUR | +| TP03 | 013020 | TOTAL PRECIPITATION PAST 3 HOURS | +| TP06 | 013021 | TOTAL PRECIPITATION PAST 6 HOURS | +| TP12 | 013022 | TOTAL PRECIPITATION PAST 12 HOURS | +| TP24 | 013023 | TOTAL PRECIPITATION PAST 24 HOURS | +| MRWVC | 013096 | MWR WATER VAPOR CONTENT (TOTAL WATER VAPOR) | +| MRLWC | 013097 | MWR LIQUID WATER CONTENT (TOTAL CLOUD LIQUID WATER) | +| PWO | 013193 | TOTAL PRECIPITABLE WATER OBSERVATION | +| PW1O | 013202 | 1.0 TO 0.9 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | +| PW2O | 013203 | 0.9 TO 0.7 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | +| PW3O | 013204 | 0.7 TO 0.3 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | +| QOB | 013245 | SPECIFIC HUMIDITY OBSERVATION | +* | | (after "VIRTMP" step: always recalculated from QC'd Tv) | +| ESBAK | 013242 | FORECAST(BACKGROUND) SATURATION SPECIFIC HUMIDITY VALUE | +| QQM | 013246 | SPECIFIC HUMIDITY (QUALITY) MARKER | +| QPC | 013247 | SPECIFIC HUMIDITY EVENT PROGRAM CODE | +| QRC | 013248 | SPECIFIC HUMIDITY EVENT REASON CODE | +| QFC | 013249 | FORECAST (BACKGROUND) SPECIFIC HUMIDITY VALUE | +| QOE | 013250 | RELATIVE HUMIDITY OBSERVATION ERROR | +| QAN | 013251 | ANALYZED SPECIFIC HUMIDITY VALUE | +| QCL | 013252 | CLIMATOLOGICAL SPECIFIC HUMIDITY VALUE | +| QCS | 013253 | STANDARD DEV OF CLIMATOLOGICAL SPECIFIC HUMIDITY VALUE | +| QOETU | 013254 | ANALYSIS-TUNED RELATIVE HUMIDITY OBSERVATION ERROR | | | | | -| RFFL | 025202 | NESDIS RECURSIVE FILTER FLAG | +| TOSS | 014031 | TOTAL SUNSHINE | | | | | -| ELEV | 007021 | SATELLITE ELEVATION (ZENITH ANGLE) | -| SOEL | 007022 | SOLAR ELEVATION (ZENITH ANGLE) | | OZON | 015001 | OZONE | -| TMSK | 012061 | SKIN TEMPERATURE | -| CLAM | 020011 | CLOUD AMOUNT | -| CHNM | 005042 | CHANNEL NUMBER | -| TMBR | 012063 | BRIGHTNESS TEMPERATURE | +| APDS | 015031 | ATMOSPHERIC PATH DELAY IN SATELLITE SIGNAL | +| APDE | 015032 | ESTIMATED ERROR IN ATMOSPHERIC PATH DELAY | | | | | -| A1 | 048001 | ERS INCIDENT ANGLE #1 | -| A2 | 048002 | ERS INCIDENT ANGLE #2 | -| A3 | 048003 | ERS INCIDENT ANGLE #3 | +| HOVI | 020001 | HORIZONTAL VISIBILITY | +| VTVI | 020002 | VERTICAL VISIBILITY | +| PRWE | 020003 | PRESENT WEATHER | +| PSW1 | 020004 | PAST WEATHER (1) | +| PSW2 | 020005 | PAST WEATHER (2) | +| TOCC | 020010 | CLOUD COVER (TOTAL) | +| CLAM | 020011 | CLOUD AMOUNT | +| CLTP | 020012 | CLOUD TYPE | +| HOCB | 020013 | HEIGHT OF BASE OF CLOUD | +| HOCT | 020014 | HEIGHT OF TOP OF CLOUD | +| CDTP | 020016 | CLOUD TOP PRESSURE OBSERVATION | +| HBLCS | 020201 | HEIGHT ABOVE SURFACE OF BASE OF LOWEST CLOUD SEEN | +| CEILING | 020204 | CLOUD CEILING (DERIVATIVE OF HOCB - HGT OF CLOUD BASE) | +| WSST | 020219 | WINDSAT SURFACE TYPE | +| CTPQM | 020246 | CLOUD TOP PRESSURE (QUALITY) MARKER | +| CTPPC | 020247 | CLOUD TOP PRESSURE EVENT PROGRAM CODE | +| CTPRC | 020248 | CLOUD TOP PRESSURE EVENT REASON CODE | +| CTPFC | 020249 | FORECAST (BACKGROUND) CLOUD TOP PRESSURE VALUE | +| CTPOE | 020250 | CLOUD TOP PRESSURE OBSERVATION ERROR | +| CTPAN | 020251 | ANALYZED CLOUD TOP PRESSURE VALUE | | | | | -| B1 | 048004 | ERS AZIMUTH ANGLE #1 | -| B2 | 048005 | ERS AZIMUTH ANGLE #2 | -| B3 | 048006 | ERS AZIMUTH ANGLE #3 | +| LKCS | 021104 | LIKELIHOOD COMPUTED FOR SOLUTION (ASCAT REPORTS ONLY) | +| WVCQ | 021155 | WIND VECTOR CELL QUALITY (ASCAT REPORTS ONLY) | +| BSCD | 021156 | BACKSCATTER DISTANCE (ASCAT REPORTS ONLY) | +| A1 | 021226 | ERS INCIDENT ANGLE NUMBER 1 | +| A2 | 021227 | ERS INCIDENT ANGLE NUMBER 2 | +| A3 | 021228 | ERS INCIDENT ANGLE NUMBER 3 | +| B1 | 021231 | ERS AZIMUTH ANGLE NUMBER 1 | +| B2 | 021232 | ERS AZIMUTH ANGLE NUMBER 2 | +| B3 | 021233 | ERS AZIMUTH ANGLE NUMBER 3 | +| S1 | 021236 | ERS BACKSCATTER NUMBER 1 | +| S2 | 021237 | ERS BACKSCATTER NUMBER 2 | +| S3 | 021238 | ERS BACKSCATTER NUMBER 3 | +| E1 | 021241 | ERS ERROR ESTIMATE NUMBER 1 | +| E2 | 021242 | ERS ERROR ESTIMATE NUMBER 2 | +| E3 | 021243 | ERS ERROR ESTIMATE NUMBER 3 | | | | | -| S1 | 048007 | ERS BACKSCATTER #1 | -| S2 | 048008 | ERS BACKSCATTER #2 | -| S3 | 048009 | ERS BACKSCATTER #3 | +| DOSW | 022003 | DIRECTION OF SWELL WAVES | +| POWV | 022011 | PERIOD OF WAVES | +| POWW | 022012 | PERIOD OF WIND WAVES | +| POSW | 022013 | PERIOD OF SWELL WAVES | +| HOWV | 022021 | HEIGHT OF WAVES | +| HOWW | 022022 | HEIGHT OF WIND WAVES | +| HOSW | 022023 | HEIGHT OF SWELL WAVES | +| SST1 | 022043 | SEA TEMPERATURE | +| SSTQM | 022246 | SEA TEMPERATURE (QUALITY) MARKER | +| SSTPC | 022247 | SEA TEMPERATURE EVENT PROGRAM CODE | +| SSTRC | 022248 | SEA TEMPERATURE EVENT REASON CODE | +| SSTFC | 022249 | FORECAST (BACKGROUND) SEA TEMPERATURE VALUE | +| SSTOE | 022250 | SEA TEMPERATURE OBSERVATION ERROR | +| SSTAN | 022251 | ANALYZED SEA TEMPERATURE VALUE | | | | | -| E1 | 048010 | ERS ERROR ESTIMATE #1 | -| E2 | 048011 | ERS ERROR ESTIMATE #2 | -| E3 | 048012 | ERS ERROR ESTIMATE #3 | +| MSTQ | 033026 | MOISTURE QUALITY | +| RFFL | 033196 | PERCENT CONFIDENCE BASED ON NESDIS RECURSIVE FILTER FCN | +| QIFY | 033197 | PERCENT CONFIDENCE BASED ON EUMETSAT QUAL INDX W/ FCST | +| QIFN | 033198 | PERCENT CONFIDENCE BASED ON EUMETSAT QUAL INDX W/O FCST | +| CHSQ | 033199 | CHI-SQUARED (OF THE WIND VECTOR RETRIEVAL) | +| WSEQC1 | 033200 | WINDSAT EDR QC FLAG #1 | +| PHER | 033201 | EST. ERROR COVARIANCE FOR WIND DIRECTION RETRIEVAL | +| EEQF | 033203 | PERCENT CONFIDENCE BASED ON NESDIS EXPECTED ERROR | +| PVWTG | 033204 | ANAL VARIATIONAL QC WEIGHT ON PRESS. OBS BASED ON GUESS | +| PVWTA | 033205 | ANAL VARIATIONAL QC WEIGHT ON PRESS. OBS BASED ON ANAL | +| TVWTG | 033206 | ANAL VARIATIONAL QC WEIGHT ON TEMP. OBS BASED ON GUESS | +| TVWTA | 033209 | ANAL VARIATIONAL QC WEIGHT ON TEMP. OBS BASED ON ANAL | +| QVWTG | 033210 | ANAL VARIATIONAL QC WEIGHT ON MOIST. OBS BASED ON GUESS | +| QVWTA | 033211 | ANAL VARIATIONAL QC WEIGHT ON MOIST. OBS BASED ON ANAL | +| WVWTG | 033212 | ANAL VARIATIONAL QC WEIGHT ON WIND OBS BASED ON GUESS | +| WVWTA | 033213 | ANAL VARIATIONAL QC WEIGHT ON WIND OBS BASED ON ANAL | +| PWTVWTG | 033214 | ANAL VARIAT. QC WGHT ON TOT PREC. WTR OBS BASED ON GESS | +| PWTVWTA | 033228 | ANAL VARIAT. QC WGHT ON TOT PREC. WTR OBS BASED ON ANAL | +| SSTE | 033245 | EST. ERROR COVARIANCE FOR SEA SURFACE TEMP RETRIEVAL | +| SPDE | 033246 | EST. ERROR COVARIANCE FOR WIND SPEED RETRIEVAL | +| VPRE | 033247 | EST. ERROR COVARIANCE FOR TOTAL WATER VAPOR RETRIEVAL | +| CLDE | 033248 | EST. ERROR COVARIANCE FOR TOTAL CLD LIQUID WATER RETR. | | | | | -| HRDR | 004202 | RADIOSONDE BALLOON DRIFT TIME MINUS CYCLE TIME | -| YDR | 005202 | RADIOSONDE BALLOON DRIFT LATITUDE | -| XDR | 006202 | RADIOSONDE BALLOON DRIFT LONGITUDE | +| RRTQM | 051001 | RAINFALL (AVERAGE RATE) (QUALITY) MARKER | +| RRTPC | 051002 | RAINFALL (AVERAGE RATE) EVENT PROGRAM CODE | +| RRTRC | 051003 | RAINFALL (AVERAGE RATE) EVENT REASON CODE | +| RRTFC | 051004 | FORECAST (BACKGROUND) RAINFALL (AVERAGE RATE) VALUE | +| RRTOE | 051005 | RAINFALL (AVERAGE RATE) OBSERVATION ERROR | +| RRTAN | 051006 | ANALYZED RAINFALL (AVERAGE RATE) VALUE | +| PWQ | 051021 | TOTAL PRECIPITABLE WATER (QUALITY) MARKER | +| PWP | 051022 | TOTAL PRECIPITABLE WATER EVENT PROGRAM CODE | +| PWR | 051023 | TOTAL PRECIPITABLE WATER EVENT REASON CODE | +| PWF | 051024 | FORECAST (BACKGROUND) TOTAL PRECIPITABLE WATER VALUE | +| PWE | 051025 | TOTAL PRECIPITABLE WATER OBSERVATION ERROR | +| PWA | 051026 | ANALYZED TOTAL PRECIPITABLE WATER VALUE | +| PWETU | 051027 | ANALYSIS-TUNED TOTAL PRECIPITABLE WATER OBS ERROR | +| PW1Q | 051032 | 1.0 TO 0.9 SIGMA LAYER PRECIP. WATER (QUALITY) MARKER | +| PW1P | 051033 | 1.0 TO 0.9 SIGMA LAYER PRECIP. WATER EVENT PROGRAM CODE | +| PW1R | 051034 | 1.0 TO 0.9 SIGMA LAYER PRECIP. WATER EVENT REASON CODE | +| PW1F | 051035 | FCST(BACKGRND) 1.0 TO 0.9 SIGMA LYR PRECIP. WATER VALUE | +| PW1E | 051036 | 1.0 TO 0.9 SIGMA LAYER PRECIP. WATER OBSERVATION ERROR | +| PW1A | 051037 | ANALYZED 1.0 TO 0.9 SIGMA LAYER PRECIP. WATER VALUE | +| PW2Q | 051042 | 0.9 TO 0.7 SIGMA LAYER PRECIP. WATER (QUALITY) MARKER | +| PW2P | 051043 | 0.9 TO 0.7 SIGMA LAYER PRECIP. WATER EVENT PROGRAM CODE | +| PW2R | 051044 | 0.9 TO 0.7 SIGMA LAYER PRECIP. WATER EVENT REASON CODE | +| PW2F | 051045 | FCST(BACKGRND) 0.9 TO 0.7 SIGMA LYR PRECIP. WATER VALUE | +| PW2E | 051046 | 0.9 TO 0.7 SIGMA LAYER PRECIP. WATER OBSERVATION ERROR | +| PW2A | 051047 | ANALYZED 0.9 TO 0.7 SIGMA LAYER PRECIP. WATER VALUE | +| PW3Q | 051052 | 0.7 TO 0.3 SIGMA LAYER PRECIP. WATER (QUALITY) MARKER | +| PW3P | 051053 | 0.7 TO 0.3 SIGMA LAYER PRECIP. WATER EVENT PROGRAM CODE | +| PW3R | 051054 | 0.7 TO 0.3 SIGMA LAYER PRECIP. WATER EVENT REASON CODE | +| PW3F | 051055 | FCST(BACKGRND) 0.7 TO 0.3 SIGMA LYR PRECIP. WATER VALUE | +| PW3E | 051056 | 0.7 TO 0.3 SIGMA LAYER PRECIP. WATER OBSERVATION ERROR | +| PW3A | 051057 | ANALYZED 0.7 TO 0.3 SIGMA LAYER PRECIP. WATER VALUE | +| PW4O | 051061 | 0.3 TO 0.0 SIGMA LAYER PRECIPITABLE WATER OBSERVATION | +| PW4Q | 051062 | 0.3 TO 0.0 SIGMA LAYER PRECIP. WATER (QUALITY) MARKER | +| PW4P | 051063 | 0.3 TO 0.0 SIGMA LAYER PRECIP. WATER EVENT PROGRAM CODE | +| PW4R | 051064 | 0.3 TO 0.0 SIGMA LAYER PRECIP. WATER EVENT REASON CODE | +| PW4F | 051065 | FCST(BACKGRND) 0.3 TO 0.0 SIGMA LYR PRECIP. WATER VALUE | +| PW4E | 051066 | 0.3 TO 0.0 SIGMA LAYER PRECIP. WATER OBSERVATION ERROR | +| PW4A | 051067 | ANALYZED 0.3 TO 0.0 SIGMA LAYER PRECIP. WATER VALUE | | | | | * The following are added temporarily until PFC, ZFC, etc. contain current | * model guess instead of Global guess (applies for all models except Global) | | | | | -| PFC_MOD | 007201 | MODEL PRESSURE FORECAST VALUE (GLOBAL MODEL SEE PFC) | -| ZFC_MOD | 010205 | MODEL HEIGHT FORECAST VALUE (GLOBAL MODEL SEE ZFC) | -| UFC_MOD | 011207 | MODEL U-COMPONENT FORECAST VALUE (GLOBAL MODEL SEE UFC) | -| VFC_MOD | 011208 | MODEL V-COMPONENT FORECAST VALUE (GLOBAL MODEL SEE VFC) | -| TFC_MOD | 012203 | MODEL TEMPERATURE FORECAST VALUE (GLOBAL MODEL SEE TFC) | -| QFC_MOD | 013248 | MODEL S. HUMIDITY FORECAST VALUE (GLOBAL MODEL SEE QFC) | -| PWF_MOD | 013249 | MODEL TOTAL PWATER FORECAST VALUE (GLOBAL MODEL SEE PWC) | -| PW1F_MOD | 013250 | MODEL 1.-.9 SIG. LYR PWATER FCST (GLOBAL MODEL SEE PW1F) | -| PW2F_MOD | 013251 | MODEL .9-.7 SIG. LYR PWATER FCST (GLOBAL MODEL SEE PW2F) | -| PW3F_MOD | 013252 | MODEL .7-.3 SIG. LYR PWATER FCST (GLOBAL MODEL SEE PW3F) | -| PW4F_MOD | 013253 | MODEL .3-0. SIG. LYR PWATER FCST (GLOBAL MODEL SEE PW4F) | +| PFCMOD | 007255 | MODEL PRESSURE FORECAST VALUE (GLOBAL MODEL SEE PFC) | +| ZFCMOD | 010255 | MODEL HEIGHT FORECAST VALUE (GLOBAL MODEL SEE ZFC) | +| UFCMOD | 011254 | MODEL U-COMPONENT FORECAST VALUE (GLOBAL MODEL SEE UFC) | +| VFCMOD | 011255 | MODEL V-COMPONENT FORECAST VALUE (GLOBAL MODEL SEE VFC) | +| TFCMOD | 012255 | MODEL TEMPERATURE FORECAST VALUE (GLOBAL MODEL SEE TFC) | +| QFCMOD | 013255 | MODEL S. HUMIDITY FORECAST VALUE (GLOBAL MODEL SEE QFC) | +| PWFMOD | 051030 | MODEL TOTAL PWATER FORECAST VALUE(GLOBAL MODEL SEE PWC) | +| PW1FMOD | 051040 | MODEL 1.-.9 SIG. LYR PWATER FCST(GLOBAL MODEL SEE PW1F) | +| PW2FMOD | 051050 | MODEL .9-.7 SIG. LYR PWATER FCST(GLOBAL MODEL SEE PW2F) | +| PW3FMOD | 051060 | MODEL .7-.3 SIG. LYR PWATER FCST(GLOBAL MODEL SEE PW3F) | +| PW4FMOD | 051070 | MODEL .3-0. SIG. LYR PWATER FCST(GLOBAL MODEL SEE PW4F) | | | | | |------------------------------------------------------------------------------| | MNEMONIC | SEQUENCE | |----------|-------------------------------------------------------------------| | | | -| ADPUPA | HEADR {PLEVL} SIRC | -| AIRCAR | HEADR PLEVL | -| AIRCFT | HEADR PLEVL RCT | -| SATWND | HEADR PLEVL SAID | -| PROFLR | HEADR {PLEVL} | -| VADWND | HEADR {PLEVL} | -| SATEMP | HEADR {PLEVL} SAID {BTLEVL} | -| GOESND | HEADR {PLEVLG} SAID {BTLEVL} ACAV | -| ADPSFC | HEADR PLEVL | -| SFCSHP | HEADR PLEVL | -| SFCBOG | HEADR PLEVL | -| SPSSMI | HEADR CAT SAID | -| SPSSMI | {BTLEVL} | -| SYNDAT | HEADR {PLEVL} | -| ERS1DA | HEADR CAT SAID | -| QKSWND | HEADR CAT SAID CTCN ATRN SPRR | -| | | -| HEADR | SID XOB YOB DHR ELV TYP T29 TSB ITP SQN | -| HEADR | PROCN RPT TCOR | -| PLEVL | CAT | -| PLEVLG | CAT | -| BTLEVL | CHNM TMBR | -| | | -| RSRDSQ | RSRD EXPRSRD | -| | | -| PINFO | [PEVN] | -| QINFO | [QEVN] TDO | -| TINFO | [TEVN] TVO | -| ZINFO | [ZEVN] | -| WINFO | [WEVN] [DFEVN] | -| PWINFO | | -| PWTINF | [PWTEVN] | -| PWLINF | PRSS | -| PW1INF | [PW1EVN] | -| PW2INF | [PW2EVN] | -| PW3INF | [PW3EVN] | -| PW4INF | [PW4EVN] | -| BTINFO | ELEV SOEL OZON TMSK CLAM | -| SCINFO | A1 A2 A3 B1 B2 B3 S1 S2 S3 E1 E2 E3 | -| PMSL | PMO PMQ | -| ALTMSQ | ALSE | -| WSPDSQ | SOB SQM | -| TURB1SQ | DGOT | -| TURB2SQ | TRBX10 TRBX21 TRBX32 TRBX43 | -| RFFLSQ | RFFL | -| ACFSUP | PCAT POAF | -| DRINFO | XDR YDR HRDR | -| RRINFO | [RREVN] | -| CTINFO | [CTPEVN] TOCC GCDTT | -| | | -| PEVN | POB PQM PPC PRC | -| QEVN | QOB QQM QPC QRC | -| TEVN | TOB TQM TPC TRC | -| ZEVN | ZOB ZQM ZPC ZRC | -| WEVN | UOB WQM WPC WRC VOB | -| DFEVN | DDO FFO DFQ DFP DFR | -| PWTEVN | PWO PWQ PWP PWR | -| PW1EVN | PW1O PW1Q PW1P PW1R | -| PW2EVN | PW2O PW2Q PW2P PW2R | -| PW3EVN | PW3O PW3Q PW3P PW3R | -| PW4EVN | PW4O PW4Q PW4P PW4R | -| RREVN | REQ6 REQ6_QM REQ6_PC REQ6_RC | -| CTPEVN | CDTP CDTP_QM CDTP_PC CDTP_RC | -| | | -| PBACKG | POE PFC | -| QBACKG | QOE QFC | -| TBACKG | TOE TFC | -| ZBACKG | ZOE ZFC | -| WBACKG | WOE UFC VFC | -| PWTBAK | PWE PWF | -| PW1BAK | PW1E PW1F | -| PW2BAK | PW2E PW2F | -| PW3BAK | PW3E PW3F | -| PW4BAK | PW4E PW4F | -| RRBACKG | REQ6_OE REQ6_FC | -| CTPBAK | CDTP_OE CDTP_FC | -| | | -| PPOSTP | PAN | -| QPOSTP | QAN | -| TPOSTP | TAN | -| ZPOSTP | ZAN | -| WPOSTP | UAN VAN | -| PWTPST | PWA | -| PW1PST | PW1A | -| PW2PST | PW2A | -| PW3PST | PW3A | -| PW4PST | PW4A | -| RRPOSTP | REQ6_AN | -| CTPPST | CDTP_AN | -| | | -| PCLIM | PCL PCS | -| QCLIM | QCL QCS | -| TCLIM | TCL TCS | -| ZCLIM | ZCL ZCS | -| WCLIM | UCL UCS VCL VCS | -| | | -| PFC_MSQ | PFC_MOD | -| QFC_MSQ | QFC_MOD | -| TFC_MSQ | TFC_MOD | -| ZFC_MSQ | ZFC_MOD | -| WFC_MSQ | UFC_MOD VFC_MOD | -| PWF_MSQ | PWF_MOD | -| PW1F_MSQ | PW1F_MOD | -| PW2F_MSQ | PW2F_MOD | -| PW3F_MSQ | PW3F_MOD | -| PW4F_MSQ | PW4F_MOD | +| ADPUPA | HEADR SIRC {PRSLEVEL} {CLOUDSEQ} | +| ADPUPA | | +| | | +| AIRCAR | HEADR ACID {PRSLEVLA} | +| | | +| AIRCFT | HEADR {PRSLEVLA} | +| | | +| SATWND | HEADR SAID PRSLEVEL SAZA | +| | | +| PROFLR | HEADR {PRSLEVEL} | +| | | +| VADWND | HEADR {PRSLEVEL} | +| | | +| SATEMP | HEADR SAID {PRSLEVEL} {BTMPLEVL} | +| | | +| GOESND | HEADR SAID ACAV {PRSLEVLG} {BTMPLEVL} | +| | | +| ADPSFC | HEADR CAT | +| ADPSFC | [W2_EVENT] | +| ADPSFC | {PREWXSEQ} {CLOUDSEQ} {TMXMNSEQ} {SWELLSEQ} | +| ADPSFC | | +| ADPSFC | | +| ADPSFC | | +| | | +| SFCSHP | HEADR CAT | +| SFCSHP | [W2_EVENT] | +| SFCSHP | {CLOUDSEQ} {SWELLSEQ} | +| SFCSHP | | +| SFCSHP | | +| | | +| SFCBOG | HEADR CAT | +| | | +| SPSSMI | HEADR CAT SAID | +| SPSSMI | {BTMPLEVL} | +| | | +| SYNDAT | HEADR {PRSLEVEL} | +| | | +| ERS1DA | HEADR CAT SAID | +| | | +| QKSWND | HEADR CAT SAID CTCN ATRN SPRR | +| | | +| MSONET | HEADR PRVSTG SPRVSTG CAT | +| MSONET | [W2_EVENT] | +| MSONET | {TOPC_SEQ} | +| | | +| GPSIPW | HEADR CAT PW__INFO | +| | | +| RASSDA | HEADR {PRSLEVEL} | +| | | +| WDSATR | HEADR CAT SAID ACAV REQV SST1 | +| WDSATR | MWD10 MWS10 MRWVC MRLWC WSST CHSQ | +| WDSATR | WSEQC1 PHER SSTE SPDE VPRE CLDE | +| | | +| ASCATW | HEADR CAT SAID CTCN WVCQ BSCD LKCS | +| | | +| HEADR | SID 207003 XOB YOB 207000 DHR ELV TYP T29 | +| HEADR | TSB ITP SQN PROCN RPT TCOR | +| | | +| PRSLEVEL | CAT | +| PRSLEVEL | [W1_EVENT] | +| | | +| PRSLEVLG | CAT | +| PRSLEVLG | | +| | | +| PRSLEVLA | RCT ROLF MSTQ IALR | +| PRSLEVLA | CAT | +| PRSLEVLA | [W1_EVENT] | +| PRSLEVLA | {TURB3SEQ} {PREWXSEQ} {CLOUDSEQ} {AFIC_SEQ} NRLQMS | +| | | +| BTMPLEVL | CHNM TMBR | +| | | +| P___INFO | [P__EVENT] | +| Q___INFO | [Q__EVENT] TDO | +| T___INFO | [T__EVENT] TVO | +| Z___INFO | [Z__EVENT] | +| W___INFO | [W__EVENT] | +| PW__INFO | PRSS | +| PWT_INFO | [PWTEVENT] | +| PWL_INFO | | +| PW1_INFO | [PW1EVENT] | +| PW2_INFO | [PW2EVENT] | +| PW3_INFO | [PW3EVENT] | +| PW4_INFO | [PW4EVENT] | +| RRT_INFO | [RRTEVENT] | +| CTP_INFO | [CTPEVENT] TOCC GCDTT | +| SST_INFO | [SSTEVENT] MSST | +| BTMPINFO | ELEV SOEL OZON TMSK CLAM | +| DRFTINFO | 207003 XDR YDR 207000 HRDR | +| SCATINFO | A1 A2 A3 B1 B2 B3 S1 S2 S3 E1 E2 E3 | +| | | +| TURB1SEQ | TRBX | +| TURB2SEQ | TRBX10 TRBX21 TRBX32 TRBX43 | +| PCCF_SEQ | RFFL QIFY QIFN EEQF | +| ACFT_SEQ | PCAT POAF | +| RSRD_SEQ | RSRD EXPRSRD | +| PMSL_SEQ | PMO PMQ PMIN | +| ALTIMSEQ | ALSE | +| TOPC_SEQ | .DTHTOPC TOPC | +| PREWXSEQ | PRWE | +| CLOUDSEQ | VSSO CLAM CLTP HOCB | +| HOCT_SEQ | HOCT | +| TMXMNSEQ | .DTHMXTM MXTM .DTHMITM MITM | +| SWELLSEQ | DOSW HOSW POSW | +| DBSS_SEQ | DBSS | +| VISB1SEQ | .REHOVI HOVI | +| VISB2SEQ | HOVI | +| VTVI_SEQ | VTVI | +| PSTWXSEQ | PSW1 PSW2 | +| PKWNDSEQ | PKWDSP PKWDDR | +| GUST1SEQ | .DTMMXGS MXGS | +| GUST2SEQ | MXGS MXGD | +| TPRECSEQ | TP01 TP03 TP06 TP24 | +| TP12_SEQ | TP12 | +| SUNSHSEQ | TOSS | +| CLOU2SEQ | TOCC HBLCS | +| XWSPDSEQ | XS10 XS20 | +| SWINDSEQ | WDIR1 WSPD1 | +| SNOW_SEQ | .DTHDOFS DOFS TOSD | +| WAVE_SEQ | HOWV POWV HOWW POWW | +| SHIP_SEQ | TDMP ASMP | +| PTENDSEQ | CHPT 3HPC | +| PTE24SEQ | 24PC | +| ACID_SEQ | ACID | +| AFIC_SEQ | AFIC HBOI HTOI | +| TURB3SEQ | DGOT HBOT HTOT | +| LATCORSQ | 207003 YORG 207000 YCOR | +| LONCORSQ | 207003 XORG 207000 XCOR | +| CLOU3SEQ | CEILING | +| APDS_SEQ | BEARAZ ELEV APDS APDE | +| | | +| P__EVENT | POB PQM PPC PRC | +| Q__EVENT | QOB QQM QPC QRC | +| T__EVENT | TOB TQM TPC TRC | +| Z__EVENT | ZOB ZQM ZPC ZRC | +| W__EVENT | UOB VOB WQM WPC WRC | +| W1_EVENT | DDO FFO DFQ DFP DFR | +| W2_EVENT | DDO SOB DFQ DFP DFR | +| PWTEVENT | PWO PWQ PWP PWR | +| PW1EVENT | PW1O PW1Q PW1P PW1R | +| PW2EVENT | PW2O PW2Q PW2P PW2R | +| PW3EVENT | PW3O PW3Q PW3P PW3R | +| PW4EVENT | PW4O PW4Q PW4P PW4R | +| RRTEVENT | 202130 201134 REQV 201000 202000 RRTQM RRTPC RRTRC | +| CTPEVENT | CDTP CTPQM CTPPC CTPRC | +| SSTEVENT | SST1 SSTQM SSTPC SSTRC | +| | | +| P__BACKG | POE PFC | +| Q__BACKG | QOE QFC | +| T__BACKG | TOE TFC | +| Z__BACKG | ZFC | +| W__BACKG | WOE UFC VFC | +| PWTBACKG | PWE PWF | +| PW1BACKG | PW1E PW1F | +| PW2BACKG | PW2E PW2F | +| PW3BACKG | PW3E PW3F | +| PW4BACKG | PW4E PW4F | +| RRTBACKG | RRTOE RRTFC | +| CTPBACKG | CTPOE CTPFC | +| SSTBACKG | SSTOE SSTFC | +| | | +| P__POSTP | PAN POETU PVWTG PVWTA | +| Q__POSTP | QAN QOETU QVWTG QVWTA ESBAK | +| T__POSTP | TAN TOETU TVWTG TVWTA | +| Z__POSTP | ZAN | +| W__POSTP | UAN VAN WOETU WVWTG WVWTA RF10M | +| PWTPOSTP | PWA PWETU PWTVWTG PWTVWTA | +| PW1POSTP | PW1A | +| PW2POSTP | PW2A | +| PW3POSTP | PW3A | +| PW4POSTP | PW4A | +| RRTPOSTP | RRTAN | +| CTPPOSTP | CTPAN | +| SSTPOSTP | SSTAN | +| | | +| PCLIMATO | PCL PCS | +| QCLIMATO | QCL QCS | +| TCLIMATO | TCL TCS | +| ZCLIMATO | ZCL ZCS | +| WCLIMATO | UCL UCS VCL VCS | +| | | +| PFC__MSQ | PFCMOD | +| QFC__MSQ | QFCMOD | +| TFC__MSQ | TFCMOD | +| ZFC__MSQ | ZFCMOD | +| WFC__MSQ | UFCMOD VFCMOD | +| PWF__MSQ | PWFMOD | +| PW1F_MSQ | PW1FMOD | +| PW2F_MSQ | PW2FMOD | +| PW3F_MSQ | PW3FMOD | +| PW4F_MSQ | PW4FMOD | | | | |------------------------------------------------------------------------------| | MNEMONIC | SCAL | REFERENCE | BIT | UNITS |-------------| |----------|------|-------------|-----|--------------------------|-------------| | | | | | |-------------| +| ACID | 0 | 0 | 64 | CCITT IA5 |-------------| +| SAID | 0 | 0 | 10 | CODE TABLE |-------------| | SID | 0 | 0 | 64 | CCITT IA5 |-------------| -| XOB | 2 | -18000 | 16 | DEG E |-------------| -| XDR | 2 | -18000 | 16 | DEG E |-------------| -| YOB | 2 | -9000 | 15 | DEG N |-------------| -| YDR | 2 | -9000 | 15 | DEG N |-------------| -| RPT | 3 | 0 | 16 | HOURS |-------------| -| DHR | 3 | -24000 | 16 | HOURS |-------------| -| TCOR | 0 | 0 | 2 | CODE TABLE |-------------| -| RCT | 2 | 0 | 12 | HOURS |-------------| -| HRDR | 3 | -24000 | 16 | HOURS |-------------| -| ELV | 0 | -1000 | 17 | METER |-------------| -| TYP | 0 | 0 | 9 | CODE TABLE |-------------| -| T29 | 0 | 0 | 10 | CODE TABLE |-------------| -| TSB | 0 | 0 | 2 | CODE TABLE |-------------| -| ITP | 0 | 0 | 8 | CODE TABLE |-------------| +| | | | | |-------------| | SIRC | 0 | 0 | 4 | CODE TABLE |-------------| -| SQN | 0 | 0 | 19 | NUMERIC |-------------| -| PROCN | 0 | 0 | 7 | NUMERIC |-------------| -| ACAV | 0 | 0 | 16 | NUMERIC |-------------| +| MSST | 0 | 0 | 3 | CODE TABLE |-------------| +| ITP | 0 | 0 | 8 | CODE TABLE |-------------| +| | | | | |-------------| +| RPT | 5 | 0 | 22 | HOURS |-------------| +| DHR | 5 | -2400000 | 23 | HOURS |-------------| +| TCOR | 0 | 0 | 3 | CODE TABLE |-------------| +| | | | | |-------------| +| YOB | 2 | -9000 | 15 | DEG N |-------------| +* YOB stored 5 * -9000000 * 25 * * +| | | | | |-------------| +| BEARAZ | 2 | 0 | 16 | DEGREE TRUE |-------------| | ATRN | 0 | 0 | 11 | NUMERIC |-------------| +| | | | | |-------------| | CTCN | 0 | 0 | 7 | NUMERIC |-------------| +* IMPORTANT: XOB is a local descriptor here even though it has the same * +* attributes as CLON (0-06-002) - this is because it is coded here * +* with the range 0 to 360 degrees east unlike CLON which has the * +* range -180 to +180 degrees, where east is + and west is - * +* (it can still be held here in 16 bits) * +| XOB | 2 | -18000 | 16 | DEG E |-------------| +* XOB stored 5 * -18000000 * 26 * * +| | | | | |-------------| +| VSSO | 0 | 0 | 6 | CODE TABLE |-------------| +| ACAV | 0 | 0 | 16 | NUMERIC |-------------| +| | | | | |-------------| +| IALR | 3 | -65536 | 17 | M/S |-------------| +| ELV | 0 | -1000 | 17 | METER |-------------| +| | | | | |-------------| | SPRR | 3 | 0 | 10 | NUMERIC |-------------| -| SAID | 0 | 0 | 10 | CODE TABLE |-------------| +| | | | | |-------------| +| NRLQMS | 0 | 0 | 88 | CCITT IA5 |-------------| +| | | | | |-------------| | RSRD | 0 | 0 | 9 | FLAG TABLE |-------------| | EXPRSRD | 0 | 0 | 8 | HOURS |-------------| | | | | | |-------------| -| CAT | 0 | 0 | 6 | CODE TABLE |-------------| +| SQN | 0 | 0 | 19 | NUMERIC |-------------| | | | | | |-------------| -| POB | 1 | 0 | 14 | MB |-------------| -| PFC | 1 | 0 | 14 | MB |-------------| -| PAN | 1 | 0 | 14 | MB |-------------| -| PCL | 1 | 0 | 14 | MB |-------------| -| POE | 1 | 0 | 14 | MB |-------------| -| PCS | 1 | 0 | 14 | MB |-------------| -| PMO | 1 | 0 | 14 | MB |-------------| -| PQM | 0 | 0 | 5 | CODE TABLE |-------------| -| PMQ | 0 | 0 | 5 | CODE TABLE |-------------| -| PPC | 0 | 0 | 4 | CODE TABLE |-------------| -| PRC | 0 | 0 | 10 | CODE TABLE |-------------| +| PROCN | 0 | 0 | 7 | NUMERIC |-------------| | | | | | |-------------| -| PRSS | -1 | 0 | 14 | PASCALS |-------------| +| TYP | 0 | 0 | 10 | CODE TABLE |-------------| +| T29 | 0 | 0 | 10 | CODE TABLE |-------------| +| TSB | 0 | 0 | 14 | CODE TABLE |-------------| | | | | | |-------------| -| ALSE | -1 | 0 | 14 | PASCALS |-------------| +| PRVSTG | 0 | 0 | 64 | CCITT IA5 |-------------| +| SPRVSTG | 0 | 0 | 64 | CCITT IA5 |-------------| | | | | | |-------------| -| RFFL | 0 | 0 | 8 | NUMERIC |-------------| +| TDMP | 0 | 0 | 4 | CODE TABLE |-------------| +| ASMP | 0 | 0 | 4 | CODE TABLE |-------------| | | | | | |-------------| -| PCAT | 2 | 0 | 7 | DEGREES KELVIN |-------------| -| POAF | 0 | 0 | 3 | CODE TABLE |-------------| -| DGOT | 0 | 0 | 4 | CODE TABLE |-------------| -| TRBX10 | 0 | 0 | 6 | CODE TABLE |-------------| -| TRBX21 | 0 | 0 | 6 | CODE TABLE |-------------| -| TRBX32 | 0 | 0 | 6 | CODE TABLE |-------------| -| TRBX43 | 0 | 0 | 6 | CODE TABLE |-------------| +| PCAT | 2 | 0 | 7 | KELVIN |-------------| +| ROLF | 0 | 0 | 3 | CODE TABLE |-------------| +| AFIC | 0 | 0 | 4 | CODE TABLE |-------------| +| HBOI | -1 | -40 | 16 | METER |-------------| +| HTOI | -1 | -40 | 16 | METER |-------------| | | | | | |-------------| -| QOB | 0 | 0 | 16 | MG/KG |-------------| -| QFC | 0 | 0 | 16 | MG/KG |-------------| -| QAN | 0 | 0 | 16 | MG/KG |-------------| -| QCL | 0 | 0 | 16 | MG/KG |-------------| -| QOE | 0 | 0 | 16 | PERCENT DIVIDED BY 10 |-------------| -| QCS | 0 | 0 | 16 | MG/KG |-------------| -| QQM | 0 | 0 | 5 | CODE TABLE |-------------| -| QPC | 0 | 0 | 4 | CODE TABLE |-------------| -| QRC | 0 | 0 | 10 | CODE TABLE |-------------| +| .DTH.... | 0 | 0 | 8 | HOURS |-------------| +| .DTM.... | 0 | 0 | 6 | MINUTES |-------------| +| RCT | 2 | 0 | 12 | HOURS |-------------| +| HRDR | 5 | -2400000 | 23 | HOURS |-------------| | | | | | |-------------| -| TOB | 1 | -2732 | 14 | DEG C |-------------| -| TVO | 1 | -2732 | 14 | DEG C |-------------| -| TDO | 1 | -2732 | 14 | DEG C |-------------| -| TFC | 1 | -2732 | 14 | DEG C |-------------| -| TAN | 1 | -2732 | 14 | DEG C |-------------| -| TCL | 1 | -2732 | 14 | DEG C |-------------| -| TOE | 1 | 0 | 10 | DEG C |-------------| -| TCS | 1 | 0 | 10 | DEG C |-------------| -| TQM | 0 | 0 | 5 | CODE TABLE |-------------| -| TPC | 0 | 0 | 4 | CODE TABLE |-------------| -| TRC | 0 | 0 | 10 | CODE TABLE |-------------| +| CHNM | 0 | 0 | 6 | NUMERIC |-------------| +| YORG | 2 | -9000 | 15 | DEG N |-------------| +* YORG stored 5 * -9000000 * 25 * * +| | | | | |-------------| +| YCOR | 0 | 0 | 3 | CODE TABLE |-------------| +| YDR | 2 | -9000 | 15 | DEG N |-------------| +* YDR stored 5 * -9000000 * 25 * * +| | | | | |-------------| +| XORG | 2 | -18000 | 16 | DEG E |-------------| +* XORG stored 5 * -18000000 * 26 * * +| | | | | |-------------| +| XCOR | 0 | 0 | 3 | CODE TABLE |-------------| +| XDR | 2 | -18000 | 16 | DEG E |-------------| +* XDR stored 5 * -18000000 * 26 * * +| | | | | |-------------| +| ELEV | 2 | -9000 | 15 | DEGREE |-------------| +| SOEL | 2 | -9000 | 15 | DEGREE |-------------| +| SAZA | 2 | -9000 | 15 | DEGREES |-------------| +| DBSS | 1 | 0 | 17 | METER |-------------| +| POB | 1 | 0 | 14 | MB |-------------| +| PQM | 0 | 0 | 5 | CODE TABLE |-------------| +| PPC | 0 | 0 | 5 | CODE TABLE |-------------| +| PRC | 0 | 0 | 10 | CODE TABLE |-------------| +| PFC | 1 | 0 | 14 | MB |-------------| +| POE | 2 | 0 | 14 | MB |-------------| +| PAN | 1 | 0 | 14 | MB |-------------| +| PCL | 1 | 0 | 14 | MB |-------------| +| PCS | 1 | 0 | 14 | MB |-------------| +| POETU | 2 | 0 | 14 | MB |-------------| | | | | | |-------------| -| GCDTT | 2 | 0 | 16 | DEGREES KELVIN |-------------| +| POAF | 0 | 0 | 3 | CODE TABLE |-------------| +| CAT | 0 | 0 | 6 | CODE TABLE |-------------| +| .RE.... | 0 | 0 | 3 | CODE TABLE |-------------| | | | | | |-------------| | ZOB | 0 | -1000 | 17 | METER |-------------| +| ALSE | -1 | 0 | 14 | PASCALS |-------------| +| 3HPC | -1 | -500 | 10 | PASCALS |-------------| +| 24PC | -1 | -1000 | 11 | PASCALS |-------------| +| CHPT | 0 | 0 | 4 | CODE TABLE |-------------| +| PRSS | -1 | 0 | 14 | PASCALS |-------------| +| PMO | 1 | 0 | 14 | MB |-------------| +| PMQ | 0 | 0 | 5 | CODE TABLE |-------------| +| PMIN | 0 | 0 | 3 | CODE TABLE |-------------| +| ZQM | 0 | 0 | 5 | CODE TABLE |-------------| +| ZPC | 0 | 0 | 5 | CODE TABLE |-------------| +| ZRC | 0 | 0 | 10 | CODE TABLE |-------------| | ZFC | 0 | -1000 | 17 | METER |-------------| +| ZOE | 0 | 0 | 10 | METER |-------------| | ZAN | 0 | -1000 | 17 | METER |-------------| | ZCL | 0 | -1000 | 17 | METER |-------------| -| ZOE | 0 | 0 | 10 | METER |-------------| | ZCS | 0 | 0 | 10 | METER |-------------| -| ZQM | 0 | 0 | 5 | CODE TABLE |-------------| -| ZPC | 0 | 0 | 4 | CODE TABLE |-------------| -| ZRC | 0 | 0 | 10 | CODE TABLE |-------------| | | | | | |-------------| -| DDO | 0 | 0 | 9 | DEGREES |-------------| +| DDO | 0 | 0 | 9 | DEGREES TRUE |-------------| | SOB | 1 | 0 | 12 | M/S |-------------| | UOB | 1 | -4096 | 13 | M/S |-------------| | VOB | 1 | -4096 | 13 | M/S |-------------| -| FFO | 0 | 0 | 9 | KNOTS |-------------| +| DGOT | 0 | 0 | 4 | CODE TABLE |-------------| +| HBOT | -1 | -40 | 16 | METERS |-------------| +| HTOT | -1 | -40 | 16 | METERS |-------------| +| MXGS | 1 | 0 | 12 | M/S |-------------| +| MXGD | 0 | 0 | 9 | DEGREES TRUE |-------------| +| MWD10 | 2 | 0 | 16 | DEGREES TRUE |-------------| +| MWS10 | 2 | 0 | 14 | M/S |-------------| +| WDIR1 | 0 | 0 | 9 | DEGREES TRUE |-------------| +| WSPD1 | 1 | 0 | 12 | M/S |-------------| +| PKWDDR | 0 | 0 | 9 | DEGREES TRUE |-------------| +| PKWDSP | 1 | 0 | 12 | M/S |-------------| +| DFQ | 0 | 0 | 5 | CODE TABLE |-------------| +| DFP | 0 | 0 | 5 | CODE TABLE |-------------| +| DFR | 0 | 0 | 10 | CODE TABLE |-------------| +| XS10 | 1 | 0 | 12 | M/S |-------------| +| XS20 | 1 | 0 | 12 | M/S |-------------| +| RF10M | 4 | 0 | 16 | NUMERIC |-------------| +| TRBX | 0 | 0 | 6 | CODE TABLE |-------------| +| TRBX10 | 0 | 0 | 6 | CODE TABLE |-------------| +| TRBX21 | 0 | 0 | 6 | CODE TABLE |-------------| +| TRBX32 | 0 | 0 | 6 | CODE TABLE |-------------| +| TRBX43 | 0 | 0 | 6 | CODE TABLE |-------------| +| WQM | 0 | 0 | 5 | CODE TABLE |-------------| +| WPC | 0 | 0 | 5 | CODE TABLE |-------------| +| WRC | 0 | 0 | 10 | CODE TABLE |-------------| | UFC | 1 | -4096 | 13 | M/S |-------------| | VFC | 1 | -4096 | 13 | M/S |-------------| +| WOE | 1 | 0 | 10 | M/S |-------------| | UAN | 1 | -4096 | 13 | M/S |-------------| | VAN | 1 | -4096 | 13 | M/S |-------------| | UCL | 1 | -4096 | 13 | M/S |-------------| | VCL | 1 | -4096 | 13 | M/S |-------------| -| WOE | 1 | 0 | 10 | M/S |-------------| | UCS | 1 | 0 | 10 | M/S |-------------| | VCS | 1 | 0 | 10 | M/S |-------------| -| WQM | 0 | 0 | 5 | CODE TABLE |-------------| -| WPC | 0 | 0 | 4 | CODE TABLE |-------------| -| WRC | 0 | 0 | 10 | CODE TABLE |-------------| -| DFQ | 0 | 0 | 5 | CODE TABLE |-------------| -| DFP | 0 | 0 | 4 | CODE TABLE |-------------| -| DFR | 0 | 0 | 10 | CODE TABLE |-------------| -| SQM | 0 | 0 | 5 | CODE TABLE |-------------| +| FFO | 0 | 0 | 9 | KNOTS |-------------| +| WOETU | 1 | 0 | 10 | M/S |-------------| | | | | | |-------------| -| PWO | 1 | 0 | 10 | MM |-------------| -| PWF | 1 | 0 | 10 | MM |-------------| -| PWA | 1 | 0 | 10 | MM |-------------| -| PWE | 1 | 0 | 10 | MM |-------------| -| PWQ | 0 | 0 | 5 | CODE TABLE |-------------| -| PWP | 0 | 0 | 4 | CODE TABLE |-------------| -| PWR | 0 | 0 | 10 | CODE TABLE |-------------| -| PW1O | 1 | 0 | 10 | MM |-------------| -| PW1F | 1 | 0 | 10 | MM |-------------| -| PW1A | 1 | 0 | 10 | MM |-------------| -| PW1E | 1 | 0 | 10 | MM |-------------| -| PW1Q | 0 | 0 | 5 | CODE TABLE |-------------| -| PW1P | 0 | 0 | 4 | CODE TABLE |-------------| -| PW1R | 0 | 0 | 10 | CODE TABLE |-------------| -| PW2O | 1 | 0 | 10 | MM |-------------| -| PW2F | 1 | 0 | 10 | MM |-------------| -| PW2A | 1 | 0 | 10 | MM |-------------| -| PW2E | 1 | 0 | 10 | MM |-------------| -| PW2Q | 0 | 0 | 5 | CODE TABLE |-------------| -| PW2P | 0 | 0 | 4 | CODE TABLE |-------------| -| PW2R | 0 | 0 | 10 | CODE TABLE |-------------| -| PW3O | 1 | 0 | 10 | MM |-------------| -| PW3F | 1 | 0 | 10 | MM |-------------| -| PW3A | 1 | 0 | 10 | MM |-------------| -| PW3E | 1 | 0 | 10 | MM |-------------| -| PW3Q | 0 | 0 | 5 | CODE TABLE |-------------| -| PW3P | 0 | 0 | 4 | CODE TABLE |-------------| -| PW3R | 0 | 0 | 10 | CODE TABLE |-------------| -| PW4O | 1 | 0 | 10 | MM |-------------| -| PW4F | 1 | 0 | 10 | MM |-------------| -| PW4A | 1 | 0 | 10 | MM |-------------| -| PW4E | 1 | 0 | 10 | MM |-------------| -| PW4Q | 0 | 0 | 5 | CODE TABLE |-------------| -| PW4P | 0 | 0 | 4 | CODE TABLE |-------------| -| PW4R | 0 | 0 | 10 | CODE TABLE |-------------| +| MXTM | 2 | 0 | 16 | KELVIN |-------------| +| MITM | 2 | 0 | 16 | KELVIN |-------------| +| TMSK | 2 | 0 | 16 | KELVIN |-------------| +| TMBR | 2 | 0 | 16 | KELVIN |-------------| +| GCDTT | 2 | 0 | 16 | KELVIN |-------------| +| TVO | 1 | -2732 | 14 | DEG C |-------------| +| TDO | 1 | -2732 | 14 | DEG C |-------------| +| TOB | 1 | -2732 | 14 | DEG C |-------------| +| TQM | 0 | 0 | 5 | CODE TABLE |-------------| +| TPC | 0 | 0 | 5 | CODE TABLE |-------------| +| TRC | 0 | 0 | 10 | CODE TABLE |-------------| +| TFC | 1 | -2732 | 14 | DEG C |-------------| +| TOE | 1 | 0 | 10 | DEG C |-------------| +| TAN | 1 | -2732 | 14 | DEG C |-------------| +| TCL | 1 | -2732 | 14 | DEG C |-------------| +| TCS | 1 | 0 | 10 | DEG C |-------------| +| TOETU | 1 | 0 | 10 | DEG C |-------------| | | | | | |-------------| -| REQ6 | 6 | 0 | 18 | KG / ((M ** 2)*SEC) |-------------| -| REQ6_FC | 6 | 0 | 18 | KG / ((M ** 2)*SEC) |-------------| -| REQ6_AN | 6 | 0 | 18 | KG / ((M ** 2)*SEC) |-------------| -| REQ6_OE | 6 | 0 | 18 | KG / ((M ** 2)*SEC) |-------------| -| REQ6_QM | 0 | 0 | 5 | CODE TABLE |-------------| -| REQ6_PC | 0 | 0 | 4 | CODE TABLE |-------------| -| REQ6_RC | 0 | 0 | 10 | CODE TABLE |-------------| +| PWO | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW1O | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW2O | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW3O | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| TOPC | 1 | -1 | 14 | KG/M**2 |-------------| +| DOFS | 2 | -2 | 12 | METER |-------------| +| TOSD | 2 | -2 | 16 | METER |-------------| +* REQV stored at a higher precision than standard via operatior descriptors * +* for message type SPSSMI (scale=6, bit width=18) * +| REQV | 4 | 0 | 12 | KG/((METER**2)*SECOND) |-------------| +| TP01 | 1 | -1 | 14 | KG/M**2 |-------------| +| TP03 | 1 | -1 | 14 | KG/M**2 |-------------| +| TP06 | 1 | -1 | 14 | KG/M**2 |-------------| +| TP12 | 1 | -1 | 14 | KG/M**2 |-------------| +| TP24 | 1 | -1 | 14 | KG/M**2 |-------------| +| MRWVC | 2 | 0 | 14 | KG/M**2 |-------------| +| MRLWC | 2 | 0 | 14 | KG/M**2 |-------------| +| QOB | 0 | 0 | 16 | MG/KG |-------------| +| ESBAK | 0 | 0 | 16 | MG/KG |-------------| +| QQM | 0 | 0 | 5 | CODE TABLE |-------------| +| QPC | 0 | 0 | 5 | CODE TABLE |-------------| +| QRC | 0 | 0 | 10 | CODE TABLE |-------------| +| QFC | 0 | 0 | 16 | MG/KG |-------------| +| QOE | 1 | 0 | 10 | PERCENT DIVIDED BY 10 |-------------| +| QAN | 0 | 0 | 16 | MG/KG |-------------| +| QCL | 0 | 0 | 16 | MG/KG |-------------| +| QCS | 0 | 0 | 16 | MG/KG |-------------| +| QOETU | 1 | 0 | 10 | PERCENT DIVIDED BY 10 |-------------| | | | | | |-------------| -| TOCC | 0 | 0 | 7 | PERCENT |-------------| -| CDTP | -1 | 0 | 14 | PASCALS |-------------| -| CDTP_FC | -1 | 0 | 14 | PASCALS |-------------| -| CDTP_AN | -1 | 0 | 14 | PASCALS |-------------| -| CDTP_OE | -1 | 0 | 14 | PASCALS |-------------| -| CDTP_QM | 0 | 0 | 5 | CODE TABLE |-------------| -| CDTP_PC | 0 | 0 | 4 | CODE TABLE |-------------| -| CDTP_RC | 0 | 0 | 10 | CODE TABLE |-------------| +| TOSS | 0 | 0 | 11 | MINUTE |-------------| | | | | | |-------------| -| ELEV | 2 | -9000 | 15 | DEGREE |-------------| -| SOEL | 2 | -9000 | 15 | DEGREE |-------------| | OZON | 0 | 0 | 10 | DOBSON UNITS |-------------| -| TMSK | 1 | 0 | 12 | DEGREES KELVIN |-------------| +| APDS | 4 | 10000 | 15 | METER |-------------| +| APDE | 4 | 0 | 10 | METER |-------------| +| | | | | |-------------| +| HOVI | -1 | 0 | 13 | METER |-------------| +| VTVI | -1 | 0 | 7 | METER |-------------| +| PRWE | 0 | 0 | 9 | CODE TABLE |-------------| +| PSW1 | 0 | 0 | 5 | CODE TABLE |-------------| +| PSW2 | 0 | 0 | 5 | CODE TABLE |-------------| +| TOCC | 0 | 0 | 7 | PERCENT |-------------| | CLAM | 0 | 0 | 4 | CODE TABLE |-------------| -| CHNM | 0 | 0 | 6 | NUMERIC |-------------| -| TMBR | 2 | 0 | 19 | KELVIN |-------------| +| CLTP | 0 | 0 | 6 | CODE TABLE |-------------| +| HOCB | -1 | -40 | 11 | METER |-------------| +| HOCT | -1 | -40 | 11 | METER |-------------| +| CDTP | -1 | 0 | 14 | PASCALS |-------------| +| HBLCS | 0 | 0 | 4 | CODE TABLE |-------------| +| CEILING | -1 | -40 | 11 | METER |-------------| +| WSST | 0 | 0 | 3 | CODE TABLE |-------------| +| CTPQM | 0 | 0 | 5 | CODE TABLE |-------------| +| CTPPC | 0 | 0 | 5 | CODE TABLE |-------------| +| CTPRC | 0 | 0 | 10 | CODE TABLE |-------------| +| CTPFC | -1 | 0 | 14 | PASCALS |-------------| +| CTPOE | -1 | 0 | 10 | PASCALS |-------------| +| CTPAN | -1 | 0 | 14 | PASCALS |-------------| | | | | | |-------------| +| LKCS | 3 | -30000 | 15 | NUMERIC |-------------| +| WVCQ | 0 | 0 | 24 | FLAG TABLE |-------------| +| BSCD | 1 | -4096 | 13 | NUMERIC |-------------| | A1 | 1 | 0 | 12 | DEGREE |-------------| | A2 | 1 | 0 | 12 | DEGREE |-------------| | A3 | 1 | 0 | 12 | DEGREE |-------------| -| | | | | |-------------| | B1 | 1 | 0 | 12 | DEGREE |-------------| | B2 | 1 | 0 | 12 | DEGREE |-------------| | B3 | 1 | 0 | 12 | DEGREE |-------------| -| | | | | |-------------| -| S1 | 2 | -5000 | 13 | BACKSCATTER |-------------| -| S2 | 2 | -5000 | 13 | BACKSCATTER |-------------| -| S3 | 2 | -5000 | 13 | BACKSCATTER |-------------| -| | | | | |-------------| +| S1 | 2 | -5000 | 13 | DECIBEL |-------------| +| S2 | 2 | -5000 | 13 | DECIBEL |-------------| +| S3 | 2 | -5000 | 13 | DECIBEL |-------------| | E1 | 0 | 0 | 7 | PERCENT |-------------| | E2 | 0 | 0 | 7 | PERCENT |-------------| | E3 | 0 | 0 | 7 | PERCENT |-------------| | | | | | |-------------| -| PFC_MOD | 1 | 0 | 14 | MB |-------------| -| ZFC_MOD | 0 | -1000 | 17 | METER |-------------| -| UFC_MOD | 1 | -4096 | 13 | M/S |-------------| -| VFC_MOD | 1 | -4096 | 13 | M/S |-------------| -| TFC_MOD | 1 | -2732 | 14 | DEG C |-------------| -| QFC_MOD | 0 | 0 | 16 | MG/KG |-------------| -| PWF_MOD | 1 | 0 | 10 | MM |-------------| -| PW1F_MOD | 1 | 0 | 10 | MM |-------------| -| PW2F_MOD | 1 | 0 | 10 | MM |-------------| -| PW3F_MOD | 1 | 0 | 10 | MM |-------------| -| PW4F_MOD | 1 | 0 | 10 | MM |-------------| +| DOSW | 0 | 0 | 9 | DEGREES TRUE |-------------| +| POWV | 0 | 0 | 6 | SECONDS |-------------| +| POWW | 0 | 0 | 6 | SECONDS |-------------| +| POSW | 0 | 0 | 6 | SECONDS |-------------| +| HOWV | 1 | 0 | 10 | METER |-------------| +| HOWW | 1 | 0 | 10 | METER |-------------| +| HOSW | 1 | 0 | 10 | METER |-------------| +| SST1 | 2 | 0 | 15 | KELVIN |-------------| +| SSTQM | 0 | 0 | 5 | CODE TABLE |-------------| +| SSTPC | 0 | 0 | 5 | CODE TABLE |-------------| +| SSTRC | 0 | 0 | 10 | CODE TABLE |-------------| +| SSTFC | 2 | 0 | 15 | KELVIN |-------------| +| SSTOE | 1 | 0 | 10 | KELVIN |-------------| +| SSTAN | 2 | 0 | 15 | KELVIN |-------------| +| | | | | |-------------| +| MSTQ | 0 | 0 | 6 | CODE TABLE |-------------| +| RFFL | 0 | 0 | 8 | PERCENT |-------------| +| QIFY | 0 | 0 | 8 | PERCENT |-------------| +| QIFN | 0 | 0 | 8 | PERCENT |-------------| +| CHSQ | 2 | 0 | 17 | NUMERIC |-------------| +| WSEQC1 | 0 | 0 | 31 | FLAG TABLE |-------------| +| PHER | 1 | 0 | 12 | DEGREES TRUE |-------------| +| EEQF | 0 | 0 | 8 | PERCENT |-------------| +| PVWTG | 0 | 0 | 7 | PERCENT |-------------| +| PVWTA | 0 | 0 | 7 | PERCENT |-------------| +| TVWTG | 0 | 0 | 7 | PERCENT |-------------| +| TVWTA | 0 | 0 | 7 | PERCENT |-------------| +| QVWTG | 0 | 0 | 7 | PERCENT |-------------| +| QVWTA | 0 | 0 | 7 | PERCENT |-------------| +| WVWTG | 0 | 0 | 7 | PERCENT |-------------| +| WVWTA | 0 | 0 | 7 | PERCENT |-------------| +| PWTVWTG | 0 | 0 | 7 | PERCENT |-------------| +| PWTVWTA | 0 | 0 | 7 | PERCENT |-------------| +| SSTE | 2 | 0 | 16 | KELVIN |-------------| +| SPDE | 2 | 0 | 15 | M/S |-------------| +| VPRE | 2 | 0 | 14 | KG/M**2 |-------------| +| CLDE | 3 | 0 | 14 | KG/M**2 |-------------| +| | | | | |-------------| +| RRTQM | 0 | 0 | 5 | CODE TABLE |-------------| +| RRTPC | 0 | 0 | 5 | CODE TABLE |-------------| +| RRTRC | 0 | 0 | 10 | CODE TABLE |-------------| +| RRTFC | 6 | 0 | 18 | KG/((M**2)*S) (or MM/S) |-------------| +| RRTOE | 6 | 0 | 18 | KG/((M**2)*S) (or MM/S) |-------------| +| RRTAN | 6 | 0 | 18 | KG/((M**2)*S) (or MM/S) |-------------| +| PWQ | 0 | 0 | 5 | CODE TABLE |-------------| +| PWP | 0 | 0 | 5 | CODE TABLE |-------------| +| PWR | 0 | 0 | 10 | CODE TABLE |-------------| +| PWF | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PWE | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PWA | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PWETU | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PW1Q | 0 | 0 | 5 | CODE TABLE |-------------| +| PW1P | 0 | 0 | 5 | CODE TABLE |-------------| +| PW1R | 0 | 0 | 10 | CODE TABLE |-------------| +| PW1F | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW1E | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PW1A | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW2Q | 0 | 0 | 5 | CODE TABLE |-------------| +| PW2P | 0 | 0 | 5 | CODE TABLE |-------------| +| PW2R | 0 | 0 | 10 | CODE TABLE |-------------| +| PW2F | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW2E | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PW2A | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW3Q | 0 | 0 | 5 | CODE TABLE |-------------| +| PW3P | 0 | 0 | 5 | CODE TABLE |-------------| +| PW3R | 0 | 0 | 10 | CODE TABLE |-------------| +| PW3F | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW3E | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PW3A | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW4O | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW4Q | 0 | 0 | 5 | CODE TABLE |-------------| +| PW4P | 0 | 0 | 5 | CODE TABLE |-------------| +| PW4R | 0 | 0 | 10 | CODE TABLE |-------------| +| PW4F | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW4E | 1 | 0 | 10 | KG/M**2 (or MM) |-------------| +| PW4A | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| | | | | |-------------| +| | | | | |-------------| +| PFCMOD | 1 | 0 | 14 | MB |-------------| +| ZFCMOD | 0 | -1000 | 17 | METER |-------------| +| UFCMOD | 1 | -4096 | 13 | M/S |-------------| +| VFCMOD | 1 | -4096 | 13 | M/S |-------------| +| TFCMOD | 1 | -2732 | 14 | DEG C |-------------| +| QFCMOD | 0 | 0 | 16 | MG/KG |-------------| +| PWFMOD | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW1FMOD | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW2FMOD | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW3FMOD | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| +| PW4FMOD | 1 | 0 | 11 | KG/M**2 (or MM) |-------------| `------------------------------------------------------------------------------' diff --git a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl index eb36c72c..345ed08f 100644 --- a/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl +++ b/src/Applications/NCEP_Etc/NCEP_enkf/scripts/gmao/etc/HISTAENS.rc.tmpl @@ -630,7 +630,7 @@ COLLECTIONS: 'bkg.eta' tavg1_2d_lfo_Nx+-.format: 'CFIO', tavg1_2d_lfo_Nx+-.descr: '2d,1-Hourly,Time-Averaged,Single-Level,Forecast,Land forcing' , - tavg1_2d_lfo_Nx+-.template: '%y4%m2%d2_%h2%n2z.nc4', + tavg1_2d_lfo_Nx+-.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', tavg1_2d_lfo_Nx+-.mode: 'time-averaged', tavg1_2d_lfo_Nx+-.ref_date: >>>IOBBKGD<<< , tavg1_2d_lfo_Nx+-.ref_time: >>>IOBBKGT<<< , @@ -650,7 +650,7 @@ COLLECTIONS: 'bkg.eta' inst1_2d_lfo_Nx+-.format: 'CFIO', inst1_2d_lfo_Nx+-.descr: '2d,1-Hourly,Instantaneous,Single-Level,Forecast,land forcing' - inst1_2d_lfo_Nx+-.template: '%y4%m2%d2_%h2%n2z.nc4', + inst1_2d_lfo_Nx+-.template: '%y4%m2%d2_%h2%n2z.>>>MEMBER<<<.>>>NCSUFFIX<<<', inst1_2d_lfo_Nx+-.mode: 'instantaneous' , inst1_2d_lfo_Nx+-.ref_date: >>>IOBBKGD<<< , inst1_2d_lfo_Nx+-.ref_time: >>>IOBBKGT<<< , diff --git a/src/Applications/NCEP_Paqc/ChangeLog b/src/Applications/NCEP_Paqc/ChangeLog new file mode 100755 index 00000000..13cc0381 --- /dev/null +++ b/src/Applications/NCEP_Paqc/ChangeLog @@ -0,0 +1,125 @@ +README for NCEPQC + + 04 Sep 1997 - This code was obtained from NCEP on 14 Aug 1997 + * make_prepbufr.gbl.sh operational script + * bufrlib library of 'prepbufr' routines + * w3lib library of utility routines + * prepdata read input datasets, perform + QC checks not requiring background + * prevents interpolate background field to obs. + location and write 'events' + * acqc quality control of aircraft obs + (except ACARS) + * cqcht96 complex quality control of rawinsonde + height/temperature + (oiqc not included in this program set) + + + These programs have been run on the Cray J90 'charney' + using either ON29 or BUFR input to 'prepdata' + +11 Mar 1999 + Current snapshot of NCEPQC code used to run (ultimately) CQCHT. +This is not the final version for the operational system. Routines +in the 'w3lib' and 'bufrlib' that are not used by PREPDATA, PREVENTS, +or CQCHT are not included here. + + +26 Jul 1999 + New versions of NCEPQC 'prepdata' and 'prevents' have been +integrated into code base. The complex quality control is being tested +and will be added when ready. + Code was added to 'prevents' to work with GFIO files. The +following routines from the GFIO library are used: +GFIO_Open, GFIO_DimInquire, GFIO_Inquire, GFIO_GetVar, GFIO_Close + Note that (in general) the NCEP programs need to be compiled +-i8 -r8 - with long integers. The calls to GFIO routines *are* being +performed with integer*4 variables, however. This has been tested with +the GFIO libraries in /ford1/local/IRIX64/pkg/gfio (which were compiled +as 'i4') and it works OK. + +12 Aug 1999 + The 'parms' subdirectory contains some tables and parameter +files used by the NCEP programs + +15 Jul 2004 (Todling) + + This now builds from buffer and w3 libs living under src/ncepshrd. + All compiles, but results still need to be check. + +26 Jan 2005 - Sienkiewicz + +Update of directory for MERRA. Moved files onto main branch. +Original code from NCEP replaced by updated code in new directories - +except for 'oiqc' and 'ssprev' + + 1 Jul 2008 + +Added new GMAO version of 'prevents' in GMAOprev directory. This version +reads the 'g5eta' format background fields directly. The new code is +adapted from the latest NCEP 'gblevents' code. + +Current directories: + block-unblock - utilities to add f77 filemarkers on BUFR files + * not on main CVS branch, should move out of PAQC? + combine_bfr - utilities and notes about combining BUFR files + * not on main CVS branch + oiqc - NCEP OIQC Optimal interpolation quality control + ssprev - Older version of NCEP prevents code to interpolate + background from spectral coeffs. Current NCEP version + is not compatible with our spectral files produced by + 'fv2ss'. Interim fix for MERRA, to be replaced by + native interpolation routine eventually + GMAOprev - New GMAO version of NCEP prevents code modified to + read g5-eta files directly. Uses newer version of + NCEP gblevents interpolation from eta levels. + + prepobs_acarsqc.fd - MDCARS (ACARS) QC routine from NCEP (Oct 05) + prepobs_cqcbufr.fd - Raob Complex Quality Control from NCEP (Oct 05) + prepobs_cqcvad.fd - VAD wind QC routine from NCEP (Oct 05) + prepobs_prepacqc.fd - Aircraft (except ACARS) QC routine from NCEP (Oct 05) + prepobs_profcqc.fd - Wind Profiler QC routine from NCEP (Oct 05) + +21 Mar 2013 + +Adding new directory modify_bufr with programs to modify BUFR files - +typically to change quality marks to undo blacklisting of observations. + +24 Sep 2013 + +The code in directory prepobs_prepacqc.fd was updated with the new +NRL aircraft QC adopted at NCEP in July 2012. When/if the new code +is adopted, it will handle aircraft and ACARS qc and the acarsqc +program will be obsolete. Meanwhile, changes to the old prepacqc +(to work around a problem with TAMDAR data) are being written to +an OPS branch. (GEOSadas-5_9_1_p10_OPS_branch) + +Some routines updated with code merged from NCEP WCOSS versions. +The new versions require use of the new BUFR library (to use +setbmiss/getbmiss). + + 19 Nov 2015 + +latest tag 'meta_prepQC_fixesNov2015' for GEOSadas-5_13_2 +Changes relative to prior tag GEOSadas-5_13_1: + +Routines have been updated with the NCEP versions from WCOSS transition +or later - except for aircraft QC still using older code. (Not transitioned +to NRLqc for aircraft partly because BUFR table problems with older +prepbufr in the archive.) +There were a few problems found in the prepQC used in MERRA2 up to Nov 2015. +*There was a limit of 120000 observations (wind+mass combined) for ACARS with +observations beyond that limit being discarded. Array sizes were updated. +*The OIQC was failing to check upperair temperature and wind data - the +new WCOSS version no longer uses OpenMP (it is MPI only) and appears to +not have the problem. +*The old prepacqc (AMDAR/AIREP QC) routine was dropping some observations +for a 'receipt time check' - added a 'SAVE' statement so receipt times +would not be retained for the read of the second part of a report and +not zeroed out. (Change is on GEOSadas-5_9_1_p10_OPS_branch.) +Other routines have changes for WCOSS including adjustment of the +prepbufr missing value to a smaller number that does not cause an overflow +when cast to integer on Linux. 'cqcvad.x' increased array sizes. The +'prevents' code added a check to reject calm SFCSHP winds when the background +wind speed is > 5m/s. + diff --git a/src/Applications/NCEP_Paqc/GMAOprev/gblevents_gmao.f b/src/Applications/NCEP_Paqc/GMAOprev/gblevents_gmao.f index 84009038..978a0811 100644 --- a/src/Applications/NCEP_Paqc/GMAOprev/gblevents_gmao.f +++ b/src/Applications/NCEP_Paqc/GMAOprev/gblevents_gmao.f @@ -256,7 +256,9 @@ C 2014-05-08 JWhiting -- altered print statement (2 format) in GBLEVN10 C subroutine; increased field width for spectral resolution to C accommodate models w/ up to 5-digit resolution (I3 to I5). -C +C 2016-10-25 M. Sienkiewicz - REPLACE INCORRECT HEIGHTS FOR ACARS OBS +C ABOVE 226.3HPA. (INCORRECT CALCULATION IN MERRA PREPDATA PROCESSING +C PRIOR TO WCOSS TRANSITION.) CONTROL BY NAMELIST SWITCH 'ACARSH'. C 2020-11-19 M.SIENKIEWICZ -- IN GBLEVN06, MODIFY INTERPOLATION TO C CORRECT ARRAY ACCESS FOR SP STATION. (AFTER CHANGE TO PREPDATA C AND/OR BUFR LIBRARY THE SP LATITUDE LOADED IN YOB WAS SLIGHTLY @@ -490,6 +492,11 @@ C PG4243 =.TRUE. ---> GIVE ALL MASS VARIABLES A C PREPBUFR TBL. VAL. 15 C (DEFAULT=.TRUE.) +C ACARSH - RECALCULATE HEIGHTS FOR ACARS DATA WHEN P<226.3 MB +C ACARSH =.FALSE. ---> DO NOT CHANGE REPORTS +C ACARSH =.TRUE. ---> RECALCULATE STD. ATM. HEIGHT ABOVE 226.3 MB +C (DEFAULT=.TRUE.) +C C CC C @@ -525,7 +532,8 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, REAL(8) OBS_8,QMS_8,BAK_8,SID_8,HDR_8(10) REAL(8) BMISS,GETBMISS LOGICAL DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT,DOANLS, - $ SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243, + $ ACARSH DIMENSION IUNITF(2) @@ -533,7 +541,7 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVBB/ PVCD,VTCD COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243,ACARSH COMMON /GBEVDD/ ERRS(300,33,6) COMMON /GBEVFF/ BMISS @@ -555,7 +563,8 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, $ 'POE QOE TOE ZOE WOE PWE PW1E PW2E PW3E PW4E NUL NUL '/ NAMELIST /PREVDATA/DOVTMP,DOFCST,SOME_FCST,DOBERR,DOANLS, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243, + $ ACARSH C---------------------------------------------------------------------- C---------------------------------------------------------------------- @@ -592,6 +601,7 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, ADPUPA_VIRT = .FALSE. dopmsl = .false. PG4243 = .TRUE. + ACARSH = .TRUE. READ(5,PREVDATA,ERR=101,END=102) GO TO 103 C----------------------------------------------------------------------- @@ -627,6 +637,8 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, DOBERR = .FALSE. ADPUPA_VIRT = .FALSE. dopmsl = .false. + PG4243 = .FALSE. + ACARSH = .FALSE. ENDIF IF(DOVTMP) RECALC_Q=.TRUE. ! RECALC_Q must be T if DOVTMP is T WRITE (6,PREVDATA) @@ -838,6 +850,10 @@ SUBROUTINE GBLEVENTS(IDATEP,IUNITF,IUNITE,IUNITP,IUNITS,SUBSET, CALL GBLEVN08(IUNITP,SUBSET) ENDIF + if(SUBSET .EQ. 'AIRCAR ' .AND. ACARSH ) then + CALL ACARSFIX(IUNITP) + end if + C RETURN TO CALLING PROGRAM TO WRITE GBL-EVENTED REPORT (SUBSET) INTO C PREPBUFR FILE C ------------------------------------------------------------------- @@ -891,14 +907,14 @@ SUBROUTINE GBLEVN02(IUNITP,IUNITS,NEWTYP,subset) LOGICAL FCST,REJP_PS,REJPS,REJT,REJQ,REJW,REJPW,REJPW1, $ REJPW2,REJPW3,REJPW4,SATMQC,SATEMP,SOLN60,SOLS60, $ MOERR_P,MOERR_T,ADPUPA_VIRT,DOBERR,DOFCST,SOME_FCST, - $ DOVTMP,VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ DOVTMP,VIRT,RECALC_Q,DOPREV,dopmsl,PG4243,ACARSH REAL(8) BMISS COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVBB/ PVCD,VTCD COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243,ACARSH COMMON /GBEVEE/PSG01,ZSG01,TG01(500),UG01(500),VG01(500), x QG01(500),zint(500),pint(500),pintlog(500),plev(500), x plevlog(500) @@ -2190,13 +2206,13 @@ SUBROUTINE GBLEVN08(IUNITP,SUBSET) ! FORMERLY SUBROUTINE VTPEVN LOGICAL EVNQ,EVNV,DOVTMP,TROP,ADPUPA_VIRT,DOBERR,DOFCST, $ SOME_FCST,FCST,VIRT,SATMQC,RECALC_Q,DOPREV, - $ evnp,dopmsl,surf,PG4243 + $ evnp,dopmsl,surf,PG4243,ACARSH COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), $ XOB,YOB,DHR,TYP,NLEV COMMON /GBEVBB/ PVCD,VTCD COMMON /GBEVCC/ DOVTMP,DOFCST,SOME_FCST,DOBERR,FCST,VIRT, - $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243 + $ QTOP_REJ,SATMQC,ADPUPA_VIRT,RECALC_Q,DOPREV,dopmsl,PG4243,ACARSH COMMON /GBEVFF/ BMISS DATA EVNSTQ /'QOB QQM QPC QRC'/ @@ -2610,3 +2626,52 @@ subroutine hflip2 ( q,im,jm,dum ) q(:,j) = dum(:) enddo end subroutine hflip2 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! NASA/GSFC, Global Modeling and Assimilation Office, Code 610.1 ! +!----------------------------------------------------------------------- +!BOP +! +! !IROUTINE: ACARSFIX - modify std atm height for ACARS obs +! +! !INTERFACE: + + subroutine acarsfix(IUNITP) +! +! !INPUT PARAMETERS + INTEGER IUNITP ! BUFR OUTPUT UNIT NUMBER + +! !DESCRIPTION: Replace incorrect ACARS standard atmosphere heights +! that were written to MERRA obs files prior to WCOSS transition +! +! !REVISION HISTORY: +! +! 25Oct2016 M.Sienkiewicz Initial version +! +!EOP +!----------------------------------------------------------------------- + + real(8) zev_8(4) + integer iret + + COMMON /GBEVAA/ SID_8,OBS_8(13,255),QMS_8(12,255),BAK_8(12,255), + $ XOB,YOB,DHR,TYP,NLEV + COMMON /GBEVFF/ BMISS + COMMON /GBEVBB/ PVCD,VTCD + HGTF_HI(P) = 11000 - ALOG(P/226.3)/1.576106E-4 + + if (nlev.eq.1) then + pob = obs_8(1,1) + if (pob .lt. 226.3) then + zob = hgtf_hi(pob) + zev_8(1) = zob + zev_8(2) = qms_8(4,1) + zev_8(3) = pvcd + zev_8(4) = 43 + CALL UFBINT(IUNITP,ZEV_8,4,1,iret,' ZOB ZQM ZPC ZRC ') + CALL UFBINT(IUNITP,ZEV_8(1),1,1,iret,' ELV ') + end if + end if + return + end + diff --git a/src/Applications/NCEP_Paqc/GMAOprev/prevents.f b/src/Applications/NCEP_Paqc/GMAOprev/prevents.f index ad93f7ca..8fb97120 100644 --- a/src/Applications/NCEP_Paqc/GMAOprev/prevents.f +++ b/src/Applications/NCEP_Paqc/GMAOprev/prevents.f @@ -75,6 +75,8 @@ C STANDARD GET_ENVIRONMENT_VARIABLE; USE FORMATTED PRINT C STATEMENTS WHERE PREVIOUSLY UNFORMATTED PRINT WAS > 80 C CHARACTERS +C 2017-05-22 M. SIENKIEWICZ - CALL MAXOUT TO INCREASE MAX RECORD SIZE +C TO AVOID LOSING SOUNDING RECORDS THAT SLIGHTLY EXCEED MAX c c rename all REAL(8) variables as C *_8 @@ -232,6 +234,7 @@ PROGRAM PREPOBS_PREVENTS CALL OPENBF(IUNITI,'IN ',IUNITI) CALL OPENBF(IUNITP,'OUT',IUNITI) + call maxout(15000) C DETERMINE WHICH NETWORK WE ARE RUNNING UNDER C -------------------------------------------- diff --git a/src/Applications/NCEP_Paqc/README b/src/Applications/NCEP_Paqc/README old mode 100755 new mode 100644 index 13cc0381..e338ae82 --- a/src/Applications/NCEP_Paqc/README +++ b/src/Applications/NCEP_Paqc/README @@ -1,125 +1,16 @@ -README for NCEPQC - - 04 Sep 1997 - This code was obtained from NCEP on 14 Aug 1997 - * make_prepbufr.gbl.sh operational script - * bufrlib library of 'prepbufr' routines - * w3lib library of utility routines - * prepdata read input datasets, perform - QC checks not requiring background - * prevents interpolate background field to obs. - location and write 'events' - * acqc quality control of aircraft obs - (except ACARS) - * cqcht96 complex quality control of rawinsonde - height/temperature - (oiqc not included in this program set) - - - These programs have been run on the Cray J90 'charney' - using either ON29 or BUFR input to 'prepdata' - -11 Mar 1999 - Current snapshot of NCEPQC code used to run (ultimately) CQCHT. -This is not the final version for the operational system. Routines -in the 'w3lib' and 'bufrlib' that are not used by PREPDATA, PREVENTS, -or CQCHT are not included here. - - -26 Jul 1999 - New versions of NCEPQC 'prepdata' and 'prevents' have been -integrated into code base. The complex quality control is being tested -and will be added when ready. - Code was added to 'prevents' to work with GFIO files. The -following routines from the GFIO library are used: -GFIO_Open, GFIO_DimInquire, GFIO_Inquire, GFIO_GetVar, GFIO_Close - Note that (in general) the NCEP programs need to be compiled --i8 -r8 - with long integers. The calls to GFIO routines *are* being -performed with integer*4 variables, however. This has been tested with -the GFIO libraries in /ford1/local/IRIX64/pkg/gfio (which were compiled -as 'i4') and it works OK. - -12 Aug 1999 - The 'parms' subdirectory contains some tables and parameter -files used by the NCEP programs - -15 Jul 2004 (Todling) - - This now builds from buffer and w3 libs living under src/ncepshrd. - All compiles, but results still need to be check. - -26 Jan 2005 - Sienkiewicz - -Update of directory for MERRA. Moved files onto main branch. -Original code from NCEP replaced by updated code in new directories - -except for 'oiqc' and 'ssprev' - - 1 Jul 2008 - -Added new GMAO version of 'prevents' in GMAOprev directory. This version -reads the 'g5eta' format background fields directly. The new code is -adapted from the latest NCEP 'gblevents' code. - -Current directories: - block-unblock - utilities to add f77 filemarkers on BUFR files - * not on main CVS branch, should move out of PAQC? - combine_bfr - utilities and notes about combining BUFR files - * not on main CVS branch - oiqc - NCEP OIQC Optimal interpolation quality control - ssprev - Older version of NCEP prevents code to interpolate - background from spectral coeffs. Current NCEP version - is not compatible with our spectral files produced by - 'fv2ss'. Interim fix for MERRA, to be replaced by - native interpolation routine eventually - GMAOprev - New GMAO version of NCEP prevents code modified to - read g5-eta files directly. Uses newer version of - NCEP gblevents interpolation from eta levels. - - prepobs_acarsqc.fd - MDCARS (ACARS) QC routine from NCEP (Oct 05) - prepobs_cqcbufr.fd - Raob Complex Quality Control from NCEP (Oct 05) - prepobs_cqcvad.fd - VAD wind QC routine from NCEP (Oct 05) - prepobs_prepacqc.fd - Aircraft (except ACARS) QC routine from NCEP (Oct 05) - prepobs_profcqc.fd - Wind Profiler QC routine from NCEP (Oct 05) - -21 Mar 2013 - -Adding new directory modify_bufr with programs to modify BUFR files - -typically to change quality marks to undo blacklisting of observations. - -24 Sep 2013 - -The code in directory prepobs_prepacqc.fd was updated with the new -NRL aircraft QC adopted at NCEP in July 2012. When/if the new code -is adopted, it will handle aircraft and ACARS qc and the acarsqc -program will be obsolete. Meanwhile, changes to the old prepacqc -(to work around a problem with TAMDAR data) are being written to -an OPS branch. (GEOSadas-5_9_1_p10_OPS_branch) - -Some routines updated with code merged from NCEP WCOSS versions. -The new versions require use of the new BUFR library (to use -setbmiss/getbmiss). - - 19 Nov 2015 - -latest tag 'meta_prepQC_fixesNov2015' for GEOSadas-5_13_2 -Changes relative to prior tag GEOSadas-5_13_1: - -Routines have been updated with the NCEP versions from WCOSS transition -or later - except for aircraft QC still using older code. (Not transitioned -to NRLqc for aircraft partly because BUFR table problems with older -prepbufr in the archive.) -There were a few problems found in the prepQC used in MERRA2 up to Nov 2015. -*There was a limit of 120000 observations (wind+mass combined) for ACARS with -observations beyond that limit being discarded. Array sizes were updated. -*The OIQC was failing to check upperair temperature and wind data - the -new WCOSS version no longer uses OpenMP (it is MPI only) and appears to -not have the problem. -*The old prepacqc (AMDAR/AIREP QC) routine was dropping some observations -for a 'receipt time check' - added a 'SAVE' statement so receipt times -would not be retained for the read of the second part of a report and -not zeroed out. (Change is on GEOSadas-5_9_1_p10_OPS_branch.) -Other routines have changes for WCOSS including adjustment of the -prepbufr missing value to a smaller number that does not cause an overflow -when cast to integer on Linux. 'cqcvad.x' increased array sizes. The -'prevents' code added a check to reject calm SFCSHP winds when the background -wind speed is > 5m/s. - +README for NCEP_Paqc + - preprocessing QC programs from NCEP and some BUFR utilities + + * block-unblock add/remove f77 filemarkers on BUFR files + (not needed with current BUFR library) + * combine_bfr utilities and notes about combining BUFR files + * GMAOprev GMAO version of NCEP 'prevents' code modified to + read g5-eta files directly. + * modify_bufr utility programs to act on BUFR files + * oiqc NCEP OIQC Optimal interpolation quality control + * prepobs_cqcbufr.fd Raob Complex Quality Control from NCEP + * prepobs_cqcvad.fd VAD wind QC routine from NCEP + * prepobs_prepacqc.fd NCEP aircraft quality control base on NRL QC + * prepobs_profcqc.fd Wind Profiler QC routine from NCEP + * radcor Chris Redder's routines for applying Haimberger + radiosonde adjustments and NCEP radiation correction diff --git a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc index 050e27b1..6c58c049 100755 --- a/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc +++ b/src/Applications/NCEP_Paqc/oiqc/gmao_prepqc @@ -21,6 +21,11 @@ # 'gmao_prepqc' without fv2ss step. # 20Mar2009 Todling Remove DASPERL (per da Silva) # 17Nov2015 Meta Clean up some unused (old) fort.XX assignments +# 27Oct2016 Meta Some modifications for new NRL QC +# 02Feb2017 Meta Plumbing fixes for NRL QC - save profile file where it +# can be found by DAS, few other tweaks +# 18Oct2019 Meta Removed reference to 'Shell'; cleaned out +# code for old ACQC, ACARSQC #------------------------------------------------------------------ # make env vars readily available @@ -82,15 +87,9 @@ use File::Copy; # PREPACQC (Aircraft/AMDAR QC) # -------- $rc1 = system("zeit_ci.x -r $fvwork/.zeit pqc_arqc"); - acqc() if ($doACQC) ; + newacqc() if ($doACQC) ; $rc1 = system("zeit_co.x -r $fvwork/.zeit pqc_arqc"); - # ACARSQC (ACARS QC) - # ------- - $rc1 = system("zeit_ci.x -r $fvwork/.zeit pqc_acarsqc"); - acarsqc() if ($doACARSQC) ; - $rc1 = system("zeit_co.x -r $fvwork/.zeit pqc_acarsqc"); - # CQCVAD (Radar VAD wind QC) # ------ $rc1 = system("zeit_ci.x -r $fvwork/.zeit pqc_cqcvad"); @@ -106,6 +105,7 @@ use File::Copy; chdir($prepqcdir); copy("next.$nymd.$hh","$bfr"); + copy("acprof.$nymd.$hh","$cft"); # All done # -------- @@ -151,6 +151,7 @@ sub init { $dd = substr($nymd,6,2); $bfr1 = "$expid.prepqc.obs.${nymd}.t${hh}z.bfr" unless ( $bfr1 ); + $cft1 = "$expid.acft_profl.${nymd}.t${hh}z.bfr"; $spc = 254 unless ( $spc ); @@ -160,6 +161,7 @@ sub init { # Get full pathnames # ------------------ $bfr = fullpath($bfr1); + $cft = fullpath($cft1); $pref = fullpath($pref1); $dynf = fullpath($dynf1); if (! -e $dynf ) { @@ -452,7 +454,6 @@ sub cqcht { Assign("cqc_blktot.$nymd.$hh", 15 ); Assign("cqc_stnlst.$nymd.$hh", 16 ); - Assign("$expid.prog.cqcstats.$nymd", 21 ); Assign("cqc_winderr.$nymd.$hh", 22 ); Assign("$rcdir/prepobs_cqc_statbge", 23 ); @@ -598,10 +599,9 @@ sub profcqc { copy("prepprf.$nymd.$hh", "$prepqcdir/next.$nymd.$hh"); } - #...................................................................... -sub acqc { +sub newacqc { $acqcdir = "$prepqcdir/acqc"; # PREPQC working directory $rc = system("/bin/mkdir -p $acqcdir" ); @@ -615,71 +615,28 @@ sub acqc { # NOTE: these files do not follow the fv file name conventions # Many of the output files are discarded # ------------------------------------------------------------ - Assign("$prepqcdir/next.$nymd.$hh", 14 ); - Assign("$rcdir/prepobs_landc", 15 ); - Assign("$rcdir/prepobs_waypoints", 23 ); + Assign("$prepqcdir/next.$nymd.$hh", 11 ); + Assign("$rcdir/prepobs_prep.bufrtable", 12 ); + Assign("acftqc_${nymd}${hh}.vvl", 41 ); Assign("prepaqc.$nymd.$hh", 61 ); - Assign("aqc_sdmisol.$nymd.$hh", 52 ); - Assign("aqc_sdmxlim.$nymd.$hh", 53 ); - - $FORT_CONVERT15 = "BIG_ENDIAN"; + Assign("prepacqc_merge.$nymd.$hh", 62 ); # Run prepacqc # ------- - $cmd = "prepacqc.x < $rcdir/prepobs_prepacqc.merra.parm"; + $cmd = "prepacqc_profl.x < $rcdir/prepobs_prepacqc.merra.parm"; print "$0: $cmd\n" unless ( $opt_q ); $rc = system ( $cmd ) unless ( $opt_n ) ; die ">>>> ERROR <<< running prepacqc.x" if ( $rc ); # copy output file to 'next' so next routine will use it copy("prepaqc.$nymd.$hh", "$prepqcdir/next.$nymd.$hh"); - - undef $FORT_CONVERT15; - + copy("prepacqc_merge.$nymd.$hh","$prepqcdir/acprof.$nymd.$hh"); } #...................................................................... -sub acarsqc { - - $arqcdir = "$prepqcdir/acarqc"; # PREPQC working directory - $rc = system("/bin/mkdir -p $arqcdir" ); - die ">>> ERROR <<< cannot create $arqcdir " if ( $rc ); - chdir("$arqcdir"); - system("/bin/touch .no_archiving"); # working prepqc dir not to be archived - - -# Assign FORTRAN units for acarsqc -# ------------------------------------------------------------ - -# NOTE: these files do not follow the fv file name conventions -# Many of the output files are discarded -# ------------------------------------------------------------ - Assign("$prepqcdir/next.$nymd.$hh", 14 ); - Assign("$rcdir/prepobs_landc", 15 ); - - Assign("prepacr.$nymd.$hh", 61 ); - Assign("acr_sdmlist.$nymd.$hh", 52 ); - - $FORT_CONVERT15 = "BIG_ENDIAN"; - -# Run acarsqc -# ------- - $cmd = "acarsqc.x < $rcdir/prepobs_acarsqc.merra.parm"; - print "$0: $cmd\n" unless ( $opt_q ); - $rc = system ( $cmd ) unless ( $opt_n ) ; - die ">>>> ERROR <<< running acarsqc.x" if ( $rc ); - -# copy output file to 'next' so next routine will use it - copy("prepacr.$nymd.$hh", "$prepqcdir/next.$nymd.$hh"); - - undef $FORT_CONVERT15; - -} -#...................................................................... - # # System: This routine saves stdout/stderr, redirects it to a specified file, # runs a shell command using this new stdout/stderr, and finally @@ -771,8 +728,7 @@ DESCRIPTION gmao_prevents.x - computes O-F cqcbufr.x - radiosonde QC profcqc.x - profiler CQC - prepacqc.x - aircraft qc (other than ACARS) - acarsqc.x - ACARS (MDCARS) aircraft qc + prepacqc_prof.x - aircraft qc oiqcbufr.x - performs actual OIQC The following parameters are required diff --git a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/CMakeLists.txt b/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/CMakeLists.txt deleted file mode 100644 index 365d8c61..00000000 --- a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/CMakeLists.txt +++ /dev/null @@ -1,20 +0,0 @@ -# This is equivalent to FOPT= in GNU Make -if (CMAKE_Fortran_COMPILER_ID MATCHES Intel) - string (REPLACE "${FOPT3}" "" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) - string (REPLACE "${OPTREPORT0}" "" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) - string (REPLACE "${FTZ}" "" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) - string (REPLACE "${ALIGN_ALL}" "" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) - string (REPLACE "${NO_ALIAS}" "" CMAKE_Fortran_FLAGS_RELEASE ${CMAKE_Fortran_FLAGS_RELEASE}) -endif () - -ecbuild_add_executable ( - TARGET acarsqc.x - SOURCES acarsqc.f - LIBS NCEP_bufr_r4i4 NCEP_w3_r4i4 NCEP_bacio_r4i4) - -if (EXTENDED_SOURCE) - set_target_properties (acarsqc.x PROPERTIES COMPILE_FLAGS ${EXTENDED_SOURCE}) -endif() - -file(GLOB parm_files *.parm) -install(FILES ${parm_files} DESTINATION etc) diff --git a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/acarsqc.f b/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/acarsqc.f deleted file mode 100755 index 5f446ac1..00000000 --- a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/acarsqc.f +++ /dev/null @@ -1,2734 +0,0 @@ -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: PREPOBS_ACARSQC -C PRGMMR: KEYSER ORG: NP22 DATE: 2011-03-30 -C -C ABSTRACT: READS IN PREPBUFR FILE CONTAINING ALL PREPROCESSED DATA -C TYPES. {ONLY BUFR TABLE A ENTRY MESSAGES "AIRCAR " ARE OPERATED -C ON.} PERFORMS CERTAIN RUDIMENTARY QUALITY CHECKS ON THE DATA -C (E.G., GROSS CHECKS AND SANITY CHECK). SORTS BY STATION ID, DOES -C TRACK CHECKING (NOT YET), AND AGGRAGATES OBS BY POSITION (CALLED -C A 'STACK'). DOES QUALITY CONTROL BY MAKING TRACK CHECKS ON -C FLIGHTS (NOT YET), REMOVING DUPLICATES (NOT YET) AND COMPARING -C COLOCATED OBSERVATIONS, (NOT YET). A SERIES OF NEW PREPBUFR -C QUALITY MARKS ARE ATTACHED TO EACH OBSERVATION (SEE REMARKS). -C FINALLY: WRITES STACKED EVENTS (CONSISTING OF THE UPDATED PREPBUFR -C QUALITY MARKS) ONTO THE EXISTING PREPBUFR DATA. IN ALL CASES, THE -C NEW FILE CONTAINS ALL OF THE ORIGINAL OBSERVATIONAL DATA (P-ALT, -C TEMP, SPECIFIC HUMIDITY, WIND) MINUS THE DUPLICATES (IF ANY) AND -C THOSE OUTSIDE THE DESIRED TIME WINDOW. FUTURE Q.C. MAY INVOLVE -C CHECKS OVER CONUS VS. OUTSIDE CONUS. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM EXISITNG -C PROGRAM "PREPOBS_PREPACQC") -C 2008-09-25 D. A. KEYSER -- IN RESPONSE TO CHANGE FROM SINGLE LEVEL -C TO DELAYED REPLICATION FOR "AIRCAR" REPORT LEVEL DATA NOW -C IN PREPBUFR FILE (IN PREPARATION FOR NRL AIRCRAFT QC -C PROGRAM WHICH WILL REPLACE THIS PROGRAM 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 2009-08-03 D. A. KEYSER -- WILL NO LONGER TRY TO PULL OUT RECEIPT -C TIME (RCT) FROM PRE-DECEMBER 2008 VERSIONS OF PREPBUFR -C FILE WHICH DO YET INCLUDE IT IN ACARS REPORT HEADER (DONE -C SO THAT CFSRR RUNS WILL NOT FAIL) -C 2011-03-30 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX" -C FROM 60000 TO 90000, "ISMX" FROM 2000 TO 4000, "ISUP" -C FROM 1000 TO 2000, AND "ITMX" FROM 2000 TO 4000 - ALL TO -C ACCOUNT FOR INCREASED NUMBER OF REPORTS NOW BEING DECODED -C DUE TO THE NEW INCLUSION OF ALASKAN ACARS REPORTS; IF -C "IRMX" IS EXCEEDED, CODE NO LONGER FAILS BUT RATHER -C PROCESSES FIRST "IRMX" REPORTS AND POSTS A WARNING -C MESSAGE TO THE PRODUCTION JOBLOG FILE -C 2012-12-07 M. SIENKIEWICZ -- INCREASED "IRMX" TO 120000 TO HANDLE -C INCREASE IN ACARS REPORTS IN NOV 2012 -C 2015-11-10 M. SIENKIEWICZ -- INCREASED "IRMX" TO 200000 TO HANDLE -C INCREASE IN ACARS REPORTS SINCE 2012 -C 2019-12-10 M. SIENKIEWICZ -- INCREASED "IRMX" TO 250000 TO HANDLE -C INCREASE IN ACARS REPORTS SINCE 2015 -C -C INPUT FILES: -C UNIT 05 - NAMELIST INPUT -C UNIT 14 - PREPBUFR 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. CONUS 1 DEG -C LAT/LON YES/NO INDICATOR (NOT YET USED IN ANY -C CHECKS, BUT PROVIDED FOR FUTURE NEEDS) -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C UNIT 52 - TEXT FILE FOR SDM PERUSAL (LIST OF REPORTS -C - THAT ARE FLAGGED FOR NON-USE BY THIS PROGRAM AS WELL -C - AS THOSE WITH LARGE INCREMENTS) -C UNIT 61 - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACARS QC) -C -C SUBPROGRAMS CALLED: -C UNIQUE: - RPACKR INDEXF INDEXC TRKCHK ACCOUNT -C - IDSORT FORSDM DBUFR IBUFR OBUFR -C - CMDDFF -C LIBRARY: -C SYSTEM - SYSTEM -C W3LIB : - W3FI04 ERREXIT -C BURLIB: - DATELEN OPENBF READMG READSB UFBINT -C - CLOSBF OPENMB UFBCPY WRITSB UFBCNT -C - COPYMG UFBQCD CLOSMG STATUS NEMTAB -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C COND = 04 - NO REPORTS WERE PROCESSED (NO "AIRCAR" TABLE A -C MESSAGES FOUND) -C COND = 22 - CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR -C - EBCDIC -C COND = 70 - THE NUMBER OF LEVELS IN A DECODED REPORT'S HEADER -C - AND/OR OBS. AND/OR FCST LVL IS NOT 1 -C -C REMARKS: SEE COMMENT CARDS FOLLOWING DOCBLOCK. -C THE FOLLOWING DESCRIBE THE COMMON BLOCKS IN THIS PROGRAM: -C /ALLDAT/ -- CONTAINS ARRAYS FOR ALL ACARS OBSERVATIONS -C /SUMDAT/ -- CONTAINS ARRAYS FOR ONLY GROUP OF STACKED OBS. -C -C THE POSSIBLE OUTPUT QUALITY MARKERS ARE DEFINED AS FOLLOWS: -C (WHERE: 'T' IS TEMPERATURE, 'Q' IS SPECIFIC HUMIDITY AND -C 'W' IS WIND) -C -C PREPBUFR -C ORIGINAL SDM KEEP FLAG MAINTAINED (T/Q/W)......... 0 -C CHECKED BY THIS PROGRAM AND GOOD (T/Q/W).......... 1 -C ORIGINAL DATA NOT CHECKED BY THIS PROGRAM (T/Q/W). 2 -C ORIGINAL DATA MISSING (T/Q/W)..................... 15 -C CHECKED BY THIS PROGRAM AND SUSPECT (T/Q/W)....... 3 -C CHECKED BY THIS PROGRAM AND BAD/FAILED (T/Q/W).... 13 -C ORIGINAL SDM PURGE FLAG MAINTAINED (T/Q/W)........ 14 -C -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ -CC -C ***** VARIABLES IN NAMELIST INPUT READ IN MAIN PROGRAM ***** -CC -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 {NOTE: THE MAXIMUM VALUE FOR WINDOW IS 5.75 (5-HOURS, -C 45-MINUTES; ANYTHING LARGER WILL RESULT IN ERROR!} -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 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) -CC -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, 70 TO 90 DEGREES (N +) -CC -C JAMASS - PROCESS ACARS 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 ACARS 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/) -CC -C FWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF FINAL LISTING -C OF ORIGINAL REPORTS IN AIRCAR FILE WITH NEW Q. MARKS -C FWRITE=.TRUE. ---> PRODUCE PRINTOUT -C FWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -C IWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF INPUT LISTING -C OF ORIGINAL REPORTS IN AIRCAR FILE BEFORE IDSORT, AFTER -C IDSORT, AND AFTER TRACK CHECK -C IWRITE=.TRUE. ---> PRODUCE PRINTOUT -C IWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -C EWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF "EVENTS" -C (WHEN A BUFR EVENT OCCURS, I.E. CHANGING A QUALITY MARK) -C {NOTE: DOES NOT APPLY TO EVENT # 7 (SEE EWRITE_7)} -C EWRITE=.TRUE. ---> PRODUCE PRINTOUT -C EWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -C EWRITE_7 - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF EVENT # 7 -C (REPORT WITH A TEMP, SPEC. HUMIDITY AND/OR WIND THAT -C HAS PASSED ALL CHECKS AND IS CONSIDERED TO BE GOOD) -C {NOTE: DOES NOT APPLY TO OTHER EVENT NUMBERS -C (SEE EWRITE)} -C EWRITE_7=.TRUE. ---> PRODUCE PRINTOUT -C EWRITE_7=.FALSE. --> NO PRINTOUT (DEFAULT) -CCCCC - PROGRAM PREPOBS_ACARSQC -C -C PARAMETER NAME "IRMX" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM -C NUMBER OF ACARS RPTS THAN CAN BE UNPACKED FROM THE INPUT FILE CHOSEN -C PARAMETER NAME "ISMX" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM -C NUMBER OF ACARS RPTS THAT CAN BE TREATED IN A STACK - PARAMETER (IRMX= 250000, ISMX= 4000) -C PARAMETER NAME "ISUP" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM -C NUMBER OF SUPEROBED REPORTS THAT CAN BE PROCESSED - PARAMETER (ISUP= 2000) -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) - PARAMETER (ISIZE= 18) - - LOGICAL FWRITE,IWRITE,EWRITE,EWRITE_7,RCPTST - - CHARACTER*1 CF,INACMK(11),PF,CINCR - CHARACTER*4 SPEC5,SPEC6,SSMARK - CHARACTER*6 CIRMX - CHARACTER*8 ACID,SAID,IDENT,AAID(IRMX) - CHARACTER*16 TAG,CTAG(IRMX),STAG(IRMX) - - INTEGER IDATA(1608),NNIN(11),IDSTR(400,2) - - REAL RDATA(1608) - - COMMON/OUTPUT/KNTOUT(2) - COMMON/SUMDAT/SAID(ISMX),SLAT(ISMX),SLON(ISMX),SHGT(ISMX), - $ STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX),SSPH(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) - COMMON/ACCONT/KISO(11) - COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST - COMMON/STWRIT/EWRITE,EWRITE_7,IWRITE - COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - COMMON/CBUFR/IDENT,IRCTME,RDATA,KIX,CINCR,CF,PF - COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP), - $ SSTMP(ISUP),SSSPH(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP), - $ SSTMPF(ISUP),SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP) - COMMON/STDATE/IDATE(5) - COMMON/WORD/ICHTP - COMMON/QUALITY/ITQM,IQQM,IWQM - COMMON/NEWTABLE/IPRSLEVLA - - NAMELIST/INPUT/WINDOW,FWRITE,IWRITE,EWRITE,EWRITE_7,JAMASS,JAWIND, - $ RCPTST - - EQUIVALENCE (RDATA,IDATA) - - DATA XMSG/99999./,INACMK/'Q','R','S','T','U','V','W','X','Y','Z', - $ 'N'/ - - CALL W3TAGB('PREPOBS_ACARSQC',2011,0089,0087,'NP22') - - PRINT 2111 - 2111 FORMAT(//11X,'***** WELCOME TO THE ACARS QUALITY CONTROL ', - $'PROGRAM ACARSQM -- VERSION CREATED 30 MAR 2011 *****'/) - -C CALL W3FI04 TO DETERMINE MACHINE WORD LENGTH (BYTES) -C AND TO TEST FOR ASCII(ICHTP=0) OR EBCDIC(ICHTP=1) CHARACTERS - CALL W3FI04(IENDN,ICHTP,LW) - PRINT 2213, LW, ICHTP, IENDN - 2213 FORMAT(/' ---> CALL TO W3FI04 RETURNS: LW = ',I3,', ICHTP = ',I3, - $ ', IENDN = ',I3/) - IF(ICHTP.GT.1) THEN -C----------------------------------------------------------------------- -C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22 - PRINT 217 - 217 FORMAT(/5X,'++ CHARACTERS ON THIS MACHINE ARE NEITHER ASCII', - $ ' NOR EBCDIC - STOP 22'/) - CALL W3TAGE('PREPOBS_ACARSQC') - CALL ERREXIT(22) -C----------------------------------------------------------------------- - END IF - -C INITIALIZE CONSTANTS FOR ACCOUNTING - KDUP = 0 - ICNT1 = 0 - KISO = 0 - NNIN = 0 - -C READ IN NAMELIST, FIRST SET-UP ANY DEFAULTS - WINDOW = 3.00 - RCPTST = .TRUE. - FWRITE = .FALSE. - IWRITE = .FALSE. - EWRITE = .FALSE. - EWRITE_7 = .FALSE. - JAMASS = 0 - JAWIND = 0 - READ(5,INPUT,END=9222) - - 9222 CONTINUE - -C GET DATE OF PREPBUFR FILE - CALL DBUFR(IDATEP) - IDATE(1) = IDATEP/1000000 - IDATE(2) = MOD((IDATEP/10000),100) - IDATE(3) = MOD((IDATEP/100),100) - IDATE(4) = MOD(IDATEP,100) - IDATE(5) = 0 - KOUNT = 0 - KNTIN = 0 - KNTOUT = 0 - TBASE = REAL(IDATE(4) * 100.) - IF(NINT(TBASE).LT.600) TBASE = TBASE + 2400. -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 (FUTURE).) - 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 - 1111 FORMAT(39X,'===> OPERATIONAL AIRCAR FILE HAS DATE: ',I6,4I4/ - $ 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//) - WRITE(6,INPUT) - -C READ IN N.H. CONUS MASK (1 DEG GRID); IF MASK > 0 THEN GRID LOCATED -C HERE -- THIS IS NEEDED LATER IN PROGRAM (FUTURE) - PRINT 101 - 101 FORMAT(/1X,'**** OPEN UNIT 15 TO GET CONUS GRID FOR POSSIBLE ', - $ 'LOCATION CHECKS ****'/) - READ(15,ERR=8814) GDNH - READ(15,ERR=8814) GDSH - READ(15,ERR=8814) GDUS - GO TO 8812 -C----------------------------------------------------------------------- - 8814 CONTINUE -C PROBLEM W/ READ; INIT. GDUS ARRAY TO 0 - (HAVE TO ASSUME ALL N.H. OBS. -C ARE OUTSIDE OF CONUS REGION) - GDUS = 0.0 - PRINT 102 - 102 FORMAT(/' +++> TROUBLE READING U.S. MASK FILE; ASSUME ALL N.H. ', - $ 'DATA OUTSIDE CONUS REGION IN ANY CONUS TEST'/) -C----------------------------------------------------------------------- - - 8812 CONTINUE - IF(IWRITE) PRINT 6176 - 6176 FORMAT(/' LISTING OF ORIGINAL DATA BEFORE IDSORT----'/9X,'ACID', - $ 7X,'LAT WLON UTC ALT TEMP SHUM DIR SPD -QM ----TAGS', - $ '----- ITP RPTIME KNTINI GALT GTEMP GDIR GSPD'/) - - 5 CONTINUE - - ALTF = XMSG - DIRF = XMSG - SPDF = XMSG - TMPF = XMSG -C*********************************************************************** -C READ IN NEXT ACARS REPORT -C*********************************************************************** - IY = 43 - SPEC5 = '----' - SPEC6 = '----' - CALL IBUFR(ALTF,DIRF,SPDF,TMPF,*2) - SPEC5(3:3) = PF - SPEC6(3:3) = CF - IF(KOUNT+1.GT.IRMX) THEN -C....................................................................... -C THERE ARE MORE RPTS IN INPUT FILE THAN "IRMX" -- DO NOT PROCESS ANY -C MORE REPORTS - PRINT 53, IRMX,IRMX - 53 FORMAT(/' #####> WARNING: THERE ARE MORE THAN ',I7,' ACARS ', - $ 'REPORTS IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER NAME', - $ ' "IRMX" - WILL, CONTINUE ON PROCESSING ONLY ',I7,' REPORTS'/) - WRITE(CIRMX,'(I6)') IRMX -! CALL SYSTEM('[ -n "$jlogfile" ] && $DATA/postmsg'// -! $ ' "$jlogfile" "***WARNING:'//CIRMX//' ACARS REPORT LIMIT '// -! $ 'EXCEEDED IN PREPOBS_ACARSQC, ONLY '//CIRMX//' RPTS '// -! $ 'PROCESSED"') - CALL CLOSBF(14) - PRINT 301 - 301 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY', - $ ' CLOSED FROM INITIAL READ OF ACARS OBS.') - go to 2 -ccccc CALL W3TAGE('PREPOBS_ACARSQC') -ccccc CALL ERREXIT(20) -C....................................................................... - END IF - KOUNT = KOUNT + 1 - KNTIN = KNTIN + 1 - KNTINI(KOUNT) = KNTIN - TAG(KOUNT)(12:12) = '-' - ALAT(KOUNT) = RDATA(1) - ALON(KOUNT) = RDATA(2) - INTP(KOUNT) = IDATA(8) - - IF(NINT(ALON(KOUNT)*100.).EQ.36000) ALON(KOUNT) = 0.0 -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) - IF(NINT(ALAT(KOUNT)*100.).GT.9000.OR.NINT(ALAT(KOUNT)*100.).LT. - $ -9000) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE LAT - SET TO MSG!!' -CAAAAA%%%%% - ALAT(KOUNT) = XMSG - TAG(KOUNT)(12:12) = '@' - END IF - IF(NINT(ALON(KOUNT)*100.).GT.36000.OR.NINT(ALON(KOUNT)*100.).LT. - $ 0) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE LON - SET TO MSG!!' -CAAAAA%%%%% - ALON(KOUNT) = XMSG - TAG(KOUNT)(12:12) = '@' - END IF - - ACID(KOUNT) = IDENT - TIME(KOUNT) = RDATA(4) -CVVVVV%%%%% - IF(NINT(TIME(KOUNT)).GT.2400.OR.NINT(TIME(KOUNT)).LT.0) - $ PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE TIME, TOSSED?' -CAAAAA%%%%% - IRTM(KOUNT) = IRCTME - -C DO A TIME CHECK ON REPORT -- IF OUTSIDE EXPANDED INPUT WINDOW TOSS IT - ITIME = NINT(TIME(KOUNT)) - IF(NINT(TBASE).GT.2300.AND.NINT(TIME(KOUNT)).LE. - $ (IDATE(4)*100)+600) TIME(KOUNT) = TIME(KOUNT) + 2400. - IF(TIME(KOUNT).LT.TMIN.OR.TIME(KOUNT).GT.TMAX) THEN -C SKIP REPORTS OUTSIDE REQUESTED TIME WINDOW -CCCCCC PRINT 9002,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),TIME(KOUNT) -C9002 FORMAT(/' ##########: MAIN; REPORTS OUTSIDE TIME WINDOW SKIPPED.', -CCCCC$ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F4.0) - KOUNT = KOUNT - 1 - GO TO 5 - END IF - - IF(RCPTST.AND.IRCTME.LE.2400) THEN -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 - IF(ITIME.LT.100) ITIME = ITIME + 2400 - IETIME = ITIME - 100 - ILTIME = ITIME + 1199 - IF(IRCTME.LT.IETIME.OR.IRCTME.GT.ILTIME) THEN -C RECEIPT TIME IS OUTSIDE EXPECTED RANGE, BUT MAY BE AROUND 00Z SO ADD -C 2400 TO RECEIPT TIME AND TEST AGAIN - IRCTMN = IRCTME + 2400 - IF(IRCTMN.LT.IETIME.OR.IRCTMN.GT.ILTIME) THEN -C RECEIPT TIME IS STILL OUTSIDE EXPECTED RANGE, SKIP REPORT -CVVVVV%%%%% - PRINT *,'~~~~~ THE STRANGE RECEIPT TIME DIFF. HAS OCCURRED!!' -CAAAAA%%%%% - PRINT 9393, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),IRCTME,SPEC6(3:3) - 9393 FORMAT(/' ##########: SKIP RPTS WHERE OBS. & RCPT. TIME ARE INCON' - $,'SISTENT ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F4.0,'; REC. TIME ',I4, - $ '; CAFB? ',A1) - KOUNT = KOUNT - 1 - GO TO 5 - END IF - END IF - END IF - - AALT(KOUNT) = RDATA(IY) - ADIR(KOUNT) = RDATA(IY+3) - ASPD(KOUNT) = RDATA(IY+4) - ATMP(KOUNT) = RDATA(IY+1) - ASPH(KOUNT) = RDATA(IY+2) -C FILL IN FORECAST VALUES FOR ALTITUDE, WIND DIR., WIND SPEED & TEMP. - AALTF(KOUNT) = ALTF - ADIRF(KOUNT) = DIRF - ASPDF(KOUNT) = SPDF - ATMPF(KOUNT) = TMPF - ITEVNT(KOUNT) = 0 - IQEVNT(KOUNT) = 0 - IWEVNT(KOUNT) = 0 -C*********************************************************************** -C*********************************************************************** -C INPUT AIRCAR TABLE A ENTRY MESSAGE QUALITY MARKER SITUATION - -C (P-ALTITUDE, TEMPERATURE. SPECIFIC HUMIDITY AND WIND) -C -C WILL CONTAIN VALUE OF 14 IF 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 ACARS FLIGHT NUMBER (UP TO EIGHT CHARACTERS) -C +++ CONTAINS SCALED VECTOR WIND INCREMENT (USES ASSIMILATING -C FORECAST DIRECTLY, ASSUMING FCST U AND V ARE IN BUFR DATA) -C +++ CONTAINS RECEIPT TIME (HOURS) -C +++ CONTAINS INSTRUMENT TYPE -C -C -C OUTPUT QUALITY MARKER SITUATION - SEE DOCBLOCK REMARKS -C (P-ALTITUDE, TEMPERATURE. SPECIFIC HUMIDITY AND WIND) -C -C -C EVENTS WRITTEN BY THIS PROGRAM INTO OUTPUT PREPBUFR 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 1 MAIN REPORT WITH AN ALTITUDE > 16,500 METERS TEMP = 13 -C (~95 MB). PROBABLY A MISCODED REPORT. SHUM = 13 -C TEMPERATURE, SPECIFIC HUMIDITY AND/OR WIND = 13 -C WIND CONSIDERED BAD IF PRESENT. -C -C 2 MAIN REPORT WITH A LATITUDE OF 0 DEGREES. COULD TEMP = 13 -C BE A MISCODED REPORT. TEMPERATURE, WIND = 13 -C SPECIFIC HUMIDITY AND/OR WIND CONSIDERED SHUM = 13 -C BAD IF PRESENT. -C -C 3 MAIN REPORT WITH A LONGITUDE OF 0 DEGREES. TEMP = 13 -C COULD BE A MISCODED REPORT. TEMPERATURE, WIND = 13 -C SPECIFIC HUMIDITY AND/OR WIND CONSIDERED SHUM = 13 -C BAD IF PRESENT. -C -C 4 MAIN REPORT WITH CALM WIND. WIND CONSIDERED BAD WIND = 13 -C IF PRESENT. -C -C 5 MAIN REPORT WITH ALTITUDE BETWEEN 2000 & 5000 FT. TEMP = 13 -C WITH TEMPERATURE THAT DIFFERS FROM GUESS SHUM = 13 -C BY > 25 DEG. C {PROBABLY DUE TO "0" DIGIT WIND = 13 -C DROPPED FROM REPORTED ALTITUDE (TRUE -C ALTITUDE BETWEEN 20,000 & 50,000 FT.)} -C TEMPERATURE, SPECIFIC HUMIDITY AND/OR WIND -C CONSIDERED BAD IF PRESENT. -C -C 6 RPACKR REPORT WITH A MISSING PHASE OF FLIGHT TEMP = 3 -C INDICATOR (PROBABLY BANKING). TEMPERATURE, SHUM = 3 -C SPECIFIC HUMIDITY AND/OR WIND CONSIDERED WIND = 3 -C SUSPECT IF PRESENT. -C -C 7 RPACKR REPORT WITH A TEMPERATURE, SPECIFIC HUMIDITY TEMP = 1 -C AND/OR WIND THAT HAS PASSED ALL CHECKS. SHUM = 1 -C TEMPERATURE, SPECIFIC HUMIDITY AND/OR WIND WIND = 1 -C CONSIDERED GOOD IF PRESENT. -C -C 8 RPACKR REPORT WITH A TEMPERATURE THAT HAS FAILED SHUM = 13 -C ONE OR MORE CHECKS AND IS CONSIDERED BAD. -C SPECIFIC HUMIDITY CONSIDERED BAD. -C -C -C*********************************************************************** -C -C EACH REPORT CARRIES WITH IT IN THIS PROGRAM THE FOLLOWING 'TAG' INFO: -C -C BYTE 1 : +++ TEMPERATURE QUALITY MARKER -C "H" - Manual (SDM) Keep -C "A" - Good -C "-" - Neutral -C "Q" - Suspect -C "F" - Failed -C "P" - Manual (SDM) Purge -C BYTE 2 : +++ SPECIFIC HUMIDITY QUALITY MARKER -C "H" - Manual (SDM) Keep -C "A" - Good -C "-" - Neutral -C "Q" - Suspect -C "F" - Failed -C "P" - Manual (SDM) Purge -C BYTE 3 : +++ WIND QUALITY MARKER -C "H" - Manual (SDM) Keep -C "A" - Good -C "-" - Neutral -C "Q" - Suspect -C "F" - Failed -C "P" - Manual (SDM) Purge -C BYTE 4 : WILL CONTAIN 'D' IF THIS REPORT IS A DUPLICATE -C : ELSE WILL BE '-' IF THIS REPORT IS NOT A DUPLICATE -C BYTE 5 : +++ SCALED VECTOR INCREMENT VALUE : WILL CONTAIN -C 'Q' - 'Z' IF INCREMENT COULD BE PRODUCED -C : ELSE WILL CONTAIN 'N' IF NOT CALCULATED -C BYTE 6 : +++ TEMPERATURE PRECISION -C : WILL CONTAIN '0' IF LOW PRECISION -C : WILL CONTAIN '1' IF HIGH PRECISION -C : ELSE WILL BE '-' IF TEMPERATURE PRECISION NOT -C REPORTED -C BYTE 7 : +++ CURRENTLY NOT USED AND SET TO '-' -C BYTE 8 : +++ 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 '-' IF NONE OF ABOVE -C BYTE 9 : +++ CURRENTLY NOT USED AND SET TO '-' -C BYTE 10 : +++ PHASE OF FLIGHT INDICATOR -C : WILL CONTAIN '0' - '2' IF RESERVED -C : WILL CONTAIN '3' IF LVL FLIGHT, ROUTINE OBSERVATION -C : WILL CONTAIN '4' IF LVL FLIGHT, HIGHEST WIND ENCOUNTERED -C : WILL CONTAIN '5' IF ASCENDING -C : WILL CONTAIN '6' IF DESCENDING -C : WILL CONTAIN '7' IF MISSING (PROBABLY BANKING) -C BYTE 11 : +++ CURRENTLY NOT USED AND SET TO '-' -C BYTE 12 : +++ INDICATOR FOR "BAD" REPORTS EXCLUDED FROM CHECKS -C : WILL CONTAIN '@' IF A "BAD"/EXCLUDED REPORT -C : ELSE WILL BE '-' -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 BYTE 15 : +++ NUMERICAL VALUE FOR SPECIFIC HUMIDITY QUALITY MARKER -C : LOWER NUMBER ALWAYS SUPERCEDES HIGHER NUMBER (SEE && ) -C BYTE 16 : +++ TRACK CHECK INDICATOR -C : WILL CONTAIN 'E' IF SUSPECTED TRACK CHECK ERROR -C : ELSE WILL BE '-' -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' -- RESERVED FOR FUTURE USE -C '5' -- SUSPECT ('Q') -C '6' -- GOOD ('A') -C '7' -- CANNOT BE CHECKED/UNTREATABLE OR NOT CHECKED (' ' OR -C '-') -C '8' -- INITIAL VALUE -C -C - - TAG(KOUNT)(1:4) = '----' - TAG(KOUNT)(5:5) = CINCR - TAG(KOUNT)(6:9) = '----' - TAG(KOUNT)(10:10) = SPEC5(3:3) - TAG(KOUNT)(11:11) = '-' - TAG(KOUNT)(13:15) = '888' - TAG(KOUNT)(16:16) = '-' - - IF(MAX(ASPD(KOUNT),ADIR(KOUNT)).GE.XMSG) THEN -C IF WIND IS MISSING, QUALITY MARKER IS SET TO 'x' - TAG(KOUNT)(3:3) = 'x' - TAG(KOUNT)(15:15) ='2' - ELSE IF(IWQM.EQ.14) THEN -C IF SDM PURGE FLAG ON WIND, WIND Q.M. IS SET TO 'P' - PRINT 9029, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9029 FORMAT(/' P-P-P-P-P-: SDM PURGE FLAG ON WIND, WIND Q.M. IS ', - $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'P' - TAG(KOUNT)(15:15) = '1' - ELSE IF(IWQM.EQ.0) THEN -C IF SDM KEEP FLAG ON WIND, WIND Q.M. IS SET TO 'H' - PRINT 8029, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 8029 FORMAT(/' H-H-H-H-H-: SDM KEEP FLAG ON WIND, WIND Q.M. IS ', - $ 'SET TO "H"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'H' - TAG(KOUNT)(15:15) = '1' - ELSE IF(IWQM.GT.3.AND.IWQM.LT.16) THEN -C IF EXISTING BAD Q.M. ON WIND, WIND Q.M. IS SET TO 'F' - PRINT 9629, IWQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9629 FORMAT(/' F-F-F-F-F-: EXISTING BAD QM ON WIND (=',I2,'), WIND ', - $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X, - $ A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - END IF - - IF(ATMP(KOUNT).GE.XMSG) THEN -C IF TEMPERATURE IS MISSING, QUALITY MARKER IS SET TO 'x' - TAG(KOUNT)(1:1) = 'x' - TAG(KOUNT)(13:13) = '2' - ELSE IF(ITQM.EQ.14) THEN -C IF SDM PURGE FLAG ON TEMPERATURE, TEMPERATURE Q.M. IS SET TO 'P' - PRINT 9039, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9039 FORMAT(/' P-P-P-P-P-: SDM PURGE FLAG ON TEMP, TEMP Q.M. IS ', - $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'P' - TAG(KOUNT)(13:13) = '1' - IF(ASPH(KOUNT).LT.XMSG) THEN -C IF SDM PURGE FLAG ON TEMPERATURE, SPECIFIC HUMIDITY Q.M. IS SET TO 'P' -C (UNLESS SPECIFIC HUMIDITY IS MISSING) - PRINT 9049, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9049 FORMAT(/' P-P-P-P-P-: SDM PURGE FLAG ON TEMP, SHUM Q.M. IS ', - $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'P' - TAG(KOUNT)(14:14) = '1' - END IF - ELSE IF(ITQM.EQ.0) THEN -C IF SDM KEEP FLAG ON TEMPERATURE, TEMPERATURE Q.M. IS SET TO 'H' - PRINT 8039, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 8039 FORMAT(/' H-H-H-H-H-: SDM KEEP FLAG ON TEMP, TEMP Q.M. IS ', - $ 'SET TO "H"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'H' - TAG(KOUNT)(13:13) = '1' - ELSE IF(ITQM.GT.3.AND.ITQM.LT.16) THEN -C IF EXISTING BAD Q.M. ON TEMP, TEMP Q.M. IS SET TO 'F' - PRINT 9639, ITQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9639 FORMAT(/' F-F-F-F-F-: EXISTING BAD QM ON TEMP (=',I2,'), TEMP ', - $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X, - $ A13/) - TAG(KOUNT)(1:1) = 'F' - TAG(KOUNT)(13:13) = '3' - IF(ASPH(KOUNT).LT.XMSG) THEN -C IF EXISTING BAD Q.M. ON TEMPERATURE, SPECIFIC HUMIDITY Q.M. IS SET TO -C 'P' (UNLESS SPECIFIC HUMIDITY IS MISSING) - PRINT 9099, ITQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9099 FORMAT(/' F-F-F-F-F-: EXISTING BAD QM ON TEMP (=',I2,'), SHUM ', - $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X, - $ A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - END IF - END IF - - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(ASPH(KOUNT).GE.XMSG) THEN -C IF SPECIFIC HUMIDITY IS MISSING, QUALITY MARKER IS SET TO 'x' - TAG(KOUNT)(2:2) = 'x' - TAG(KOUNT)(14:14) ='2' - ELSE IF(IQQM.EQ.14) THEN -C IF SDM PURGE FLAG ON SPECIFIC HUMIDITY, SPECIFIC HUMIDITY Q.M. IS SET -C TO 'P' - PRINT 9059, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9059 FORMAT(/' P-P-P-P-P-: SDM PURGE FLAG ON SHUM, SHUM Q.M. IS ', - $ 'SET TO "P"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'P' - TAG(KOUNT)(14:14) = '1' - ELSE IF(IQQM.EQ.0) THEN -C IF SDM KEEP FLAG ON SPECIFIC HUMIDITY, SPECIFIC HUMIDITY Q.M. IS SET -C TO 'H' - PRINT 8059, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 8059 FORMAT(/' H-H-H-H-H-: SDM KEEP FLAG ON SHUM, SHUM Q.M. IS ', - $ 'SET TO "H"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13,/) - TAG(KOUNT)(2:2) = 'H' - TAG(KOUNT)(14:14) = '1' - ELSE IF(IQQM.GT.3.AND.IQQM.LT.16) THEN -C IF EXISTING BAD Q.M. ON SHUM, SHUM Q.M. IS SET TO 'F' - PRINT 9649, IQQM,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9649 FORMAT(/' F-F-F-F-F-: EXISTING BAD QM ON SHUM (=',I2,'), SHUM ', - $ 'Q.M. IS SET TO "F"..',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X, - $ A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - END IF - END IF - -C SET POS. 12 OF TAG TO '@' TO MARK PURGE FLAG OR MISSING DATA ON BOTH -C WIND AND TEMPERATURE (THESE REPORTS WILL BE EXCLUDED FROM MOST -C FURTHER PROCESSING) - IF((TAG(KOUNT)(1:1).EQ.'P'.OR.TAG(KOUNT)(1:1).EQ.'x') .AND. - $ (TAG(KOUNT)(3:3).EQ.'P'.OR.TAG(KOUNT)(3:3).EQ.'x')) - $ TAG(KOUNT)(12:12) = '@' - - IF(AALT(KOUNT).GT.16500) THEN - TAG(KOUNT)(12:12) = '@' -CVVVVV%%%%% -ccc PRINT *,'~~~~~ HERE IS A RPT WITH ALT > 16,500 METERS' -CAAAAA%%%%% - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9108, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9108 FORMAT(/' #EVENT 1: ALTITUDE IS > 16,500 M (~95 MB), TEMP QM ', - $ '"F" ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 1 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 7108, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 7108 FORMAT(/' #EVENT 1: ALTITUDE IS > 16,500 M (~95 MB), SHUM QM ', - $ '"F" ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - IQEVNT(KOUNT) = 1 - END IF - IF(TAG(KOUNT)(15:15).GT.'3') THEN - IF(EWRITE) PRINT 7908, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 7908 FORMAT(/' #EVENT 1: ALTITUDE IS > 16,500 M (~95 MB), WIND QM ', - $ '"F" ',I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - IWEVNT(KOUNT) = 1 - END IF - END IF - - IF(NINT(ALAT(KOUNT)*100.).EQ.0) THEN - TAG(KOUNT)(12:12) = '@' -CVVVVV%%%%% -ccc PRINT *,'~~~~~ HERE IS A RPT WITH LATITUDE OF 0 DEGREES' -CAAAAA%%%%% - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9908, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9908 FORMAT(/' #EVENT 2: LATITUDE IS 0 DEGREES, TEMP QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 2 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 2908, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 2908 FORMAT(/' #EVENT 2: LATITUDE IS 0 DEGREES, SHUM QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - IQEVNT(KOUNT) = 2 - END IF - IF(TAG(KOUNT)(15:15).GT.'3') THEN - IF(EWRITE) PRINT 8908, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 8908 FORMAT(/' #EVENT 2: LATITUDE IS 0 DEGREES, WIND QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - IWEVNT(KOUNT) = 2 - END IF - END IF - - IF(NINT(ALON(KOUNT)*100.).EQ.0) THEN - TAG(KOUNT)(12:12) = '@' -CVVVVV%%%%% -ccc PRINT *,'~~~~~ HERE IS A RPT WITH LONGITUDE OF 0 DEGREES' -CAAAAA%%%%% - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 5908, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 5908 FORMAT(/' #EVENT 3: LONGITUDE IS 0 DEGREES, TEMP QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 3 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 5909, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 5909 FORMAT(/' #EVENT 3: LONGITUDE IS 0 DEGREES, SHUM QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - IQEVNT(KOUNT) = 3 - END IF - IF(TAG(KOUNT)(15:15).GT.'3') THEN - IF(EWRITE) PRINT 5910, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 5910 FORMAT(/' #EVENT 3: LONGITUDE IS 0 DEGREES, WIND QM "F" ',I5,2X, - $ A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - IWEVNT(KOUNT) = 3 - END IF - END IF - - IF(TAG(KOUNT)(15:15).GT.'3'.AND.NINT(ASPD(KOUNT)*10.).EQ.0.) THEN -C FLAG ALL CALM WINDS - IF(EWRITE) PRINT 9005, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9005 FORMAT(/' #EVENT 4: CALM WIND, WIND Q.M. SET "F".', - $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - IWEVNT(KOUNT) = 4 - END IF - - IF(TAG(KOUNT)(13:13).GT.'2'.AND.ATMPF(KOUNT).LT.XMSG) THEN -C IF GUESS TEMPERATURE AVAILABLE, CHECK TEMPERATURE OF REPORTS WITH -C ALTITUDE BETWEEN 2000 AND 5000 FEET - IF NOT WITHIN 25 DEG. C OF -C GUESS TEMPERATURE FLAG THE REPORT; SET POS. 12 OF TAG TO '@' TO MARK -C 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) - IF((AALT(KOUNT).GT.609..AND.AALT(KOUNT).LT.1524.).AND. - $ (ABS(ATMP(KOUNT)-ATMPF(KOUNT)).GT.25.)) THEN - TAG(KOUNT)(12:12) = '@' -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A RPT WITH INCORRECT? ALTITUDE!!' -CAAAAA%%%%% - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9902, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 9902 FORMAT(/' #EVENT 5: "0" DIGIT DROPPED FROM ALT.?, TEMP QM "F" ', - $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(1:1) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 5 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 7902, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 7902 FORMAT(/' #EVENT 5: "0" DIGIT DROPPED FROM ALT.?, SHUM QM "F" ', - $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(14:14) = '3' - IQEVNT(KOUNT) = 5 - END IF - IF(TAG(KOUNT)(15:15).GT.'3') THEN - IF(EWRITE) PRINT 8902, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT)(1:3),TAG(KOUNT)(4:16) - 8902 FORMAT(/' #EVENT 5: "0" DIGIT DROPPED FROM ALT.?, WIND QM "F" ', - $ I5,2X,A8,2X,F6.2,1X,F7.2,2X,F5.0,2X,A3,1X,A13/) - TAG(KOUNT)(3:3) = 'F' - TAG(KOUNT)(15:15) = '3' - IWEVNT(KOUNT) = 5 - END IF - END IF - END IF - - IF(IWRITE) THEN - PRINT 6177, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ NINT(TIME(KOUNT)),NINT(AALT(KOUNT)),ATMP(KOUNT),ASPH(KOUNT), - $ NINT(ADIR(KOUNT)),ASPD(KOUNT),TAG(KOUNT)(1:3), - $ TAG(KOUNT)(4:16),INTP(KOUNT),IRTM(KOUNT),KNTINI(KOUNT), - $ NINT(AALTF(KOUNT)),ATMPF(KOUNT),NINT(ADIRF(KOUNT)), - $ ASPDF(KOUNT) - 6177 FORMAT(' ',I5,2X,A8,1X,2(1X,F6.2),1X,I4,1X,I5,2(1X,F5.1),1X, - $ I3,1X,F4.1,2X,A3,2X,A13,3X,I2,3X,I4,2X,I5,1X,I5,1X,F5.1,2X, - $ I3,1X,F4.1) - END IF - -C NOW GO BACK AND READ IN NEXT REPORT - GO TO 5 - -C*********************************************************************** - - 2 CONTINUE - -C ALL MESSAGES READ IN -- FINISHED READING IN REPORTS - PRINT 812, KOUNT - 812 FORMAT(/' ALL MESSAGES READ IN PREPBUFR FILE -- TOTAL NUMBER OF ', - $ 'REPORTS READ=',I6) - NFILE = KOUNT - - IF(KOUNT.EQ.0) GO TO 6000 - -C*********************************************************************** -C SORT BY ACARS STATION ID (FOR TRACK CHECKING) -C*********************************************************************** - CALL IDSORT(NFILE,NEXCLUDE) - IF(IWRITE) THEN - PRINT 2177 - 2177 FORMAT(/' LISTING OF ORIGINAL DATA AFTER IDSORT----'/9X,'ACID', - $ 7X,'LAT WLON UTC ALT TEMP SHUM DIR SPD -QM ----TAGS', - $ '----- ITP 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)), - $ ATMP(K),ASPH(K),NINT(ADIR(K)),ASPD(K),TAG(K)(1:3),TAG(K)(4:16), - $ INTP(K),IRTM(K),KNTINI(K),NINT(AALTF(K)),ATMPF(K),NINT(ADIRF(K)), - $ ASPDF(K) - ENDDO - END IF - PRINT 6122, KOUNT,NEXCLUDE - 6122 FORMAT(/' AFTER ID SORT: INPUT FILE COUNT=',I7,', NUMBER OF ', - $ 'EXCLUDED REPORTS=',I5/) - -C*********************************************************************** -C TRACK CHECK -C*********************************************************************** -C CALL TRACK CHECK WITH NEXCLUDE (GOOD REPORTS ARE FIRST IN SORTED -C ARRAY, REPORTS EXCLUDED FROM ALL CHECKS ARE LAST IN SORTED ARRAY) -C CALL TRACK CHECK WITH NFILE=KOUNT, RETURNS NEW KOUNT (NO DUPS) - CALL TRKCHK(KOUNT,NEXCLUDE) ! Not much happens in here yet! -C*********************************************************************** -C HERE, TAG(KOUNT)(16:16) NOW CONTAINS '-' OR 'E' FOR SUSPECTED TRKCHK -C ERROR - DO CENSUS ON INCREMENTS - DO K = 1,KOUNT - IF(TIME(K).GE.TMINO.AND.TIME(K).LE.TMAXO) THEN - DO M = 1,11 - IF(TAG(K)(5:5).EQ.INACMK(M)) THEN - NNIN(M) = NNIN(M) + 1 - EXIT - END IF - ENDDO - END IF - ENDDO -C INITIALIZE SDM LOOKAT FILE FOR FLAGGED REPORTS -- UNIT 52 - WRITE(52,15) (IDATE(I),I=1,4) - 15 FORMAT(/'SDM ACARS QC CHECK FILE FOR ',I6,3I4.2) - WRITE(52,16) - 16 FORMAT('REPORTS TOSSED (WIND AND/OR TEMP QM=F), OR WITH LARGE ', - $ 'WIND INCREMENTS (.GE. 50 )'/ - $ ' (SUSPECT QM=Q, GOOD QM=A)'/ - $ '(NOTE1: ACARS ARE NEVER FLAGGED AS BAD DUE ONLY TO LARGE ', - $ 'INCREMENTS)'/ - $ '(NOTE2: DOES NOT INCLUDE REPORTS MARKED FOR EXCLUSION BY ', - $ 'THIS PROGRAM - THESE'/9X,'ARE NOT CONSIDERED CANDIDATES FOR ', - $ 'RETENTION)'// - $ 'SDMEDIT CAN BE USED TO MARK THESE FOR RETENTION (KEEP FLAG) ', - $ 'IN LATER RUNS'/' OR FLAG (PURGE) THOSE WITH LARGE WIND ', - $ 'INCREMENTS'//) - - WRITE(52,17) - 17 FORMAT(/' AC',9X,'LAT LON UTC ALT TEMP SHUM WDIR ', - $ 'WSPD INCR WND TMP'/'IDENT',27X,'(MB) (C) (G/KG)',7X, - $ '(M/S) (KTS) QM QM'/'-------- ------ ------- ---- ----', - $ ' ----- ----- ---- ----- ----- --- ---'/) - - KDUP = NFILE - KOUNT -C ARRANGE STACK - INDX RUNS FROM 1 TO KOUNT - JARRAY = 0 - CTAG = '----------------' - AAID = ' ' - DO INDX = 1,KOUNT - 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) - SSPH(1) = ASPH(INDX) - SHGTF(1) = AALTF(INDX) - SDIRF(1) = ADIRF(INDX) - SSPDF(1) = ASPDF(INDX) - STMPF(1) = ATMPF(INDX) - -C CALL RPACKR - CALL RPACKR(INDX) - -C CALL FORSDM TO ALERT SDM TO FLAGGED REPORTS OR REPORTS WITH LARGE -C INCREMENTS (SKIP EXCLUDED REPORTS AT END OF THE LIST) - IF(INDX.LE.KOUNT-NEXCLUDE) CALL FORSDM(INDX) - - ICNT1 = ICNT1 + 1 - ENDDO - - 6000 CONTINUE - -C----------------------------------------------------------------------- -C PACK Q.C'ED OBSERVATIONS INTO PREPBUFR FILE -C----------------------------------------------------------------------- - CALL OBUFR(KOUNT) - -C----------------------------------------------------------------------- -C ALL REPORTS HAVE BEEN PROCESSED -- WE ARE DONE -C----------------------------------------------------------------------- - PRINT 8926, KNTOUT - 8926 FORMAT(/5X,'@@@@@ ALL REPORTS PROCESSED: NUMBER OF ORIGINAL ', - $ '"AIRCAR" MASS REPORTS COPIED TO OUTPUT FILE =',I6/35X,'NUMBER ', - $ 'OF ORIGINAL "AIRCAR" WIND REPORTS COPIED TO OUTPUT FILE =',I6) - IF(FWRITE) THEN - PRINT 8923 - 8923 FORMAT(//26X,'>>>>> ORIGINAL LISTING OF ACARS REPORTS NOW WITH ', - $ 'NEW QUALITY MARKS <<<<<'//' K STNID TIME LAT LON ', - $ ' ALT TEMP SHUM DIR SPD -QM ----TAGS----- ITP ', - $ 'KINI TEV QEV WEV GALT GTEMP GDIR GSPD'/16X,'UTC',10X,'WEST',5X, - $ 'M C G/KG DEG M/S',8X,13('-'),27X,'M C DEG M/S'/) - KNT = 0 - DO K = 1,KOUNT - IF(TAG(K)(4:4).EQ.'D') GO TO 200 - KNT = KNT + 1 - PRINT 6111, KNT,ACID(K),NINT(TIME(K)),ALAT(K),ALON(K), - $ NINT(AALT(K)),ATMP(K),ASPH(K),NINT(ADIR(K)),ASPD(K),TAG(K)(1:3), - $ TAG(K)(4:16),INTP(K),KNTINI(K),ITEVNT(K),IQEVNT(K),IWEVNT(K), - $ NINT(AALTF(K)),ATMPF(K),NINT(ADIRF(K)),ASPDF(K) - 6111 FORMAT(' ',I7,1X,A8,1X,I4,2(1X,F6.2),1X,I5,2(1X,F5.1),2X,I3,2X, - $ F4.1,2X,A3,2X,A13,3X,I2,1X,I5,3(1X,I3),1X,I5,1X,F5.1,2X,I3,1X, - $ F4.1) - 200 CONTINUE - ENDDO - END IF - - PRINT 5001, NFILE,ICNT1,KDUP - 5001 FORMAT(//' ORIGINAL DATA (WITHIN EXPANDED INPUT TIME WINDOW)'/ - $ ' INPUT FILE COUNT=',I6,'; NUMBER OF NON-DUPLICATES WRITTEN ', - $ 'OUT=',I6,'; NUMBER OF DUPLICATES NOT WRITTEN OUT=',I5) - PRINT 5014, INACMK - 5014 FORMAT(//' ORIGINAL DATA (WITHIN OUTPUT TIME WINDOW)'/49X, - $ 11(5X,A1)/) - PRINT 5331, NNIN - 5331 FORMAT(' NUMBER ACCORDING TO OBS-GUESS INCREMENT (INPUT) ',11I6) - PRINT 5337, KISO - 5337 FORMAT(' NUMBER ACCORDING TO OBS-GUESS INCREMENT (OUTPUT) ',11I6) - - END FILE 52 - - REWIND 52 - - PRINT 5015 - 5015 FORMAT(/49X,'************PROGRAM COMPLETED *********') - - CALL W3TAGE('PREPOBS_ACARSQC') - - STOP - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: TRKCHK COMPLETE TRACK CHECK FOR ALL FLIGHTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: PERFORMS COMPLETE TRACK CHECK FOR ALL ACARS FLIGHTS WITH -C TWO OR MORE REPORTS. USING REPORTS ALREADY SORTED BY STATION -C ID (TAIL NUMBER), CALCULATES GROUND SPEED AND OTHER LOGICAL -C QUANTITIES TO ENTER DECISION MAKING ALGORITHM FOR CHOOSING BAD -C REPORTS. THESE OBSERVATIONS ARE FLAGGED. DUPLICATE REPORTS ARE -C ELIMINATED. NOTE: THIS IS NOT YET RUNNING, ALL THIS SUBROUTINE -C DOES NOW IS RESORT REPORTS ACCORDING TO REPORTED LATITUDE. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (NO TRACK CHECKING -C LOGIC YET IN PLACE) -C -C USAGE: CALL TRKCHK(NFILE,NEXCLUDE) -C INPUT ARGUMENT LIST: -C NFILE - NUMBER OF OBSERVATIONS TO BE TREATED -C NEXCLUDE - 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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE TRKCHK(NFILE,NEXCLUDE) - - PARAMETER (IRMX= 250000, ISMX= 4000) - PARAMETER (ISIZE= 18) -C PARAMETER NAME "ITMX" IN THIS SUBROUTINE (ONLY) SETS THE MAXIMUM -C NUMBER OF ACARS RPTS THAT CAN BE CHECKED IN A SINGLE TRACK - PARAMETER (ITMX= 4000) - PARAMETER (ITRKL= 20) - - LOGICAL LOGLAT,LOGTME,LOGLT1,LOGWND,DUP,LOGTRK,LOGALT,NEW,LOGLON, - $ LOGLO,LOGTMP,LOGGT3,LOGHI,LPOS25,TRACE,LUTCEQ,LLATEQ,LLONEQ, - $ LVAREQ,EWRITE,EWRITE_7,IWRITE - - CHARACTER*1 TOSLIM,CTG - CHARACTER*8 ACID,SAAID(IRMX),AAID(IRMX),TYPE(ITRKL) - CHARACTER*16 TAG,CTAG(IRMX),STAG(IRMX) - CHARACTER*32 CARRAY(IRMX) - - INTEGER IPTNAD(ITRKL),JPTNAD(ITRKL),IPTADJ(ITRKL),IPTTRK(5), - $ DTKNT,IARRAY(ISMX),INDR(IRMX) - - REAL AVESPD(ITMX),DELPOS(ITMX),DELLAT(ITMX),DELLON(ITMX) - - COMMON/STWRIT/EWRITE,EWRITE_7,IWRITE - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - COMMON/ACCONT/KISO(11) - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - - DATA XMSG/99999./,IMSG/99999/ - - KOUNT = NFILE - TRACE = .TRUE. - TRACE = .FALSE. - DG2RAD = (4.0 * ATAN(1.0))/180. - -C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING -C (ORIGINAL DATA HAS BEEN SORTED BY TAIL NUMBER ID, WITH BAD REPORTS -C LAST) - AAID(1:NFILE) = ACID(1:NFILE) - SAAID(1:NFILE) = AAID(1:NFILE) - JARRAY(1:NFILE,1) = NINT(ALAT(1:NFILE)*100.) - JARRAY(1:NFILE,2) = NINT(ALON(1:NFILE)*100.) - JARRAY(1:NFILE,3) = NINT(AALT(1:NFILE)) - JARRAY(1:NFILE,4) = NINT(TIME(1:NFILE)) - JARRAY(1:NFILE,5) = NINT(ATMP(1:NFILE)*10.) - JARRAY(1:NFILE,6) = NINT(ADIR(1:NFILE)) - JARRAY(1:NFILE,7) = NINT(ASPD(1:NFILE)*10.) - JARRAY(1:NFILE,8) = INTP(1:NFILE) - JARRAY(1:NFILE,9) = IRTM(1:NFILE) - JARRAY(1:NFILE,10) = KNTINI(1:NFILE) - JARRAY(1:NFILE,11) = ITEVNT(1:NFILE) - JARRAY(1:NFILE,12) = IWEVNT(1:NFILE) - JARRAY(1:NFILE,13) = NINT(AALTF(1:NFILE)) - JARRAY(1:NFILE,14) = NINT(ADIRF(1:NFILE)) - JARRAY(1:NFILE,15) = NINT(ASPDF(1:NFILE)*10.) - JARRAY(1:NFILE,16) = NINT(ATMPF(1:NFILE)*10.) - JARRAY(1:NFILE,17) = NINT(ASPH(1:NFILE)*10.) - JARRAY(1:NFILE,18) = IQEVNT(1:NFILE) - KARRAY(1:NFILE,:) = JARRAY(1:NFILE,:) - CTAG(1:NFILE) = TAG(1:NFILE) - STAG(1:NFILE) = CTAG(1:NFILE) - NACARS = NFILE - NEXCLUDE - PRINT 501, KOUNT,NACARS,NEXCLUDE - 501 FORMAT(1X,128('*')/43X,'ACARS TRACK CHECK SORT - NCEP ', - $ 'WASHINGTON'/128('*')//' INPUT FILE COUNT=',I6,', NUMBER OF ', - $ 'NON-EXCLUDED REPORTS=',I6,', NUMBER OF EXCLUDED REPORTS=',I6) -CCCCC PRINT 502 -CC502 FORMAT(' LISTING OF DATA, SORTED BY ID, ENTERING TRKCHK----'/9X, -CCCCC$ 'ACID',7X,'LAT WLON UTC ALT TEMP SHUM DIR SPD ', -CCCCC$ '-QM ----TAGS----- ITP RPTIME KNTINI GALT GTEMP GDIR GSPD'/) -CCCCC DO J = 1,KOUNT -CCCCC SARRY1 = XMSG -CCCCC IF(JARRAY(J, 1).LT.IMSG) SARRY1 = JARRAY(J, 1) * 0.01 -CCCCC SARRY2 = XMSG -CCCCC IF(JARRAY(J, 2).LT.IMSG) SARRY2 = JARRAY(J, 2) * 0.01 -CCCCC SARRY5 = XMSG -CCCCC IF(JARRAY(J, 5).LT.IMSG) SARRY5 = JARRAY(J, 5) * 0.1 -CCCCC SARRY7 = XMSG -CCCCC IF(JARRAY(J, 7).LT.IMSG) SARRY7 = JARRAY(J, 7) * 0.1 -CCCCC SARRY15 = XMSG -CCCCC IF(JARRAY(J,15).LT.IMSG) SARRY15 = JARRAY(J,15) * 0.1 -CCCCC SARRY16 = XMSG -CCCCC IF(JARRAY(J,16).LT.IMSG) SARRY16 = JARRAY(J,16) * 0.1 -CCCCC SARRY17 = XMSG -CCCCC IF(JARRAY(J,17).LT.IMSG) SARRY17 = JARRAY(J,17) * 0.1 -CCCCC PRINT 331, J,AAID(J),SARRY1,SARRY2,JARRAY(J,4),JARRAY(J,3), -CCCCC$ SARRAY5,SARRAY17,JARRAY(J,6),SARRAY7,CTAG(J)(1:3), -CCCCC$ CTAG(J)(4:16),JARRAY(J,8),JARRAY(J,9),JARRAY(J,10), -CCCCC$ JARRAY(J,13),SARRY16,JARRAY(J,14),SARRY15 -CCCCC ENDDO - PRINT 574 - 574 FORMAT(/' ----------------------------------') - NTRK = 0 - ITRK = NACARS + 1 - 65 CONTINUE - PRINT 574 - -C*********************************************************************** -C DETERMINE TRACK FOR EACH NON-EXCLUDED ACARS FLIGHT ID -C*********************************************************************** - PRINT 574 - NTRK = 0 - ITRK = 1 - PRINT 574 - -C Future Track checking logic will go here - - -C RESORT FOR SUBSEQUENT Q.C. CHECKING: -C 1ST ORDER - LATITUDE (SOUTH TO NORTH) -C 2ND ORDER - LONGITUDE (WEST, INCREASING) -C 3RD ORDER - TIME (INCREASING) -C 4TH ORDER - ALITITUDE (INCREASING) -C SORT BY CONCATENATING THESE QUANITIIES INTO CHARACTER ARRAY - DO J = 1,NACARS - 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) - WRITE(CARRAY(J)(15:20),'(I6.6)') JARRAY(J,3) - CARRAY(J)(21:32) = '000000000000' -CCCCC PRINT 788, J,AAID(J),CARRAY(J) -CC788 FORMAT(' DBG J ',I6,2X,'; ID=',A8,'; CARRAY=',A32) - ENDDO -C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE - IF(NACARS.GT.0) CALL INDEXC(NACARS,CARRAY,INDR) -C WRITE SORTED REPORTS INTO SAAID, KARRAY, AND STAG ARRAYS (REMAINING -C EXCLUDED REPORTS ALREADY IN THESE ARRAYS IN PROPER POSITION FROM -C STORE MADE AT BEGINNING OF SUBROUTINE) - DO I = 1,NACARS - J = INDR(I) - SAAID(I) = AAID(J) - STAG(I) = CTAG(J) - KARRAY(I,:) = JARRAY(J,:) - ENDDO -CCCCC PRINT 562 -CC562 FORMAT(' LAT/LON ACID ',6X,' LAT LON ',4X,'UTC ALT ', -CCCCC$' TEMP SHUM WDIR WSPD ') -CCCCC DO J = 1,KOUNT -CCCCC KARRY1 = MIN(KARRAY(J, 1),IMSG) -CCCCC KARRY2 = MIN(KARRAY(J, 2),IMSG) -CCCCC KARRY5 = MIN(KARRAY(J, 5),IMSG) -CCCCC KARRY17 = MIN(KARRAY(J,17),IMSG) -CCCCC KARRY7 = MIN(KARRAY(J, 7),IMSG) -CCCCC PRINT 711, J,SAAID(J),KARRY1*.01,KARRY2*.01,KARRAY(J,4), -CCCCC$ KARRAY(J,3),KARRAY5*.1,KARRAY17*.1,KARRAY(J,6),KARRAY7*.1, -CCCCC$ STAG(J)(1:3),STAG(J)(4:16) -CC711 FORMAT(' ',I5,2X,A8,2(2X,F6.2),4X,I4,3X,I5,2(3X,F5.1),5X,I3,4X, -CCCCC$ F4.1,A3,1X,A13) -CCCCC ENDDO -C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS AND ELIMINATE DUPS - IF(IWRITE) PRINT 557 - 557 FORMAT(/' FINAL LISTING OF DATA, SORTED BY ID AND LATITUDE, ', - $ ' LEAVING TRKCHK----'/9X,'ACID',7X,'LAT WLON UTC ALT ', - $ 'TEMP SHUM DIR SPD -QM ----TAGS----- ITP RPTIME KNTINI ', - $ 'GALT GTEMP GDIR GSPD'/) - M = 0 - DO I = 1,KOUNT - IF(STAG(I)(4:4).EQ.'D') THEN - PRINT 9022, I,SAAID(I),REAL(KARRAY(I,1))*.01, - $ REAL(KARRAY(I,2))*.01,REAL(KARRAY(I,4)),STAG(I)(1:3), - $ STAG(I)(4:16) - 9022 FORMAT(/' ##########: TRKCHK; DUPLICATE REMOVED AT END OF SUBR..', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - CYCLE - END IF - 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) * .1 - ADIR(M) = KARRAY(I,6) - ASPD(M) = KARRAY(I,7) * .1 - 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) * .1 - ATMPF(M) = KARRAY(I,16) * .1 - ASPH(M) = KARRAY(I,17) * .1 - IQEVNT(M) = KARRAY(I,18) - TAG(M) = STAG(I) - IF(IWRITE) PRINT 331, M,ACID(M),ALAT(M),ALON(M),NINT(TIME(M)), - $ NINT(AALT(M)),ATMP(M),ASPH(M),NINT(ADIR(M)),ASPD(M), - $ TAG(M)(1:3),TAG(M)(4:16),INTP(M),IRTM(M),KNTINI(M), - $ NINT(AALTF(M)),ATMPF(M),NINT(ADIRF(M)),ASPDF(M) - 331 FORMAT(' ',I5,2X,A8,1X,2(1X,F6.2),1X,I4,1X,I5,2(1X,F5.1),1X, - $ I3,1X,F4.1,2X,A3,2X,A13,3X,I2,3X,I4,2X,I5,1X,I5,1X,F5.1,2X, - $ I3,1X,F4.1) - ENDDO - NFILE = M - PRINT 681, NFILE - 681 FORMAT(//1X,128('*')/25X,'OUT OF TRACK CHECK - NUMBER OF NON-', - $ 'DUPLICATE REPORTS (INCL. PREVIOUSLY EXCLUDED) =',I7/1X,128('*') - $ ///) - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FORSDM WRITES FLAGGED OR LARGE INCREMENT REPORTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: WRITES ALL REPORTS CONTAINING A TEMPERATURE AND/OR WIND -C WHICH HAS BEEN FLAGGED FOR NON-USE TO A TEXT FILE WHICH THE SDM -C CAN EXAMINE. ALSO WRITES ALL REPORTS WITH LARGE WIND INCREMENTS, -C REGARDLESS OF QUALITY MARKER. THIS ALLOWS THE SDM TO USE SDMEDIT -C TO 'KEEP' ANY OF THESE REPORTS IN THE NEXT NETWORK RUN. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C -C USAGE: CALL FORSDM(INDX) -C INPUT ARGUMENT LIST: -C INDX - POINTER TO POSITION IN ORIGINAL ACARS ARRAY -C -C OUTPUT FILES: -C UNIT 52 - TEXT FILE FOR SDM PERUSAL (LIST OF REPORTS THAT ARE -C - FLAGGED FOR NON-USE BY THIS PROGRAM AS WELL AS THOSE -C - WITH LARGE INCREMENTS) -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE FORSDM(INDX) - - PARAMETER (IRMX= 250000) - - CHARACTER*1 CTG,CLON,TAGX(3),CH1(9) - CHARACTER*8 ACID - CHARACTER*16 TAG - - INTEGER ICH1(9) - - COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST - COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - - DATA XMSG/99999./ - DATA CH1 /'Q','R','S','T','U','V','W','X','Y'/ - DATA ICH1 /10, 20, 30, 40, 50, 60, 70, 80, 90 / - - IF((TAG(INDX)(5:5).GE.'U'.AND.TAG(INDX)(5:5).LE.'Z').OR. - $ TAG(INDX)(1:1).EQ.'F'.OR.TAG(INDX)(3:3).EQ.'F') THEN -C SKIP WRITING OF ANY FLAGGED 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 WINDS AND/OR TEMPS FLAGGED BY -C THIS PROGRAM; SCALE BASED ON VALUE OF SCALED INCREMENT CHARACTER Q-Z, -C IF INCREMENT NOT AVAIL. SCALE SET TO MSG - SCALE = XMSG - IF(TAG(INDX)(5:5).GE.'Q'.AND.TAG(INDX)(5:5).LE.'Z') THEN - CTG = TAG(INDX)(5:5) - SCALE = 100.0 - DO I=1,9 - IF(CTG.EQ.CH1(I)) THEN - SCALE = ICH1(I) - EXIT - END IF - ENDDO - 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.) - QLON = ALON(INDX) - CLON = 'W' - IF(NINT(QLON).GT.180) THEN - QLON = (360. - QLON) - CLON = 'E' - END IF - DO M = 1,3,1 - TAGX(M) = TAG(INDX)(M:M) - IF(TAG(INDX)(M:M).EQ.'-'.OR.TAG(INDX)(M:M).EQ.'x') - $ TAGX(M) = ' ' - END DO - WRITE(52,25) ACID(INDX),ALAT(INDX),QLON,CLON,NINT(QTIME), - $ NINT(PRALT),ATMP(INDX),ASPH(INDX),NINT(ADIR(INDX)),ASPD(INDX), - $ NINT(SCALE),TAGX(3),TAGX(1) - 25 FORMAT(A8,2X,F6.2,1X,F6.2,A1,2(2X,I4),2(1X,F5.1),3X,I3,1X,F5.1,2X, - $ I3,2X,2(3X,A1)) - END IF - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RPACKR PREPARES OBS. FOR PACKING -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: PREPARES OBSERVATIONS FOR FINAL PACKING TO OUTPUT FILE. -C FINAL CHECK TO REMOVE DUPLICATES, FINAL ASSIGNMENT OF TEMPERATURE, -C SPECIFIC HUMIDITY AND WIND QUALITY MARKERS (IF APPLICABLE) AND -C ACCUMULATION OF NEW SUPEROBS IN HOLDING ARRAYS (IF APPLICABLE). -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C -C USAGE: CALL RPACKR(INDX) -C INPUT ARGUMENT LIST: -C INDX - POINTER TO POSITION IN ORIGINAL ACARS ARRAY -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE RPACKR(INDX) - - PARAMETER (IRMX= 250000, ISMX= 4000) - PARAMETER (ISUP= 2000) - - LOGICAL EWRITE,EWRITE_7 - - CHARACTER*4 SSMARK - CHARACTER*8 ACID,SAID - CHARACTER*16 TAG - - INTEGER IDATA(1608) - - REAL ORIGTM(10),RDATA(1608) - - COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST - COMMON/OUTPUT/KNTOUT(2) - COMMON/STWRIT/EWRITE,EWRITE_7,IWRITE - COMMON/SUMDAT/SAID(ISMX),SLAT(ISMX),SLON(ISMX),SHGT(ISMX), - $ STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX),SSPH(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - COMMON/SUPOBS/SSLAT(ISUP),SSLON(ISUP),SSTIM(ISUP),SSHGT(ISUP), - $ SSTMP(ISUP),SSSPH(ISUP),SSDIR(ISUP),SSSPD(ISUP),SSHGTF(ISUP), - $ SSTMPF(ISUP),SSDIRF(ISUP),SSSPDF(ISUP),SSMARK(ISUP) - - EQUIVALENCE (IDATA,RDATA) - - DATA IMSG/99999/ - -C INVENTORY INCREMENTS - CALL ACCOUNT(INDX) - IF(TAG(INDX)(4:4).EQ.'D') THEN -C SKIP REPACKING OF ORIGINAL REPORT IF IT IS INDEED A DUPLICATE REPORT - PRINT 9026, INDX,ACID(INDX),ALAT(INDX),ALON(INDX), - $ TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 9026 FORMAT(/' ##########: RPACKR; DUPLICATE REMOVED AT BEG OF SUBR..', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - KNTINI(INDX) = IMSG - GO TO 1 - END IF -C SKIP REPACKING OF ORIGINAL REPORT IF IT IS OUTSIDE REQ. TIME WINDOW - IF(TIME(INDX).LT.TMINO.OR.TIME(INDX).GT.TMAXO) THEN -C SET POS.1 OF TAG TO 'D' TO REMOVE FROM FINAL LISTING OF ORIG. REPORTS - TAG(INDX)(4:4) = 'D' -CCCCC PRINT 9002, INDX,ACID(INDX),ALAT(INDX),ALON(INDX), -CCCCC$ TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) -C9002 FORMAT(/' ##########: RPACKR; RPTS OUTSIDE TIME WINDOW SKIPPED..', -CCCCC$ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - KNTINI(INDX) = IMSG - GO TO 1 - END IF -C NOW, MAKE FINAL ASSIGNMENT OF TEMPERATURE, SPECIFIC HUMIDITY AND WIND -C Q. MARKS (IF APPL.) - IF(TAG(INDX)(13:13).GT.'5') THEN - IF(TAG(INDX)(10:10).EQ.'7') THEN - IF(EWRITE) PRINT 9095, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 9095 FORMAT(/' #EVENT 6: RPACKR; ACARS BANKING?, TEMP QM. Q', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - TAG(INDX)(1:1) = 'Q' - TAG(INDX)(13:13) = '5' - ITEVNT(INDX) = 6 - ELSE IF(TAG(INDX)(13:13).GT.'6') THEN -C IF "GOOD" REPORT, TEMP Q.M. IS 'A' - IF(EWRITE_7) PRINT 9090, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 9090 FORMAT(' #EVENT 7: RPACKR; "GOOD" ACARS, TEMP Q.M. A', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13) - TAG(INDX)(1:1) = 'A' - TAG(INDX)(13:13) = '6' - ITEVNT(INDX) = 7 - END IF - END IF - IF(TAG(INDX)(14:14).GT.'5') THEN - IF(TAG(INDX)(10:10).EQ.'7') THEN - IF(EWRITE) PRINT 7095, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 7095 FORMAT(/' #EVENT 6: RPACKR; ACARS BANKING?, SHUM QM. Q', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - TAG(INDX)(2:2) = 'Q' - TAG(INDX)(14:14) = '5' - IQEVNT(INDX) = 6 - ELSE IF(TAG(INDX)(14:14).GT.'6') THEN -C IF "GOOD" REPORT, SPECIFIC HUMIDITY Q.M. IS 'A' - IF(EWRITE_7) PRINT 7090, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 7090 FORMAT(' #EVENT 7: RPACKR; "GOOD" ACARS, SHUM Q.M. A', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13) - TAG(INDX)(2:2) = 'A' - TAG(INDX)(14:14) = '6' - IQEVNT(INDX) = 7 - END IF - END IF - IF(TAG(INDX)(15:15).GT.'5') THEN - IF(TAG(INDX)(10:10).EQ.'7') THEN - IF(EWRITE) PRINT 8095, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 8095 FORMAT(/' #EVENT 6: RPACKR; ACARS BANKING?, WIND QM. Q', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - TAG(INDX)(3:3) = 'Q' - TAG(INDX)(15:15) = '5' - IWEVNT(INDX) = 6 - ELSE IF(TAG(INDX)(15:15).GT.'6') THEN -C IF "GOOD" ACARS REPORT, WIND Q.M. IS 'A' - IF(EWRITE_7) PRINT 9091, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 9091 FORMAT(' #EVENT 7: RPACKR; "GOOD" ACARS, WIND Q.M. A', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13) - TAG(INDX)(3:3) = 'A' - TAG(INDX)(15:15) = '6' - IWEVNT(INDX) = 7 - END IF - END IF - IF(TAG(INDX)(1:1).EQ.'F'.AND.TAG(INDX)(14:14).GT.'3') THEN -C IF TEMPERATURE IS FLAGGED, THEN SPECIFIC HUMIDITY IS ALWAYS -C ALSO FLAGGED - IF(EWRITE) PRINT 7033, INDX,ACID(INDX),ALAT(INDX), - $ ALON(INDX),TIME(INDX),TAG(INDX)(1:3),TAG(INDX)(4:16) - 7033 FORMAT(/' #EVENT 8: RPACKR; BAD TEMP, SHUM Q.M. SET TO "F"....', - $ I5,2X,A8,2(2X,F6.2),1X,F5.0,2X,A3,1X,A13/) - TAG(INDX)(2:2) = 'F' - TAG(INDX)(14:14) = '3' - IQEVNT(INDX) = 8 - END IF - - 1 CONTINUE - - NPT = 1 - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: ACCOUNT DOES SIMPLE ACCOUNTING OF REPORTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: DOES SIMPLE ACCOUNTING BY LOGGING NUMBER OF REPORTS BY -C SCALED VECTOR INCREMENT. IN ADDITION, LOGS THE NUMBER OF -C SDM KEEPS AND SDM PURGES. THE NUMBER OF BAD TEMPERATURES -C IS ALSO ACCOUNTED FOR HERE. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C -C USAGE: CALL ACCOUNT(INDX) -C INPUT ARGUMENT LIST: -C INDX - POINTER TO POSITION IN ORIGINAL ACARS ARRAY -C -C REMARKS: CALLED BY SUBROUTINE 'RPACKR'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE ACCOUNT(INDX) - - PARAMETER (IRMX= 250000) - - CHARACTER*1 INACMK(11) - CHARACTER*8 ACID - CHARACTER*16 TAG - - COMMON/ACCONT/KISO(11) - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST - - DATA INACMK/'Q','R','S','T','U','V','W','X','Y','Z','N'/ - - IF(TIME(INDX).GE.TMINO.AND.TIME(INDX).LE.TMAXO) THEN - DO M = 1,11 - IF(TAG(INDX)(5:5).EQ.INACMK(M)) THEN - KISO(M) = KISO(M) + 1 - EXIT - END IF - ENDDO - END IF - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: IDSORT SORTS INPUT AIRCAR REPORTS BY STATION ID -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: USES LOCAL SORT ROUTINE TO SORT ENTIRE ACARS FILE -C BY THE 8-CHARACTER STATION (FLIGHT) IDENTIFICATION. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C -C USAGE: CALL IDSORT(NFILE,NEXCLUDE) -C INPUT ARGUMENT LIST: -C NFILE - NUMBER OF OBSERVATIONS TO SORT -C -C OUTPUT ARGUMENT LIST: -C NEXCLUDE - 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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE IDSORT(NFILE,NEXCLUDE) - - PARAMETER (IRMX= 250000) - PARAMETER (ISIZE= 18) - - CHARACTER*8 ACID,AAID(IRMX) - CHARACTER*16 TAG,STAG(IRMX) - CHARACTER*32 CARRAY(IRMX) - - REAL SARRAY(IRMX,ISIZE) - - INTEGER INDR(IRMX) - - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - COMMON/WORD/ICHTP - - DATA IMSG/99999/ - - NEXCLUDE = 0 -C FILL IN CARRAY FOR SORT ROUTINE - DO 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: -C '99999' IF CHARACTERS ARE EBCDIC, -C '~~~~~' IF CHARACTERS ARE ASCII) -C 1ST ORDER - "99999" or "~~~~~"//STATION ID -C 2ND ORDER - TIME (INCREASING) -C 3RD ORDER - LONGITUDE (WEST, INCREASING) -C 4TH ORDER - LATITUDE (SOUTH TO NORTH) -C 5TH ORDER - ALTITUDE (INCREASING) - NEXCLUDE = NEXCLUDE + 1 - CARRAY(J)(1:5) = '99999' - IF(ICHTP.EQ.0) CARRAY(J)(1:5) = '~~~~~' - CARRAY(J)( 6:12) = ACID(J)(1:7) - WRITE(CARRAY(J)(13:16),'(I4.4)') NINT(TIME(J)) - WRITE(CARRAY(J)(17:21),'(I5.5)') NINT(ALON(J)*100.) - WRITE(CARRAY(J)(22:26),'(I5.5)') NINT(ALAT(J)*100.) + 9000 - WRITE(CARRAY(J)(27:32),'(I6.6)') NINT(AALT(J)) - ELSE -C GOOD REPORTS WILL BE AT BEGINNING OF SORT -C 1ST ORDER - STATION ID -C 2ND ORDER - LONGITUDE (WEST, INCREASING) -C 3RD ORDER - TIME (INCREASING) -C 4TH ORDER - LATITUDE (SOUTH TO NORTH) -C 5TH ORDER - ALTITUDE (INCREASING) - 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)) - WRITE(CARRAY(J)(17:21),'(I5.5)') NINT(ALAT(J)*100.) + 9000 - WRITE(CARRAY(J)(22:27),'(I6.6)') NINT(AALT(J)) - CARRAY(J)(28:32) = '00000' - END IF -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) - SARRAY(J,17) = ASPH(J) - SARRAY(J,18) = REAL(IQEVNT(J)) - STAG(J) = TAG(J) -CCCCC LON = IMSG -CCCCC PRINT 1927, AAID(J),NINT(TIME(J)),ALON(J),CARRAY(J) -C1927 FORMAT(' ',A8,6X,I4,3X,F6.2,A32) -CCCCC PRINT 100, J,AAID(J),SARRAY(J,1),SARRAY(J,2),SARRAY(J,4), -CCCCC$ SARRAY(J,3),SARRAY(J,5),SARRAY(J,17),SARRAY(J,6),SARRAY(J,7), -CCCCC$ STAG(J)(1:3) -CC100 FORMAT(' ', I7,2X,A8,2X,2(3X,F6.2),4X,F5.0,3X,F6.0,2(4X,F5.1), -CCCCC$ 5X,F4.0,5X,F4.1,1X,A3) - ENDDO -C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE - IF(NFILE.GT.0) CALL INDEXC(NFILE,CARRAY,INDR) - DO I = 1,NFILE - J = INDR(I) -C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS - 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) - ASPH(I) = SARRAY(J,17) - IQEVNT(I) = NINT(SARRAY(J,18)) - TAG(I) = STAG(J) - ENDDO - - RETURN - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: INDEXC GENERAL SORT ROUTINE FOR CHARACTER ARRAY -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1999-08-23 -C -C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST -C FOR A 32-CHARACTER ARRAY. DOES NOT REARRANGE THE FILE. -C -C PROGRAM HISTORY LOG: -C 1993-06-05 R KISTLER --- FORTRAN VERSION OF C-PROGRAM -C 1993-07-15 P. JULIAN ---- MODIFIED TO SORT 12-CHARACTER ARRAY -C 1994-08-25 D. A. KEYSER - MODIFIED TO SORT 16-CHARACTER ARRAY -C 1995-05-30 D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST, -C IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY) -C 1999-08-23 D. A. KEYSER - EXPANDED CHARACTER ARRAY FROM 16 TO 32 -C BYTES (ALLOWS HIGHER ORDERS TO BE INCLUDED IN SORT) -C -C USAGE: CALL INDEXC(N,CARRIN,INDX) -C INPUT ARGUMENT LIST: -C N - SIZE OF ARRAY TO BE SORTED -C CARRIN - 32-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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE INDEXC(N,CARRIN,INDX) - - CHARACTER*32 CARRIN(N),CC - - INTEGER INDX(N) - - DO J = 1,N - INDX(J) = J - ENDDO - -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: NP22 DATE: 1995-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 1993-06-05 R KISTLER -- FORTRAN VERSION OF C-PROGRAM -C 1995-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' AND 'OBUFR'. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE INDEXF(N,IARRIN,INDX) - - INTEGER INDX(N),IARRIN(N) - - DO J = 1,N - INDX(J) = J - ENDDO - -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 PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2009-08-03 -C -C ABSTRACT: READS THRU SUCCESSIVE BUFR MESSAGES UNTIL THE BUFR TABLE -C A ENTRY "AIRCAR" (ACARS AIRCRAFT REPORTS) IS FOUND IN A PREPBUFR -C FILE. RETURNS THE DATE OF THIS MESSAGE TO THE CALLING PROGRAM. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C 2009-08-03 D. A. KEYSER -- WILL NO LONGER TRY TO PULL OUT RECEIPT -C TIME (RCT) FROM PRE-DECEMBER 2008 VERSIONS OF PREPBUFR -C FILE WHICH DO YET INCLUDE IT IN ACARS REPORT HEADER (DONE -C SO THAT CFSRR RUNS WILL NOT FAIL) -C -C USAGE: CALL DBUFR(IDATEP) -C OUTPUT ARGUMENT LIST: -C IDATEP - DATE FROM FIRST TABLE A "AIRCAR" MESSAGE (YYYYMMDDHH) -C -C INPUT FILES: -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE DBUFR(IDATEP) - - CHARACTER*8 SUBSET - CHARACTER*1 CTAB - - COMMON/NEWTABLE/IPRSLEVLA - - CALL DATELEN(10) - - CALL OPENBF(14,'IN',14) - -C Check to see if the post 12/2008 version of the PREPBUFR mnemonic -C table which includes Table D mnemonic "PRSLEVLA" is being used here -C -------------------------------------------------------------------- - - CALL STATUS(14,LUN,IDUMMY1,IDUMMY2) - CALL NEMTAB(LUN,'PRSLEVLA',IDUMMY1,CTAB,IRET) - IPRSLEVLA = 0 - IF(IRET.GT.0.AND.CTAB.EQ.'D') IPRSLEVLA = 1 - - 10 CONTINUE - - CALL READMG(14,SUBSET,IDATEP,IRET) - IF(IRET.NE.0) GO TO 999 - IF(SUBSET.NE.'AIRCAR ') GO TO 10 -cppppp - print * ,' ' - print *, 'First AIRCAR message found ... ' - print *,'PREPBUFR File Sec. 1 message date (IDATEP) = ',IDATEP -cppppp - IF(IDATEP.LT.1000000000) THEN - -C If 2-digit year returned in IDATEP, must use "windowing" technique -C to create a 4-digit year - -C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS -C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT -C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) - - PRINT *, '##ACARSQC - THE FOLLOWING SHOULD NEVER HAPPEN!!!!!' - PRINT *, '##ACARSQC - 2-DIGIT YEAR IN IDATEP RETURNED FROM ', - $ 'READMG (IDATEP IS: ',IDATEP,') - USE WINDOWING TECHNIQUE ', - $ 'TO OBTAIN 4-DIGIT YEAR' - IF(IDATEP/1000000.GT.20) THEN - IDATEP = 1900000000 + IDATEP - ELSE - IDATEP = 2000000000 + IDATEP - ENDIF - PRINT *, '##ACARSQC - CORRECTED IDATEP WITH 4-DIGIT YEAR, ', - $ 'IDATEP NOW IS: ',IDATEP - ENDIF - - RETURN - -C----------------------------------------------------------------------- - 999 CONTINUE -C PREPBUFR DATA SET CONTAINS NO "AIRCAR" TABLE A MSGS -- STOP 4 !!! - PRINT 14 - 14 FORMAT(/' PREPBUFR DATA SET CONTAINS NO "AIRCAR" TABLE A ', - $ 'MESSAGES - STOP 4'/) - CALL CLOSBF(14) - CALL W3TAGE('PREPOBS_ACARSQC') - CALL ERREXIT(4) -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: IBUFR DECODES ACARS OBS. FROM PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2009-08-03 -C -C ABSTRACT: DECODES AN ACARS AIRCRAFT OBSERVATION FROM A TABLE A -C ENTRY "AIRCAR" MESSAGE IN A PREPBUFR FILE FOR EACH CALL. IF ALL -C SUBSETS HAVE BEEN DECODED IN A MESSAGE THE NEXT TABLE A ENTRY -C "AIRCAR" MESSAGE IN READ IN AND DECODED. A RETURN 1 OCCURS WHEN -C ALL TABLE A ENTRY "AIRCAR" MESSAGES HAVE BEEN PROCESSED. SPECIAL -C LOGIC COMBINES THE SEPARATE WIND AND MASS REPORT "PIECES" INTO A -C SINGLE OBSERVATION PRIOR TO RETURN TO CALLING PROGRAM. -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C 2008-09-25 D. A. KEYSER -- IN RESPONSE TO CHANGE FROM SINGLE LEVEL -C TO DELAYED REPLICATION FOR "AIRCAR" REPORT LEVEL DATA NOW -C IN PREPBUFR FILE (IN PREPARATION FOR NRL AIRCRAFT QC -C PROGRAM WHICH WILL REPLACE THIS PROGRAM 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 2009-08-03 D. A. KEYSER -- WILL NO LONGER TRY TO PULL OUT RECEIPT -C TIME (RCT) FROM PRE-DECEMBER 2008 VERSIONS OF PREPBUFR -C FILE WHICH DO YET INCLUDE IT IN ACARS REPORT HEADER (DONE -C SO THAT CFSRR RUNS WILL NOT FAIL) -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 (M/S) -C TMPF - FORECAST VALUE FOR TEMPERATURE (DEG. C) -C -C INPUT FILES: -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE IBUFR(ALTF,DIRF,SPDF,TMPF,*) - - CHARACTER*1 CIQMMK(10),CF,PF,CINCR - CHARACTER*8 SUBSET,IDENT - CHARACTER*40 HEADR,OBLVL,FCLVL - - REAL(8) HDR6_8,OBS_8(10),HDR_8(9),FST_8(4),RCT_8 - REAL ACAT(9) - - COMMON/QUALITY/ITQM,IQQM,IWQM - COMMON/CBUFR/IDENT,IRCTME,RDATA(1608),KIX,CINCR,CF,PF - COMMON/STDATE/IDATE(5) - COMMON/NEWTABLE/IPRSLEVLA - - EQUIVALENCE (IDENT,HDR6_8),(IRPTYP,RDATA(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 QOB QQM '/ - DATA FCLVL/'UFC VFC TFC ZFC '/ - DATA XMSG/99999./,IMSG/99999/,IFLAG/0/,ILOOP/1/,KI/0/,SQNL/0/ - DATA BMISS /10E10/ - -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 - IF(IFLAG.EQ.1) GO TO 45 - RDATA = XMSG - - 30 CONTINUE - - CALL READSB(14,IRET) - IF(IRET.NE.0) THEN - 20 CONTINUE - CALL READMG(14,SUBSET,IDATEP,IRET) - IF(IRET.NE.0) THEN -C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ -C FILE WILL BE CLOSED - PRINT 101 - 101 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY', - $ ' CLOSED FROM INITIAL READ OF ACARS OBS.') - CALL CLOSBF(14) - RETURN 1 - END IF - IF(SUBSET.NE.'AIRCAR ') GO TO 20 - GO TO 30 - END IF - - CALL UFBINT(14,HDR_8, 9,1,N1LEV,HEADR) - CALL UFBINT(14,OBS_8,10,1,NLEV ,OBLVL) - CALL UFBINT(14,FST_8, 4,1,NLEV2,FCLVL) - IF(IPRSLEVLA.EQ.1) THEN - -C If the post 12/2008 version of the PREPBUFR mnemonic table which -C includes Table D mnemonic "PRSLEVLA" is being used here, then 'RCT' -C is present in the ACARS report header -C -------------------------------------------------------------------- - - CALL UFBINT(14,RCT_8, 1,1,N3LEV,'RCT') - ELSE - -C .... otherwise, 'RCT' is not present in the ACARS report header -C ---------------------------------------------------------- - - RCT_8 = BMISS - N3LEV = 1 ! set so that if test below will not be satisfied - END IF - IF(N1LEV.NE.NLEV.OR.NLEV2.NE.NLEV.OR.NLEV.NE.1.OR.N3LEV.NE.NLEV) - $ GO TO 999 - KI = NINT(HDR_8(8))/100 - IF(ILOOP.EQ.2) THEN -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) - IF(HDR_8(9).EQ.SQNL) GO TO 40 - ILOOP = 1 - IFLAG = 1 - RETURN - END IF - - 45 CONTINUE - -C CONSTRUCT OBSERVATION HEADER(ONLY DONE FOR 1ST DECODED REPORT "PIECE") - CF = '-' - PF = '-' - CINCR = 'N' - RDATA(1) = MIN(99999._8,HDR_8(1)) - RDATA(2) = MIN(99999._8,(360._8-HDR_8(2))) -C IRCTME = MIN(IMSG,NINT(HDR_8(3)*100.)) - IRCTME = NINT(MIN(9999._8,HDR_8(3)*100.)) -C NDT = MIN(IMSG,NINT(HDR_8(4)*100.)) - NDT = NINT(MIN(9999._8,HDR_8(4)*100.)) - RDATA(4) = NDT + (IDATE(4) * 100) - RDATA(4) = MOD(NINT(RDATA(4)),2400) - IF(NINT(RDATA(4)).LT.0) RDATA(4) = NINT(2400. + RDATA(4)) - if (hdr_8(5) .lt. xmsg) then - IF(NINT(HDR_8(5)).EQ.1) CF = 'C' - IF(NINT(HDR_8(5)).EQ.2) PF = '7' - endif -C IRPTYP = MIN(99,NINT(HDR_8(7))) - IRPTYP = NINT(MIN(99._8,HDR_8(7))) - HDR6_8 = HDR_8(6) - KIX = HDR_8(8) - - 40 CONTINUE - - IF(KI.EQ.2) THEN -C CONSTRUCT WIND PART OF OBSERVATION FROM DECODED WIND REPORT "PIECE" - -C CINCR 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 = 'N' IS STORED) - IF(MAX(FST_8(1),FST_8(2)).LT.XMSG) THEN - IF(MAX(OBS_8(7),OBS_8(8)).LT.XMSG.AND.(ABS(RDATA(4)- - $ REAL(IDATE(4)*100.)).LE.333..OR.(RDATA(4)- - $ REAL(IDATE(4)*100.)).GE.2067.)) THEN - VDIF = SQRT((FST_8(1)-OBS_8(7))**2 - $ +(FST_8(2)-OBS_8(8))**2)*1.9425 - CINCR = 'Z' - DO J = 1,9 - IF(VDIF.LT.ACAT(J)) THEN - CINCR = CIQMMK(J) - EXIT - END IF - ENDDO - END IF -C CONSTRUCT FCST WIND DIR. (DEG) & SPD (M/S) FROM FCST WIND COMPONENTS - ISUNIT = 2 - UFC = FST_8(1) - VFC = FST_8(2) - CALL CMDDFF(ISUNIT,UFC,VFC,DIRF,SPDF) - DIRF = NINT(DIRF) - END IF -C RDATA(43) HOLDS PRESSURE ALTITUDE (METERS) - RDATA(43) = MIN(99999._8,OBS_8(1)) -C ALTF HOLDS FORECAST PRESSURE ALTITUDE (METERS) - IF(FST_8(4).LT.XMSG) ALTF = NINT(FST_8(4)) -C RDATA(46) HOLDS WIND DIRECTION (DEGREES) - RDATA(46) = MIN(99999._8,OBS_8(3)) -C RDATA(46) HOLDS WIND SPEED (M/S) - SPEED = XMSG - IF(MAX(OBS_8(7),OBS_8(8)).LT.XMSG) - $ SPEED = SQRT(OBS_8(7)**2 + OBS_8(8)**2) - RDATA(47) = MIN(XMSG,SPEED) -C IWQM HOLDS WIND QUALITY MARKER (NUMERIC) - IWQM = MIN(99._8,OBS_8(6)) - ELSE -C CONSTRUCT MASS PART OF OBSERVATION FROM DECODED MASS REPORT "PIECE" - -C RDATA(43) HOLDS PRESSURE ALTITUDE (METERS) - RDATA(43) = MIN(99999._8,OBS_8(1)) -C ALTF HOLDS FORECAST PRESSURE ALTITUDE (METERS) - IF(FST_8(4).LT.XMSG) ALTF = NINT(FST_8(4)) -C RDATA(44) HOLDS TEMPERATURE (DEGREES CELSIUS) - RDATA(44) = MIN(99999._8,OBS_8(2)) -C TMPF HOLDS FORECAST TEMPERATURE (DEGREES CELSIUS X 10) - IF(FST_8(3).LT.XMSG) TMPF = FST_8(3) -C ITQM HOLDS TEMPERATURE QUALITY MARKER (NUMERIC) - ITQM = MIN(99._8,OBS_8(5)) -C RDATA(45) HOLDS SPECIFIC HUMIDITY (G/KG) - RDATA(45) = MIN(99999._8,OBS_8(9)*.001) -C IQQM HOLDS SPECIFIC HUMIDITY QUALITY MARKER (NUMERIC) - IQQM = MIN(99._8,OBS_8(10)) - END IF - - IF(ILOOP.EQ.1) THEN -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 ACARS OBSERVATION -C (SAVE RPT SEQ. # OF 1ST "PIECE" FOR LATER COMPARISON AGAINST SECOND) - SQNL = HDR_8(9) - ILOOP = 2 - GO TO 30 - END IF - -C IF TWO "PIECES" HAVE BEEN DECODED IN THIS CALL, READY TO RETURN -C COMPLETE ACARS OBSERVATION TO CALLING PROGRAM - ILOOP = 1 - IFLAG = 0 - - RETURN - -C----------------------------------------------------------------------- - 999 CONTINUE -C THE NUMBER OF DECODED LEVELS IS NOT 1!! -- STOP 70 - PRINT 217 - 217 FORMAT(/' THE NUMBER OF DECODED LEVELS FOR A REPORT IS NOT 1 -- ', - $ 'STOP 70'/) - CALL W3TAGE('PREPOBS_ACARSQC') - CALL ERREXIT(70) -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: OBUFR WRITES ACARS RPTS TO PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-05-07 -C -C ABSTRACT: RESORTS ALL OBS. IN HOLDING ARRAYS BACK TO ORIGINAL ORDER, -C THEN FOR ALL TABLE A ENTRY MESSAGES EXCEPT "AIRCAR" DOES A -C STRAIGHT COPY OF EACH SUBSET (REPORT) FROM THE INPUT PREPBUFR -C FILE TO THE OUTPUT PREPBUFR FILE. FOR TABLE A ENTRY "AIRCAR" -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, SPECIFIC HUMIDITY OR WIND QUALITY MARKER). -C IF SO, PUSHES DOWN TEMPERATURE, SPECIFIC HUMIDITY OR WIND STACKED -C EVENTS AND RECORDS THIS EVENT (REASON CODE) ALONG WITH THE NEW -C QUALITY MARKER PRIOR TO WRITING THE SUBSET TO THE OUTPUT PREPBUFR -C FILE. WILL ALSO UPDATE LAT/LON IF IT WAS CHANGED DUE TO A WAYPOINT -C ERROR (THIS IS NOT A STACKED EVENT, HOWEVER). -C -C PROGRAM HISTORY LOG: -C 2002-05-07 D. A. KEYSER -- ORIGINAL AUTHOR (ADAPTED FROM SUBROUTINE -C IN EXISTING PROGRAM "PREPOBS_PREPACQC") -C -C USAGE: CALL OBUFR(KOUNT) -C INPUT ARGUMENT LIST: -C KOUNT - THE NUMBER OF ACARS OBSERVATIONS IN HOLDING ARRAYS -C -C INPUT FILES: -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C UNIT 61 - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACARS QC) -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - - SUBROUTINE OBUFR(KOUNT) - - PARAMETER (IRMX= 250000) - PARAMETER (ISIZE= 18) - - CHARACTER*1 CHRQM(6) - CHARACTER*8 LAST,ACID,AAID(IRMX),SUBSET,POSITN,HEADR - CHARACTER*16 TAG,STAG(IRMX) - CHARACTER*20 QM1LVL,QM2LVL,QM3LVL - - REAL(8) HDR_8(2),QMS1_8(4),QMS2_8(5),QMS3_8(4) - REAL RQM(6),SARRAY(IRMX,ISIZE),PHIACF(7) - - INTEGER INDR(IRMX),IARRAY(IRMX),MFLAG(2) - - COMMON/ALLDAT/ACID(IRMX),ALAT(IRMX),ALON(IRMX),AALT(IRMX), - $ TIME(IRMX),ASPD(IRMX),ADIR(IRMX),TBASE,ATMP(IRMX),ASPH(IRMX), - $ TAG(IRMX),IRTM(IRMX),INTP(IRMX),KNTINI(IRMX),ITEVNT(IRMX), - $ IWEVNT(IRMX),ATMPF(IRMX),AALTF(IRMX),ASPDF(IRMX),ADIRF(IRMX), - $ IQEVNT(IRMX) - COMMON/OUTPUT/KNTOUT(2) - COMMON/INPT/TMAXO,TMINO,JAMASS(6),JAWIND(6),RCPTST - 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 QM3LVL/'QOB QQM QPC QRC '/ - 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'/) -C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING - - DO J = 1,KOUNT - 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) - SARRAY(J,17) = ASPH(J) - SARRAY(J,18) = REAL(IQEVNT(J)) - STAG(J) = TAG(J) - IARRAY(J) = KNTINI(J) - ENDDO - -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 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) - ASPH(I) = SARRAY(J,17) - IQEVNT(I) = NINT(SARRAY(J,18)) - TAG(I) = STAG(J) - ENDDO - - CALL DATELEN(10) - CALL OPENBF(14,'IN',14) - PRINT 200 - 200 FORMAT(/5X,'+++> PREPBUFR 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,'+++> PREPBUFR 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'/) - -C GET THE "PROGRAM CODE" CORRESPONDING TO "ACARSQC" - CALL UFBQCD1(14,'ACARSQC',PCODE) - - 10 CONTINUE - -C READ IN NEXT BUFR MESSAGE FROM INPUT FILE - CALL READMG(14,SUBSET,IDATEP,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.'AIRCAR ') THEN - 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,'===> PREPBUFR DATA ' - $,'SET IN UNIT 14 SUCCESSFULLY CLOSED FROM FINAL READ OF ALL OBS') - CALL CLOSBF(61) - PRINT 9102 - 9102 FORMAT(/5X,'===> PREPBUFR 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.'AIRCAR ') 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.'AIRCAR ') THEN - CALL UFBCNT(61,IRECO,ISUBO) - ISUBOT = ISUBOT + ISUBO - PRINT 1254, IRECO,LAST,ISUBO,ISUBOT -C MUST CLOSE THE LAST "AIRCAR" TABLE A ENTRY MESSAGE - CALL CLOSMG(61) - END IF - PRINT 105, SUBSET,IDATEP - 105 FORMAT(/' ===> NEXT MESSAGE IN OUTPUT PREPBUFR DATA SET IN ', - $ 'UNIT 61 HAS NEW TABLE A ENTRY OF "',A6,'" -- DATE IS',I11) - CALL UFBCNT(61,IRECOL,ISUBO) - IRECOL = IRECOL + 1 - END IF - LAST = SUBSET - IF(SUBSET.NE.'AIRCAR ') THEN -C ALL TABLE A ENTRY BUFR MESSAGES THAT ARE NOT "AIRCAR" 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 "AIRCAR" MESSAGES COME HERE TO DECODE/ENCODE EACH SUBSET - CALL OPENMB(61,SUBSET,IDATEP) - - 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_8,2,1,N1LEV,HEADR) - IF(N1LEV.NE.1) GO TO 999 - KNEW = 0 - IF(HDR_8(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(MIN(MFLAG(1),MFLAG(2)).EQ.1) TAG(KKK)(4:4) = 'D' - KKK = KKK + 1 - MFLAG(1) = 1 - MFLAG(2) = 1 - END IF - IFLAG = 0 - KNTBFR = KNTBFR + 1 - END IF - SQNL = HDR_8(2) -C DETERMINE IF THIS "AIRCAR" 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 IBNDA = 1,5 - IF(ALAT(KKK).LT.(PHIACF(IBNDA+1)-0.005)) GO TO 6701 - ENDDO - IBNDA = 6 - 6701 CONTINUE - KI = NINT(HDR_8(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) THEN - IF(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_8,4,1,N1LEV,QM1LVL) - IF(N1LEV.NE.1) GO TO 999 - QMS1_8(2) = 2. - QMS1_8(3) = PCODE - QMS1_8(4) = ITEVNT(KKK) - DO I = 1,6 - IF(TAG(KKK)(1:1).EQ.CHRQM(I)) THEN - QMS1_8(2) = RQM(I) - EXIT - END IF - ENDDO - CALL UFBINT(61,QMS1_8,4,1,IRET,QM1LVL) - END IF - IF(IQEVNT(KKK).GT.0) THEN -C --> COME HERE IF THERE IS A SPECIFIC HUMIDITY EVENT (NEW Q. MARKER) -C STACK NEW Q.MARK, PGM CODE, REASON CODE (EVENT) AND SHUM OB - CALL UFBINT(14,QMS3_8,4,1,N1LEV,QM3LVL) - IF(N1LEV.NE.1) GO TO 999 - QMS3_8(2) = 2. - QMS3_8(3) = PCODE - QMS3_8(4) = IQEVNT(KKK) - DO I = 1,6 - IF(TAG(KKK)(2:2).EQ.CHRQM(I)) THEN - QMS3_8(2) = RQM(I) - EXIT - END IF - ENDDO - CALL UFBINT(61,QMS3_8,4,1,IRET,QM3LVL) - 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_8,5,1,N1LEV,QM2LVL) - IF(N1LEV.NE.1) GO TO 999 - QMS2_8(2) = 2. - QMS2_8(3) = PCODE - QMS2_8(4) = IWEVNT(KKK) - DO I = 1,6 - IF(TAG(KKK)(3:3).EQ.CHRQM(I)) THEN - QMS2_8(2) = RQM(I) - EXIT - END IF - ENDDO - CALL UFBINT(61,QMS2_8,5,1,IRET,QM2LVL) - 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.',I5,' WITH',I5,' REPORTS (TOTAL NO. REPORTS ', - $ 'WRITTEN =',I7,')'/) - END IF - ISUBO = ISUBON - - 3 CONTINUE - -CCCCC IF(KNEW.EQ.1) THEN -CCCCC PRINT 6111, KKK,ACID(KKK),TIME(KKK),ALAT(KKK),ALON(KKK), -CCCCC$ AALT(KKK),ATMP(KKK),ASPH(KKK),ADIR(KKK),ASPD(KKK), -CCCCC$ TAG(KKK)(1:3),TAG(KKK)(4:16),INTP(KKK),KNTINI(KKK),ITEVNT(KKK), -CCCCC$ IQEVNT(KKK),IWEVNT(KKK) -C6111 FORMAT(' ',I5,2X,A8,3X,F5.0,2(3X,F6.2),1X,F6.0,2(4X,F5.1),2X, -CCCCC$ F4.0,3X,F4.1,4X,A3,3X,A13,I6,I8,3I6) -CCCCC END IF - GO TO 2 - -C----------------------------------------------------------------------- - 999 CONTINUE -C THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS IS NOT 1!! -- STOP 70 - PRINT 217 - 217 FORMAT(/' THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS FOR', - $ ' A REPORT IS NOT 1 -- STOP 70'/) - CALL W3TAGE('PREPOBS_ACARSQC') - CALL ERREXIT(70) -C----------------------------------------------------------------------- - - END - -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CMDDFF CONVERTS WIND U/V COMPONENTS TO DIR/SPD -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-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 1995-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: FORTRAN 90 -C MACHINE: IBM-SP -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 UFBQCD1(LUNIT,NEMO,QCD) - - CHARACTER*(*) NEMO - CHARACTER*6 FXY,ADN30 - CHARACTER*1 TAB - -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - - CALL STATUS(LUNIT,LUN,IL,IM) - IF(IL.EQ.0) GOTO 900 - - CALL NEMTAB(LUN,NEMO,IDN,TAB,IRET) - IF(TAB.NE.'D') then - QCD = 14 ! hardwire when missing - return - endif - - FXY = ADN30(IDN,6) - IF(FXY(2:3).NE.'63') GOTO 902 - READ(FXY(4:6),'(F3.0)',ERR=903) QCD - - RETURN -900 CALL BORT('UFBQCD - FILE IS CLOSED ') -901 CALL BORT('UFBQCD - MISSING OR INVALID TABLE D QC CODE ') -902 CALL BORT('UFBQCD - TABLE D QC CODE DESCRIPTOR NOT 363YYY') -903 CALL BORT('UFBQCD - ERROR READING YYY FROM QC CODE DESCRP') - END diff --git a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/prepobs_acarsqc.merra.parm b/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/prepobs_acarsqc.merra.parm deleted file mode 100644 index 84e45fec..00000000 --- a/src/Applications/NCEP_Paqc/prepobs_acarsqc.fd/prepobs_acarsqc.merra.parm +++ /dev/null @@ -1,9 +0,0 @@ - - Cards for ACARSQC -- Version 7 May 2002 - Here: GMAO/MERRA system -- Effective: origination to present - - &INPUT - WINDOW=3.00, JAMASS = 6*0, JAWIND= 6*0, - FWRITE = .TRUE., IWRITE=.FALSE., EWRITE=.TRUE., EWRITE_7=.FALSE. - / - diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt index bef4d659..ec5a9ec4 100644 --- a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/CMakeLists.txt @@ -4,9 +4,9 @@ if (CMAKE_Fortran_COMPILER_ID MATCHES Intel) endif () ecbuild_add_executable ( - TARGET prepacqc.x - SOURCES prepacqc.f + TARGET prepacqc_profl.x + SOURCES prepacqc.f acftobs_qc.f indexc40.f input_acqc.f output_acqc_noprof.f output_acqc_prof.f sub2mem_mer.f sub2mem_um.f tranQCflags.f pmat.f90 pmat2.f90 pmat3.f90 pietc.f90 pspl.f90 pkind.f90 LIBS NCEP_bufr_r4i4 NCEP_w3_r4i4) file(GLOB parm_files *.parm) -install(FILES ${parm_files} prepobs_landc prepobs_waypoints DESTINATION etc) +install(FILES ${parm_files} DESTINATION etc) diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f new file mode 100644 index 00000000..0e5a03ef --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/acftobs_qc.f @@ -0,0 +1,29961 @@ +ccccc +c 2013-02-07 D. Keyser -- Final changes to run on WCOSS: use formatted print statements +c where previously unformatted print was > 80 characters; use GNU +c standard call "date_and_time" instead of calls to "date" and +c "time" to obtain system date and time to avoid ifort compiler +c warning +c 2014-07-18 D. Keyser -- +c - Keep track of maximum value for number of flights calculated at some +c point during the processing of subroutine acftobs_qc. If, at the end +c of acftobs_qc, this value is at least 90% of the allowed limit +c ("maxflt", set in the main program), post a diagnostic warning message +c to the production joblog file prior to exiting from acftobs_qc. +c - In subr. do_flt and do_reg, return (abnormally) immediately if +c "maxflt" is exceeded rather than waiting to test for this at end of +c do_flt and do_reg and then return (abnormally). Prior to return +c subtract 1 from number of flights so it will remain at "maxflt". The +c immediate return avoids clobbering of memory in these cases. +c - In subr. reorder, where any new flight exceeding "maxflt" replaces the +c previous flight at index "maxflt" in the arrays to avoid an array +c overflow (done in two places original NRL version), post a diagnostic +c warning message to the production joblog file (found a third instance +c where this needs to be done in subr, reorder - original NRL version +c did not trap it and arrays limited to length "maxflt" would have +c overflowed). +c - If "maxflt" is exceeded in subr. dupchk (1 place possible) or in subr. +c do_flt (2 places possible), the abnormal return back to subr. +c acftobs_qc results in subr. acftobs_qc now continuing on but setting a +c flag for "maxflt_exceeded". Prior to this, subr. acftobs_qc itself +c immediately performed an abnormal return back to main program in such +c cases resulting in no more NRL QC processing. Now NRL QC processing +c will continue on to the end of subr. acftobs_qc where the abnormal +c return back to the main program will be triggered by the +c "maxflt_exceeded" flag. +c - There is one, apparently rare, condition where "maxflt" could be +c exceeded in subr. acft_obs itself (within logic which generates master +c list of tail numbers and counts). Since it can't be determined if +c continuing on without processing (QC'ing) any more data would yield +c acceptable results, the program now immediately stops with condition +c code 98 and a diagnostic warning message is posted to the production +c joblog file noting that "maxflt" needs to be increased. Prior to this +c it returned to the main program where it also immediately stopped with +c condition code 98 (so no real change in what happens here, just where +c it happens). +c - Increased format width from I5 to I6 in all places where aircraft obs +c index is listed out (since there now can be > 99999 reports). +c 2013-10-07 Sienkiewicz Initialize some uninitialzed variables in 'benford_qc' and +c 'rejlist_qc', for 'gfortran' compile +c 2016-12-09 D. Keyser -- +c - Since "ACARS" as referred to here is not used and we earlier decided to +c use this to provide a separate category for TAMDARs (for stratifying +c statistics), all printout here changes the term "ACARS" to "TAMDAR". +c In addition, all comments now refer to "TAMDAR" instead of "ACARS". +c - Variables holding latitude and longitude data (including input +c arguments "alat" and "alon") now double precision. XOB and YOB in +c PREPBUFR file now scaled to 10**5 (was 10**2) to handle new v7 AMDAR +c and MDCRS reports which have this higher precision. +c BENEFIT: Retains exact precison here. Improves QC processing. +c - Note: QC here can be improved further by changing logic in many +c places to account for the increased precision. This needs to +c be investigated. For now, locations in code where this +c seems possible are noted by the spanning comments: +c ! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c ! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c - The format for all print statements containing latitude and longitude +c changed to print to 5 decimal places. +c - Intrinsic function "ifix" replaced with "int" for cases where the +c argument is now a real*8 lat or lon (else compiler error if "ifix" +c operates on a real*8 argument). +c +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +ccccc +c +c ################################################################### +c subroutine acftobs_qc +c ################################################################### +c + subroutine acftobs_qc(max_reps,cdtg_an,numreps,krej + x, c_acftreg,c_acftid,itype,idt,idp,alon,alat,pres,ht_ft + x, ob_t,ob_q,ob_dir,ob_spd,t_prcn + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, nchk_t,nchk_q,nchk_d,nchk_s + x, indx,isave,in_bad,c_qc,csort + x, maxflt,kflight,creg_flt,cid_flt,cid_flt_old,l_newflt + x, nobs_flt,iobs_flt,ntot_flt,nrej_flt,ntot_flt_old,nrej_flt_old + x, creg_reg,nobs_reg,ntot_reg,nrej_reg,ntemp_reg,nwind_reg + x, nwhol_reg,creg_reg_tot,nobs_reg_tot,nwhol_reg_tot + x, nrej_reg_tot,ntemp_reg_tot,nwind_reg_tot,nrej_inv_tot + x, nrej_stk_tot,nrej_grc_tot,nrej_pos_tot,nrej_ord_tot + x, nrej_sus_tot,lead_t_tot,lead_d_tot,lead_s_tot,n_xiv_t + x, n_xiv_d,n_xiv_s,sum_xiv_t,sum_xiv_d,sum_xiv_s,sumabs_xiv_t + x, sumabs_xiv_d,sumabs_xiv_s,l_minus9c + x, l_last,l_first_date,l_operational,l_pc,l_ncep,*) +c +c This routine performs qc checks on the combined ACARS, AIREP, PIREP, +c AMDAR and TAMDAR aircraft data. To the extent possible, the data are +c sorted into tracks and checked for consistency along the tracks. + +cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +c For NCEP purposes NRL ACARS applies to TAMDAR - all references to +c ACARS are changed to TAMDAR in printout +cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + +c Adapted from sortacrs--P.M. Pauley's original ACARS QC program +c Most QC checks patterned after those developed by Bill Moninger +c +c Programmer: P.M. Pauley (12/22/97--modified 09/13/99) +c version of 2/9/2000 +c +c Input: arrays containing observations +c +c Output: (possibly re-ordered) arrays containing observations with qc flags set +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + implicit none +c +c Parameter statements +c -------------------- + integer io8,io30,io31,io32,io33,io34,io35,io36,io37,io38 + parameter(io8 = 8) ! i/o unit number for log file +c + parameter(io30 = 30) ! i/o unit for duplicate check rejects + parameter(io31 = 31) ! i/o unit for spike check rejects + parameter(io32 = 32) ! i/o unit for invalid check rejects + parameter(io33 = 33) ! i/o unit for stuck check rejects + parameter(io34 = 34) ! i/o unit for gross check rejects + parameter(io35 = 35) ! i/o unit for position check rejects + parameter(io36 = 36) ! i/o unit for ordering check rejects + parameter(io37 = 37) ! i/o unit for suspect data check rejects + parameter(io38 = 38) ! i/o unit for reject list check rejects +c (If it is desirable to place all rejected reports in a single file, the +c numbers assigned in these parameter statements should be set equal so that +c the bad reports are all written to the bad data file.) +c +c integer nbadlat,nbadwind +c parameter(nbadlat = 63) ! # of acft with decimal lat/lons +c parameter(nbadwind = 198) ! # of acft with flipped winds +c + integer nbadtemp,nblkwind,nblktemp + parameter(nbadtemp = 59) ! # of acft with temps in whole degrees + parameter(nblkwind = 67) ! # of acft blacklisted for wind errors + parameter(nblktemp = 45) ! # of acft blacklisted for temp errors +c + integer imiss + real amiss + parameter(imiss = 99 999) ! integer missing value flag + parameter(amiss = -9999.) ! real missing value flag +c + character*8 cregmiss,cidmiss + parameter(cregmiss = ' ') ! missing value flag for tail number + parameter(cidmiss = '9999-999') ! missing value flag for flight number +c + real ft2m + parameter(ft2m = 3.28084) ! conversion factor to convert ft to m +c + integer idt_near,idt_updn,idt_samflt + parameter(idt_near = 1805) ! time diff between "near" neighbors (was a0) + parameter(idt_updn = 180) ! time diff to check ascents/descents + parameter(idt_samflt = 7200) ! time diff allowed for same flight +c + real htdif_same + parameter(htdif_same = 100.) ! height difference considered negligible +c + real htdif_1min + parameter(htdif_1min = 8000.) ! maximum height difference allowed in one minute +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of input reports allowed + ! (initialized by calling routine) +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c replace above with this in event of future switch to dynamic memory allocation + +callocinteger max_reps ! original number of input reports obtained from +calloc ! first pass through to get total for array allocation +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +c +c Internal QC flags +c ----------------- + character*11 c_qc(max_reps) +c +c Legend for QC flags +c ------------------- +c ( 1:1 ) info about reject +c 'A'--altitude error +c 'B'--report declared bad in decoder or aircraft id = XX999 +c 'd'--near duplicate +c 'D'--exact duplicate +c 'e'--encode error--reject report with missing winds +c 'E'--encode error--report rejected +c 'N'--duplicate check or stuck value check not performed +c 'O'--isolated off-track point +c 'p'--point closer to last rejected point than to current point +c 'P'--unrealistic airspeed +c 'r'--redundant report +c 's'--suspect reports--too few reports to check +c 'S'--suspect reports--too many rejects for flight +c 't'--time error +c 'v'--report failed bounce test +c 'V'--unrealistic vertical speed +c 'W'--waypoint error +c 'X'--isolated minimum/maximum altitude +c '2'--second flight with same ident found +c '.'--good report +c '-'--not checked +c +c 'A'--anomalous +c ( 2:2 ) time \ 'B' or 'b'--bad +c ( 3:3 ) latitude | 'E'--encode error +c ( 4:4 ) longitude | 'I' or 'i'--inconsistent +c ( 5:5 ) pressure/altitude | 'K'--constant (stuck) values +c ( 6:6 ) temperature | 'M'--missing +c ( 7:7 ) direction | 'N'--not checked +c ( 8:8 ) speed | 'R' or 'r'--rehabilitated [1] +c ( 9:9 ) moisture / 'S'--suspect +c '-'--not checked +c '.'--passed checks +c +c (10:10) black lists +c 'C'--aircraft reports temperature in whole deg C +c 'F'--aircraft reports flipped winds (not checked here) +c 'L'--aircraft reports decimal lat/lon (not checked here) +c 'T'--temperature blacklisted +c 'W'--winds blacklisted +c 'O'--both temperature and winds blacklisted +c '.'--passed black-list checks +c +c (11:11) flight phase +c 'a'--low-resolution ascent +c 'A'--high-resolution ascent +c 'd'--low-resolution descent +c 'D'--high-resolution descent +c 'I'--isolated report +c 'L'--level flight +c 'N'--time difference too great to permit check +c 'U'--unknown +c +c [1] If altitude is read and pressure computed, c_qc(ii)(5:5) = 'R' +c If pressure is read and altitude computed, c_qc(ii)(5:5) = 'r' +c +c Data arrays +c ----------- + character*10 cdtg_an ! date time group for analysis + integer numreps_orig ! original number of reports passed in (bad and good) + integer numreps ! number of reports (deemped "good" + ! reports after each QC step) + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + integer idp(max_reps) ! surface pressure change at ob location + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + integer nchk_t(max_reps) ! NCEP QC flag for temperature ob + $, nchk_q(max_reps) ! NCEP QC flag for specific humidity ob + $, nchk_d(max_reps) ! NCEP QC flag for wind direction ob + $, nchk_s(max_reps) ! NCEP QC flag for wind speed ob + logical l_minus9c(max_reps) ! true for mdcrs -9C temperatures +c +c Arrays for mixed duplicates +c --------------------------- + integer maxflt ! maximum number of flights in dataset + ! (initialized by calling routine) + integer maxflt_exceeded ! flag to indicate that maxflt has been exceeded (=1, + ! else =0) + character*6 cmaxflt ! character form of maxflt for NCEP print statement +c character*9 c_air_id(max_reps) ! airep flight id for mixed duplicate +ccccdak x, c_acr_id(max_reps) ! acars flight id for mixed duplicate +c x, c_acr_id(max_reps) ! tamdar flight id for mixed duplicate +ccccdak character*8 c_acr_reg(maxflt) ! acars tail number for mixed duplicate +c character*8 c_acr_reg(maxflt) ! tamdar tail number for mixed duplicate +c integer idt_min(maxflt) ! min time for flight segment +c $, idt_max(maxflt) ! max time for flight segment +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports + $, in_bad(max_reps) ! pointer index for bad reports + $, isave(max_reps) ! second pointer index + $, krej ! counter for number of reports rejected +c +c Blacklists +c ---------- + character*8 cbadtemp(nbadtemp) ! acft reports temperature in whole deg C +c $, cbadlat(nbadlat) ! acft reports decimal lat/lon +c $, cbadwind(nbadwind) ! acft reports flipped winds + $, cblkwind(nblkwind) ! winds blacklisted + $, cblktemp(nblktemp) ! temperatures blacklisted +c +c Flight statistics +c ----------------- + integer kflight ! number of flights in dataset + integer kflight_max ! number of flights in dataset (maximum over course of + ! processing) + character*8 creg_flt(maxflt) ! tail number for each flight + character*9 cid_flt(maxflt) ! flight id for each flight + $, cid_flt_old(maxflt) ! previous value of cid_flt + integer nobs_flt(maxflt) ! number of reports per flight + $, iobs_flt(maxflt) ! index for first report in each flight + $, ntot_flt(maxflt) ! total number of reports per flight + $, nrej_flt(maxflt) ! number of reports rejected per flight + $, ntot_flt_old(maxflt)! previous value of total number of reports per flight + $, nrej_flt_old(maxflt)! previous value of # of reports rejected per flight +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail numbers in dataset + integer kreg_max ! actual number of tail numbers in dataset (maximum + ! over course of processing) + character*8 creg_reg(maxflt) ! tail numbers + integer nobs_reg(maxflt,5) ! number of reports per tail number per type + integer ntot_reg(maxflt,5) ! total number of reports rejected per tail number + integer nrej_reg(maxflt,5) ! number of reports rejected per tail number + integer ntemp_reg(maxflt,5) ! number of reports w. rejected temp + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds + integer nwhol_reg(maxflt,5) ! number of reports w. temp in whole deg +c + integer kreg_tot ! number of unique tail numbers + integer kreg_tot_max ! number of unique tail numbers (maximum over course + ! of processing) + character*8 creg_reg_tot(maxflt)! master list of tail numbers + integer nobs_reg_tot(maxflt,5) ! number of reports per tail number + $, nwhol_reg_tot(maxflt,5)! number of temps in whole degs /tail number + $, nrej_reg_tot(maxflt,5) ! number of reports rejected per tail number + $, ntemp_reg_tot(maxflt,5)! number of temps rejected per tail number + $, nwind_reg_tot(maxflt,5)! number of winds rejected per tail number + $, nrej_inv_tot(maxflt,5) ! number of reports rejected in invalid + $, nrej_stk_tot(maxflt,5) ! number of reports rejected in stkchek + $, nrej_grc_tot(maxflt,5) ! number of reports rejected in grchek + $, nrej_pos_tot(maxflt,5) ! number of reports rejected in poschek + $, nrej_ord_tot(maxflt,5) ! number of reports rejected in ordchek + $, nrej_sus_tot(maxflt,5) ! number of reports rejected in suspect data check + integer lead_t_tot(maxflt,11,2) ! distribution of temperature innovations + $, lead_d_tot(maxflt,11,2) ! distribution of temperature innovations + $, lead_s_tot(maxflt,11,2) ! distribution of temperature innovations + $, n_xiv_t(maxflt,2) ! number of temperature innovations + $, n_xiv_d(maxflt,2) ! number of wind direction innovations + $, n_xiv_s(maxflt,2) ! number of wind speed innovations + integer mm ! do loop index--over tail numbers + real percent ! percentage of obs rejected + real sum_xiv_t(maxflt,2) ! sum of temperature innovations + $, sum_xiv_d(maxflt,2) ! sum of wind direction innovations + $, sum_xiv_s(maxflt,2) ! sum of wind speed innovations + $, sumabs_xiv_t(maxflt,2) ! sum of absolute value of temperature innovations + $, sumabs_xiv_d(maxflt,2) ! sum of absolute value of wind direction innovations + $, sumabs_xiv_s(maxflt,2) ! sum of absolute value of wind speed innovations + logical l_newflt(maxflt) ! true if flight is new flight +c +c Data counters +c ------------- + integer kbadtot ! total number of rejected reports + $, n_minus9C(5) ! number of -9C temperatures rejected +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type +c + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Other variables +c --------------- + integer ii ! do loop index + $, kk ! do loop index + $, iob ! do loop index--over reports + $, len ! length of filename +ccccdak integer knt_acars ! number of acars reports + integer knt_acars ! number of tamdar reports + $, knt_mdcrs ! number of mdcrs reports + $, knt_man_airep ! number of manual airep reports + $, knt_man_Yairep ! number of manual YRXX airep reports + $, knt_airep ! number of airep reports + $, knt_amdar ! number of amdar reports +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + $, kidt ! relative time + 100 000 for sort +c + integer iht_ft ! integer form of flight level + $, ilat ! integer form of latitude + $, ilon ! integer form of longitude +c $, kdup(maxflt) ! number of mixed duplicates per id pair +c + integer kdtg_an ! integer form of date-time group + $, k_AMDAR_tot ! total number of AMDAR reports + $, k_AIREP_tot ! total number of AIREP reports + $, k_UAL_tot ! total number of UAL AIREP reports + $, k_EU_tot ! total number of EU AIREP reports + $, k_AU_tot ! total number of AU AIREP reports + $, k_other_tot ! total number of other AIREP reports + $, k_AIREP_good ! number of good AIREP reports + $, k_YAIREP_good ! number of good YRXX86 AIREP reports + $, k_UAL_good ! number of good UAL AIREP reports + $, k_EU_good ! number of good EU AIREP reports + $, k_AU_good ! number of good AU AIREP reports + $, k_other_good ! number of good other AIREP reports + real per_AIREP ! percentage of good AIREP reports + $, per_UAL ! percentage of good UAL AIREP reports + $, per_EU ! percentage of good EU AIREP reports + $, per_AU ! percentage of good AU AIREP reports + $, per_other ! percentage of good other AIREP reports +c + integer k_total ! total number of aircraft reports + $, k_good ! number of good aircraft reports + $, k_tot_mdcrs ! total number of unspecified mdcrs reports + $, k_good_mdcrs ! number of good unspecified mdcrs reports + $, k_tot_mdcrs_lvl ! total number of level mdcrs reports + $, k_good_mdcrs_lvl ! number of good level mdcrs reports + $, k_tot_mdcrs_asc ! total number of ascent mdcrs reports + $, k_good_mdcrs_asc ! number of good ascent mdcrs reports + $, k_tot_mdcrs_des ! total number of descent mdcrs reports + $, k_good_mdcrs_des ! number of good descent mdcrs reports + $, k_tot_amdar ! total number of unspecified amdar reports + $, k_good_amdar ! number of good unspecified amdar reports + $, k_tot_amdar_lvl ! total number of level amdar reports + $, k_good_amdar_lvl ! number of good level amdar reports + $, k_tot_amdar_asc ! total number of ascent amdar reports + $, k_good_amdar_asc ! number of good ascent amdar reports + $, k_tot_amdar_des ! total number of descent amdar reports + $, k_good_amdar_des ! number of good descent amdar reports + $, k_tot_airep ! total number of unspecified airep reports + $, k_good_airep ! number of good unspecified airep reports + $, k_tot_airep_lvl ! total number of level airep reports + $, k_good_airep_lvl ! number of good level airep reports + $, k_tot_airep_asc ! total number of ascent airep reports + $, k_good_airep_asc ! number of good ascent airep reports + $, k_tot_airep_des ! total number of descent airep reports + $, k_good_airep_des ! number of good descent airep reports + $, k_tot_man_airep ! total number of man_airep reports + $, k_good_man_airep ! number of good man_airep reports +c + character*6 c_ht_ft ! character form of flight level + character*4 c_type ! character form of ob type + character*5 c_lat ! character form of latitude + character*6 c_lon ! character form of longitude + character*7 c_idt ! character form of relative time + character*25 csort(max_reps) ! variable used for sorting data +c + character*200 c_path ! path name for output files + integer lpath ! length of c_path +c + character*200 infile30 ! file name for rejected duplicates + $, infile31 ! file name for rejected spike reports + $, infile32 ! file name for rejected invalid reports + $, infile33 ! file name for rejected stuck reports + $, infile34 ! file name for rejected gross errors + $, infile35 ! file name for rejected position errors + $, infile36 ! file name for rejected ordering errors + $, infile37 ! file name for rejected suspect data errors + $, infile38 ! file name for rejected reject list reports + $, logfile ! file name for log file +c + logical l_opn ! true if file is already open + $, l_first ! true first time subroutine is called + $, l_first_date ! true for first date + ! (initialized by calling routine) + $, l_print ! true for printing values + $, l_sort ! true if data need to be sorted + $, l_flight ! true if flight stats to be updated + $, l_found ! true if tail numbers found on list + $, l_last ! true if last time subroutine is called + ! (initialized by calling routine) + $, l_pc ! if true, set up path names for Pat's PC + ! (initialized by calling routine) + $, l_ncep ! if true, use NCEP preferences + ! (initialized by calling routine) +c + logical l_do_innov ! compute innovation distribution if true + $, l_operational ! run QC in operational mode if true + ! (initialized by calling routine) + $, l_init ! initialize counters if true + $, l_innov_miss ! true if all innovations missing +c +c Data statements +c --------------- +cc +cc List of aircraft that report lat/lon in decimal instead of degrees, +cc minutes, tenths of minutes. (NOTE: this may ONLY be true at FSL) +cc (from W. Moninger at FSL) +cc ------------------------------------------------------------------- +c data cbadlat/'N000UA','N105UA','N106UA','N171UA','N172UA' +c A, 'N173UA','N174UA','N175UA','N176UA','N177UA','N178UA' +c B, 'N179UA','N180UA','N181UA','N182UA','N183UA','N184UA' +c C, 'N185UA','N186UA','N187UA','N188UA','N189UA','N190UA' +c D, 'N191UA','N192UA','N403UP','N404UP','N405UP','N406UP' +c E, 'N410UP','N414UP','N416UP','N417UP','N419UP','N421UP' +c F, 'N425UP','N426UP','N427UP','N429UP','N434UP','N641UA' +c G, 'N642UA','N643UA','N644UA','N645UA','N646UA','N647UA' +c H, 'N648UA','N649UA','N650UA','N651UA','N652UA','N653UA' +c I, 'N654UA','N655UA','N656UA','N657UA','N658UA','N659UA' +c J, 'N660UA','N661UA','N662UA','N663UA'/ +c +c List of aircraft that report temperature in degrees celsius, +c rather than in the expected tenths of degrees. +c (from W. Moninger at FSL) +c (Pseudo-id list derived from Oct 1998 data) +c (Pseudo-id list corrected from Sept 1999 data +c '35SYR4RA','5UUIR4BA','D5KYR5BA','ECOIR4BA' fixed) +c Check by tail number disabled in grchek after 1999100100--modified on 5/3/01 by PMP +c In 19-31 Oct 1999 dataset, the following aircraft were also fixed: +c '2OZYR4JA','4QJYR4BA','CE5YR4BA','NH5YR3BA','PI1IR4ZA', +c 'QJ5IR5BA','UUEYR3ZA','WSAIR3JA','XV2YR3RA','YITYR4ZA' +c ----------------------------------------------------------------------------------- + data cbadtemp/'N916UA', 'N917UA', 'N918UA', 'N919UA', 'N920UA' + A, 'N921UA', 'N923UA', 'N924UA', 'N925UA', 'N926UA' + B, 'N927UA', 'N928UA', 'N929UA', 'N930UA', 'N931UA' + C, 'N932UA', 'N933UA', 'N934UA', 'N936UA', 'N937UA' + D, 'N938UA', 'N940UA', 'N941UA', 'N942UA', 'N944UA' + E, 'N945UA', 'N946UA', 'N947UA', 'N948UA', 'N949UA' + F, 'N950UA', 'N951UA', 'N953UA', 'N954UA' + G, '034IR4RA','2OZYR4JA','4JPIR4RA','4QJYR4BA','A12YR4RA' + H, 'CE5YR4BA','G5GIR5BA','KTQYR3BA','NH5YR3BA','O2KYR4ZA' + J, 'PI1IR4ZA','QJ5IR5BA','QQZYR3ZA','RUMIR3ZA','TGPIR3JA' + K, 'UUEYR3ZA','VAVIR3ZA','WSAIR3JA','XV2YR3RA','YITYR4ZA' + L, 'ZZAYR4JA','35SYR4RA','5UUIR4BA','D5KYR5BA','ECOIR4BA'/ +cc +cc List of Delta MD88s to be flipped. +cc (from W. Moninger at FSL) +cc ---------------------------------- +c data cbadwind/'N900DE','N900DL','N901DE','N901DL','N902DE' +c A, 'N902DL','N903DE','N903DL','N904DE','N904DL','N905DE','N905DL' +c B, 'N906DE','N906DL','N907DE','N907DL','N908DE','N908DL','N909DE' +c C, 'N909DL','N910DE','N910DL','N911DE','N911DL','N912DE','N912DL' +c D, 'N913DL','N914DE','N914DL','N915DE','N915DL','N916DE','N916DL' +c E, 'N917DE','N917DL','N918DE','N918DL','N919DE','N919DL','N920DE' +c F, 'N920DL','N921DE','N921DL','N922DE','N922DL','N923DE','N923DL' +c G, 'N924DE','N924DL','N925DE','N925DL','N926DE','N926DL','N927DE' +c H, 'N927DL','N928DE','N928DL','N929DE','N929DL','N930DE','N930DL' +c I, 'N931DE','N931DL','N932DE','N932DL','N933DE','N933DL','N934DE' +c J, 'N934DL','N935DE','N935DL','N936DE','N936DL','N937DE','N937DL' +c K, 'N938DE','N938DL','N939DE','N939DL','N940DE','N940DL','N941DE' +c L, 'N941DL','N942DE','N942DL','N943DE','N943DL','N944DE','N945DE' +c M, 'N945DL','N946DE','N946DL','N947DE','N947DL','N948DE','N948DL' +c N, 'N949DE','N949DL','N950DE','N950DL','N951DE','N951DL','N952DE' +c O, 'N952DL','N953DE','N953DL','N954DE','N954DL','N955DE','N955DL' +c P, 'N956DE','N956DL','N957DE','N957DL','N958DE','N958DL','N959DE' +c Q, 'N959DL','N960DE','N960DL','N961DE','N961DL','N962DE','N962DL' +c R, 'N963DE','N963DL','N964DE','N964DL','N965DE','N965DL','N966DE' +c S, 'N966DL','N967DE','N967DL','N968DE','N968DL','N969DE','N969DL' +c T, 'N970DE','N970DL','N971DE','N971DL','N972DE','N972DL','N973DE' +c U, 'N973DL','N974DE','N974DL','N975DE','N975DL','N976DE','N976DL' +c V, 'N977DE','N977DL','N978DE','N978DL','N979DE','N979DL','N980DE' +c W, 'N980DL','N981DE','N981DL','N982DE','N982DL','N983DE','N983DL' +c X, 'N984DE','N984DL','N985DE','N985DL','N986DE','N986DL','N987DE' +c Y, 'N987DL','N988DE','N988DL','N989DE','N989DL','N990DE','N990DL' +c Z, 'N991DE','N991DL','N992DE','N992DL','N993DE','N993DL','N994DE' +c a, 'N994DL','N995DE','N995DL','N996DE','N996DL','N997DE','N997DL' +c b, 'N998DE','N998DL','N999DE','N999DL'/ +c +c Aircraft blacklisted for wind errors +c (from W. Moninger at FSL) +c ------------------------------------ + data cblkwind/'N508UA','N581UA','N586UA','N587UA','N902DL' + A, 'N904DL','N908DL','N909DL','N910DL','N911DL','N912DL' + B, 'N913DE','N913DL','N914DE','N914DL','N915DE','N915DL' + C, 'N916DL','N917DE','N917DL','N918DE','N918DL','N919DE' + D, 'N921DL','N922DL','N924DL','N926DL','N928DL','N929DL' + E, 'N930DL','N931DL','N933DL','N934DL','N936DL','N938DL' + F, 'N939DL','N940DL','N941DL','N942DL','N943DL','N944DL' + G, 'N948DL','N949DL','N950DL','N951DL','N952DL','N953DL' + H, 'N954DL','N955DL','N957DL','N958DL','N960DL','N964DL' + I, 'N964DL','N966DL','N967DL','N968DL','N969DL','N970DL' + J, 'N971DL','N972DL','N981DL','N983DL','N984DL','N985DL' + K, 'N986DL','N?O970'/ +c +c Aircraft blacklisted for temperature errors +c (from W. Moninger at FSL) +c ------------------------------------------- + data cblktemp/'N508UA','N581UA','N585UA','N586UA','N587UA' + A, 'N916UA','N917UA','N918UA','N919UA','N920UA','N921UA' + B, 'N922UA','N923UA','N924UA','N925UA','N926UA','N927UA' + C, 'N928UA','N929UA','N930UA','N931UA','N932UA','N933UA' + D, 'N934UA','N935UA','N936UA','N937UA','N938DL','N938UA' + E, 'N940UA','N941UA','N942UA','N944UA','N945UA','N946UA' + F, 'N947UA','N948UA','N949UA','N950UA','N951UA','N952UA' + G, 'N953UA','N954UA','N955UA','N985DL'/ +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + +c Start subroutine. +c ----------------- + write(*,*) + write(*,*) '**********************' + write(*,*) 'Welcome to acftobs_qc' + call system('date') + write(*,*) '**********************' + write(*,*) + + numreps_orig = numreps ! need to save numreps_orig for input to INDEXC later +c +c Set up path for output files +c ---------------------------- + if(l_pc) then + l_init = .false. + l_do_innov = .true. +cc c_path = 'c:\MyFiles\acft_data\acftqc_tfile\' ! path for pc + c_path = 'c:\MyFiles\acft_data\acftqc_tfile\\' ! path for pc + call slen(c_path,lpath) +c + elseif(.not.l_operational) then + l_init = .true. + l_do_innov = .false. + call getenv('INNOVATIONS',c_path) + call slen(c_path,lpath) + c_path = c_path(1:lpath)//'acft/' ! path for Origin + call slen(c_path,lpath) +c + elseif(l_ncep) then + l_init = .true. ! init counters for each run + l_operational = .false. ! extra printout/log files = yes + l_do_innov = .true. + c_path = ' ' ! output will go to working directory + call slen(c_path,lpath) + +c Open log file for acftobs_qc. +c ----------------------------- +c open(io8,status='new') + + else + l_init = .true. + l_do_innov = .false. + endif +c +c Test if log file is already open +c -------------------------------- + print *, 'checking if io8 is open...' + + inquire(unit = io8,opened = l_opn) + print *, 'done checking if io8 is open...',l_opn +c +c Open file if not already open +c ----------------------------- + if(.not.l_opn) then + if(lpath.gt.0) then + logfile = c_path(1:lpath)//'acftqc_'//cdtg_an//'.log' + else + logfile = 'acftqc_'//cdtg_an//'.log' + endif + call slen(logfile,len) + print *, 'trying to open io8 ', trim(logfile) + open(unit = io8, file = logfile(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + print *, 'done trying to open io8' + + endif +c + write(io8,*) + write(io8,*) 'Beginning acftobs_qc!' +c +c Open individual files for rejected data if the assigned unit is not opened +c (The io numbers may all be set equal to put all rejected data in same file.) +c ----------------------------------------------------------------------------- + if(.not.l_operational) then + inquire(unit = io30,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile30 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.dup' + else + infile30 = 'acftqc_'//cdtg_an//'.dup' + endif + call slen(infile30,len) + open(unit = io30, file = infile30(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile30(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile30(1:len),' already open' + endif +c + inquire(unit = io31,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile31 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.spk' + else + infile31 = 'acftqc_'//cdtg_an//'.spk' + endif + call slen(infile31,len) + open(unit = io31, file = infile31(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile31(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile31(1:len),' already open' + endif +c + inquire(unit = io32,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile32 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.inv' + else + infile32 = 'acftqc_'//cdtg_an//'.inv' + endif + call slen(infile32,len) + open(unit = io32, file = infile32(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile32(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile32(1:len),' already open' + endif +c + inquire(unit = io33,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile33 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.stk' + else + infile33 = 'acftqc_'//cdtg_an//'.stk' + endif + call slen(infile33,len) + open(unit = io33, file = infile33(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile33(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile33(1:len),' already open' + endif +c + inquire(unit = io34,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile34 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.grc' + else + infile34 = 'acftqc_'//cdtg_an//'.grc' + endif + call slen(infile34,len) + open(unit = io34, file = infile34(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile34(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile34(1:len),' already open' + endif +c + inquire(unit = io35,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile35 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.inc' + else + infile35 = 'acftqc_'//cdtg_an//'.inc' + endif + call slen(infile35,len) + open(unit = io35, file = infile35(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile35(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile35(1:len),' already open' + endif +c + inquire(unit = io36,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile36 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.ord' + else + infile36 = 'acftqc_'//cdtg_an//'.ord' + endif + call slen(infile36,len) + open(unit = io36, file = infile36(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile36(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile36(1:len),' already open' + endif +c + inquire(unit = io37,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile37 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.sus' + else + infile37 = 'acftqc_'//cdtg_an//'.sus' + endif + call slen(infile37,len) + open(unit = io37, file = infile37(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile37(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile37(1:len),' already open' + endif +c + inquire(unit = io38,opened = l_opn) + if(.not.l_opn) then + if(lpath.gt.0) then + infile38 = c_path(1:lpath)//'acftqc_'//cdtg_an//'.lst' + else + infile38 = 'acftqc_'//cdtg_an//'.lst' + endif + call slen(infile38,len) + open(unit = io38, file = infile38(1:len) + $, form = 'FORMATTED',status = 'UNKNOWN') + write(io8,*) + write(io8,*) infile38(1:len),' successfully opened' + else + write(io8,*) + write(io8,*) infile38(1:len),' already open' + endif + endif +c +c Initialize arrays +c ----------------- + do ii=1,max_reps + csort(ii) = 'zzzzzzzzzzzzzzzzzzzzzzzzz' + indx(ii) = ii + enddo +c + krej = 0 + maxflt_exceeded = 0 +c + kreg = 0 + if(l_first_date) then + kreg_tot = 0 + creg_reg_tot = 'xxxxxxxx' +c + if(.not.l_operational) then + nobs_reg_tot = 0 + nrej_reg_tot = 0 + nrej_inv_tot = 0 + nrej_stk_tot = 0 + nrej_grc_tot = 0 + nrej_pos_tot = 0 + nrej_ord_tot = 0 + nrej_sus_tot = 0 + nwhol_reg_tot = 0 + ntemp_reg_tot = 0 + nwind_reg_tot = 0 + endif +c + endif + l_first_date = .false. +c + ntot_reg = 0 +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports before QC processing' + write(io8,*) '----------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Count reports by aircraft data type +c ----------------------------------- + knt_acars = 0 + knt_mdcrs = 0 + knt_man_airep = 0 + knt_man_Yairep = 0 + knt_airep = 0 + knt_amdar = 0 +c +c Form variable to sort--time + level + lat + lon + type +c (first sort is to check for duplicates) +c ------------------------------------------------------ + write(io8,*) + write(io8,*) 'Forming variable to sort--time+level+lat+lon+type' + write(io8,*) '-------------------------------------------------' +c + if(l_pc) call p_ddtg('Forming variable to sort',io8) +c + do ii=1,numreps +c + if(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then +c + knt_acars = knt_acars + 1 +c + elseif(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + knt_mdcrs = knt_mdcrs + 1 +c + elseif(itype(ii).eq.i_man_airep) then +c + knt_man_airep = knt_man_airep + 1 +c + elseif(itype(ii).eq.i_man_Yairep) then +c + knt_man_Yairep = knt_man_Yairep + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + knt_airep = knt_airep + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + knt_amdar = knt_amdar + 1 + endif +c + kidt = idt(ii) + 100 000 + if(kidt.ge.1 000 000) + $ write(io8,*) 'kidt too large--',kidt + write(c_idt,'(i6)') kidt +c + if(ht_ft(ii).eq.amiss) then + c_ht_ft = '999999' + else + iht_ft = nint(ht_ft(ii)) + 100 000 + if(iht_ft.ge.200 000) then ! if nint(ht_ft(ii)) = 100,000 or greater + write(io8,*) + write(io8,*) 'iht_ft too large--',iht_ft + write (io8,8001) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii),pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii),idp(ii) + 8001 format(i6,1x,a8,1x,a8,1x,a9,1x + x, i7,1x,2f11.5,1x,f8.1,1x,f7.0,1x + x, f5.2,4(2(1x,f8.2),1x,i5),1x,i4) + iht_ft = imiss + endif + + if(iht_ft.ge.0) then + write(c_ht_ft,'(i6.6)') iht_ft + else + write(c_ht_ft,'(i6.5)') iht_ft + endif + endif +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(ii).eq.amiss) then + c_lat = '99999' + else + ilat = nint(alat(ii)*100.) + if(abs(ilat).ge.100 000) write(io8,*)'ilat too large--',ilat + write(c_lat,'(i5)') ilat + endif +c + if(alon(ii).eq.amiss) then + c_lon = '999999' + else + ilon = nint(alon(ii)*100.) + if(abs(ilon).ge.1 000 000) write(io8,*)'ilon too large--',ilon + write(c_lon,'(i6)') ilon + endif +c + c_type = c_insty_ob(itype(ii)) +c + csort(ii) = c_idt(1:6) + $ //c_ht_ft(1:6) +cc $ //c_ht_ft(1:5) + $ //c_lat(1:5) + $ //c_lon(1:6) + $ //c_type(1:2) + enddo +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + write(io8,*) +ccccdak write(io8,*) 'Number of raw acars reports = ',knt_acars + write(io8,*) 'Number of raw tamdar reports = ',knt_acars + write(io8,*) 'Number of raw mdcrs reports = ',knt_mdcrs + write(io8,*) 'Number of raw man_airep reports = ',knt_man_airep + write(io8,*) 'Number of raw man_Yairep reports = ',knt_man_Yairep + write(io8,*) 'Number of raw airep reports = ',knt_airep + write(io8,*) 'Number of raw amdar reports = ',knt_amdar +c +c Sort reports in file according to array csort +c --------------------------------------------- + write(*,*) 'Sorting reports by time first' + write(io8,*) + write(io8,*) 'Sorting reports by time first' + write(io8,*) '-----------------------------' +c + if(l_pc) call p_ddtg('Calling INDEXC for the first sort',io8) +c + call INDEXC(numreps_orig,csort,indx) +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after first sort' + write(io8,*) '------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform first pass through data--duplicate removal +c -------------------------------------------------- + write(*,*)'Beginning 1st pass through data--duplicate removal' + write(io8,*) + write(io8,*)'Beginning 1st pass through data--duplicate removal' + write(io8,*)'----------------------------------------------------' +c + if(l_pc) call p_ddtg('Calling dupchek_qc',io8) +c + call dupchek_qc(numreps,max_reps,maxflt,htdif_same + $, c_acftreg,c_acftid,c_qc,cdtg_an + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s,kbadtot + $, kreg,creg_reg,nobs_reg,nrej_reg,ntemp_reg,nwind_reg + $, indx,csort,amiss,imiss,io8,io30,l_last,l_operational,l_init + $, l_ncep,*199) + go to 198 + 199 continue + print *, '----------------------------------------------------' + print *, '~~~> maxflt_exceeded -- coming out of call to dupchk' + print *, '----------------------------------------------------' + maxflt_exceeded = 1 + 198 continue + kreg_max = kreg + kreg_tot_max = kreg_tot +cppppp +cc print *, 'after call to dupchek_qc kreg, kreg_tot: ', +cc $ kreg, kreg_tot +cc print *, 'kreg_max, kreg_tot_max: ',kreg_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from dupchek_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .false. + l_print = .false. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = kflight + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 1 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp + +c + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after duplicate removal' + write(io8,*) '-------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Generate master list of tail numbers and counts +c ----------------------------------------------- + if(l_pc) call p_ddtg('Setting up master list of tail numbers',io8) +c + do mm=1,kreg + l_found = .false. +c + if(kreg_tot.ne.0) then + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8)) then + if(.not.l_operational) then + nobs_reg_tot(ii,1:5) = nobs_reg_tot(ii,1:5) + nobs_reg(mm,1:5) + l_found = .true. + endif + endif + enddo + endif +c + if(.not.l_found) then + kreg_tot = kreg_tot + 1 + if(kreg_tot.gt.maxflt) then +c............................................................................................ + write(*,*) 'WARNING: kreg_tot > maxflt--',kreg_tot + +c There are more flights in input file than "maxflt" -- stop abnormally with c. code 98 +c (can't be sure continuing on w/o processing any more data would turn out ok) +c -------------------------------------------------------------------------------------- + print 53, maxflt + 53 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + '"FLIGHTS" IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER ', + + 'NMAE "MAXFLT" - STOP 98'/) + + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmaxflt//' AIRCRAFT "FLIGHT" '// + + 'LIMIT EXCEEDED IN PREPOBS_PREPACQC, STOP 98"') + + call w3tage('PREPOBS_PREPACQC') + call errexit(98) +c............................................................................................ + endif + creg_reg_tot(kreg_tot)(1:8) = creg_reg(mm)(1:8) +c + if(.not.l_operational) then + nobs_reg_tot(kreg_tot,1:5) = nobs_reg(mm,1:5) + endif + endif + enddo +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then +c + if(.not.l_operational) then + ntemp_reg_tot(ii,1:5)=ntemp_reg_tot(ii,1:5)+ntemp_reg(mm,1:5) + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo +c +c Output innovation distributions +c ------------------------------- + if(l_do_innov.and.(.not.l_operational)) then +c + if(l_pc) call p_ddtg('Calling innov_qc',io8) +c + call innov_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s,amiss, + $ c_qc,1,io8,l_init,l_innov_miss) + endif +c +c Examine first digit distribution for comparison with Benford's law +c Perform after duplicate check and before other QC checks +c ------------------------------------------------------------------ + if(l_do_innov.and. + $ (.not.l_operational).and. + $ (.not.l_innov_miss)) then +c + if(l_pc) call p_ddtg('Calling benford_qc',io8) +c + call benford_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s,amiss, + $ c_acftreg,itype,maxflt,kreg_tot,creg_reg_tot, + $ c_qc,lead_t_tot,lead_d_tot,lead_s_tot, + $ n_xiv_t,n_xiv_d,n_xiv_s, + $ sum_xiv_t,sum_xiv_d,sum_xiv_s, + $ sumabs_xiv_t,sumabs_xiv_d,sumabs_xiv_s,1,io8 + $, l_init,l_last) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 1 to benford_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp + endif +c +c Perform second pass through data--spike check +c --------------------------------------------- + write(*,*)'Beginning 2nd pass through data--spike check' + write(io8,*) + write(io8,*)'Beginning 2nd pass through data--spike check' + write(io8,*)'--------------------------------------------' +c + if(l_pc) call p_ddtg('Calling spike_qc',io8) +c + call spike_qc(numreps,max_reps,c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s,idt,itype,ichk_t,ichk_q + $, ichk_d,ichk_s,kbadtot,indx,csort,amiss,imiss,io8 + $, io31,cdtg_an,l_operational,l_init) +c + if(l_pc) call p_ddtg('Back from spike_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .false. + l_print = .false. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 2 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + + if(.not.l_operational) then + nrej_inv_tot(ii,1:5)=nrej_inv_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after spike check' + write(io8,*) '-------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Form variable to sort--flight number + time + level + type +c (second sort is to begin to form tracks) +c ---------------------------------------------------------- + write(io8,*) + write(io8,*) 'Forming variable to sort--flight#+time+level+type' + write(io8,*) '-------------------------------------------------' +c + if(l_pc) call p_ddtg('Forming variable for second sort',io8) +c + do iob=1,numreps + ii = indx(iob) +c +c Exclude previously rejected reports +c ----------------------------------- + if(csort(ii)(1:5).eq.'badob') then + csort(ii) = 'zzzzzzzzzzzzzzzzzzzzzzzzz' +c write(io8,*) 'badob found for iob = ',iob,' ii = ',ii +c + elseif(csort(ii).ne.'zzzzzzzzzzzzzzzzzzzzzzzzz') then +c + kidt = idt(ii) + 100 000 + if(kidt.ge.1 000 000) write(io8,*) 'kidt too large--',kidt + write(c_idt,'(i6)') kidt +c + if(ht_ft(ii).eq.amiss) then + c_ht_ft = '999999' + else + iht_ft = nint(ht_ft(ii)) + 100 000 + if(iht_ft.ge.200 000) then ! if nint(ht_ft(iob)) = 100,000 or greater + write(io8,*) 'iht_ft too large--',iht_ft + write (io8,8001) iob,c_insty_ob(itype(iob)) + x, c_acftreg(iob),c_acftid(iob) + x, idt(iob),alat(iob),alon(iob),pres(iob),ht_ft(iob) + x, t_prcn(iob),ob_t(iob),xiv_t(iob),ichk_t(iob) + x, ob_q(iob),xiv_q(iob),ichk_q(iob) + x, ob_dir(iob),xiv_d(iob),ichk_d(iob) + x, ob_spd(iob),xiv_s(iob),ichk_s(iob),idp(iob) + iht_ft = imiss + endif + + if(iht_ft.ge.0) then + write(c_ht_ft,'(i6.6)') iht_ft + else + write(c_ht_ft,'(i6.5)') iht_ft + endif + endif +c + c_type = c_insty_ob(itype(ii)) +c + csort(ii) = c_acftid(ii)(1:9) + $ //c_idt(1:6) + $ //c_ht_ft(1:6) + $ //c_type(1:2) + $ //' ' + endif + enddo +c +c Sort reports in file according to array csort +c --------------------------------------------- + write(*,*) 'Sorting reports by flight number first' + write(io8,*) + write(io8,*) 'Sorting reports by flight number first' + write(io8,*) '--------------------------------------' +c + if(l_pc) call p_ddtg('Calling INDEXC for second sort',io8) +c + call INDEXC(numreps_orig,csort,indx) +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after second sort' + write(io8,*) '-------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Determine starting index for each flight and number of reports per flight +c ------------------------------------------------------------------------- + write(*,*) 'Determine starting index/length for each flight' + write(io8,*) + write(io8,*) 'Determine starting index/length for each flight' + write(io8,*) '-----------------------------------------------' +c + if(l_pc) call p_ddtg('Calling do_flt',io8) +c + l_first = .true. + l_print = .false. + call do_flt(l_first,numreps,max_reps,c_acftid,c_acftreg,idt, + $ ht_ft,cidmiss,cregmiss,indx,idt_samflt, + $ kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt, + $ nrej_flt,iobs_flt,csort,l_sort,l_print,amiss,io8,*299) + go to 298 + 299 continue + print *, '-------------------------------------------------------' + print *, '~~~> maxflt_exceeded -- coming out of call #1 to do_flt' + print *, '-------------------------------------------------------' + maxflt_exceeded = 1 + 298 continue + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 1 to do_flt kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c +c Re-sort if flight number with two tail numbers was found +c -------------------------------------------------------- + if(l_sort) then +c + write(*,*) 'Re-sorting reports by flight number first' + write(io8,*) + write(io8,*) 'Re-sorting reports by flight number first' + write(io8,*) '-----------------------------------------' +c + if(l_pc) call p_ddtg('Calling INDEXC to redo second sort',io8) +c + call INDEXC(numreps_orig,csort,indx) +c +c Redo starting index for each flight and number of reports per flight +c -------------------------------------------------------------------- + if(l_pc) call p_ddtg('Calling do_flt after re-sort',io8) +c + l_first = .false. + l_print = .false. + call do_flt(l_first,numreps,max_reps,c_acftid,c_acftreg,idt, + $ ht_ft,cidmiss,cregmiss,indx,idt_samflt, + $ kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt, + $ nrej_flt,iobs_flt,csort,l_sort,l_print,amiss,io8,*399) + go to 398 + 399 continue + print *, '-------------------------------------------------------' + print *, '~~~> maxflt_exceeded -- coming out of call #2 to do_flt' + print *, '-------------------------------------------------------' + maxflt_exceeded = 1 + 398 continue + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 2 to do_flt kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c +c Output reports to log file if desired +c ------------------------------------- +c DAK: may want to set l_print=F below to save time and space in prod runs + l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after re-sort' + write(io8,*) '---------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif + endif +c +c Perform third pass through data--invalid data check +c --------------------------------------------------- + write(*,*)'Beginning 3rd pass through data--invalid data check' + write(io8,*) + write(io8,*)'Beginning 3rd pass through data--invalid data check' + write(io8,*)'---------------------------------------------------' +c + if(l_pc) call p_ddtg('Calling invalid_qc',io8) +c + call invalid_qc(numreps,max_reps,c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s,maxflt,kreg,creg_reg,ntemp_reg + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s,kbadtot,n_minus9C + $, indx,csort,amiss,imiss,io8,io32,l_operational,l_init + $, cdtg_an,l_minus9c) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to invalid_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from invalid_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 3 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + + if(.not.l_operational) then + nrej_inv_tot(ii,1:5)=nrej_inv_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + ntemp_reg_tot(ii,1:5)=ntemp_reg_tot(ii,1:5)+ntemp_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after invalid data check' + write(io8,*) '--------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform fourth pass through data--reports with stuck values +c ---------------------------------------------------------- + write(*,*) 'Beginning 4th pass through data--stuck values' + write(io8,*) + write(io8,*) 'Beginning 4th pass through data--stuck values' + write(io8,*) '---------------------------------------------' +c + if(l_pc) call p_ddtg('Calling stk_val_qc',io8) +c + call stk_val_qc(numreps,max_reps,indx,csort,amiss,cdtg_an + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kflight,maxflt,nobs_flt,iobs_flt + $, kreg,creg_reg,nwhol_reg,ntemp_reg,nwind_reg + $, kbadtot,io8,io33,l_operational,l_init,l_ncep) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to stk_val_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from stk_val_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 4 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then +c + if(.not.l_operational) then + nrej_stk_tot(ii,1:5)=nrej_stk_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + nwhol_reg_tot(ii,1:5)=nwhol_reg_tot(ii,1:5)+nwhol_reg(mm,1:5) + ntemp_reg_tot(ii,1:5)=ntemp_reg_tot(ii,1:5)+ntemp_reg(mm,1:5) + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after stuck value check' + write(io8,*) '-------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform fifth pass through data--gross checks +c --------------------------------------------- + write(*,*) 'Beginning 5th pass through data--gross checks' + write(io8,*) + write(io8,*) 'Beginning 5th pass through data--gross checks' + write(io8,*) '---------------------------------------------' +c + if(l_pc) call p_ddtg('Calling grchek_qc',io8) +c + call grchek_qc(numreps,max_reps,indx,csort,amiss,cdtg_an + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, cbadtemp,nbadtemp + $, cblkwind,nblkwind,cblktemp,nblktemp,kbadtot,io8,io34 + $, maxflt,kreg,creg_reg,nwhol_reg,nwind_reg + $, ft2m,l_operational,l_init) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to grchek_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from grchek_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 5 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + + if(.not.l_operational) then + nrej_grc_tot(ii,1:5)=nrej_grc_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + nwhol_reg_tot(ii,1:5)=nwhol_reg_tot(ii,1:5)+nwhol_reg(mm,1:5) + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after gross check' + write(io8,*) '-------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform six pass through data +c Check for inconsistent altitudes or positions in duplicates +c ----------------------------------------------------------- + write(*,*) 'Beginning 6th pass through data--inconsistent posn' + write(io8,*) + write(io8,*) 'Beginning 6th pass through data--inconsistent posn' + write(io8,*) '--------------------------------------------------' +c + if(l_pc) call p_ddtg('Calling poschek_qc',io8) +c + call poschek_qc(numreps,max_reps,indx,csort,imiss,amiss + $, idt_updn,c_acftreg,c_acftid,cidmiss,c_qc,cdtg_an + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kflight,maxflt,nobs_flt,iobs_flt,kbadtot,io8,io35 + $, l_operational,l_init) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to poschek_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from poschek_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 6 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then +c + if(.not.l_operational) then + nrej_pos_tot(ii,1:5)=nrej_pos_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after inconsistent position check' + write(io8,*) '-----------------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Check ordering of near-duplicate reports +c ---------------------------------------- + write(io8,*) + write(io8,*) 'Check ordering of near-duplicates' + write(io8,*) '---------------------------------' +c + if(l_pc) call p_ddtg('Calling orddup_qc',io8) +c + call orddup_qc(max_reps,indx,isave,ht_ft,idt,alat,alon + $, kflight,maxflt,nobs_flt,iobs_flt + $, c_acftreg,c_acftid,cidmiss,idt_near,io8) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to orddup_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from orddup_qc',io8) +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after check of near-dup ordering' + write(io8,*) '----------------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform seventh pass through data--check ordering of flights +c ------------------------------------------------------------ + write(*,*) 'Beginning 7th pass through data--ordering check' + write(io8,*) + write(io8,*) 'Beginning 7th pass through data--ordering check' + write(io8,*) '-----------------------------------------------' +c + if(l_pc) call p_ddtg('Calling ordchek_qc',io8) +c + call ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss,idt_near + $, idt_updn,htdif_same,c_acftreg,c_acftid,cidmiss,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kreg,creg_reg,nwind_reg + $, kflight,maxflt,nobs_flt,ntot_flt,iobs_flt,kbadtot + $, io8,io36,l_operational,l_init) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to ordchek_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from ordchek_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 7 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then +c + if(.not.l_operational) then + nrej_ord_tot(ii,1:5)=nrej_ord_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after ordering check' + write(io8,*) '----------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform eighth pass through data--suspect data check +c ---------------------------------------------------- + write(*,*) 'Beginning 8th pass through data--suspect check' + write(io8,*) + write(io8,*) 'Beginning 8th pass through data--suspect check' + write(io8,*) '----------------------------------------------' +c +c Re-examine data flagged as suspect +c ---------------------------------- + if(l_pc) call p_ddtg('Calling suspect_qc',io8) +c + call suspect_qc(numreps,max_reps,indx,csort,imiss,idt_near,amiss + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, maxflt,kflight,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,kreg,creg_reg,nobs_reg,nwind_reg + $, ntot_reg,kbadtot,io8,io37,l_operational,l_init) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to suspect_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from suspect_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 8 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then +c + if(.not.l_operational) then + nrej_sus_tot(ii,1:5)=nrej_sus_tot(ii,1:5)+nrej_reg(mm,1:5) + nrej_reg_tot(ii,1:5)=nrej_reg_tot(ii,1:5)+nrej_reg(mm,1:5) + endif +c + ntot_reg(mm,1:5)=ntot_reg(mm,1:5)+nrej_reg(mm,1:5) + endif + enddo + enddo + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after suspect data check' + write(io8,*) '--------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c Perform ninth pass through data--reject list check +c -------------------------------------------------- + write(*,*) 'Beginning 9th pass through data--reject list check' + write(io8,*) + write(io8,*) 'Beginning 9th pass through data--reject list check' + write(io8,*) '--------------------------------------------------' +c + if(l_pc) call p_ddtg('Calling rejlist_qc',io8) +c + call rejlist_qc(numreps,max_reps,indx,csort + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, nchk_t,nchk_q,nchk_d,nchk_s + $, maxflt,kreg,creg_reg,nwind_reg,ntemp_reg + $, kbadtot,io8,io38,l_operational,l_init,l_ncep) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call to rejlist_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from rejlist_qc',io8) +c +c Re-order index array to skip bad reports +c ---------------------------------------- + l_flight = .true. + l_print = .true. + if(kbadtot.gt.0) then + call reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 9 to reorder kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp + endif +c + if(.not.l_operational) then + do mm=1,kreg + do ii=1,kreg_tot + if(creg_reg(mm)(1:8).eq.creg_reg_tot(ii)(1:8).and. + $ creg_reg(mm).ne.'xxxxxxxx') then + ntemp_reg_tot(ii,1:5)=ntemp_reg_tot(ii,1:5)+ntemp_reg(mm,1:5) + nwind_reg_tot(ii,1:5)=nwind_reg_tot(ii,1:5)+nwind_reg(mm,1:5) + endif + enddo + enddo + endif +c +c Output reports to log file if desired +c ------------------------------------- + l_print = .false. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Reports after reject list check' + write(io8,*) '-------------------------------' + call pr_workdata(max_reps,numreps,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) + endif +c +c write(io8,*) +c write(io8,*) 'Post-QC reports from HZMYCWBA,415IC1BA, or JHCWUURA' +c write(io8,*) '---------------------------------------------------' +c do iob = 1,max_reps +c ii = iob +cc if(c_acftreg(ii)(1:8).eq.'HZMYCWBA'.or. +cc $ c_acftreg(ii)(1:8).eq.'415IC1BA'.or. +cc $ c_acftreg(ii)(1:8).eq.'JHCWUURA') then +c if(c_acftreg(ii)(1:8).eq.'HN3ICWBA'.or. +c $ c_acftreg(ii)(1:8).eq.'JSYYCURA'.or. +c $ c_acftreg(ii)(1:8).eq.'U5IICUZA'.or. +c $ c_acftreg(ii)(1:8).eq.'415IC1BA'.or. +c $ c_acftreg(ii)(1:8).eq.'OIIYC1ZA'.or. +c $ c_acftreg(ii)(1:8).eq.'E5QYZFRA'.or. +c $ c_acftreg(ii)(1:8).eq.'QNVYCWBA'.or. +c $ c_acftreg(ii)(1:8).eq.'1ZUYC1RA'.or. +c $ c_acftreg(ii)(1:8).eq.'1GUUIRRA'.or. +c $ c_acftreg(ii)(1:8).eq.'JI0KEWJA') then +cc +c write (io8,8011) iob,ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii),pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii),idp(ii) +c x, c_qc(ii),csort(ii) +c 8011 format(i5,1x,i6,1x,a8,1x,a8,1x,a9,1x +c x, i7,1x,2f11.5,1x,f8.1,1x,f7.0,1x +c x, f5.2,4(2(1x,f8.2),1x,i5),1x,i4 +c x, 1x,'!',a11,'!',1x,a25) +c endif +c enddo +c +c Output innovation distributions +c ------------------------------- + if(l_do_innov.and.(.not.l_operational)) then +c + if(l_pc) call p_ddtg('Calling innov_qc',io8) +c + call innov_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s,amiss, + $ c_qc,2,io8,l_init,l_innov_miss) + endif +c +c Examine first digit distribution for comparison with Benford's law +c Perform after all QC checks +c ------------------------------------------------------------------ + if(l_do_innov.and. + $ (.not.l_operational).and. + $ (.not.l_innov_miss)) then +c + if(l_pc) call p_ddtg('Calling benford_qc',io8) +c + call benford_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s,amiss, + $ c_acftreg,itype,maxflt,kreg_tot,creg_reg_tot, + $ c_qc,lead_t_tot,lead_d_tot,lead_s_tot, + $ n_xiv_t,n_xiv_d,n_xiv_s, + $ sum_xiv_t,sum_xiv_d,sum_xiv_s, + $ sumabs_xiv_t,sumabs_xiv_d,sumabs_xiv_s,2,io8 + $, l_init,l_last) + kflight_max = max(kflight,kflight_max) + kreg_max = max(kreg,kreg_max) + kreg_tot_max = max(kreg_tot,kreg_tot_max) +cppppp +cc print *, 'after call 2 to benford_qc kreg, kflight, kreg_tot: ', +cc $ kreg, kflight, kreg_tot +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp +c + if(l_pc) call p_ddtg('Back from benford_qc',io8) +c + endif +c +c Compute statistics for automated AIREPs +c --------------------------------------- +c (Additional AMDAR bulletins turned on Feb 10, 1999--automated AIREPs +c are largely superfluous after that date. Before then, Australian +c and Asian AMDAR reports were only received as AIREPs.) +c -------------------------------------------------------------------- + read(cdtg_an,'(i8)') kdtg_an +c + k_AMDAR_tot = 0 + k_AIREP_tot = 0 + k_AIREP_good = 0 + k_UAL_tot = 0 + k_UAL_good = 0 + k_EU_tot = 0 + k_EU_good = 0 + k_AU_tot = 0 + k_AU_good = 0 + k_other_tot = 0 + k_other_good = 0 + l_print = .true. +c + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'Unrejected re-encoded ACARS and AMDAR reports' + write(io8,*) 'Unrejected re-encoded TAMDAR and AMDAR reports' + write(io8,*) '---------------------------------------------' + endif +c + do ii=1,numreps_orig +c +c Count the total number of AMDAR reports +c --------------------------------------- + if(itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar) then +c + k_AMDAR_tot = k_AMDAR_tot + 1 +c +c Count the total number of AIREP reports +c --------------------------------------- + elseif(itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des.or. + $ itype(ii).eq.i_airep) then +c + k_AIREP_tot = k_AIREP_tot + 1 +c +c Count the total number of UAL AIREPs +ccccdak (Most of these are re-encoded ACARS) +c (Most of these are re-encoded TAMDAR) +c ------------------------------------- + if(c_acftid(ii)(1:3).eq.'UAL') then + k_UAL_tot = k_UAL_tot + 1 +c +c Count the total number of EU AIREPs +c ----------------------------------- + elseif(c_acftid(ii)(1:2).eq.'EU') then + k_EU_tot = k_EU_tot + 1 +c +c Count the total number of AU AIREPs +c ----------------------------------- + elseif(c_acftid(ii)(1:2).eq.'AU') then + k_AU_tot = k_AU_tot + 1 +c +c Count the total number of other AIREPs +c -------------------------------------- + else + k_other_tot = k_other_tot + 1 + endif +c +c Count the number of good AIREP reports +c -------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') then +c + k_AIREP_good = k_AIREP_good + 1 +c +c Count the number of good UAL AIREPs +c ----------------------------------- + if(c_acftid(ii)(1:3).eq.'UAL') then + k_UAL_good = k_UAL_good + 1 +c +c Count the number of good EU AIREPs +c ---------------------------------- + elseif(c_acftid(ii)(1:2).eq.'EU') then + k_EU_good = k_EU_good + 1 +c +c Count the number of good AU AIREPs +c ---------------------------------- + elseif(c_acftid(ii)(1:2).eq.'AU') then + k_AU_good = k_AU_good + 1 +c +c Count the number of good other AIREPs +c ------------------------------------- + else + k_other_good = k_other_good + 1 + endif +c +c Output data after the date the Australian AMDAR was turned on +c ------------------------------------------------------------- + if(kdtg_an.ge.19990210) then +c +c Output reports if desired +c ------------------------- + if(l_print) then + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii),idp(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x + x, f7.0,1x,f5.2,4(2(1x,f8.2),1x,i5),1x,i4,1x,'!',a11,'!') + endif + endif + endif + endif + enddo +c +c Compute and output statistics +c ----------------------------- + if(k_AIREP_tot.gt.0) then + per_AIREP = 100. * k_AIREP_good / k_AIREP_tot + else + per_AIREP = amiss + endif + if(k_UAL_tot.gt.0) then + per_UAL = 100. * k_UAL_good / k_UAL_tot + else + per_UAL = amiss + endif + if(k_EU_tot.gt.0) then + per_EU = 100. * k_EU_good / k_EU_tot + else + per_EU = amiss + endif + if(k_AU_tot.gt.0) then + per_AU = 100. * k_AU_good / k_AU_tot + else + per_AU = amiss + endif + if(k_other_tot.gt.0) then + per_other = 100. * k_other_good / k_other_tot + else + per_other = amiss + endif +c + write(io8,*) + write(io8,*) 'Counts for re-encoded AMDAR reports' + write(io8,*) '-----------------------------------' + write(io8,*) 'Total number of AMDARs = ',k_AMDAR_tot + write(io8,*) + write(io8,*) 'Total number of AIREPs = ',k_AIREP_tot + write(io8,*) ' Total number of UAL = ',k_UAL_tot + write(io8,*) ' Total number of EU = ',k_EU_tot + write(io8,*) ' Total number of AU = ',k_AU_tot + write(io8,*) ' Total number of other = ',k_other_tot + write(io8,*) + write(io8,*) 'Number of good AIREPs = ',k_AIREP_good + write(io8,*) ' Number of UAL = ',k_UAL_good + write(io8,*) ' Number of EU = ',k_EU_good + write(io8,*) ' Number of AU = ',k_AU_good + write(io8,*) ' Number of other = ',k_other_good + write(io8,*) + write(io8,*) 'Percentage of good AIREPs = ',per_AIREP + write(io8,*) ' Percentage of good UAL = ',per_UAL + write(io8,*) ' Percentage of good EU = ',per_EU + write(io8,*) ' Percentage of good AU = ',per_AU + write(io8,*) ' Percentage of good other = ',per_other +c +c Compute similar statistics for YRXX86 AIREPs--keypad reports +c ------------------------------------------------------------ + k_total = 0 + k_good = 0 + k_tot_mdcrs = 0 + k_good_mdcrs = 0 + k_tot_mdcrs_lvl = 0 + k_good_mdcrs_lvl = 0 + k_tot_mdcrs_asc = 0 + k_good_mdcrs_asc = 0 + k_tot_mdcrs_des = 0 + k_good_mdcrs_des = 0 + k_tot_amdar = 0 + k_good_amdar = 0 + k_tot_amdar_lvl = 0 + k_good_amdar_lvl = 0 + k_tot_amdar_asc = 0 + k_good_amdar_asc = 0 + k_tot_amdar_des = 0 + k_good_amdar_des = 0 + k_tot_airep = 0 + k_good_airep = 0 + k_tot_airep_lvl = 0 + k_good_airep_lvl = 0 + k_tot_airep_asc = 0 + k_good_airep_asc = 0 + k_tot_airep_des = 0 + k_good_airep_des = 0 + k_tot_man_airep = 0 + k_good_man_airep = 0 + knt_man_Yairep = 0 + k_YAIREP_good = 0 +c + write(io8,*) + write(io8,*) 'Unrejected YRXX86 keypad AIREP reports' + write(io8,*) '--------------------------------------' +c + do ii=1,numreps_orig +c +c Count the total number of aircraft obs +c -------------------------------------- + if(itype(ii).ne.imiss) then +c + k_total = k_total + 1 +c +c Count the total number of good aircraft obs +c ------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good = k_good + 1 +c + endif +c +c Count the total number of unspecified MDCRS reports +c --------------------------------------------------- + if(itype(ii).eq.i_mdcrs) then +c + k_tot_mdcrs = k_tot_mdcrs + 1 +c +c Count the number of good unspecified MDCRS reports +c -------------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs = k_good_mdcrs + 1 +c +c Count the total number of level MDCRS reports +c --------------------------------------------- + elseif(itype(ii).eq.i_mdcrs_lvl) then +c + k_tot_mdcrs_lvl = k_tot_mdcrs_lvl + 1 +c +c Count the number of good level MDCRS reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_lvl = k_good_mdcrs_lvl + 1 +c +c Count the total number of ascent MDCRS reports +c ---------------------------------------------- + elseif(itype(ii).eq.i_mdcrs_asc) then +c + k_tot_mdcrs_asc = k_tot_mdcrs_asc + 1 +c +c Count the number of good ascent MDCRS reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_asc = k_good_mdcrs_asc + 1 +c +c Count the total number of descent MDCRS reports +c ----------------------------------------------- + elseif(itype(ii).eq.i_mdcrs_des) then +c + k_tot_mdcrs_des = k_tot_mdcrs_des + 1 +c +c Count the number of good descent MDCRS reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_des = k_good_mdcrs_des + 1 +c +c Count the total number of unspecified AMDAR reports +c --------------------------------------------------- + elseif(itype(ii).eq.i_amdar) then +c + k_tot_amdar = k_tot_amdar + 1 +c +c Count the number of good unspecified AMDAR reports +c -------------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar = k_good_amdar + 1 +c +c Count the total number of level AMDAR reports +c --------------------------------------------- + elseif(itype(ii).eq.i_amdar_lvl) then +c + k_tot_amdar_lvl = k_tot_amdar_lvl + 1 +c +c Count the number of good level AMDAR reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_lvl = k_good_amdar_lvl + 1 +c +c Count the total number of ascent AMDAR reports +c ---------------------------------------------- + elseif(itype(ii).eq.i_amdar_asc) then +c + k_tot_amdar_asc = k_tot_amdar_asc + 1 +c +c Count the number of good ascent AMDAR reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_asc = k_good_amdar_asc + 1 +c +c Count the total number of descent AMDAR reports +c ----------------------------------------------- + elseif(itype(ii).eq.i_amdar_des) then +c + k_tot_amdar_des = k_tot_amdar_des + 1 +c +c Count the number of good descent AMDAR reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_des = k_good_amdar_des + 1 +c +c Count the total number of unspecified AIREP reports +c --------------------------------------------------- + elseif(itype(ii).eq.i_airep) then +c + k_tot_airep = k_tot_airep + 1 +c +c Count the number of good unspecified AIREP reports +c -------------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep = k_good_airep + 1 +c +c Count the total number of level AIREP reports +c --------------------------------------------- + elseif(itype(ii).eq.i_airep_lvl) then +c + k_tot_airep_lvl = k_tot_airep_lvl + 1 +c +c Count the number of good level AIREP reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_lvl = k_good_airep_lvl + 1 +c +c Count the total number of ascent AIREP reports +c ---------------------------------------------- + elseif(itype(ii).eq.i_airep_asc) then +c + k_tot_airep_asc = k_tot_airep_asc + 1 +c +c Count the number of good ascent AIREP reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_asc = k_good_airep_asc + 1 +c +c Count the total number of descent AIREP reports +c ----------------------------------------------- + elseif(itype(ii).eq.i_airep_des) then +c + k_tot_airep_des = k_tot_airep_des + 1 +c +c Count the number of good descent AIREP reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_des = k_good_airep_des + 1 +c +c Count the total number of manAIREP reports +c ------------------------------------------- + elseif(itype(ii).eq.i_man_airep) then +c + k_tot_man_airep = k_tot_man_airep + 1 +c +c Count the number of good manAIREP reports +c ----------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_man_airep = k_good_man_airep + 1 +c +c Count the total number of man-Yairep reports +c -------------------------------------------- + elseif(itype(ii).eq.i_man_Yairep) then +c + knt_man_Yairep = knt_man_Yairep + 1 +c +c Count the number of good man-Yairep reports +c ------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') then +c + k_YAIREP_good = k_YAIREP_good + 1 +c +c Output data after the date the Tinker bulletins were turned on +c -------------------------------------------------------------- + if(kdtg_an.ge.20001001) then +c +c Output reports if desired +c ------------------------- + if(l_print) then + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii),idp(ii) + x, c_qc(ii) + endif + endif + endif + endif + enddo +c + if(knt_man_Yairep.gt.0) then + per_AIREP = 100. * k_YAIREP_good / knt_man_Yairep + else + per_AIREP = amiss + endif +c + write(io8,*) + write(io8,*) 'Counts for YRXX86 keypad AIREP reports' + write(io8,*) '--------------------------------------' + write(io8,*) 'Total number of man-Yaireps = ',knt_man_Yairep + write(io8,*) 'Number of good man-Yaireps = ',k_YAIREP_good + write(io8,*) 'Percentage of good man-Yaireps = ',per_AIREP +c +c Output overall totals +c --------------------- + write(io8,*) + write(io8,*) ' Counts by specified data type' + write(io8,*) ' -----------------------------' + write(io8,*) ' Type #Total #Good' + write(io8,*) ' --------------------------' + write(io8,*) 'mdcrs ',k_tot_mdcrs,k_good_mdcrs + write(io8,*) 'mdcrs_lvl',k_tot_mdcrs_lvl,k_good_mdcrs_lvl + write(io8,*) 'mdcrs_asc',k_tot_mdcrs_asc,k_good_mdcrs_asc + write(io8,*) 'mdcrs_des',k_tot_mdcrs_des,k_good_mdcrs_des + write(io8,*) ' --------------------------' + write(io8,*) 'amdar ',k_tot_amdar,k_good_amdar + write(io8,*) 'amdar_lvl',k_tot_amdar_lvl,k_good_amdar_lvl + write(io8,*) 'amdar_asc',k_tot_amdar_asc,k_good_amdar_asc + write(io8,*) 'amdar_des',k_tot_amdar_des,k_good_amdar_des + write(io8,*) ' --------------------------' + write(io8,*) 'airep ',k_tot_airep,k_good_airep + write(io8,*) 'airep_lvl',k_tot_airep_lvl,k_good_airep_lvl + write(io8,*) 'airep_asc',k_tot_airep_asc,k_good_airep_asc + write(io8,*) 'airep_des',k_tot_airep_des,k_good_airep_des + write(io8,*) ' --------------------------' + write(io8,*) 'man_airep',k_tot_man_airep,k_good_man_airep + write(io8,*) 'man-Yaire',knt_man_Yairep,k_YAIREP_good + write(io8,*) ' --------------------------' + write(io8,*) 'total ',k_total,k_good + write(io8,*) ' --------------------------' +c +c Re-count totals using determined data type +c ------------------------------------------ + k_total = 0 + k_good = 0 + k_tot_mdcrs = 0 + k_good_mdcrs = 0 + k_tot_mdcrs_lvl = 0 + k_good_mdcrs_lvl = 0 + k_tot_mdcrs_asc = 0 + k_good_mdcrs_asc = 0 + k_tot_mdcrs_des = 0 + k_good_mdcrs_des = 0 + k_tot_amdar = 0 + k_good_amdar = 0 + k_tot_amdar_lvl = 0 + k_good_amdar_lvl = 0 + k_tot_amdar_asc = 0 + k_good_amdar_asc = 0 + k_tot_amdar_des = 0 + k_good_amdar_des = 0 + k_tot_airep = 0 + k_good_airep = 0 + k_tot_airep_lvl = 0 + k_good_airep_lvl = 0 + k_tot_airep_asc = 0 + k_good_airep_asc = 0 + k_tot_airep_des = 0 + k_good_airep_des = 0 + k_tot_man_airep = 0 + k_good_man_airep = 0 + knt_man_Yairep = 0 + k_YAIREP_good = 0 +c + do ii=1,numreps_orig +c +c Count the total number of aircraft obs +c -------------------------------------- + if(itype(ii).ne.imiss) then +c + k_total = k_total + 1 +c +c Count the total number of good aircraft obs +c ------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good = k_good + 1 +c + endif +c +c Count the total number of manAIREP reports +c ------------------------------------------- + if(itype(ii).eq.i_man_airep) then +c + k_tot_man_airep = k_tot_man_airep + 1 +c +c Count the number of good manAIREP reports +c ----------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_man_airep = k_good_man_airep + 1 +c +c Count the total number of man-Yairep reports +c -------------------------------------------- + elseif(itype(ii).eq.i_man_Yairep) then +c + knt_man_Yairep = knt_man_Yairep + 1 +c +c Count the number of good man-Yairep reports +c ------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + 4 k_YAIREP_good = k_YAIREP_good + 1 +c +c Count the number of level reports +c --------------------------------- + elseif(c_qc(ii)(11:11).eq.'L') then +c +c Count the total number of level MDCRS reports +c --------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + k_tot_mdcrs_lvl = k_tot_mdcrs_lvl + 1 +c +c Count the number of good level MDCRS reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_lvl = k_good_mdcrs_lvl + 1 +c +c Count the total number of level AMDAR reports +c --------------------------------------------- + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + k_tot_amdar_lvl = k_tot_amdar_lvl + 1 +c +c Count the number of good level AMDAR reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_lvl = k_good_amdar_lvl + 1 +c +c Count the total number of level AIREP reports +c --------------------------------------------- + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + k_tot_airep_lvl = k_tot_airep_lvl + 1 +c +c Count the number of good level AIREP reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_lvl = k_good_airep_lvl + 1 +c + endif +c +c Count the number of ascent reports +c ---------------------------------- + elseif(c_qc(ii)(11:11).eq.'A'.or. + $ c_qc(ii)(11:11).eq.'a') then +c +c Count the total number of ascent MDCRS reports +c ---------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + k_tot_mdcrs_asc = k_tot_mdcrs_asc + 1 +c +c Count the number of good ascent MDCRS reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_asc = k_good_mdcrs_asc + 1 +c +c Count the total number of ascent AMDAR reports +c ---------------------------------------------- + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + k_tot_amdar_asc = k_tot_amdar_asc + 1 +c +c Count the number of good ascent AMDAR reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_asc = k_good_amdar_asc + 1 +c +c Count the total number of ascent AIREP reports +c ---------------------------------------------- + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + k_tot_airep_asc = k_tot_airep_asc + 1 +c +c Count the number of good ascent AIREP reports +c --------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_asc = k_good_airep_asc + 1 +c + endif +c +c Count the number of descent reports +c ----------------------------------- + elseif(c_qc(ii)(11:11).eq.'D'.or. + $ c_qc(ii)(11:11).eq.'d') then +c +c Count the total number of descent MDCRS reports +c ----------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + k_tot_mdcrs_des = k_tot_mdcrs_des + 1 +c +c Count the number of good descent MDCRS reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs_des = k_good_mdcrs_des + 1 +c +c Count the total number of descent AMDAR reports +c ----------------------------------------------- + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + k_tot_amdar_des = k_tot_amdar_des + 1 +c +c Count the number of good descent AMDAR reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar_des = k_good_amdar_des + 1 +c +c Count the total number of descent AIREP reports +c ----------------------------------------------- + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + k_tot_airep_des = k_tot_airep_des + 1 +c +c Count the number of good descent AIREP reports +c ---------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep_des = k_good_airep_des + 1 +c + endif +c +c Count the remaining reports +c --------------------------- + else +c +c Count the total number of other MDCRS reports +c --------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + k_tot_mdcrs = k_tot_mdcrs + 1 +c +c Count the number of good other MDCRS reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_mdcrs = k_good_mdcrs + 1 +c +c Count the total number of other AMDAR reports +c --------------------------------------------- + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + k_tot_amdar = k_tot_amdar + 1 +c +c Count the number of good other AMDAR reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_amdar = k_good_amdar + 1 +c +c Count the total number of other AIREP reports +c --------------------------------------------- + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + k_tot_airep = k_tot_airep + 1 +c +c Count the number of good other AIREP reports +c -------------------------------------------- + if(csort(ii)(1:5).ne.'zzzzz'.and. + $ csort(ii)(1:5).ne.'badob') + $ k_good_airep = k_good_airep + 1 +c + endif +c + endif + enddo +c + write(io8,*) + write(io8,*) ' Counts by determined data type' + write(io8,*) ' ------------------------------' + write(io8,*) ' Type #Total #Good' + write(io8,*) ' --------------------------' + write(io8,*) 'mdcrs ',k_tot_mdcrs,k_good_mdcrs + write(io8,*) 'mdcrs_lvl',k_tot_mdcrs_lvl,k_good_mdcrs_lvl + write(io8,*) 'mdcrs_asc',k_tot_mdcrs_asc,k_good_mdcrs_asc + write(io8,*) 'mdcrs_des',k_tot_mdcrs_des,k_good_mdcrs_des + write(io8,*) ' --------------------------' + write(io8,*) 'amdar ',k_tot_amdar,k_good_amdar + write(io8,*) 'amdar_lvl',k_tot_amdar_lvl,k_good_amdar_lvl + write(io8,*) 'amdar_asc',k_tot_amdar_asc,k_good_amdar_asc + write(io8,*) 'amdar_des',k_tot_amdar_des,k_good_amdar_des + write(io8,*) ' --------------------------' + write(io8,*) 'airep ',k_tot_airep,k_good_airep + write(io8,*) 'airep_lvl',k_tot_airep_lvl,k_good_airep_lvl + write(io8,*) 'airep_asc',k_tot_airep_asc,k_good_airep_asc + write(io8,*) 'airep_des',k_tot_airep_des,k_good_airep_des + write(io8,*) ' --------------------------' + write(io8,*) 'man_airep',k_tot_man_airep,k_good_man_airep + write(io8,*) 'man-Yaire',knt_man_Yairep,k_YAIREP_good + write(io8,*) ' --------------------------' + write(io8,*) 'total ',k_total,k_good + write(io8,*) ' --------------------------' +c +c Output totals for each flight +c ----------------------------- + if(.not.l_operational) then + write(io8,*) + write(io8,*) 'Totals for tail#s with rejected reports' + write(io8,*) '---------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nobs_reg_tot(kk,1).ne.0.or. + $ nobs_reg_tot(kk,2).ne.0.or. + $ nobs_reg_tot(kk,3).ne.0.or. + $ nobs_reg_tot(kk,4).ne.0.or. + $ nobs_reg_tot(kk,5).ne.0) then +c + percent = (nrej_reg_tot(kk,1) + nrej_reg_tot(kk,2) + $ + nrej_reg_tot(kk,3) + nrej_reg_tot(kk,4) + $ + nrej_reg_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_reg_tot(kk,1),nrej_reg_tot(kk,2), + $ nrej_reg_tot(kk,3),nrej_reg_tot(kk,4), + $ nrej_reg_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with temp in whole degrees' + write(io8,*) '--------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nwhol_reg_tot(kk,1).ne.0.or. + $ nwhol_reg_tot(kk,2).ne.0.or. + $ nwhol_reg_tot(kk,3).ne.0.or. + $ nwhol_reg_tot(kk,4).ne.0.or. + $ nwhol_reg_tot(kk,5).ne.0) then +c + percent = (nwhol_reg_tot(kk,1) + nwhol_reg_tot(kk,2) + $ + nwhol_reg_tot(kk,3) + nwhol_reg_tot(kk,4) + $ + nwhol_reg_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nwhol_reg_tot(kk,1),nwhol_reg_tot(kk,2), + $ nwhol_reg_tot(kk,3),nwhol_reg_tot(kk,4), + $ nwhol_reg_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with rejected temperatures' + write(io8,*) '--------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(ntemp_reg_tot(kk,1).ne.0.or. + $ ntemp_reg_tot(kk,2).ne.0.or. + $ ntemp_reg_tot(kk,3).ne.0.or. + $ ntemp_reg_tot(kk,4).ne.0.or. + $ ntemp_reg_tot(kk,5).ne.0) then +c + percent = (ntemp_reg_tot(kk,1) + ntemp_reg_tot(kk,2) + $ + ntemp_reg_tot(kk,3) + ntemp_reg_tot(kk,4) + $ + ntemp_reg_tot(kk,5)) *100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ ntemp_reg_tot(kk,1),ntemp_reg_tot(kk,2), + $ ntemp_reg_tot(kk,3),ntemp_reg_tot(kk,4), + $ ntemp_reg_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with rejected winds' + write(io8,*) '-------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nwind_reg_tot(kk,1).ne.0.or. + $ nwind_reg_tot(kk,2).ne.0.or. + $ nwind_reg_tot(kk,3).ne.0.or. + $ nwind_reg_tot(kk,4).ne.0.or. + $ nwind_reg_tot(kk,5).ne.0) then +c + percent = (nwind_reg_tot(kk,1) + nwind_reg_tot(kk,2) + $ + nwind_reg_tot(kk,3) + nwind_reg_tot(kk,4) + $ + nwind_reg_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nwind_reg_tot(kk,1),nwind_reg_tot(kk,2), + $ nwind_reg_tot(kk,3),nwind_reg_tot(kk,4), + $ nwind_reg_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with invalid check errors' + write(io8,*) '-------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_inv_tot(kk,1).ne.0.or. + $ nrej_inv_tot(kk,2).ne.0.or. + $ nrej_inv_tot(kk,3).ne.0.or. + $ nrej_inv_tot(kk,4).ne.0.or. + $ nrej_inv_tot(kk,5).ne.0) then +c + percent = (nrej_inv_tot(kk,1) + nrej_inv_tot(kk,2) + $ + nrej_inv_tot(kk,3) + nrej_inv_tot(kk,4) + $ + nrej_inv_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_inv_tot(kk,1),nrej_inv_tot(kk,2), + $ nrej_inv_tot(kk,3),nrej_inv_tot(kk,4), + $ nrej_inv_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with stuck values' + write(io8,*) '-----------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_stk_tot(kk,1).ne.0.or. + $ nrej_stk_tot(kk,2).ne.0.or. + $ nrej_stk_tot(kk,3).ne.0.or. + $ nrej_stk_tot(kk,4).ne.0.or. + $ nrej_stk_tot(kk,5).ne.0) then +c + percent = (nrej_stk_tot(kk,1) + nrej_stk_tot(kk,2) + $ + nrej_stk_tot(kk,3) + nrej_stk_tot(kk,4) + $ + nrej_stk_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_stk_tot(kk,1),nrej_stk_tot(kk,2), + $ nrej_stk_tot(kk,3),nrej_stk_tot(kk,4), + $ nrej_stk_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with gross check errors' + write(io8,*) '-----------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_grc_tot(kk,1).ne.0.or. + $ nrej_grc_tot(kk,2).ne.0.or. + $ nrej_grc_tot(kk,3).ne.0.or. + $ nrej_grc_tot(kk,4).ne.0.or. + $ nrej_grc_tot(kk,5).ne.0) then +c + percent = (nrej_grc_tot(kk,1) + nrej_grc_tot(kk,2) + $ + nrej_grc_tot(kk,3) + nrej_grc_tot(kk,4) + $ + nrej_grc_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_grc_tot(kk,1),nrej_grc_tot(kk,2), + $ nrej_grc_tot(kk,3),nrej_grc_tot(kk,4), + $ nrej_grc_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with position check errors' + write(io8,*) '--------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_pos_tot(kk,1).ne.0.or. + $ nrej_pos_tot(kk,2).ne.0.or. + $ nrej_pos_tot(kk,3).ne.0.or. + $ nrej_pos_tot(kk,4).ne.0.or. + $ nrej_pos_tot(kk,5).ne.0) then +c + percent = (nrej_pos_tot(kk,1) + nrej_pos_tot(kk,2) + $ + nrej_pos_tot(kk,3) + nrej_pos_tot(kk,4) + $ + nrej_pos_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_pos_tot(kk,1),nrej_pos_tot(kk,2), + $ nrej_pos_tot(kk,3),nrej_pos_tot(kk,4), + $ nrej_pos_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with ordering check errors' + write(io8,*) '--------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_ord_tot(kk,1).ne.0.or. + $ nrej_ord_tot(kk,2).ne.0.or. + $ nrej_ord_tot(kk,3).ne.0.or. + $ nrej_ord_tot(kk,4).ne.0.or. + $ nrej_ord_tot(kk,5).ne.0) then +c + percent = (nrej_ord_tot(kk,1) + nrej_ord_tot(kk,2) + $ + nrej_ord_tot(kk,3) + nrej_ord_tot(kk,4) + $ + nrej_ord_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_ord_tot(kk,1),nrej_ord_tot(kk,2), + $ nrej_ord_tot(kk,3),nrej_ord_tot(kk,4), + $ nrej_ord_tot(kk,5),percent + endif + enddo +c + write(io8,*) + write(io8,*) 'Totals for tail#s with suspect check errors' + write(io8,*) '-------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg_tot + if(nrej_sus_tot(kk,1).ne.0.or. + $ nrej_sus_tot(kk,2).ne.0.or. + $ nrej_sus_tot(kk,3).ne.0.or. + $ nrej_sus_tot(kk,4).ne.0.or. + $ nrej_sus_tot(kk,5).ne.0) then +c + percent = (nrej_sus_tot(kk,1) + nrej_sus_tot(kk,2) + $ + nrej_sus_tot(kk,3) + nrej_sus_tot(kk,4) + $ + nrej_sus_tot(kk,5)) * 100.0 + $ / (nobs_reg_tot(kk,1) + nobs_reg_tot(kk,2) + $ + nobs_reg_tot(kk,3) + nobs_reg_tot(kk,4) + $ + nobs_reg_tot(kk,5)) +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg_tot(kk), + $ nobs_reg_tot(kk,1),nobs_reg_tot(kk,2), + $ nobs_reg_tot(kk,3),nobs_reg_tot(kk,4), + $ nobs_reg_tot(kk,5), + $ nrej_sus_tot(kk,1),nrej_sus_tot(kk,2), + $ nrej_sus_tot(kk,3),nrej_sus_tot(kk,4), + $ nrej_sus_tot(kk,5),percent + endif + enddo + endif +c +c Close files +c ----------- + if(.not.l_operational) then + close(io30) + close(io31) + close(io32) + close(io33) + close(io34) + close(io35) + close(io36) + close(io37) + close(io38) + elseif(l_ncep) then + close(io8) + endif + +cppppp +cc print *, 'kreg_max, kflight_max, kreg_tot_max: ', +cc $ kreg_max, kflight_max, kreg_tot_max +cppppp + kflight_max = max(kreg_max,kflight_max,kreg_tot_max) +cppppp +cc print *, 'overall flight number max:', kflight_max +cppppp + if(kflight_max/.90.gt.maxflt .and. kflight_max.lt.maxflt ) then + +c If the maximum number of calculated flights at some point in this processing read in from +c PREPBUFR file is at least 90% of the maximum number of flights allowed ("maxflt"), print +c diagnostic warning message to production joblog file +c ----------------------------------------------------------------------------------------- + + print 153, kflight_max,maxflt + 153 format(/' #####> WARNING: THE MAX NUMBER OF CALCULATED ', + $ 'AIRCRAFT FLIGHTS FROM INPUT FILE (',I6,') ARE > 90% OF UPPER', + $ ' LIMIT OF ',I6,' -- INCREASE SIZE OF "MAXFLT" SOON!'/) + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '// + + '"***WARNING: HIT 90% OF '//cmaxflt//' AIRCRAFT FLIGHT LIMIT'// + + ' IN PREPOBS_PREPACQC, INCREASE SIZE OF PARM MAXFLT"') + endif + + + write(*,*) + write(*,*) '********************' + write(*,*) 'acftobs_qc has ended' + call system('date') + write(*,*) '--> # flights = ',kflight_max + write(*,*) '********************' + write(*,*) + +c return 1 if # flts > maxflt out of subr. do_flt, and subr. do_reg (latter transferred here +c via subr. dupchek_qc) + if(maxflt_exceeded .gt. 0) then + print *, '--------------------------------------------------' + print *, '~~~> maxflt_exceeded -- return 1 out of acftobs_qc' + print *, '--------------------------------------------------' + return 1 + endif + + return + + end +c +c ################################################################### +c subroutine pr_workdata +c ################################################################### +c + subroutine pr_workdata(max_reps,numdo,indx + x, alat,alon,pres,ht_ft,idt,idp,c_acftreg,c_acftid,itype + x, t_prcn,ob_t,ob_q,ob_dir,ob_spd + x, xiv_t,xiv_q,xiv_d,xiv_s,ichk_t,ichk_q,ichk_d,ichk_s + x, cdtg_an,c_qc,csort,io8) +c +c Print work arrays +c + implicit none +c + integer io8 ! i/o unit number for log file + integer ii,iob ! do loop indices + integer max_reps ! maximum number of observations allowed + $, numdo ! number of reports to print + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + integer idt(max_reps) ! time in seconds to analysis time + integer idp(max_reps) ! surface pressure change at ob location + character*8 c_acftreg(max_reps) ! acft registration (tail) number + character*9 c_acftid(max_reps) ! acft flight number + integer itype(max_reps) ! instrument type + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL quality control flag for temperature ob + $, ichk_q(max_reps) ! NRL quality control flag for specific humidity + $, ichk_d(max_reps) ! NRL quality control flag for wind direction + $, ichk_s(max_reps) ! NRL quality control flag for wind speed + integer indx(max_reps) ! pointer index for reports + character*10 cdtg_an ! date time group for analysis + character*11 c_qc(max_reps) ! quality control flags for reports + character*25 csort(max_reps) ! variable used for sorting data +c + character*16 c_insty_ob ! function to convert integer instrument type + ! to character instrument type +c + integer ihr_an ! hour of analysis time + $, ihr ! ob hour + $, imin ! ob minute + $, isec ! ob second + $, itime ! ob minute/second +c + real*8 wlon ! west longitude +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + write(io8,8030) + 8030 format(' index type tail num flight time hh:mm:ss ' + $,'lat lon pres height t-pr temp ichk dir ichk spd' + $ ' ichk humid ichk') +c + read(cdtg_an,'(8x,i2)') ihr_an +c + do iob = 1,numdo + ii = indx(iob) +c + ihr = idt(ii) / 3600 + if(idt(ii).lt.0) then + itime = (abs(ihr)+1)*3600 + idt(ii) + ihr = ihr_an + ihr - 1 + if(ihr.lt.0) ihr = ihr + 24 + else + itime = idt(ii) - ihr*3600 + ihr = ihr_an + ihr + endif +c + imin = itime / 60 + if(imin.eq.60) then + imin = 0 + ihr = ihr + 1 + itime = itime - 3600 + endif +c + isec = itime - imin*60 +c + if(alon(ii).gt.180.0) then + wlon = alon(ii) - 360.0 + else + wlon = alon(ii) + endif +c +c if(alon(ii).ge.300.0) then + write (io8,8001) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),ihr,imin,isec + x, alat(ii),wlon,pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),ichk_t(ii) + x, ob_dir(ii),ichk_d(ii) + x, ob_spd(ii),ichk_s(ii) + x, ob_q(ii),ichk_q(ii) + 8001 format(i6,1x,a8,1x,a8,1x,a9,1x + x, i6,1x,i2,':',i2.2,':',i2.2,1x + x, f9.5,1x,f10.5,1x,f6.1,1x,f6.0,1x + x, f5.2,1x,f6.2,1x,i4,1x,f4.0,1x,i3,1x + x, f5.1,1x,i3,1x,f6.2,1x,i3) +c endif + enddo +c + return + end +c +c ################################################################### +c subroutine indexc +c ################################################################### +c +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 25-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 ??-??-?? p. m. pauley - size of carrin changed to character*24 +c 10-11-15 s. m. bender - size of carrin changed to character*25 +c +c usage: call indexc(n,carrin,indx) +c input argument list: +c n - size of array to be sorted +c carrin - 25-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: none. +c +c attributes: +c language: Fortran 90 +c machine: NCEP WCOSS +c +c$$$ + subroutine indexc(n,carrin,indx) +c + implicit none +c + integer n ! dimension of array to be sorted + $, j ! do loop index, sort variable + $, i ! sort variable + $, l ! variable used to decide if sort is finished + $, ir ! " " + integer indx(n) ! pointer array + $, indxt ! pointer used in sort +c + character*25 carrin(n) ! input array to be sorted + $, cc ! character variable used in sort +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + do 10 j = 1,n + indx(j) = j + 10 continue +c +c must be > 1 element in sort list, else return +c + if(n.le.1) return +c + l = n/2 + 1 + ir = n +c + 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 +c + i = l + j = l * 2 +c + 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 +c + if(j.le.ir) go to 30 + indx(i) = indxt + go to 33 +c + end +c +c ################################################################### +c subroutine dupchek_qc +c ################################################################### +c + subroutine dupchek_qc(numreps,max_reps,maxflt,htdif_same + $, c_acftreg,c_acftid,c_qc,cdtg_an + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s,kbadtot + $, kreg,creg_reg,nobs_reg,nrej_reg,ntemp_reg,nwind_reg + $, indx,csort,amiss,imiss,io8,io30,l_last,l_operational,l_init + $, l_ncep,*) +c +c Remove duplicates from dataset +c +c Modified 8/15/01 (P.M. Pauley) to change time threshold to 90 seconds. +c 60 sec is required for AMDAR reports from different centers and for +c MDCRS-AIREP duplicates that use different rounding. 63 seconds was +c required to overcome an ISIS2000 error that led to a missing value +c for seconds being interpreted as 63. Finally, 70 seconds is needed +c to catch position report duplicates. The position reports can be +c up to 70 seconds out of sync with the ascent sounding data as a +c result of rounding error. +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + character*10 cdtg_an ! date time group for analysis + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + $, ktype ! pointer for instrument type + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Arrays for mixed duplicates +c --------------------------- + integer maxflt ! max number of flights allowed +c x, ndup ! number of ids with mixed duplicates +c character*9 c_air_id(maxflt) ! airep flight id for mixed duplicate +ccccdak x, c_acr_id(maxflt) ! acars flight id for mixed duplicate +c x, c_acr_id(maxflt) ! tamdar flight id for mixed duplicate +ccccdak character*8 c_acr_reg(maxflt) ! acars tail number for mixed duplicate +c character*8 c_acr_reg(maxflt) ! tamdar tail number for mixed duplicate +c integer kdup(maxflt) ! number of mixed duplicates per id pair +c $, idt_min(maxflt) ! min time for flight segment +c $, idt_max(maxflt) ! max time for flight segment +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io30 ! i/o unit number for rejected dups +c + integer imiss ! integer missing value flag + real amiss ! real missing value flag +c + real htdif_same ! height difference considered negligible + integer idt_dif ! time difference (current - previous) + $, difdir ! difference between wind directions +c +c integer idt_samflt ! time difference allowed for same flight +c $, min_idt,max_idt ! limits on rel time allowed for same flight +c + integer iob ! do loop index + $, ii ! index pointing to current report + $, iim1 ! index pointing to previous report + $, kkdup ! do loop index + integer knt ! counter used to define indices + $, knt0 ! " + $, knt1 ! " + integer isave ! variable used to shuffle indices + $, kbadtot ! total number of rejected duplicates + $, kbad(5,3) ! counter for number of exact, near duplicates +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c + integer n_exact ! number of exact dups + $, n_exact_sh ! number of exact dups with short ids + $, n_ex_sh_MaMa ! --manAIREP-manAIREP + $, n_ex_sh_MaAr ! --manAIREP-AIREP + $, n_ex_sh_MaMd ! --manAIREP-MDCRS +ccccdak $, n_ex_sh_MaAc ! --manAIREP-ACARS + $, n_ex_sh_MaAc ! --manAIREP-TAMDAR + $, n_ex_sh_ArMa ! --AIREP-manAIREP + $, n_ex_sh_ArAr ! --AIREP-AIREP + $, n_exact_0ll ! number of exact dups with zero lat/lon +ccccdak $, n_ex_0ll_AcAc ! --ACARS-ACARS + $, n_ex_0ll_AcAc ! --TAMDAR-TAMDAR + $, n_ex_0ll_MdMd ! --MDCRS-MDCRS + $, n_ex_0ll_MaMa ! --manAIREP-manAIREP + $, n_ex_0ll_MaAr ! --manAIREP-AIREP +ccccdak $, n_exact_MdAc ! number of exact dups--MDCRS-ACARS + $, n_exact_MdAc ! number of exact dups--MDCRS-TAMDAR +ccccdak $, n_exact_AcMa ! number of exact dups--ACARS-manAIREP + $, n_exact_AcMa ! number of exact dups--TAMDAR-manAIREP +ccccdak $, n_exact_AcAr ! number of exact dups--ACARS-AIREP + $, n_exact_AcAr ! number of exact dups--TAMDAR-AIREP + $, n_exact_MdMa ! number of exact dups--MDCRS-manAIREP + $, n_exact_MdAr ! number of exact dups--MDCRS-AIREP + $, n_exact_AmAr ! number of exact dups--AMDAR-AIREP + $, n_exact_AmMa ! number of exact dups--AMDAR-manAIREP + $, n_exact_ArMa ! number of exact dups--AIREP-manAIREP +ccccdak $, n_exact_AcAc ! number of exact dups--ACARS-ACARS + $, n_exact_AcAc ! number of exact dups--TAMDAR-TAMDAR + $, n_exact_MdMd ! number of exact dups--MDCRS-MDCRS + $, n_exact_ArAr ! number of exact dups--AIREP-AIREP + $, n_exact_MaMa ! number of exact dups--manAIREP-manAIREP + $, n_exact_AmAm ! number of exact dups--AMDAR-AMDAR +c + integer n_near ! number of near dups + $, n_near_sh ! number of near dups with short ids + $, n_nr_sh_MaMa ! --manAIREP-manAIREP + $, n_nr_sh_MaAr ! --manAIREP-AIREP + $, n_nr_sh_MaMd ! --manAIREP-MDCRS +ccccdak $, n_nr_sh_MaAc ! --manAIREP-ACARS + $, n_nr_sh_MaAc ! --manAIREP-TAMDAR + $, n_nr_sh_ArMa ! --AIREP-manAIREP + $, n_nr_sh_ArAr ! --AIREP-AIREP + $, n_near_0ll ! number of near dups with zero lat/lon +ccccdak $, n_nr_0ll_AcAc ! --ACARS-ACARS + $, n_nr_0ll_AcAc ! --TAMDAR-TAMDAR + $, n_nr_0ll_MdMd ! --MDCRS-MDCRS + $, n_nr_0ll_MaAr ! --manAIREP-AIREP + $, n_nr_0ll_AmAr ! --AMDAR-AIREP + $, n_nr_0ll_MaMa ! --manAIREP-manAIREP + $, n_nr_0ll_MaMd ! --manAIREP-MDCRS + $, n_nr_0ll_MdMa ! --MDCRS-manAIREP + $, n_nr_0ll_MaAm ! --manAIREP-AMDAR + $, n_nr_0ll_AmMa ! --AMDAR-manAIREP + $, n_near_ws ! number of near dups with missing winds + $, n_nr_mswn_MaMa ! --manAIREP-manAIREP + $, n_nr_mswn_MaAr ! --manAIREP-AIREP + $, n_nr_mswn_MaAm ! --manAIREP-AMDAR + $, n_nr_mswn_ArMa ! --AIREP-manAIREP + $, n_nr_mswn_ArAr ! --AIREP-AIREP +ccccdak $, n_nr_mswn_AcAc ! --ACARS-ACARS + $, n_nr_mswn_AcAc ! --TAMDAR-TAMDAR + $, n_nr_mswn_MdMd ! --MDCRS-MDCRS +ccccdak $, n_nr_mswn_AcMd ! --ACARS-MDCRS + $, n_nr_mswn_AcMd ! --TAMDAR-MDCRS +ccccdak $, n_nr_mswn_MdAc ! --MDCRS-ACARS + $, n_nr_mswn_MdAc ! --MDCRS-TAMDAR + $, n_nr_mswn_MdAm ! --MDCRS-AMDAR + $, n_nr_mswn_MdAr ! --MDCRS-AIREP + $, n_nr_mswn_MdMa ! --MDCRS-manAIREP +ccccdak $, n_nr_mswn_ArAc ! --AIREP-ACARS + $, n_nr_mswn_ArAc ! --AIREP-TAMDAR + $, n_nr_mswn_ArMd ! --AIREP-MDCRS +ccccdak $, n_nr_mswn_MaAc ! --manAIREP-ACARS + $, n_nr_mswn_MaAc ! --manAIREP-TAMDAR + $, n_nr_mswn_MaMd ! --manAIREP-MDCRS + $, n_nr_mswn_AmAm ! --AMDAR-AMDAR + $, n_nr_mswn_ArAm ! --AIREP-AMDAR + $, n_nr_mswn_AmAr ! --AMDAR-AIREP +ccccdak $, n_nr_mswn_AcAm ! --ACARS-AMDAR + $, n_nr_mswn_AcAm ! --TAMDAR-AMDAR + $, n_near_ws_IT ! number of near dups with missing winds + ! and with flight # beginning with 'IT' + $, n_near_ws_EU ! number of near dups with missing winds + ! and with flight # beginning with 'EU' + $, n_near_0ws ! number of near dups with zero winds + $, n_near_0ws_ArAm ! --AIREP-AMDAR + $, n_near_0ws_AmAr ! --AMDAR-AIREP + $, n_near_0ws_AmAm ! --AMDAR-AMDAR + $, n_near_0ws_ArAr ! --AIREP-AIREP + $, n_near_0ws_MaMa ! --manAIREP-manAIREP + $, n_near_0ws_MaMd ! --manAIREP-MDCRS + $, n_near_0ws_MaAm ! --manAIREP-AMDAR + $, n_near_0ws_MaAr ! --manAIREP-AIREP + $, n_near_0ws_ArMd ! --AIREP-MDCRS + $, n_near_0ws_MdMd ! --MDCRS-MDCRS + $, n_near_mst ! number of near dups with missing temperature + $, n_nr_mst_MaMa ! --manAIREP-manAIREP + $, n_nr_mst_MaAr ! --manAIREP-AIREP + $, n_nr_mst_MaAm ! --manAIREP-AMDAR +ccccdak $, n_nr_mst_ArAc ! --AIREP-ACARS + $, n_nr_mst_ArAc ! --AIREP-TAMDAR + $, n_nr_mst_ArMd ! --AIREP-MDCRS +ccccdak $, n_nr_mst_MaAc ! --manAIREP-ACARS + $, n_nr_mst_MaAc ! --manAIREP-TAMDAR + $, n_nr_mst_MaMd ! --manAIREP-MDCRS + $, n_nr_mst_MdMd ! --MDCRS-MDCRS + $, n_nr_mst_ArMa ! --manAIREP-AIREP + $, n_nr_mst_AmAm ! --AMDAR-AMDAR + $, n_nr_mst_ArAr ! --AIREP-AIREP + $, n_nr_mst_AmAr ! --AMDAR-AIREP + $, n_nr_mst_ArAm ! --AIREP-AMDAR +ccccdak $, n_near_MdAc ! number of near dups--MDCRS-ACARS + $, n_near_MdAc ! number of near dups--MDCRS-TAMDAR +ccccdak $, n_near_AcAr ! number of near dups--ACARS-AIREP + $, n_near_AcAr ! number of near dups--TAMDAR-AIREP + $, n_near_MdAr ! number of near dups--MDCRS-AIREP + $, n_near_AmAr ! number of near dups--AMDAR-AIREP +ccccdak $, n_near_AcMa ! number of near dups--ACARS-manAIREP + $, n_near_AcMa ! number of near dups--TAMDAR-manAIREP + $, n_near_MdMa ! number of near dups--MDCRS-manAIREP + $, n_near_ArMa ! number of near dups--AIREP-manAIREP + $, n_near_AmMa ! number of near dups--AIREP-manAIREP +ccccdak $, n_near_AcAc ! number of near dups--ACARS-ACARS + $, n_near_AcAc ! number of near dups--TAMDAR-TAMDAR + $, n_near_MdMd ! number of near dups--MDCRS-MDCRS + $, n_near_ArAr ! number of near dups--AIREP-AIREP + $, n_near_MaMa ! number of near dups--manAIREP-manAIREP + $, n_near_AmAm ! number of near dups--AMDAR-AMDAR + $, n_near_negpos ! number of near dups with neg/pos altitude +c +ccccdak integer n_slow_MdAc ! number of low-wind dups--MDCRS-ACARS + integer n_slow_MdAc ! number of low-wind dups--MDCRS-TAMDAR +ccccdak $, n_slow_AcAr ! number of low-wind dups--ACARS-AIREP + $, n_slow_AcAr ! number of low-wind dups--TAMDAR-AIREP + $, n_slow_MdAr ! number of low-wind dups--MDCRS-AIREP + $, n_slow_AmAr ! number of low-wind dups--AMDAR-AIREP + $, n_slow_ArMa ! number of low-wind dups--AIREP-manAIREP +ccccdak $, n_slow_AcAc ! number of low-wind dups--ACARS-ACARS + $, n_slow_AcAc ! number of low-wind dups--TAMDAR-TAMDAR + $, n_slow_MdMd ! number of low-wind dups--MDCRS-MDCRS + $, n_slow_ArAr ! number of low-wind dups--AIREP-AIREP + $, n_slow_MaMa ! number of low-wind dups--manAIREP-manAIREP + $, n_slow_AmAm ! number of low-wind dups--AMDAR-AMDAR +c + integer n_bad_encode ! number of bad-encode dups +c + integer n_ex_bad_roll_Md ! number of exact bad roll angle dups--MDCRS-MDCRS + integer n_ex_bad_roll_Am ! number of exact bad roll angle dups--AMDAR-AMDAR + integer n_nr_bad_roll_Md ! number of near bad roll angle dups--MDCRS-MDCRS + integer n_nr_bad_roll_Am ! number of near bad roll angle dups--AMDAR-AMDAR + integer n_nr_posrep ! number of position report dups--MDCRS-MDCRS +c + integer n_xx999_Ar ! number of aireps with missing id + $, n_xx999_Ma ! number of manual aireps with missing id + $, n_sh_Ar ! number of aireps with short id + $, n_sh_Ma ! number of manual aireps with short id + $, n_00_Md ! number of mdcrs with rounded position + $, n_0000_Md ! number of mdcrs with rounded position (0,0 deg) +ccccdak $, n_00_Ac ! number of acars with rounded position + $, n_00_Ac ! number of tamdar with rounded position +ccccdak $, n_0000_Ac ! number of acars with rounded position (0,0 deg) + $, n_0000_Ac ! number of tamdar with rounded position (0,0 deg) + $, n_00_Ar ! number of aireps with rounded position + $, n_0000_Ar ! number of aireps with rounded position (0,0 deg) + $, n_00_Ma ! number of manual aireps with rounded position + $, n_0000_Ma ! number of manual aireps with rounded pos (0,0 deg) + $, n_00_Am ! number of amdar with rounded position + $, n_0000_Am ! number of amdar with rounded position (0,0 deg) +c + integer n_lat ! latitude index + $, n_lon ! longitude index + $, n_area_Md(19,37) ! number of mdcrs reports by area +ccccdak $, n_area_Ac(19,37) ! number of acars reports by area + $, n_area_Ac(19,37) ! number of tamdar reports by area + $, n_area_Ar(19,37) ! number of airep reports by area + $, n_area_Ma(19,37) ! number of manual airep reports by area + $, n_area_Am(19,37) ! number of amdar reports by area + $, n_time_Md(24) ! number of mdcrs reports by time +ccccdak $, n_time_Ac(24) ! number of acars reports by time + $, n_time_Ac(24) ! number of tamdar reports by time + $, n_time_Ar(24) ! number of airep reports by time + $, n_time_Ma(24) ! number of manual airep reports by time + $, n_time_Am(24) ! number of amdar reports by time + $, n_lev_Md(53) ! number of mdcrs reports by level +ccccdak $, n_lev_Ac(53) ! number of acars reports by level + $, n_lev_Ac(53) ! number of tamdar reports by level + $, n_lev_Ar(53) ! number of airep reports by level + $, n_lev_Ma(53) ! number of manual airep reports by level + $, n_lev_Am(53) ! number of amdar reports by level + $, klev ! index for level + $, n_temp_Md(36,13) ! number of mdcrs reports by temp, alt +ccccdak $, n_temp_Ac(36,13) ! number of acars reports by temp, alt + $, n_temp_Ac(36,13) ! number of tamdar reports by temp, alt + $, n_temp_Ar(36,13) ! number of airep reports by temp, alt + $, n_temp_Ma(36,13) ! number of manual airep reports by temp, alt + $, n_temp_Am(36,13) ! number of amdar reports by temp, alt + $, ktemp ! index for temperature + $, kalt ! index for altitude + $, n_wspd_Md(40,13) ! number of mdcrs reports by wspd, alt +ccccdak $, n_wspd_Ac(40,13) ! number of acars reports by wspd, alt + $, n_wspd_Ac(40,13) ! number of tamdar reports by wspd, alt + $, n_wspd_Ar(40,13) ! number of airep reports by wspd, alt + $, n_wspd_Ma(40,13) ! number of manual airep reports by wspd, alt + $, n_wspd_Am(40,13) ! number of amdar reports by wspd, alt + $, kwspd ! index for windspeed +c +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak $, nbad_Ac ! number of bad acars + $, nbad_Ac ! number of bad tamdar + $, nbad_Md ! number of bad mdcrs + $, nbad_Ma ! number of bad manual aireps + $, nbad_Ar ! number of bad aireps + $, nbad_Am ! number of bad amdar +ccccdak $, ndup_Ac ! number of duplicate acars + $, ndup_Ac ! number of duplicate tamdar + $, ndup_Md ! number of duplicate mdcrs + $, ndup_Ma ! number of duplicate manual aireps + $, ndup_Ar ! number of duplicate aireps + $, ndup_Am ! number of duplicate amdar +c + integer kk ! index pointing to current flight +c $, kk1 ! index pointing to current flight +c $, kmap ! number of re-mapped flight ids + $, ihr_an ! hour of analysis + $, ihr_ob ! hour of observation +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail#s in dataset + $, mm ! index pointing to current tail number + character*8 creg_reg(maxflt) ! tail numbers + integer nobs_reg(maxflt,5) ! number of reports per tail# per type + integer nrej_reg(maxflt,5) ! number of reports rejected per tail# + integer ntemp_reg(maxflt,5) ! number of reports w. rejected temp + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds +c +c Switches +c -------- + logical l_print ! print values if true + $, l_ii_sh ! true if ii rep has short id + $, l_iim1_sh ! true if iim1 rep has short id + $, l_ii_0lat ! true if ii rep has zero latitude + $, l_iim1_0lat ! true if iim1 rep has zero latitude + $, l_ii_0lon ! true if ii rep has zero latitude + $, l_iim1_0lon ! true if iim1 rep has zero latitude +ccccdak $, l_ii_acars ! true if ii rep is type acars + $, l_ii_acars ! true if ii rep is type tamdar +ccccdak $, l_iim1_acars ! true if iim1 rep is type acars + $, l_iim1_acars ! true if iim1 rep is type tamdar + $, l_ii_mdcrs ! true if ii rep is type mdcrs + $, l_iim1_mdcrs ! true if iim1 rep is type mdcrs + $, l_ii_airep ! true if ii rep is type airep + $, l_iim1_airep ! true if iim1 rep is type airep + $, l_ii_man ! true if ii rep is type manual airep + $, l_iim1_man ! true if iim1 rep is type manual airep + $, l_ii_amdar ! true if ii rep is type amdar + $, l_iim1_amdar ! true if iim1 rep is type amdar + $, l_last ! true if last time subroutine is called + $, l_save_dups ! save dups if true + $, l_operational ! run QC in operational mode if true + $, l_init ! initialize counters if true +c $, l_ual_all ! true if all remapped ids are UAL acft + $, l_ncep ! run QC w/ NCEP preferences if true +c + data l_save_dups/ .false. / +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize variables +c -------------------- +c ndup = 0 + nrej_reg = 0 + ntemp_reg = 0 + nwind_reg = 0 +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then +c + n_exact = 0 + n_exact_sh = 0 + n_ex_sh_MaMa = 0 + n_ex_sh_MaAr = 0 + n_ex_sh_MaMd = 0 + n_ex_sh_MaAc = 0 + n_ex_sh_ArMa = 0 + n_ex_sh_ArAr = 0 + n_exact_0ll = 0 + n_ex_0ll_AcAc = 0 + n_ex_0ll_MdMd = 0 + n_ex_0ll_MaMa = 0 + n_ex_0ll_MaAr = 0 + n_exact_MdAc = 0 + n_exact_AcMa = 0 + n_exact_AcAr = 0 + n_exact_MdMa = 0 + n_exact_MdAr = 0 + n_exact_AmAr = 0 + n_exact_AmMa = 0 + n_exact_ArMa = 0 + n_exact_AcAc = 0 + n_exact_MdMd = 0 + n_exact_ArAr = 0 + n_exact_MaMa = 0 + n_exact_AmAm = 0 +c + n_near = 0 + n_near_sh = 0 + n_nr_sh_MaMa = 0 + n_nr_sh_MaAr = 0 + n_nr_sh_MaMd = 0 + n_nr_sh_MaAc = 0 + n_nr_sh_ArMa = 0 + n_nr_sh_ArAr = 0 + n_near_0ll = 0 + n_nr_0ll_AcAc = 0 + n_nr_0ll_MdMd = 0 + n_nr_0ll_MaAr = 0 + n_nr_0ll_AmAr = 0 + n_nr_0ll_MaMa = 0 + n_nr_0ll_MaMd = 0 + n_nr_0ll_MdMa = 0 + n_nr_0ll_MaAm = 0 + n_nr_0ll_AmMa = 0 + n_near_ws = 0 + n_nr_mswn_MaMa = 0 + n_nr_mswn_MaAr = 0 + n_nr_mswn_MaAm = 0 + n_nr_mswn_ArMa = 0 + n_nr_mswn_ArAr = 0 + n_nr_mswn_AcAc = 0 + n_nr_mswn_MdMd = 0 + n_nr_mswn_AcMd = 0 + n_nr_mswn_MdAc = 0 + n_nr_mswn_MdAm = 0 + n_nr_mswn_MdAr = 0 + n_nr_mswn_MdMa = 0 + n_nr_mswn_ArAc = 0 + n_nr_mswn_ArMd = 0 + n_nr_mswn_MaAc = 0 + n_nr_mswn_MaMd = 0 + n_nr_mswn_AmAm = 0 + n_nr_mswn_ArAm = 0 + n_nr_mswn_AmAr = 0 + n_nr_mswn_AcAm = 0 + n_near_ws_IT = 0 + n_near_ws_EU = 0 + n_near_0ws = 0 + n_near_0ws_ArAm = 0 + n_near_0ws_AmAr = 0 + n_near_0ws_AmAm = 0 + n_near_0ws_ArAr = 0 + n_near_0ws_MaMa = 0 + n_near_0ws_MaMd = 0 + n_near_0ws_MaAm = 0 + n_near_0ws_MaAr = 0 + n_near_0ws_ArMd = 0 + n_near_0ws_MdMd = 0 + n_near_mst = 0 + n_nr_mst_MaMa = 0 + n_nr_mst_MaAr = 0 + n_nr_mst_MaAm = 0 + n_nr_mst_ArAc = 0 + n_nr_mst_ArMd = 0 + n_nr_mst_MaAc = 0 + n_nr_mst_MaMd = 0 + n_nr_mst_MdMd = 0 + n_nr_mst_ArMa = 0 + n_nr_mst_AmAm = 0 + n_nr_mst_ArAr = 0 + n_nr_mst_AmAr = 0 + n_nr_mst_ArAm = 0 + n_near_MdAc = 0 + n_near_AcAr = 0 + n_near_MdAr = 0 + n_near_AmAr = 0 + n_near_AcMa = 0 + n_near_MdMa = 0 + n_near_ArMa = 0 + n_near_AmMa = 0 + n_near_AcAc = 0 + n_near_MdMd = 0 + n_near_ArAr = 0 + n_near_MaMa = 0 + n_near_AmAm = 0 + n_near_negpos = 0 + n_slow_MdAc = 0 + n_slow_AcAr = 0 + n_slow_MdAr = 0 + n_slow_AmAr = 0 + n_slow_ArMa = 0 + n_slow_AcAc = 0 + n_slow_MdMd = 0 + n_slow_ArAr = 0 + n_slow_MaMa = 0 + n_slow_AmAm = 0 +c + n_bad_encode = 0 +c + n_ex_bad_roll_Md = 0 + n_ex_bad_roll_Am = 0 + n_nr_bad_roll_Md = 0 + n_nr_bad_roll_Am = 0 + n_nr_posrep = 0 +c + n_xx999_Ar = 0 + n_xx999_Ma = 0 + n_sh_Ar = 0 + n_sh_Ma = 0 + n_00_Md = 0 + n_0000_Md = 0 + n_00_Ac = 0 + n_0000_Ac = 0 + n_00_Ar = 0 + n_0000_Ar = 0 + n_00_Ma = 0 + n_0000_Ma = 0 + n_00_Am = 0 + n_0000_Am = 0 +c + n_area_Md = 0 + n_area_Ac = 0 + n_area_Ar = 0 + n_area_Ma = 0 + n_area_Am = 0 +c + n_time_Md = 0 + n_time_Ac = 0 + n_time_Ar = 0 + n_time_Ma = 0 + n_time_Am = 0 +c + n_lev_Md = 0 + n_lev_Ac = 0 + n_lev_Ar = 0 + n_lev_Ma = 0 + n_lev_Am = 0 +c + n_temp_Md = 0 + n_temp_Ac = 0 + n_temp_Ar = 0 + n_temp_Ma = 0 + n_temp_Am = 0 +c + n_wspd_Md = 0 + n_wspd_Ac = 0 + n_wspd_Ar = 0 + n_wspd_Ma = 0 + n_wspd_Am = 0 +c + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nbad_Ac = 0 + nbad_Md = 0 + nbad_Ma = 0 + nbad_Ar = 0 + nbad_Am = 0 + ndup_Ac = 0 + ndup_Md = 0 + ndup_Ma = 0 + ndup_Ar = 0 + ndup_Am = 0 + endif +c + read(cdtg_an,'(8x,i2)') ihr_an +c +c Begin loop over reports +c ----------------------- + do iob = 1,numreps +c +c Initialize indices +c ------------------ + ii = indx(iob) + knt0 = iob + knt = iob + if(iob.gt.1) then + iim1 = indx(iob-1) + else + iim1 = 0 + endif +c + if(iob.eq.1.and.c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = 'N' +c +c Set ktype +c --------- + if(itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des.or. + $ itype(ii).eq.i_airep) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c +c Examine the data distribution +c ----------------------------- +c +c Count UA reports with short ids +c ------------------------------- + if(c_acftid(ii)(1:2).eq.'UA'.and. + $ c_acftid(ii)(3:3).ne.'L'.and. + $ ktype.eq.4)then + n_sh_Ar = n_sh_Ar + 1 +c + elseif(c_acftid(ii)(1:2).eq.'UA'.and. + $ c_acftid(ii)(3:3).ne.'L'.and. + $ ktype.eq.5) then + n_sh_Ma = n_sh_Ma + 1 + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c Count reports with lat and lon in whole degrees +c (Count positions of 0.0 lat and 0.0 lon separately) +c --------------------------------------------------- + if((abs(alat(ii)-float(int(alat(ii)))).lt.0.001).and. + $ (abs(alon(ii)-float(int(alon(ii)))).lt.0.001)) then +c + if(ktype.eq.1) then + if(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then + n_0000_Md = n_0000_Md + 1 + else + n_00_Md = n_00_Md + 1 + endif + elseif(ktype.eq.2) then + if(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then + n_0000_Ac = n_0000_Ac + 1 + else + n_00_Ac = n_00_Ac + 1 + endif + elseif(ktype.eq.3) then + if(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then + n_0000_Am = n_0000_Am + 1 + else + n_00_Am = n_00_Am + 1 + endif + elseif(ktype.eq.4) then + if(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then + n_0000_Ar = n_0000_Ar + 1 + else + n_00_Ar = n_00_Ar + 1 + endif + elseif(ktype.eq.5) then + if(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then + n_0000_Ma = n_0000_Ma + 1 + else + n_00_Ma = n_00_Ma + 1 + endif + endif + endif +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Count reports by geographic area +c -------------------------------- + n_lat = int(alat(ii))/10 + 10 + n_lon = int(alon(ii))/10 + 1 +c + if(ktype.eq.1) then + n_area_Md(n_lat,n_lon) = n_area_Md(n_lat,n_lon) + 1 +c + elseif(ktype.eq.2) then + n_area_Ac(n_lat,n_lon) = n_area_Ac(n_lat,n_lon) + 1 +c + elseif(ktype.eq.3) then + n_area_Am(n_lat,n_lon) = n_area_Am(n_lat,n_lon) + 1 +c + elseif(ktype.eq.4) then + n_area_Ar(n_lat,n_lon) = n_area_Ar(n_lat,n_lon) + 1 +c + elseif(ktype.eq.5) then + n_area_Ma(n_lat,n_lon) = n_area_Ma(n_lat,n_lon) + 1 + endif +c +c Count reports by time +c --------------------- + ihr_ob = idt(ii) + ihr_an * 3600 + if(ihr_ob.lt.0) then + ihr_ob = (24 * 3600) + ihr_ob + endif + ihr_ob = ihr_ob / 3600 + if(ihr_ob.lt.0.or.ihr_ob.gt.23) then + if(l_ncep) then +! DAK - NCEP runs centered at 21z (NDAS/RAP), 22z (RAP) and 23z (RAP) have many obs with +! ihr_ob > 23 since obs at the tail end of the time window radius move into the next +! day - so, if ihr_ob is 24-29, change to 00-05 to avoid array overflow here + if(ihr_ob.gt.23.and.ihr_ob.le.29) ihr_ob = ihr_ob - 24 + else + write(io8,*) 'Bad ihr_ob = ',ihr_ob, ihr_an, idt(ii), ii, + $ iob, c_acftid(ii), alat(ii), alon(ii), ht_ft(ii) + endif + endif +c + if(ktype.eq.1) then + n_time_Md(ihr_ob+1) = n_time_Md(ihr_ob+1) + 1 +c + elseif(ktype.eq.2) then + n_time_Ac(ihr_ob+1) = n_time_Ac(ihr_ob+1) + 1 +c + elseif(ktype.eq.3) then + n_time_Am(ihr_ob+1) = n_time_Am(ihr_ob+1) + 1 +c + elseif(ktype.eq.4) then + n_time_Ar(ihr_ob+1) = n_time_Ar(ihr_ob+1) + 1 +c + elseif(ktype.eq.5) then + n_time_Ma(ihr_ob+1) = n_time_Ma(ihr_ob+1) + 1 + endif +c +c Count reports by level, temperature, and windspeed +c -------------------------------------------------- + if(ht_ft(ii).lt.0) then + klev = 53 + elseif(ht_ft(ii).gt.50 000) then + klev = 52 + else + klev = ifix(ht_ft(ii)+500.) / 1000 + 1 + endif +c + if(ht_ft(ii).lt.0) then + kalt = 13 + elseif(ht_ft(ii).gt.50 000) then + kalt = 12 + else + kalt = ifix(ht_ft(ii)) / 5000 + 1 + endif +c + if(ob_t(ii).eq.amiss) then + ktemp = 36 + elseif(ob_t(ii).lt.173.16) then + ktemp = 35 + elseif(ob_t(ii).gt.333.16) then + ktemp = 34 + else + ktemp = (ob_t(ii)-173.16) / 5 + 1 + endif +c + if(ob_spd(ii).eq.amiss) then + kwspd = 40 + elseif(ob_spd(ii).lt.0) then + kwspd = 39 + elseif(ob_spd(ii).gt.180) then + kwspd = 38 + else + kwspd = ob_spd(ii) / 5 + 1 + endif +c + if(ktype.eq.1) then + n_lev_Md(klev) = n_lev_Md(klev) + 1 + n_temp_Md(ktemp,kalt) = n_temp_Md(ktemp,kalt) + 1 + n_wspd_Md(kwspd,kalt) = n_wspd_Md(kwspd,kalt) + 1 +c + elseif(ktype.eq.2) then + n_lev_Ac(klev) = n_lev_Ac(klev) + 1 + n_temp_Ac(ktemp,kalt) = n_temp_Ac(ktemp,kalt) + 1 + n_wspd_Ac(kwspd,kalt) = n_wspd_Ac(kwspd,kalt) + 1 +c + elseif(ktype.eq.3) then + n_lev_Am(klev) = n_lev_Am(klev) + 1 + n_temp_Am(ktemp,kalt) = n_temp_Am(ktemp,kalt) + 1 + n_wspd_Am(kwspd,kalt) = n_wspd_Am(kwspd,kalt) + 1 +c + elseif(ktype.eq.4) then + n_lev_Ar(klev) = n_lev_Ar(klev) + 1 + n_temp_Ar(ktemp,kalt) = n_temp_Ar(ktemp,kalt) + 1 + n_wspd_Ar(kwspd,kalt) = n_wspd_Ar(kwspd,kalt) + 1 +c + elseif(ktype.eq.5) then + n_lev_Ma(klev) = n_lev_Ma(klev) + 1 + n_temp_Ma(ktemp,kalt) = n_temp_Ma(ktemp,kalt) + 1 + n_wspd_Ma(kwspd,kalt) = n_wspd_Ma(kwspd,kalt) + 1 + endif +c +c Count reports with missing ids +c ------------------------------ + if(c_acftid(ii)(1:5).eq.'XX999'.or. + $ c_acftid(ii)(1:4).eq.'////') then +c + if(ktype.eq.4) then + n_xx999_Ar = n_xx999_Ar + 1 +c + elseif(ktype.eq.5) then + n_xx999_Ma = n_xx999_Ma + 1 + endif +c + endif +c +c Check for duplicates--uses algorithm like P. Phoebus's airepd +c Checks tail number, date-time, lat/lon, flight level, temp, winds +c ----------------------------------------------------------------- +c idt_dif = idt(ii) - idt(iim1) +c + idt_dif = 0 + kkdup = 0 +c +c Repeat check for all reports within 90 sec +c (90 sec used to check for dups with position reports--8/15/01) +c -------------------------------------------------------------- +c do while(idt_dif.eq.0.and. +c + do while(idt_dif.le.90.and. + $ idt_dif.ne.imiss.and. + $ iim1.ne.0) +c +c Initialize print switch +c ----------------------- + l_print = .false. +c +c Compute index for previous report +c --------------------------------- + knt = knt - 1 + 10 if(knt.gt.0) then + iim1 = indx(knt) + knt1 = knt + if(c_qc(iim1)(1:1).eq.'D'.or. + $ c_qc(iim1)(1:1).eq.'d'.or. + $ c_qc(iim1)(1:1).eq.'e'.or. + $ c_qc(iim1)(1:1).eq.'E'.or. + $ c_qc(iim1)(1:1).eq.'B') then + knt = knt - 1 + goto 10 + endif + else + iim1 = 0 + knt1 = 0 + endif +c +c Perform check only for valid iim1 +c --------------------------------- + if(iim1.ne.0) then +c +c Compute time difference between reports +c (Allow a time difference of up to 60 sec-- +c dups may have a time difference of 1 min) +c (changed to 90 sec--6/5/01) +c ------------------------------------------ + idt_dif = idt(ii) - idt(iim1) +c + kkdup = kkdup + 1 +c +c Set up logical variables used in testing for duplicates +c ------------------------------------------------------- +c +c iim1 report has short id? +c ------------------------- + l_iim1_sh = .false. + if(itype(iim1).eq.i_man_airep.or. + $ itype(iim1).eq.i_man_Yairep) then +c + if(c_acftid(iim1)(1:8).eq.c_acftid(ii)(1:8)) then + l_iim1_sh = .false. + elseif(c_acftid(ii)(1:3).eq.'UAL') then + if(c_acftid(iim1)(1:2).eq.'UA'.and. + $ c_acftid(iim1)(3:3).ne.'L') then + l_iim1_sh = .true. + else + l_iim1_sh = .false. + endif + elseif(c_acftid(iim1)(1:6).eq.c_acftid(ii)(1:6).and. + $ c_acftid(ii) (7:7).ne.' '.and. + $ c_acftid(iim1)(7:7).eq.' ') then + l_iim1_sh = .true. + elseif(c_acftid(iim1)(1:6).eq. + $ c_acftid(ii)(2:7)) then + l_iim1_sh = .true. + elseif(c_acftid(iim1)(1:6).eq. + $ c_acftid(ii)(1:2)//c_acftid(ii)(4:7)) then + l_iim1_sh = .true. + elseif(c_acftid(iim1)(1:6).eq. + $ c_acftid(ii)(1:3)//c_acftid(ii)(5:7)) then + l_iim1_sh = .true. + endif + endif +c +c ii report has short id? +c ----------------------- + l_ii_sh = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then +c + if(c_acftid(iim1)(1:8).eq.c_acftid(ii)(1:8)) then + l_ii_sh = .false. + elseif(c_acftid(iim1)(1:3).eq.'UAL') then + if(c_acftid(ii)(1:2).eq.'UA'.and. + $ c_acftid(ii)(3:3).ne.'L') then + l_ii_sh = .true. + else + l_ii_sh = .false. + endif + elseif(c_acftid(iim1)(1:6).eq.c_acftid(ii)(1:6).and. + $ c_acftid(iim1)(7:7).ne.' '.and. + $ c_acftid(ii) (7:7).eq.' ') then + l_ii_sh = .true. + elseif(c_acftid(ii)(1:6).eq. + $ c_acftid(iim1)(2:7)) then + l_ii_sh = .true. + elseif(c_acftid(ii)(1:6).eq. + $ c_acftid(iim1)(1:2)//c_acftid(iim1)(4:7)) then + l_ii_sh = .true. + elseif(c_acftid(ii)(1:6).eq. + $ c_acftid(iim1)(1:3)//c_acftid(iim1)(5:7)) then + l_ii_sh = .true. + endif + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c iim1 report has zero latitude? +c ------------------------------ + l_iim1_0lat = .false. + if(abs(alat(iim1)).lt.0.001.and. + $ alat(ii).gt.0.125.and. + $ alat(ii).lt.359.875) + $ l_iim1_0lat = .true. +c +c ii report has zero latitude? +c ---------------------------- + l_ii_0lat = .false. + if(abs(alat(ii)).lt.0.001.and. + $ alat(iim1).gt.0.125.and. + $ alat(iim1).lt.359.875) + $ l_ii_0lat = .true. +c +c iim1 report has zero longitude? +c ------------------------------- + l_iim1_0lon = .false. + if(abs(alon(iim1)).lt.0.001.and. + $ alon(ii).gt.0.125.and. + $ alon(ii).lt.359.875) + $ l_iim1_0lon = .true. +c +c ii report has zero longitude? +c ----------------------------- + l_ii_0lon = .false. + if(abs(alon(ii)).lt.0.001.and. + $ alon(iim1).gt.0.125.and. + $ alon(iim1).lt.359.875) + $ l_ii_0lon = .true. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +ccccdak iim1 report is ACARS? +c iim1 report is TAMDAR? +c ---------------------- + l_iim1_acars = .false. + if(itype(iim1).eq.i_acars.or. + $ itype(iim1).eq.i_acars_lvl.or. + $ itype(iim1).eq.i_acars_des.or. + $ itype(iim1).eq.i_acars_asc) l_iim1_acars = .true. +c +ccccdak ii report is ACARS? +c ii report is TAMDAR? +c -------------------- + l_ii_acars = .false. + if(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_asc) l_ii_acars = .true. +c +c iim1 report is MDCRS? +c --------------------- + l_iim1_mdcrs = .false. + if(itype(iim1).eq.i_mdcrs.or. + $ itype(iim1).eq.i_mdcrs_lvl.or. + $ itype(iim1).eq.i_mdcrs_des.or. + $ itype(iim1).eq.i_mdcrs_asc) l_iim1_mdcrs = .true. +c +c ii report is MDCRS? +c ------------------- + l_ii_mdcrs = .false. + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_asc) l_ii_mdcrs = .true. +c +c iim1 report is AIREP? +c --------------------- + l_iim1_airep = .false. + if(itype(iim1).eq.i_airep.or. + $ itype(iim1).eq.i_airep_lvl.or. + $ itype(iim1).eq.i_airep_des.or. + $ itype(iim1).eq.i_airep_asc) l_iim1_airep = .true. +c +c ii report is AIREP? +c ------------------- + l_ii_airep = .false. + if(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des.or. + $ itype(ii).eq.i_airep_asc) l_ii_airep = .true. +c +c iim1 report is manual AIREP? +c ---------------------------- + l_iim1_man = .false. + if(itype(iim1).eq.i_man_airep.or. + $ itype(iim1).eq.i_man_Yairep) l_iim1_man = .true. +c +c ii report is manual AIREP? +c -------------------------- + l_ii_man = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) l_ii_man = .true. +c +c iim1 report is AMDAR? +c --------------------- + l_iim1_amdar = .false. + if(itype(iim1).eq.i_amdar.or. + $ itype(iim1).eq.i_amdar_lvl.or. + $ itype(iim1).eq.i_amdar_des.or. + $ itype(iim1).eq.i_amdar_asc) l_iim1_amdar = .true. +c +c ii report is AMDAR? +c ------------------- + l_ii_amdar = .false. + if(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_asc) l_ii_amdar = .true. +c +c Compute magnitude of direction difference +c (constrain to be less than 180 deg +c ----------------------------------------- + if(ob_dir(ii).eq.amiss.or. + $ ob_dir(iim1).eq.amiss) then + difdir = amiss + else + difdir = abs(ob_dir(iim1)-ob_dir(ii)) + if(difdir.gt.180) difdir = 360. - difdir + endif +c +c Check if report is exact dup (qc flag = 'D') +c -------------------------------------------- + if(idt_dif.eq.0) then +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if((abs(alat(iim1)-alat(ii)).lt.0.015.or. + $ l_iim1_0lat.or.l_ii_0lat).and. + $ (abs(alon(iim1)-alon(ii)).lt.0.015.or. + $ l_iim1_0lon.or.l_ii_0lon).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (abs(pres(iim1)-pres(ii)).lt.0.05.or. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.0.5).and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.0.05.and. + $ ((abs(difdir).lt.2.5).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).eq.amiss)).and. + $ abs(ob_spd(iim1)-ob_spd(ii)).lt.0.05) then +c +c If exact dup found, decide which report to keep: +ccccdak Choose MDCRS over ACARS +c Choose MDCRS over TAMDAR +ccccdak Choose ACARS/MDCRS over AIREP +c Choose TAMDAR or MDCRS over AIREP +c Choose AMDAR over AIREP +c Choose automated over manual AIREP +c Choose 7-char flight number over 6-char flight number +c Choose present over missing flight/tail number +c Choose non-zero over zero lat or lon +c ------------------------------------------------------- +c +c Keep ob ii +c ---------- + if((l_ii_mdcrs.and.l_iim1_acars).or. + $ (l_ii_acars.and.l_iim1_airep).or. + $ (l_ii_mdcrs.and.l_iim1_airep).or. + $ (l_ii_amdar.and.l_iim1_airep).or. + $ (l_ii_mdcrs.and.l_iim1_man ).or. + $ (l_ii_acars.and.l_iim1_man ).or. + $ (l_ii_amdar.and.l_iim1_man ).or. + $ (l_ii_airep.and.l_iim1_man ).or. + $ l_iim1_sh.or. + $ l_iim1_0lat.or. + $ l_iim1_0lon) then +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'D' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_exact = n_exact + 1 +c + if(l_iim1_sh) then + n_exact_sh = n_exact_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Exact dup found with short id--' + $, ii + endif + if(l_iim1_man.and.l_ii_man) then + n_ex_sh_MaMa = n_ex_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_ex_sh_MaAr = n_ex_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_ex_sh_MaMd = n_ex_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_ex_sh_MaAc = n_ex_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_ex_sh_ArMa = n_ex_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_ex_sh_ArAr = n_ex_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Uncategorized short-id dup' + endif + endif +c + elseif(l_iim1_0lat.or.l_iim1_0lon) then + n_exact_0ll = n_exact_0ll + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Exact dup found with 0l/l--',ii + endif + if(l_iim1_acars.and.l_ii_acars) then + n_ex_0ll_AcAc = n_ex_0ll_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_ex_0ll_MdMd = n_ex_0ll_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_man.and.l_ii_man) then + n_ex_0ll_MaMa = n_ex_0ll_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_ex_0ll_MaAr = n_ex_0ll_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized exact 0l/l dup' + endif + endif +c + elseif(l_ii_mdcrs.and.l_iim1_acars) then + n_exact_MdAc = n_exact_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS exact dup found--' + write(io8,*) 'MDCRS-TAMDAR exact dup found--' + x, ii + endif +c + elseif(l_ii_acars.and.l_iim1_man) then + n_exact_AcMa = n_exact_AcMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-manAIREP exact dup--',ii + write(io8,*) 'TAMDAR-manAIREP exact dup--',ii + endif +c + elseif(l_ii_acars.and.l_iim1_airep) then + n_exact_AcAr = n_exact_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP exact dup--',ii + write(io8,*) 'TAMDAR-AIREP exact dup--',ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_man) then + n_exact_MdMa = n_exact_MdMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-manAIREP exact dup--',ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_airep) then + n_exact_MdAr = n_exact_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP exact dup found--',ii + endif +c + elseif(l_ii_amdar.and.l_iim1_airep) then + n_exact_AmAr = n_exact_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP exact dup found--' + $, ii + endif +c + elseif(l_ii_amdar.and.l_iim1_man) then + n_exact_AmMa = n_exact_AmMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-manAIREP exact dup--',ii + endif +c + elseif(l_ii_airep.and.l_iim1_man) then + n_exact_ArMa = n_exact_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP exact dup--',ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized exact dup-1-',ii + endif + endif +c +c Keep ob iim1 +c ------------ + elseif((l_iim1_mdcrs.and.l_ii_acars).or. + $ (l_iim1_acars.and.l_ii_airep).or. + $ (l_iim1_mdcrs.and.l_ii_airep).or. + $ (l_iim1_amdar.and.l_ii_airep).or. + $ (l_iim1_mdcrs.and.l_ii_man ).or. + $ (l_iim1_acars.and.l_ii_man ).or. + $ (l_iim1_amdar.and.l_ii_man ).or. + $ (l_iim1_airep.and.l_ii_man ).or. + $ l_ii_sh.or. + $ l_ii_0lat.or. + $ l_ii_0lon) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'D' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_exact = n_exact + 1 +c + if(l_ii_sh) then + n_exact_sh = n_exact_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Exact dup with short id--',ii + endif + if(l_ii_man.and.l_iim1_man) then + n_ex_sh_MaMa = n_ex_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_ex_sh_MaAr = n_ex_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_ex_sh_MaMd = n_ex_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_ex_sh_MaAc = n_ex_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_ex_sh_ArMa = n_ex_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_ex_sh_ArAr = n_ex_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Uncategorized short-id dup' + endif + endif +c + elseif(l_ii_0lat.or.l_ii_0lon) then + n_exact_0ll = n_exact_0ll + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Exact dup found with 0l/l--',ii + endif + if(l_iim1_acars.and.l_ii_acars) then + n_ex_0ll_AcAc = n_ex_0ll_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_ex_0ll_MdMd = n_ex_0ll_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_man.and.l_ii_man) then + n_ex_0ll_MaMa = n_ex_0ll_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_ex_0ll_MaAr = n_ex_0ll_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized exact 0l/l dup' + endif + endif +c + elseif(l_iim1_mdcrs.and.l_ii_acars) then + n_exact_MdAc = n_exact_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS exact dup found--' + write(io8,*) 'MDCRS-TAMDAR exact dup found--' + $, ii + endif +c + elseif(l_iim1_acars.and.l_ii_man) then + n_exact_AcMa = n_exact_AcMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-manAIREP exact dup--',ii + write(io8,*) 'TAMDAR-manAIREP exact dup--',ii + endif +c + elseif(l_iim1_acars.and.l_ii_airep) then + n_exact_AcAr = n_exact_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP exact dup--',ii + write(io8,*) 'TAMDAR-AIREP exact dup--',ii + endif +c + elseif(l_iim1_mdcrs.and.l_ii_man) then + n_exact_MdMa = n_exact_MdMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-manAIREP exact dup--',ii + endif +c + elseif(l_iim1_mdcrs.and.l_ii_airep) then + n_exact_MdAr = n_exact_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP exact dup found--',ii + endif +c + elseif(l_iim1_amdar.and.l_ii_airep) then + n_exact_AmAr = n_exact_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP exact dup found--' + $, ii + endif +c + elseif(l_iim1_amdar.and.l_ii_man) then + n_exact_AmMa = n_exact_AmMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-manAIREP exact dup--',ii + endif +c + elseif(l_iim1_airep.and.l_ii_man) then + n_exact_ArMa = n_exact_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP exact dup--',ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized exact dup-2-',ii + endif + endif +c +c Duplicate pair doesn't fall in any of the above categories +c Keep ob ii +c ---------------------------------------------------------- + else +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'D' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_exact = n_exact + 1 +c + if(l_ii_acars.and.l_iim1_acars) then + n_exact_AcAc = n_exact_AcAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-ACARS exact dup found--' + write(io8,*) 'TAMDAR-TAMDAR exact dup found--' + $, ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + if(ichk_s(ii).eq.-10) then + n_ex_bad_roll_Md = n_ex_bad_roll_Md + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc ii--MdMd exact' + endif + ichk_t(ii) = ichk_t(iim1) + ichk_q(ii) = ichk_q(iim1) + ichk_d(ii) = ichk_d(iim1) + ichk_s(ii) = ichk_s(iim1) +c + elseif(ichk_s(iim1).eq.-10) then + n_ex_bad_roll_Md = n_ex_bad_roll_Md + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'Bad roll qc iim1--MdMd exact' + endif +c + else + n_exact_MdMd = n_exact_MdMd + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-MDCRS exact dup--',ii,iim1 + write(io8,*) 'c_qc =..',c_qc(ii),'..',c_qc(iim1) + endif + endif +c + elseif(l_ii_amdar.and.l_iim1_amdar) then + if(ichk_s(ii).eq.-10) then + n_ex_bad_roll_Am = n_ex_bad_roll_Am + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc ii--AmAm exact' + endif + ichk_t(ii) = ichk_t(iim1) + ichk_q(ii) = ichk_q(iim1) + ichk_d(ii) = ichk_d(iim1) + ichk_s(ii) = ichk_s(iim1) +c + elseif(ichk_s(iim1).eq.-10) then + n_ex_bad_roll_Am = n_ex_bad_roll_Am + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'Bad roll qc iim1--AmAm exact' + endif +c + else + n_exact_AmAm = n_exact_AmAm + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AMDAR exact dup--',ii,iim1 + write(io8,*) 'c_qc =..',c_qc(ii),'..',c_qc(iim1) + endif + endif +c + elseif(l_ii_airep.and.l_iim1_airep) then + n_exact_ArAr = n_exact_ArAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-AIREP exact dup found--' + $, ii + endif +c + elseif(l_ii_man.and.l_iim1_man) then + n_exact_MaMa = n_exact_MaMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'manAIREP-manAIREP exact dup--' + $, ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized exact dup-3-',ii + endif + endif + endif + endif + endif +c +c Check if report is a near dup (qc flag = 'd') +c Most near dups came in different formats with different units/precision +c ----------------------------------------------------------------------- +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c First exclude reports that are too far apart--set c_qc to '.' +c ------------------------------------------------------------- + if((abs(alat(iim1)-alat(ii)).lt.0.125.or. + $ ( (l_iim1_0lat.or.l_ii_0lat).and. + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_man.or.l_iim1_man) )).and. + $ (abs(alon(iim1)-alon(ii)).lt.0.125.or. + $ ( (l_iim1_0lon.or.l_ii_0lon).and. + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_man.or.l_iim1_man) ))) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Time threshold changed to 90 sec to look for position reports (8/15/01) +c ----------------------------------------------------------------------- + if((idt_dif.ge.0.and.idt_dif.le.90).and. + $ c_qc(iim1)(1:1).ne.'D'.and. +c +c AMDAR-AIREP dups below 25,000' +c + $ ((ht_ft(ii).lt.25000..and. + $ ifix(ht_ft(iim1)).eq.-ifix(ht_ft(ii)).and. + $ ((( (l_ii_amdar.and.l_iim1_airep).or. + $ (l_ii_airep.and.l_iim1_amdar) ).and. + $ c_acftid(ii).eq.c_acftid(iim1) ).or. ! new + $ l_ii_amdar.and.l_iim1_man.or. + $ l_ii_man.and.l_iim1_amdar ).or. +c +c high-res dups below 25,000' +c + $ abs(ht_ft(iim1)-ht_ft(ii)).lt. + $ htdif_same/4.+0.5).or. +c +c MDCRS cross-type dups below 25,000' +c + $ (ht_ft(ii).lt.25000..and. + $ ((l_ii_mdcrs.and.(.not.l_iim1_mdcrs)).or. ! new + $ (l_iim1_mdcrs.and.(.not.l_ii_mdcrs)).or. ! new + $ (l_ii_mdcrs.and. ! new on 6/5/01 + $ (itype(ii ).ne.i_mdcrs.and. ! " + $ itype(iim1).eq.i_mdcrs).and. ! " + $ c_acftid(ii).eq.c_acftid(iim1)).or. ! " + $ (l_iim1_mdcrs.and. ! " + $ (itype(iim1).ne.i_mdcrs.and. ! " + $ itype(ii ).eq.i_mdcrs).and. ! " + $ c_acftid(ii).eq.c_acftid(iim1)).or. ! " + $ (l_ii_acars.and.(.not.l_iim1_acars)).or. ! new + $ (l_iim1_acars.and.(.not.l_ii_acars)).or. ! new + $ (l_ii_man.and.(.not.l_iim1_man)).or. ! new + $ (l_iim1_man.and.(.not.l_ii_man)).or. ! new + $ (((l_ii_amdar.and.l_iim1_amdar).or. ! new + $ (l_ii_airep.and.l_iim1_amdar).or. ! new + $ (l_iim1_airep.and.l_ii_amdar)).and. ! new + $ c_acftid(ii).eq.c_acftid(iim1))).and. ! new + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.htdif_same+0.5).or. +c +c dups above 25,000' +c + $ (ht_ft(ii).gt.24999.5.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.htdif_same+0.5)).and. +c +c other criteria +c + $ (abs(ob_t(iim1)-ob_t(ii)).lt.1.25.or. + $ (ob_t(iim1).eq.amiss.and.ob_t(ii).ne.amiss).or. + $ (ob_t(iim1).ne.amiss.and.ob_t(ii).eq.amiss)).and. +c + $ (abs(difdir).lt.10.5.or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss).or. + $ (ob_dir(iim1).ne.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss).or. + $ (ob_spd(iim1).ne.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).lt.0.5.and.ob_dir(ii).lt.0.5).or. + $ (ob_dir(iim1).lt.0.5.and.difdir.gt.10.5).or. + $ (difdir.gt.10.5.and.ob_dir(ii).lt.0.5)).and. +c + $ (abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25.or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss).or. + $ (ob_spd(iim1).ne.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss).or. + $ (ob_dir(iim1).ne.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_spd(iim1).lt.0.05.and.ob_spd(ii).lt.0.05).or. + $ (ob_spd(iim1).lt.0.05.and.ob_spd(ii).gt.1.25).or. + $ (ob_spd(iim1).gt.1.25.and.ob_spd(ii).lt.0.05))) then +c +c Count duplicates where one has neg and the other pos altitude +c ------------------------------------------------------------- + if(abs(abs(ht_ft(iim1))-abs(ht_ft(ii))).lt.0.5.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).gt.0.5) then + n_near_negpos = n_near_negpos + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Neg-pos altitude dup found' + endif + endif +c +c If near dup found, decide which report to keep +ccccdak Choose MDCRS over ACARS +c Choose MDCRS over TAMDAR +c Choose reports with flight phase over no reported flight phase +ccccdak Choose ACARS/MDCRS over AIREP/manual AIREP +c Choose TAMDAR or MDCRS over AIREP/manual AIREP +c Choose AMDAR over AIREP/manual AIREP +c Choose automated over manual AIREP +c Choose 7-char flight number over 6-char flight number +c Choose present over missing flight/tail number +c Choose present over missing/zero wind speed or direction +c Choose non-zero over zero lat or lon +c ---------------------------------------------------------------- +c +c Keep ob ii +c ---------- + if( ( ( ((l_ii_mdcrs.and.l_iim1_acars).or. + $ (l_ii_mdcrs.and.l_iim1_mdcrs.and. + $ .not.(itype(ii).eq.i_mdcrs.and. + $ itype(iim1).ne.i_mdcrs)).or. + $ (l_ii_acars.and.l_iim1_acars).or. + $ (l_ii_amdar.and.l_iim1_amdar).or. ! new + $ (l_ii_amdar.and.l_iim1_airep)).and. ! new + $ c_acftreg(ii).eq.c_acftreg(iim1) ).and. +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ ((abs(alat(iim1)-alat(ii)).lt.0.025.and. + $ abs(alon(iim1)-alon(ii)).lt.0.025.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ob_t(iim1)-ob_t(ii)).lt.0.65.and. + $ ((abs(difdir).lt.5.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).gt.10.5.and. + $ ob_dir(iim1).lt.0.5)).and. + $ ((abs(ob_spd(iim1)-ob_spd(ii)).lt.0.55).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_spd(ii).gt.1.25.and. + $ ob_spd(iim1).lt.0.05)) ).or. +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ (abs(alat(iim1)-alat(ii)).lt.0.055.and. + $ abs(alon(iim1)-alon(ii)).lt.0.055.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.15.5.and. + $ idt_dif.le.30.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ ((abs(difdir).lt.10.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).gt.10.5.and. + $ ob_dir(iim1).lt.0.5)).and. + $ ((abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_spd(ii).gt.1.25.and. + $ ob_spd(iim1).lt.0.05)) ))).or. +c + $ (l_ii_airep.and.l_iim1_man).or. +c + $ (l_ii_acars.and.l_iim1_airep).or. + $ (l_ii_mdcrs.and.l_iim1_airep).or. +c + $ (l_ii_acars.and.l_iim1_man).or. + $ (l_ii_mdcrs.and.l_iim1_man).or. +c + $ (l_ii_amdar.and.l_iim1_man).or. +c + $ ((itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des).and. + $ itype(iim1).eq.i_mdcrs).or. +c + $ l_iim1_sh.or. +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ (l_iim1_0lat.and.abs(alat(ii)).gt.0.125).or. +c + $ (l_iim1_0lon.and. + $ (alon(ii).gt.0.125.and.alon(ii).lt.359.875)).or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + $ (ob_t(ii).ne.amiss.and.ob_t(iim1).eq.amiss).or. +c + $ (.not.(l_ii_mdcrs.and.l_iim1_acars).and. + $ .not.(l_ii_mdcrs.and.l_iim1_mdcrs).and. + $ .not.(l_ii_acars.and.l_iim1_acars).and. + $ ((ob_spd(ii).ne.amiss.and.ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and.ob_dir(iim1).eq.amiss).or. + $ (((ob_spd(ii).gt.1.25.and.ob_spd(iim1).lt.0.05).or. + $ (difdir.gt.10.5.and.ob_dir(iim1).lt.0.5)).and. + $ c_acftid(ii).eq.c_acftid(iim1)))) ) then +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'd' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_near = n_near + 1 +c + if(l_iim1_sh) then + n_near_sh = n_near_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with short id--' + $, ii + endif + if(l_iim1_man.and.l_ii_man) then + n_nr_sh_MaMa = n_nr_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_sh_MaAr = n_nr_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_sh_MaMd = n_nr_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_nr_sh_MaAc = n_nr_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_sh_ArMa = n_nr_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_nr_sh_ArAr = n_nr_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized short-id dup' + endif + endif +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(((l_iim1_0lat.and. + $ abs(alat(ii)).gt.0.125).or. + $ (l_iim1_0lon.and. + $ (alon(ii).gt.0.125.and. + $ alon(ii).lt.359.875))).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_man.or.l_iim1_man)) then + n_near_0ll = n_near_0ll + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with 0l/l--',ii + endif + if(l_iim1_acars.and.l_ii_acars) then + n_nr_0ll_AcAc = n_nr_0ll_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_nr_0ll_MdMd = n_nr_0ll_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_0ll_MaAr = n_nr_0ll_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_amdar.and.l_ii_airep) then + n_nr_0ll_AmAr = n_nr_0ll_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_iim1_man.and.l_ii_man) then + n_nr_0ll_MaMa = n_nr_0ll_MaMa + 1 + if(l_print) write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_0ll_MaMd = n_nr_0ll_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_mdcrs.and.l_ii_man) then + n_nr_0ll_MdMa = n_nr_0ll_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_iim1_man.and.l_ii_amdar) then + n_nr_0ll_MaAm = n_nr_0ll_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_iim1_amdar.and.l_ii_man) then + n_nr_0ll_AmMa = n_nr_0ll_AmMa + 1 + if(l_print) write(io8,*) 'AMDAR-manAIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized near 0l/l dup' + endif + endif +c + elseif(ob_t(ii).ne.amiss.and. + $ ob_t(iim1).eq.amiss) then + n_near_mst = n_near_mst + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with msg temp--' + $, ii + endif + if(l_iim1_man.and.l_ii_man) then + n_nr_mst_MaMa = n_nr_mst_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mst_MaAr = n_nr_mst_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_amdar) then + n_nr_mst_MaAm = n_nr_mst_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_iim1_airep.and.l_ii_acars) then + n_nr_mst_ArAc = n_nr_mst_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_iim1_airep.and.l_ii_mdcrs) then + n_nr_mst_ArMd = n_nr_mst_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_nr_mst_MaAc = n_nr_mst_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_mst_MaMd = n_nr_mst_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_nr_mst_MdMd = n_nr_mst_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_airep.and.l_ii_man) then + n_nr_mst_ArMa = n_nr_mst_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_amdar.and.l_ii_amdar) then + n_nr_mst_AmAm = n_nr_mst_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_nr_mst_ArAr = n_nr_mst_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_iim1_airep.and.l_ii_amdar) then + n_nr_mst_ArAm = n_nr_mst_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_iim1_amdar.and.l_ii_airep) then + n_nr_mst_AmAr = n_nr_mst_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized msg-temp dup' + endif + endif +c + elseif((ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss)) then + n_near_ws = n_near_ws + 1 + l_print = .false. + if(c_acftid(ii)(1:2).eq.'IT') then + n_near_ws_IT = n_near_ws_IT + 1 + l_print = .false. + elseif(c_acftid(ii)(1:2).eq.'EU') then + n_near_ws_EU = n_near_ws_EU + 1 + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup with msg winds--',ii + endif + if(l_iim1_man.and.l_ii_man) then + n_nr_mswn_MaMa = n_nr_mswn_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mswn_MaAr = n_nr_mswn_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_amdar) then + n_nr_mswn_MaAm = n_nr_mswn_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_mswn_ArMa = n_nr_mswn_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_nr_mswn_ArAr = n_nr_mswn_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_iim1_acars.and.l_ii_acars) then + n_nr_mswn_AcAc = n_nr_mswn_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_nr_mswn_MdMd = n_nr_mswn_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_acars.and.l_ii_mdcrs) then + n_nr_mswn_AcMd = n_nr_mswn_AcMd + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-MDCRS dup' + if(l_print) write(io8,*) 'TAMDAR-MDCRS dup' + elseif(l_iim1_mdcrs.and.l_ii_acars) then + n_nr_mswn_MdAc = n_nr_mswn_MdAc + 1 +ccccdak if(l_print) write(io8,*) 'MDCRS-ACARS dup' + if(l_print) write(io8,*) 'MDCRS-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_amdar) then + n_nr_mswn_MdAm = n_nr_mswn_MdAm + 1 + if(l_print) write(io8,*) 'MDCRS-AMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_airep) then + n_nr_mswn_MdAr = n_nr_mswn_MdAr + 1 + if(l_print) write(io8,*) 'MDCRS-AIREP dup' + elseif(l_iim1_mdcrs.and.l_ii_man) then + n_nr_mswn_MdMa = n_nr_mswn_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_acars) then + n_nr_mswn_ArAc = n_nr_mswn_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_iim1_airep.and.l_ii_mdcrs) then + n_nr_mswn_ArMd = n_nr_mswn_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_nr_mswn_MaAc = n_nr_mswn_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_mswn_MaMd = n_nr_mswn_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_amdar.and.l_ii_amdar) then + n_nr_mswn_AmAm = n_nr_mswn_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_iim1_airep.and.l_ii_amdar) then + n_nr_mswn_ArAm = n_nr_mswn_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_iim1_amdar.and.l_ii_airep) then + n_nr_mswn_AmAr = n_nr_mswn_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_iim1_acars.and.l_ii_amdar) then + n_nr_mswn_AcAm = n_nr_mswn_AcAm + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-AMDAR dup' + if(l_print) write(io8,*) 'TAMDAR-AMDAR dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized msg-wind dup' + endif + endif +c + elseif((ob_spd(ii).gt.1.25.and. + $ ob_spd(iim1).lt.0.05).or. + $ (ob_dir(ii).gt.10.5.and. + $ difdir.gt.10.5.and. + $ ob_dir(iim1).lt.0.5)) then + n_near_0ws = n_near_0ws + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with 0 winds-1-' + $, ii + endif + if(l_iim1_airep.and.l_ii_amdar) then + n_near_0ws_ArAm = n_near_0ws_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_iim1_amdar.and.l_ii_airep) then + n_near_0ws_AmAr = n_near_0ws_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_iim1_amdar.and.l_ii_amdar) then + n_near_0ws_AmAm = n_near_0ws_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_near_0ws_ArAr = n_near_0ws_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_man) then + n_near_0ws_MaMa = n_near_0ws_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_near_0ws_MaMd = n_near_0ws_MaMd + 1 + if(l_print) + $ write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_amdar) then + n_near_0ws_MaAm = n_near_0ws_MaAm + 1 + if(l_print) + $ write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_near_0ws_MaAr = n_near_0ws_MaAr + 1 + if(l_print) + $ write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_airep.and.l_ii_mdcrs) then + n_near_0ws_ArMd = n_near_0ws_ArMd + 1 + if(l_print) + $ write(io8,*) 'AIREP-MDCRS dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_near_0ws_MdMd = n_near_0ws_MdMd + 1 + if(l_print) + $ write(io8,*) 'MDCRS-MDCRS dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Uncategorized zero-wind dup' + write(io8,*) ' dir difference = ',difdir + endif + endif +c + elseif(l_ii_mdcrs.and.l_iim1_acars) then + n_near_MdAc = n_near_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS near dup found--',ii + write(io8,*) 'MDCRS-TAMDAR near dup found--',ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + if(itype(iim1).eq.i_mdcrs.and. + $ itype(ii ).ne.i_mdcrs) then + n_nr_posrep = n_nr_posrep + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS position report dup-1-',ii + endif +c + elseif(ichk_s(ii ).eq.-10.and. + $ ichk_s(iim1).ne.-10) then + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 + l_print = .false. !!!! + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc ii--MdMd near' + endif + ichk_t(ii) = ichk_t(iim1) + ichk_q(ii) = ichk_q(iim1) + ichk_d(ii) = ichk_d(iim1) + ichk_s(ii) = ichk_s(iim1) +c + elseif(ichk_s(iim1).eq.-10.and. + $ ichk_s(ii ).ne.-10) then + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 + l_print = .false. !!!! + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc iim1--MdMd near' + endif +c + else + n_near_MdMd = n_near_MdMd + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-MDCRS near dup found--',ii + endif + endif +c + elseif(l_ii_acars.and.l_iim1_acars) then + n_near_AcAc = n_near_AcAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-ACARS near dup found--',ii + write(io8,*) 'TAMDAR-TAMDAR near dup found--',ii + endif +c + elseif(l_ii_acars.and.l_iim1_airep) then + n_near_AcAr = n_near_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP near dup found--',ii + write(io8,*) 'TAMDAR-AIREP near dup found--',ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_airep) then + n_near_MdAr = n_near_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP near dup found--',ii + endif +c + elseif(l_ii_amdar.and.l_iim1_amdar) then + if(ichk_s(ii ).eq.-10.and. + $ ichk_s(iim1).ne.-10) then + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 + l_print = .false. !!!! + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc ii--AmAm near' + endif + ichk_t(ii) = ichk_t(iim1) + ichk_q(ii) = ichk_q(iim1) + ichk_d(ii) = ichk_d(iim1) + ichk_s(ii) = ichk_s(iim1) +c + elseif(ichk_s(iim1).eq.-10.and. + $ ichk_s(ii ).ne.-10) then + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 + l_print = .false. !!!! + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll qc iim1--AmAm near' + endif +c + else + n_near_AmAm = n_near_AmAm + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AMDAR near dup found--',ii + endif + endif +c + elseif(l_ii_amdar.and.l_iim1_airep) then + n_near_AmAr = n_near_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP near dup found--',ii + endif +c + elseif(l_ii_acars.and.l_iim1_man) then + n_near_AcMa = n_near_AcMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-manAIREP near dup--',ii + write(io8,*) 'TAMDAR-manAIREP near dup--',ii + endif +c + elseif(l_ii_mdcrs.and.l_iim1_man) then + n_near_MdMa = n_near_MdMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-manAIREP near dup--',ii + endif +c + elseif(l_ii_airep.and.l_iim1_man) then + n_near_ArMa = n_near_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP near dup--',ii + endif +c + elseif(l_ii_amdar.and.l_iim1_man) then + n_near_AmMa = n_near_AmMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-manAIREP near dup--',ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized near dup-1-',ii, + $ ' difdir = ',difdir + endif + endif +c +c Keep ob iim1 +c ------------ + elseif( ( ( ((l_iim1_mdcrs.and.l_ii_acars).or. + $ (itype(ii).eq.i_mdcrs.and. + $ itype(iim1).ne.i_mdcrs).or. + $ (l_iim1_amdar.and.l_ii_airep)).and. + $ c_acftreg(ii).eq.c_acftreg(iim1)).and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c + $ ((abs(alat(iim1)-alat(ii)).lt.0.025.and. + $ abs(alon(iim1)-alon(ii)).lt.0.025.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ob_t(iim1)-ob_t(ii)).lt.0.65.and. + $ ((abs(difdir).lt.5.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).ne.amiss).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).ne.amiss).or. + $ (ob_dir(iim1).gt.10.5.and. + $ ob_dir(ii).lt.0.5)).and. + $ ((abs(ob_spd(iim1)-ob_spd(ii)).lt.0.55 ).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).ne.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).ne.amiss).or. + $ (ob_spd(iim1).gt.1.25.and. + $ ob_spd(ii).lt.0.05)) ).or. +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ (abs(alat(iim1)-alat(ii)).lt.0.055.and. + $ abs(alon(iim1)-alon(ii)).lt.0.055.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.15.5.and. + $ idt_dif.le.30.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ ((abs(difdir).lt.10.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).ne.amiss).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).ne.amiss).or. + $ (ob_dir(iim1).gt.10.5.and. + $ ob_dir(ii).lt.0.5)).and. + $ ((abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25 ).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).ne.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).ne.amiss).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss).or. + $ (ob_spd(iim1).gt.1.25.and. + $ ob_spd(ii).lt.0.05)) ))).or. +c + $ (l_iim1_airep.and.l_ii_man).or. +c + $ (l_iim1_acars.and.l_ii_airep).or. + $ (l_iim1_mdcrs.and.l_ii_airep).or. +c + $ (l_iim1_acars.and.l_ii_man).or. + $ (l_iim1_mdcrs.and.l_ii_man).or. +c + $ (l_iim1_amdar.and.l_ii_man).or. +c + $ ((itype(iim1).eq.i_mdcrs_lvl.or. + $ itype(iim1).eq.i_mdcrs_asc.or. + $ itype(iim1).eq.i_mdcrs_des).and. + $ itype(ii).eq.i_mdcrs).or. +c + $ l_ii_sh.or. +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ (l_ii_0lat.and.abs(alat(ii)).gt.0.125).or. +c + $ (l_ii_0lon.and. + $ (alon(ii).gt.0.125.and.alon(ii).lt.359.875)).or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + $ (ob_t(iim1).ne.amiss.and.ob_t(ii).eq.amiss).or. +c + $ (.not.(l_ii_mdcrs.and.l_iim1_acars).and. + $ .not.(l_ii_mdcrs.and.l_iim1_mdcrs).and. + $ .not.(l_ii_acars.and.l_iim1_acars).and. + $ ((ob_spd(iim1).ne.amiss.and. + $ ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).ne.amiss.and. + $ ob_dir(ii).eq.amiss).or. + $ (((ob_spd(iim1).gt.1.25.and. + $ ob_spd(ii).lt.0.05).or. + $ (difdir.gt.10.5.and.ob_dir(ii).lt.0.5)).and. + $ (c_acftid(ii).eq.c_acftid(iim1)) )) )) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'd' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_near = n_near + 1 +c + if(l_ii_sh) then + n_near_sh = n_near_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with short id--' + $, ii + endif + if(l_ii_man.and.l_iim1_man) then + n_nr_sh_MaMa = n_nr_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_sh_MaAr = n_nr_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_sh_MaMd = n_nr_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_nr_sh_MaAc = n_nr_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_sh_ArMa = n_nr_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_nr_sh_ArAr = n_nr_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized short-id dup' + endif + endif +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(((l_ii_0lat.and.abs(alat(ii)).gt.0.125).or. + $ (l_ii_0lon.and. + $ (alon(ii).gt.0.125.and. + $ alon(ii).lt.359.875))).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_man.or.l_iim1_man)) then + n_near_0ll = n_near_0ll + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with 0l/l--',ii + endif + if(l_iim1_acars.and.l_ii_acars) then + n_nr_0ll_AcAc = n_nr_0ll_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_nr_0ll_MdMd = n_nr_0ll_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_0ll_MaAr = n_nr_0ll_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_amdar.and.l_iim1_airep) then + n_nr_0ll_AmAr = n_nr_0ll_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_ii_man.and.l_iim1_man) then + n_nr_0ll_MaMa = n_nr_0ll_MaMa + 1 + if(l_print) write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_0ll_MaMd = n_nr_0ll_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_mdcrs.and.l_iim1_man) then + n_nr_0ll_MdMa = n_nr_0ll_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_ii_man.and.l_iim1_amdar) then + n_nr_0ll_MaAm = n_nr_0ll_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_ii_amdar.and.l_iim1_man) then + n_nr_0ll_AmMa = n_nr_0ll_AmMa + 1 + if(l_print) write(io8,*) 'AMDAR-manAIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized near 0l/l dup' + endif + endif +c + elseif(ob_t(ii).ne.amiss.and. + $ ob_t(iim1).eq.amiss) then + n_near_mst = n_near_mst + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with msg temp--' + $, ii + endif + if(l_ii_man.and.l_iim1_man) then + n_nr_mst_MaMa = n_nr_mst_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_mst_MaAr = n_nr_mst_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_amdar) then + n_nr_mst_MaAm = n_nr_mst_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_ii_airep.and.l_iim1_acars) then + n_nr_mst_ArAc = n_nr_mst_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_ii_airep.and.l_iim1_mdcrs) then + n_nr_mst_ArMd = n_nr_mst_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_nr_mst_MaAc = n_nr_mst_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_mst_MaMd = n_nr_mst_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + n_nr_mst_MdMd = n_nr_mst_MdMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mst_ArMa = n_nr_mst_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_amdar.and.l_iim1_amdar) then + n_nr_mst_AmAm = n_nr_mst_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_nr_mst_ArAr = n_nr_mst_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_ii_amdar.and.l_iim1_airep) then + n_nr_mst_AmAr = n_nr_mst_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_ii_airep.and.l_iim1_amdar) then + n_nr_mst_ArAm = n_nr_mst_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized msg-temp dup' + endif + endif +c + elseif((ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss)) then + n_near_ws = n_near_ws + 1 + l_print = .false. + if(c_acftid(iim1)(1:2).eq.'IT') then + n_near_ws_IT = n_near_ws_IT + 1 + l_print = .false. + elseif(c_acftid(iim1)(1:2).eq.'EU') then + n_near_ws_EU = n_near_ws_EU + 1 + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup with msg winds--',ii + endif + if(l_ii_man.and.l_iim1_man) then + n_nr_mswn_MaMa = n_nr_mswn_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_mswn_MaAr = n_nr_mswn_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_amdar) then + n_nr_mswn_MaAm = n_nr_mswn_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mswn_ArMa = n_nr_mswn_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_nr_mswn_ArAr = n_nr_mswn_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_ii_acars.and.l_iim1_acars) then + n_nr_mswn_AcAc = n_nr_mswn_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + n_nr_mswn_MdMd = n_nr_mswn_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_ii_acars.and.l_iim1_mdcrs) then + n_nr_mswn_AcMd = n_nr_mswn_AcMd + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-MDCRS dup' + if(l_print) write(io8,*) 'TAMDAR-MDCRS dup' + elseif(l_ii_mdcrs.and.l_iim1_acars) then + n_nr_mswn_MdAc = n_nr_mswn_MdAc + 1 +ccccdak if(l_print) write(io8,*) 'MDCRS-ACARS dup' + if(l_print) write(io8,*) 'MDCRS-TAMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_amdar) then + n_nr_mswn_MdAm = n_nr_mswn_MdAm + 1 + if(l_print) write(io8,*) 'MDCRS-AMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_airep) then + n_nr_mswn_MdAr = n_nr_mswn_MdAr + 1 + if(l_print) write(io8,*) 'MDCRS-AIREP dup' + elseif(l_ii_mdcrs.and.l_iim1_man) then + n_nr_mswn_MdMa = n_nr_mswn_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_acars) then + n_nr_mswn_ArAc = n_nr_mswn_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_ii_airep.and.l_iim1_mdcrs) then + n_nr_mswn_ArMd = n_nr_mswn_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_nr_mswn_MaAc = n_nr_mswn_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_mswn_MaMd = n_nr_mswn_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_amdar.and.l_iim1_amdar) then + n_nr_mswn_AmAm = n_nr_mswn_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_ii_airep.and.l_iim1_amdar) then + n_nr_mswn_ArAm = n_nr_mswn_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_ii_amdar.and.l_iim1_airep) then + n_nr_mswn_AmAr = n_nr_mswn_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_ii_acars.and.l_iim1_amdar) then + n_nr_mswn_AcAm = n_nr_mswn_AcAm + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-AMDAR dup' + if(l_print) write(io8,*) 'TAMDAR-AMDAR dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized msg-wind dup' + endif + endif +c + elseif((ob_spd(ii).gt.1.25.and. + $ ob_spd(iim1).lt.0.05).or. + $ (ob_dir(ii).gt.10.5.and. + $ difdir.gt.10.5.and. + $ ob_dir(iim1).lt.0.5)) then + n_near_0ws = n_near_0ws + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Near dup found with 0 winds-2-' + $, ii + endif + if(l_ii_airep.and.l_iim1_amdar) then + n_near_0ws_ArAm = n_near_0ws_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_ii_amdar.and.l_iim1_airep) then + n_near_0ws_AmAr = n_near_0ws_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_ii_amdar.and.l_iim1_amdar) then + n_near_0ws_AmAm = n_near_0ws_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_near_0ws_ArAr = n_near_0ws_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_man) then + n_near_0ws_MaMa = n_near_0ws_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_near_0ws_MaMd = n_near_0ws_MaMd + 1 + if(l_print) + $ write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_amdar) then + n_near_0ws_MaAm = n_near_0ws_MaAm + 1 + if(l_print) + $ write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_near_0ws_MaAr = n_near_0ws_MaAr + 1 + if(l_print) + $ write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_airep.and.l_iim1_mdcrs) then + n_near_0ws_ArMd = n_near_0ws_ArMd + 1 + if(l_print) + $ write(io8,*) 'AIREP-MDCRS dup' + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + n_near_0ws_MdMd = n_near_0ws_MdMd + 1 + if(l_print) + $ write(io8,*) 'MDCRS-MDCRS dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Uncategorized zero-wind dup' + write(io8,*) ' dir difference = ',difdir + endif + endif +c + elseif(l_iim1_mdcrs.and.l_ii_acars) then + n_near_MdAc = n_near_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS near dup found--',ii + write(io8,*) 'MDCRS-TAMDAR near dup found--',ii + endif +c + elseif(itype(iim1).eq.i_mdcrs.and. + $ itype(ii ).ne.i_mdcrs) then + n_nr_posrep = n_nr_posrep + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS position report dup-2-',ii + endif +c + elseif(l_iim1_acars.and.l_ii_airep) then + n_near_AcAr = n_near_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP near dup found--',ii + write(io8,*) 'TAMDAR-AIREP near dup found--',ii + endif +c + elseif(l_iim1_mdcrs.and.l_ii_airep) then + n_near_MdAr = n_near_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP near dup found--',ii + endif +c + elseif(l_iim1_amdar.and.l_ii_airep) then + n_near_AmAr = n_near_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP near dup found--',ii + endif +c + elseif(l_iim1_acars.and.l_ii_man) then + n_near_AcMa = n_near_AcMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-manAIREP near dup--',ii + write(io8,*) 'TAMDAR-manAIREP near dup--',ii + endif +c + elseif(l_iim1_mdcrs.and.l_ii_man) then + n_near_MdMa = n_near_MdMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-manAIREP near dup--',ii + endif +c + elseif(l_iim1_airep.and.l_ii_man) then + n_near_ArMa = n_near_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP near dup--',ii + endif +c + elseif(l_iim1_amdar.and.l_ii_man) then + n_near_AmMa = n_near_AmMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-manAIREP near dup--',ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized near dup-2-',ii, + $ ' difdir = ',difdir + endif + endif +c +ccccdak Exclude other MDCRS-ACARS, MDCRS-AIREP, ACARS-AIREP, MDCRS-MDCRS +ccccdak or ACARS-ACARS duplicates +c Exclude other MDCRS-TAMDAR, MDCRS-AIREP, TAMDAR-AIREP, MDCRS-MDCRS +c or TAMDAR-TAMDAR duplicates +c ---------------------------------------------------------------- + elseif( (l_iim1_mdcrs.and.l_ii_acars).or. + $ (l_ii_mdcrs.and.l_iim1_acars).or. + $ (l_ii_mdcrs.and.l_iim1_mdcrs).or. + $ (l_ii_acars.and.l_iim1_acars).or. + $ (l_ii_amdar.and.l_iim1_amdar).or. + $ (l_ii_amdar.and.l_iim1_airep).or. + $ (l_ii_airep.and.l_iim1_amdar) ) then +c +c Duplicate pair doesn't fall in any of the above categories +c but ids are equal +c Keep ob ii +c ---------------------------------------------------------- + elseif((c_acftid(ii).eq.c_acftid(iim1)).or. + $ (l_ii_man.and.l_iim1_man).or. + $ (l_ii_amdar.and.l_ii_amdar.and. + $ c_acftid(ii)(1:6).eq.c_acftid(iim1)(1:6)))then +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'd' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_near = n_near + 1 +c + if(l_ii_airep.and.l_iim1_airep) then + n_near_ArAr = n_near_ArAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-AIREP near dup found--',ii + endif +c + elseif(l_ii_man.and.l_iim1_man) then + n_near_MaMa = n_near_MaMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'manAIREP-manAIREP near dup--',ii + endif +c + elseif(l_ii_amdar.and.l_iim1_amdar) then + n_near_AmAm = n_near_AmAm + 1 + if(c_acftid(ii).eq.c_acftid(iim1)) then + l_print = .false. + else + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AMDAR near dup found--',ii + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized near dup-3-',ii + endif + endif +c +c Duplicate pair doesn't fall in any of the above categories +c Flag to log file but don't reject +c ---------------------------------------------------------- + elseif(c_acftid(ii).eq.c_acftid(iim1)) then + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Leftover near duplicate found',ii + endif + endif +c +c Check if report is a low-windspeed dup not previously caught +c (These are typically near-surface observations) +c ------------------------------------------------------------ + elseif(idt_dif.ge.0.and.idt_dif.le.90.and. + $ c_qc(iim1)(1:1).ne.'D'.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.035.and. + $ abs(alon(iim1)-alon(ii)).lt.0.035.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c $ abs(ht_ft(iim1)-ht_ft(ii)).lt.50.5.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.25.5.and. + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_sh.or.l_iim1_sh).and. +c $ abs(ob_t(iim1)-ob_t(ii)).lt.2.05.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ ((ob_spd(iim1).lt.25.05.and. + $ ob_spd(ii).lt.25.05.and. + $ abs(ob_spd(iim1)-ob_spd(ii)).lt.2.05.and. + $ ((abs(difdir).lt.10.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss))).or. + $ (ob_spd(iim1).lt.15.05.and. + $ ob_spd(ii).lt.15.05.and. + $ abs(ob_spd(iim1)-ob_spd(ii)).lt.3.55.and. + $ ((abs(difdir).lt.15.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss))).or. + $ (ob_spd(iim1).lt.10.05.and. + $ ob_spd(ii).lt.10.05.and. + $ abs(ob_spd(iim1)-ob_spd(ii)).lt.5.05.and. + $ ((abs(difdir).lt.25.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss))).or. + $ (ob_spd(iim1).lt.5.05.and. + $ ob_spd(ii).lt.5.05.and. + $ ((abs(difdir).lt.45.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss))).or. + $ (ob_spd(iim1).lt.3.65.and. + $ ob_spd(ii).lt.3.65).or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss).or. + $ (ob_spd(iim1).ne.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss).or. + $ (ob_dir(iim1).ne.amiss.and.ob_dir(ii).eq.amiss)) + $ ) then +c +c If near dup found, decide which report to keep +ccccdak Choose MDCRS over ACARS +c Choose MDCRS over TAMDAR +ccccdak Choose ACARS/MDCRS over AIREP/manual AIREP +c Choose TAMDAR or MDCRS over AIREP/manual AIREP +c Choose AMDAR over AIREP/manual AIREP +c Choose automated over manual AIREP +c Choose 7-char flight number over 6-char flight number +c Choose present over missing flight/tail number +c Choose present over missing wind speed +c Choose non-zero over zero lat or lon +c ------------------------------------------------------- +c +c Keep ob ii +c ---------- + if((l_ii_mdcrs.and.l_iim1_acars).or. + $ (l_ii_mdcrs.and.l_iim1_airep).or. + $ (l_ii_mdcrs.and.l_iim1_man).or. + $ (l_ii_mdcrs.and.l_iim1_mdcrs.and. + $ ichk_s(ii).ne.-10).or. + $ (l_ii_acars.and.l_iim1_airep).or. + $ (l_ii_acars.and.l_iim1_man).or. + $ (l_ii_acars.and.l_iim1_acars).or. + $ (l_ii_amdar.and.l_iim1_airep).or. + $ (l_ii_amdar.and.l_iim1_man).or. + $ (l_ii_amdar.and.l_iim1_amdar).or. + $ (l_ii_airep.and.l_iim1_man).or. + $ (l_ii_airep.and.l_iim1_airep).or. + $ (l_ii_man.and.l_iim1_man).or. + $ l_iim1_sh.or. + $ (ob_spd(ii).ne.amiss.and.ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and.ob_dir(iim1).eq.amiss) + $ )then +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'd' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_near = n_near + 1 +c + if(l_iim1_sh) then + n_near_sh = n_near_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Low-wind dup found with short id' + endif + if(l_iim1_man.and.l_ii_man) then + n_nr_sh_MaMa = n_nr_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_sh_MaAr = n_nr_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_sh_MaMd = n_nr_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_nr_sh_MaAc = n_nr_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_sh_ArMa = n_nr_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_nr_sh_ArAr = n_nr_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncat. low-wind short-id dup' + endif + endif +c + elseif((ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss)) then + n_near_ws = n_near_ws + 1 + l_print = .false. + if(c_acftid(ii)(1:2).eq.'IT') then + n_near_ws_IT = n_near_ws_IT + 1 + l_print = .false. + elseif(c_acftid(ii)(1:2).eq.'EU') then + n_near_ws_EU = n_near_ws_EU + 1 + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*)'Low-wind dup found with msg wind' + endif + if(l_iim1_man.and.l_ii_man) then + n_nr_mswn_MaMa = n_nr_mswn_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mswn_MaAr = n_nr_mswn_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_iim1_man.and.l_ii_amdar) then + n_nr_mswn_MaAm = n_nr_mswn_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_mswn_ArMa = n_nr_mswn_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_airep) then + n_nr_mswn_ArAr = n_nr_mswn_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_iim1_acars.and.l_ii_acars) then + n_nr_mswn_AcAc = n_nr_mswn_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_mdcrs) then + n_nr_mswn_MdMd = n_nr_mswn_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_iim1_acars.and.l_ii_mdcrs) then + n_nr_mswn_AcMd = n_nr_mswn_AcMd + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-MDCRS dup' + if(l_print) write(io8,*) 'TAMDAR-MDCRS dup' + elseif(l_iim1_mdcrs.and.l_ii_acars) then + n_nr_mswn_MdAc = n_nr_mswn_MdAc + 1 +ccccdak if(l_print) write(io8,*) 'MDCRS-ACARS dup' + if(l_print) write(io8,*) 'MDCRS-TAMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_amdar) then + n_nr_mswn_MdAm = n_nr_mswn_MdAm + 1 + if(l_print) write(io8,*) 'MDCRS-AMDAR dup' + elseif(l_iim1_mdcrs.and.l_ii_airep) then + n_nr_mswn_MdAr = n_nr_mswn_MdAr + 1 + if(l_print) write(io8,*) 'MDCRS-AIREP dup' + elseif(l_iim1_mdcrs.and.l_ii_man) then + n_nr_mswn_MdMa = n_nr_mswn_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_iim1_airep.and.l_ii_acars) then + n_nr_mswn_ArAc = n_nr_mswn_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_iim1_airep.and.l_ii_mdcrs) then + n_nr_mswn_ArMd = n_nr_mswn_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_iim1_man.and.l_ii_acars) then + n_nr_mswn_MaAc = n_nr_mswn_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_mdcrs) then + n_nr_mswn_MaMd = n_nr_mswn_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_iim1_amdar.and.l_ii_amdar) then + n_nr_mswn_AmAm = n_nr_mswn_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_iim1_airep.and.l_ii_amdar) then + n_nr_mswn_ArAm = n_nr_mswn_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_iim1_amdar.and.l_ii_airep) then + n_nr_mswn_AmAr = n_nr_mswn_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_iim1_acars.and.l_ii_amdar) then + n_nr_mswn_AcAm = n_nr_mswn_AcAm + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-AMDAR dup' + if(l_print) write(io8,*) 'TAMDAR-AMDAR dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncat. low-wind msg-wind dup' + endif + endif +c + elseif(l_ii_mdcrs.and.l_iim1_acars) then + n_slow_MdAc = n_slow_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS low-wind dup found' + write(io8,*) 'MDCRS-TAMDAR low-wind dup found' + endif +c + elseif(l_ii_mdcrs.and.l_iim1_airep) then + n_slow_MdAr = n_slow_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP low-wind dup found' + endif +c + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + if(ichk_s(iim1).eq.-10) then + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'MDCRS-MDCRS bad roll qc lw dup' + endif + else + n_slow_MdMd = n_slow_MdMd + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'MDCRS-MDCRS low-wind dup found' + endif + endif +c + elseif(l_ii_acars.and.l_iim1_airep) then + n_slow_AcAr = n_slow_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP low-wind dup found' + write(io8,*) 'TAMDAR-AIREP low-wind dup found' + endif +c + elseif(l_ii_acars.and.l_iim1_acars) then + n_slow_AcAc = n_slow_AcAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-ACARS low-wind dup found' + write(io8,*) 'TAMDAR-TAMDAR low-wind dup found' + endif +c + elseif(l_ii_amdar.and.l_iim1_airep) then + n_slow_AmAr = n_slow_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP low-wind dup found' + endif +c + elseif(l_ii_amdar.and.l_iim1_amdar) then + if(ichk_s(iim1).eq.-10) then + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'AMDAR-AMDAR bad roll qc lw dup' + endif + else + n_slow_AmAm = n_slow_AmAm + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AMDAR low-wind dup found' + endif + endif +c + elseif(l_ii_airep.and.l_iim1_man) then + n_slow_ArMa = n_slow_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP low-wind dup' + endif +c + elseif(l_ii_airep.and.l_iim1_airep) then + n_slow_ArAr = n_slow_ArAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-AIREP low-wind dup found' + endif +c + elseif(l_ii_man.and.l_iim1_man) then + n_slow_MaMa = n_slow_MaMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'manAIREP-manAIREP low-wind dup' + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized low-wind dup-1-' + endif + endif +c +c Keep ob iim1 +c ------------ + elseif((l_iim1_mdcrs.and.l_ii_acars).or. + $ (l_iim1_mdcrs.and.l_ii_airep).or. + $ (l_iim1_mdcrs.and.l_ii_man).or. + $ (l_iim1_mdcrs.and.l_ii_mdcrs).or. + $ (l_iim1_acars.and.l_ii_airep).or. + $ (l_iim1_acars.and.l_ii_man).or. + $ (l_iim1_acars.and.l_ii_acars).or. + $ (l_iim1_amdar.and.l_ii_airep).or. + $ (l_iim1_amdar.and.l_ii_man).or. + $ (l_iim1_airep.and.l_ii_man).or. + $ l_ii_sh.or. + $ (ob_spd(iim1).ne.amiss.and. + $ ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).ne.amiss.and. + $ ob_dir(ii).eq.amiss)) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave +c + if(c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N') + $ c_qc(iim1)(1:1) = 'd' +c + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' +c +c Count rejects by category +c ------------------------- + n_near = n_near + 1 +c + if(l_ii_sh) then + n_near_sh = n_near_sh + 1 + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Low-wind dup found with short id' + endif + if(l_ii_man.and.l_iim1_man) then + n_nr_sh_MaMa = n_nr_sh_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_sh_MaAr = n_nr_sh_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_sh_MaMd = n_nr_sh_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_nr_sh_MaAc = n_nr_sh_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_sh_ArMa = n_nr_sh_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_nr_sh_ArAr = n_nr_sh_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncat. low-wind short-id dup' + endif + endif +c + elseif((ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).eq.amiss).or. + $ (ob_dir(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss)) then + n_near_ws = n_near_ws + 1 + l_print = .false. + if(c_acftid(iim1)(1:2).eq.'IT') then + n_near_ws_IT = n_near_ws_IT + 1 + l_print = .false. + elseif(c_acftid(iim1)(1:2).eq.'EU') then + n_near_ws_EU = n_near_ws_EU + 1 + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Low-wind dup with msg winds' + endif + if(l_ii_man.and.l_iim1_man) then + n_nr_mswn_MaMa = n_nr_mswn_MaMa + 1 + if(l_print) + $ write(io8,*) 'manAIREP-manAIREP dup' + elseif(l_ii_man.and.l_iim1_airep) then + n_nr_mswn_MaAr = n_nr_mswn_MaAr + 1 + if(l_print) write(io8,*) 'manAIREP-AIREP dup' + elseif(l_ii_man.and.l_iim1_amdar) then + n_nr_mswn_MaAm = n_nr_mswn_MaAm + 1 + if(l_print) write(io8,*) 'manAIREP-AMDAR dup' + elseif(l_iim1_man.and.l_ii_airep) then + n_nr_mswn_ArMa = n_nr_mswn_ArMa + 1 + if(l_print) write(io8,*) 'AIREP-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_airep) then + n_nr_mswn_ArAr = n_nr_mswn_ArAr + 1 + if(l_print) write(io8,*) 'AIREP-AIREP dup' + elseif(l_ii_acars.and.l_iim1_acars) then + n_nr_mswn_AcAc = n_nr_mswn_AcAc + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-ACARS dup' + if(l_print) write(io8,*) 'TAMDAR-TAMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + n_nr_mswn_MdMd = n_nr_mswn_MdMd + 1 + if(l_print) write(io8,*) 'MDCRS-MDCRS dup' + elseif(l_ii_acars.and.l_iim1_mdcrs) then + n_nr_mswn_AcMd = n_nr_mswn_AcMd + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-MDCRS dup' + if(l_print) write(io8,*) 'TAMDAR-MDCRS dup' + elseif(l_ii_mdcrs.and.l_iim1_acars) then + n_nr_mswn_MdAc = n_nr_mswn_MdAc + 1 +ccccdak if(l_print) write(io8,*) 'MDCRS-ACARS dup' + if(l_print) write(io8,*) 'MDCRS-TAMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_amdar) then + n_nr_mswn_MdAm = n_nr_mswn_MdAm + 1 + if(l_print) write(io8,*) 'MDCRS-AMDAR dup' + elseif(l_ii_mdcrs.and.l_iim1_airep) then + n_nr_mswn_MdAr = n_nr_mswn_MdAr + 1 + if(l_print) write(io8,*) 'MDCRS-AIREP dup' + elseif(l_ii_mdcrs.and.l_iim1_man) then + n_nr_mswn_MdMa = n_nr_mswn_MdMa + 1 + if(l_print) write(io8,*) 'MDCRS-manAIREP dup' + elseif(l_ii_airep.and.l_iim1_acars) then + n_nr_mswn_ArAc = n_nr_mswn_ArAc + 1 +ccccdak if(l_print) write(io8,*) 'AIREP-ACARS dup' + if(l_print) write(io8,*) 'AIREP-TAMDAR dup' + elseif(l_ii_airep.and.l_iim1_mdcrs) then + n_nr_mswn_ArMd = n_nr_mswn_ArMd + 1 + if(l_print) write(io8,*) 'AIREP-MDCRS dup' + elseif(l_ii_man.and.l_iim1_acars) then + n_nr_mswn_MaAc = n_nr_mswn_MaAc + 1 +ccccdak if(l_print) write(io8,*) 'manAIREP-ACARS dup' + if(l_print) write(io8,*) 'manAIREP-TAMDAR dup' + elseif(l_ii_man.and.l_iim1_mdcrs) then + n_nr_mswn_MaMd = n_nr_mswn_MaMd + 1 + if(l_print) write(io8,*) 'manAIREP-MDCRS dup' + elseif(l_ii_amdar.and.l_iim1_amdar) then + n_nr_mswn_AmAm = n_nr_mswn_AmAm + 1 + if(l_print) write(io8,*) 'AMDAR-AMDAR dup' + elseif(l_ii_airep.and.l_iim1_amdar) then + n_nr_mswn_ArAm = n_nr_mswn_ArAm + 1 + if(l_print) write(io8,*) 'AIREP-AMDAR dup' + elseif(l_ii_amdar.and.l_iim1_airep) then + n_nr_mswn_AmAr = n_nr_mswn_AmAr + 1 + if(l_print) write(io8,*) 'AMDAR-AIREP dup' + elseif(l_ii_acars.and.l_iim1_amdar) then + n_nr_mswn_AcAm = n_nr_mswn_AcAm + 1 +ccccdak if(l_print) write(io8,*) 'ACARS-AMDAR dup' + if(l_print) write(io8,*) 'TAMDAR-AMDAR dup' + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncat. low-wind msg-wind dup' + endif + endif +c + elseif(l_iim1_mdcrs.and.l_ii_acars) then + n_slow_MdAc = n_slow_MdAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'MDCRS-ACARS low-wind dup found' + write(io8,*) 'MDCRS-TAMDAR low-wind dup found' + endif +c + elseif(l_iim1_mdcrs.and.l_ii_airep) then + n_slow_MdAr = n_slow_MdAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'MDCRS-AIREP low-wind dup found' + endif +c + elseif(l_ii_mdcrs.and.l_iim1_mdcrs) then + if(ichk_s(iim1).eq.-10) then + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'MDCRS-MDCRS bad roll qc lw dup' + endif + else + n_slow_MdMd = n_slow_MdMd + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'MDCRS-MDCRS low-wind dup found' + endif + endif +c + elseif(l_iim1_acars.and.l_ii_airep) then + n_slow_AcAr = n_slow_AcAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-AIREP low-wind dup found' + write(io8,*) 'TAMDAR-AIREP low-wind dup found' + endif +c + elseif(l_iim1_acars.and.l_ii_acars) then + n_slow_AcAc = n_slow_AcAc + 1 + l_print = .false. + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'ACARS-ACARS low-wind dup found' + write(io8,*) 'TAMDAR-TAMDAR low-wind dup found' + endif +c + elseif(l_ii_amdar.and.l_iim1_amdar) then + if(ichk_s(iim1).eq.-10) then + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'AMDAR-AMDAR bad roll qc lw dup' + endif + else + n_slow_AmAm = n_slow_AmAm + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*)'AMDAR-AMDAR low-wind dup found' + endif + endif +c + elseif(l_iim1_amdar.and.l_ii_airep) then + n_slow_AmAr = n_slow_AmAr + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AMDAR-AIREP low-wind dup found' + endif +c + elseif(l_iim1_airep.and.l_ii_man) then + n_slow_ArMa = n_slow_ArMa + 1 + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'AIREP-manAIREP low-wind dup' + endif +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Uncategorized low-wind dup-2-' + endif + endif + endif +c +c Check if report is a near dup except for flight id (not rejected) +c Echo to log file for later inspection +c ----------------------------------------------------------------- + elseif(idt_dif.ge.0.and.idt_dif.le.90.and. + $ c_qc(iim1)(1:1).ne.'D'.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.125.and. + $ abs(alon(iim1)-alon(ii)).lt.0.125.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ((ht_ft(ii).lt.25000.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.htdif_same/4+0.5).or. + $ (((l_ii_mdcrs.and.(.not.l_iim1_mdcrs)).or. ! new + $ (l_iim1_mdcrs.and.(.not.l_ii_mdcrs)).or. ! new + $ (l_ii_acars.and.(.not.l_iim1_acars)).or. ! new + $ (l_iim1_acars.and.(.not.l_ii_acars)).or. ! new + $ (l_ii_man.and.(.not.l_iim1_man)).or. ! new + $ (l_iim1_man.and.(.not.l_ii_man)).or. ! new + $ (((l_ii_amdar.and.l_iim1_amdar).or. ! new + $ (l_ii_airep.and.l_iim1_amdar).or. ! new + $ (l_iim1_airep.and.l_ii_amdar)).and. ! new + $ c_acftid(ii).eq.c_acftid(iim1)) ).and. ! new + $ ht_ft(ii).lt.25000.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.htdif_same+0.5).or. + $ (ht_ft(ii).gt.24999.5.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.htdif_same+0.5)).and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ ((abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25.and. + $ ((abs(difdir).lt.10.5).or. + $ (ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).eq.amiss))).or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss).or. + $ (ob_spd(iim1).ne.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss).or. + $ (ob_dir(iim1).ne.amiss.and.ob_dir(ii).eq.amiss)) + $ ) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Non-rejected duplicate found--',ii + endif +c +c Check if airep report is an exact dup except for large temperature or +c wind differences--assume encode error and reject both! +c ----------------------------------------------------------------- + elseif((idt_dif.ge.0.and.idt_dif.le.90).and. + $ c_qc(iim1)(1:1).ne.'D'.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.035.and. + $ abs(alon(iim1)-alon(ii)).lt.0.035.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (abs(ht_ft(iim1)-ht_ft(ii)).lt.0.5.or. + $ abs(pres(iim1)-pres(ii)).lt.0.05).and. + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_sh.or.l_iim1_sh).and. + $ (l_ii_man.and.l_iim1_man)) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Encoding problem detected' + endif +c +c Special case where winds are missing +c (Temperature for that report is usually way off!) +c Reject report with missing winds +c ------------------------------------------------- + if(ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss.and. + $ ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss.and. + $ (c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N')) then +c + c_qc(iim1)(1:1) = 'e' +c + elseif(ob_spd(ii).eq.amiss.and. + $ ob_spd(iim1).ne.amiss.and. + $ ob_dir(ii).eq.amiss.and. + $ ob_dir(iim1).ne.amiss.and. + $ (c_qc(ii)(1:1).eq.'-'.or. + $ c_qc(ii)(1:1).eq.'.'.or. + $ c_qc(ii)(1:1).eq.'N')) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave + c_qc(iim1)(1:1) = 'e' +c + elseif((c_acftid(ii).eq.c_acftid(iim1).or. + $ l_iim1_sh).and. + $ (c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N')) then +c + c_qc(iim1)(1:1) = 'E' +c + elseif((c_acftid(ii).eq.c_acftid(iim1).or.l_ii_sh).and. + $ (c_qc(ii)(1:1).eq.'-'.or. + $ c_qc(ii)(1:1).eq.'.'.or. + $ c_qc(ii)(1:1).eq.'N')) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave + c_qc(iim1)(1:1) = 'E' +c + endif +c + if(abs(ob_t(iim1)-ob_t(ii)).lt.2.05.and. + $ abs(difdir).lt.10.5.and. + $ abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25) then +c + c_qc(iim1)(1:1) = 'd' +c + if(l_print) write(io8,*) 'Near duplicate' + n_near = n_near + 1 + n_near_MaMa = n_near_MaMa + 1 +c + else + n_bad_encode = n_bad_encode + 1 +c + if(abs(ob_t(iim1)-ob_t(ii)).gt.2.05.and. + $ c_qc(iim1)(1:1).ne.'e') then + c_qc(ii)(6:6) = 'E' + if(l_print) write(io8,*) 'Bad temperature' + endif +c + if(abs(difdir).gt.10.5.and. + $ c_qc(iim1)(1:1).ne.'e') then + c_qc(ii)(7:7) = 'E' + if(l_print) write(io8,*) 'Bad wind direction' + endif +c + if(abs(ob_spd(iim1)-ob_spd(ii)).gt.1.25.and. + $ c_qc(iim1)(1:1).ne.'e') then + c_qc(ii)(8:8) = 'E' + if(l_print) write(io8,*) 'Bad windspeed' + endif + endif +c +c Check if report is a position dup +c Echo to log file for later inspection +c ------------------------------------- + elseif(idt_dif.ge.0.and.idt_dif.le.90.and. + $ c_qc(iim1)(1:1).ne.'D'.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.035.and. + $ abs(alon(iim1)-alon(ii)).lt.0.035.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c $ abs(ht_ft(iim1)-ht_ft(ii)).lt.50.5.and. + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.25.5.and. + $ (c_acftid(ii).eq.c_acftid(iim1).or. + $ l_ii_sh.or.l_iim1_sh)) then +c +c Check if MDCRS-MDCRS duplicate has a bad roll angle +c --------------------------------------------------- + if((ichk_s(iim1).eq.-10.and. + $ ichk_s(ii ).ne.-10).and. + $ l_iim1_mdcrs.and.l_ii_mdcrs.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ (c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N')) then +c + c_qc(iim1)(1:1) = 'd' +c + n_near = n_near + 1 + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll angle qc - MDCRS' + endif +c + elseif((ichk_s(ii ).eq.-10.and. + $ ichk_s(iim1).ne.-10).and. + $ l_iim1_mdcrs.and.l_ii_mdcrs.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ (c_qc(ii)(1:1).eq.'-'.or. + $ c_qc(ii)(1:1).eq.'.'.or. + $ c_qc(ii)(1:1).eq.'N')) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave +c + c_qc(iim1)(1:1) = 'd' +c + n_near = n_near + 1 + n_nr_bad_roll_Md = n_nr_bad_roll_Md + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll angle qc - MDCRS' + endif +c +c Check if AMDAR-AMDAR duplicate has a bad roll angle +c --------------------------------------------------- + elseif((ichk_s(iim1).eq.-10.and. + $ ichk_s(ii ).ne.-10).and. + $ l_iim1_amdar.and.l_ii_amdar.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ (c_qc(iim1)(1:1).eq.'-'.or. + $ c_qc(iim1)(1:1).eq.'.'.or. + $ c_qc(iim1)(1:1).eq.'N')) then +c + c_qc(iim1)(1:1) = 'd' +c + n_near = n_near + 1 + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll angle qc - AMDAR' + endif +c + elseif((ichk_s(ii ).eq.-10.and. + $ ichk_s(iim1).ne.-10).and. + $ l_iim1_amdar.and.l_ii_amdar.and. + $ abs(ob_t(iim1)-ob_t(ii)).lt.1.25.and. + $ (c_qc(ii)(1:1).eq.'-'.or. + $ c_qc(ii)(1:1).eq.'.'.or. + $ c_qc(ii)(1:1).eq.'N')) then +c + indx(knt1) = ii + indx(knt0) = iim1 + isave = ii + ii = iim1 + iim1 = isave +c + c_qc(iim1)(1:1) = 'd' +c + n_near = n_near + 1 + n_nr_bad_roll_Am = n_nr_bad_roll_Am + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll angle qc - AMDAR' + endif +c + else + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Position duplicate found' + endif +c + endif +c +c Set c_qc to '.' if no duplicate found within 60 sec window +c ---------------------------------------------------------- + else + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' + endif +c +c Set c_qc to '.' if lats and lons too far apart +c ---------------------------------------------- + else + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' + endif +c + if(l_print) then +c if(c_qc(iim1)(1:1).eq.'d'.and. +c $ (idt(ii).ne.idt(iim1).or. +c $ c_acftid(ii).ne.c_acftid(iim1))) then + write(io8,*) + write(io8,8002) kkdup,iim1,c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + write(io8,8002) kkdup,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 8002 format(i3,1x,i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0,1x,f5.2,4(2(1x,f8.2),1x,i5),1x + x, '!',a11,'!') + endif +cc +ccccccdak Set up table associating airep and acars flight ids +cc Set up table associating airep and tamdar flight ids +cc Require that the report be within idt_samflt of the previously +cc saved minimum and maximum times for this flight segment +cc and is within fairly close limits on position, temp and winds +cc --------------------------------------------------------------- +c if( ( (l_ii_acars .and..not.l_iim1_acars ).or. +c $ (l_iim1_acars .and..not.l_ii_acars ).or. +c $ (l_ii_mdcrs .and..not.l_iim1_mdcrs).or. +c $ (l_iim1_mdcrs.and..not.l_ii_mdcrs ) ).and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c $ abs(alat(iim1)-alat(ii)) .lt.0.025.and. +c $ abs(alon(iim1)-alon(ii)) .lt.0.025.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c $ abs(ob_t(iim1)-ob_t(ii)) .lt.0.65.and. +c $ abs(difdir).lt.5.5.and. +c $ abs(ob_spd(iim1)-ob_spd(ii)).lt.0.55.and. +c $ (c_qc(iim1)(1:1).eq.'D'.or.c_qc(iim1)(1:1).eq.'d').and. +c $ c_acftid(iim1)(1:8).ne.c_acftid(ii)(1:8) ) then +cc +c if(ndup.ne.0) then +c kk = 1 +cc +c do while (kk.le.ndup) +c min_idt = idt_min(kk) - idt_samflt +cc if(min_idt.lt.0) min_idt = 0 +c max_idt = idt_max(kk) + idt_samflt +cc if(max_idt.gt.24*60*60) max_idt = 24*60*60 +cc +c if(c_acftid(ii) .eq.c_acr_id(kk).and. +c $ c_acftreg(ii) .eq.c_acr_reg(kk).and. +c $ c_acftid(iim1).eq.c_air_id(kk).and. +c $ idt(ii).ge.min_idt.and. +c $ idt(ii).le.max_idt) then +cc +c kdup(kk) = kdup(kk) + 1 +c if(idt(ii).lt.idt_min(kk)) +c $ idt_min(kk) = idt(ii) +c if(idt(ii).gt.idt_max(kk)) +c $ idt_max(kk) = idt(ii) +cc +c goto 201 +c endif +cc +c kk = kk + 1 +c enddo +c endif +cc +c ndup = ndup + 1 +c c_acr_id(ndup) = c_acftid(ii) +c c_acr_reg(ndup) = c_acftreg(ii) +c c_air_id(ndup) = c_acftid(iim1) +c idt_min(ndup) = idt(ii) +c idt_max(ndup) = idt(ii) +c kdup(ndup) = 1 +cc +c 201 continue +c endif +c +c Set c_qc to '.' if iim1 = 0 +c --------------------------- + else + if(c_qc(ii)(1:1).eq.'-') c_qc(ii)(1:1) = '.' + endif +c +c End loop over reports within 60 seconds +c --------------------------------------- + enddo +c +c End loop over reports +c --------------------- + enddo +cc +cc Check mixed duplicates for double mapping +cc ----------------------------------------------- +c do kk=1,ndup-1 +c do kk1=kk+1,ndup +c if(c_air_id(kk).eq.c_air_id(kk1).and. +c $ c_acr_id(kk).ne.c_acr_id(kk1)) then +c if((kdup(kk).le.3.and.kdup(kk1).gt.5).or. +c $ ((kdup(kk1)-kdup(kk))*100/kdup(kk1).ge.70)) then +c c_air_id(kk) = ' ' +c c_acr_id(kk) = ' ' +c kdup(kk) = 0 +c elseif((kdup(kk).gt.5.and.kdup(kk1).le.3).or. +c $ ((kdup(kk)-kdup(kk1))*100/kdup(kk).ge.70)) then +c c_air_id(kk1) = ' ' +c c_acr_id(kk1) = ' ' +c kdup(kk1) = 0 +c else +c write(io8,*) +c write(io8,*) 'Multiple ids for mixed duplicates found' +c write(io8,*) 'Cannot choose which id to use' +c write(io8,*) kk,' ',c_air_id(kk),c_acr_id(kk), +c $ kdup(kk),idt_min(kk),idt_max(kk) +c write(io8,*) kk1,' ',c_air_id(kk1),c_acr_id(kk1), +c $ kdup(kk1),idt_min(kk1),idt_max(kk1) +c c_air_id(kk) = ' ' +c c_acr_id(kk) = ' ' +c kdup(kk) = 0 +c c_air_id(kk1) = ' ' +c c_acr_id(kk1) = ' ' +c kdup(kk1) = 0 +c endif +c endif +c enddo +c enddo +cc +cc Output mixed duplicate mapping +cc ------------------------------ +c write(io8,*) +ccccdak write(io8,*) ' kk airep id acars id # idt_min idt_max' +c write(io8,*) ' kk airep id tamdar id # idt_min idt_max' +c write(io8,*) ' -- -------- --------- --- ------- -------' +c do kk=1,ndup +c write(io8,*) kk,' ',c_air_id(kk),c_acr_id(kk),kdup(kk), +c $ idt_min(kk),idt_max(kk) +c enddo +cc +cc Map new flight ids and tail numbers on airep data +cc Check all flights--allow AMDAR-AIREP mixed dups +ccccccdak Almost all of the AIREP-ACARS/MDCRS dups are UAL +cc Almost all of the AIREP-TAMDAR/MDCRS dups are UAL +cc ------------------------------------------------- +c kmap = 0 +c l_ual_all = .false. +cc +c do iob=1,numreps +c ii = indx(iob) +c if(itype(ii).ne.i_acars .and. +c $ itype(ii).ne.i_acars_asc .and. +c $ itype(ii).ne.i_acars_lvl .and. +c $ itype(ii).ne.i_acars_des .and. +c $ itype(ii).ne.i_mdcrs .and. +c $ itype(ii).ne.i_mdcrs_asc.and. +c $ itype(ii).ne.i_mdcrs_lvl.and. +c $ itype(ii).ne.i_mdcrs_des.and. +c $ itype(ii).ne.i_amdar .and. +c $ itype(ii).ne.i_amdar_asc.and. +c $ itype(ii).ne.i_amdar_lvl.and. +c $ itype(ii).ne.i_amdar_des.and. +c $ c_qc(ii)(1:1).ne.'D'.and. +c $ c_qc(ii)(1:1).ne.'d'.and. +c $ c_qc(ii)(1:1).ne.'e'.and. +c $ c_qc(ii)(1:1).ne.'E'.and. +c $ (.not.l_ual_all.or. +c $ (l_ual_all.and.c_acftid(ii)(1:2).eq.'UA'))) then +cc +c do kk=1,ndup +c min_idt = idt_min(kk) - idt_samflt +c max_idt = idt_max(kk) + idt_samflt +cc +c if((c_acftid(ii)(1:8).eq. +c $ c_air_id(kk)(1:2)//c_air_id(kk)(4:9)).or. +c $ (c_acftid(ii)(1:9).eq.c_air_id(kk)(1:9)).and. +c $ idt(ii).ge.min_idt.and. +c $ idt(ii).le.max_idt) then +cc +cc write(io8,*) +cc write(io8,*) 'Flight id re-mapped: before and after' +cc write(io8,8002) kkdup,ii,c_insty_ob(itype(ii)) +cc x, c_acftreg(ii),c_acftid(ii) +cc x, idt(ii),alat(ii),alon(ii) +cc x, pres(ii),ht_ft(ii) +cc x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +cc x, ob_q(ii),xiv_q(ii),ichk_q(ii) +cc x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +cc x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +cc x, c_qc(ii) +cc +c c_acftid(ii) = c_acr_id(kk) +c c_acftreg(ii) = c_acr_reg(kk) +c kmap = kmap + 1 +cc +cc write(io8,8002) kkdup,ii,c_insty_ob(itype(ii)) +cc x, c_acftreg(ii),c_acftid(ii) +cc x, idt(ii),alat(ii),alon(ii) +cc x, pres(ii),ht_ft(ii) +cc x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +cc x, ob_q(ii),xiv_q(ii),ichk_q(ii) +cc x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +cc x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +cc x, c_qc(ii) +c endif +c enddo +c endif +c enddo +c +c If no tail number is found, copy airlines ident into tail number +c to accumulate stats by airline +c ----------------------------------------------------------------- +c DAK: Could this be written more efficiently? + do iob=1,numreps + ii = indx(iob) +C DAK: Here is the logic that originally did not work for TAMDAR reports whose tail number is +c missing, but flight number was all numbers (e.g., "00009934") meaning a tail number +c could not be created from the flight number -- this was bypassed by changing "000" in +c the 1st 3 characters of the flight number to "TAM" in subroutine input_acqc where the +c reports are read in from NCEP PREPBUFR file and stored in memory + if(c_acftreg(ii).eq.' ') then + if(c_acftid(ii)(1:5).eq.'XX999') then + c_acftreg(ii)(1:5) = 'XX999' + else + if(c_acftid(ii)(1:1).ge.'A'.and. + $ c_acftid(ii)(1:1).le.'Z') + $ c_acftreg(ii)(1:1) = c_acftid(ii)(1:1) +c + if(c_acftid(ii)(2:2).ge.'A'.and. + $ c_acftid(ii)(2:2).le.'Z'.and. + $ c_acftreg(ii)(1:1).ne.' ') + $ c_acftreg(ii)(2:2) = c_acftid(ii)(2:2) +c + if(c_acftid(ii)(3:3).ge.'A'.and. + $ c_acftid(ii)(3:3).le.'Z'.and. + $ c_acftreg(ii)(2:2).ne.' ') + $ c_acftreg(ii)(3:3) = c_acftid(ii)(3:3) +c + if(c_acftid(ii)(4:4).ge.'A'.and. + $ c_acftid(ii)(4:4).le.'Z'.and. + $ c_acftreg(ii)(3:3).ne.' ') + $ c_acftreg(ii)(4:4) = c_acftid(ii)(4:4) +c + if(c_acftid(ii)(5:5).ge.'A'.and. + $ c_acftid(ii)(5:5).le.'Z'.and. + $ c_acftreg(ii)(4:4).ne.' ') + $ c_acftreg(ii)(5:5) = c_acftid(ii)(5:5) + endif + endif + enddo +c +c write(io8,*) +c write(io8,*) 'Number of flight ids re-mapped = ',kmap +c +c Sum number of reports per tail numbers +c -------------------------------------- + write(*,*) 'Counting number of reports per tail number' + write(io8,*) + write(io8,*) 'Counting number of reports per tail number' + write(io8,*) '------------------------------------------' + l_print = .false. + call do_reg(l_print,io8, + $ max_reps,numreps,itype,c_qc,c_acftreg,indx, + $ maxflt,kreg,creg_reg,nobs_reg,*99) +c +c Output statistics and rejects +c ----------------------------- + kbad = 0 +c +c Write header to output file +c --------------------------- + if(.not.l_operational) then + write(io30,*) + write(io30,*) 'Encode dups (E or e)' + write(io30,*) '--------------------' + write(io30,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c +c Loop over reports +c ----------------- + do iob = 1,numreps + ii = indx(iob) +c +c Count number of reports considered +c ---------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + nrep_Md = nrep_Md + 1 + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + nrep_Ac = nrep_Ac + 1 + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + nrep_Am = nrep_Am + 1 + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + nrep_Ar = nrep_Ar + 1 + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nrep_Ma = nrep_Ma + 1 + ktype = 5 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + ktype = 0 + endif +c +c Count number of reports rejected with encode errors +c --------------------------------------------------- + if(c_qc(ii)(1:1).eq.'e'.or. + $ c_qc(ii)(1:1).eq.'E') then +c + if(ktype.ne.0) kbad(ktype,1) = kbad(ktype,1) + 1 +c +c Count number of rejected reports by tail number +c ----------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(ktype.gt.0.and.ktype.le.5) + $ nrej_reg(mm,ktype) = nrej_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c Flag bad report for reorder subroutine and output rejects +c --------------------------------------------------------- + csort(ii)(1:5) = 'badob' +c + if(.not.l_operational) then + write(io30,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count number of bad temperatures and bad winds +c ---------------------------------------------- + elseif(c_qc(ii)(6:6).eq.'E'.or. + $ c_qc(ii)(7:7).eq.'E'.or. + $ c_qc(ii)(8:8).eq.'E') then +c +c Count number of rejected temps/winds by tail number +c --------------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(ktype.gt.0.and.ktype.le.5) then + if(c_qc(ii)(6:6).eq.'E') + $ ntemp_reg(mm,ktype) = ntemp_reg(mm,ktype) + 1 + if(c_qc(ii)(7:7).eq.'E'.or. + $ c_qc(ii)(8:8).eq.'E') + $ nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + endif + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif + enddo +c +c Output statistics +c ----------------- + if(.not.l_operational) then + write(io30,*) + write(io30,*)' Number of MDCRS encode dups rejected = ' + $, kbad(1,1) +ccccdak write(io30,*)' Number of ACARS encode dups rejected = ' + write(io30,*)' Number of TAMDAR encode dups rejected = ' + $, kbad(2,1) + write(io30,*)' Number of AMDAR encode dups rejected = ' + $, kbad(3,1) + write(io30,*)' Number of AIREP encode dups rejected = ' + $, kbad(4,1) + write(io30,*)' Number of manAIREP encode dups rejected = ' + $, kbad(5,1) + endif +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers for rejected encode dups' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nrej_reg(mm,1)+nrej_reg(mm,2)+nrej_reg(mm,3) + $ +nrej_reg(mm,4)+nrej_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nrej_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers for reports with bad temperature' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( ntemp_reg(mm,1)+ntemp_reg(mm,2)+ntemp_reg(mm,3) + $ +ntemp_reg(mm,4)+ntemp_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(ntemp_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers for reports with bad winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,kk),kk=1,5) + endif + enddo +c +c Write header to output file +c --------------------------- + if(l_save_dups.and.(.not.l_operational)) then + write(io30,*) + write(io30,*) 'True dups(D) and close dups (d)' + write(io30,*) '-------------------------------' + write(io30,3001) + endif +c +c Loop over reports +c ----------------- + do iob = 1,numreps + ii = indx(iob) +c +c Count number of exact duplicates +c -------------------------------- + if(c_qc(ii)(1:1).eq.'D'.and. + $ csort(ii)(1:5).ne.'badob') then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + kbad(1,2) = kbad(1,2) + 1 + ndup_Md = ndup_Md + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + kbad(2,2) = kbad(2,2) + 1 + ndup_Ac = ndup_Ac + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + kbad(3,2) = kbad(3,2) + 1 + ndup_Am = ndup_Am + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + kbad(4,2) = kbad(4,2) + 1 + ndup_Ar = ndup_Ar + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + kbad(5,2) = kbad(5,2) + 1 + ndup_Ma = ndup_Ma + 1 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif + endif +c +c Count number of near and encode duplicates +c ------------------------------------------ + if(c_qc(ii)(1:1).eq.'d'.and. + $ csort(ii)(1:5).ne.'badob') then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + kbad(1,3) = kbad(1,3) + 1 + ndup_Md = ndup_Md + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + kbad(2,3) = kbad(2,3) + 1 + ndup_Ac = ndup_Ac + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + kbad(3,3) = kbad(3,3) + 1 + ndup_Am = ndup_Am + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + kbad(4,3) = kbad(4,3) + 1 + ndup_Ar = ndup_Ar + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + kbad(5,3) = kbad(5,3) + 1 + ndup_Ma = ndup_Ma + 1 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif + endif +c +c Set flag for "reorder" and output dups if desired +c ------------------------------------------------- + if(c_qc(ii)(1:1).eq.'D'.or. + $ c_qc(ii)(1:1).eq.'d') then +c + csort(ii)(1:5) = 'badob' +c + if(l_save_dups.and.(.not.l_operational)) then + write(io30,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif +c + endif + enddo +c +c Output statistics +c ----------------- + if(.not.l_operational) then + write(io30,*)' Number of MDCRS exact dups rejected = ' + $, kbad(1,2) +ccccdak write(io30,*)' Number of ACARS exact dups rejected = ' + write(io30,*)' Number of TAMDAR exact dups rejected = ' + $, kbad(2,2) + write(io30,*)' Number of AMDAR exact dups rejected = ' + $, kbad(3,2) + write(io30,*)' Number of AIREP exact dups rejected = ' + $, kbad(4,2) + write(io30,*)' Number of manAIREP exact dups rejected = ' + $, kbad(5,2) + write(io30,*)' Number of MDCRS near dups rejected = ' + $, kbad(1,3) +ccccdak write(io30,*)' Number of ACARS near dups rejected = ' + write(io30,*)' Number of TAMDAR near dups rejected = ' + $, kbad(2,3) + write(io30,*)' Number of AMDAR near dups rejected = ' + $, kbad(3,3) + write(io30,*)' Number of AIREP near dups rejected = ' + $, kbad(4,3) + write(io30,*)' Number of manAIREP near dups rejected = ' + $, kbad(5,3) + endif +c + kbadtot = kbad(1,1) + kbad(2,1) + kbad(3,1) + kbad(4,1) + $ + kbad(5,1) + kbad(1,2) + kbad(2,2) + kbad(3,2) + $ + kbad(4,2) + kbad(5,2) + kbad(1,3) + kbad(2,3) + $ + kbad(3,3) + kbad(4,3) + kbad(5,3) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in duplicate check' +c +c Output detailed stats +c --------------------- + if(l_last) then + write(io8,*) + write(io8,*) 'Distribution of MDCRS reports' + do ii=19,1,-1 + write(io8,'(37i7)') (n_area_Md(ii,kk),kk=1,37) + enddo +c + write(io8,*) +ccccdak write(io8,*) 'Distribution of ACARS reports' + write(io8,*) 'Distribution of TAMDAR reports' + do ii=19,1,-1 + write(io8,'(37i7)') (n_area_Ac(ii,kk),kk=1,37) + enddo +c + write(io8,*) + write(io8,*) 'Distribution of AMDAR reports' + do ii=19,1,-1 + write(io8,'(37i7)') (n_area_Am(ii,kk),kk=1,37) + enddo +c + write(io8,*) + write(io8,*) 'Distribution of AIREP reports' + do ii=19,1,-1 + write(io8,'(37i7)') (n_area_Ar(ii,kk),kk=1,37) + enddo +c + write(io8,*) + write(io8,*) 'Distribution of manAIREP reports' + do ii=19,1,-1 + write(io8,'(37i7)') (n_area_Ma(ii,kk),kk=1,37) + enddo +c + write(io8,*) + write(io8,*) 'Temporal distribution of MDCRS reports' + do ii=1,24 + write(io8,*) ii,n_time_Md(ii) + enddo +c + write(io8,*) +ccccdak write(io8,*) 'Temporal distribution of ACARS reports' + write(io8,*) 'Temporal distribution of TAMDAR reports' + do ii=1,24 + write(io8,*) ii,n_time_Ac(ii) + enddo +c + write(io8,*) + write(io8,*) 'Temporal distribution of AMDAR reports' + do ii=1,24 + write(io8,*) ii,n_time_Am(ii) + enddo +c + write(io8,*) + write(io8,*) 'Temporal distribution of AIREP reports' + do ii=1,24 + write(io8,*) ii,n_time_Ar(ii) + enddo +c + write(io8,*) + write(io8,*) 'Temporal distribution of manAIREP reports' + do ii=1,24 + write(io8,*) ii,n_time_Ma(ii) + enddo +c + write(io8,*) + write(io8,*) 'Vertical distribution of MDCRS reports' + write(io8,*) '<0 ',n_lev_Md(53) + do ii=0,50 + write(io8,*) ii,n_lev_Md(ii+1) + enddo + write(io8,*) '>50',n_lev_Md(52) +c + write(io8,*) +ccccdak write(io8,*) 'Vertical distribution of ACARS reports' + write(io8,*) 'Vertical distribution of TAMDAR reports' + write(io8,*) '<0 ',n_lev_Ac(53) + do ii=0,50 + write(io8,*) ii,n_lev_Ac(ii+1) + enddo + write(io8,*) '>50',n_lev_Ac(52) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AMDAR reports' + write(io8,*) '<0 ',n_lev_Am(53) + do ii=0,50 + write(io8,*) ii,n_lev_Am(ii+1) + enddo + write(io8,*) '>50',n_lev_Am(52) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AIREP reports' + write(io8,*) '<0 ',n_lev_Ar(53) + do ii=0,50 + write(io8,*) ii,n_lev_Ar(ii+1) + enddo + write(io8,*) '>50',n_lev_Ar(52) +c + write(io8,*) + write(io8,*) 'Vertical distribution of manAIREP reports' + write(io8,*) '<0 ',n_lev_Ma(53) + do ii=0,50 + write(io8,*) ii,n_lev_Ma(ii+1) + enddo + write(io8,*) '>50',n_lev_Ma(52) +c + write(io8,*) + write(io8,*) 'Vertical distribution of MDCRS temp reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Temp (C) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_temp_Md(36,13), + $ (n_temp_Md(36,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < -100 '',13i7)') n_temp_Md(35,13), + $ (n_temp_Md(35,ii),ii=1,12) + do kk=1,33 + ktemp = (5 * (kk-1) + 173) - 273 + write(io8,'(i9,13i7)') ktemp,n_temp_Md(kk,13), + $ (n_temp_Md(kk,ii),ii=1,12) + enddo + write(io8,'('' > 60 '',13i7)') n_temp_Md(34,13), + $ (n_temp_Md(34,ii),ii=1,12) +c + write(io8,*) +ccccdak write(io8,*) 'Vertical distribution of ACARS temp reports' + write(io8,*) 'Vertical distribution of TAMDAR temp reports' + write(io8,*) '--------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Temp (C) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_temp_Ac(36,13), + $ (n_temp_Ac(36,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < -100 '',13i7)') n_temp_Ac(35,13), + $ (n_temp_Ac(35,ii),ii=1,12) + do kk=1,33 + ktemp = (5 * (kk-1) + 173) - 273 + write(io8,'(i9,13i7)') ktemp,n_temp_Ac(kk,13), + $ (n_temp_Ac(kk,ii),ii=1,12) + enddo + write(io8,'('' > 60 '',13i7)') n_temp_Ac(34,13), + $ (n_temp_Ac(34,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AMDAR temp reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Temp (C) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_temp_Am(36,13), + $ (n_temp_Am(36,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < -100 '',13i7)') n_temp_Am(35,13), + $ (n_temp_Am(35,ii),ii=1,12) + do kk=1,33 + ktemp = (5 * (kk-1) + 173) - 273 + write(io8,'(i9,13i7)') ktemp,n_temp_Am(kk,13), + $ (n_temp_Am(kk,ii),ii=1,12) + enddo + write(io8,'('' > 60 '',13i7)') n_temp_Am(34,13), + $ (n_temp_Am(34,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AIREP temp reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Temp (C) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_temp_Ar(36,13), + $ (n_temp_Ar(36,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < -100 '',13i7)') n_temp_Ar(35,13), + $ (n_temp_Ar(35,ii),ii=1,12) + do kk=1,33 + ktemp = (5 * (kk-1) + 173) - 273 + write(io8,'(i9,13i7)') ktemp,n_temp_Ar(kk,13), + $ (n_temp_Ar(kk,ii),ii=1,12) + enddo + write(io8,'('' > 60 '',13i7)') n_temp_Ar(34,13), + $ (n_temp_Ar(34,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of manAIREP temp reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Temp (C) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_temp_Ma(36,13), + $ (n_temp_Ma(36,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < -100 '',13i7)') n_temp_Ma(35,13), + $ (n_temp_Ma(35,ii),ii=1,12) + do kk=1,33 + ktemp = (5 * (kk-1) + 173) - 273 + write(io8,'(i9,13i7)') ktemp,n_temp_Ma(kk,13), + $ (n_temp_Ma(kk,ii),ii=1,12) + enddo + write(io8,'('' > 60 '',13i7)') n_temp_Ma(34,13), + $ (n_temp_Ma(34,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of MDCRS wspd reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Spd(m/s) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_wspd_Md(40,13), + $ (n_wspd_Md(40,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < 0 '',13i7)') n_wspd_Md(39,13), + $ (n_wspd_Md(39,ii),ii=1,12) + do kk=1,37 + kwspd = 5 * (kk-1) + write(io8,'(i9,13i7)') kwspd,n_wspd_Md(kk,13), + $ (n_wspd_Md(kk,ii),ii=1,12) + enddo + write(io8,'('' > 180 '',13i7)') n_wspd_Md(38,13), + $ (n_wspd_Md(38,ii),ii=1,12) +c + write(io8,*) +ccccdak write(io8,*) 'Vertical distribution of ACARS wspd reports' + write(io8,*) 'Vertical distribution of TAMDAR wspd reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Spd(m/s) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_wspd_Ac(40,13), + $ (n_wspd_Ac(40,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < 0 '',13i7)') n_wspd_Ac(39,13), + $ (n_wspd_Ac(39,ii),ii=1,12) + do kk=1,37 + kwspd = 5 * (kk-1) + write(io8,'(i9,13i7)') kwspd,n_wspd_Ac(kk,13), + $ (n_wspd_Ac(kk,ii),ii=1,12) + enddo + write(io8,'('' > 180 '',13i7)') n_wspd_Ac(38,13), + $ (n_wspd_Ac(38,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AMDAR wspd reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Spd(m/s) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_wspd_Am(40,13), + $ (n_wspd_Am(40,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < 0 '',13i7)') n_wspd_Am(39,13), + $ (n_wspd_Am(39,ii),ii=1,12) + do kk=1,37 + kwspd = 5 * (kk-1) + write(io8,'(i9,13i7)') kwspd,n_wspd_Am(kk,13), + $ (n_wspd_Am(kk,ii),ii=1,12) + enddo + write(io8,'('' > 180 '',13i7)') n_wspd_Am(38,13), + $ (n_wspd_Am(38,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of AIREP wspd reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Spd(m/s) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_wspd_Ar(40,13), + $ (n_wspd_Ar(40,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < 0 '',13i7)') n_wspd_Ar(39,13), + $ (n_wspd_Ar(39,ii),ii=1,12) + do kk=1,37 + kwspd = 5 * (kk-1) + write(io8,'(i9,13i7)') kwspd,n_wspd_Ar(kk,13), + $ (n_wspd_Ar(kk,ii),ii=1,12) + enddo + write(io8,'('' > 180 '',13i7)') n_wspd_Ar(38,13), + $ (n_wspd_Ar(38,ii),ii=1,12) +c + write(io8,*) + write(io8,*) 'Vertical distribution of manAIREP wspd reports' + write(io8,*) '-------------------------------------------' + write(io8,'('' Altitude (kft)'')') + write(io8,'(1x,a45,a41)') + $ 'Spd(m/s) <0 0-5 5-10 10-15 15-20 20-25 ', + $ '25-30 30-35 35-40 40-45 45-50 50 >50 ' + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' missing '',13i7)') n_wspd_Ma(40,13), + $ (n_wspd_Ma(40,ii),ii=1,12) + write(io8,'(1x,a45,a41)') + $ '-------- ----- ----- ----- ----- ----- ----- ', + $ '----- ----- ----- ----- ----- ----- -----' + write(io8,'('' < 0 '',13i7)') n_wspd_Ma(39,13), + $ (n_wspd_Ma(39,ii),ii=1,12) + do kk=1,37 + kwspd = 5 * (kk-1) + write(io8,'(i9,13i7)') kwspd,n_wspd_Ma(kk,13), + $ (n_wspd_Ma(kk,ii),ii=1,12) + enddo + write(io8,'('' > 180 '',13i7)') n_wspd_Ma(38,13), + $ (n_wspd_Ma(38,ii),ii=1,12) + endif +c + write(*,*) + write(*,*) 'Duplicate check data counts--',cdtg_an + write(*,*) '---------------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(*,'('' Short ids '',24x,2(1x,i7),8x)') + $ n_sh_Ar,n_sh_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' All duplicates '',5(1x,i7))') + $ ndup_Md,ndup_Ac,ndup_Am,ndup_Ar,ndup_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Bad encode dup '',32x,(1x,i7),8x)') + $ n_bad_encode + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Duplicate check data counts' + write(io8,*) '---------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Missing ids '',24x,2(1x,i7),8x)') + $ n_xx999_Ar,n_xx999_Ma + write(io8,'(''Short ids '',24x,2(1x,i7),8x)') + $ n_sh_Ar,n_sh_Ma + write(io8,'(''Whole deg pos '',5(1x,i7))') + $ n_00_Md,n_00_Ac,n_00_Am,n_00_Ar,n_00_Ma + write(io8,'(''Zero lat/lon '',5(1x,i7))') + $ n_0000_Md,n_0000_Ac,n_0000_Am,n_0000_Ar,n_0000_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''All duplicates '',5(1x,i7))') + $ ndup_Md,ndup_Ac,ndup_Am,ndup_Ar,ndup_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Bad encode dup '',32x,(1x,i7),8x)') + $ n_bad_encode + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Exact duplicates: ',n_exact + write(io8,*) ' Exact duplicates with short ids: ',n_exact_sh + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',32x,(1x,i7))') + $ n_ex_sh_MaMd + write(io8,'(''Duplicates Ac '',32x,(1x,i7))') + $ n_ex_sh_MaAc + write(io8,'(''Duplicates Ar '',24x,2(1x,i7))') + $ n_ex_sh_ArAr,n_ex_sh_MaAr + write(io8,'(''Duplicates Ma '',24x,2(1x,i7))') + $ n_ex_sh_ArMa,n_ex_sh_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Exact dups with 0 lat and 0 lon: ',n_exact_0ll + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',5(1x,i7))') + $ n_ex_0ll_MdMd,n_ex_0ll_AcAc + write(io8,'(''Duplicates Ar '',32x,2(1x,i7))') + $ n_ex_0ll_MaAr + write(io8,'(''Duplicates Ma '',32x,2(1x,i7))') + $ n_ex_0ll_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Other exact duplicates:' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',2(1x,i7),8x,2(1x,i7))') + $ n_exact_MdMd,n_exact_MdAc,n_exact_MdAr,n_exact_MdMa + write(io8,'(''Duplicates Ac '',8x,(1x,i7),8x,2(1x,i7))') + $ n_exact_AcAc,n_exact_AcAr,n_exact_AcMa + write(io8,'(''Duplicates Am '',16x,4(1x,i7))') + $ n_exact_AmAm,n_exact_AmAr,n_exact_AmMa + write(io8,'(''Duplicates Ar '',24x,3(1x,i7))') + $ n_exact_ArAr,n_exact_ArMa + write(io8,'(''Duplicates Ma '',32x,2(1x,i7))') + $ n_exact_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Exact duplicates with bad roll angle qc flags: ' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',(1x,i7))') + $ n_ex_bad_roll_Md + write(io8,'(''Duplicates Am '',16x,(1x,i7))') + $ n_ex_bad_roll_Am + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) ' Near duplicates: ',n_near + write(io8,*) ' Near duplicates with short ids: ',n_near_sh + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',32x,(1x,i7))') + $ n_nr_sh_MaMd + write(io8,'(''Duplicates Ac '',32x,(1x,i7))') + $ n_nr_sh_MaAc + write(io8,'(''Duplicates Ar '',24x,2(1x,i7))') + $ n_nr_sh_ArAr,n_nr_sh_MaAr + write(io8,'(''Duplicates Ma '',24x,2(1x,i7))') + $ n_nr_sh_ArMa,n_nr_sh_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Near dups with 0 lat and 0 lon: ',n_near_0ll + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',(1x,i7),24x,(1x,i7))') + $ n_nr_0ll_MdMd,n_nr_0ll_MaMd + write(io8,'(''Duplicates Ac '',8x,5(1x,i7))') + $ n_nr_0ll_AcAc + write(io8,'(''Duplicates Am '',32x,(1x,i7))') + $ n_nr_0ll_MaAm + write(io8,'(''Duplicates Ar '',16x,(1x,i7),8x,(1x,i7))') + $ n_nr_0ll_AmAr,n_nr_0ll_MaAr + write(io8,'(''Duplicates Ma '',(1x,i7),8x,(1x,i7),8x,(1x,i7))') + $ n_nr_0ll_MdMa,n_nr_0ll_AmMa,n_nr_0ll_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Near dups with missing temp: ',n_near_mst + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',(1x,i7),16x,2(1x,i7))') + $ n_nr_mst_MdMd,n_nr_mst_ArMd,n_nr_mst_MaMd + write(io8,'(''Duplicates Ac '',24x,2(1x,i7))') + $ n_nr_mst_ArAc,n_nr_mst_MaAc + write(io8,'(''Duplicates Am '',16x,3(1x,i7))') + $ n_nr_mst_AmAm,n_nr_mst_ArAm,n_nr_mst_MaAm + write(io8,'(''Duplicates Ar '',16x,3(1x,i7))') + $ n_nr_mst_AmAr,n_nr_mst_ArAr,n_nr_mst_MaAr + write(io8,'(''Duplicates Ma '',24x,2(1x,i7))') + $ n_nr_mst_ArMa,n_nr_mst_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Near dups with missing winds: ',n_near_ws + write(io8,*) ' ID begins with IT:',n_near_ws_IT + write(io8,*) ' ID begins with EU:',n_near_ws_EU + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',2(1x,i7),8x,2(1x,i7))') + $ n_nr_mswn_MdMd,n_nr_mswn_AcMd,n_nr_mswn_ArMd,n_nr_mswn_MaMd + write(io8,'(''Duplicates Ac '',2(1x,i7),8x,2(1x,i7))') + $ n_nr_mswn_MdAc,n_nr_mswn_AcAc,n_nr_mswn_ArAc,n_nr_mswn_MaAc + write(io8,'(''Duplicates Am '',5(1x,i7))') + $ n_nr_mswn_MdAm,n_nr_mswn_AcAm,n_nr_mswn_AmAm,n_nr_mswn_ArAm + $, n_nr_mswn_MaAm + write(io8,'(''Duplicates Ar '',(1x,i7),8x,4(1x,i7))') + $ n_nr_mswn_MdAr,n_nr_mswn_AmAr,n_nr_mswn_ArAr,n_nr_mswn_MaAr + write(io8,'(''Duplicates Ma '',(1x,i7),16x,3(1x,i7))') + $ n_nr_mswn_MdMa,n_nr_mswn_ArMa,n_nr_mswn_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Near dups with zero winds: ',n_near_0ws + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',(1x,i7),16x,2(1x,i7))') + $ n_near_0ws_MdMd,n_near_0ws_ArMd,n_near_0ws_MaMd + write(io8,'(''Duplicates Am '',16x,3(1x,i7))') + $ n_near_0ws_AmAm,n_near_0ws_ArAm,n_near_0ws_MaAm + write(io8,'(''Duplicates Ar '',16x,3(1x,i7))') + $ n_near_0ws_AmAr,n_near_0ws_ArAr,n_near_0ws_MaAr + write(io8,'(''Duplicates Ma '',32x,(1x,i7))') + $ n_near_0ws_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,*) + write(io8,*) ' Other near duplicates:' + write(io8,*) ' Neg AMDAR/pos AIREP altitude: ',n_near_negpos + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',2(1x,i7),8x,2(1x,i7))') + $ n_near_MdMd,n_near_MdAc,n_near_MdAr,n_near_MdMa + write(io8,'(''Duplicates Ac '',8x,(1x,i7),8x,2(1x,i7))') + $ n_near_AcAc,n_near_AcAr,n_near_AcMa + write(io8,'(''Duplicates Am '',16x,4(1x,i7))') + $ n_near_AmAm,n_near_AmAr,n_near_AmMa + write(io8,'(''Duplicates Ar '',24x,3(1x,i7))') + $ n_near_ArAr,n_near_ArMa + write(io8,'(''Duplicates Ma '',32x,2(1x,i7))') + $ n_near_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Near duplicates with low windspeeds: ' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',2(1x,i7),8x,2(1x,i7))') + $ n_slow_MdMd,n_slow_MdAc,n_slow_MdAr + write(io8,'(''Duplicates Ac '',8x,(1x,i7),8x,2(1x,i7))') + $ n_slow_AcAc,n_slow_AcAr + write(io8,'(''Duplicates Am '',16x,4(1x,i7))') + $ n_slow_AmAm,n_slow_AmAr + write(io8,'(''Duplicates Ar '',24x,3(1x,i7))') + $ n_slow_ArAr,n_slow_ArMa + write(io8,'(''Duplicates Ma '',32x,2(1x,i7))') + $ n_slow_MaMa + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Near duplicates with bad roll angle qc flags: ' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',(1x,i7))') + $ n_nr_bad_roll_Md + write(io8,'(''Duplicates Am '',16x,(1x,i7))') + $ n_nr_bad_roll_Am + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Near duplicates with position reports: ' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Duplicates Md '',2(1x,i7),8x,2(1x,i7))') + $ n_nr_posrep + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + return + + 99 continue + print *, '--------------------------------------------------' + print *, '~~~> SUBR. DUPCHEK_QC (transferred here from subr. ', + $ 'do_reg): RETURN 1' + print *, '--------------------------------------------------' + return 1 + + end +c +c ################################################################### +c subroutine reorder +c ################################################################### +c + subroutine reorder(l_flight,numreps,max_reps,indx,krej,in_bad + $, io8,l_print,cregmiss,csort,c_acftid,itype + $, kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,cid_flt_old,ntot_flt_old,nrej_flt_old + $, kreg,creg_reg,nobs_reg,nrej_reg,c_acftreg,l_newflt) +c +c Re-order index array to skip bad reports +c +c modified by p.m.pauley (3/2/01) to save extra ids not previously catalogued +c (needed for 2nd flights found in ordchek) +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! max number of observations/reports +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + integer itype(max_reps) ! instrument type + $, ktype ! pointer for instrument type + character*9 c_acftid(max_reps) ! acft flight number + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*25 csort(max_reps) ! variable used for sorting data +c +c Arrays for mixed duplicates +c --------------------------- + integer maxflt ! max number of flights allowed + $, kflight ! number of flights in dataset + character*6 cmaxflt ! character form of maxflt for NCEP print statement + character*8 creg_flt(maxflt) ! tail number for each flight + character*9 cid_flt(maxflt) ! flight id for each flight + character*9 cid_flt_old(maxflt) ! old value of flight id for each flight + integer nobs_flt(maxflt) ! number of reports per flight + $, ntot_flt(maxflt) ! previous value of total number of reports per flight + $, ntot_flt_old(maxflt)! previous value of total number of reports per flight + $, nrej_flt(maxflt) ! number of reports rejected per flight + $, nrej_flt_old(maxflt)! old value of number of reports rejected per flight + $, iobs_flt(maxflt) ! index for first report in each flight +c + logical l_newflt(maxflt) ! true if flight is new flight +c +c Tail number variables +c --------------------- + integer kreg ! number of tail numbers in dataset + character*8 creg_reg(maxflt) ! tail numbers + character*8 cregmiss ! missing value for tail number + integer nobs_reg(maxflt,5) ! # of reports / flight / type + integer nrej_reg(maxflt,5) ! # of reports rejected / flight / type + $, kk,mm ! index pointing to current tail number +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for reports + $, in_bad(max_reps) ! pointer index for bad reports +c +c Functions +c --------- + integer insty_ob_fun ! function to convert character +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer iob,job ! do loop index + $, ii,jj ! index pointing to current report + $, iim1,jjm1 ! index pointing to previous report + integer keep ! counter for number of reports kept + $, krej ! counter for number of reports rejected + integer kbad(5) ! counter for number of bad reports + $, kgood(5) ! counter for number of good reports + $, kper(5) ! percentage of bad reports (out of # of good) + $, k_yairep ! number of YRXX86 AIREPs rejected + real percent ! percentage of rejected reports +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + $, ifirst1 ! indicator - 1st time in subr. maxflt @ ipt 1 exceeded + $, ifirst2 ! indicator - 1st time in subr. maxflt @ ipt 2 exceeded + $, ifirst3 ! indicator - 1st time in subr. maxflt @ ipt 3 exceeded +c +ccccdak save i_acars ! instrument type for acars + save i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + $, ifirst1 ! indicator - 1st time in subr. maxflt @ ipt 1 exceeded + $, ifirst2 ! indicator - 1st time in subr. maxflt @ ipt 2 exceeded + $, ifirst3 ! indicator - 1st time in subr. maxflt @ ipt 3 exceeded +c +c Switches +c -------- + logical l_flight ! true if flight stats to be updated + $, l_print ! true if flight stats to be printed + $, l_first ! true first time subroutine is called + $, l_done ! true if finished +c +c Data statements +c --------------- + data l_first /.true./,ifirst1/0/,ifirst2/0/,ifirst3/0/ +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + if(l_first) then + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c + l_first = .false. + endif +c +c Initialize counters +c ------------------- + k_yairep = 0 +c + kbad = 0 + kgood = 0 +c + keep = 0 +c + l_newflt = .false. + nrej_reg = 0 +c + kk = 1 + mm = 1 +c +c Loop over obs +c ------------- + do iob = 1,numreps + ii = indx(iob) +c +c If report rejected... +c --------------------- + if(csort(ii)(1:5).eq.'badob') then +c + krej = krej+1 + in_bad(krej) = indx(iob) +c + csort(ii)(1:25) = 'zzzzzzzzzzzzzzzzzzzzzzzzz' +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + kbad(1) = kbad(1) + 1 + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + kbad(2) = kbad(2) + 1 + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + kbad(3) = kbad(3) + 1 + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + kbad(4) = kbad(4) + 1 + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + kbad(5) = kbad(5) + 1 + ktype = 5 +c + if(itype(ii).eq.i_man_Yairep) + $ k_yairep = k_yairep + 1 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif +c +c Count rej reps by tail number/flight number, if desired +c ------------------------------------------------------- + if(l_flight) then +c +c Increment number of reports rejected per flight +c ----------------------------------------------- + 11 if(c_acftid(ii).eq.cid_flt(mm)) then + nrej_flt(mm) = nrej_flt(mm) + 1 + if(l_newflt(mm)) then + mm = 1 + endif +c + else + mm = mm + 1 + if(mm.le.kflight) then + goto 11 +c + else + if(kflight.ne.maxflt) then + kflight = kflight + 1 + else +c----------------------------------- + if(ifirst1.eq.0) then + ifirst1 = 1 + write(io8,*) + write(io8,*) 'WARNING-1: Need to increase maxflt!' + print 53, maxflt,maxflt + 53 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + '"FLIGHTS" IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER ', + +'NAME "MAXFLT" - WILL CONTINUE ON PROCESSING ONLY ',I6,' FLTS-1'/) + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmaxflt//' AIRCRAFT "FLIGHT" '// + + 'LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// + + cmaxflt//' FLIGHTS PROCESSED-1"') + endif +c----------------------------------- + endif + cid_flt(kflight) = c_acftid(ii) + creg_flt(kflight) = c_acftreg(ii) + iobs_flt(kflight) = iob + ntot_flt(kflight) = 0 + nrej_flt(kflight) = 1 + l_newflt(kflight) = .true. + mm = 1 +c +c Search backwards for first ob from new flight +c --------------------------------------------- + job = iob + if(job.ne.1) then +12 jjm1 = indx(job-1) + if(c_acftid(jjm1)(1:9).eq.cid_flt(kflight)(1:9)) then + job = job-1 + if(job.ne.1) goto 12 + endif + endif +c +c Count total number of obs from new flight +c ----------------------------------------- + do while(job.le.numreps) + jj = indx(job) + if(c_acftid(jj)(1:9).eq.cid_flt(kflight)(1:9)) then + ntot_flt(kflight) = ntot_flt(kflight) + 1 + job = job + 1 + else + job = numreps + 1 + endif + enddo +c + nobs_flt(kflight) = ntot_flt(kflight) +c + endif + endif +c +c Skip blank tail numbers +c ----------------------- + if(c_acftreg(ii).ne.' ') then +c +c If tail numbers are equal, increment counters +c --------------------------------------------- + if(c_acftreg(ii).eq.creg_reg(kk)) then + nrej_reg(kk,ktype) = nrej_reg(kk,ktype) + 1 +c +c Otherwise, loop to find matching tail number +c -------------------------------------------- + else + kk = 1 + l_done = .false. + do while (.not.l_done) + if(c_acftreg(ii).eq.creg_reg(kk)) then + nrej_reg(kk,ktype) = nrej_reg(kk,ktype) + 1 + l_done = .true. + else + kk = kk + 1 + if(kk.eq.kreg+1) then + write(io8,*) + write(io8,*) 'Tail# not found--',c_acftreg(ii),ii + l_done = .true. + endif + endif + enddo + endif + endif + endif +c +c If report not rejected... +c ------------------------- + else + keep = keep + 1 +c + indx(keep) = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + kgood(1) = kgood(1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + kgood(2) = kgood(2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + kgood(3) = kgood(3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + kgood(4) = kgood(4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + kgood(5) = kgood(5) + 1 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif + endif + enddo +c +c Save number of good reports +c --------------------------- + numreps = keep +c +c Update flight stats if desired +c ------------------------------ + if(l_flight) then +c +c Initialize variables +c -------------------- + cid_flt_old = cid_flt ! DAK: has cid_flt been initialized at this point? + ntot_flt_old = ntot_flt ! DAK: has ntot_flt been initialized at this point? + nrej_flt_old = nrej_flt ! DAK: has nrej_flt been initialized at this point? + iobs_flt = 0 + nobs_flt = 0 + ntot_flt = 0 + nrej_flt = 0 + cid_flt = ' ' + creg_flt = ' ' + l_newflt = .false. +c +c + mm = 1 +c +c Begin loop over reports +c ----------------------- + do iob = 1,numreps + ii = indx(iob) + if(iob.eq.1) then + iim1 = 0 + else + iim1 = indx(iob-1) + endif +c +c Initialize variables for iob = 1 +c -------------------------------- + if(iob.eq.1) then + kk = 1 + iobs_flt(1) = 1 + nobs_flt(1) = 1 + cid_flt(1) = c_acftid(ii) + creg_flt(1) = c_acftreg(ii) +c + 101 if(cid_flt(1).eq.cid_flt_old(mm)) then + ntot_flt(1) = ntot_flt_old(mm) + nrej_flt(1) = nrej_flt_old(mm) + + else + mm = mm + 1 + if(mm.le.kflight) then + goto 101 + + else + write(io8,*) + write(io8,*) 'flight id #1 not found--',c_acftid(ii) +c +c ntot_flt(1) = nobs_flt(1) + cid_flt(1) = c_acftid(ii) + creg_flt(1) = c_acftreg(ii) + iobs_flt(1) = iob + nobs_flt(1) = 1 + ntot_flt(1) = 1 + nrej_flt(1) = 0 + l_newflt(1) = .true. + mm = 1 + endif + endif +c +c If flight numbers are equal, increment counter +c ---------------------------------------------- + elseif(c_acftid(iim1).eq.c_acftid(ii)) then + nobs_flt(kk) = nobs_flt(kk) + 1 + if(l_newflt(kk)) then + mm = 1 + endif + if(c_acftreg(ii).ne.cregmiss.and.creg_flt(kk).eq.cregmiss) + $ creg_flt(kk) = c_acftreg(ii) +c +c Otherwise, save starting index & start counting reports for next flight +c ------------------------------------------------------------------------- + else + if(kk.ne.maxflt) then + kk = kk + 1 + else +c----------------------------------- + if(ifirst2.eq.0) then + write(io8,*) + write(io8,*) 'WARNING-2: Need to increase maxflt!' + ifirst2 = 1 + print 753, maxflt,maxflt + 753 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + '"FLIGHTS" IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER ', + +'NAME "MAXFLT" - WILL CONTINUE ON PROCESSING ONLY ',I6,' FLTS-2'/) + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmaxflt//' AIRCRAFT "FLIGHT" '// + + 'LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// + + cmaxflt//' FLIGHTS PROCESSED-2"') + endif +c----------------------------------- + endif + iobs_flt(kk) = iob + nobs_flt(kk) = 1 + cid_flt(kk) = c_acftid(ii) + creg_flt(kk) = c_acftreg(ii) +c + 201 if(cid_flt(kk).eq.cid_flt_old(mm)) then + ntot_flt(kk) = ntot_flt_old(mm) + nrej_flt(kk) = nrej_flt_old(mm) + mm = 1 +c + else + mm = mm + 1 + if(mm.le.kflight) then + goto 201 +c + else + if(kk.ne.maxflt) then + kk = kk + 1 + else +c----------------------------------- + if(ifirst3.eq.0) then + write(io8,*) + write(io8,*) 'WARNING-3: Need to increase maxflt!' + ifirst3 = 1 + print 853, maxflt,maxflt + 853 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + '"FLIGHTS" IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER ', + +'NAME "MAXFLT" - WILL CONTINUE ON PROCESSING ONLY ',I6,' FLTS-3'/) + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmaxflt//' AIRCRAFT "FLIGHT" '// + + 'LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// + + cmaxflt//' FLIGHTS PROCESSED-3"') + endif +c----------------------------------- + endif + cid_flt(kk) = c_acftid(ii) + creg_flt(kk) = c_acftreg(ii) + iobs_flt(kk) = iob + ntot_flt(kk) = 0 + nrej_flt(kk) = 1 + l_newflt(kk) = .true. + mm = 1 +c +c Count total number of obs from new flight +c ----------------------------------------- + job = iob + do while(job.le.numreps) + jj = indx(job) + if(c_acftid(jj)(1:9).eq.cid_flt(kk)(1:9)) then + ntot_flt(kk) = ntot_flt(kk) + 1 + job = job + 1 + else + job = numreps + 1 + endif + enddo +c + nobs_flt(kk) = ntot_flt(kk) +c + endif + endif + endif + enddo + endif +c +c if(kflight.ne.kk) then +c write(io8,*) +c write(io8,*) 'Mismatch in numbers of flights' +c write(io8,*) ' kk = ',kk +c write(io8,*) ' kflight = ',kflight +c endif +c + kflight = kk +c +c Output number of reports retained/skipped +c ----------------------------------------- + if(kgood(1).eq.0)then + kper(1) = 0 + else + kper(1) = kbad(1) * 100 / (kgood(1)+kbad(1)) + endif +c + if(kgood(2).eq.0)then + kper(2) = 0 + else + kper(2) = kbad(2) * 100 / (kgood(2)+kbad(2)) + endif +c + if(kgood(3).eq.0)then + kper(3) = 0 + else + kper(3) = kbad(3) * 100 / (kgood(3)+kbad(3)) + endif +c + if(kgood(4).eq.0)then + kper(4) = 0 + else + kper(4) = kbad(4) * 100 / (kgood(4)+kbad(4)) + endif +c + if(kgood(5).eq.0)then + kper(5) = 0 + else + kper(5) = kbad(5) * 100 / (kgood(5)+kbad(5)) + endif +c + write(io8,*) + write(io8,*) ' Re-ordering index array' + write(io8,*) ' -----------------------' + write(io8,*) numreps,' reports retained' + write(io8,*) kbad(1),' MDCRS reports skipped leaving ',kgood(1) + $ ,'--',kper(1),'%' +ccccdak write(io8,*) kbad(2),' ACARS reports skipped leaving ',kgood(2) + write(io8,*) kbad(2),' TAMDAR rpts skipped leaving ',kgood(2) + $ ,'--',kper(2),'%' + write(io8,*) kbad(3),' AMDAR reports skipped leaving ',kgood(3) + $ ,'--',kper(3),'%' + write(io8,*) kbad(4),' AIREP reports skipped leaving ',kgood(4) + $ ,'--',kper(4),'%' + write(io8,*) kbad(5),' manAIREP reports skipped leaving ',kgood(5) + $ ,'--',kper(5),'%' + write(io8,*) ' out of these, ',k_yairep,' are YRXX reports' +c +c Output indices for each flight +c ------------------------------ + if(l_print.and.l_flight) then + write(io8,*) + write(io8,*) 'Subtotals for tail#s with rejected reports' + write(io8,*) '------------------------------------------' + write(io8,'(27x,a12,22x,a8)')'Total Number','Rejected' + write(io8,'(a47,a43)') + $ ' kk tail num #Md #Ac #Am #Ar #Ma', + $ ' #Md #Ac #Am #Ar #Ma % ' + write(io8,'(1x,a47,a43)') + $ '----- -------- ------ ------ ------ ------ ----', + $ '-- ------ ------ ------ ------ ------ -----' +c + do kk=1,kreg + + if((nobs_reg(kk,1)+nobs_reg(kk,2)+ + $ nobs_reg(kk,3)+nobs_reg(kk,4)+ + $ nobs_reg(kk,5)).ne.0) then +c + percent = (nrej_reg(kk,1) + nrej_reg(kk,2) + $ + nrej_reg(kk,3) + nrej_reg(kk,4) + $ + nrej_reg(kk,5)) * 100.0 + $ / (nobs_reg(kk,1) + nobs_reg(kk,2) + $ + nobs_reg(kk,3) + nobs_reg(kk,4) + $ + nobs_reg(kk,5)) + else + percent = -9999.0 + endif +c + write(io8,'(i5,1x,a8,10(1x,i6),f6.1)') kk,creg_reg(kk) + $, nobs_reg(kk,1),nobs_reg(kk,2) + $, nobs_reg(kk,3),nobs_reg(kk,4) + $, nobs_reg(kk,5) + $, nrej_reg(kk,1),nrej_reg(kk,2) + $, nrej_reg(kk,3),nrej_reg(kk,4) + $, nrej_reg(kk,5),percent + enddo + endif +c + return + end +c +c ################################################################### +c subroutine do_flt +c ################################################################### +c + subroutine do_flt(l_first,numreps,max_reps,c_acftid,c_acftreg,idt, + $ ht_ft,cidmiss,cregmiss,indx,idt_samflt, + $ kflight,maxflt,cid_flt,creg_flt,nobs_flt,ntot_flt, + $ nrej_flt,iobs_flt,csort,l_sort,l_print,amiss,io8,*) +c +c Determine starting index for each flight and number of reports per flight +c +c modified by p.pauley (4/1/01) to allow a shorter time gap between flight +c segments if a low altitude is found on either +c side of the time gap +c +c modified by p.pauley (11/1/01) to use both upper and lower case letters +c for the 9th character in the flight id. +c Required to deal with the large number of +c aircraft using flight id VYXAUSJA beginning +c in late October 2001. +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! max number of observations/reports +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + character*9 c_acftid(max_reps) ! acft flight number + character*8 c_acftreg(max_reps) ! acft registration (tail) number + integer idt(max_reps) ! time in seconds to analysis time + real ht_ft(max_reps) ! height in feet + character*25 csort(max_reps) ! variable used for sorting data +c +c Arrays for mixed duplicates +c --------------------------- + integer maxflt ! max number of flights allowed + $, kflight ! number of flights in dataset + character*8 creg_flt(maxflt) ! tail number for each flight + character*9 cid_flt(maxflt) ! flight id for each flight + integer nobs_flt(maxflt) ! number of reports per flight + $, ntot_flt(maxflt) ! total number of reports per flight + $, nrej_flt(maxflt) ! number of reports rejected per flight + $, iobs_flt(maxflt) ! index for first report in each flight +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for reports +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer ii ! index for current ob + $, iim1 ! index for previous ob + $, iob ! do loop index--over reports + $, kk ! do loop index--over flights + integer nave ! average number of reports per flight + $, nmiss ! number of reps with missing flight id + $, idt_samflt ! time difference allowed for same flight + $, idt_dif ! actual time difference + integer istart ! first report in flight + $, iistart ! index for first report in flight + $, iend ! last report in flight + $, iiend ! index for last report in flight + integer k_abc ! pointer for c_abc + integer knt ! counter used in defining iim1 +c + real amiss ! real missing value flag +c + character*1 c_abc(62) ! array of lower-case and upper-case letters + character*8 cregmiss ! missing value flag for tail number + $, cidmiss ! missing value flag for flight number +c +c Switches +c -------- + logical l_first ! true first time subroutine is called + $, l_print ! true for printing values + $, l_sort ! true if data need to be sorted + $, l_same ! true if tail numbers are same + $, l_newid ! true if letter to be appended to flight id +c +c Data statements +c --------------- + data c_abc/'a','b','c','d','e','f','g','h','i','j','k','l','m', + $ 'n','o','p','q','r','s','t','u','v','w','x','y','z', + $ 'A','B','C','D','E','F','G','H','I','J','K','L','M', + $ 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z', + $ '0','1','2','3','4','5','6','7','8','9'/ +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize variables +c -------------------- + l_sort = .false. +c + kflight = 0 + iobs_flt = 0 + nobs_flt = 0 + ntot_flt = 0 + nrej_flt = 0 + cid_flt = ' ' + creg_flt = ' ' +c +c Begin loop over reports +c ----------------------- + do iob = 1,numreps + ii = indx(iob) + if(iob.eq.1) then + iim1 = 0 + else + iim1 = indx(iob-1) + endif +c +c Initialize variables for iob = 1 +c -------------------------------- + if(iob.eq.1) then + kflight = 1 + iobs_flt(1) = 1 + nobs_flt(1) = 1 + ntot_flt(1) = 1 + cid_flt(1) = c_acftid(ii) + creg_flt(1) = c_acftreg(ii) + nmiss = 1 +c +c If flight numbers are equal, increment counter +c ---------------------------------------------- + elseif(c_acftid(iim1)(1:9).eq.c_acftid(ii)(1:9)) then + nobs_flt(kflight) = nobs_flt(kflight) + 1 + ntot_flt(kflight) = ntot_flt(kflight) + 1 + if(c_acftid(ii)(1:8).eq.cidmiss(1:8)) + $ nmiss = nmiss + 1 + if(c_acftreg(ii).ne.cregmiss.and. + $ creg_flt(kflight).eq.cregmiss) + $ creg_flt(kflight) = c_acftreg(ii) +c +c Otherwise, save starting index and start counting reports for next flight +c ------------------------------------------------------------------------- + else + kflight = kflight + 1 +c----------------------------------- +c Check index against maximum +c --------------------------- + if(kflight.gt.maxflt) then + kflight = kflight - 1 + write(io8,*) + write(io8,*) 'Subr. DO_FLT, ipoint 1: Max number of ', + $ 'flights exceeded--increase maxflt' + return 1 + endif +c----------------------------------- + cid_flt(kflight) = c_acftid(ii) + creg_flt(kflight) = c_acftreg(ii) + iobs_flt(kflight) = iob + nobs_flt(kflight) = 1 + ntot_flt(kflight) = 1 + endif + enddo +c +c Check for flights with same flight # (but different tail #s) +c (do this only the first time the subroutine is called) +c ------------------------------------------------------------ + if(l_first) then + do kk=1,kflight + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) + k_abc = 0 +c +c Check if tail number is constant for entire flight +c -------------------------------------------------- + l_same = .true. +c + do iob=istart+1,iend + ii = indx(iob) + if(c_acftreg(iistart).eq.cregmiss) then + istart = istart + 1 + iistart = indx(istart) + elseif(c_acftreg(ii).ne.c_acftreg(iistart).and. + $ c_acftreg(ii).ne.cregmiss) then + l_same = .false. + endif + enddo +c +c Change last char of tail # if second tail # found +c ------------------------------------------------- + if(.not.l_same) then + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c ii report has different tail number than first report +c ----------------------------------------------------- + if(c_acftreg(ii).ne.c_acftreg(iistart)) then +c +c ii report has different tail number than ii report +c -------------------------------------------------- + if(c_acftreg(ii).ne.cregmiss.and. + $ c_acftreg(ii).ne.c_acftreg(iim1)) then +c +c look backwards for same tail number if different ids are found +c -------------------------------------------------------------- + knt = 1 + 10 continue + if(c_acftreg(ii).ne.c_acftreg(iim1).and. + $ iob-knt.gt.istart) then + knt = knt + 1 + iim1 = indx(iob-knt) + idt_dif = abs(idt(ii) - idt(iim1)) + goto 10 + endif +c +c use new 9th char if tail number not found +c ----------------------------------------- + if(iim1.eq.iistart) then + k_abc = k_abc + 1 +c + if(k_abc.gt.62) then + write(io8,*) + write(io8,*) 'k_abc too large--too many tail#s!' + c_acftid(ii)(9:9) = '?' + csort(ii)(9:9) = '?' + else + c_acftid(ii)(9:9) = c_abc(k_abc) + csort(ii)(9:9) = c_abc(k_abc) + endif +c + l_sort = .true. +c +c use old 9th char if tail number found +c ------------------------------------- + else + c_acftid(ii)(9:9) = c_acftid(iim1)(9:9) + csort(ii)(9:9) = c_acftid(ii)(9:9) + endif +c +c subsequent reports with different tail number +c --------------------------------------------- + elseif(c_acftreg(ii).ne.cregmiss.and. + $ c_acftreg(ii).eq.c_acftreg(iim1)) then +c + c_acftid(ii)(9:9) = c_acftid(iim1)(9:9) + csort(ii)(9:9) = c_acftid(iim1)(9:9) +c +c missing value for tail number +c ----------------------------- + elseif(c_acftreg(ii).eq.cregmiss.and. + $ iob.ne.istart) then +c + if(c_acftreg(iim1).ne.cregmiss.and. + $ abs(idt(ii)-idt(iim1)).le.7200) then + c_acftreg(ii) = c_acftreg(iim1) +c +c else +c write(io8,*) +c write(io8,*) 'Missing tail number found for rep #',ii +c write(io8,*) 'Not sure which tail number to choose!' + endif + endif + endif + enddo + endif + enddo + endif +c +c Check if large time gaps exist during flight +c and identify coherent flight segments +c -------------------------------------------- + if(.not.l_sort) then +c + l_sort = .false. +c + do kk=1,kflight + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) + k_abc = 0 +c + l_newid = .false. +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) + idt_dif = abs(idt(ii) - idt(iim1)) + knt = 1 +c +c increment abc counter and change 8th char if time threshold crossed +c and flight ids don't change +c ------------------------------------------------------------------- + if(c_acftid(ii)(1:9).eq.c_acftid(iim1)(1:9).and. + $ (idt_dif.gt.idt_samflt.or. + $ (idt_dif.gt.idt_samflt/6.and. + $ ht_ft(ii).ne.amiss.and. + $ ht_ft(iim1).ne.amiss.and. + $ (ht_ft(ii).lt.5001..or.ht_ft(iim1).lt.5001.)))) then +c + l_newid = .true. + l_sort = .true. + k_abc = k_abc + 1 + if(c_abc(k_abc).eq.c_acftid(ii)(8:8)) k_abc = k_abc + 1 +c + if(k_abc.gt.10) then + write(io8,*) + write(io8,*) 'Large value: k_abc = ',k_abc + write(io8,*) ' ids = ',c_acftreg(ii),' ',c_acftid(ii) + endif +c + if(k_abc.gt.62) then + write(io8,*) + write(io8,*) 'k_abc too large!' + c_acftid(ii)(8:8) = '?' + csort(ii)(8:8) = '?' + else + c_acftid(ii)(8:8) = c_abc(k_abc) + csort(ii)(8:8) = c_acftid(ii)(8:8) + endif +c +c Check if flight numbers and tail numbers are the same, +c the time difference is small, and a new id is in use. +c Change flight id if so. +c ------------------------------------------------------- + elseif(c_acftid(ii)(1:7).eq.c_acftid(iim1)(1:7).and. + $ c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ idt_dif.le.idt_samflt.and. + $ l_newid) then +c + c_acftid(ii)(8:8) = c_acftid(iim1)(8:8) + csort(ii)(8:8) = c_acftid(ii)(8:8) + endif + enddo +c + enddo +c +c Re-do flight limits if time gaps found +c -------------------------------------- + if(l_sort) then + kflight = 0 + iobs_flt = 0 + nobs_flt = 0 + ntot_flt = 0 + nrej_flt = 0 + cid_flt = ' ' + creg_flt = ' ' +c + do iob = 1,numreps + ii = indx(iob) + if(iob.eq.1) then + iim1 = 0 + else + iim1 = indx(iob-1) + endif +c +c Initialize variables for iob = 1 +c -------------------------------- + if(iob.eq.1) then + kflight = 1 + iobs_flt(1) = 1 + nobs_flt(1) = 1 + ntot_flt(1) = 1 + cid_flt(1) = c_acftid(ii) + creg_flt(1) = c_acftreg(ii) + nmiss = 1 +c +c If flight numbers are equal, increment counter +c ---------------------------------------------- + elseif(c_acftid(iim1)(1:9).eq.c_acftid(ii)(1:9)) then + nobs_flt(kflight) = nobs_flt(kflight) + 1 + ntot_flt(kflight) = ntot_flt(kflight) + 1 + if(c_acftid(ii)(1:8).eq.cidmiss(1:8)) + $ nmiss = nmiss + 1 + if(c_acftreg(ii).ne.cregmiss.and. + $ creg_flt(kflight).eq.cregmiss) + $ creg_flt(kflight) = c_acftreg(ii) +c +c Otherwise, save starting index and start counting reports for next flight +c ------------------------------------------------------------------------- + else + kflight = kflight + 1 +c----------------------------------- +c Check index against maximum +c --------------------------- + if(kflight.gt.maxflt) then + kflight = kflight - 1 + write(io8,*) + write(io8,*) 'Subr. DO_FLT, ipoint 2: Max number of ', + $ 'flights exceeded--increase maxflt' + return 1 + endif +c----------------------------------- + cid_flt(kflight) = c_acftid(ii) + creg_flt(kflight) = c_acftreg(ii) + iobs_flt(kflight) = iob + nobs_flt(kflight) = 1 + ntot_flt(kflight) = 1 + endif + enddo + endif + endif +c +c Output basic stats +c ------------------ + nave = (numreps-nmiss) / (kflight-1) + write(io8,*) + write(io8,*) kflight,' different flights found' + write(io8,*) nave,' reports per flight, on average' +c +c Output indices for each flight +c ------------------------------ + if(l_print.and.((.not.l_sort.and.l_first).or..not.l_first)) then + write(io8,*) + write(io8,*) 'Indices for individual flights' + write(io8,*) '------------------------------' + write(io8,*) ' kk flight id istrt indx iend indx nobs' +c + do kk=1,kflight + istart = iobs_flt(kk) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + ii = indx(istart) + if(ii.eq.0) then + write(io8,*) + write(io8,*) 'ii = 0 in do_flt output section' + endif + write(io8,'(i5,1x,a9,5(1x,i5))') kk,c_acftid(ii),istart, + $ indx(istart),iend,indx(iend),nobs_flt(kk) + enddo + endif +c + return + end +c +c ################################################################### +c subroutine do_reg +c ################################################################### +c + subroutine do_reg(l_print,io8, + $ max_reps,numreps,itype,c_qc,c_acftreg,indx, + $ maxflt,kreg,creg_reg,nobs_reg,*) +c +c Count number of obs per tail (registration) number +c + implicit none +c +c Observation variables +c --------------------- + integer max_reps ! maximum number of reports allowed + integer numreps ! actual number of reports + $, itype(max_reps) ! observation type + character*11 c_qc(max_reps) ! qc flags + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + integer indx(max_reps) ! pointer index for reports + integer iob ! do loop index--over reports + integer ii ! index for current ob +c $, iim1 ! index for previous ob +c +c Tail number variables +c --------------------- + integer maxflt ! max number of flights/tail numbers + integer kreg ! actual number of tail#s in dataset + character*8 creg_reg(maxflt) ! tail numbers + integer nobs_reg(maxflt,5) ! number of reports per tail# per type + integer ktot ! sum of reports categorized + $, mm ! do loop index--over tail numbers +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c +c Function +c -------- + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Switches +c -------- + logical l_print ! true for printing values + logical l_done ! true if finished +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize variables +c -------------------- + kreg = 0 + creg_reg = 'xxxxxxxx' + nobs_reg = 0 +c +c Begin loop over reports +c ----------------------- + do iob = 1,numreps + ii = indx(iob) +c +c +c Ignore reports with blank tail number and those marked as duplicates +c -------------------------------------------------------------------- + if(c_acftreg(ii).ne.' '.and. + $ c_qc(ii)(1:1).ne.'D'.and. + $ c_qc(ii)(1:1).ne.'d') then +c +c Handle case where kreg = 0 +c -------------------------- + if(kreg.eq.0) then + kreg = 1 + mm = 1 + creg_reg(kreg) = c_acftreg(ii) + l_done = .true. +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nobs_reg(kreg,1) = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nobs_reg(kreg,2) = 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nobs_reg(kreg,3) = 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nobs_reg(kreg,4) = 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nobs_reg(kreg,5) = 1 + endif +c +c If tail numbers are equal, increment counter +c -------------------------------------------- + elseif(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nobs_reg(mm,1) = nobs_reg(mm,1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nobs_reg(mm,2) = nobs_reg(mm,2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nobs_reg(mm,3) = nobs_reg(mm,3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nobs_reg(mm,4) = nobs_reg(mm,4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nobs_reg(mm,5) = nobs_reg(mm,5) + 1 + endif +c +c Otherwise, loop to find matching tail number +c -------------------------------------------- + else + mm = 1 + l_done = .false. +c + do while (.not.l_done) + if(c_acftreg(ii).eq.creg_reg(mm)) then + l_done = .true. +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nobs_reg(mm,1) = nobs_reg(mm,1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nobs_reg(mm,2) = nobs_reg(mm,2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nobs_reg(mm,3) = nobs_reg(mm,3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nobs_reg(mm,4) = nobs_reg(mm,4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nobs_reg(mm,5) = nobs_reg(mm,5) + 1 + endif +c +c If tail number not found, add to end +c ------------------------------------ + else + mm = mm + 1 + if(mm.eq.kreg+1) then + kreg = kreg + 1 +c----------------------------------- +c Check index against maximum +c --------------------------- + if(kreg.gt.maxflt) then + kreg = kreg - 1 + write(io8,*) + write(io8,*) 'Subr. DO_REG: Max number of flights ', + $ 'exceeded--increase maxflt' + return 1 + endif +c----------------------------------- + creg_reg(kreg) = c_acftreg(ii) + l_done = .true. +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nobs_reg(mm,1) = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nobs_reg(mm,2) = 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nobs_reg(mm,3) = 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nobs_reg(mm,4) = 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nobs_reg(mm,5) = 1 + endif + endif + endif + enddo +c + endif + endif + enddo +c +c Output indices for each flight +c ------------------------------ + if(l_print) then + write(io8,*) + write(io8,*) 'Indices for individual tail numbers' + write(io8,*) '-----------------------------------' +ccccdak write(io8,*) ' mm flight# #MDCRS #ACARS #AMDAR ', + write(io8,*) ' mm flight# #MDCRS #TAMDAR #AMDAR ', + $ ' #AIREP #manAIREP ' + endif +c + ktot = 0 + do mm=1,kreg +c + if(l_print) write(io8,'(i5,1x,a8,6(1x,i5))') mm,creg_reg(mm), + $ nobs_reg(mm,1),nobs_reg(mm,2),nobs_reg(mm,3), + $ nobs_reg(mm,4),nobs_reg(mm,5) +c + ktot = ktot + nobs_reg(mm,1) + nobs_reg(mm,2) + nobs_reg(mm,3) + $ + nobs_reg(mm,4) + nobs_reg(mm,5) +c + enddo +c + write(io8,*) + write(io8,*) numreps,' reports input to do_reg' + write(io8,*) ktot,' reports categorized by tail number' +c + return + end +c +c ################################################################### +c subroutine innov_qc +c ################################################################### +c + subroutine innov_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s,amiss, + $ c_qc,knt,io8,l_init,l_innov_miss) +c +c Compute distribution of innovations +c + implicit none +c +c Work arrays +c ----------- + integer io8 ! i/o unit number for log file + $, knt ! counter for first or second time innov_qc is called + integer ii,nn,iob ! do loop indices + integer n_xiv ! computed innovation (integer) + integer max_reps ! maximum number of observations allowed + integer numreps ! actual number of reports + real amiss ! missing value flag (real) + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer knt_t(2) ! number of non-rejected temperature innovations + $, knt_d(2) ! number of non-rejected wind direction innovations + $, knt_s(2) ! number of non-rejected wind speed innovations + integer k_t(104,2) ! distribution of temperature innovations + $, k_d(40,2) ! distribution of wind direction innovations + $, k_s(104,2) ! distribution of wind speed innovations + integer indx(max_reps) ! pointer index for reports +c + character*11 c_qc(max_reps) ! qc flags +c + logical l_init ! initialize variables if true + $, l_innov_miss ! true if all innovations missing +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + l_innov_miss = .true. +c +c Initialize histogram arrays +c --------------------------- + if(l_init) then + k_t(:,knt) = 0 +c + k_d(:,knt) = 0 +c + k_s(:,knt) = 0 +c + knt_t(knt) = 0 + knt_d(knt) = 0 + knt_s(knt) = 0 + endif +c +c Loop over reports +c ----------------- + do iob=1,numreps + ii = indx(iob) +c + nn = nint(xiv_t(ii)) + 52 + if(nn.eq.43) then + write(io8,*) + write(io8,*) 'Temperature innovation = -9 for ii = ',ii + write(io8,*) ' xiv_t = ',xiv_t(ii) + endif +c +c Count distribution of temperature innovations +c --------------------------------------------- + if(c_qc(ii)(6:6).ne.'B'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I'.and. + $ c_qc(ii)(6:6).ne.'K'.and. + $ c_qc(ii)(6:6).ne.'b') then +c + knt_t(knt) = knt_t(knt) + 1 + nn = nint(xiv_t(ii)) + 52 +c + if(xiv_t(ii).eq.amiss) then + k_t(104,knt) = k_t(104,knt) + 1 + elseif(xiv_t(ii).lt.-50.) then + k_t(1,knt) = k_t(1,knt) + 1 + elseif(xiv_t(ii).gt.50.) then + k_t(103,knt) = k_t(103,knt) + 1 + else + k_t(nn,knt) = k_t(nn,knt) + 1 + endif + endif +c +c Count distribution of wind direction innovations +c ------------------------------------------------ + if(c_qc(ii)(7:7).ne.'S'.and. + $ c_qc(ii)(7:7).ne.'E'.and. + $ c_qc(ii)(7:7).ne.'K'.and. + $ c_qc(ii)(7:7).ne.'B'.and. + $ c_qc(ii)(7:7).ne.'I') then +c + knt_d(knt) = knt_d(knt) + 1 + nn = nint(xiv_d(ii)/10.) + 20 +c + if(xiv_d(ii).eq.amiss) then + k_d(40,knt) = k_d(40,knt) + 1 + elseif(xiv_d(ii).lt.-180.) then + k_d(1,knt) = k_d(1,knt) + 1 + elseif(xiv_d(ii).gt.180.) then + k_d(39,knt) = k_d(39,knt) + 1 + else + k_d(nn,knt) = k_d(nn,knt) + 1 + endif + endif +c +c Count distribution of wind speed innovations +c -------------------------------------------- + if(c_qc(ii)(8:8).ne.'S'.and. + $ c_qc(ii)(8:8).ne.'E'.and. + $ c_qc(ii)(8:8).ne.'K'.and. + $ c_qc(ii)(8:8).ne.'B'.and. + $ c_qc(ii)(8:8).ne.'A'.and. + $ c_qc(ii)(8:8).ne.'I') then +c + knt_s(knt) = knt_s(knt) + 1 + nn = nint(xiv_s(ii)) + 52 +c + if(xiv_s(ii).eq.amiss) then + k_s(104,knt) = k_s(104,knt) + 1 + elseif(xiv_s(ii).lt.-50.) then + k_s(1,knt) = k_s(1,knt) + 1 + elseif(xiv_s(ii).gt.50.) then + k_s(103,knt) = k_s(103,knt) + 1 + else + k_s(nn,knt) = k_s(nn,knt) + 1 + endif + endif +c + enddo +c +c Output distribution of temperature innovations if non-missing values present +c ---------------------------------------------------------------------------- + if(knt_t(knt).gt.k_t(104,knt)) then +c + l_innov_miss = .false. +c + write(io8,*) + write(io8,*) 'Distribution of Temperature Innovations (K)' + write(io8,*) '-------------------------------------------' + if(k_t(1,knt).gt.0) write(io8,*) ' < -50 ',k_t(1,knt) +c + do nn=2,102 + n_xiv = nn - 52 + if(k_t(nn,knt).gt.0) write(io8,*) n_xiv, k_t(nn,knt) + enddo +c + if(k_t(103,knt).gt.0) write(io8,*) ' > 50 ',k_t(103,knt) + if(k_t(104,knt).gt.0) write(io8,*) ' missing',k_t(104,knt) +c + else + write(io8,*) + write(io8,*) 'All temperature innovations missing' + endif +c +c Output distribution of wind direction innovations +c ------------------------------------------------- + if(knt_d(knt).gt.k_d(40,knt)) then +c + l_innov_miss = .false. +c + write(io8,*) + write(io8,*) 'Distribution of Wind Direction Innovations' + write(io8,*) '------------------------------------------' + if(k_d(1,knt).gt.0) write(io8,*) ' < -180 ',k_d(1,knt) +c + do nn=2,38 + n_xiv = (nn - 20) * 10 + if(k_d(nn,knt).gt.0) write(io8,*) n_xiv, k_d(nn,knt) + enddo +c + if(k_d(39,knt).gt.0) write(io8,*) ' > 180 ',k_d(39,knt) + if(k_d(40,knt).gt.0) write(io8,*) ' missing',k_d(40,knt) +c + else + write(io8,*) + write(io8,*) 'All wind direction innovations missing' + endif +c +c Output distribution of wind speed innovations +c --------------------------------------------- + if(knt_s(knt).gt.k_s(104,knt)) then +c + l_innov_miss = .false. +c + write(io8,*) + write(io8,*) 'Distribution of Wind Speed Innovations (m/s)' + write(io8,*) '--------------------------------------------' + if(k_s(1,knt).gt.0) write(io8,*) ' < -50 ',k_s(1,knt) +c + do nn=2,102 + n_xiv = nn - 52 + if(k_s(nn,knt).gt.0) write(io8,*) n_xiv, k_s(nn,knt) + enddo +c + if(k_s(103,knt).gt.0) write(io8,*) ' > 50 ',k_s(103,knt) + if(k_s(104,knt).gt.0) write(io8,*) ' missing',k_s(104,knt) +c + else + write(io8,*) + write(io8,*) 'All wind speed innovations missing' + endif +c + return + end +c +c ################################################################### +c subroutine benford_qc +c ################################################################### +c + subroutine benford_qc(max_reps,numreps,indx,xiv_t,xiv_d,xiv_s, + $ amiss,c_acftreg,itype,maxflt,kreg_tot,creg_reg_tot, + $ c_qc,lead_t_tot,lead_d_tot,lead_s_tot, + $ n_xiv_t,n_xiv_d,n_xiv_s, + $ sum_xiv_t,sum_xiv_d,sum_xiv_s, + $ sumabs_xiv_t,sumabs_xiv_d,sumabs_xiv_s,knt,io8 + $, l_init,l_last) +c +c Compute leading digit distributions to compare with Benford's law +c + implicit none +c +c Work arrays +c ----------- + integer io8 ! i/o unit number for log file + integer ii,jj,mm,iob,nid ! do loop indices + integer max_reps ! maximum number of observations allowed + integer numreps ! actual number of reports + $, lead ! value of leading digit + integer indx(max_reps) ! pointer index for reports + real amiss ! missing value flag (real) + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer itype(max_reps) ! type of aircraft data + character*8 c_acftreg(max_reps) ! tail numbers +c + character*11 c_qc(max_reps) ! qc flags +c + integer maxflt ! maximum number of tail numbers + $, kreg_tot ! number of unique tail numbers + $, knt ! counter for first or second time benford is called + $, ktype ! instrument type + character*8 creg_reg_tot(maxflt) ! master list of tail numbers + integer lead_t_tot(maxflt,11,2) ! distribution of temperature innovation leading digits + $, lead_d_tot(maxflt,11,2) ! distribution of wind direction innovation leading digits + $, lead_s_tot(maxflt,11,2) ! distribution of wind speed innovation leading digits + $, lead_t_sum(11,2) ! overall distribution of temperature innovations + $, lead_d_sum(11,2) ! overall distribution of wind direction innovations + $, lead_s_sum(11,2) ! overall distribution of wind speed innovations + $, lead_t_typ(5,11,2) ! distribution of temperature innovations by instrument type + $, lead_d_typ(5,11,2) ! distribution of wind direction innovations by instrument type + $, lead_s_typ(5,11,2) ! distribution of wind speed innovations by instrument type + $, lead_t_reg(33,11,2) ! distribution of temperature innovations by tail number group + $, lead_d_reg(33,11,2) ! distribution of wind direction innovations by tail number group + $, lead_s_reg(33,11,2) ! distribution of wind speed innovations by tail number group + $, n_xiv_t(maxflt,2) ! number of temperature innovations + $, n_xiv_d(maxflt,2) ! number of wind direction innovations + $, n_xiv_s(maxflt,2) ! number of wind speed innovations + $, ntot_xiv_t(2) ! total number of temperature innovations + $, ntot_xiv_d(2) ! total number of wind direction innovations + $, ntot_xiv_s(2) ! total number of wind speed innovations + $, ntyp_xiv_t(5,2) ! number of temperature innovations by instrument type + $, ntyp_xiv_d(5,2) ! number of wind direction innovations by instrument type + $, ntyp_xiv_s(5,2) ! number of wind speed innovations by instrument type + $, ntot_t_reg(33,2) ! total number of innovations by tail number type + $, ntot_d_reg(33,2) ! total number of innovations by tail number type + $, ntot_s_reg(33,2) ! total number of innovations by tail number type + real sum_xiv_t(maxflt,2) ! sum of temperature innovations + $, sum_xiv_d(maxflt,2) ! sum of wind direction innovations + $, sum_xiv_s(maxflt,2) ! sum of wind speed innovations + $, sumabs_xiv_t(maxflt,2) ! sum of absolute value of temperature innovations + $, sumabs_xiv_d(maxflt,2) ! sum of absolute value of wind direction innovations + $, sumabs_xiv_s(maxflt,2) ! sum of absolute value of wind speed innovations + $, avg ! average innovation + $, avgabs ! absolute average innovation + $, avg_lead(11) ! average number of innovations per leading digit +c + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c + character*12 c_lead ! character form of xiv + character*8 c_label(5) ! label for output + character*2 c_reg_list(33) ! Tail number ids used to summarize stats + logical l_init ! initialize variables if true + $, l_last ! true if last time subroutine is called +c +ccccdak data c_label/'MDCRS ','ACARS ','AMDAR ', + data c_label/'MDCRS ','TAMDAR ','AMDAR ', + $ 'AIREP ','manAIREP'/ +c + data c_reg_list/'AN','AR','BA','EU','IT','KL','LH','MK','NZ','QF' + $, 'SA','SK','SV' + $, '13','L3','IC','YC','0I','EI','KI','UI','2M','IR' + $, 'YR','AS','JT','AU','GU','WU','FV','QV','VV','YW'/ +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize leading digit arrays +c ------------------------------- + if(l_init) then + ntot_xiv_t(1) = 0 + ntot_xiv_d(1) = 0 + ntot_xiv_s(1) = 0 + ntot_xiv_t(2) = 0 + ntot_xiv_d(2) = 0 + ntot_xiv_s(2) = 0 +c + sum_xiv_t(1:kreg_tot,:) = 0.0 + sum_xiv_d(1:kreg_tot,:) = 0.0 + sum_xiv_s(1:kreg_tot,:) = 0.0 + sumabs_xiv_t(1:kreg_tot,:) = 0.0 + sumabs_xiv_d(1:kreg_tot,:) = 0.0 + sumabs_xiv_s(1:kreg_tot,:) = 0.0 + n_xiv_t(1:kreg_tot,:) = 0 + n_xiv_d(1:kreg_tot,:) = 0 + n_xiv_s(1:kreg_tot,:) = 0 +c + lead_t_tot(1:kreg_tot,:,:) = 0 + lead_d_tot(1:kreg_tot,:,:) = 0 + lead_s_tot(1:kreg_tot,:,:) = 0 +c + lead_t_sum = 0 + lead_d_sum = 0 + lead_s_sum = 0 +c + lead_t_reg = 0 + lead_d_reg = 0 + lead_s_reg = 0 + lead_t_typ = 0 + lead_d_typ = 0 + lead_s_typ = 0 + ntot_t_reg = 0 + ntot_d_reg = 0 + ntot_s_reg = 0 + ntyp_xiv_t = 0 + ntyp_xiv_d = 0 + ntyp_xiv_s = 0 + + endif +c +c Loop over reports +c ----------------- + do iob=1,numreps + ii = indx(iob) +c +c Determine the instrument type +c ----------------------------- + if(itype(ii).eq.insty_ob_fun('mdcrs').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_lvl').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_asc').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_des')) then + ktype = 1 +c + elseif(itype(ii).eq.insty_ob_fun('acars').or. + $ itype(ii).eq.insty_ob_fun('acars_lvl').or. + $ itype(ii).eq.insty_ob_fun('acars_asc').or. + $ itype(ii).eq.insty_ob_fun('acars_des')) then + ktype = 2 +c + elseif(itype(ii).eq.insty_ob_fun('amdar').or. + $ itype(ii).eq.insty_ob_fun('amdar_lvl').or. + $ itype(ii).eq.insty_ob_fun('amdar_asc').or. + $ itype(ii).eq.insty_ob_fun('amdar_des')) then + ktype = 3 +c + elseif(itype(ii).eq.insty_ob_fun('airep').or. + $ itype(ii).eq.insty_ob_fun('airep_lvl').or. + $ itype(ii).eq.insty_ob_fun('airep_asc').or. + $ itype(ii).eq.insty_ob_fun('airep_des')) then + ktype = 4 +c + elseif(itype(ii).eq.insty_ob_fun('man-airep').or. + $ itype(ii).eq.insty_ob_fun('man-Yairep')) then + ktype = 5 + endif +c +c Find this tail number in the master list +c ---------------------------------------- + do mm=1,kreg_tot +c + if(c_acftreg(ii)(1:8).eq.creg_reg_tot(mm)(1:8)) then +c write(io8,*) +c write(io8,*) 'Tail number found in master list at mm = ',mm +c +c Compute leading digit distribution for temperature innovations +c -------------------------------------------------------------- + if(c_qc(ii)(6:6).ne.'B'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I'.and. + $ c_qc(ii)(6:6).ne.'K'.and. + $ c_qc(ii)(6:6).ne.'b') then +c + if(xiv_t(ii).eq.amiss) then + lead = 11 + elseif(xiv_t(ii).eq.0.0) then + lead = 10 + else + write(c_lead,'(e12.5)') xiv_t(ii) + if(c_lead(2:2).eq.' '.or. + $ c_lead(2:2).eq.'0'.or. + $ c_lead(2:2).eq.'-') then + lead = ichar(c_lead(4:4)) - 48 + else + lead = ichar(c_lead(2:2)) - 48 + write(io8,*) '?',xiv_t(ii),c_lead,lead + endif + endif +c +c write(io8,*) ' ii = ',ii,' mm = ',mm +c write(io8,*) ' xiv_t = ',xiv_t(ii),' lead = ',lead +c + lead_t_tot(mm,lead,knt) = lead_t_tot(mm,lead,knt) + 1 + lead_t_sum(lead,knt) = lead_t_sum(lead,knt) + 1 + lead_t_typ(ktype,lead,knt) = + $ lead_t_typ(ktype,lead,knt) + 1 +c + if(itype(ii).eq.insty_ob_fun('amdar').or. + $ itype(ii).eq.insty_ob_fun('amdar_lvl').or. + $ itype(ii).eq.insty_ob_fun('amdar_asc').or. + $ itype(ii).eq.insty_ob_fun('amdar_des')) then +c + nid = 1 + do while(nid.le.13) + if(c_acftreg(ii)(1:2).eq.c_reg_list(nid)(1:2)) then + lead_t_reg(nid,lead,knt) = + $ lead_t_reg(nid,lead,knt)+1 + if(lead.ne.11) + $ ntot_t_reg(nid,knt) = ntot_t_reg(nid,knt) + 1 + nid = 14 + else + nid = nid + 1 + endif + enddo +c + elseif(itype(ii).eq.insty_ob_fun('mdcrs').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_lvl').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_asc').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_des').or. + $ itype(ii).eq.insty_ob_fun('acars').or. + $ itype(ii).eq.insty_ob_fun('acars_lvl').or. + $ itype(ii).eq.insty_ob_fun('acars_asc').or. + $ itype(ii).eq.insty_ob_fun('acars_des')) then +c + nid = 14 + do while(nid.le.33) + if(c_acftreg(ii)(4:5).eq.c_reg_list(nid)(1:2)) then + lead_t_reg(nid,lead,knt) = + $ lead_t_reg(nid,lead,knt) + 1 + if(lead.ne.11) + $ ntot_t_reg(nid,knt) = ntot_t_reg(nid,knt) + 1 + nid = 34 + else + nid = nid + 1 + endif + enddo + endif +c + if(lead.ne.11) then + sum_xiv_t(mm,knt) = sum_xiv_t(mm,knt) + xiv_t(ii) + sumabs_xiv_t(mm,knt) = sumabs_xiv_t(mm,knt) + $ + abs(xiv_t(ii)) + n_xiv_t(mm,knt) = n_xiv_t(mm,knt) + 1 + ntot_xiv_t(knt) = ntot_xiv_t(knt) + 1 + ntyp_xiv_t(ktype,knt) = ntyp_xiv_t(ktype,knt) + 1 + endif +c +c write(io8,*) 'lead_t_tot = ',(lead_t_tot(mm,jj,knt),jj=1,11) +c + endif +c +c +c Compute leading digit distribution for wind direction innovations +c ----------------------------------------------------------------- + if(c_qc(ii)(7:7).ne.'S'.and. + $ c_qc(ii)(7:7).ne.'E'.and. + $ c_qc(ii)(7:7).ne.'K'.and. + $ c_qc(ii)(7:7).ne.'B'.and. + $ c_qc(ii)(7:7).ne.'I') then +c + if(xiv_d(ii).eq.amiss) then + lead = 11 + elseif(xiv_d(ii).eq.0.0) then + lead = 10 + else + write(c_lead,'(e12.5)') xiv_d(ii) + if(c_lead(2:2).eq.' '.or. + $ c_lead(2:2).eq.'0'.or. + $ c_lead(2:2).eq.'-') then + lead = ichar(c_lead(4:4)) - 48 + else + lead = ichar(c_lead(2:2)) - 48 + write(io8,*) '?',xiv_d(ii),c_lead,lead + endif + endif +c +c write(io8,*) 'ii = ',ii,' mm = ',mm +c write(io8,*) 'xiv_d = ',xiv_d(ii),' lead = ',lead +c + lead_d_tot(mm,lead,knt) = lead_d_tot(mm,lead,knt) + 1 + lead_d_sum(lead,knt) = lead_d_sum(lead,knt) + 1 + lead_d_typ(ktype,lead,knt) = + $ lead_d_typ(ktype,lead,knt) + 1 +c + if(itype(ii).eq.insty_ob_fun('amdar').or. + $ itype(ii).eq.insty_ob_fun('amdar_lvl').or. + $ itype(ii).eq.insty_ob_fun('amdar_asc').or. + $ itype(ii).eq.insty_ob_fun('amdar_des')) then +c + nid = 1 + do while(nid.le.13) + if(c_acftreg(ii)(1:2).eq.c_reg_list(nid)(1:2)) then + lead_d_reg(nid,lead,knt) = + $ lead_d_reg(nid,lead,knt) + 1 + if(lead.ne.11) + $ ntot_d_reg(nid,knt) = ntot_d_reg(nid,knt) + 1 + nid = 14 + else + nid = nid + 1 + endif + enddo +c + elseif(itype(ii).eq.insty_ob_fun('mdcrs').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_lvl').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_asc').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_des').or. + $ itype(ii).eq.insty_ob_fun('acars').or. + $ itype(ii).eq.insty_ob_fun('acars_lvl').or. + $ itype(ii).eq.insty_ob_fun('acars_asc').or. + $ itype(ii).eq.insty_ob_fun('acars_des')) then +c + nid = 14 + do while(nid.le.33) + if(c_acftreg(ii)(4:5).eq.c_reg_list(nid)(1:2)) then + lead_d_reg(nid,lead,knt) = + $ lead_d_reg(nid,lead,knt) + 1 + if(lead.ne.11) + $ ntot_d_reg(nid,knt) = ntot_d_reg(nid,knt) + 1 + nid = 34 + else + nid = nid + 1 + endif + enddo + endif +c + if(lead.ne.11) then + sum_xiv_d(mm,knt) = sum_xiv_d(mm,knt) + xiv_d(ii) + sumabs_xiv_d(mm,knt) = sumabs_xiv_d(mm,knt) + $ + abs(xiv_d(ii)) + n_xiv_d(mm,knt) = n_xiv_d(mm,knt) + 1 + ntot_xiv_d(knt) = ntot_xiv_d(knt) + 1 + ntyp_xiv_d(ktype,knt) = ntyp_xiv_d(ktype,knt) + 1 + endif +c +c write(io8,*) 'lead_d_tot = ',(lead_d_tot(mm,jj,knt),jj=1,11) +c + endif +c +c Compute leading digit distribution for wind speed innovations +c ------------------------------------------------------------- + if(c_qc(ii)(8:8).ne.'S'.and. + $ c_qc(ii)(8:8).ne.'E'.and. + $ c_qc(ii)(8:8).ne.'K'.and. + $ c_qc(ii)(8:8).ne.'B'.and. + $ c_qc(ii)(8:8).ne.'A'.and. + $ c_qc(ii)(8:8).ne.'I') then +c + if(xiv_s(ii).eq.amiss) then + lead = 11 + elseif(xiv_s(ii).eq.0.0) then + lead = 10 + else + write(c_lead,'(e12.5)') xiv_s(ii) + if(c_lead(2:2).eq.' '.or. + $ c_lead(2:2).eq.'0'.or. + $ c_lead(2:2).eq.'-') then + lead = ichar(c_lead(4:4)) - 48 + else + lead = ichar(c_lead(2:2)) - 48 + write(io8,*) '?',xiv_s(ii),c_lead,lead + endif + endif +c +c write(io8,*) 'ii = ',ii,' mm = ',mm +c write(io8,*) 'xiv_s = ',xiv_s(ii),' lead = ',lead +c + lead_s_tot(mm,lead,knt) = lead_s_tot(mm,lead,knt) + 1 + lead_s_sum(lead,knt) = lead_s_sum(lead,knt) + 1 + lead_s_typ(ktype,lead,knt) = + $ lead_s_typ(ktype,lead,knt) + 1 +c + if(itype(ii).eq.insty_ob_fun('amdar').or. + $ itype(ii).eq.insty_ob_fun('amdar_lvl').or. + $ itype(ii).eq.insty_ob_fun('amdar_asc').or. + $ itype(ii).eq.insty_ob_fun('amdar_des')) then +c + nid = 1 + do while(nid.le.13) + if(c_acftreg(ii)(1:2).eq.c_reg_list(nid)(1:2)) then + lead_s_reg(nid,lead,knt) = + $ lead_s_reg(nid,lead,knt) + 1 + if(lead.ne.11) + $ ntot_s_reg(nid,knt) = ntot_s_reg(nid,knt) + 1 + nid = 14 + else + nid = nid + 1 + endif + enddo +c + elseif(itype(ii).eq.insty_ob_fun('mdcrs').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_lvl').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_asc').or. + $ itype(ii).eq.insty_ob_fun('mdcrs_des').or. + $ itype(ii).eq.insty_ob_fun('acars').or. + $ itype(ii).eq.insty_ob_fun('acars_lvl').or. + $ itype(ii).eq.insty_ob_fun('acars_asc').or. + $ itype(ii).eq.insty_ob_fun('acars_des')) then +c + nid = 14 + do while(nid.le.33) + if(c_acftreg(ii)(4:5).eq.c_reg_list(nid)(1:2)) then + lead_s_reg(nid,lead,knt) = + $ lead_s_reg(nid,lead,knt) + 1 + if(lead.ne.11) + $ ntot_s_reg(nid,knt) = ntot_s_reg(nid,knt) + 1 + nid = 34 + else + nid = nid + 1 + endif + enddo + endif +c + if(lead.ne.11) then + sum_xiv_s(mm,knt) = sum_xiv_s(mm,knt) + xiv_s(ii) + sumabs_xiv_s(mm,knt) = sumabs_xiv_s(mm,knt) + $ + abs(xiv_s(ii)) + n_xiv_s(mm,knt) = n_xiv_s(mm,knt) + 1 + ntot_xiv_s(knt) = ntot_xiv_s(knt) + 1 + ntyp_xiv_s(ktype,knt) = ntyp_xiv_s(ktype,knt) + 1 + endif +c +c write(io8,*) 'lead_s_tot = ',(lead_s_tot(mm,jj,knt),jj=1,11) +c + endif + endif + enddo + enddo +c +c Output results +c -------------- + if(l_last) then + write(io8,*) + write(io8,*) 'Temperature statistics' + write(io8,*) '----------------------' + write(io8,'('' leading digit distribution'')') + write(io8,'('' Tail# 1 2 3 4 5 6 '' + $, '' 7 8 9 0 amiss tot avg avgabs'')') + write(io8,'(''--------------------------------------------------'' + $, ''-----------------------------------------------'')') + +c + do mm=1,kreg_tot + if(n_xiv_t(mm,knt).ne.0) then + if(sum_xiv_t(mm,knt).ne.0.0) then + avg = sum_xiv_t(mm,knt) / float(n_xiv_t(mm,knt)) + else + avg = 0.0 + endif + if(sumabs_xiv_t(mm,knt).ne.0.0) then + avgabs = sumabs_xiv_t(mm,knt) / float(n_xiv_t(mm,knt)) + else + avgabs = 0.0 + endif + avg_lead = float(lead_t_tot(mm,:,knt)) + $ / float(n_xiv_t(mm,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7,2f7.2)') + $ creg_reg_tot(mm),(lead_t_tot(mm,lead,knt),lead=1,11), + $ n_xiv_t(mm,knt),avg,avgabs + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do jj=1,33 + if(ntot_t_reg(jj,knt).ne.0) then + avg_lead = float(lead_t_reg(jj,:,knt)) + $ / float(ntot_t_reg(jj,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_reg_list(jj),(lead_t_reg(jj,lead,knt),lead=1,11), + $ ntot_t_reg(jj,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do ktype=1,5 + if(ntyp_xiv_t(ktype,knt).ne.0) then + avg_lead = float(lead_t_typ(ktype,:,knt)) + $ / float(ntyp_xiv_t(ktype,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_label(ktype),(lead_t_typ(ktype,lead,knt),lead=1,11), + $ ntyp_xiv_t(ktype,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + if(ntot_xiv_t(knt).ne.0) then + avg_lead = float(lead_t_sum(:,knt)) + $ / float(ntot_xiv_t(knt)) * 100.0 +c + write(io8,'(1x,''Overall '',1x,11i6,i7)') + $ (lead_t_sum(lead,knt),lead=1,11), + $ ntot_xiv_t(knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif +c + write(io8,*) + write(io8,*) 'Wind direction statistics' + write(io8,*) '-------------------------' + write(io8,'('' leading digit distribution'')') + write(io8,'('' Tail# 1 2 3 4 5 6 '' + $, '' 7 8 9 0 amiss tot avg avgabs'')') + write(io8,'(''--------------------------------------------------'' + $, ''-----------------------------------------------'')') +c + do mm=1,kreg_tot + if(n_xiv_d(mm,knt).ne.0) then + if(sum_xiv_d(mm,knt).ne.0.0) then + avg = sum_xiv_d(mm,knt) / float(n_xiv_d(mm,knt)) + else + avg = 0.0 + endif + if(sumabs_xiv_d(mm,knt).ne.0.0) then + avgabs = sumabs_xiv_d(mm,knt) / float(n_xiv_d(mm,knt)) + else + avgabs = 0.0 + endif + avg_lead = float(lead_d_tot(mm,:,knt)) + $ / float(n_xiv_d(mm,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7,2f7.2)') + $ creg_reg_tot(mm),(lead_d_tot(mm,lead,knt),lead=1,11), + $ n_xiv_d(mm,knt),avg,avgabs + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do jj=1,33 + if(ntot_d_reg(jj,knt).ne.0) then + avg_lead = float(lead_d_reg(jj,:,knt)) + $ / float(ntot_d_reg(jj,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_reg_list(jj),(lead_d_reg(jj,lead,knt),lead=1,11), + $ ntot_d_reg(jj,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do ktype=1,5 + if(ntyp_xiv_d(ktype,knt).ne.0) then + avg_lead = float(lead_d_typ(ktype,:,knt)) + $ / float(ntyp_xiv_d(ktype,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_label(ktype),(lead_d_typ(ktype,lead,knt),lead=1,11), + $ ntyp_xiv_d(ktype,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + if(ntot_xiv_d(knt).ne.0) then + avg_lead = float(lead_d_sum(:,knt)) + $ / float(ntot_xiv_d(knt)) * 100.0 +c + write(io8,'(1x,''Overall '',1x,11i6,i7)') + $ (lead_d_sum(lead,knt),lead=1,11), + $ ntot_xiv_d(knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif +c + write(io8,*) + write(io8,*) 'Wind speed statistics' + write(io8,*) '---------------------' + write(io8,'('' leading digit distribution'')') + write(io8,'('' Tail# 1 2 3 4 5 6 '' + $, '' 7 8 9 0 amiss tot avg avgabs'')') + write(io8,'(''--------------------------------------------------'' + $, ''-----------------------------------------------'')') +c + do mm=1,kreg_tot + if(n_xiv_s(mm,knt).ne.0) then + if(sum_xiv_s(mm,knt).ne.0.0) then + avg = sum_xiv_s(mm,knt) / float(n_xiv_s(mm,knt)) + else + avg = 0.0 + endif + if(sumabs_xiv_s(mm,knt).ne.0.0) then + avgabs = sumabs_xiv_s(mm,knt) / float(n_xiv_s(mm,knt)) + else + avgabs = 0.0 + endif + avg_lead = float(lead_s_tot(mm,:,knt)) + $ / float(n_xiv_s(mm,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7,2f7.2)') + $ creg_reg_tot(mm),(lead_s_tot(mm,lead,knt),lead=1,11), + $ n_xiv_s(mm,knt),avg,avgabs + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do jj=1,33 + if(ntot_s_reg(jj,knt).ne.0) then + avg_lead = float(lead_s_reg(jj,:,knt)) + $ / float(ntot_s_reg(jj,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_reg_list(jj),(lead_s_reg(jj,lead,knt),lead=1,11), + $ ntot_s_reg(jj,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + do ktype=1,5 + if(ntyp_xiv_s(ktype,knt).ne.0) then + avg_lead = float(lead_s_typ(ktype,:,knt)) + $ / float(ntyp_xiv_s(ktype,knt)) * 100.0 +c + write(io8,'(1x,a8,1x,11i6,i7)') + $ c_label(ktype),(lead_s_typ(ktype,lead,knt),lead=1,11), + $ ntyp_xiv_s(ktype,knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + enddo +c + write(io8,*) + if(ntot_xiv_s(knt).ne.0) then + avg_lead = float(lead_s_sum(:,knt)) + $ / float(ntot_xiv_s(knt)) * 100.0 +c + write(io8,'(1x,''Overall '',1x,11i6,i7)') + $ (lead_s_sum(lead,knt),lead=1,11), + $ ntot_xiv_s(knt) + write(io8,'(1x,8x,1x,11f6.1)') (avg_lead(lead),lead=1,11) + endif + endif +c + return + end +c +c ################################################################### +c subroutine invalid_qc +c ################################################################### +c + subroutine invalid_qc(numreps,max_reps,c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s,maxflt,kreg,creg_reg,ntemp_reg + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s,kbadtot,n_minus9C + $, indx,csort,amiss,imiss,io8,io32,l_operational,l_init + $, cdtg_an,l_minus9c) +c +c Remove invalid data from dataset +c +c modified 5/18/01 by p.m.pauley-- -9c test refined +c modified 6/28/01 by p.m.pauley--test added for direction=360 +c some aircraft report 360 when they should report 180 +c modified 1/8/03 by P.M.Pauley--added check for truncated German +c AMDAR reports--these seem to have blank tail numbers, which +c the code changes to 'LH ' (which the test looks for) +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + character*10 cdtg_an ! date time group for analysis + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + $, ktype ! pointer for instrument type + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable + logical l_minus9c(max_reps) ! true for mdcrs -9C temperatures +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io32 ! i/o unit number for rejected reports +c + integer imiss ! integer missing value flag + real amiss ! real missing value flag +c + integer iob ! do loop index + $, ii ! index pointing to current report + $, iim2 ! index pointing to report before previous report + $, iim1 ! index pointing to previous report + $, iip1 ! index pointing to following report + $, iip2 ! index pointing to report after following report + $, kbadtot ! total number of rejected duplicates + $, kbad(5) ! counter for number of invalid reports +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c + integer n_empty(5) ! number of empty reports + $, n_zero_tmp(5) ! number of reports with zero winds and temperature + $, n_zero_alt(5) ! number of reports with zero winds and altitude + $, n_zero_pos(5) ! number of reports with zero lat/lon + $, n_bad_decode(5) ! number of reports with bad decodes + $, n_miss_time(5) ! number of reports with missing times + $, n_miss_pos(5) ! number of reports with missing positions + $, n_miss_pres(5) ! number of reports with missing pressures + $, n_small_pres(5) ! number of reports with too small pressures + $, n_low_airep(5) ! number of low-level aireps rejected + ! (sign on altitude is ambiguous) + $, n_minus9C(5) ! number of -9C temperatures rejected + $, n_bad360(5) ! number of erroneous north winds + $, n_bad180(5) ! number of erroneous south winds +c + integer n_xx999_Ar ! number of aireps with missing id + $, n_xx999_Ma ! number of manual aireps with missing id + integer n_blank_Ar ! number of aireps with blank id + $, n_blank_Ma ! number of manual aireps with blank id + $, n_blank_Md ! number of MDCRS reports with blank id + $, n_blank_Am ! number of AMDAR reports with blank id +c +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak $, nbad_Ac ! number of bad acars + $, nbad_Ac ! number of bad tamdar + $, nbad_Md ! number of bad mdcrs + $, nbad_Ma ! number of bad manual aireps + $, nbad_Ar ! number of bad aireps + $, nbad_Am ! number of bad amdar +c + integer maxflt ! max number of flights allowed + integer kreg ! actual number of tail#s in dataset + $, mm ! index pointing to current tail number + character*8 creg_reg(maxflt) ! tail numbers + integer ntemp_reg(maxflt,5) ! number of reports w. rejected temp +c + integer knt ! counter used in defining iim1, iip1 +c +c Switches +c -------- + logical l_print ! print values if true + $, l_operational ! run QC in operational mode if true + $, l_init ! initialize counters if true +c $, l_ual_all ! true if all remapped ids are UAL acft +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + n_empty = 0 + n_zero_tmp = 0 + n_zero_alt = 0 + n_zero_pos = 0 + n_bad_decode = 0 + n_miss_time = 0 + n_miss_pos = 0 + n_miss_pres = 0 + n_small_pres = 0 + n_low_airep = 0 + n_minus9C = 0 + n_bad360 = 0 + n_bad180 = 0 +c + n_xx999_Ar = 0 + n_xx999_Ma = 0 + n_blank_Ar = 0 + n_blank_Ma = 0 + n_blank_Md = 0 + n_blank_Am = 0 +c + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nbad_Ac = 0 + nbad_Md = 0 + nbad_Ma = 0 + nbad_Ar = 0 + nbad_Am = 0 + endif +c +c Begin loop over reports +c ----------------------- + do iob = 1,numreps +c + l_print = .false. +c +c Compute ii index +c ---------------- + ii = indx(iob) +c +c Compute ii-1 index +c ------------------ + knt = iob - 1 + 10 if(knt.ge.1) then + iim1 = indx(knt) + if(c_qc(iim1)(1:1).eq.'B'.or. + $ c_qc(iim1)(3:4).eq.'BB'.or. + $ c_qc(iim1)(2:2).eq.'M'.or. + $ c_qc(iim1)(3:3).eq.'M'.or. + $ c_qc(iim1)(4:4).eq.'M'.or. + $ c_qc(iim1)(5:5).eq.'M'.or. + $ c_qc(iim1)(5:5).eq.'B'.or. + $ c_qc(iim1)(6:6).eq.'B'.or. + $ c_qc(iim1)(7:7).eq.'B'.or. + $ c_qc(iim1)(6:8).eq.'MMM') then + knt = knt - 1 + goto 10 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c ------------------ + knt = knt - 1 + 15 if(knt.ge.1) then + iim2 = indx(knt) + if(c_qc(iim2)(1:1).eq.'B'.or. + $ c_qc(iim2)(3:4).eq.'BB'.or. + $ c_qc(iim2)(2:2).eq.'M'.or. + $ c_qc(iim2)(3:3).eq.'M'.or. + $ c_qc(iim2)(4:4).eq.'M'.or. + $ c_qc(iim2)(5:5).eq.'M'.or. + $ c_qc(iim2)(5:5).eq.'B'.or. + $ c_qc(iim2)(6:6).eq.'B'.or. + $ c_qc(iim2)(7:7).eq.'B'.or. + $ c_qc(iim2)(6:8).eq.'MMM') then + knt = knt - 1 + goto 15 + endif + else + iim2 = 0 + endif +c +c Compute ii+1 index +c ------------------ + knt = iob + 1 + 20 if(knt.le.numreps) then + iip1 = indx(knt) + if(c_qc(iip1)(1:1).eq.'B'.or. + $ c_qc(iip1)(3:4).eq.'BB'.or. + $ c_qc(iip1)(2:2).eq.'M'.or. + $ c_qc(iip1)(3:3).eq.'M'.or. + $ c_qc(iip1)(4:4).eq.'M'.or. + $ c_qc(iip1)(5:5).eq.'M'.or. + $ c_qc(iip1)(5:5).eq.'B'.or. + $ c_qc(iip1)(6:6).eq.'B'.or. + $ c_qc(iip1)(7:7).eq.'B'.or. + $ c_qc(iip1)(6:8).eq.'MMM') then + knt = knt + 1 + goto 20 + endif + else + iip1 = 0 + endif +c +c Compute ii+2 index +c ------------------ + knt = knt + 1 + 25 if(knt.le.numreps) then + iip2 = indx(knt) + if(c_qc(iip2)(1:1).eq.'B'.or. + $ c_qc(iip2)(3:4).eq.'BB'.or. + $ c_qc(iip2)(2:2).eq.'M'.or. + $ c_qc(iip2)(3:3).eq.'M'.or. + $ c_qc(iip2)(4:4).eq.'M'.or. + $ c_qc(iip2)(5:5).eq.'M'.or. + $ c_qc(iip2)(5:5).eq.'B'.or. + $ c_qc(iip2)(6:6).eq.'B'.or. + $ c_qc(iip2)(7:7).eq.'B'.or. + $ c_qc(iip2)(6:8).eq.'MMM') then + knt = knt + 1 + goto 25 + endif + else + iip2 = 0 + endif +c +c Set ktype +c --------- + if(itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des.or. + $ itype(ii).eq.i_airep) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c +c Count reports with missing ids +c ------------------------------ + if(c_acftid(ii)(1:5).eq.'XX999'.or. + $ c_acftid(ii)(1:4).eq.'////') then +c + c_qc(ii)(1:1) = 'B' +c + if(ktype.eq.4) then + n_xx999_Ar = n_xx999_Ar + 1 +c + elseif(ktype.eq.5) then + n_xx999_Ma = n_xx999_Ma + 1 + endif +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with missing id' + endif +c +c Count reports with blank ids +c ---------------------------- + +C DAK: Here is where TAMDAR reports were originally tossed for having a blank tail number due +c to logic in subroutine dupchek_qc that would not allow one to be generated (flight +c number was all numbers and tail number was originally missing, thus a tail number +c could not be created from the flight number) -- this has since been bypassed by +c changing characters 1-3 in in the flight number to "TAM" in subroutine input_acqc +c where the reports are read in from NCEP PREPBUFR file and stored in memory + + elseif(c_acftreg(ii)(1:8).eq.' ') then +c + c_qc(ii)(1:1) = 'B' +c + if(ktype.eq.1) then + n_blank_Md = n_blank_Md + 1 +c + elseif(ktype.eq.3) then + n_blank_Am = n_blank_Am + 1 +c + elseif(ktype.eq.4) then + n_blank_Ar = n_blank_Ar + 1 +c + elseif(ktype.eq.5) then + n_blank_Ma = n_blank_Ma + 1 + endif +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with blank tail number' + endif +c +c Look for truncated German AMDAR reports +c --------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.'LH '.and. + $ ktype.eq.3) then +c + c_qc(ii)(1:1) = 'B' + n_bad_decode(3) = n_bad_decode(3) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Truncated German AMDAR report' + endif +c +c Count reports marked bad in decoder +c ----------------------------------- + elseif(c_qc(ii)(1:1).eq.'B') then +c + n_bad_decode(ktype) = n_bad_decode(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report marked bad in decoder' + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c Check for zero position--lat/lon both zero +c ------------------------------------------ + elseif(abs(alat(ii)).lt.0.001.and. + $ abs(alon(ii)).lt.0.001) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + c_qc(ii)(3:4) = 'BB' +c + n_zero_pos(ktype) = n_zero_pos(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with zero lat and lon' + endif +c +c Check for missing time +c ---------------------- + elseif(idt(ii).eq.imiss) then +c + c_qc(ii)(2:2) = 'M' +c + n_miss_time(ktype) = n_miss_time(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with missing time' + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c Check for missing latitude/longitude +c ------------------------------------ + elseif(alat(ii).eq.amiss.or. + $ alon(ii).eq.amiss) then +c + if(alat(ii).eq.amiss) c_qc(ii)(3:3) = 'M' + if(alon(ii).eq.amiss) c_qc(ii)(4:4) = 'M' +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + n_miss_pos(ktype) = n_miss_pos(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with missing lat or lon' + endif +c +c Check for missing pressure/altitude +c ----------------------------------- + elseif(pres(ii).eq.amiss.and.ht_ft(ii).eq.amiss) then +c + c_qc(ii)(5:5) = 'M' +c + n_miss_pres(ktype) = n_miss_pres(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with missing pressure' + endif +c +c Check for too-small pressure (too-large altitude) +c Allow high altitude manual AIREPs from Concordes (BAW and AFR) +c -------------------------------------------------------------- + elseif(ht_ft(ii).gt.49999.5.or.pres(ii).lt.116.05) then + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ (c_acftid(ii)(1:3).eq.'AFR'.or. + $ c_acftid(ii)(1:3).eq.'BAW')) then +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Valid high-altitude report--ii = ',ii + endif +c + else + c_qc(ii)(5:5) = 'B' +c + n_small_pres(ktype) = n_small_pres(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Altitude is too high!' + endif + endif +c +c Check for low-level airep reports--altitude sign not known +c ---------------------------------------------------------- + elseif((itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ abs(ht_ft(ii)).lt.600.0) then +c + c_qc(ii)(5:5) = 'B' +c + n_low_airep(ktype) = n_low_airep(ktype) + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Low-altitude AIREP found' + endif +c +c Check for empty report--temperature and winds missing +c ----------------------------------------------------- + elseif(ob_t(ii).eq.amiss.and. + $ (ob_dir(ii).eq.amiss.or. + $ ob_spd(ii).eq.amiss)) then +c + c_qc(ii)(6:9) = 'MMMN' + if(ob_q(ii).eq.amiss) c_qc(ii)(9:9) = 'M' +c + n_empty(ktype) = n_empty(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with missing temperature, winds' + endif +c +c Check for empty report--temperature and winds zero +c -------------------------------------------------- + elseif(abs(ob_t(ii)-273.16).lt.0.05.and. + $ (ifix(ob_dir(ii)).eq.360.or.ifix(ob_dir(ii)).eq.0).and. + $ ifix(ob_spd(ii)*10.0).eq.0.and. + $ (itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep)) then +c + c_qc(ii)(6:9) = 'MMMN' + if(ob_q(ii).eq.amiss) c_qc(ii)(9:9) = 'M' +c + n_zero_tmp(ktype) = n_zero_tmp(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with zero C temperature, winds' + endif +c +c Check for empty report--altitude and winds zero +c ----------------------------------------------- + elseif(ifix(ht_ft(ii)).eq.0.and. + $ (ifix(ob_dir(ii)).eq.360.or.ifix(ob_dir(ii)).eq.0).and. + $ ifix(ob_spd(ii)).eq.0) then +c + c_qc(ii)(5:9) = 'BNMMN' + if(ob_q(ii).eq.amiss) c_qc(ii)(9:9) = 'M' +c + n_zero_alt(ktype) = n_zero_alt(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Report found with zero altitude, winds' + endif +c +c Perform checks on just temperature or wind direction +c ---------------------------------------------------- + else +c +c Check for -9C temperature, precision = 1.00, no phase indicated +c --------------------------------------------------------------- +c if(abs(ob_t(ii)-264.16).lt.0.05.and. + if(l_minus9c(ii)) then +c +c write(io8,*) +c write(io8,*) 'l_minus9c = T at iob,ii = ',iob,ii +c write(io8,*) ' t_prcn = ',t_prcn(ii) +c write(io8,*) ' itype = ',c_insty_ob(itype(ii)) +c write(io8,*) ' ht_ft = ',ht_ft(ii) +c write(io8,*) ' ids = ',c_acftreg(ii),c_acftid(ii) +c + if(ifix(t_prcn(ii)*100).eq.100.and. + $ itype(ii).eq.i_mdcrs) then +c + if(iob.eq.1) then + iim1 = 0 + else + iim1 = indx(iob-1) + endif +c + if(iob.eq.numreps) then + iip1 = 0 + else + iip1 = indx(iob+1) + endif +c +c Reject ob if -9C temperature exceeds gross check +c ------------------------------------------------ + if(ht_ft(ii).gt.30187.5) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'-9C temp would be rejected by gross chk!' + $, ' ii = ',ii + endif +c + if(c_qc(ii)(6:6).eq.'-') then + c_qc(ii)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c +c Perform other checks if previous ob available +c --------------------------------------------- + elseif(iim1.ne.0) then +c +c Reject ob if previous ob is from same flight but does not +c have -9C temperature, precision = 1.00, no phase indicated +c ------------------------------------------------------------ + if(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. +c $ abs(ob_t(iim1)-264.16).gt.0.05.and. + $ (.not.l_minus9c(iim1)).and. + $ ifix(t_prcn(iim1)*100).ne.100.and. + $ itype(iim1).ne.i_mdcrs) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated -9C temperature found!--iim1' + $, ' ii = ',ii + endif +c + if(c_qc(ii)(6:6).eq.'-') then + c_qc(ii)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c +c Check if previous ob has -9C temperature, precision = 1.00, no phase indicated +c ------------------------------------------------------------------------------ + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. +c $ abs(ob_t(iim1)-264.16).lt.0.05.and. + $ l_minus9c(iim1).and. + $ ifix(t_prcn(ii)*100).eq.100.and. + $ itype(ii).eq.i_mdcrs) then +c +c Check if following ob is available +c ---------------------------------- + if(iip1.ne.0) then +c +c Check if following ob is from same flight +c ----------------------------------------- + if(c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8)) then +c +c Reject all three obs if following ob has -9C temperature, +c precision = 1.00, no phase indicated +c --------------------------------------------------------- +c if(abs(ob_t(iip1)-264.16).lt.0.05.and. + if(l_minus9c(iip1).and. + $ ifix(t_prcn(iip1)*100).eq.100.and. + $ itype(iip1).eq.i_mdcrs) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Three -9C temps in a row' + $, ' ii = ',ii + endif +c + if(c_qc(iim1)(6:6).eq.'-') then + c_qc(iim1)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + if(c_qc(ii)(6:6).eq.'-') then + c_qc(ii)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + if(c_qc(iip1)(6:6).eq.'-') then + c_qc(iip1)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + endif +c +c Following ob is not from same flight--reject two obs +c ---------------------------------------------------- + else +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*)'Two -9C temps in a row' + $, ' ii = ',ii + endif +c + if(c_qc(iim1)(6:6).eq.'-') then + c_qc(iim1)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + if(c_qc(ii)(6:6).eq.'-') then + c_qc(ii)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + endif + endif + endif +c +c Check if following ob is available +c ---------------------------------- + elseif(iip1.ne.0) then +c +c Reject ob if following ob is from same flight but does not +c have -9C temperature, precision = 1.00, no phase indicated +c ------------------------------------------------------------ + if(c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. +c $ abs(ob_t(iip1)-264.16).gt.0.05.and. + $ (.not.l_minus9c(iip1)).and. + $ ifix(t_prcn(iip1)*100).ne.100.and. + $ itype(iip1).ne.i_mdcrs) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated -9C temperature found--iip1!' + $, ' ii = ',ii + endif +c + if(c_qc(ii)(6:6).eq.'-') then + c_qc(ii)(6:6) = 'I' + n_minus9C(ktype) = n_minus9C(ktype) + 1 + endif +c + endif + endif + endif + endif +c +c Check for erroneous 360 and 0 degree wind directions +c Exclude winds less than 5 kts? +c ---------------------------------------------------- + if((ifix(ob_dir(ii)).eq.360.or. + $ ifix(ob_dir(ii)).eq.0).and. + $ ifix(ob_spd(ii)*100.0).ne.0.and. + $ ob_spd(ii).ne.amiss.and. + $ itype(ii).ne.i_man_airep.and. + $ itype(ii).ne.i_man_Yairep) then +c +c Perform other checks if previous and following obs available +c ------------------------------------------------------------ + if(iim1.ne.0.and.iip1.ne.0) then +c +c Check if previous and following obs from same flight +c ---------------------------------------------------- + if(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. + $ c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. + $ ob_dir(iim1).ne.amiss.and. + $ ob_spd(iim1).ne.amiss.and. + $ ifix(ob_dir(iim1)).ne.360.and. + $ ifix(ob_dir(iim1)).ne.0.and. + $ ob_dir(iip1).ne.amiss.and. + $ ob_spd(iip1).ne.amiss.and. + $ ifix(ob_dir(iip1)).ne.360.and. + $ ifix(ob_dir(iip1)).ne.0) then +c +c Reject ob if neither neighbor has a northerly component +c ------------------------------------------------------- + if(ifix(ob_dir(iim1)).lt.270.and. + $ ifix(ob_dir(iim1)).gt.90.and. + $ ifix(ob_dir(iip1)).lt.270.and. + $ ifix(ob_dir(iip1)).gt.90) then +c + if(ob_spd(ii).lt.7.75.and. + $ (ob_spd(iim1).lt.7.75.or. + $ ob_spd(iip1).lt.7.75).and. + $ abs(idt(ii)-idt(iim1)).gt.120.and. + $ abs(idt(ii)-idt(iip1)).gt.120) then +c +c light and variable ok except for high time resolution flights +c + elseif(ob_spd(ii).lt.2.55.and. + $ (ob_spd(iim1).lt.2.55.or. + $ ob_spd(iip1).lt.2.55)) then +c +c light and variable ok for high time resolution flights +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iim1)-ht_ft(ii)).gt.8000.0.and. + $ (ht_ft(iip1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res descent-ascent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-1-ii = ',ii + endif + endif + endif +c +c Check if three consecutive north winds are ok +c --------------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. + $ c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. + $ ob_dir(iim1).ne.amiss.and. + $ ob_spd(iim1).ne.amiss.and. + $ (ifix(ob_dir(iim1)).eq.360.or. + $ ifix(ob_dir(iim1)).eq.0).and. + $ ob_dir(iip1).ne.amiss.and. + $ ob_spd(iip1).ne.amiss.and. + $ (ifix(ob_dir(iip1)).eq.360.or. + $ ifix(ob_dir(iip1)).eq.0).and. + $ iim2.ne.0.and. + $ iip2.ne.0) then +c +c Reject ob if neither neighbor has a northerly component +c ------------------------------------------------------- + if(ifix(ob_dir(iim2)).lt.270.and. + $ ifix(ob_dir(iim2)).gt.90.and. + $ ifix(ob_dir(iip2)).lt.270.and. + $ ifix(ob_dir(iip2)).gt.90) then +c + if(ob_spd(ii).lt.7.75.and. + $ ((ob_spd(iim2).lt.7.75.and. + $ ob_spd(iim1).lt.7.75).or. + $ (ob_spd(iip1).lt.7.75.and. + $ ob_spd(iip2).lt.7.75)).and. + $ abs(idt(ii)-idt(iim1)).gt.120.and. + $ abs(idt(ii)-idt(iip1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ ((ob_spd(iim2).lt.2.55.and. + $ ob_spd(iim1).lt.2.55).or. + $ (ob_spd(iip1).lt.2.55.and. + $ ob_spd(iip2).lt.2.55))) then +c +c light and variable ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-1-ii = ',ii + endif + endif + endif +c +c Check if previous ob from same flight +c ------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. + $ ob_dir(iim1).ne.amiss.and. + $ ob_spd(iim1).ne.amiss.and. + $ ifix(ob_dir(iim1)).ne.360.and. + $ ifix(ob_dir(iim1)).ne.0) then +c +c Reject ob if neighbor does not have a northerly wind +c ---------------------------------------------------- + if(ifix(ob_dir(iim1)).lt.270.and. + $ ifix(ob_dir(iim1)).gt.90) then +c + if(ob_spd(ii).lt.7.75.and. + $ ob_spd(iim1).lt.7.75.and. + $ abs(idt(ii)-idt(iim1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ ob_spd(iim1).lt.2.55) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iim1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res descent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-2-ii = ',ii + endif + endif + endif +c +c Check if following ob from same flight +c -------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. + $ ob_dir(iip1).ne.amiss.and. + $ ob_spd(iip1).ne.amiss.and. + $ ifix(ob_dir(iip1)).ne.360.and. + $ ifix(ob_dir(iip1)).ne.0) then +c +c Reject ob if neighbor does not have a northerly wind +c ---------------------------------------------------- + if(ifix(ob_dir(iip1)).lt.270.and. + $ ifix(ob_dir(iip1)).gt.90) then +c + if(ob_spd(ii).lt.7.75.and. + $ ob_spd(iip1).lt.7.75.and. + $ abs(idt(ii)-idt(iip1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ ob_spd(iip1).lt.2.55) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iip1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res ascent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-3-ii = ',ii + endif + endif + endif +c +c If neither ob is valid or from same flight, reject ob +c ----------------------------------------------------- + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-4-ii = ',ii + endif + endif +c +c If first or last ob, reject ob +c ------------------------------ + else +c + c_qc(ii)(7:7) = 'B' + n_bad360(ktype) = n_bad360(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad north wind found-5-ii = ',ii + endif + endif +c +c Check for erroneous 180 deg wind directions +c ------------------------------------------- + elseif(ifix(ob_dir(ii)).eq.180.and. + $ itype(ii).ne.i_man_airep.and. + $ itype(ii).ne.i_man_Yairep) then +c +c Perform other checks if previous and following obs available +c ------------------------------------------------------------ + if(iim1.ne.0.and.iip1.ne.0) then +c +c Check if previous and following obs from same flight +c ---------------------------------------------------- + if(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. + $ c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. + $ ob_dir(iim1).ne.amiss.and. + $ ifix(ob_dir(iim1)).ne.0.and. + $ ob_dir(iip1).ne.amiss.and. + $ ifix(ob_dir(iip1)).ne.0) then +c +c Reject ob if neither neighbor has a southerly component +c ------------------------------------------------------- + if((ifix(ob_dir(iim1)).lt.90.or. + $ ifix(ob_dir(iim1)).gt.270).and. + $ (ifix(ob_dir(iip1)).lt.90.or. + $ ifix(ob_dir(iip1)).gt.270)) then +c + if(ob_spd(ii).lt.7.75.and. + $ (ob_spd(iim1).lt.7.75.or. + $ ob_spd(iip1).lt.7.75).and. + $ abs(idt(ii)-idt(iim1)).gt.120.and. + $ abs(idt(ii)-idt(iip1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ (ob_spd(iim1).lt.2.55.or. + $ ob_spd(iip1).lt.2.55)) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iim1)-ht_ft(ii)).gt.8000.0.and. + $ (ht_ft(iip1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res descent-ascent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad180(ktype) = n_bad180(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad south wind found-1-ii = ',ii + write(io8,*) 'dirs = ',ob_dir(iim1),ob_dir(ii) + $, ob_dir(iip1) + endif + endif + endif +c +c Check if previous ob from same flight +c ------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iim1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iim1)(1:8).and. + $ ob_dir(iim1).ne.amiss.and. + $ ifix(ob_dir(iim1)).ne.0) then +c +c Reject ob if neighbor does not have a southerly wind +c ---------------------------------------------------- + if(ifix(ob_dir(iim1)).lt.90.or. + $ ifix(ob_dir(iim1)).gt.270) then +c + if(ob_spd(ii).lt.7.75.and. + $ ob_spd(iim1).lt.7.75.and. + $ abs(idt(ii)-idt(iim1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ ob_spd(iim1).lt.2.55) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iim1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res descent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad180(ktype) = n_bad180(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad south wind found-2-ii = ',ii + endif + endif + endif +c +c Check if following ob from same flight +c -------------------------------------- + elseif(c_acftreg(ii)(1:8).eq.c_acftreg(iip1)(1:8).and. + $ c_acftid(ii)(1:8).eq.c_acftid(iip1)(1:8).and. + $ ob_dir(iip1).ne.amiss.and. + $ ifix(ob_dir(iip1)).ne.0) then +c +c Reject ob if neighbor does not have a southerly wind +c ---------------------------------------------------- + if(ifix(ob_dir(iip1)).lt.90.or. + $ ifix(ob_dir(iip1)).gt.270) then +c + if(ob_spd(ii).lt.7.75.and. + $ ob_spd(iip1).lt.7.75.and. + $ abs(idt(ii)-idt(iim1)).gt.120) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.2.55.and. + $ ob_spd(iip1).lt.2.55) then +c +c light and variable ok +c + elseif(ob_spd(ii).lt.7.75.and. + $ ht_ft(ii).lt.10000.0.and. + $ (ht_ft(iip1)-ht_ft(ii)).gt.8000.0) then +c +c large shear in low-res ascent probably ok +c + else +c + c_qc(ii)(7:7) = 'B' + n_bad180(ktype) = n_bad180(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad south wind found-3-ii = ',ii + endif + endif + endif +c +c If neither ob is valid or from same flight, reject ob +c ----------------------------------------------------- + else +c + c_qc(ii)(7:7) = 'B' + n_bad180(ktype) = n_bad180(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad south wind found-4-ii = ',ii + endif + endif +c +c If first or last ob, reject ob +c ------------------------------ + else +c + c_qc(ii)(7:7) = 'B' + n_bad180(ktype) = n_bad180(ktype) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad south wind found-5-ii = ',ii + endif + endif + endif +c + endif +c +c Print selected rejected reports +c ------------------------------- + if(l_print) then +c +c if(iob.gt.1) then +c iim1 = indx(iob-1) +c else +c iim1 = indx(1) +c endif +c if(iob.lt.numreps) then +c iip1 = indx(iob+1) +c else +c iip1 = indx(numreps) +c endif +c + if(iim1.eq.0) iim1 = ii + if(iip1.eq.0) iip1 = ii +c + write(io8,8002) iim1,c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + write(io8,8002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + write(io8,8002) iip1,c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1) + x, pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1) + 8002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0,1x,f5.2,4(2(1x,f8.2),1x,i5),1x + x, '!',a11,'!') + endif +c +c End loop over reports +c --------------------- + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io32,*) + write(io32,*) 'Invalid reports' + write(io32,*) '---------------' + write(io32,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + kbad = 0 +c +c Loop over reports +c ----------------- + do iob = 1,numreps + ii = indx(iob) +c +c Count number of reports considered +c ---------------------------------- + if(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + nrep_Ac = nrep_Ac + 1 + elseif(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + nrep_Md = nrep_Md + 1 + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nrep_Ma = nrep_Ma + 1 + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + nrep_Ar = nrep_Ar + 1 + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + nrep_Am = nrep_Am + 1 + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif +c +c Count number of reports rejected as invalid +c ------------------------------------------- + if(c_qc(ii)(1:1).eq.'B'.or. + $ c_qc(ii)(5:5).eq.'B'.or. + $ c_qc(ii)(2:2).eq.'M'.or. + $ c_qc(ii)(3:3).eq.'M'.or. + $ c_qc(ii)(4:4).eq.'M'.or. + $ c_qc(ii)(5:5).eq.'M'.or. + $ c_qc(ii)(6:8).eq.'MMM'.or. + $ c_qc(ii)(3:4).eq.'BB') then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + nbad_Md = nbad_Md + 1 + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + nbad_Ac = nbad_Ac + 1 + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + nbad_Am = nbad_Am + 1 + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + nbad_Ar = nbad_Ar + 1 + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nbad_Ma = nbad_Ma + 1 + ktype = 5 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + endif +c +c Flag bad report for reorder subroutine and output rejects +c --------------------------------------------------------- + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(.not.l_operational) then + write(io32,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif + endif + enddo +c +c Loop over reports +c ----------------- + if(.not.l_operational) then + write(io32,*) + write(io32,*) 'Invalid temperatures (-9C)' + write(io32,*) '--------------------------' + write(io32,3001) +c + do iob = 1,numreps + ii = indx(iob) +c +c Count number of reports rejected as invalid +c ------------------------------------------- + if(c_qc(ii)(6:6).eq.'I') then +c +c Output rejected temperatures +c ---------------------------- + write(io32,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) +c +c Count number of rejected temps by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(ktype.gt.0.and.ktype.le.5) then + ntemp_reg(mm,ktype) = ntemp_reg(mm,ktype) + 1 + endif + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif + enddo + endif +c +c Output statistics +c ----------------- + if(.not.l_operational) then + write(io32,*) + write(io32,*)' Number of invalid MDCRS reps rejected = ' + $, kbad(1) +ccccdak write(io32,*)' Number of invalid ACARS reps rejected = ' + write(io32,*)' Number of invalid TAMDAR reps rejected = ' + $, kbad(2) + write(io32,*)' Number of invalid AMDAR reps rejected = ' + $, kbad(3) + write(io32,*)' Number of invalid AIREP reps rejected = ' + $, kbad(4) + write(io32,*)' Number of invalid manAIREP reps rejected = ' + $, kbad(5) + endif +c + write(io8,*) + write(io8,*) ' Invalid reports--rejected' + write(io8,*) ' -------------------------' + write(io8,*)' Number of invalid MDCRS reps rejected = ' + $, kbad(1) +ccccdak write(io8,*)' Number of invalid ACARS reps rejected = ' + write(io8,*)' Number of invalid TAMDAR reps rejected = ' + $, kbad(2) + write(io8,*)' Number of invalid AMDAR reps rejected = ' + $, kbad(3) + write(io8,*)' Number of invalid AIREP reps rejected = ' + $, kbad(4) + write(io8,*)' Number of invalid manAIREP reps rejected = ' + $, kbad(5) +c +c Output detailed stats +c --------------------- + write(*,*) + write(*,*) 'Invalid check data counts--',cdtg_an + write(*,*) '-------------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(*,'('' Total invalid '',5(1x,i7))') + $ nbad_Md,nbad_Ac,nbad_Am,nbad_Ar,nbad_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Invalid check data counts' + write(io8,*) '-------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total invalid '',5(1x,i7))') + $ nbad_Md,nbad_Ac,nbad_Am,nbad_Ar,nbad_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Empty reports '',5(1x,i7))') + $ n_empty(1),n_empty(2),n_empty(3),n_empty(4),n_empty(5) + write(io8,'(''Zero tmp/winds '',5(1x,i7))') n_zero_tmp(1) + $, n_zero_tmp(2),n_zero_tmp(3),n_zero_tmp(4),n_zero_tmp(5) + write(io8,'(''Zero alt/winds '',5(1x,i7))') n_zero_alt(1) + $, n_zero_alt(2),n_zero_alt(3),n_zero_alt(4),n_zero_alt(5) + write(io8,'(''Zero lat/lon '',5(1x,i7))') n_zero_pos(1) + $, n_zero_pos(2),n_zero_pos(3),n_zero_pos(4),n_zero_pos(5) + write(io8,'(''Missing ids '',24x,2(1x,i7),8x)') + $ n_xx999_Ar,n_xx999_Ma + write(io8,'(''Blank ids '',1x,i7,8x,3(1x,i7))') + $ n_blank_Md,n_blank_Am,n_blank_Ar,n_blank_Ma + write(io8,'(''Bad decode '',5(1x,i7))') + $ n_bad_decode(1),n_bad_decode(2),n_bad_decode(3) + $, n_bad_decode(4),n_bad_decode(5) + write(io8,'(''Missing time '',5(1x,i7))') + $ n_miss_time(1),n_miss_time(2),n_miss_time(3) + $, n_miss_time(4),n_miss_time(5) + write(io8,'(''Missing pos '',5(1x,i7))') + $ n_miss_pos(1),n_miss_pos(2),n_miss_pos(3) + $, n_miss_pos(4),n_miss_pos(5) + write(io8,'(''Missing pres '',5(1x,i7))') + $ n_miss_pres(1),n_miss_pres(2),n_miss_pres(3) + $, n_miss_pres(4),n_miss_pres(5) + write(io8,'(''Small pres '',5(1x,i7))') + $ n_small_pres(1),n_small_pres(2),n_small_pres(3) + $, n_small_pres(4),n_small_pres(5) + write(io8,'(''Low AIREPs '',5(1x,i7))') + $ n_low_airep(1),n_low_airep(2),n_low_airep(3) + $, n_low_airep(4),n_low_airep(5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''-9C temps '',5(1x,i7))') + $ n_minus9C(1),n_minus9C(2),n_minus9C(3) + $, n_minus9C(4),n_minus9C(5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Bad north wind '',5(1x,i7))') + $ n_bad360(1),n_bad360(2),n_bad360(3) + $, n_bad360(4),n_bad360(5) + write(io8,'(''Bad south wind '',5(1x,i7))') + $ n_bad180(1),n_bad180(2),n_bad180(3) + $, n_bad180(4),n_bad180(5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in invalid check' +c + return + end +c +c ################################################################### +c subroutine stk_val_qc +c ################################################################### +c + subroutine stk_val_qc(numreps,max_reps,indx,csort,amiss,cdtg_an + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kflight,maxflt,nobs_flt,iobs_flt + $, kreg,creg_reg,nwhol_reg,ntemp_reg,nwind_reg + $, kbadtot,io8,io33,l_operational,l_init,l_ncep) +c +c Check for flights with stuck values +c (defined as a flight with three or more reports where all reports have the +c same time, lat, lon, pres, ob_t, ob_dir, or ob_spd) +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + character*10 cdtg_an ! date time group for analysis + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Flight statistics +c ----------------- + integer maxflt ! max number of flights allowed + integer nobs_flt(maxflt) ! number of reports per flight + $, iobs_flt(maxflt) ! index for first report in each flight + $, kflight ! number of flights in dataset + integer istart ! index for 1st rep in current flight + $, iistart ! index from pointer array for istart + $, iend ! index for last rep in current flight + $, iiend ! index from pointer array for iend +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail#s in dataset + $, mreg ! index pointing to current tail number + character*8 creg_reg(maxflt) ! tail numbers + integer nwhol_reg(maxflt,5) ! number of reports w. temp in whole deg + integer ntemp_reg(maxflt,5) ! number of reports w. rejected temp + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds +c +c Counters +c -------- + integer nstk_time(5) ! number of reports with stuck time + $, nstk_both(5) ! number of reports with both stuck time and position + $, nstk_posn(5) ! number of reports with stuck position + $, nstk_alat(5) ! number of reports with stuck latitude + $, nstk_alon(5) ! number of reports with stuck longitude + $, nstk_pres(5) ! number of reports with stuck pressure + $, nstk_val(5) ! number of reports with stuck temp and winds + $, nstk_temp(5) ! number of reports with stuck temperature + $, nstk_wdir(5) ! number of reports with stuck direction + $, nstk_wspd(5) ! number of reports with stuck speed + $, nstk_moist(5) ! number of reports with stuck moisture + $, nstk_whol(5) ! number of reports w. temp in whole deg + integer kbad(5) ! counter for number of bad reports + $, kbadt(5) ! counter for number of bad temperatures + $, kbadw(5) ! counter for number of bad winds + $, kbadtot ! counter for total number of bad reports +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak integer nstk_Ac ! number of acars reports rejected + integer nstk_Ac ! number of tamdar reports rejected + $, nstk_Md ! number of mdcrs reports rejected + $, nstk_Ma ! number of manual airep reports rejected + $, nstk_Ar ! number of airep reports rejected + $, nstk_Am ! number of amdar reports rejected +c +c Instrument types +c ---------------- +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io33 ! i/o unit number for stuck check +c + real amiss ! real missing value flag +c + integer iob,kk,mm ! do loop indices + $, ii,jj ! index pointing to current report + $, iim1 ! index pointing to previous report + $, iobfirst ! index for first stuck time + $, ioblast ! index for last stuck time + $, iifirst ! index for first stuck latitude + $, iilast ! index for last stuck latitude +c +ccccdak integer k_ACARS ! number of ACARS/MDCRS reports + integer k_ACARS ! number of TAMDAR/MDCRS reports + $, k_AIREP ! number of AIREP reports + $, k_manAIREP ! number of manual AIREP reports + $, k_AMDAR ! number of AMDAR reports + $, k_stuck ! counter for number of stuck reports + $, ktype ! ob type +c + integer istk_time ! value of stuck clock + real*8 alat_min ! min value of latitude during flight + $, alat_max ! max value of latitude during flight + $, alon_min ! min value of longitude during flight + $, alon_max ! max value of longitude during flight + $, stk_alat ! value of stuck latitude + $, stk_alon ! value of stuck longitude + real ht_max ! max height during flight + $, ht_min ! min height during flight + $, ht_max_stuck ! max height during stuck portion + $, ht_min_stuck ! min height during stuck portion + $, temp_min ! min temperature during flight + $, temp_max ! max tempetature during flight + $, ob_min ! min value of parameter during flight + $, ob_max ! max value of parameter during flight + $, stk_pres ! value of stuck pressure + $, stk_alt ! value of stuck altitude + $, stk_temp ! value of stuck temperature + $, stk_wdir ! value of stuck direction + $, stk_wspd ! value of stuck speed + $, stk_moist ! value of stuck moisture +c +c Switches +c -------- + logical stuck ! true if variable found to be stuck +c + logical l_init ! initialize counters if true + $, l_operational ! run QC in operational mode if true + $, l_ncep ! run QC w/ NCEP preferences if true +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + nstk_time = 0 + nstk_both = 0 + nstk_posn = 0 + nstk_alat = 0 + nstk_alon = 0 + nstk_pres = 0 + nstk_val = 0 + nstk_temp = 0 + nstk_wdir = 0 + nstk_wspd = 0 + nstk_moist = 0 +c + nstk_whol = 0 + kbadt = 0 + kbadw = 0 + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nstk_Ac = 0 + nstk_Md = 0 + nstk_Ma = 0 + nstk_Ar = 0 + nstk_Am = 0 + endif +c + nwhol_reg = 0 + ntemp_reg = 0 + nwind_reg = 0 +c +c Begin loop over flights +c ----------------------- + do kk = 1,kflight +c +c Initialize variables +c -------------------- + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) +c +c Handle case where only one or two reports are present for flight +c ---------------------------------------------------------------- + if(nobs_flt(kk).eq.0) then +c write(io8,*) +c write(io8,*) 'No good obs for flight ',kflight + elseif(nobs_flt(kk).eq.1) then +c write(io8,*) +c write(io8,*) 'Only one report present for flight ',kflight + elseif(nobs_flt(kk).eq.2) then +c write(io8,*) +c write(io8,*) 'Only two reports present for flight ',kflight +c +c Handle case where three or more reports are present for flight +c -------------------------------------------------------------- + else +c +c Check if clock is stuck +c (ignore both single manAIREPs, and whole flights of manAIREPs) +c -------------------------------------------------------------- + k_ACARS = 0 + k_AIREP = 0 + k_manAIREP = 0 + k_AMDAR = 0 + ht_min = ht_ft(iistart) + ht_max = ht_ft(iistart) + temp_min = ob_t(iistart) + temp_max = ob_t(iistart) +c +ccccdak First find first ACARS/MDCRS/AIREP report and count reports by category +c First find first TAMDAR/MDCRS/AIREP report and count reports by category +c ------------------------------------------------------------------------ + do iob=istart,iend + ii = indx(iob) + if(ht_ft(ii).lt.ht_min) ht_min = ht_ft(ii) + if(ht_ft(ii).gt.ht_max) ht_max = ht_ft(ii) + if(ob_t(ii).lt.temp_min) temp_min = ob_t(ii) + if(ob_t(ii).gt.temp_max) temp_max = ob_t(ii) +c + if(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + k_ACARS = k_ACARS + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + k_AIREP = k_AIREP + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + k_AMDAR = k_AMDAR + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then +c + k_manAIREP = k_manAIREP + 1 +c + endif + enddo +c +ccccdak If more than 3 ACARS/MDCRS/AIREP/AMDAR reports are present, look for stuck clock +c If more than 3 TAMDAR/MDCRS/AIREP/AMDAR reports are present, look for stuck clock +c --------------------------------------------------------------------------------- + if((k_ACARS+k_AIREP+k_AMDAR).ge.3) then + stuck = .true. + k_stuck = 0 + istk_time = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + ht_min_stuck = 999 999. + ht_max_stuck = -999 999. +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Set "stuck" to false if times not equal and re-initialize stats +c --------------------------------------------------------------- + elseif(idt(iim1).ne.idt(ii)) then +c +c If a portion of the flight is stuck, set QC flags +c ------------------------------------------------- + if(k_stuck.ge.3.and. + $ istk_time.ne.-999 999.and. + $ ((istk_time.eq.0.and. + $ (itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des)).or. + $ ht_max_stuck-ht_min_stuck.lt.100..or. + $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +c + do jj=iobfirst,ioblast + ii = indx(jj) + c_qc(ii)(2:2) = 'K' + enddo +c + write(io8,*) + write(io8,*) 'Flight with > 3 constant times' + do jj=istart,iend + ii = indx(jj) + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + enddo + endif +c + stuck = .false. + k_stuck = 0 + istk_time = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + ht_min_stuck = 999 999. + ht_max_stuck = -999 999. +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else + k_stuck = k_stuck + 1 + istk_time = idt(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(ht_ft(iim1).lt.ht_min_stuck) + $ ht_min_stuck = ht_ft(iim1) + if(ht_ft(iim1).gt.ht_max_stuck) + $ ht_max_stuck = ht_ft(iim1) + endif + ioblast = iob + if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) + if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) + endif + enddo +c +c If entire flight is stuck and flight is long enough, set QC flags +c ----------------------------------------------------------------- + if(stuck.and. + $ ((k_ACARS+k_AIREP+k_AMDAR).ge.3.or. + $ (k_ACARS+k_AIREP+k_AMDAR).eq.0).and. + $ (idt(iistart).eq.0.or. + $ ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(2:2) = 'K' + enddo +c +c Otherwise, if only a portion of the flight is stuck, set QC flags +c ----------------------------------------------------------------- + elseif(k_stuck.ge.3.and. + $ istk_time.ne.-999 999.and. + $ ((istk_time.eq.0.and. + $ (itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des)).or. + $ ht_max_stuck-ht_min_stuck.lt.100..or. + $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +c + do iob=iobfirst,ioblast + ii = indx(iob) + c_qc(ii)(2:2) = 'K' + enddo +c + write(io8,*) + write(io8,*) 'Flight with > 3 constant times' + do iob=istart,iend + ii = indx(iob) + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + enddo + endif + endif +c +c Perform remaining tests only for flights with four or more reports +c ------------------------------------------------------------------ + if(nobs_flt(kk).gt.3) then +c +c Check if position is stuck +c -------------------------- + stuck = .true. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alat = -999 999 + stk_alon = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + alat_min = 999 999 + alat_max = -999 999 + alon_min = 999 999 + alon_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over reports with previously averaged positions +c ---------------------------------------------------- + elseif(ichk_t(ii).eq.-4) then +!vvvv^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Set "stuck" to false if lat/lons not equal and re-initialize stats +c ------------------------------------------------------------------ + elseif((abs(alat(iim1)-alat(ii)).gt.0.015.and. + $ alat(iim1).ne.amiss.and. + $ alat(ii).ne.amiss).or. + $ (abs(alon(iim1)-alon(ii)).gt.0.015.and. + $ alon(iim1).ne.amiss.and. + $ alon(ii).ne.amiss)) then +c +c If a portion of the flight is stuck, set QC flags +c ------------------------------------------------- + if(k_stuck.ge.3.and. + $ stk_alat.ne.-999 999.and. + $ stk_alon.ne.-999 999.and. + $ stk_alat.ne.amiss.and. + $ stk_alon.ne.amiss.and. + $ abs(alat_max-alat_min).lt.0.015.and. + $ abs(alon_max-alon_min).lt.0.015.and. + $ (abs(stk_alat).lt.0.005.or. + $ abs(stk_alon).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_max_stuck-ht_min_stuck.lt.100..or. + $ ((itype(ii).ne.i_amdar.and. + $ itype(ii).ne.i_amdar_lvl.and. + $ itype(ii).ne.i_amdar_asc.and. + $ itype(ii).ne.i_amdar_des).and. + $ ht_max_stuck-ht_min_stuck.gt.9000.).or. + $ ((itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des).and. + $ ht_max_stuck-ht_min_stuck.gt.12000.)) ) then +c + do jj=iobfirst,ioblast + ii = indx(jj) + c_qc(ii)(3:4) = 'KK' + enddo +c + write(io8,*) + write(io8,*) 'Flight with > 3 constant positions' + do jj=istart,iend + ii = indx(jj) + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + enddo + endif +c + stuck = .false. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alat = -999 999 + stk_alon = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat_min = 999 999 + alat_max = -999 999 + alon_min = 999 999 + alon_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + k_stuck = k_stuck + 1 + stk_alat = alat(ii) + stk_alon = alon(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(alat(iim1).lt.alat_min.and. + $ alat(iim1).ne.amiss) alat_min = alat(iim1) + if(alat(iim1).gt.alat_max.and. + $ alat(iim1).ne.amiss) alat_max = alat(iim1) + if(alon(iim1).lt.alon_min.and. + $ alon(iim1).ne.amiss) alon_min = alon(iim1) + if(alon(iim1).gt.alon_max.and. + $ alon(iim1).ne.amiss) alon_max = alon(iim1) + if(ht_ft(iim1).lt.ht_min_stuck) + $ ht_min_stuck = ht_ft(iim1) + if(ht_ft(iim1).gt.ht_max_stuck) + $ ht_max_stuck = ht_ft(iim1) + endif + ioblast = iob + if(iifirst.eq.-999 999) iifirst = iim1 + iilast = ii + if(alat(ii).lt.alat_min.and. + $ alat(ii).ne.amiss) alat_min = alat(ii) + if(alat(ii).gt.alat_max.and. + $ alat(ii).ne.amiss) alat_max = alat(ii) + if(alon(ii).lt.alon_min.and. + $ alon(ii).ne.amiss) alon_min = alon(ii) + if(alon(ii).gt.alon_max.and. + $ alon(ii).ne.amiss) alon_max = alon(ii) + if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) + if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) + endif + enddo +c +c If entire flight is stuck and flight is long enough, set QC flags +c ----------------------------------------------------------------- + if(stuck.and. + $ alat(iistart).ne.amiss.and. + $ alon(iistart).ne.amiss.and. + $ abs(alat_max-alat_min).lt.0.015.and. + $ abs(alon_max-alon_min).lt.0.015.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (abs(alat(iistart)).lt.0.005.or. + $ abs(alon(iistart)).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_max-ht_min.lt.100..or. + $ ((itype(ii).ne.i_amdar.and. + $ itype(ii).ne.i_amdar_lvl.and. + $ itype(ii).ne.i_amdar_asc.and. + $ itype(ii).ne.i_amdar_des).and. + $ ht_max-ht_min.gt.9000.).or. + $ ((itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des).and. + $ ht_max-ht_min.gt.12000.)) ) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(3:4) = 'KK' + enddo +c +c Otherwise, if only a portion of the flight is stuck, set QC flags +c ----------------------------------------------------------------- + elseif(k_stuck.ge.3.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ stk_alat.ne.-999 999.and. + $ stk_alon.ne.-999 999.and. + $ stk_alat.ne.amiss.and. + $ stk_alon.ne.amiss.and. + $ abs(alat_max-alat_min).lt.0.015.and. + $ abs(alon_max-alon_min).lt.0.015.and. + $ (abs(stk_alat).lt.0.005.or. + $ abs(stk_alon).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_max_stuck-ht_min_stuck.lt.100..or. + $ ((itype(ii).ne.i_amdar.and. + $ itype(ii).ne.i_amdar_lvl.and. + $ itype(ii).ne.i_amdar_asc.and. + $ itype(ii).ne.i_amdar_des).and. + $ ht_max_stuck-ht_min_stuck.gt.9000.).or. + $ ((itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des).and. + $ ht_max_stuck-ht_min_stuck.gt.12000.)) ) then +c + do iob=iobfirst,ioblast + ii = indx(iob) + c_qc(ii)(3:4) = 'KK' + enddo +c + write(io8,*) + write(io8,*) 'Flight with > 3 constant positions' + do iob=istart,iend + ii = indx(iob) + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + enddo + endif +c +c Check if latitude is stuck +c -------------------------- + stuck = .true. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alat = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + alat_min = 999 999 + alat_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over reports with previously averaged positions +c ---------------------------------------------------- + elseif(ichk_t(ii).eq.-4) then +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c Set "stuck" to false if lats not equal and re-initialize stats +c -------------------------------------------------------------- + elseif(abs(alat(iim1)-alat(ii)).gt.0.005.and. + $ alat(iim1).ne.amiss.and. + $ alat(ii).ne.amiss) then +cc +cc If a portion of the flight is stuck, set QC flags +cc ------------------------------------------------- +c if(k_stuck.ge.3.and. +c $ stk_alat.ne.-999 999.and. +c $ stk_alat.ne.amiss.and. +c $ abs(alat_max-alat_min).lt.0.005.and. +c $ abs(nint(stk_alat)-stk_alat).gt.0.005.and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ (abs(stk_alat).lt.0.005.or. +c $ ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +cc +c do jj=iobfirst,ioblast +c ii = indx(jj) +c c_qc(ii)(3:3) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant latitudes' +c do jj=istart,iend +c ii = indx(jj) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c endif +c + stuck = .false. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alat = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + alat_min = 999 999 + alat_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + elseif(c_qc(ii)(3:3).ne.'K') then + k_stuck = k_stuck + 1 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alat = alat(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(alat(iim1).lt.alat_min.and. + $ alat(iim1).ne.amiss) alat_min = alat(iim1) + if(alat(iim1).gt.alat_max.and. + $ alat(iim1).ne.amiss) alat_max = alat(iim1) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + if(ht_ft(iim1).lt.ht_min_stuck) + $ ht_min_stuck = ht_ft(iim1) + if(ht_ft(iim1).gt.ht_max_stuck) + $ ht_max_stuck = ht_ft(iim1) + endif + ioblast = iob + if(iifirst.eq.-999 999) iifirst = iim1 + iilast = ii +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(ii).lt.alat_min.and. + $ alat(ii).ne.amiss) alat_min = alat(ii) + if(alat(ii).gt.alat_max.and. + $ alat(ii).ne.amiss) alat_max = alat(ii) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) + if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) + endif + enddo +c +c Don't reject flights with constant lat rounded to nearest deg +c or flights with elapsed time less than 30 minutes (1800 seconds) +c -------------------------------------------------------------- + if(stuck.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ alat(iistart).ne.amiss.and. + $ abs(alat_max-alat_min).lt.0.005.and. + $ abs(nint(alat(iistart))-alat(iistart)).gt.0.005.and. + $ abs(idt(iiend)-idt(iistart)).gt.1800.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (abs(alat(iistart)).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(3:3) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c $ stk_alat.ne.-999 999.and. +c $ stk_alat.ne.amiss.and. +c $ abs(alat_max-alat_min).lt.0.005.and. +c $ abs(nint(stk_alat)-stk_alat).gt.0.005.and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ (abs(stk_alat).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c $ ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(3:3) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant latitudes' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +c Check if longitude is stuck +c --------------------------- + stuck = .true. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alon = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + alon_min = 999 999 + alon_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over reports with previously averaged positions +c ---------------------------------------------------- + elseif(ichk_t(ii).eq.-4) then +c +c Set "stuck" to false if lons not equal and re-initialize stats +c -------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(abs(alon(iim1)-alon(ii)).gt.0.005.and. + $ alon(iim1).ne.amiss.and. + $ alon(ii).ne.amiss) then +cc +cc If a portion of the flight is stuck, set QC flags +cc ------------------------------------------------- +c if(k_stuck.ge.3.and. +c $ stk_alon.ne.-999 999.and. +c $ stk_alon.ne.amiss.and. +c $ abs(alon_max-alon_min).lt.0.005.and. +c $ abs(nint(stk_alon)-stk_alon).gt.0.005.and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ (abs(stk_alon).lt.0.005.or. +c $ ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +cc +c do jj=iobfirst,ioblast +c ii = indx(jj) +c c_qc(ii)(4:4) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant longitudes' +c do jj=istart,iend +c ii = indx(jj) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c endif +c + stuck = .false. + k_stuck = 0 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + stk_alon = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + alon_min = 999 999 + alon_max = -999 999 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + elseif(c_qc(ii)(4:4).ne.'K') then + k_stuck = k_stuck + 1 + stk_alon = alon(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon(iim1).lt.alon_min.and. + $ alon(iim1).ne.amiss) alon_min = alon(iim1) + if(alon(iim1).gt.alon_max.and. + $ alon(iim1).ne.amiss) alon_max = alon(iim1) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + if(ht_ft(iim1).lt.ht_min_stuck) + $ ht_min_stuck = ht_ft(iim1) + if(ht_ft(iim1).gt.ht_max_stuck) + $ ht_max_stuck = ht_ft(iim1) + endif + ioblast = iob + if(iifirst.eq.-999 999) iifirst = iim1 + iilast = ii +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon(ii).lt.alon_min.and. + $ alon(ii).ne.amiss) alon_min = alon(ii) + if(alon(ii).gt.alon_max.and. + $ alon(ii).ne.amiss) alon_max = alon(ii) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) + if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) + endif + enddo +c +c Don't reject flights with constant lon rounded to nearest deg +c or flights with elapsed time less than 30 minutes (1800 seconds) +c -------------------------------------------------------------- + if(stuck.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ alon(iistart).ne.amiss.and. + $ abs(alon_max-alon_min).lt.0.005.and. + $ abs(nint(alon(iistart))-alon(iistart)).gt.0.005.and. + $ abs(idt(iiend)-idt(iistart)).gt.1800.and. +c $ abs(alon(iiend)-alon(iistart)).lt.0.005.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (abs(alon(iistart)).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(4:4) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c $ stk_alon.ne.-999 999.and. +c $ stk_alon.ne.amiss.and. +c $ abs(alon_max-alon_min).lt.0.005.and. +c $ abs(nint(stk_alon)-stk_alon).gt.0.005.and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ (abs(stk_alon).lt.0.005.or. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c $ ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +c +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(4:4) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant longitudes' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +c Check if pressure is stuck +c (constant ok if at upper levels) +c (The check for stuck segments is commented out) +c ----------------------------------------------- + stuck = .true. + k_stuck = 0 + stk_pres = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Set "stuck" to false if pressures not equal and re-initialize stats +c ------------------------------------------------------------------- + elseif(abs(pres(iim1)-pres(ii)).gt.0.05.and. + $ pres(iim1).ne.amiss.and. + $ pres(ii).ne.amiss) then + stuck = .false. + k_stuck = 0 + stk_pres = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_pres = pres(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(pres(iim1).lt.ob_min.and. + $ pres(iim1).ne.amiss) ob_min = pres(iim1) + if(pres(iim1).gt.ob_max.and. + $ pres(iim1).ne.amiss) ob_max = pres(iim1) + endif +c ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(pres(ii).lt.ob_min.and. + $ pres(ii).ne.amiss) ob_min = pres(ii) + if(pres(ii).gt.ob_max.and. + $ pres(ii).ne.amiss) ob_max = pres(ii) +c + endif + enddo +c +c Don't reject flights with pressure less than 750 mb +c --------------------------------------------------- + if(stuck.and. + $ pres(iistart).gt.750..and. + $ pres(iistart).ne.amiss.and. +c $ abs(pres(iiend)-pres(iistart)).lt.0.05.and. + $ abs(ob_max-ob_min).lt.0.05.and. + $ abs(idt(iiend)-idt(iistart)).gt.1800.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(5:5) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_pres.ne.-999 999.and. +c $ stk_pres.ne.amiss.and. +c $ abs(ob_max-ob_min).lt.0.05.and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ stk_pres.gt.750.) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(5:5) = 'K' +c enddo +cc +c stuck = .true. +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant pressures' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +c Check if altitude is stuck +c (constant ok if at upper levels) +c (The check for stuck segments is commented out) +c ----------------------------------------------- + if(.not.stuck) then +c + stuck = .true. + k_stuck = 0 + stk_alt = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Set "stuck" to false if heights not equal and re-initialize stats +c ----------------------------------------------------------------- + elseif(ifix(ht_ft(iim1)/10.).ne. + $ ifix(ht_ft(ii)/10.).and. + $ ht_ft(iim1).ne.amiss.and. + $ ht_ft(ii).ne.amiss) then + stuck = .false. + k_stuck = 0 + stk_alt = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_alt = ht_ft(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(ht_ft(iim1).lt.ob_min.and. + $ ht_ft(iim1).ne.amiss) ob_min = ht_ft(iim1) + if(ht_ft(iim1).gt.ob_max.and. + $ ht_ft(iim1).ne.amiss) ob_max = ht_ft(iim1) + endif +c ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(ht_ft(ii).lt.ob_min.and. + $ ht_ft(ii).ne.amiss) ob_min = ht_ft(ii) + if(ht_ft(ii).gt.ob_max.and. + $ ht_ft(ii).ne.amiss) ob_max = ht_ft(ii) +c + endif + enddo +c +c Don't reject flights with altitude greater than 8000' +c ----------------------------------------------------- + if(stuck.and. + $ ht_ft(iistart).lt.8000..and. + $ ht_ft(iistart).ne.amiss.and. +c $ ifix(ht_ft(iiend)/10.).eq.ifix(ht_ft(iistart)/10.).and. + $ ifix(ob_max/10.).eq.ifix(ob_min/10.).and. + $ abs(idt(iiend)-idt(iistart)).gt.1800.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(5:5) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_alt.ne.-999 999.and. +c $ stk_alt.ne.amiss.and. +c $ ifix(ob_max/10.).eq.ifix(ob_min/10.).and. +c $ abs(idt(iilast)-idt(iifirst)).gt.1800.and. +c $ stk_alt.lt.8000.) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(5:5) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant altitudes' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif + endif +c +c Check if temperature is stuck or reported in whole deg +c (The check for stuck segments is commented out) +c ------------------------------------------------------ + stuck = .true. + k_stuck = 0 + stk_temp = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over temperatures already rejected +c --------------------------------------- + elseif(c_qc(ii)(6:6).eq.'B'.or. + $ c_qc(ii)(6:6).eq.'b'.or. + $ c_qc(ii)(6:6).eq.'E'.or. + $ c_qc(ii)(6:6).eq.'I') then +c +c Set "stuck" to false if temps not equal and re-initialize stats +c --------------------------------------------------------------- + elseif(abs(ob_t(iim1)-ob_t(ii)).gt.0.05.and. + $ ob_t(iim1).ne.amiss.and. + $ ob_t(ii).ne.amiss) then +c + stuck = .false. + k_stuck = 0 + stk_temp = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_temp = ob_t(ii) + if(iobfirst.eq.-999 999.and. + $ ob_t(iim1).ne.amiss) then + iobfirst = iob-1 + ioblast = iob-1 + if(ob_t(iim1).lt.ob_min.and. + $ ob_t(iim1).ne.amiss) ob_min = ob_t(iim1) + if(ob_t(iim1).gt.ob_max.and. + $ ob_t(iim1).ne.amiss) ob_max = ob_t(iim1) +c if(ht_ft(iim1).lt.ht_min_stuck) +c $ ht_min_stuck = ht_ft(iim1) +c if(ht_ft(iim1).gt.ht_max_stuck) +c $ ht_max_stuck = ht_ft(iim1) + endif + if(ob_t(ii).ne.amiss) ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(ob_t(ii).lt.ob_min.and. + $ ob_t(ii).ne.amiss) ob_min = ob_t(ii) + if(ob_t(ii).gt.ob_max.and. + $ ob_t(ii).ne.amiss) ob_max = ob_t(ii) +c if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) +c if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) +c + endif + enddo +c +c Don't reject flights with a height difference of less than 1500' +c -------------------------------------------------------------- + if(stuck.and. + $ k_stuck.gt.0.and. + $ ob_t(iistart).ne.amiss.and. + $ iobfirst.ne.ioblast.and. + $ (ht_max-ht_min.gt.1500..or. + $ ht_max.gt.25000.).and. + $ abs(ob_max-ob_min).lt.0.05.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0)) then +c + do iob=istart,iend + ii = indx(iob) + if(c_qc(ii)(6:6).ne.'B'.and. + $ c_qc(ii)(6:6).ne.'b'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I') c_qc(ii)(6:6) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_temp.ne.-999 999.and. +c $ stk_temp.ne.amiss.and. +c $ abs(ob_max-ob_min).lt.0.05.and. +c $ (ht_max_stuck-ht_min_stuck.gt.1500..or. +c $ ht_max_stuck.gt.25000.)) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(6:6) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant temperatures' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +ccccdak Recompute temperature reported in whole degrees for ACARS/MDCRS +c Recompute temperature reported in whole degrees for TAMDAR/MDCRS +c Mark as bad for other types +c ---------------------------------------------------------------- + if(temp_min.gt.266.0.and. + $ temp_max.lt.278.0.and. + $ (.not.stuck).and. + $ ht_max.gt.25000.) then +c + do mm=1,kreg + if(c_acftreg(iistart).eq.creg_reg(mm)) mreg = mm + enddo +c + do iob=istart,iend + ii = indx(iob) + if(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ob_t(ii) = (ob_t(ii) - 273.16) * 10. + 273.16 +c write(io8,*) ' temperature recomputed' + c_qc(ii)(6:6) = 'R' + t_prcn(ii) = 1.00 + else +c write(io8,*) ' temperature marked bad' + c_qc(ii)(6:6) = 'b' + endif +c +c Count number of corrected/rejected temperatures +c ----------------------------------------------- + if(c_acftreg(ii).eq.creg_reg(mreg)) then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nwhol_reg(mreg,1) = nwhol_reg(mreg,1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nwhol_reg(mreg,2) = nwhol_reg(mreg,2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nwhol_reg(mreg,3) = nwhol_reg(mreg,3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nwhol_reg(mreg,4) = nwhol_reg(mreg,4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nwhol_reg(mreg,5) = nwhol_reg(mreg,5) + 1 + endif +c + else + do mm=1,kreg + if(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nwhol_reg(mm,1) = nwhol_reg(mm,1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nwhol_reg(mm,2) = nwhol_reg(mm,2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nwhol_reg(mm,3) = nwhol_reg(mm,3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nwhol_reg(mm,4) = nwhol_reg(mm,4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nwhol_reg(mm,5) = nwhol_reg(mm,5) + 1 + endif + endif + enddo + endif + enddo + endif +c +c Check if wind direction is stuck +c (The check for stuck segments is commented out) +c ----------------------------------------------- + stuck = .true. + k_stuck = 0 + stk_wdir = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over winds already rejected +c -------------------------------- + elseif(c_qc(ii)(7:7).eq.'B'.or. + $ c_qc(ii)(7:7).eq.'E'.or. + $ c_qc(ii)(8:8).eq.'E') then +c +c Set "stuck" to false if directions not equal and re-initialize stats +c -------------------------------------------------------------------- + elseif(abs(ob_dir(iim1)-ob_dir(ii)).gt.0.5.and. + $ ob_dir(iim1).ne.amiss.and. + $ ob_dir(ii).ne.amiss) then + stuck = .false. + k_stuck = 0 + stk_wdir = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_wdir = ob_dir(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(ob_dir(iim1).lt.ob_min.and. + $ ob_dir(iim1).ne.amiss) ob_min = ob_dir(iim1) + if(ob_dir(iim1).gt.ob_max.and. + $ ob_dir(iim1).ne.amiss) ob_max = ob_dir(iim1) +c if(ht_ft(iim1).lt.ht_min_stuck) +c $ ht_min_stuck = ht_ft(iim1) +c if(ht_ft(iim1).gt.ht_max_stuck) +c $ ht_max_stuck = ht_ft(iim1) + endif +c ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(ob_dir(ii).lt.ob_min.and. + $ ob_dir(ii).ne.amiss) ob_min = ob_dir(ii) + if(ob_dir(ii).gt.ob_max.and. + $ ob_dir(ii).ne.amiss) ob_max = ob_dir(ii) +c if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) +c if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) +c + endif + enddo +c +c Don't reject flights with constant dir rounded to nearest 10 deg +c -------------------------------------------------------------- + if(stuck.and. + $ ob_dir(iistart).ne.amiss.and. + $ (abs(nint(ob_dir(iistart)/10.)*10 + $ -ob_dir(iistart)).gt.0.5).and. +c $ abs(ob_dir(iiend)-ob_dir(iistart)).lt.0.5.and. + $ abs(ob_max-ob_min).lt.0.5.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(7:7) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_wdir.ne.-999 999.and. +c $ stk_wdir.ne.amiss.and. +c $ (abs(nint(stk_wdir/10.)*10-stk_wdir).gt.0.5).and. +c $ abs(ob_max-ob_min).lt.0.5.and. +c $ (ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.) ) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(7:7) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant wind directions' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +c Check if wind speed is stuck +c (The check for stuck segments is commented out) +c ----------------------------------------------- + stuck = .true. + k_stuck = 0 + stk_wspd = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Skip over winds already rejected +c -------------------------------- + elseif(c_qc(ii)(7:7).eq.'B'.or. + $ c_qc(ii)(7:7).eq.'E'.or. + $ c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'E') then +c +c Set "stuck" to false if speeds not equal and re-initialize stats +c ---------------------------------------------------------------- + elseif(abs(ob_spd(iim1)-ob_spd(ii)).gt.0.05.and. + $ ob_spd(iim1).ne.amiss.and. + $ ob_spd(ii).ne.amiss) then + stuck = .false. + k_stuck = 0 + stk_wspd = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_wspd = ob_spd(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(ob_spd(iim1).lt.ob_min.and. + $ ob_spd(iim1).ne.amiss) ob_min = ob_spd(iim1) + if(ob_spd(iim1).gt.ob_max.and. + $ ob_spd(iim1).ne.amiss) ob_max = ob_spd(iim1) +c if(ht_ft(iim1).lt.ht_min_stuck) +c $ ht_min_stuck = ht_ft(iim1) +c if(ht_ft(iim1).gt.ht_max_stuck) +c $ ht_max_stuck = ht_ft(iim1) + endif +c ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(ob_spd(ii).lt.ob_min.and. + $ ob_spd(ii).ne.amiss) ob_min = ob_spd(ii) + if(ob_spd(ii).gt.ob_max.and. + $ ob_spd(ii).ne.amiss) ob_max = ob_spd(ii) +c if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) +c if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) +c + endif + enddo +c +c Don't reject flights with constant direction rounded to the nearest 10 deg +c -------------------------------------------------------------------------- + if(stuck.and. + $ ob_spd(iistart).ne.amiss.and. + $ (ob_dir(iistart).ne.-999 999.and. + $ (ob_dir(iistart).eq.0.0.or. + $ abs(nint(ob_dir(iistart)/10.)*10 + $ -ob_dir(iistart)).gt.0.5).or. + $ ob_dir(iiend).ne.-999 999.and. + $ (ob_dir(iiend).eq.0.0.or. + $ abs(nint(ob_dir(iiend)/10.)*10 + $ -ob_dir(iiend)).gt.0.5)).and. +c $ abs(ob_spd(iiend)-ob_spd(iistart)).lt.0.05.and. + $ abs(ob_max-ob_min).lt.0.05.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then +c + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(8:8) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_wspd.ne.-999 999.and. +c $ stk_wspd.ne.amiss.and. +c $ ((ob_dir(iifirst).ne.-999 999.and. +c $ (ob_dir(iifirst).eq.0.0.or. +c $ abs(nint(ob_dir(iifirst)/10.)*10 +c $ -ob_dir(iifirst)).gt.0.5)).or. +c $ (ob_dir(iilast).ne.-999 999.and. +c $ (ob_dir(iilast).eq.0.0.or. +c $ abs(nint(ob_dir(iilast)/10.)*10 +c $ -ob_dir(iilast)).gt.0.5))).and. +c $ abs(ob_max-ob_min).lt.0.05.and. +c $ (ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.)) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(8:8) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant wind speeds' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c +c Check if moisture is stuck +c (The check for stuck segments is commented out) +c ----------------------------------------------- + stuck = .true. + k_stuck = 0 + stk_moist = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c + do iob=istart+1,iend + ii = indx(iob) + iim1 = indx(iob-1) +c +c Skip over isolated man_airep reports +c ------------------------------------ + if((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ k_ACARS+k_AIREP+k_AMDAR.gt.0) then +c +c Set "stuck" to false if moistures not equal and re-initialize stats +c Exclude missing values +c ------------------------------------------------------------------- + elseif(abs(ob_q(iim1)-ob_q(ii)).gt.0.005.and. + $ ob_q(iim1).ne.amiss.and. + $ ob_q(ii).ne.amiss.and. + $ ichk_q(ii).ne.-9.and. + $ ichk_q(ii).ne.9.and. + $ ichk_q(ii).ne.-1.and. + $ .not.(ob_q(ii).lt.0.005.and.ichk_q(ii).eq.-7)) then +c + stuck = .false. + k_stuck = 0 + stk_moist = -999 999 + iobfirst = -999 999 + ioblast = -999 999 + iifirst = -999 999 + iilast = -999 999 + ob_min = 999 999 + ob_max = -999 999 + ht_min_stuck = 999 999 + ht_max_stuck = -999 999 +c +c Accumulate statistics for stuck segments +c ---------------------------------------- + else +c k_stuck = k_stuck + 1 +c stk_moist = ob_q(ii) + if(iobfirst.eq.-999 999) then + iobfirst = iob-1 + if(ob_q(iim1).lt.ob_min.and. + $ ob_q(iim1).ne.amiss) ob_min = ob_q(iim1) + if(ob_q(iim1).gt.ob_max.and. + $ ob_q(iim1).ne.amiss) ob_max = ob_q(iim1) +c if(ht_ft(iim1).lt.ht_min_stuck) +c $ ht_min_stuck = ht_ft(iim1) +c if(ht_ft(iim1).gt.ht_max_stuck) +c $ ht_max_stuck = ht_ft(iim1) + endif +c ioblast = iob +c if(iifirst.eq.-999 999) iifirst = iim1 +c iilast = ii + if(ob_q(ii).lt.ob_min.and. + $ ob_q(ii).ne.amiss) ob_min = ob_q(ii) + if(ob_q(ii).gt.ob_max.and. + $ ob_q(ii).ne.amiss) ob_max = ob_q(ii) +c if(ht_ft(ii).lt.ht_min_stuck) ht_min_stuck = ht_ft(ii) +c if(ht_ft(ii).gt.ht_max_stuck) ht_max_stuck = ht_ft(ii) +c + endif + enddo +c +c Don't reject flights with moisture = 0 (=> missing) +c --------------------------------------------------- + if(stuck.and. + $ ob_q(iistart).ne.amiss.and. + $ abs(ob_q(iistart)).gt.0.005.and. +c $ abs(ob_q(iiend)-ob_q(iistart)).lt.0.005.and. + $ abs(ob_max-ob_min).lt.0.005.and. + $ (k_ACARS+k_AIREP+k_AMDAR.ge.3.or. + $ k_ACARS+k_AIREP+k_AMDAR.eq.0).and. + $ (ht_max-ht_min.lt.100..or. + $ ht_max-ht_min.gt.9000.)) then + + do iob=istart,iend + ii = indx(iob) + if(c_qc(ii)(9:9).eq.'-') c_qc(ii)(9:9) = 'K' + enddo +cc +cc Otherwise, if only a portion of the flight is stuck, set QC flags +cc ----------------------------------------------------------------- +c elseif(k_stuck.ge.3.and. +c $ stk_moist.ne.-999 999.and. +c $ stk_moist.ne.amiss.and. +c $ stk_moist.gt.0.005.and. +c $ abs(ob_max-ob_min).lt.0.005.and. +c $ (ht_max_stuck-ht_min_stuck.lt.100..or. +c $ ht_max_stuck-ht_min_stuck.gt.9000.)) then +cc +c do iob=iobfirst,ioblast +c ii = indx(iob) +c c_qc(ii)(9:9) = 'K' +c enddo +cc +c write(io8,*) +c write(io8,*) 'Flight with > 3 constant moisture' +c do iob=istart,iend +c ii = indx(iob) +c write(io8,3002) ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +c enddo +c + endif +c + endif + endif + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io33,*) + write(io33,*) 'Reports with temperatures in whole degrees' + write(io33,*) '------------------------------------------' + write(io33,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + do iob = 1,numreps + ii = indx(iob) +c + if(c_qc(ii)(6:6).eq.'R'.or. + $ c_qc(ii)(6:6).eq.'b') then +c + if(.not.l_operational) then + write(io33,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count number of recomputed or marked reports +c -------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + nstk_whol(1) = nstk_whol(1) + 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + nstk_whol(2) = nstk_whol(2) + 1 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + nstk_whol(3) = nstk_whol(3) + 1 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + nstk_whol(4) = nstk_whol(4) + 1 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + nstk_whol(5) = nstk_whol(5) + 1 + endif +c + endif + enddo +c + if(.not.l_operational) then + write(io33,*) + write(io33,*) ' Number of MDCRS in whole deg =',nstk_whol(1) +ccccdak write(io33,*) ' Number of ACARS in whole deg =',nstk_whol(2) + write(io33,*) ' Number of TAMDAR in whole deg =',nstk_whol(2) + write(io33,*) ' Number of AMDAR in whole deg =',nstk_whol(3) + write(io33,*) ' Number of AIREP in whole deg =',nstk_whol(4) + write(io33,*) ' Number of manAIREP in whole deg =',nstk_whol(5) +c + write(io33,*) + write(io33,*) 'Reports with stuck values (K)' + write(io33,*) '-----------------------------' + write(io33,3001) + endif +c + kbad = 0 +c + do iob = 1,numreps + ii = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c + if(ktype.eq.1) then + nrep_Md = nrep_Md + 1 + elseif(ktype.eq.2) then + nrep_Ac = nrep_Ac + 1 + elseif(ktype.eq.3) then + nrep_Am = nrep_Am + 1 + elseif(ktype.eq.4) then + nrep_Ar = nrep_Ar + 1 + elseif(ktype.eq.5) then + nrep_Ma = nrep_Ma + 1 + endif +c + if(c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:3).eq.'K'.or. + $ c_qc(ii)(4:4).eq.'K'.or. + $ c_qc(ii)(5:5).eq.'K'.or. + $ c_qc(ii)(6:6).eq.'K'.or. + $ c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K'.or. + $ c_qc(ii)(9:9).eq.'K') then +c + if(.not.l_operational) then + write(io33,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif +c +c Count number of rejects +c ----------------------- + if(c_qc(ii)(2:4).eq.'KKK') then + nstk_both(ktype) = nstk_both(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'K') then + nstk_time(ktype) = nstk_time(ktype) + 1 + elseif(c_qc(ii)(3:4).eq.'KK') then + nstk_posn(ktype) = nstk_posn(ktype) + 1 + elseif(c_qc(ii)(3:3).eq.'K') then + nstk_alat(ktype) = nstk_alat(ktype) + 1 + elseif(c_qc(ii)(4:4).eq.'K') then + nstk_alon(ktype) = nstk_alon(ktype) + 1 + elseif(c_qc(ii)(5:5).eq.'K') then + nstk_pres(ktype) = nstk_pres(ktype) + 1 + elseif(c_qc(ii)(6:6).eq.'K'.and. + $ (c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K')) then + nstk_val(ktype) = nstk_val(ktype) + 1 + else + if(c_qc(ii)(6:6).eq.'K') then + nstk_temp(ktype) = nstk_temp(ktype) + 1 + endif + if(c_qc(ii)(7:7).eq.'K') then + nstk_wdir(ktype) = nstk_wdir(ktype) + 1 + endif + if(c_qc(ii)(8:8).eq.'K') then + nstk_wspd(ktype) = nstk_wspd(ktype) + 1 + endif + if(c_qc(ii)(9:9).eq.'K') then + nstk_moist(ktype) = nstk_moist(ktype) + 1 + endif + endif +c +c Count number of rejected temps/winds by tail number +c --------------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then +c + if(ktype.gt.0.and.ktype.le.5) then + if(c_qc(ii)(6:6).eq.'K'.and. + $ c_qc(ii)(2:2).ne.'K'.and. + $ c_qc(ii)(3:3).ne.'K'.and. + $ c_qc(ii)(4:4).ne.'K'.and. + $ c_qc(ii)(5:5).ne.'K') + $ ntemp_reg(mm,ktype) = ntemp_reg(mm,ktype) + 1 + if((c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K').and. + $ c_qc(ii)(2:2).ne.'K'.and. + $ c_qc(ii)(3:3).ne.'K'.and. + $ c_qc(ii)(4:4).ne.'K'.and. + $ c_qc(ii)(5:5).ne.'K') + $ nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + endif + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif +c +c Reject reports with stuck time, lat, lon, pres +c Also reject report if both temperature and winds are stuck +c ---------------------------------------------------------- + if(c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:3).eq.'K'.or. + $ c_qc(ii)(4:4).eq.'K'.or. + $ c_qc(ii)(5:5).eq.'K'.or. + $ (c_qc(ii)(6:6).eq.'K'.and. + $ (c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K'))) then +c + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(ktype.eq.1) then + nstk_Md = nstk_Md + 1 + elseif(ktype.eq.2) then + nstk_Ac = nstk_Ac + 1 + elseif(ktype.eq.3) then + nstk_Am = nstk_Am + 1 + elseif(ktype.eq.4) then + nstk_Ar = nstk_Ar + 1 + elseif(ktype.eq.5) then + nstk_Ma = nstk_Ma + 1 + endif +c +c Count reports with stuck temperature, wind direction, and wind speed +c -------------------------------------------------------------------- + else + if(c_qc(ii)(6:6).eq.'K') then + kbadt(ktype) = kbadt(ktype) + 1 + endif + if(c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K') then + kbadw(ktype) = kbadw(ktype) + 1 + endif + endif +c + enddo +c + if(.not.l_operational) then + write(io33,*) + write(io33,*)' Number of stuck MDCRS reps rejected=',kbad(1) +ccccdak write(io33,*)' Number of stuck ACARS reps rejected=',kbad(2) + write(io33,*)' Number of stuck TAMDAR reps rejected=',kbad(2) + write(io33,*)' Number of stuck AMDAR reps rejected=',kbad(3) + write(io33,*)' Number of stuck AIREP reps rejected=',kbad(4) + write(io33,*)' Number of stuck manAIREP reps rejected=',kbad(5) + write(io33,*)' Number of stuck MDCRS temps marked=',kbadt(1) +ccccdak write(io33,*)' Number of stuck ACARS temps marked=',kbadt(2) + write(io33,*)' Number of stuck TAMDAR temps marked=',kbadt(2) + write(io33,*)' Number of stuck AMDAR temps marked=',kbadt(3) + write(io33,*)' Number of stuck AIREP temps marked=',kbadt(4) + write(io33,*)' Number of stuck manAIREP temps marked=',kbadt(5) + write(io33,*)' Number of stuck MDCRS winds marked=',kbadw(1) +ccccdak write(io33,*)' Number of stuck ACARS winds marked=',kbadw(2) + write(io33,*)' Number of stuck TAMDAR winds marked=',kbadw(2) + write(io33,*)' Number of stuck AMDAR winds marked=',kbadw(3) + write(io33,*)' Number of stuck AIREP winds marked=',kbadw(4) + write(io33,*)' Number of stuck manAIREP winds marked=',kbadw(5) + endif +c + write(io8,*) + write(io8,*) ' Reports with stuck values' + write(io8,*) ' -------------------------' + write(io8,*)' Number of stuck MDCRS reps rejected = ',kbad(1) +ccccdak write(io8,*)' Number of stuck ACARS reps rejected = ',kbad(2) + write(io8,*)' Number of stuck TAMDAR reps rejected = ',kbad(2) + write(io8,*)' Number of stuck AMDAR reps rejected = ',kbad(3) + write(io8,*)' Number of stuck AIREP reps rejected = ',kbad(4) + write(io8,*)' Number of stuck manAIREP reps rejected = ',kbad(5) + write(io8,*)' Number of stuck MDCRS temps marked = ',kbadt(1) +ccccdak write(io8,*)' Number of stuck ACARS temps marked = ',kbadt(2) + write(io8,*)' Number of stuck TAMDAR temps marked = ',kbadt(2) + write(io8,*)' Number of stuck AMDAR temps marked = ',kbadt(3) + write(io8,*)' Number of stuck AIREP temps marked = ',kbadt(4) + write(io8,*)' Number of stuck manAIREP temps marked = ',kbadt(5) + write(io8,*)' Number of stuck MDCRS winds marked = ',kbadw(1) +ccccdak write(io8,*)' Number of stuck ACARS winds marked = ',kbadw(2) + write(io8,*)' Number of stuck TAMDAR winds marked = ',kbadw(2) + write(io8,*)' Number of stuck AMDAR winds marked = ',kbadw(3) + write(io8,*)' Number of stuck AIREP winds marked = ',kbadw(4) + write(io8,*)' Number of stuck manAIREP winds marked = ',kbadw(5) +c +c Output reports with good moisture +c --------------------------------- + if(.not.l_operational) then + write(io33,*) + write(io33,*) 'Reports with valid moisture' + write(io33,*) '---------------------------' + write(io33,3001) + endif +c + do iob = 1,numreps + ii = indx(iob) +c + +cc smb 8/18/05 - ichk arrays were declared as reals, should have been integer +cc fixed 8/19/05. +cc if(l_ncep.and.ob_q(ii).eq.amiss) then +cc ichk_q(ii) = -9 +cc endif + + if(ob_q(ii).eq.amiss.and. + $ (ichk_q(ii).eq.-9.or. + $ ichk_q(ii).eq.9)) then +c +c missing moisture and QC flag signals missing data +c + elseif((ifix(ob_q(ii)*100).eq.0.or.ob_q(ii).eq.amiss).and. + $ ichk_q(ii).eq.-7.and. + $ (c_acftreg(ii)(4:5).eq.'WU'.or. + $ c_acftreg(ii)(4:5).eq.'GU')) then +c +c moisture qc flag = -7 means invalid input parameter +c + elseif(.not.l_operational) then + write(io33,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif + enddo +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers for reports with temp in whole deg' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nwhol_reg(mm,1)+nwhol_reg(mm,2)+nwhol_reg(mm,3) + $ +nwhol_reg(mm,4)+nwhol_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwhol_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers for reports with stuck temperature' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( ntemp_reg(mm,1)+ntemp_reg(mm,2)+ntemp_reg(mm,3) + $ +ntemp_reg(mm,4)+ntemp_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(ntemp_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers for reports with stuck winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,kk),kk=1,5) + endif + enddo +c + write(*,*) + write(*,*) 'Stuck value check data counts--',cdtg_an + write(*,*) '-----------------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(*,'('' Total invalid '',5(1x,i7))') + $ nstk_Md,nstk_Ac,nstk_Am,nstk_Ar,nstk_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Temps in wh deg'',5(1x,i7))') + $ (nstk_whol(ii),ii=1,5) + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Stuck value check data counts' + write(io8,*) '-----------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ nstk_Md,nstk_Ac,nstk_Am,nstk_Ar,nstk_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Temps in wh deg'',5(1x,i7))') + $ (nstk_whol(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,'(''Stuck time '',5(1x,i7))') + $ (nstk_time(ii),ii=1,5) + write(io8,'(''Stuck position '',5(1x,i7))') + $ (nstk_posn(ii),ii=1,5) + write(io8,'(''Stuck time&posn'',5(1x,i7))') + $ (nstk_both(ii),ii=1,5) + write(io8,'(''Stuck latitude '',5(1x,i7))') + $ (nstk_alat(ii),ii=1,5) + write(io8,'(''Stuck longitude'',5(1x,i7))') + $ (nstk_alon(ii),ii=1,5) + write(io8,'(''Stuck pressure '',5(1x,i7))') + $ (nstk_pres(ii),ii=1,5) + write(io8,'(''Stuck values '',5(1x,i7))') + $ (nstk_val(ii),ii=1,5) + write(io8,'(''Stuck temp '',5(1x,i7))') + $ (nstk_temp(ii),ii=1,5) + write(io8,'(''Stuck direction'',5(1x,i7))') + $ (nstk_wdir(ii),ii=1,5) + write(io8,'(''Stuck speed '',5(1x,i7))') + $ (nstk_wspd(ii),ii=1,5) + write(io8,'(''Stuck moisture '',5(1x,i7))') + $ (nstk_moist(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in stuck value check' +c + return + end +c +c ################################################################### +c subroutine grchek_qc +c ################################################################### +c + subroutine grchek_qc(numreps,max_reps,indx,csort,amiss,cdtg_an + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, cbadtemp,nbadtemp + $, cblkwind,nblkwind,cblktemp,nblktemp,kbadtot,io8,io34 + $, maxflt,kreg,creg_reg,nwhol_reg,nwind_reg + $, ft2m,l_operational,l_init) +c +c Perform gross checks on aircraft data +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + character*10 cdtg_an ! date time group for analysis + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail#s in dataset + $, mm ! index pointing to current tail number + integer maxflt ! max number of flights allowed + character*8 creg_reg(maxflt) ! tail numbers + integer nwhol_reg(maxflt,5) ! number of reports w. temp in whole deg + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Black list arrays +c ----------------- + integer nbadtemp ! # of acft with temps in whole degrees + $, nblkwind ! # of acft blacklisted for wind errors + $, nblktemp ! # of acft blacklisted for temp errors + character*8 cbadtemp(nbadtemp) ! acft reports temp in whole deg C + $, cblkwind(nblkwind) ! winds blacklisted + $, cblktemp(nblktemp) ! temperatures blacklisted +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io34 ! i/o unit number for gross errors +c + real amiss ! real missing value flag +c + integer iob ! do loop index + $, ii ! index pointing to current report + $, iim1 ! index pointing to previous report + $, iip1 ! index pointing to following report + integer idt1_00z ! relative time equal to 00Z (pos) + $, idt2_00z ! relative time equal to 00Z (neg) +c + integer nac ! do loop index + integer nrep(5) ! number of reports considered + integer kbad(5) ! counter for number of bad reports + $, n_sus_time(5) ! counter for suspect times + $, n_bad_pos(5) ! counter for bad latitudes or longitudes + $, n_sus_lat(5) ! counter for suspect latitudes + $, n_sus_lon(5) ! counter for suspect longitudes + $, n_sus_alt(5) ! counter for suspect altitudes + $, n_bad_alt(5) ! counter for bad altitudes/pressures + $, n_inc_alt(5) ! counter for inconsistent altitudes + $, n_bad_UAL(5) ! counter for bad UAL surface reports + $, n_list_temp(5) ! counter for black-listed temperatures + $, n_whole_temp(5) ! counter for whole-degree temperatures + $, n_mis_temp(5) ! counter for missing temperatures + $, n_bad_temp(5) ! counter for bad temperatures + $, n_cold_temp(5) ! counter for anomalous cold temperatures + $, n_list_wind(5) ! counter for black-listed winds + $, n_mis_dir(5) ! counter for missing directions + $, n_bad_dir(5) ! counter for bad directions + $, n_inc_dir(5) ! counter for inconsistent directions + $, n_mis_spd(5) ! counter for missing speeds + $, n_inc_spd(5) ! counter for inconsistent speeds + $, n_calm_spd(5) ! counter for rejected calm speeds + $, n_bad_spd(5) ! counter for bad speeds + $, n_mis_moist(5) ! counter for missing moisture + $, n_bad_moist(5) ! counter for bad moisture + $, n_sus_moist(5) ! counter for suspect moisture + $, n_bad_rep(5) ! counter for reports with both bad winds + ! and bad temperatures + $, kbadtot ! counter for total number of bad reps +c + real tmax ! max allowable temperature + $, tmin ! min allowable temperature + $, wmax ! max allowable windspeed + $, ft2m ! ft to meters conversion factor + $, height_ft ! computed height in feet + $, height_m ! computed height in meters + $, t ! temperature in centigrade + $, es ! saturation vapor pressure + $, qs ! saturation specific humidity +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + integer ktype ! instrument type index +c +c Switches +c -------- + logical l_print ! print values if true + $, l_init ! initialize counters if true +ccccdak $, l_ii_acars ! true if ii rep is type acars + $, l_ii_acars ! true if ii rep is type tamdar + $, l_ii_mdcrs ! true if ii rep is type mdcrs + $, l_ii_airep ! true if ii rep is type airep + $, l_ii_man ! true if ii rep is type manual airep + $, l_ii_amdar ! true if ii rep is type amdar + $, l_operational ! run QC in operational mode if true +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize variables +c -------------------- + if(l_init) then + nrep = 0 + n_sus_time = 0 + n_bad_pos = 0 + n_sus_lat = 0 + n_sus_lon = 0 + n_sus_alt = 0 + n_bad_alt = 0 + n_inc_alt = 0 + n_bad_UAL = 0 + n_list_temp = 0 + n_mis_temp = 0 + n_bad_temp = 0 + n_cold_temp = 0 + n_list_wind = 0 + n_mis_dir = 0 + n_bad_dir = 0 + n_inc_dir = 0 + n_mis_spd = 0 + n_inc_spd = 0 + n_calm_spd = 0 + n_bad_spd = 0 + n_mis_moist = 0 + n_bad_moist = 0 + n_sus_moist = 0 + n_bad_rep = 0 + n_whole_temp = 0 + kbad = 0 + endif +c + nwhol_reg = 0 + nwind_reg = 0 +c +c Compute relative time equal to 00z +c ---------------------------------- + read(cdtg_an,'(8x,i2)') idt1_00z + idt1_00z = idt1_00z * 3600 + idt2_00z = 0 - idt1_00z +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Loop over reports +c ----------------- + do iob=1,numreps + ii = indx(iob) + l_print = .false. +c +c Set up logical variables used in testing +c ---------------------------------------- + l_ii_mdcrs = .false. + l_ii_acars = .false. + l_ii_amdar = .false. + l_ii_airep = .false. + l_ii_man = .false. +c +c ii report is MDCRS? +c ------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_asc) then + l_ii_mdcrs = .true. + ktype = 1 +c +ccccdak report is ACARS? +c report is TAMDAR? +c ------------------- + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_asc) then + l_ii_acars = .true. + ktype = 2 +c +c ii report is AMDAR? +c ------------------- + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_asc) then + l_ii_amdar = .true. + ktype = 3 +c +c ii report is AIREP? +c ------------------- + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des.or. + $ itype(ii).eq.i_airep_asc) then + l_ii_airep = .true. + ktype = 4 +c +c ii report is manual AIREP? +c -------------------------- + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + l_ii_man = .true. + ktype = 5 + endif +c +c Compute height in feet from pressure for pressure/altitude check +c ---------------------------------------------------------------- + call p2ht_qc(pres(ii),height_m,amiss) + call ht2fl_qc(height_m,height_ft,amiss,ft2m) +c +c write(io8,*) 'p2ht test--tail#,pressure,computed ht,obs ht' +c write(io8,*) c_acftreg(ii),pres(ii),height_ft,ht_ft(ii) +c +c First perform checks that reject the whole report +c ------------------------------------------------- +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c Reject reports with unphysical latitudes +c ---------------------------------------- + if(alat(ii).gt.90.0.or.alat(ii).lt.-90.0) then + l_print = .true. + if(l_print) write(io8,*) 'Latitude bad' + c_qc(ii)(3:3) = 'B' + n_bad_pos(ktype) = n_bad_pos(ktype) + 1 +c +c Reject reports with unphysical longitudes +c ----------------------------------------- + elseif(alon(ii).gt.360.0.or.alon(ii).lt.0.0) then + l_print = .true. + if(l_print) write(io8,*) 'Longitude bad' + c_qc(ii)(4:4) = 'B' + n_bad_pos(ktype) = n_bad_pos(ktype) + 1 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Reject reports with unphysical or inconsistent pressures/altitudes +c ------------------------------------------------------------------ + elseif(pres(ii).gt.1080..or.pres(ii).lt.50.) then + l_print = .true. + if(l_print) write(io8,*) 'Pressure bad' + if(c_qc(ii)(5:5).eq.'R') pres(ii) = amiss + if(c_qc(ii)(5:5).eq.'r') ht_ft(ii) = amiss + c_qc(ii)(5:5) = 'B' + n_bad_alt(ktype) = n_bad_alt(ktype) + 1 +c + elseif(abs(height_ft-ht_ft(ii)).gt.25.0) then + l_print = .true. + if(l_print) write(io8,*) 'Pressure and height inconsistent' + c_qc(ii)(5:5) = 'I' + n_inc_alt(ktype) = n_inc_alt(ktype) + 1 +c +c Reject surface UAL aireps +c (1/27/00) These are actually erroneous reports from UAL Airbus A320/A319 +c aircraft that Tinker has incorrectly re-encoded into AIREP format. +c In these reports, the altitude is divided by 10, temperature is +c missing, the values listed as windspeed are actually wind +c direction, and it's not clear what is listed as wind direction. +c ----------------------------------------------------------------------------- + elseif((l_ii_man.or.l_ii_airep).and. + $ c_acftid(ii)(1:3).eq.'UAL'.and. + $ ht_ft(ii).lt.5000.0.and. + $ ob_t(ii).eq.amiss) then + l_print = .true. + if(l_print) write(io8,*) 'Bad UAL surface report' + c_qc(ii)(1:1) = 'B' + n_bad_UAL(ktype) = n_bad_UAL(ktype) + 1 +c +c Now, perform checks on individual parameters in remaining reports +c ----------------------------------------------------------------- + else +c +c Exclude missing temperatures +c ---------------------------- + if(ob_t(ii).eq.amiss) then +c l_print = .true. + if(l_print) write(io8,*) 'Temperature missing' + c_qc(ii)(6:6) = 'M' + n_mis_temp(ktype) = n_mis_temp(ktype) + 1 +c +c Check list of aircraft reporting temperature in whole deg +c Re-compute temperature to correct +c (Since most of the aircraft were fixed by mid-1999, stop +c doing this check after 1 Oct 1999) +c --------------------------------------------------------- + elseif(cdtg_an.lt.'1999100100') then + do nac = 1,nbadtemp + if(c_acftreg(ii).eq.cbadtemp(nac)) then +c l_print = .true. + if(l_print) write(io8,*)'On list with temp in whole deg' + c_qc(ii)(10:10) = 'C' +c +ccccdak Recompute temperature for ACARS or MDCRS reports +c Recompute temperature for TAMDAR or MDCRS reports +c (Since AIREPs are reported only to nearest degree, +c don't bother to recompute temperature--inadequate precision!) +c --------------------------------------------------------------------- +c +c Don't bother with temperatures already fixed or rejected +c -------------------------------------------------------- + if(c_qc(ii)(6:6).ne.'R'.and. + $ c_qc(ii)(6:6).ne.'b'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I'.and. + $ c_qc(ii)(6:6).ne.'K') then +c +c If temperatures are outside of limits, assume that the +c error was corrected on this aircraft +c ------------------------------------------------------ + if(ob_t(ii).lt.266.0.or.ob_t(ii).gt.278.0) then + l_print = .true. + if(l_print) then + write(io8,*) 'On list with temp in whole deg' + write(io8,*) ' Temperature not within bounds!!!' + endif +c +ccccdak If bad temperature occurred in an ACARS, MDCRS, or +c If bad temperature occurred in an TAMDAR, MDCRS, or +c AMDAR report, fix it +c --------------------------------------------------- + elseif(l_ii_acars.or.l_ii_mdcrs.or.l_ii_amdar) then + ob_t(ii) = (ob_t(ii) - 273.16) * 10. + 273.16 + l_print = .true. + if(l_print) write(io8,*) ' temperature recomputed' + t_prcn(ii) = 1.00 + c_qc(ii)(6:6) = 'R' + n_whole_temp(ktype) = n_whole_temp(ktype) + 1 +c +c Count number of whole-degree temps by tail number +c ------------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwhol_reg(mm,ktype) = nwhol_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c If bad temperature occurred in an AIREP, reject it +c -------------------------------------------------- + else + l_print = .true. + if(l_print) then + write(io8,*) 'On list with temp in whole deg' + write(io8,*) ' temperature marked bad' + endif + c_qc(ii)(6:6) = 'b' + n_whole_temp(ktype) = n_whole_temp(ktype) + 1 + endif + endif +c + endif + enddo + endif +c +c QC temperature--Moninger algorithm +c ---------------------------------- + if(c_qc(ii)(6:6).ne.'b'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I'.and. + $ c_qc(ii)(6:6).ne.'K'.and. + $ c_qc(ii)(6:6).ne.'B'.and. + $ c_qc(ii)(6:6).ne.'M') then +c +c Check for anomalously cold temperatures accompanied by missing winds +c -------------------------------------------------------------------- + if(ob_t(ii).lt.205.0.and. + $ ob_spd(ii).eq.amiss.and. + $ ob_dir(ii).eq.amiss) then + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Cold temperature with missing winds' + endif + c_qc(ii)(6:6) = 'B' + n_cold_temp(ktype) = n_cold_temp(ktype) + 1 +c +c QC upper-level temperatures +c --------------------------- + else + if(ht_ft(ii).gt.35000.) then + if(ob_t(ii).gt.253.16-0.005.or. + $ ob_t(ii).lt.173.15+0.005) then + l_print = .true. + if(l_print) write(io8,*) 'Temperature bad--173 253' + c_qc(ii)(6:6) = 'B' + n_bad_temp(ktype) = n_bad_temp(ktype) + 1 +c + else + if(c_qc(ii)(6:6).eq.'-') c_qc(ii)(6:6) = '.' + endif +c +c QC lower-level temperatures +c --------------------------- + else + tmax = 60. - 80. * (ht_ft(ii) / 35000.) + tmax = tmax + 273.16 + tmin = -60. - 40. * (ht_ft(ii) - 18000.) / 17000. + tmin = tmin + 273.16 + if(ht_ft(ii).lt.18000.) tmin = 213.16 + if(ob_t(ii).gt.tmax.or.ob_t(ii).lt.tmin) then + l_print = .true. + if(l_print) write(io8,*) 'Temperature bad--',tmin,tmax + c_qc(ii)(6:6) = 'B' + n_bad_temp(ktype) = n_bad_temp(ktype) + 1 +c + else + if(c_qc(ii)(6:6).eq.'-') c_qc(ii)(6:6) = '.' + endif + endif + endif + endif +c +c Check if aircraft is on black list for temp errors +c -------------------------------------------------- + if(c_qc(ii)(10:10).eq.'-') c_qc(ii)(10:10) = '.' +c + do nac = 1,nblktemp + if(c_acftreg(ii).eq.cblktemp(nac)) then +c l_print = .true. + if(l_print) write(io8,*) 'Black-listed for temp errors' + c_qc(ii)(10:10) = 'T' + n_list_temp(ktype) = n_list_temp(ktype) + 1 + endif + enddo +cc +cc QC temperature--RAOB algorithm +cc ------------------------------ +c if(ob_t(ii).ne.amiss) then +cc $ c_qc(ii)(6:6).ne.'b'.and. +cc $ c_qc(ii)(6:6).ne.'E'.and. +cc $ c_qc(ii)(6:6).ne.'I'.and. +cc $ c_qc(ii)(6:6).ne.'K') then +c +c if(pres(ii).le.300.0.or. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c $ (pres(ii).le.400.0.and.alat(ii).gt.45.0)) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c if(ob_t(ii).le.173.15.or.ob_t(ii).ge.268.15) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +cc +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c elseif(abs(alat(ii)).le.45.0) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c if(pres(ii).le.400.) then +c tmax = 268.15 + (pres(ii) - 300.) / 100. * 5.0 +c if(ob_t(ii).le.173.15.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.500.0) then +c tmin = 173.16 + (pres(ii) - 400.) / 100. * 5.0 +c tmax = 273.16 + (pres(ii) - 400.) / 100. * 10.0 +c if(ob_t(ii).le.tmin.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.700.0) then +c tmin = 178.15 + (pres(ii) - 500.) / 200. * 15.0 +c tmax = 283.15 + (pres(ii) - 500.) / 200. * 20.0 +c if(ob_t(ii).le.tmin.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.850.0) then +c tmin = 193.15 + (pres(ii) - 700.) / 150. * 15.0 +c tmax = 303.15 + (pres(ii) - 700.) / 150. * 10.0 +c if(ob_t(ii).le.tmin.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.1000.0) then +c tmin = 208.15 + (pres(ii) - 850.) / 150. * 15.0 +c tmax = 313.15 + (pres(ii) - 850.) / 150. * 20.0 +c if(ob_t(ii).le.tmin.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).gt.1000.0) then +c if(ob_t(ii).le.223.15.or.ob_t(ii).ge.333.15) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c endif +cc +c else +c if(pres(ii).le.500.0) then +c tmax = 268.15 + (pres(ii) - 400.) / 100. * 10.0 +c if(ob_t(ii).le.173.15.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.700.0) then +c tmin = 173.15 + (pres(ii) - 500.) / 200. * 10.0 +c tmax = 278.15 + (pres(ii) - 500.) / 200. * 15.0 +c if(ob_t(ii).le.tmin.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.850.0) then +c tmax = 293.15 + (pres(ii) - 700.) / 150. * 10.0 +c if(ob_t(ii).le.183.15.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).le.1000.0) then +c tmax = 303.15 + (pres(ii) - 850.) / 150. * 20.0 +c if(ob_t(ii).le.183.15.or.ob_t(ii).ge.tmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c elseif(pres(ii).gt.1000.0) then +c if(ob_t(ii).le.183.15.or.ob_t(ii).ge.323.15) then +c l_print = .true. +c if(l_print) write(io8,*) 'Temperature bad by RAOB check' +c if(l_print.and.c_qc(ii)(6:6).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c endif +c +c endif +c endif +c +c Perform remaining tests only if temperature not rejected +c -------------------------------------------------------- + if(c_qc(ii)(6:6).ne.'B') then +cc +cc Check list of aircraft flipping winds +cc (Test skipped since list of aircraft used actual tail numbers +cc rather than pseudo-numbers!) +cc ------------------------------------- +c do nac = 1,nbadwind +c if(c_acftreg(ii).eq.cbadwind(nac)) then +c write(io8,*) +c write(io8,*) c_acftreg(ii),' in rep # ',ii, +c $ ' on list of acft with flipped winds' +c c_qc(ii)(10:10) = 'F' +c endif +c enddo +cc +cc Check list of aircraft reporting decimal lat/lons +cc No correction performed at present +cc (Test skipped since list of aircraft used actual tail numbers +cc rather than the pseudo-numbers used currently!) +cc ------------------------------------------------------------- +c do nac = 1,nbadlat +c if(c_acftreg(ii).eq.cbadlat(nac)) then +c write(io8,*) +c write(io8,*) c_acftreg(ii),' in rep # ',ii, +c $ ' on list of acft with decimal lat/lons' +c c_qc(ii)(10:10) = 'L' +c endif +c enddo +c +c QC relative time +c ---------------- + if(idt(ii).eq.idt1_00z.or. + $ idt(ii).eq.idt2_00z) then +c l_print = .true. + if(l_print) write(io8,*) 'Time equal to 00Z' + c_qc(ii)(2:2) = 'S' + n_sus_time(ktype) = n_sus_time(ktype) + 1 + else + if(c_qc(ii)(2:2).eq.'-') c_qc(ii)(2:2) = '.' + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c QC latitude +c ----------- + if(abs(alat(ii)).lt.0.005) then + l_print = .false. + if(l_print) write(io8,*) 'Latitude zero' + c_qc(ii)(3:3) = 'S' + n_sus_lat(ktype) = n_sus_lat(ktype) + 1 + else + if(c_qc(ii)(3:3).eq.'-') c_qc(ii)(3:3) = '.' + endif +c +c QC longitude +c ------------ + if(abs(alon(ii)).lt.0.005) then + l_print = .false. + if(l_print) write(io8,*) 'Longitude zero' + c_qc(ii)(4:4) = 'S' + n_sus_lon(ktype) = n_sus_lon(ktype) + 1 + else + if(c_qc(ii)(4:4).eq.'-') c_qc(ii)(4:4) = '.' + endif +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Set zero altitude to suspect +c ---------------------------- + if(abs(ht_ft(ii)).lt.0.5) then + l_print = .true. + if(l_print) write(io8,*) 'Altitude zero' + c_qc(ii)(5:5) = 'S' + n_sus_alt(ktype) = n_sus_alt(ktype) + 1 + else + if(c_qc(ii)(5:5).eq.'-') c_qc(ii)(5:5) = '.' + endif +c +c QC winds--Moninger algorithm +c ---------------------------- +c +c QC direction +c ------------ +c if(ob_dir(ii).eq.0.0) then +c ob_dir(ii) = 360. +c + if(ob_dir(ii).eq.amiss) then +c l_print = .true. + if(l_print) write(io8,*) 'Wind direction missing' + c_qc(ii)(7:7) = 'M' + n_mis_dir(ktype) = n_mis_dir(ktype) + 1 +c + elseif(c_qc(ii)(7:7).ne.'K'.and. + $ c_qc(ii)(7:7).ne.'E'.and. + $ c_qc(ii)(7:7).ne.'B') then + if(ob_dir(ii).lt.0.0.or.ob_dir(ii).gt.360.0) then + l_print = .true. + if(l_print) write(io8,*) 'Wind direction bad',ob_dir(ii) + c_qc(ii)(7:7) = 'B' + n_bad_dir(ktype) = n_bad_dir(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c + else + if(c_qc(ii)(7:7).eq.'-') c_qc(ii)(7:7) = '.' + endif + endif +c +c QC speed +c -------- +c +c First flag missing wind speeds +c ------------------------------ + if(ob_spd(ii).eq.amiss) then +c l_print = .true. + if(l_print) write(io8,*) 'Wind speed missing' + c_qc(ii)(8:8) = 'M' + n_mis_spd(ktype) = n_mis_spd(ktype) + 1 +c +c Flag inconsistent directions--speed missing, direction not +c ---------------------------------------------------------- + if(c_qc(ii)(7:7).ne.'M'.and. + $ c_qc(ii)(7:7).ne.'B'.and. + $ c_qc(ii)(7:7).ne.'E'.and. + $ c_qc(ii)(7:7).ne.'K') then +c l_print = .true. + if(l_print) write(io8,*) 'Wind direction not missing' + c_qc(ii)(7:7) = 'I' + n_inc_dir(ktype) = n_inc_dir(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c + endif +c +c Exclude previously rejected wind speeds +c --------------------------------------- + elseif(c_qc(ii)(8:8).ne.'K'.and. + $ c_qc(ii)(8:8).ne.'E') then +c +c Flag inconsistent speeds--direction missing, speed not +c ------------------------------------------------------ + if(ob_dir(ii).eq.amiss) then +c l_print = .true. + if(l_print) write(io8,*) 'Wind speed not missing' + c_qc(ii)(8:8) = 'I' + n_inc_spd(ktype) = n_inc_spd(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c Flag negative winds speeds +c -------------------------- + elseif(ob_spd(ii).lt.0.0) then + l_print = .true. + if(l_print) write(io8,*) 'Wind speed negative' + c_qc(ii)(8:8) = 'B' + n_bad_spd(ktype) = n_bad_spd(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c Reject all calm winds +c --------------------- + elseif(ob_spd(ii).lt.0.05.and. + $ ob_dir(ii).lt.0.05) then +c if(pres(ii).lt.700.) l_print = .true. + l_print = .false. + if(l_print) write(io8,*) 'Wind speed and direction zero' + c_qc(ii)(8:8) = 'B' + n_calm_spd(ktype) = n_calm_spd(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c QC wind speeds +c -------------- + else + if(ht_ft(ii).lt.30000.) then + wmax = 70. + 230. * ht_ft(ii) / 30000. + elseif(ht_ft(ii).lt.40000.) then + wmax = 300. + elseif(ht_ft(ii).lt.45000.) then + wmax = 300. - 100. * (ht_ft(ii) - 40000.) / 5000. + else + wmax = 200. + endif + wmax = wmax * 0.5144 ! convert max from knots to m/s + if(ob_spd(ii).gt.wmax) then + l_print = .true. + if(l_print) write(io8,*) 'Wind speed > wmax = ',wmax + c_qc(ii)(8:8) = 'B' + n_bad_spd(ktype) = n_bad_spd(ktype) + 1 +c +c Count number of rejected winds by tail number +c --------------------------------------------- + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c + else + if(c_qc(ii)(8:8).eq.'-') c_qc(ii)(8:8) = '.' + endif + endif + endif +c +c Check if aircraft is on black list for wind errors +c -------------------------------------------------- + do nac = 1,nblkwind + if(c_acftreg(ii).eq.cblkwind(nac)) then +c l_print = .true. + if(l_print) write(io8,*) 'Black-listed for wind errors' +c + if(c_qc(ii)(10:10).eq.'T') then + c_qc(ii)(10:10) = 'O' + else + c_qc(ii)(10:10) = 'W' + endif + n_list_wind(ktype) = n_list_wind(ktype) + 1 + endif + enddo +cc +cc QC speed--RAOB algorithm +cc ------------------------ +c if(ob_spd(ii).ne.amiss.and. +c $ ob_spd(ii).ne.0.0.and. +c $ c_qc(ii)(8:8).ne.'K'.and. +c $ c_qc(ii)(8:8).ne.'E') then +cc +c if(pres(ii).ge.700.0) then +c if(ob_spd(ii).gt.100.0) then +c l_print = .true. +c if(l_print) write(io8,*) 'Windspeed bad by RAOB check' +c if(l_print.and.c_qc(ii)(8:8).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +cc +c elseif(pres(ii).ge.500.0) then +c wmax = 100.0 + (700.0 - pres(ii)) / 200. * 20.0 +c if(ob_spd(ii).ge.wmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Windspeed bad by RAOB check' +c if(l_print.and.c_qc(ii)(8:8).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +cc +c elseif(pres(ii).ge.300.0) then +c wmax = 120.0 + (500.0 - pres(ii)) / 200. * 60.0 +c if(ob_spd(ii).ge.wmax) then +c l_print = .true. +c if(l_print) write(io8,*) 'Windspeed bad by RAOB check' +c if(l_print.and.c_qc(ii)(8:8).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +cc +c elseif(pres(ii).ge.200.0) then +c if(ob_spd(ii).ge.180.0) then +c l_print = .true. +c if(l_print) write(io8,*) 'Windspeed bad by RAOB check' +c if(l_print.and.c_qc(ii)(8:8).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +cc +c elseif(pres(ii).ge.100.0) then +c if(ob_spd(ii).ge.170.0) then +c l_print = .true. +c if(l_print) write(io8,*) 'Windspeed bad by RAOB check' +c if(l_print.and.c_qc(ii)(8:8).ne.'B') +c $ write(io8,*) ' Report not rejected by Moninger check' +c endif +c endif +c endif +c +c QC moisture +c ----------- +c +c Exclude values already flagged as constant +c ------------------------------------------ + if(c_qc(ii)(9:9).ne.'K') then +c +c Check for missing values +c (treat moisture qc flag = 1 (non-measurement mode) as missing) +c (treat moisture qc flag = 9 (sensor not installed) as missing) +c -------------------------------------------------------------- + if(ob_q(ii).eq.amiss.or. + $ ichk_q(ii).eq.-9.or. + $ ichk_q(ii).eq.9.or. + $ ichk_q(ii).eq.-1) then +c +c l_print = .true. + if(l_print) write(io8,*) 'Moisture not present' + c_qc(ii)(9:9) = 'M' + n_mis_moist(ktype) = n_mis_moist(ktype) + 1 +c +c Assume zero moisture with qc flag of 7 signify missing ob +c --------------------------------------------------------- + elseif(ob_q(ii).lt.0.005.and.ichk_q(ii).eq.-7) then +c +c l_print = .true. + if(l_print) write(io8,*) 'Moisture not present, = 0' + c_qc(ii)(9:9) = 'M' + n_mis_moist(ktype) = n_mis_moist(ktype) + 1 +c +c QC remaining values +c ------------------- + else +c + if(ichk_q(ii).ne. 0.and. + $ ichk_q(ii).ne.-2.and. + $ ichk_q(ii).ne.-3.and. + $ ichk_q(ii).ne.-4.and. + $ ichk_q(ii).ne.-5.and. + $ ichk_q(ii).ne.-6.and. + $ ichk_q(ii).ne.-7.and. + $ ichk_q(ii).ne.-8.and. + $ ichk_q(ii).ne.908) l_print = .true. +c + if(l_print) + $ write(io8,*) 'Moisture qc flag = ',ichk_q(ii),ii +c +c Compute saturation specific humidity to test for supersaturation +c Reference: http://www.ofcm.gov/fmh3/text/appendd.htm +c ---------------------------------------------------------------- + if(c_qc(ii)(6:6).ne.'K'.and. + $ c_qc(ii)(6:6).ne.'E'.and. + $ c_qc(ii)(6:6).ne.'I'.and. + $ c_qc(ii)(6:6).ne.'M'.and. + $ c_qc(ii)(6:6).ne.'B'.and. + $ c_qc(ii)(6:6).ne.'b'.and. + $ c_qc(ii)(10:10).ne.'T'.and. + $ c_qc(ii)(10:10).ne.'O') then +c + t = ob_t(ii) - 273.16 +c temperature in centigrade + es = 6.1121 * exp( (17.502 * t) / (t + 240.97) ) +c saturation vapor pressure + qs = .622 * es / pres(ii) * 1000. +c saturation specific humidity (g/kg) + else + qs = amiss + endif +c +c Examine values of moisture qc flag +c (meaning of flag values is from BUFR table 0 33 26) +c (1 => Normal operations--non-measurement mode) +c (9 => Sensor not installed) +c (10-62 are reserved values; 63 => missing value) +c --------------------------------------------------- + if(ichk_q(ii).eq.-2) then + if(l_print) write(io8,*) ' Small RH' + c_qc(ii)(9:9) = '2' +c + elseif(ichk_q(ii).eq.-3) then + if(l_print) write(io8,*) ' Element wet' + c_qc(ii)(9:9) = '3' +c + elseif(ichk_q(ii).eq.-4) then + if(l_print) write(io8,*) ' Element contaminated' + c_qc(ii)(9:9) = 'B' + n_bad_moist(ktype) = n_bad_moist(ktype) + 1 +c + elseif(ichk_q(ii).eq.-5) then + if(l_print) write(io8,*) ' Heater failed' + c_qc(ii)(9:9) = 'B' + n_bad_moist(ktype) = n_bad_moist(ktype) + 1 +c + elseif(ichk_q(ii).eq.-6) then + if(l_print) + $ write(io8,*) ' Heater failed, wet/contam. element' + c_qc(ii)(9:9) = 'B' + n_bad_moist(ktype) = n_bad_moist(ktype) + 1 +c + elseif(ichk_q(ii).eq.-7) then + if(l_print) write(io8,*) ' Invalid input parameters ' + c_qc(ii)(9:9) = 'B' + n_bad_moist(ktype) = n_bad_moist(ktype) + 1 +c + elseif(ichk_q(ii).eq.-8) then + if(l_print) write(io8,*) ' Numeric error' + c_qc(ii)(9:9) = 'B' + n_bad_moist(ktype) = n_bad_moist(ktype) + 1 +c + elseif(qs.eq.amiss) then + if(l_print) write(io8,*) ' Cannot check supersat.' + c_qc(ii)(9:9) = 'N' +c + elseif(ob_q(ii)-qs.gt.0.01) then + l_print = .true. + if(l_print) + $ write(io8,*) ' Supersaturation present--qs = ',qs + c_qc(ii)(9:9) = 'S' + n_sus_moist(ktype) = n_sus_moist(ktype) + 1 +c + else + if(c_qc(ii)(9:9).eq.'-') c_qc(ii)(9:9) = '.' + endif + endif + endif + endif + endif +c +c Print offending report with neighbors if desired +c ------------------------------------------------ + if(l_print) then +c + if(iob.eq.1) then + iim1 = 0 + else + iim1 = indx(iob-1) + endif +c + if(iob.eq.numreps) then + iip1 = 0 + else + iip1 = indx(iob+1) + endif +c + if(iim1.ne.0) write (io8,8001) iim1,c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1),pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1),csort(iim1) +c + write (io8,8001) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii),pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii),csort(ii) +c + if(iip1.ne.0) write (io8,8001) iip1,c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1),pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1),csort(iip1) +c + 8001 format(i6,1x,a8,1x,a8,1x,a9,1x + x, i7,1x,2f11.5,1x,f8.1,1x,f7.0,1x + x, f5.2,4(2(1x,f8.2),1x,i5) + x, 1x,'!',a11,'!',1x,a25) + write(io8,*) + endif +c +c End loop over reports +c --------------------- + enddo +c +c Write out and count bad data here +c --------------------------------- + write(io34,*) + write(io34,*) 'Data that failed gross checks' + write(io34,*) '(rejected reports not included subsequently' + write(io34,*) '-------------------------------------------' + write(io34,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') +c +c Loop over obs +c ------------- + do iob=1,numreps + ii = indx(iob) +c + l_print = .false. +c +c Set index +c --------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 +c + else + write(io8,*) + write(io8,*) 'Bad itype: ',itype(ii),' for ii = ',ii + ktype = 5 + endif +c +c Add up number of reports considered +c ----------------------------------- + nrep(ktype) = nrep(ktype) + 1 +c +c Rejected reports +c ---------------- + if(c_qc(ii)(3:3).eq.'B'.or. + $ c_qc(ii)(4:4).eq.'B'.or. + $ c_qc(ii)(5:5).eq.'B'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(1:1).eq.'B'.or. + $ c_qc(ii)(6:6).eq.'B') then +c + csort(ii)(1:5) = 'badob' +c +c Invalid reports--no data +c ------------------------ + elseif((c_qc(ii)(6:6).eq.'K'.or. + $ c_qc(ii)(10:10).eq.'T'.or. + $ c_qc(ii)(10:10).eq.'O'.or. + $ c_qc(ii)(6:6).eq.'M'.or. + $ c_qc(ii)(6:6).eq.'E'.or. + $ c_qc(ii)(6:6).eq.'I'.or. + $ c_qc(ii)(6:6).eq.'B'.or. + $ c_qc(ii)(6:6).eq.'b').and. +c + $ (c_qc(ii)(7:7).eq.'K'.or. + $ c_qc(ii)(8:8).eq.'K'.or. + $ c_qc(ii)(10:10).eq.'W'.or. + $ c_qc(ii)(10:10).eq.'O'.or. + $ c_qc(ii)(7:7).eq.'M'.or. + $ c_qc(ii)(8:8).eq.'M'.or. + $ c_qc(ii)(7:7).eq.'E'.or. + $ c_qc(ii)(8:8).eq.'E'.or. + $ c_qc(ii)(7:7).eq.'B'.or. + $ c_qc(ii)(8:8).eq.'B'.or. + $ c_qc(ii)(7:7).eq.'I'.or. + $ c_qc(ii)(8:8).eq.'I')) then +c + csort(ii)(1:5) = 'badob' + n_bad_rep(ktype) = n_bad_rep(ktype) + 1 +c + endif +c +c Output and count rejected obs +c ----------------------------- + if(.not.l_operational) then +c + if(csort(ii)(1:5).eq.'badob') then + kbad(ktype) = kbad(ktype) + 1 +c + write(io34,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii),pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x + x, i7,1x,2f11.5,1x,f8.1,1x,f7.0,1x + x, f5.2,4(2(1x,f8.2),1x,i5) + x, 1x,'!',a11,'!') + endif + endif +c + enddo +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers for reports with temp in whole deg' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nwhol_reg(mm,1)+nwhol_reg(mm,2)+nwhol_reg(mm,3) + $ +nwhol_reg(mm,4)+nwhol_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwhol_reg(mm,ii),ii=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers for reports with bad winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' -------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,ii),ii=1,5) + endif + enddo +c + write(*,*) + write(*,*) 'Gross check data counts--',cdtg_an + write(*,*) '-----------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ (nrep(ii),ii=1,5) + write(*,'('' Total rejected '',5(1x,i7))') + $ (kbad(ii),ii=1,5) + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + if(.not.l_operational) then + write(io34,*) + write(io34,*) 'Gross check data counts' + write(io34,*) '-----------------------' + write(io34,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io34,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io34,'(''Num considered '',5(1x,i7))') + $ (nrep(ii),ii=1,5) + write(io34,'(''Total rejected '',5(1x,i7))') + $ (kbad(ii),ii=1,5) + write(io34,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + endif +c + write(io8,*) + write(io8,*) 'Gross check data counts' + write(io8,*) '-----------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ (nrep(ii),ii=1,5) + write(io8,'(''Total rejected '',5(1x,i7))') + $ (kbad(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,'(''Bad lat/lon '',5(1x,i7))') + $ (n_bad_pos(ii),ii=1,5) + write(io8,'(''Bad alt '',5(1x,i7))') + $ (n_bad_alt(ii),ii=1,5) + write(io8,'(''Incons alt '',5(1x,i7))') + $ (n_inc_alt(ii),ii=1,5) + write(io8,'(''Bad sfc UAL '',5(1x,i7))') + $ (n_bad_UAL(ii),ii=1,5) + write(io8,'(''Bad temp '',5(1x,i7))') + $ (n_bad_temp(ii),ii=1,5) + write(io8,'(''Cold temp '',5(1x,i7))') + $ (n_cold_temp(ii),ii=1,5) + write(io8,'(''Report bad '',5(1x,i7))') + $ (n_bad_rep(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Wh-deg temp '',5(1x,i7))') + $ (n_whole_temp(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Bad dir '',5(1x,i7))') + $ (n_bad_dir(ii),ii=1,5) + write(io8,'(''Incons dir '',5(1x,i7))') + $ (n_inc_dir(ii),ii=1,5) + write(io8,'(''Bad spd '',5(1x,i7))') + $ (n_bad_spd(ii),ii=1,5) + write(io8,'(''Calm spd '',5(1x,i7))') + $ (n_calm_spd(ii),ii=1,5) + write(io8,'(''Incons spd '',5(1x,i7))') + $ (n_inc_spd(ii),ii=1,5) + write(io8,'(''Bad moist '',5(1x,i7))') + $ (n_bad_moist(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Listed temp '',5(1x,i7))') + $ (n_list_temp(ii),ii=1,5) + write(io8,'(''Listed wind '',5(1x,i7))') + $ (n_list_wind(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Missing temp '',5(1x,i7))') + $ (n_mis_temp(ii),ii=1,5) + write(io8,'(''Missing dir '',5(1x,i7))') + $ (n_mis_dir(ii),ii=1,5) + write(io8,'(''Missing spd '',5(1x,i7))') + $ (n_mis_spd(ii),ii=1,5) + write(io8,'(''Missing moist '',5(1x,i7))') + $ (n_mis_moist(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Suspect time '',5(1x,i7))') + $ (n_sus_time(ii),ii=1,5) + write(io8,'(''Suspect lat '',5(1x,i7))') + $ (n_sus_lat(ii),ii=1,5) + write(io8,'(''Suspect lon '',5(1x,i7))') + $ (n_sus_lon(ii),ii=1,5) + write(io8,'(''Suspect alt '',5(1x,i7))') + $ (n_sus_alt(ii),ii=1,5) + write(io8,'(''Suspect moist '',5(1x,i7))') + $ (n_sus_moist(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in gross check' +c + return + end +c +c ################################################################### +c subroutine poschek_qc +c ################################################################### +c + subroutine poschek_qc(numreps,max_reps,indx,csort,imiss,amiss + $, idt_updn,c_acftreg,c_acftid,cidmiss,c_qc,cdtg_an + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kflight,maxflt,nobs_flt,iobs_flt,kbadtot,io8,io35 + $, l_operational,l_init) +c +c Check near duplicate reports with different positions/altitudes/times +c and pick the best one +c Also, look for redundant data and reject it +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + character*10 cdtg_an ! date time group for analysis + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer + real gcirc_qc ! function to compute great circle distances +c +c Flight statistics +c ----------------- + integer maxflt ! max number of flights allowed + integer nobs_flt(maxflt) ! number of reports per flight + $, iobs_flt(maxflt) ! index for first report in each flight + $, kflight ! number of flights in dataset + integer istart ! index for 1st rep in current flight + $, iistart ! index from pointer array for istart + $, iend ! index for last rep in current flight + $, iiend ! index from pointer array for iend +c +c Counters +c -------- + integer ninc_xtra(5) ! number of redundant reports + $, ninc_way(5) ! number of duplicate reports with waypoint errors + $, ninc_alt(5) ! number of duplicate reports with altitude errors + $, ninc_stk(5) ! number of reports with stuck times + $, ninc_time(5) ! number of reports with stuck times + $, ninc_avg(5) ! number of reports with averaged position or time + $, ninc_bad(5) ! number of reports with inconsistent positions + integer kbad(5) ! counter for number of bad reports + $, kbadtot ! counter for total number of bad reports +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak integer ninc_Ac ! number of acars reports rejected + integer ninc_Ac ! number of tamdar reports rejected + $, ninc_Md ! number of mdcrs reports rejected + $, ninc_Ma ! number of manual airep reports rejected + $, ninc_Ar ! number of airep reports rejected + $, ninc_Am ! number of amdar reports rejected +c +c Instrument types +c ---------------- +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io35 ! i/o unit number for position check +c + real amiss ! real missing value flag +c + integer iob,kk ! do loop indices + $, ii ! index pointing to current report + $, iim1 ! index pointing to previous report + $, iim2 ! index pointing to 2nd report previous + $, iip1 ! index pointing to following report + $, knt1 ! counter used to define iim1 index + $, knt2 ! counter used to define iim2 index + integer iht0 ! integer ht_ft(ii) + $, ihtm1 ! integer ht_ft(iim1) + integer ihtdif0 ! height difference (current - previous) + integer imiss ! integer missing value flag + $, idt_dif ! time difference (current - previous report) + $, idt_difp1 ! time difference (following - current report) + $, idt_tot ! time between iim2 and iip1 points + integer idt_updn ! time difference to check ascents/descents + $, idt_stk ! time clock is stuck at +c + integer ktype ! ob type +c + real*8 alat_dif ! difference in latitude + $, alon0 ! longitude at point ii + $, alonm2 ! longitude at point iim2 + $, alonp1 ! longitude at point iip1 + $, alon_dif ! difference in longitude + real diff0 ! difference between points ii and iim1 + $, diffm1 ! difference between points iim1 and iip1 + $, difdir ! direction difference + real*8 alat_est ! estimated latitude + $, alon_est ! estimated longitude + real time_est ! estimated time + $, dist_tot ! estimated distance between iim2 and iip1 points + $, dist_ii ! estimated distance between "est" and ii points + $, dist_iim1 ! estimated distance between "est" and iim1 points +c + character*8 cidmiss ! missing value flag for flight number +c +c Switches +c -------- + logical l_print ! true for printing two reports used in check +c + logical l_init ! initialize counters if true + $, stuck ! true if stuck clock found + $, l_operational ! true if operational mode used +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + ninc_xtra = 0 + ninc_way = 0 + ninc_alt = 0 + ninc_stk = 0 + ninc_time = 0 + ninc_avg = 0 + ninc_bad = 0 + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + ninc_Ac = 0 + ninc_Md = 0 + ninc_Ma = 0 + ninc_Ar = 0 + ninc_Am = 0 + endif +c +c Begin loop over flights +c ----------------------- + do kk = 1,kflight +c +c Initialize variables +c -------------------- + stuck = .false. + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) + l_print = .false. +c +c Check two-report manAIREP flights +c --------------------------------- + if(nobs_flt(kk).eq.2.and. + $ (itype(iistart).eq.i_man_airep.or. + $ itype(iistart).eq.i_man_Yairep).and. + $ (itype(iiend).eq.i_man_airep.or. + $ itype(iiend).eq.i_man_Yairep).and. + $ abs(ob_t(iistart)-ob_t(iiend)).lt.1.25.and. + $ abs(ob_dir(iistart)-ob_dir(iiend)).lt.10.5.and. + $ abs(ob_spd(iistart)-ob_spd(iiend)).lt.1.25) then +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c Check for position discrepancies +c -------------------------------- + if((abs(alat(iistart)-alat(iiend)).gt.0.125.or. + $ abs(alon(iistart)-alon(iiend)).gt.0.125).and. + $ abs(ht_ft(iistart)-ht_ft(iiend)).lt.1.5.and. + $ idt(iistart).eq.idt(iiend)) then +c + dist_tot = gcirc_qc(alat(iistart),alon(iistart), + $ alat(iiend), alon(iiend)) + dist_tot = dist_tot / 1000. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in position for 2-rep flight' + write(io8,*) 'dist_tot = ',dist_tot + endif +c +c If points are close together, average the position +c -------------------------------------------------- + if(dist_tot.lt.115.0) then + if(l_print) then + write(io8,*) 'points close--averaging' + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat(iistart) = (alat(iistart)+alat(iiend))/2.0 + alon(iistart) = (alon(iistart)+alon(iiend))/2.0 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + c_qc(iistart)(3:4) = 'RR' + c_qc(iiend)(1:1) = 'W' + c_qc(iiend)(3:4) = 'BB' +c + else + c_qc(iistart)(1:1) = 'W' + c_qc(iistart)(3:4) = 'BB' + c_qc(iiend)(1:1) = 'W' + c_qc(iiend)(3:4) = 'BB' + endif +c +c Check for altitude discrepancies +c -------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif((abs(alat(iistart)-alat(iiend)).lt.0.125.or. + $ abs(alon(iistart)-alon(iiend)).lt.0.125).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iistart)-ht_ft(iiend)).gt.1000..and. + $ idt(iistart).eq.idt(iiend)) then +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in altitude for 2-rep flight' + endif +c + c_qc(iistart)(1:1) = 'A' + c_qc(iistart)(5:5) = 'B' + c_qc(iiend)(1:1) = 'A' + c_qc(iiend)(5:5) = 'B' +c +c Check for time discrepancies +c ---------------------------- + elseif(idt(iistart).ne.idt(iiend).and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iistart)-alat(iiend)).lt.0.125.and. + $ abs(alon(iistart)-alon(iiend)).lt.0.125.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iistart)-ht_ft(iiend)).lt.50.5) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in time for 2-rep flight' + endif +c +c If points are close in time, average times +c ------------------------------------------ + if(abs(idt(iistart)-idt(iiend)).lt.1800.0) then +c + if(l_print) then + write(io8,*) 'points close--averaging' + endif +c + idt(iiend) = (idt(iiend)+idt(iistart))/2 + c_qc(iiend)(2:2) = 'R' + c_qc(iistart)(1:1) = 't' + c_qc(iistart)(2:2) = 'B' +c +c Otherwise reject both points +c ---------------------------- + else + c_qc(iistart)(1:1) = 't' + c_qc(iistart)(2:2) = 'B' + c_qc(iiend)(1:1) = 't' + c_qc(iiend)(2:2) = 'B' + endif + endif +c +c Print both reports if desired +c ----------------------------- + if(l_print) then + iim1 = iistart + ii = iiend + write(io8,8002) kk,iim1 + x, c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 8002 format(i4,1x,i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Otherwise, examine only "real" flights with at least three reports +c ------------------------------------------------------------------ + elseif(c_acftid(iistart)(1:8).ne.cidmiss(1:8).and. + $ nobs_flt(kk).ge.3) then +c +c Begin loop over reports +c ----------------------- + do iob = istart+1,iend + l_print = .false. +c + ii = indx(iob) +c +c Compute ii+1 index +c ------------------ + if(iob.lt.iend) then + iip1 = indx(iob+1) + else + iip1 = 0 + endif +c +c Compute ii-1 index +c ------------------ + knt1 = iob - 1 + 10 if(knt1.ge.istart) then + iim1 = indx(knt1) + if(c_qc(iim1)(1:1).eq.'r'.or. + $ c_qc(iim1)(1:1).eq.'W'.or. + $ c_qc(iim1)(1:1).eq.'A'.or. + $ c_qc(iim1)(1:1).eq.'t'.or. + $ c_qc(iim1)(2:2).eq.'K'.or. + $ c_qc(iim1)(5:5).eq.'B') then + knt1 = knt1 - 1 + goto 10 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c ------------------ + knt2 = knt1 - 1 + 20 if(knt2.ge.istart) then + iim2 = indx(knt2) + if(c_qc(iim2)(1:1).eq.'r'.or. + $ c_qc(iim2)(1:1).eq.'W'.or. + $ c_qc(iim2)(1:1).eq.'A'.or. + $ c_qc(iim2)(2:2).eq.'K'.or. + $ c_qc(iim2)(2:2).eq.'B'.or. + $ c_qc(iim2)(5:5).eq.'B') then + knt2 = knt2 - 1 + goto 20 + endif + else + iim2 = 0 + endif +c +c Continue only if iim1 is valid +c ------------------------------ + if(iim1.ne.0) then +c +c Compute height and time differences for iim1 report +c --------------------------------------------------- + if(ht_ft(ii).ne.amiss) then + iht0 = nint(ht_ft(ii)/100.) * 100 + else + iht0 = imiss + endif +c + if(ht_ft(iim1).ne.amiss) then + ihtm1 = nint(ht_ft(iim1)/100.) * 100 + else + ihtm1 = imiss + endif +c + if(ht_ft(ii).ne.amiss.and.ht_ft(iim1).ne.amiss) then + ihtdif0 = abs(iht0 - ihtm1) + else + ihtdif0 = imiss + endif +c + idt_dif = abs(idt(ii) - idt(iim1)) +c +c Compute magnitude of direction difference +c (constrain to be less than 180 deg +c ----------------------------------------- + if(ob_dir(ii).eq.amiss.or. + $ ob_dir(iim1).eq.amiss) then + difdir = amiss + else + difdir = abs(ob_dir(iim1)-ob_dir(ii)) + if(difdir.gt.180) difdir = 360. - difdir + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c +c Discrepancies in position +c ------------------------- + if(idt_dif.eq.0.and. + $ (abs(alat(ii)-alat(iim1)).ge.0.5.or. + $ abs(alon(ii)-alon(iim1)).ge.0.5) .and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(ii)-ht_ft(iim1)).lt.1.5) then +c +c Check for short segments with stuck clock +c ----------------------------------------- + if(iim2.ne.0) then + if(idt(iim1).eq.idt(ii).and. + $ idt(iim2).eq.idt(ii)) then + c_qc(iim2)(2:2) = 'K' + c_qc(iim1)(2:2) = 'K' + c_qc(ii)(2:2) = 'K' + endif + endif +c + if(iip1.ne.0) then + if(idt(iim1).eq.idt(ii).and. + $ idt(iip1).eq.idt(ii)) then + c_qc(iip1)(2:2) = 'K' + c_qc(iim1)(2:2) = 'K' + c_qc(ii)(2:2) = 'K' + endif + endif +c + if(c_qc(ii)(2:2).eq.'K') then + stuck = .true. + idt_stk = idt(ii) + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in position' + write(io8,*) 'Stuck clock found' + endif + endif + endif +c +c Exclude reports diagnosed as stuck from remaining checks +c -------------------------------------------------------- + if(c_qc(ii)(2:2).eq.'K') then +c +c United flights with 2000' as lowest valid alt +c Pressure/altitude on ground invalid +c Flag if temperatures and altitudes are inconsistent! +c Time-stamp the test so it only applies to the 1996 dataset +c ---------------------------------------------------------- + elseif(cdtg_an.lt.'1998010100'.and. + $ iht0.eq.2000.and. + $ idt_dif.lt.300.and. + $ ihtdif0.gt.6000.and.ihtdif0.ne.imiss.and. + $ ob_t(iim1).gt.ob_t(ii)) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad altitude for first point' + write(io8,*) 'ht_ft(',ii,') = ',ht_ft(ii) + write(io8,*) 'ht_ft(',iim1,') = ',ht_ft(iim1) + endif + c_qc(iim1)(5:5) = 'B' +c + elseif(ihtm1.eq.2000.and. + $ idt_dif.lt.300.and. + $ ihtdif0.gt.6000.and.ihtdif0.ne.imiss.and. + $ ob_t(ii).gt.ob_t(iim1)) then + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad altitude for last point' + write(io8,*) 'ht_ft(',ii,') = ',ht_ft(ii) + write(io8,*) 'ht_ft(',iim1,') = ',ht_ft(iim1) + endif + c_qc(ii)(5:5) = 'B' +c +c Multiple values at same altitude at low altitudes +c Save only one +c ------------------------------------------------- + elseif(iht0.lt.8000.and. + $ idt_dif.le.60.and. + $ ihtdif0.lt.2) then +c + if(iip1.ne.0) then + idt_difp1 = abs(idt(ii)-idt(iip1)) + else + idt_difp1 = imiss + endif +c +c Save newer report if at beginning of flight +c ------------------------------------------- + if(idt(iim1).ne.idt(ii).and. + $ (iim1.eq.iistart.or. + $ (idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn)))then + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Multiple values at same altitude' + write(io8,*) 'Saving newer report' + endif + c_qc(iim1)(1:1) = 'r' +c +c Save report nearer to next report, if available +c Otherwise, save report with smallest temperature or +c windspeed difference w.r.t. next report +c --------------------------------------------------- + elseif(iip1.ne.0) then +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(ii).ne.alat(iim1).or. + $ alon(ii).ne.alon(iim1)) then + diffm1 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iip1),alon(iip1)) + diffm1 = diffm1 / 1000. + diff0 = gcirc_qc(alat(ii),alon(ii), + $ alat(iip1),alon(iip1)) + diff0 = diff0 / 1000. +c +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + elseif(ob_t(ii).ne.ob_t(iim1)) then + diffm1 = abs(ob_t(iim1)-ob_t(iip1)) + diff0 = abs(ob_t(ii)-ob_t(iip1)) +c + elseif(ob_spd(ii).ne.ob_spd(iim1)) then + diffm1 = abs(ob_spd(iim1)-ob_spd(iip1)) + diff0 = abs(ob_spd(ii)-ob_spd(iip1)) +c + else + diffm1 = 1.0 + diff0 = 0.0 + endif +c + if(diff0.lt.diffm1.or.ichk_s(iim1).eq.-10) then + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Multiple values at same altitude' + write(io8,*) 'Saving ii report' + endif + c_qc(iim1)(1:1) = 'r' +c + elseif(diffm1.lt.diff0) then + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Multiple values at same altitude' + write(io8,*) 'Saving iim1 report' + endif + c_qc(ii)(1:1) = 'r' +c + else + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Multiple values at same altitude' + write(io8,*) 'Differences should not be equal!' + endif + endif +c +c If following report not available, drop current report +c ------------------------------------------------------ + else + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Multiple values at same altitude' + write(io8,*) 'Following report not available' + endif + c_qc(ii)(1:1) = 'r' + endif +c +c Perform remaining checks only for manAIREP duplicates +c ----------------------------------------------------- + elseif((itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep).and. + $ (itype(iim1).eq.i_man_airep.or. + $ itype(iim1).eq.i_man_Yairep).and. + $ (abs(ob_t(iim1)-ob_t(ii)).lt.1.25.or. + $ (ob_t(iim1).eq.amiss.and.ob_t(ii).ne.amiss).or. + $ (ob_t(iim1).ne.amiss.and.ob_t(ii).eq.amiss)).and. + $ (abs(difdir).lt.10.5.or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss).or. + $ (ob_dir(iim1).ne.amiss.and.ob_dir(ii).eq.amiss).or. + $ (ob_dir(iim1).lt.0.5.and.ob_dir(ii).lt.0.5).or. + $ (ob_dir(iim1).lt.0.5.and.difdir.gt.10.5).or. + $ (difdir.gt.10.5.and.ob_dir(ii).lt.0.5)).and. + $ (abs(ob_spd(iim1)-ob_spd(ii)).lt.1.25.or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss).or. + $ (ob_spd(iim1).ne.amiss.and.ob_spd(ii).eq.amiss).or. + $ (ob_spd(iim1).lt.0.05.and.ob_spd(ii).lt.0.05).or. + $ (ob_spd(iim1).lt.0.05.and.ob_spd(ii).gt.1.25).or. + $ (ob_spd(iim1).gt.1.25.and.ob_spd(ii).lt.0.05)))then +c +c Check for position discrepancies +c -------------------------------- + if(idt_dif.eq.0.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ (abs(alat(ii)-alat(iim1)).ge.0.125.or. + $ abs(alon(ii)-alon(iim1)).ge.0.125) .and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(ii)-ht_ft(iim1)).lt.1.5) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in position' + write(io8,*) 'Waypoint error found' + endif +c +c If ii and iim1 points are close together, average the position +c -------------------------------------------------------------- + dist_tot = gcirc_qc(alat(ii),alon(ii), + $ alat(iim1),alon(iim1)) + dist_tot = dist_tot / 1000. +c + if(dist_tot.lt.115.0) then + if(l_print) then + write(io8,*) 'points close--averaging' + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat(ii) = (alat(ii)+alat(iim1))/2.0 + alon(ii) = (alon(ii)+alon(iim1))/2.0 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + c_qc(ii)(3:4) = 'RR' + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' +c +c Otherwise, examine neighboring reports to decide which one to keep +c ------------------------------------------------------------------ + elseif(iim2.ne.0.and.iip1.ne.0) then +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat_est = (alat(iip1)-alat(iim2)) + $ / (idt(iip1)-idt(iim2)) + $ * (idt(ii)-idt(iim2)) + $ + alat(iim2) + alon_est = (alon(iip1)-alon(iim2)) + $ / (idt(iip1)-idt(iim2)) + $ * (idt(ii)-idt(iim2)) + $ + alon(iim2) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + dist_tot = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iim2),alon(iim2)) + dist_tot = dist_tot / 1000. + dist_ii = gcirc_qc(alat_est,alon_est, + $ alat(ii),alon(ii)) + dist_ii = dist_ii / 1000. + dist_iim1= gcirc_qc(alat_est,alon_est, + $ alat(iim1),alon(iim1)) + dist_iim1 = dist_iim1 / 1000. +c + if(l_print) then + write(io8,*) 'Estimated position = ', + $ alat_est,alon_est + write(io8,*) 'Distances: iim2-iip1 = ',dist_tot + write(io8,*) ' est-ii = ',dist_ii + write(io8,*) ' est-iim1 = ',dist_iim1 + endif +c +c If the neighboring reports are close enough together, +c choose the report that is closest to the interpolated point +c ----------------------------------------------------------- + if(dist_tot.lt.2500.0) then + if(dist_ii.lt.dist_iim1) then + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' + else + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' + endif +c +c If the neighboring reports are too far apart, +c reject both reports +c --------------------------------------------- + else + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' + endif +c +c If only iim2 point is available... +c ---------------------------------- + elseif(iim2.ne.0) then +c + dist_tot = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii),alon(ii)) + dist_tot = dist_tot / 1000. + dist_ii = gcirc_qc(alat(iim2),alon(iim2), + $ alat(ii),alon(ii)) + dist_ii = dist_ii / 1000. + dist_iim1= gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim1)) + dist_iim1 = dist_iim1 / 1000. + if(l_print) + $ write(io8,*) 'distances:',dist_ii,dist_iim1 +c +c If ii point is close and iim1 point is far, choose ii point +c ----------------------------------------------------------- + if(abs(idt(ii)-idt(iim2)).le.5400.and. + $ dist_ii.le.1500.0.and.dist_iim1.gt.1500.0) then + if(l_print) then + write(io8,*) 'iim1 point is too far away' + endif + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' +c +c If iim1 point is close and ii point is far, choose iim1 point +c ------------------------------------------------------------- + elseif(abs(idt(ii)-idt(iim2)).le.5400.and. + $ dist_ii.gt.1500.0.and.dist_iim1.le.1500.0) then + if(l_print) then + write(io8,*) 'ii point is too far away' + endif + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) then + write(io8,*) 'cannot decide which point' + endif + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' + endif +c +c If only iip1 point is available... +c ---------------------------------- + elseif(iip1.ne.0) then +c + dist_tot = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii),alon(ii)) + dist_tot = dist_tot / 1000. + dist_ii = gcirc_qc(alat(iip1),alon(iip1), + $ alat(ii),alon(ii)) + dist_ii = dist_ii / 1000. + dist_iim1= gcirc_qc(alat(iip1),alon(iip1), + $ alat(iim1),alon(iim1)) + dist_iim1 = dist_iim1 / 1000. + if(l_print) + $ write(io8,*) 'distances:',dist_ii,dist_iim1 +c +c If ii point is close and iim1 point is far, choose ii point +c ----------------------------------------------------------- + if(abs(idt(ii)-idt(iip1)).le.5400.and. + $ dist_ii.le.1500.0.and.dist_iim1.gt.1500.0) then + if(l_print) then + write(io8,*) 'iim1 point is too far away' + endif + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' +c +c If iim1 point is close and ii point is far, choose iim1 point +c ------------------------------------------------------------- + elseif(abs(idt(ii)-idt(iip1)).le.5400.and. + $ dist_ii.gt.1500.0.and.dist_iim1.le.1500.0) then + if(l_print) then + write(io8,*) 'ii point is too far away' + endif + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) then + write(io8,*) 'cannot decide which point' + endif + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' + endif +c +c If both of the neighboring reports are not available +c and points are not close together, reject both reports +c ------------------------------------------------------ + else + if(l_print) then + write(io8,*) 'cannot decide which point' + endif + c_qc(iim1)(1:1) = 'W' + c_qc(iim1)(3:4) = 'BB' + c_qc(ii)(1:1) = 'W' + c_qc(ii)(3:4) = 'BB' + endif +c +c Check for duplicate with altitude error +c --------------------------------------- + elseif(idt_dif.eq.0.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.125.and. + $ abs(alon(iim1)-alon(ii)).lt.0.125.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iim1)-ht_ft(ii)).gt.1000.0) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Near duplicate with altitude error' + endif +c +c Examine neighboring reports to decide which one to keep +c ------------------------------------------------------- + if(iim2.ne.0.and.iip1.ne.0) then +c + dist_tot = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iim2),alon(iim2)) + dist_tot = dist_tot / 1000. +c + if(l_print) then + write(io8,*) 'Distances: iim2-iip1 = ',dist_tot + endif +c +c Require the neighboring reports to be fairly close together +c ----------------------------------------------------------- + if(dist_tot.lt.2500.0) then +c +c If the neighboring reports have the same altitude, +c choose the report with the same altitude +c -------------------------------------------------- + if(abs(ht_ft(iim2)-ht_ft(iip1)).lt.1.5) then + write(io8,*) 'Neighboring altitudes equal' +c + if(abs(ht_ft(ii)-ht_ft(iim2)).lt.1.5) then + write(io8,*) 'ii altitude equal' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' +c + elseif(abs(ht_ft(iim1)-ht_ft(iim2)).lt.1.5) then + write(io8,*) 'iim1 altitude equal' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' +c + else + write(io8,*) 'neither altitude equal' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If points constitute an ascent or a descent, don't reject any +c ------------------------------------------------------------- + elseif((ht_ft(iim2).gt.ht_ft(iim1).and. + $ ht_ft(iim1).gt.ht_ft(ii).and. + $ ht_ft(ii ).gt.ht_ft(iip1)).or. + $ (ht_ft(iim2).lt.ht_ft(iim1).and. + $ ht_ft(iim1).lt.ht_ft(ii).and. + $ ht_ft(ii ).lt.ht_ft(iip1)).or. + $ (ht_ft(iim2).gt.ht_ft(ii).and. + $ ht_ft(ii ).gt.ht_ft(iim1).and. + $ ht_ft(iim1).gt.ht_ft(iip1)).or. + $ (ht_ft(iim2).lt.ht_ft(ii).and. + $ ht_ft(ii ).lt.ht_ft(iim1).and. + $ ht_ft(iim1).lt.ht_ft(iip1))) then +c + if(l_print) + $ write(io8,*) 'ascent/descent found--no rejects' +c +c If the neighboring reports have different altitudes and +c different temperatures, try using temperature to select one +c ----------------------------------------------------------- + elseif(ob_t(iim2).ne.ob_t(iip1)) then + write(io8,*) 'altitudes and temperatures differ' +c + if(abs(ht_ft(ii)-ht_ft(iim2)).lt.1.5.and. + $ abs(ob_t(ii)-ob_t(iim2)).lt.2.005) then + if(l_print) then + write(io8,*) 'ii point matches iim2' + endif + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' +c + elseif(abs(ht_ft(iim1)-ht_ft(iim2)).lt.1.5.and. + $ abs(ob_t(iim1)-ob_t(iim2)).lt.2.005) then + if(l_print) then + write(io8,*) 'iim1 point matches iim2' + endif + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' +c + elseif(abs(ht_ft(ii)-ht_ft(iip1)).lt.1.5.and. + $ abs(ob_t(ii)-ob_t(iip1)).lt.2.005) then + if(l_print) then + write(io8,*) 'ii point matches iip1' + endif + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' +c + elseif(abs(ht_ft(iim1)-ht_ft(iip1)).lt.1.5.and. + $ abs(ob_t(iim1)-ob_t(iip1)).lt.2.005) then + if(l_print) then + write(io8,*) 'iim1 point matches iip1' + endif + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) + $ write(io8,*) 'neither point matches' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If the neighboring reports have different altitudes +c and the same temperature, reject both reports +c ---------------------------------------------------- + else + if(l_print) write(io8,*) 'cannot select' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If the neighboring reports are too far apart, +c reject both reports +c --------------------------------------------- + else + if(l_print) write(io8,*) 'points too far apart' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If only iim2 point is available... +c ---------------------------------- + elseif(iim2.ne.0) then + dist_ii = gcirc_qc(alat(iim2),alon(iim2), + $ alat(ii ),alon(ii )) + dist_ii = dist_ii / 1000. + dist_iim1= gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim1)) + dist_iim1 = dist_iim1 / 1000. +c +c If ii point is close, choose it +c ------------------------------- + if(abs(idt(ii)-idt(iim2)).le.5400.and. + $ dist_ii.lt.1500.0.and. + $ abs(ht_ft(ii)-ht_ft(iim2)).lt.1.5.and. + $ abs(ob_t(ii)-ob_t(iim2)).lt.2.005) then + if(l_print) then + write(io8,*) 'ii point matches iim2' + endif + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' +c +c If iim1 point is close, choose it +c --------------------------------- + elseif(abs(idt(ii)-idt(iim2)).le.5400.and. + $ dist_iim1.lt.1500.0.and. + $ abs(ht_ft(iim1)-ht_ft(iim2)).lt.1.5.and. + $ abs(ob_t(iim1)-ob_t(iim2)).lt.2.005) then + if(l_print) then + write(io8,*) 'iim1 point matches iim2' + endif + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) write(io8,*) 'cannot make match' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If only iip1 point is available... +c ---------------------------------- + elseif(iip1.ne.0) then + dist_ii = gcirc_qc(alat(iip1),alon(iip1), + $ alat(ii ),alon(ii )) + dist_ii = dist_ii / 1000. + dist_iim1= gcirc_qc(alat(iip1),alon(iip1), + $ alat(iim1),alon(iim1)) + dist_iim1 = dist_iim1 / 1000. +c +c If ii point is close, choose it +c ------------------------------- + if(abs(idt(ii)-idt(iip1)).le.5400.and. + $ dist_ii.le.1500.0.and. + $ abs(ht_ft(ii)-ht_ft(iip1)).lt.1.5.and. + $ abs(ob_t(ii)-ob_t(iip1)).lt.2.005) then + if(l_print) then + write(io8,*) 'ii point matches iip1' + endif + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' +c +c If iim1 point is close, choose it +c --------------------------------- + elseif(abs(idt(ii)-idt(iip1)).le.5400.and. + $ dist_iim1.le.1500.0.and. + $ abs(ht_ft(iim1)-ht_ft(iip1)).lt.1.5.and. + $ abs(ob_t(iim1)-ob_t(iip1)).lt.2.005) then + if(l_print) then + write(io8,*) 'iim1 point matches iip1' + endif + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) write(io8,*) 'cannot make match' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c If both of the neighboring reports are not available +c reject both reports +c ---------------------------------------------------- + else + if(l_print) write(io8,*) 'no neighboring points' + c_qc(iim1)(1:1) = 'A' + c_qc(iim1)(5:5) = 'B' + c_qc(ii)(1:1) = 'A' + c_qc(ii)(5:5) = 'B' + endif +c +c Check for duplicate with time error +c ----------------------------------- + elseif(idt(iim1).ne.idt(ii).and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ abs(alat(iim1)-alat(ii)).lt.0.125.and. + $ abs(alon(iim1)-alon(ii)).lt.0.125.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ abs(ht_ft(iim1)-ht_ft(ii)).lt.50.5) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Discrepancy in time' + endif +c +c If points are close in time, average times +c ------------------------------------------ + if(abs(idt(iim1)-idt(ii)).lt.1800.0) then +c + if(l_print) then + write(io8,*) 'points close--averaging' + endif + idt(ii) = (idt(ii)+idt(iim1))/2 + c_qc(ii)(2:2) = 'R' + c_qc(iim1)(1:1) = 't' + c_qc(iim1)(2:2) = 'B' +c +c Otherwise, examine neighboring reports to decide which one to keep +c ------------------------------------------------------------------ + elseif(iim2.ne.0.and.iip1.ne.0) then +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat_dif = abs(alat(iip1)-alat(iim2)) + alon0 = alon(ii) + alonm2 = alon(iim2) + alonp1 = alon(iip1) + if(alon0.gt.270.0.and.alonm2.lt.90.0) + $ alonm2 = alonm2 + 360.0 + if(alon0.lt.90.0.and.alonm2.gt.270.0) + $ alonm2 = 360.0 - alonm2 + if(alon0.gt.270.0.and.alonp1.lt.90.0) + $ alonp1 = alonp1 + 360.0 + if(alon0.lt.90.0.and.alonp1.gt.270.0) + $ alonp1 = 360.0 - alonp1 + alon_dif = abs(alonp1-alonm2) +c + if(alon_dif.eq.0.0.and. + $ alat_dif.eq.0.0) then + time_est = amiss +c + elseif(alon_dif.ge.alat_dif) then + time_est = (float(idt(iip1)-idt(iim2))) + $ / (alonp1-alonm2) + $ * (alon0-alonm2) + $ + float(idt(iim2)) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + else + time_est = (float(idt(iip1)-idt(iim2))) + $ / (alat(iip1)-alat(iim2)) + $ * (alat(ii)-alat(iim2)) + $ + float(idt(iim2)) + endif +c + idt_tot = abs(idt(iip1) - idt(iim2)) +c + if(l_print) then + write(io8,*) 'Estimated time = ',time_est + write(io8,*) 'Lons = ',alonm2,alon0,alonp1 + endif +c +c If the neighboring reports are close enough together, +c choose the report that is closest to the interpolated point +c ----------------------------------------------------------- + if(idt_tot.lt.9000.and.time_est.ne.amiss) then + if(abs(ifix(time_est)-idt(ii)).lt. + $ abs(ifix(time_est)-idt(iim1))) then + c_qc(iim1)(1:1) = 't' + c_qc(iim1)(2:2) = 'B' +c + else + c_qc(ii)(1:1) = 't' + c_qc(ii)(2:2) = 'B' +c + endif +c +c If the neighboring reports are too far apart, +c reject both reports +c --------------------------------------------- + else + c_qc(iim1)(1:1) = 't' + c_qc(iim1)(2:2) = 'B' + c_qc(ii)(1:1) = 't' + c_qc(ii)(2:2) = 'B' + endif +c +c Otherwise reject both points +c ---------------------------- + else + if(l_print) then + write(io8,*) 'cannot decide which point' + endif + c_qc(iim1)(1:1) = 't' + c_qc(iim1)(2:2) = 'B' + c_qc(ii)(1:1) = 't' + c_qc(ii)(2:2) = 'B' + endif +c +c Write out any other duplicates +c ------------------------------ + else + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Leftover duplicate' + endif + endif +c +c Make sure retained report has all available values +c (ii report is rejected; iim1 report is retained) +c -------------------------------------------------- + if((c_qc(ii)(1:1).eq.'W'.and.c_qc(iim1).ne.'W').or. + $ (c_qc(ii)(1:1).eq.'A'.and.c_qc(iim1).ne.'A').or. + $ (c_qc(ii)(1:1).eq.'t'.and.c_qc(iim1).ne.'t')) then +c + if(ob_t(iim1).eq.amiss.and.ob_t(ii).ne.amiss) then + ob_t(iim1) = ob_t(ii) + c_qc(iim1)(6:6) = c_qc(ii)(6:6) + ob_t(ii) = amiss + c_qc(ii)(6:6) = 'M' + endif + if(ob_dir(iim1).eq.amiss.and.ob_dir(ii).ne.amiss) then + ob_dir(iim1) = ob_dir(ii) + c_qc(iim1)(7:7) = c_qc(ii)(7:7) + ob_dir(ii) = amiss + c_qc(ii)(7:7) = 'M' + endif + if(ob_dir(iim1).lt.0.5.and.difdir.gt.10.5) then + ob_dir(iim1) = ob_dir(ii) + c_qc(iim1)(7:7) = c_qc(ii)(7:7) + ob_dir(ii) = amiss + c_qc(ii)(7:7) = 'M' + endif + if(ob_spd(iim1).eq.amiss.and.ob_spd(ii).ne.amiss) then + ob_spd(iim1) = ob_spd(ii) + c_qc(iim1)(8:8) = c_qc(ii)(8:8) + ob_spd(ii) = amiss + c_qc(ii)(8:8) = 'M' + endif + if(ob_spd(iim1).lt.0.05.and.ob_spd(ii).gt.1.25) then + ob_spd(iim1) = ob_spd(ii) + c_qc(iim1)(8:8) = c_qc(ii)(8:8) + ob_spd(ii) = amiss + c_qc(ii)(8:8) = 'M' + endif +c + if(ob_spd(ii).eq.amiss.and.ob_dir(ii).ne.amiss) + $ c_qc(ii)(7:7) = 'I' + if(ob_dir(ii).eq.amiss.and.ob_spd(ii).ne.amiss) + $ c_qc(ii)(8:8) = 'I' + if(ob_spd(iim1).eq.amiss.and.ob_dir(iim1).ne.amiss) + $ c_qc(iim1)(7:7) = 'I' + if(ob_dir(iim1).eq.amiss.and.ob_spd(iim1).ne.amiss) + $ c_qc(iim1)(8:8) = 'I' +c +c Make sure retained report has all available values +c (iim1 report is rejected; ii report is retained) +c -------------------------------------------------- + elseif((c_qc(iim1)(1:1).eq.'W'.and.c_qc(ii).ne.'W').or. + $ (c_qc(iim1)(1:1).eq.'A'.and.c_qc(ii).ne.'A').or. + $ (c_qc(iim1)(1:1).eq.'t'.and.c_qc(ii).ne.'t'))then +c + if(ob_t(ii).eq.amiss.and.ob_t(iim1).ne.amiss) then + ob_t(ii) = ob_t(iim1) + c_qc(ii)(6:6) = c_qc(iim1)(6:6) + ob_t(iim1) = amiss + c_qc(iim1)(6:6) = 'M' + endif + if(ob_dir(ii).eq.amiss.and.ob_dir(iim1).ne.amiss) then + ob_dir(ii) = ob_dir(iim1) + c_qc(ii)(7:7) = c_qc(iim1)(7:7) + ob_dir(iim1) = amiss + c_qc(iim1)(7:7) = 'M' + endif + if(ob_dir(ii).lt.0.5.and.difdir.gt.10.5) then + ob_dir(ii) = ob_dir(iim1) + c_qc(ii)(7:7) = c_qc(iim1)(7:7) + ob_dir(iim1) = amiss + c_qc(iim1)(7:7) = 'M' + endif + if(ob_spd(ii).eq.amiss.and.ob_spd(iim1).ne.amiss) then + ob_spd(ii) = ob_spd(iim1) + c_qc(ii)(8:8) = c_qc(iim1)(8:8) + ob_spd(iim1) = amiss + c_qc(iim1)(8:8) = 'M' + endif + if(ob_spd(ii).lt.0.05.and.ob_spd(iim1).gt.1.25) then + ob_spd(ii) = ob_spd(iim1) + c_qc(ii)(8:8) = c_qc(iim1)(8:8) + ob_spd(iim1) = amiss + c_qc(iim1)(8:8) = 'M' + endif +c + if(ob_spd(ii).eq.amiss.and.ob_dir(ii).ne.amiss) + $ c_qc(ii)(7:7) = 'I' + if(ob_dir(ii).eq.amiss.and.ob_spd(ii).ne.amiss) + $ c_qc(ii)(8:8) = 'I' + if(ob_spd(iim1).eq.amiss.and.ob_dir(iim1).ne.amiss) + $ c_qc(iim1)(7:7) = 'I' + if(ob_dir(iim1).eq.amiss.and.ob_spd(iim1).ne.amiss) + $ c_qc(iim1)(8:8) = 'I' + endif + endif + endif +c +c Print series of reports if desired +c ---------------------------------- + if(l_print) then + if(iim2.ne.0) write(io8,8002) kk,iim2 + x, c_insty_ob(itype(iim2)) + x, c_acftreg(iim2),c_acftid(iim2) + x, idt(iim2),alat(iim2),alon(iim2) + x, pres(iim2),ht_ft(iim2) + x, t_prcn(iim2),ob_t(iim2),xiv_t(iim2),ichk_t(iim2) + x, ob_q(iim2),xiv_q(iim2),ichk_q(iim2) + x, ob_dir(iim2),xiv_d(iim2),ichk_d(iim2) + x, ob_spd(iim2),xiv_s(iim2),ichk_s(iim2) + x, c_qc(iim2) + if(iim1.ne.0) write(io8,8002) kk,iim1 + x, c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + if(iip1.ne.0) write(io8,8002) kk,iip1 + x, c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1) + x, pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1) + endif +c +c End loop over reports +c --------------------- + enddo +c +c Check rest of flight if stuck clock found +c ----------------------------------------- + if(stuck) then + do iob = istart,iend + ii = indx(iob) + if(idt(ii).eq.idt_stk.and. + $ c_qc(ii)(2:2).ne.'K') then + c_qc(ii)(2:2) = 'K' + write(io8,*) + write(io8,*) 'Another stuck clock found' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif + enddo + endif +c +c End if clause for real flights with at least three reports +c ---------------------------------------------------------- + endif +c +c End loop over flights +c --------------------- + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io35,*) + write(io35,*) 'Inconsistent positions' + write(io35,*) '----------------------' + write(io35,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + kbad = 0 +c + do iob = 1,numreps + ii = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c + if(ktype.eq.1) then + nrep_Md = nrep_Md + 1 + elseif(ktype.eq.2) then + nrep_Ac = nrep_Ac + 1 + elseif(ktype.eq.3) then + nrep_Am = nrep_Am + 1 + elseif(ktype.eq.4) then + nrep_Ar = nrep_Ar + 1 + elseif(ktype.eq.5) then + nrep_Ma = nrep_Ma + 1 + endif +c + if(c_qc(ii)(1:1).eq.'r'.or. + $ c_qc(ii)(1:1).eq.'W'.or. + $ c_qc(ii)(1:1).eq.'A'.or. + $ c_qc(ii)(1:1).eq.'t'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(2:2).eq.'R'.or. + $ c_qc(ii)(3:4).eq.'RR'.or. + $ c_qc(ii)(5:5).eq.'B') then +c + if(.not.l_operational) then + write(io35,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count by category +c ----------------- + if(c_qc(ii)(1:1).eq.'r') then + ninc_xtra(ktype) = ninc_xtra(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'W') then + ninc_way(ktype) = ninc_way(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'A') then + ninc_alt(ktype) = ninc_alt(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'K') then + ninc_stk(ktype) = ninc_stk(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'B') then + ninc_time(ktype) = ninc_time(ktype) + 1 + elseif(c_qc(ii)(3:4).eq.'RR'.or. + $ c_qc(ii)(2:2).eq.'R') then + ninc_avg(ktype) = ninc_avg(ktype) + 1 + elseif(c_qc(ii)(5:5).eq.'B') then + ninc_bad(ktype) = ninc_bad(ktype) + 1 + endif + endif +c +c Reject redundant reports and reports with inconsistent positions +c ---------------------------------------------------------------- + if(c_qc(ii)(1:1).eq.'r'.or. + $ c_qc(ii)(1:1).eq.'W'.or. + $ c_qc(ii)(1:1).eq.'A'.or. + $ c_qc(ii)(1:1).eq.'t'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(5:5).eq.'B') then +c + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(ktype.eq.1) then + ninc_Md = ninc_Md + 1 + elseif(ktype.eq.2) then + ninc_Ac = ninc_Ac + 1 + elseif(ktype.eq.3) then + ninc_Am = ninc_Am + 1 + elseif(ktype.eq.4) then + ninc_Ar = ninc_Ar + 1 + elseif(ktype.eq.5) then + ninc_Ma = ninc_Ma + 1 + endif + endif +c + enddo +c + if(.not.l_operational) then + write(io35,*) + write(io35,*)' Number of inc MDCRS reps rejected = ',kbad(1) +ccccdak write(io35,*)' Number of inc ACARS reps rejected = ',kbad(2) + write(io35,*)' Number of inc TAMDAR reps rejected = ',kbad(2) + write(io35,*)' Number of inc AMDAR reps rejected = ',kbad(3) + write(io35,*)' Number of inc AIREP reps rejected = ',kbad(4) + write(io35,*)' Number of inc manAIREP reps rejected = ',kbad(5) + endif +c + write(io8,*) + write(io8,*) ' Reports with inconsistent positions--rejected' + write(io8,*) ' ---------------------------------------------' + write(io8,*)' Number of inc MDCRS reps rejected = ',kbad(1) +ccccdak write(io8,*)' Number of inc ACARS reps rejected = ',kbad(2) + write(io8,*)' Number of inc TAMDAR reps rejected = ',kbad(2) + write(io8,*)' Number of inc AMDAR reps rejected = ',kbad(3) + write(io8,*)' Number of inc AIREP reps rejected = ',kbad(4) + write(io8,*)' Number of inc manAIREP reps rejected = ',kbad(5) +c + write(*,*) + write(*,*) 'Inconsistent position check data counts--',cdtg_an + write(*,*) '---------------------------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(*,'('' Total rejected '',5(1x,i7))') + $ ninc_Md,ninc_Ac,ninc_Am,ninc_Ar,ninc_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Inconsistent position check data counts' + write(io8,*) '---------------------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ ninc_Md,ninc_Ac,ninc_Am,ninc_Ar,ninc_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Redundant reps '',5(1x,i7))') + $ (ninc_xtra(ii),ii=1,5) + write(io8,'(''Bad waypoint '',5(1x,i7))') + $ (ninc_way(ii),ii=1,5) + write(io8,'(''Bad altitude '',5(1x,i7))') + $ (ninc_alt(ii),ii=1,5) + write(io8,'(''Stuck clock '',5(1x,i7))') + $ (ninc_stk(ii),ii=1,5) + write(io8,'(''Bad time '',5(1x,i7))') + $ (ninc_time(ii),ii=1,5) + write(io8,'(''Inconsistent ht'',5(1x,i7))') + $ (ninc_bad(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Avg posn/time '',5(1x,i7))') + $ (ninc_avg(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in position check' +c + return + end +c +c ################################################################### +c subroutine orddup_qc +c ################################################################### +c + subroutine orddup_qc(max_reps,indx,isave,ht_ft,idt,alat,alon + $, kflight,maxflt,nobs_flt,iobs_flt + $, c_acftreg,c_acftid,cidmiss,idt_near,io8) +c +c Check the ordering of near-duplicate reports based on heights +c + implicit none +c + integer io8 ! i/o unit number for log file + integer iob ! do loop index + $, max_reps ! max number of observations/reports + $, ii ! index pointing to current report + $, iim1 ! index pointing to previous report + $, iim2 ! index pointing to two reports ago + $, iim3 ! index pointing to three reports ago + $, iip1 ! index pointing to following report + $, iip2 ! index pointing to report after next + integer indx(max_reps) ! pointer array + $, isave(max_reps) ! second pointer array used to reverse order + integer kk ! do loop index + integer knt ! number of reports with the same time + $, kneg ! number of reports with negative heights + ! and with the same time + $, kkk ! do loop index + $, nn ! do loop index + $, nback ! variable used in reversing order + integer idt_dif1 ! first time difference + $, idt_dif2 ! second time difference + integer idt_near ! time difference between "near" neighbors +c +c Work arrays +c ----------- + real ht_ft(max_reps) ! height in feet + integer iht0,iht1 ! integer height in feet + integer idt(max_reps) ! time in seconds to analysis time + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + character*9 c_acftid(max_reps) ! acft flight number + character*8 c_acftreg(max_reps) ! acft tail number +c + character*8 cidmiss ! missing value flag for flight number +c + integer maxflt ! max number of flights allowed + integer kflight ! number of flights in dataset + integer nobs_flt(maxflt) ! number of reports per flight + $, iobs_flt(maxflt) ! index for first report in each flight + integer istart ! index for first report in current flight + $, iistart ! index from pointer array for istart + $, iend ! index for last report in current flight + $, iiend ! index from pointer array for iend + $, inow ! iob + 1 + $, inext ! counter + $, iinext ! index from pointer array for inext + $, ilast ! index for last report with same time + $, iilast ! index from pointer array for ilast + $, iilastm1 ! index from pointer array for ilast-1 + $, iilastm2 ! index from pointer array for ilast-2 + $, iilastp1 ! index from pointer array for ilast+1 + $, iibefore ! index from pointer array for previous rep + $, iiafter ! index from pointer array for following rep + $, iii ! index pointer for current report + $, iiim1 ! index pointer for previous report + real*8 alat_dif ! latitude difference used to check ordering + $, alon_dif ! longitude difference used to check ordering + real ht_max ! maximum height in group with same time + $, ht_min ! minimum height in group with same time + $, ht_dif1,ht_dif2 ! height differences +c + logical sameht ! true if altitudes are equal +c + logical l_print ! print diagnostic output if true +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Begin loop over flights +c ----------------------- + do kk = 1,kflight +c +c Initialize variables +c -------------------- + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) +c +c Set print switch +c ---------------- + l_print = .false. + if(c_acftreg(iistart)(1:8).eq.'########') l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) 'orddup output for ########' + write(io8,*) '--------------------------' + write(io8,*) 'iistart,iiend = ',iistart,iiend + endif +c +c Don't compare reports with missing flight number +c Perform check only for flights with three or more reports +c ----------------------------------------------------------------- + if(c_acftid(iistart)(1:8).ne.cidmiss(1:8).and. + $ nobs_flt(kk).ge.3) then +c + if(l_print) write(io8,*) 'Valid flight found' +c +c Check ordering of reports with the same time +c -------------------------------------------- +c +c Compute indices +c --------------- + iob = istart +c + do while(iob.lt.iend) + if(iob.gt.istart+2) then + iim3 = indx(iob-3) + else + iim3 = 0 + endif +c + if(iob.gt.istart+1) then + iim2 = indx(iob-2) + else + iim2 = 0 + endif +c + if(iob.gt.istart) then + iim1 = indx(iob-1) + else + iim1 = 0 + endif +c + ii = indx(iob) +c + if(iob.lt.iend) then + iip1 = indx(iob+1) + else + iip1 = 0 + endif +c + if(iob.lt.iend-1) then + iip2 = indx(iob+2) + else + iip2 = 0 + endif +c +c Count number of reports with same time +c -------------------------------------- + if(iip1.ne.0) then + if(idt(ii).eq.idt(iip1)) then + knt = 2 +c write(io8,*) +c write(io8,*) 'Second report with same time--',ii,iip1,knt +c + ht_max = ht_ft(ii) + if(ht_ft(iip1).gt.ht_max) ht_max = ht_ft(iip1) +c + ht_min = ht_ft(ii) + if(ht_ft(iip1).lt.ht_min) ht_min = ht_ft(iip1) +c + if(ht_ft(ii).lt.0) then + kneg = 1 +c write(io8,*) +c write(io8,*) 'Negative height found for ii=',ii + else + kneg = 0 + endif +c + if(ht_ft(iip1).lt.0) then + kneg = kneg + 1 +c write(io8,*) 'A second neg ht found for ii=',iip1 + endif +c + inow = iob + 1 + inext = inow + 1 +c + 10 if(inext.le.iend) then + iinext = indx(inext) + if(idt(ii).eq.idt(iinext)) then + knt = knt + 1 +c write(io8,*) 'Another report with same time--',inext + if(ht_ft(iinext).gt.ht_max) ht_max = ht_ft(iinext) + if(ht_ft(iinext).lt.ht_min) ht_min = ht_ft(iinext) + if(ht_ft(iinext).lt.0) then + kneg = kneg + 1 +c write(io8,*) 'Another neg ht found for ii=',iinext + endif + inext = inext + 1 + goto 10 + endif + endif +c + if(l_print) then + write(io8,*) + write(io8,*) '#obs with same time = ',knt + write(io8,*) '#obs with neg height = ',kneg + write(io8,*) 'ht_max,ht_min = ',ht_max,ht_min + write(io8,*) 'inow,inext = ',inow,inext + write(io8,*) 'iim3,iim2,iim1 = ',iim3,iim2,iim1 + write(io8,*) 'ii,iip1,iip2 = ',ii,iip1,iip2 + endif +c + ilast = inext - 1 + if(ilast.le.iend) then + iilast = indx(ilast) + else + iilast = 0 + endif + if(ilast+1.le.iend) then + iilastp1 = indx(ilast+1) + else + iilastp1 = 0 + endif + if(ilast-1.ge.istart) then + iilastm1 = indx(ilast-1) + else + iilastm1 = 0 + endif + if(ilast-2.ge.istart) then + iilastm2 = indx(ilast-2) + else + iilastm2 = 0 + endif +c + if(l_print) then + write(io8,*) 'iilastm2,iilastm1 = ',iilastm2,iilastm1 + write(io8,*) 'iilast,iilastp1 = ',iilast,iilastp1 + endif +c +c Case with duplicates in middle of flight +c ---------------------------------------- + if(iim1.ne.0.and.iip1.ne.0.and. + $ iilast.ne.0.and.iilastp1.ne.0.and. + $ iilastm1.ne.0) then +c + idt_dif1 = abs(idt(ii) - idt(iim1)) + iibefore = iim1 + if(idt_dif1.ge.idt_near) then + idt_dif1 = abs(idt(iip1) - idt(ii)) + iibefore = ii + endif +c + idt_dif2 = abs(idt(iilastp1) - idt(iilast)) + iiafter = iilastp1 + if(idt_dif2.ge.idt_near) then + idt_dif2 = abs(idt(iilast) - idt(iilastm1)) + iiafter = iilast + endif +c + if(l_print) then + write(io8,*) 'Duplicates in middle of flight' + write(io8,*) 'idt_dif1,idt_dif2= ',idt_dif1,idt_dif2 + write(io8,*) 'iibefore,iiafter = ',iibefore,iiafter + endif +c +c Check if near dups are part of a level flight leg +c ------------------------------------------------- + if(abs(ht_ft(iibefore) - ht_ft(iiafter)).le.100.0.and. + $ abs(ht_ft(iibefore) - ht_max).le.100.0.and. + $ abs(ht_min - ht_ft(iiafter)).le.100.0) then +c + if(l_print) + $ write(io8,*) 'Near dups in smooth level leg--ii=',ii +c +c Or part of a smooth ascent +c -------------------------- + elseif(ht_ft(iibefore).lt.ht_ft(iiafter).and. + $ ht_ft(iibefore).le.ht_min.and. + $ ht_max.le.ht_ft(iiafter)) then +c + if(l_print) + $ write(io8,*) 'Near dups in smooth ascent--ii=',ii +c +c Or part of smooth descent +c ------------------------- + elseif(ht_ft(iibefore).gt.ht_ft(iiafter).and. + $ ht_ft(iibefore).ge.ht_max.and. + $ ht_min.ge.ht_ft(iiafter)) then +c + if(l_print) + $ write(io8,*) 'Near dups in smooth descent--ii=',ii +c +c Or near dups are near max or min altitude +c ----------------------------------------- + else +c + ht_dif1 = abs(ht_ft(iibefore) - ht_ft(ii)) + ht_dif2 = abs(ht_ft(iilast) - ht_ft(iiafter)) +c +c Re-set iibefore or iiafter if appropriate +c ----------------------------------------- + if(idt_dif1.lt.idt_dif2.and. + $ iibefore.ne.ii.and.iiafter.ne.iilast) then +c + idt_dif2 = abs(idt(iilast) - idt(iilastm1)) + iiafter = iilast +c + if(l_print) then + write(io8,*) 'Near dups near peak alt-1-ii=',ii + write(io8,*) 'idt_dif2,iiafter= ',idt_dif2,iiafter + endif +c + elseif(idt_dif1.gt.idt_dif2.and. + $ iibefore.ne.ii.and.iiafter.ne.iilast) then +c + idt_dif1 = abs(idt(iip1) - idt(ii)) + iibefore = ii +c + if(l_print) then + write(io8,*) + write(io8,*)'Near dups near peak alt-2-ii=',ii + write(io8,*)'idt_dif1,iibefore=',idt_dif1,iibefore + endif +c + elseif(idt_dif1.eq.idt_dif2.and. + $ iibefore.ne.ii.and.iiafter.eq.iilast) then +c + if(idt(iip2)-idt(iip1).ge.idt_near) then + idt_dif2 = abs(idt(iilastm1) - idt(iilastm2)) + iiafter = iilastm1 +c + if(l_print) then + write(io8,*)'Dropping last point in descent',ii + write(io8,*)'idt_dif2,iiafter=',idt_dif2,iiafter + endif +c + elseif(ht_dif1.lt.ht_dif2) then + idt_dif2 = abs(idt(iilast) - idt(iilastm1)) + iiafter = iilast +c + if(l_print) then + write(io8,*)'Near dups near peak alt-3-ii=',ii + write(io8,*)'idt_dif2,iiafter=',idt_dif2,iiafter + endif +c + elseif(ht_dif1.gt.ht_dif2) then + idt_dif1 = abs(idt(iip1) - idt(ii)) + iibefore = ii +c + if(l_print) then + write(io8,*)'Near dups near peak alt-4-ii=',ii + write(io8,*)'idt_dif1,iibefr=',idt_dif1,iibefore + endif +c + else + if(l_print) then + write(io8,*)'Near dups near peak alt-5-ii=',ii + write(io8,*)'Neither time nor height check used' + endif + endif +c + else + if(l_print) then + write(io8,*) 'Near dups near peak alt-6-ii=',ii + write(io8,*) 'Indices not reset' + endif + endif + endif +c +c Case with duplicates during whole flight +c ---------------------------------------- + elseif(iob.eq.istart.and.ilast.eq.iend.and. + $ iilastm1.ne.0) then + idt_dif1 = 0 + iibefore = ii + idt_dif2 = abs(idt(iilast) - idt(iilastm1)) + iiafter = iilast +c + if(l_print) then + write(io8,*) 'Near dups found during whole flight' + write(io8,*) knt,' reports found with same time' + write(io8,*) 'idt_dif1,idt_dif2= ',idt_dif1,idt_dif2 + write(io8,*) 'iibefore,iiafter = ',iibefore,iiafter + endif +c +c Case with duplicates at beginning of flight +c ------------------------------------------- + elseif(iob.eq.istart.and.ilast.le.iend.and. + $ iilastm1.ne.0.and.iilastp1.ne.0) then + idt_dif1 = 0 + iibefore = ii + idt_dif2 = abs(idt(iilast) - idt(iilastp1)) + iiafter = iilastp1 + if(idt_dif2.ge.idt_near) then + idt_dif2 = abs(idt(iilast) - idt(iilastm1)) + iiafter = iilast + endif +c + if(l_print) then + write(io8,*)'Near dups found at beginning of flight' + write(io8,*) knt,' reports found with same time' + write(io8,*) 'idt_dif1,idt_dif2= ',idt_dif1,idt_dif2 + write(io8,*) 'iibefore,iiafter = ',iibefore,iiafter + endif +c +c Case with duplicates at end of flight +c ------------------------------------- + elseif(iob.gt.istart.and.ilast.eq.iend.and. + $ iim1.ne.0.and.iip1.ne.0) then + idt_dif1 = abs(idt(ii) - idt(iim1)) + iibefore = iim1 + if(idt_dif1.ge.idt_near) then + idt_dif1 = abs(idt(iip1) - idt(ii)) + iibefore = ii + endif + idt_dif2 = 0 + iiafter = iilast +c + if(l_print) then + write(io8,*) 'Near dups found at end of flight' + write(io8,*) knt,' reports found with same time' + write(io8,*) 'idt_dif1,idt_dif2= ',idt_dif1,idt_dif2 + write(io8,*) 'iibefore,iiafter = ',iibefore,iiafter + endif + endif +c +c Check time differences--compare neighboring reports within idt_near +c ------------------------------------------------------------------- + if(idt_dif1.lt.idt_near.and.idt_dif2.lt.idt_near) then +c + iht0 = nint(ht_ft(iibefore)/100.) + iht1 = nint(ht_ft(iiafter)/100.) +c + if(l_print) then + write(io8,*) 'Time differences within idt_near' + write(io8,*) 'iht0,iht1 = ',iht0,iht1 + endif +c +c Check if all altitudes are equal +c -------------------------------- + sameht = .true. +c + do kkk=iob,iob+knt-1 + if(nint(ht_ft(indx(kkk))/100.).ne. + $ nint(ht_ft(ii)/100.)) + $ sameht = .false. + enddo +c + if(l_print) + $ write(io8,*) 'Altitudes equal?',sameht +c +c Use lat/lon to order obs if altitudes equal +c ------------------------------------------- + if(sameht.and.knt.eq.2) then +c + alat_dif = abs(alat(iiafter) - alat(iibefore)) + alon_dif = abs(alon(iiafter) - alon(iibefore)) + iii = indx(iob+1) + iiim1 = indx(iob) +c + if(l_print) then + write(io8,*) 'Level pair at ii = ',ii + write(io8,*) 'alat_dif = ',alat_dif + write(io8,*) 'alon_dif = ',alon_dif + write(io8,*) 'iii,iiim1 = ',iii,iiim1 + endif +c + if(alat_dif.gt.alon_dif) then + if((alat(iibefore).gt.alat(iiafter).and. + $ alat(iiim1).lt.alat(iii)).or. + $ (alat(iibefore).le.alat(iiafter).and. + $ alat(iiim1).gt.alat(iii))) then +c + if(l_print) then + write(io8,*) 'Reversing pair of obs-1-',iii + write(io8,*) 'lats = ',alat(iiim1),alat(iii) + endif +c + indx(iob) = iii + indx(iob+1) = iiim1 + endif +c + else + if((alon(iibefore).gt.alon(iiafter).and. + $ alon(iiim1).lt.alon(iii)).or. + $ (alon(iibefore).le.alon(iiafter).and. + $ alon(iiim1).gt.alon(iii))) then +c + if(l_print) then + write(io8,*) 'Reversing pair of obs-2-',iii + write(io8,*) 'lons = ',alon(iiim1),alon(iii) + endif +c + indx(iob) = iii + indx(iob+1) = iiim1 + endif + endif +c +c Descent found +c ------------- + elseif(iht0.gt.iht1) then +c + if(l_print) + $ write(io8,*) 'Reversing descent at report',ii +c +c Re-order descending portions of flights with positive heights +c ------------------------------------------------------------- + do nn = iob,ilast + nback = ilast - nn + iob + isave(nn) = indx(nback) + enddo +c + indx(iob:ilast) = isave(iob:ilast) +c +c Ascent found +c ------------ + elseif(iht0.lt.iht1) then +c + if(l_print) + $ write(io8,*) 'Ascent found at ii = ',ii +c +c Reorder portions of flight with negative heights +c ------------------------------------------------ + if(kneg.eq.2.and.ht_ft(ii).lt.0.and. + $ ht_ft(ii).ne.ht_ft(iip1)) then +c +cc 12/01 if(l_print) +cc 12/01 $ write(io8,*) 'Reversing neg alts--ii=',ii, +c +cc 12/01 + ht_ft(ii),ht_ft(iip1) +c +cc 12/01 iiim1 = indx(iob) +cc 12/01 indx(iob) = indx(iob+1) +cc 12/01 indx(iob+1) = iiim1 +c + endif +c +c Level flight found +c ------------------ + elseif(iht0.eq.iht1) then +c sameht = .true. +c + if(l_print) + $ write(io8,*) 'Level flight at ii = ',ii +c +c Slight descent found--reorder +c ----------------------------- +c if(knt.eq.2.and. + if( + $ nint(ht_ft(indx(iob))).gt. + $ nint(ht_ft(iilast))) then +c +c if(l_print) then +c write(io8,*) 'Reordering slight descent--',iii +c write(io8,*) 'alt= ',ht_ft(indx(iob)), +c $ ht_ft(indx(iob+1)) +c endif +cc +c iii = indx(iob+1) +c iiim1 = indx(iob) +c indx(iob) = iii +c indx(iob+1) = iiim1 +c + if(l_print) + $ write(io8,*) 'Reversing descent at report',ii +c +c Re-order descending portions of flights with positive heights +c ------------------------------------------------------------- + do nn = iob,ilast + nback = ilast - nn + iob + isave(nn) = indx(nback) + enddo +c + indx(iob:ilast) = isave(iob:ilast) +c +c Ordering unknown +c ---------------- + else +c +c Try using lat/lon to order obs +c ------------------------------ + if(knt.eq.2) then +c + alat_dif = abs(alat(iiafter) - alat(iibefore)) + alon_dif = abs(alon(iiafter) - alon(iibefore)) + iii = indx(iob+1) + iiim1 = indx(iob) +c + if(l_print) then + write(io8,*) 'Unknown ordering at ii = ',ii + write(io8,*) 'alat_dif = ',alat_dif + write(io8,*) 'alon_dif = ',alon_dif + write(io8,*) 'iii,iiim1 = ',iii,iiim1 + endif +c + if(alat_dif.gt.alon_dif) then + if((alat(iibefore).gt.alat(iiafter).and. + $ alat(iiim1).lt.alat(iii)).or. + $ (alat(iibefore).le.alat(iiafter).and. + $ alat(iiim1).gt.alat(iii))) then +c + if(l_print) then + write(io8,*) 'Reversing unknown order-1-' + $, iii + write(io8,*)'lats= ',alat(iiim1),alat(iii) + endif +c + indx(iob) = iii + indx(iob+1) = iiim1 + endif +c + else + if((alon(iibefore).gt.alon(iiafter).and. + $ alon(iiim1).lt.alon(iii)).or. + $ (alon(iibefore).le.alon(iiafter).and. + $ alon(iiim1).gt.alon(iii))) then +c + if(l_print) then + write(io8,*) 'Reversing unknown order-2-' + $, iii + write(io8,*)'lons =',alon(iiim1),alon(iii) + endif +c + indx(iob) = iii + indx(iob+1) = iiim1 + endif + endif +c + else + write(io8,*) 'Ordering unknown--ii = ',ii + write(io8,*) 'Flight # = ',c_acftid(ii) +c + do kkk=iob-1,iob+knt + write(io8,*) 'ht_ft(',indx(kkk),') = ' + $ ,ht_ft(indx(kkk)) + $ ,' idt = ',idt(indx(kkk)) + enddo + endif + endif + endif +c +c +c Time differences too large for comparison +c ----------------------------------------- + elseif(l_print) then + write(io8,*)'Time diffs too large for comparison!' + write(io8,*)'idt_dif1=',idt_dif1,' iibefore=',iibefore + write(io8,*)'idt_dif2=',idt_dif2,' iiafter =',iiafter + endif +c + iob = ilast + 1 +c + else + iob = iob + 1 + endif +c + else + iob = iob + 1 + endif +c + enddo + endif + enddo +c + return + end +c +c ################################################################### +c subroutine ordchek_qc +c ################################################################### +c + subroutine ordchek_qc(numreps,max_reps,indx,csort,imiss,amiss + $, idt_near,idt_updn,htdif_same,c_acftreg,c_acftid,cidmiss + $, c_qc,alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir + $, ob_spd,xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, kreg,creg_reg,nwind_reg + $, kflight,maxflt,nobs_flt,ntot_flt,iobs_flt,kbadtot + $, io8,io36,l_operational,l_init) +c +c Check ordering of flights +c +c Modified by P.M. Pauley (3/7/00) +c Problems were found with the great circle distance calculation. +c The calculation formula was changed from the law of cosines +c to the haversine formula, the latter of which works at the small +c distances that gave the former problems. An effort was also made +c to compute the course direction explicitly, since the method used +c was to compute the north-south and east-west distances and use +c them to compute the direction using a plane-geometry approximation. +c However, the formulas for course direction that were tried had +c more computational problems than the plane-geometry approximation, +c so they were abandoned. However, rather than computing the +c airspeed using the north-south and east-west components of the +c groundspeed and wind vectors, a method (again based on plane +c geometry) to compute the magnitude of the airspeed vector as +c the third side of the wind triangle was derived. This method +c yields an airspeed that is more consistent with the computed +c groundspeed and the wind than the previous method, which could +c lead to unrealistic differences between the groundspeed and +c airspeed magnitudes. These methods are not rigorously exact, +c but were deemed sufficiently accurate for the purposes at hand. +c +c Modified by P.M. Pauley 9/21/02 +c As data resolution has increased, some aspects of the track (such +c as deciding a point is going backwards) have become less meaningful. +c Changes were made to reduce the number of false positives. +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer + real gcirc_qc ! function to compute great circle distances +c +c Flight statistics +c ----------------- + integer maxflt ! max number of flights allowed + integer nobs_flt(maxflt) ! number of reports per flight + $, ntot_flt(maxflt) ! total number of reports per flight + $, iobs_flt(maxflt) ! index for first report in each flight + $, kflight ! number of flights in dataset + integer istart ! index for 1st rep in current flight + $, iistart ! index from pointer array for istart + $, iend ! index for last rep in current flight + $, iiend ! index from pointer array for iend + $, iifirst ! index from pointer array for beginning of first flight segment + $, jjstart ! index for start of flight segment + $, iobfirst ! index for beginning of first flight segment + $, iilast ! index from pointer array for end of first flight segment + $, ioblast ! index for end of first flight segment +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail#s in dataset + character*8 creg_reg(maxflt) ! tail numbers + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds +c +c Counters +c -------- + integer nord_dup(5) ! number of previously undetected near duplicates + $, nord_stk(5) ! number of reports with stuck times + $, nord_time(5) ! number of reports with inconsistent times + $, nord_2nd(5) ! number of reports with in second flights + $, nord_near(5) ! number of reports rejected as closer to last rejected point + $, nord_aspd(5) ! number of reports with excessive airspeed + $, nord_lone(5) ! number of reports rejected as isolated off-track points + $, nord_dble(5) ! number of reports rejected when track doubles back on itself + $, nord_turn(5) ! number of reports rejected when track makes too large a turn + $, nord_alt(5) ! number of reports with inconsistent altitudes + $, nord_wind(5) ! number of reports with anomalous windspeeds + integer kbad(5) ! counter for number of bad reports + $, kbadtot ! counter for total number of bad reports +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak integer nord_Ac ! number of acars reports rejected + integer nord_Ac ! number of tamdar reports rejected + $, nord_Md ! number of mdcrs reports rejected + $, nord_Ma ! number of manual airep reports rejected + $, nord_Ar ! number of airep reports rejected + $, nord_Am ! number of amdar reports rejected +c +c Instrument types +c ---------------- +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdsk $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io36 ! i/o unit number for ordering check +c + real amiss ! real missing value flag + real d2r ! conversion factor for degrees to radians +c + integer iob,job,nob,kk ! do loop indices + $, ii,jj,nn ! index pointing to current report + $, mm ! index pointing to current tail number + $, iim1,nnm1 ! index pointing to previous report + $, iim2 ! index pointing to 2nd report previous + $, iim3 ! index pointing to 3rd report previous + $, iip1,jjp1,nnp1 ! index pointing to following report + $, iip2 ! index pointing to 2nd report following + $, iip3 ! index pointing to 3rd report following + $, iobp1 ! index for following report + $, iobp2 ! index for 2nd report following report + $, knt0 ! counter saved from definition of ii index + $, knt1 ! counter used to define iim1 index + $, knt2 ! counter used to define iim2 index + $, knt3 ! counter used to define iip1 index + $, knt4 ! counter used to define iip2 index + $, knt5 ! counter used to define iim3 index + $, knt6 ! counter used to define iip3 index + $, knt_iob ! counter for number of times iob repeated + $, iob_sav ! previous value of iob + $, knt_iip1_bad ! number of times iip1 report is rejected as bad manuever + $, job_alat_min ! index for minimum latitude + $, job_alat_max ! index for maximum latitude + $, job_alon_min ! index for minimum longitude + $, job_alon_max ! index for maximum longitude + $, jj_alat_min ! pointer index for minimum latitude + $, jj_alat_max ! pointer index for maximum latitude + $, jj_alon_min ! pointer index for minimum longitude + $, jj_alon_max ! pointer index for maximum longitude + integer imiss ! integer missing value flag + integer idt_near ! time difference between "near" neighbors + integer idt_updn ! time difference to check ascents/descents + integer idt0 ! time for report ii + $, idtm1 ! time for report iim1 + $, idtm2 ! time for report iim2 + $, idtm3 ! time for report iim3 + $, idtp1 ! time for report iip1 + $, idtp2 ! time for report iip2 + $, idtp3 ! time for report iip3 + $, idt_start ! time for first report of flight + $, idt_end ! time for last report of flight + $, idt_last_bad ! time for last bad report + integer idt_dif0 ! time difference (current - previous report) + $, idt_difm1 ! time difference (two previous reports) + $, idt_difm2 ! time difference (two reports before those) + $, idt_difp1 ! time difference (following - current report) + $, idt_difp2 ! time difference (two following reports) + $, idt_difp3 ! time difference (two reports after those) + $, idt_dif_wo0 ! time difference (iim1 and iip1 points) + $, idt_dif_wop1 ! time difference (ii and iip2 points) + $, idt_dif_wop2 ! time difference (iip1 and iip3 points) + $, idt_dif_bad0 ! time difference (ii and last_bad points) + $, idt_dif_badp1 ! time difference (iip1 and last_bad points) + $, idt_dif_track ! time difference (first and last points) +c + integer ktype ! ob type + $, itype0 ! ob type for ii report + $, itypem1 ! ob type for iim1 report + $, itypep1 ! ob type for iip1 report + $, itypep2 ! ob type for iip2 report +c + real htdif_same ! height difference considered negligible + real*8 alat_dif ! latitude difference (current-previous report) + $, alon_dif ! longitude difference (current-previous report) + $, alat_min ! minimum latitude for flight + $, alat_max ! maximum latitude for flight + $, alon_min ! minimum longitude for flight + $, alon_max ! maximum longitude for flight + $, alat0 ! latitude in current report + $, alatm1 ! latitude in previous report + $, alatm2 ! latitude at 2nd previous report + $, alatm3 ! latitude at 3rd previous report + $, alatp1 ! latitude at following report + $, alatp2 ! latitude at 2nd following report + $, alatp3 ! latitude at 3rd following report + $, alon0 ! longitude in current report + $, alonm1 ! longitude in previous report + $, alonm2 ! longitude at 2nd previous report + $, alonm3 ! longitude at 3rd previous report + $, alonp1 ! longitude at following report + $, alonp2 ! longitude at 2nd following report + $, alonp3 ! longitude at 3rd following report + real ht_dif0 ! height difference (current-previous report) + $, ht_difm1 ! height difference (two previous reports) + $, ht_difm2 ! height difference (two reports before those) + $, ht_difp1 ! height difference (following-current report) + $, ht_difp2 ! height difference (two following reports) + $, ht_difp3 ! height difference (two reports after those) + $, ht_dif_wo0 ! height difference between iim1 and iip1 reports + $, ht_dif_wop1 ! height difference between ii and iip2 reports + $, ht_dif_wop2 ! height difference between iip1 and iip3 reports + $, ht_dif_bad0 ! height difference between ii and last_bad reports + $, ht_dif_badp1 ! height difference between iip1 and last_bad reports + $, ht_dif_track ! height difference between first and last reports + $, dif_t ! temperature difference (current-previous report) + $, dif_dir ! direction difference (current-previous report) + $, dif_spd ! speed difference (current-previous report) + $, ht_ft0 ! height in current report + $, ht_ftm1 ! height in previous report + $, ht_ftm2 ! height at 2nd previous report + $, ht_ftm3 ! height at 3rd previous report + $, ht_ftp1 ! height at following report + $, ht_ftp2 ! height at 2nd following report + $, ht_ftp3 ! height at 3rd following report +c +c real uwind0 ! u component for wind at ii point +c $, vwind0 ! v component for wind at ii point +c $, uwindm1 ! u component for wind at iim1 point +c $, vwindm1 ! v component for wind at iim1 point +c $, uwindm2 ! u component for wind at iim2 point +c $, vwindm2 ! v component for wind at iim2 point +c $, uwindm3 ! u component for wind at iim3 point +c $, vwindm3 ! v component for wind at iim3 point +c $, uwindp1 ! u component for wind at iip1 point +c $, vwindp1 ! v component for wind at iip1 point +c $, uwindp2 ! u component for wind at iip2 point +c $, vwindp2 ! v component for wind at iip2 point +c $, uwindp3 ! u component for wind at iip3 point +c $, vwindp3 ! v component for wind at iip3 point +c $, uwind_start ! u component for wind at first point +c $, vwind_start ! v component for wind at first point +c $, uwind_end ! u component for wind at last point +c $, vwind_end ! v component for wind at last point +c $, uwind_last ! u component for wind at last bad point +c $, vwind_last ! v component for wind at last bad point + real wspd_last ! wind speed at last bad point + $, wdir_last ! wind direction at last bad point + real distm1 ! distance between iim2 and iim1 points + $, distm2 ! distance between iim2 and iim3 points + $, dist0 ! distance between iim1 and ii points + $, distp1 ! distance between iip1 and ii points + $, distp2 ! distance between iip2 and iip1 points + $, distp3 ! distance between iip3 and iip2 points + $, dist_wo0 ! distance between iim1 and iip1 points + $, dist_wop1 ! distance between ii and iip2 points + $, dist_wop2 ! distance between iip1 and iip3 points + $, dist_bad0 ! distance between ii and last_bad points + $, dist_badp1 ! distance between ii and last_bad points + $, dist_track ! distance between first and last points + $, dist_2ndflt ! distance between first and last points of potential 2nd flight + $, udistm1 ! E-W distance between iim2 and iim1 points + $, vdistm1 ! N-S distance between iim2 and iim1 points + $, udistm2 ! E-W distance between iim3 and iim2 points + $, vdistm2 ! N-S distance between iim3 and iim2 points + $, udist0 ! E-W distance between ii and iim1 points + $, vdist0 ! N-S distance between ii and iim1 points + $, udistp1 ! E-W distance between ii and iip1 points + $, vdistp1 ! N-S distance between ii and iip1 points + $, udistp2 ! E-W distance between iip1 and iip2 points + $, vdistp2 ! N-S distance between iip1 and iip2 points + $, udistp3 ! E-W distance between iip2 and iip3 points + $, vdistp3 ! N-S distance between iip2 and iip3 points + $, udist_wo0 ! E-W distance between iim1 and iip1 points + $, vdist_wo0 ! N-S distance between iim1 and iip1 points + $, udist_wop1 ! E-W distance between ii and iip2 points + $, vdist_wop1 ! N-S distance between ii and iip2 points + $, udist_wop2 ! E-W distance between iip1 and iip3 points + $, vdist_wop2 ! N-S distance between iip1 and iip3 points + $, udist_bad0 ! E-W distance between ii and last_bad points + $, vdist_bad0 ! N-S distance between ii and last_bad points + $, udist_badp1 ! E-W distance between iip1 and last_bad points + $, vdist_badp1 ! N-S distance between iip1 and last_bad points + $, udist_track ! E-W distance between first and last points + $, vdist_track ! N-S distance between first and last points + real upspdm1 ! u component of platform speed (iim2 to iim1 points) + $, vpspdm1 ! v component of platform speed (iim2 to iim1 points) + $, upspdm2 ! u component of platform speed (iim3 to iim2 points) + $, vpspdm2 ! v component of platform speed (iim3 to iim2 points) + $, upspd0 ! u component of platform speed (iim1 to ii points) + $, vpspd0 ! v component of platform speed (iim1 to ii points) + $, upspdp1 ! u component of platform speed (ii to iip1 points) + $, vpspdp1 ! v component of platform speed (ii to iip1 points) + $, upspdp2 ! u component of platform speed (iip1 to iip2 points) + $, vpspdp2 ! v component of platform speed (iip1 to iip2 points) + $, upspdp3 ! u component of platform speed (iip2 to iip3 points) + $, vpspdp3 ! v component of platform speed (iip2 to iip3 points) + $, upspd_wo0 ! u component of platform speed (iim1 to iip1 points) + $, vpspd_wo0 ! v component of platform speed (iim1 to iip1 points) + $, upspd_wop1 ! u component of platform speed (ii to iip2 points) + $, vpspd_wop1 ! v component of platform speed (ii to iip2 points) + $, upspd_wop2 ! u component of platform speed (iip1 to iip3 points) + $, vpspd_wop2 ! v component of platform speed (iip1 to iip3 points) + $, upspd_bad0 ! u component of platform speed (ii to last_bad points) + $, vpspd_bad0 ! v component of platform speed (ii to last_bad points) + $, upspd_badp1 ! u component of platform speed (iip1 to last_bad points) + $, vpspd_badp1 ! v component of platform speed (iip1 to last_bad points) + $, upspd_track ! u component of platform speed (first and last points) + $, vpspd_track ! v component of platform speed (first and last points) + $, pdirm1 ! platform direction of aircraft (iim2 to iim1 points) + $, pdirm2 ! platform direction of aircraft (iim3 to iim2 points) + $, pdir0 ! platform direction of aircraft (iim1 to ii points) + $, pdirp1 ! platform direction of aircraft (iip1 to ii points) + $, pdirp2 ! platform direction of aircraft (iip1 to iip2 points) + $, pdirp3 ! platform direction of aircraft (iip2 to iip3 points) + $, pdir_wo0 ! platform direction of aircraft (iim1 to iip1 points) + $, pdir_wop1 ! platform direction of aircraft (ii to iip2 points) + $, pdir_wop2 ! platform direction of aircraft (iip1 to iip3 points) + $, pdir_bad0 ! platform direction of aircraft (ii to last_bad points) + $, pdir_badp1 ! platform direction of aircraft (iip1 to last_bad points) + $, pdir_track ! platform direction of aircraft (first and last points) + $, pspdm1 ! platform speed of aircraft (iim2 to iim1 points) + $, pspdm2 ! platform speed of aircraft (iim3 to iim2 points) + $, pspd0 ! platform speed of aircraft (iip1 to ii points) + $, pspdp1 ! platform speed of aircraft (iip1 to ii points) + $, pspdp2 ! platform speed of aircraft (iip2 to iip1 points) + $, pspdp3 ! platform speed of aircraft (iip3 to iip2 points) + $, pspd_wo0 ! platform speed of aircraft (iip1 to iim1 points) + $, pspd_wop1 ! platform speed of aircraft (iip2 to ii points) + $, pspd_wop2 ! platform speed of aircraft (iip3 to iip1 points) + $, pspd_bad0 ! platform speed of aircraft (ii to last_bad points) + $, pspd_badp1 ! platform speed of aircraft (iip1 to last_bad points) + $, pspd_track ! platform speed of aircraft (first and last points) + real spd_thresh ! threshold speed of aircraft + $, spd_man_thresh ! threshold speed of aircraft for manual aireps +c real uairspdm1 ! u component of airspeed (iim2 to iim1 points) +c $, vairspdm1 ! v component of airspeed (iim2 to iim1 points) +c $, uairspdm2 ! u component of airspeed (iim3 to iim2 points) +c $, vairspdm2 ! v component of airspeed (iim3 to iim2 points) +c $, uairspd0 ! u component of airspeed (iim1 to ii points) +c $, vairspd0 ! v component of airspeed (iim1 to ii points) +c $, uairspdp1 ! u component of airspeed (ii to iip1 points) +c $, vairspdp1 ! v component of airspeed (ii to iip1 points) +c $, uairspdp2 ! u component of airspeed (iip1 to iip2 points) +c $, vairspdp2 ! v component of airspeed (iip1 to iip2 points) +c $, uairspdp3 ! u component of airspeed (iip2 to iip3 points) +c $, vairspdp3 ! v component of airspeed (iip2 to iip3 points) +c $, uairspd_wo0 ! u component of airspeed (iim1 to iip1 points) +c $, vairspd_wo0 ! v component of airspeed (iim1 to iip1 points) +c $, uairspd_wop1 ! u component of airspeed (ii to iip2 points) +c $, vairspd_wop1 ! v component of airspeed (ii to iip2 points) +c $, uairspd_wop2 ! u component of airspeed (iip1 to iip3 points) +c $, vairspd_wop2 ! v component of airspeed (iip1 to iip3 points) +c $, uairspd_bad0 ! u component of airspeed (ii to last_bad points) +c $, vairspd_bad0 ! v component of airspeed (ii to last_bad points) +c $, uairspd_badp1 ! u component of airspeed (iip1 to last_bad points) +c $, vairspd_badp1 ! v component of airspeed (iip1 to last_bad points) +c $, uairspd_track ! u component of airspeed (first and last points) +c $, vairspd_track ! v component of airspeed (first and last points) + real airspdm1 ! airspeed between iim1 and iim2 points +c $, airdirm1 ! airspeed direction between iim1 and iim2 points + $, airspdm2 ! airspeed between iim2 and iim3 points +c $, airdirm2 ! airspeed direction between iim2 and iim3 points + $, airspd0 ! airspeed between ii and iim1 points +c $, airdir0 ! airspeed direction between ii and iim1 points + $, airspdp1 ! airspeed between ii and iip1 points +c $, airdirp1 ! airspeed direction between ii and iip1 points + $, airspdp2 ! airspeed between iip1 and iip2 points +c $, airdirp2 ! airspeed direction between iip1 and iip2 points + $, airspdp3 ! airspeed between iip2 and iip3 points +c $, airdirp3 ! airspeed direction between iip2 and iip3 points + $, airspd_wo0 ! airspeed between iim1 and iip1 points +c $, airdir_wo0 ! airspeed direction between iim1 and iip1 points + $, airspd_wop1 ! airspeed between ii and iip2 points +c $, airdir_wop1 ! airspeed direction between ii and iip2 points + $, airspd_wop2 ! airspeed between iip1 and iip3 points +c $, airdir_wop2 ! airspeed direction between iip1 and iip3 points + $, airspd_bad0 ! airspeed between ii and last_bad points +c $, airdir_bad0 ! airspeed direction between ii and last_bad points + $, airspd_badp1 ! airspeed between iip1 and last_bad points +c $, airdir_badp1 ! airspeed direction between iip1 and last_bad points + $, airspd_track ! airspeed between first and last points +c $, airdir_track ! airspeed direction between first and last points + real vspdm1 ! vertical speed of aircraft (iim1 to iim2 points) + $, vspdm2 ! vertical speed of aircraft (iim2 to iim3 points) + $, vspd0 ! vertical speed of aircraft (ii to iim1 points) + $, vspdp1 ! vertical speed of aircraft (iip1 to ii points) + $, vspdp2 ! vertical speed of aircraft (iip2 to iip1 points) + $, vspdp3 ! vertical speed of aircraft (iip3 to iip2 points) + $, vspd_wo0 ! vertical speed of aircraft (iip1 to iim1 points) + $, vspd_wop1 ! vertical speed of aircraft (iip2 to ii points) + $, vspd_wop2 ! vertical speed of aircraft (iip3 to iip1 points) + $, vspd_bad0 ! vertical speed of aircraft (ii to last_bad points) + $, vspd_badp1 ! vertical speed of aircraft (iip1 to last_bad points) + $, vspd_track ! vertical speed of aircraft (first and last points) + real vspd_thresh ! threshold vertical speed of aircraft + $, vspd_bounce ! threshold vertical speed used in bounce test +c + integer indx_save(200) ! pointer indices for rejected reports + $, ll ! index for indx_save + $, keep ! variable used in saving indices + $, knt_bad ! number of reports in potential second flight + $, last_bad ! pointer index for last rejected report + $, last_bad_m1 ! pointer index for next-to-last rejected report +c + character*8 cidmiss ! missing value flag for flight number +c +c Switches +c -------- + logical l_print ! true for printing reports used in check +c + logical l_retest ! retest track if true +c + logical l_init ! initialize counters if true + $, l_ii_man_airep ! true if ii report is manual airep + $, l_iim1_man_airep ! true if iim1 report is manual airep + $, l_iim2_man_airep ! true if iim2 report is manual airep + $, l_iim3_man_airep ! true if iim3 report is manual airep + $, l_iip1_man_airep ! true if iip1 report is manual airep + $, l_iip2_man_airep ! true if iip2 report is manual airep + $, l_ii_pspd_ok ! true if pspd is ok for point ii + $, l_stuck ! true if stuck clock found + $, l_operational ! true if operational mode used +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Degrees to radians +c ------------------ + d2r = atan(1.0) / 45.0 +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + nord_dup = 0 + nord_stk = 0 + nord_time = 0 + nord_2nd = 0 + nord_near = 0 + nord_aspd = 0 + nord_lone = 0 + nord_dble = 0 + nord_turn = 0 + nord_alt = 0 + nord_wind = 0 + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nord_Ac = 0 + nord_Md = 0 + nord_Ma = 0 + nord_Ar = 0 + nord_Am = 0 + endif +c + nwind_reg = 0 +c +c Begin loop over flights +c ----------------------- + do kk = 1,kflight +c +c Initialize variables +c -------------------- + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) +c +c Don't compare reports with missing flight number +c Perform check only for flights with three or more reports +c ----------------------------------------------------------------- + if(c_acftid(iistart)(1:8).ne.cidmiss(1:8).and. + $ nobs_flt(kk).ge.3) then +c +c Determine flight phase of reports +c --------------------------------- + do iob=istart,iend + l_print = .false. +c + ii = indx(iob) +c +c Decide if report is a manual airep +c ---------------------------------- + l_ii_man_airep = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) l_ii_man_airep = .true. +c +c Compute ii-1 index +c if(iob.gt.istart) iim1 = indx(iob-1) +c -------------------------------------- + iim1 = 0 + knt1 = iob - 1 + 10 if(knt1.ge.istart) then + iim1 = indx(knt1) + if(c_qc(iim1)(1:1).eq.'d'.or. + $ c_qc(iim1)(2:2).eq.'I'.or. + $ c_qc(iim1)(2:2).eq.'K'.or. + $ c_qc(iim1)(3:4).eq.'II'.or. + $ c_qc(iim1)(5:5).eq.'I'.or. + $ c_qc(iim1)(5:5).eq.'i') then + knt1 = knt1 - 1 + goto 10 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c if(iob.gt.istart+1) iim2 = indx(iob-2) +c -------------------------------------- + iim2 = 0 + knt2 = knt1 - 1 + 20 if(knt2.ge.istart) then + iim2 = indx(knt2) + if(c_qc(iim2)(1:1).eq.'d'.or. + $ c_qc(iim2)(2:2).eq.'I'.or. + $ c_qc(iim2)(2:2).eq.'K'.or. + $ c_qc(iim2)(3:4).eq.'II'.or. + $ c_qc(iim2)(5:5).eq.'I'.or. + $ c_qc(iim2)(5:5).eq.'i') then + knt2 = knt2 - 1 + goto 20 + endif + else + iim2 = 0 + endif +c +c Compute ii+1 index +c if(iob.lt.iend) iip1 = indx(iob+1) +c ------------------------------------ + iip1 = 0 + knt3 = iob + 1 + 30 if(knt3.le.iend) then + iip1 = indx(knt3) + if(c_qc(iip1)(1:1).eq.'d'.or. + $ c_qc(iip1)(2:2).eq.'I'.or. + $ c_qc(iip1)(2:2).eq.'K'.or. + $ c_qc(iip1)(3:4).eq.'II'.or. + $ c_qc(iip1)(5:5).eq.'I'.or. + $ c_qc(iip1)(5:5).eq.'i') then + knt3 = knt3 + 1 + goto 30 + endif + else + iip1 = 0 + endif +c +c Compute ii+2 index +c if(iob.lt.iend-1) iip2 = indx(iob+2) +c ------------------------------------ + iip2 = 0 + knt4 = knt3 + 1 + 40 if(knt4.le.iend) then + iip2 = indx(knt4) + if(c_qc(iip2)(1:1).eq.'d'.or. + $ c_qc(iip2)(2:2).eq.'I'.or. + $ c_qc(iip2)(2:2).eq.'K'.or. + $ c_qc(iip2)(3:4).eq.'II'.or. + $ c_qc(iip2)(5:5).eq.'I'.or. + $ c_qc(iip2)(5:5).eq.'i') then + knt4 = knt4 + 1 + goto 40 + endif + else + iip2 = 0 + endif +c +c Compute time and height differences +c ----------------------------------- + alat0 = alat(ii) + alon0 = alon(ii) + ht_ft0 = ht_ft(ii) +c + if(iim1.ne.0) then + idt_dif0 = abs(idt(ii) - idt(iim1)) + ht_dif0 = abs(ht_ft(ii) - ht_ft(iim1)) + ht_ftm1 = ht_ft(iim1) + else + idt_dif0 = imiss + ht_dif0 = amiss + ht_ftm1 = amiss + endif +c + if(iim2.ne.0) then + ht_ftm2 = ht_ft(iim2) + else + ht_ftm2 = amiss + endif +c + if(iim1.ne.0.and.iim2.ne.0) then + idt_difm1 = abs(idt(iim1) - idt(iim2)) + ht_difm1 = abs(ht_ft(iim1) - ht_ft(iim2)) + else + idt_difm1 = imiss + ht_difm1 = amiss + endif +c + if(iip1.ne.0) then + idt_difp1 = abs(idt(iip1) - idt(ii)) + ht_difp1 = abs(ht_ft(iip1) - ht_ft(ii)) + ht_ftp1 = ht_ft(iip1) + else + idt_difp1 = imiss + ht_difp1 = amiss + ht_ftp1 = amiss + endif +c + if(iip2.ne.0) then + ht_ftp2 = ht_ft(iip2) + else + ht_ftp2 = amiss + endif +c + if(iip2.ne.0.and.iip1.ne.0) then + idt_difp2 = abs(idt(iip2) - idt(iip1)) + ht_difp2 = abs(ht_ft(iip2) - ht_ft(iip1)) + else + idt_difp2 = imiss + ht_difp2 = amiss + endif +c +c Look for high resolution level legs +c ----------------------------------- +c +c Use iim1, ii, iip1 points +c ----------------------------------- + if(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_dif0 .lt.htdif_same+0.5.and. + $ ht_difp1.lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c -------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_updn.and. + $ ht_difm1.lt.htdif_same+0.5.and. + $ ht_dif0 .lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iip1.ne.0.and.idt_difp1.lt.idt_updn.and. + $ ht_difp1.gt.htdif_same+0.5.and. + $ ht_difp1.lt.5000.) then + if(ht_ftp1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + if(ht_ftp1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + endif +c +c Use ii, iip1, iip2 points +c -------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_difp1.lt.htdif_same+0.5.and. + $ ht_difp2.lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iim1.ne.0.and.idt_dif0.lt.idt_updn.and. + $ ht_dif0.gt.htdif_same+0.5.and. + $ ht_dif0.lt.5000.) then + if(ht_ftm1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + if(ht_ftm1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + endif +c +c Look for high resolution ascents and descents +c --------------------------------------------- +c +c Use iim1, ii, iip1 points +c ----------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'D' +c +c Use iim2, iim1, ii points +c ----------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'D' +c +c Use ii, iip1, iip2 points +c ----------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_ft0.gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'D' +c +c Look for other level legs +c ------------------------- +c +c Use iim1, ii, iip1 points +c ------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*3)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*3)).and. + $ ht_dif0.lt.htdif_same*1.5+0.5.and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*3)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*3)).and. + $ ht_difm1.lt.htdif_same*1.5+0.5.and. + $ ht_dif0 .lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iip1.ne.0.and.idt_difp1.lt.idt_updn.and. + $ ht_difp1.gt.htdif_same+0.5.and. + $ ht_difp1.lt.5000.) then + if(ht_ftp1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + if(ht_ftp1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + endif +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*3)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*3)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5.and. + $ ht_difp2.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iim1.ne.0.and.idt_dif0.lt.idt_updn.and. + $ ht_dif0.gt.htdif_same+0.5.and. + $ ht_dif0.lt.5000.) then + if(ht_ftm1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + if(ht_ftm1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + endif +c +c Look for other ascents and descents +c ----------------------------------- +c +c Use iim1, ii, iip1 points +c -------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'd' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'd' +c +c Use ii, iip1, iip2 points +c -------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'd' +c +c Look for 2-point level legs +c --------------------------- +c +c Use iim1, ii, iip1 points +c ------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_dif0.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_dif0 .lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Look for isolated ascending and descending points +c ------------------------------------------------- +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_difm1.lt.htdif_same*1.5+0.5) then +c + if(ht_ft0.lt.ht_ftm1) then + c_qc(ii)(11:11) = 'd' + elseif(ht_ft0.gt.ht_ftm1) then + c_qc(ii)(11:11) = 'a' + else + write(io8,*) + write(io8,*) 'unidentified isolated point found!' + write(io8,*) 'hts:',ht_ftm2,ht_ftm1,ht_ft0 + c_qc(ii)(11:11) = 'U' + endif +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_difp2.lt.htdif_same*1.5+0.5) then +c + if(ht_ft0.gt.ht_ftp1) then + c_qc(ii)(11:11) = 'd' + elseif(ht_ft0.lt.ht_ftp1) then + c_qc(ii)(11:11) = 'a' + else + write(io8,*) + write(io8,*) 'unidentified isolated point found!' + write(io8,*) 'hts:',ht_ft0,ht_ftp1,ht_ftp2 + c_qc(ii)(11:11) = 'U' + endif +c +c Check if time difference is too great to categorize manAIREPs +c ------------------------------------------------------------- + elseif(l_ii_man_airep.and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp2.gt.idt_near*2))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2)))then +c + c_qc(ii)(11:11) = 'N' +c +c Check if time difference is too great to categorize remaining types +c ------------------------------------------------------------------- + elseif((.not.l_ii_man_airep).and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp2.gt.idt_near*2/3))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2/3).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2/3).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2/3).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2/3)))then +c + c_qc(ii)(11:11) = 'N' +c +c Label everything else as unknown +c -------------------------------- + else + c_qc(ii)(11:11) = 'U' + endif +c + enddo +c +c Check ordering +c Compute platform speed and airspeed between neighboring points +c Check for realistic platform speeds using Moninger's test +c Threshold lowered from 600 m/s to 525 m/s; manAIREPs use 325 m/s +c Compute vertical velocity between neighboring points and do bounce test +c ----------------------------------------------------------------------- + 5500 continue +c +c Initialize variables for track check +c ------------------------------------ + l_ii_pspd_ok = .false. + l_stuck = .false. +c + spd_thresh = 525. + spd_man_thresh = 350. + vspd_thresh = 12000.0/60.0 + vspd_bounce = 6000.0/60.0 +c + iob = istart +c + indx_save = imiss + ll = 0 + knt_bad = 0 + last_bad = 0 + last_bad_m1 = 0 + knt_iob = 1 + iob_sav = 0 +c +c Loop over reports for current flight +c ------------------------------------ + do while(iob.le.iend) + l_print = .false. + l_retest = .false. +c + knt0 = iob + ii = indx(iob) +c + if(iob.eq.iob_sav) then + knt_iob = knt_iob + 1 + else + iob_sav = iob + knt_iob = 1 + endif +c + if(knt_iob.gt.75) then + write(io8,*) + write(io8,*) 'Too many repetitions with the same iob',iob + write(io8,*) ' Sorted index ii = ',ii + write(io8,*) ' Number of repetitions = ',knt_iob + iob = iob + 1 + iob_sav = iob + knt_iob = 1 + endif +c +c Go to next report if ii index is invalid +c ---------------------------------------- + if(c_qc(ii)(1:1).eq.'d'.or. + $ c_qc(ii)(2:2).eq.'I'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i') then +c + iob = iob + 1 + l_ii_pspd_ok = .false. + l_print = .false. + if(l_print) then + write(io8,*) 'Index invalid: ii = ',ii + endif +c +c Check out ordering etc for valid indices +c ---------------------------------------- + else +c +c Compute ii-1 index +c if(iob.gt.istart) iim1 = indx(iob-1) +c -------------------------------------- + iim1 = 0 + knt1 = iob - 1 + 11 if(knt1.ge.istart) then + iim1 = indx(knt1) + if(c_qc(iim1)(1:1).eq.'d'.or. + $ c_qc(iim1)(2:2).eq.'I'.or. + $ c_qc(iim1)(2:2).eq.'K'.or. + $ c_qc(iim1)(3:4).eq.'II'.or. + $ c_qc(iim1)(5:5).eq.'I'.or. + $ c_qc(iim1)(5:5).eq.'i') then + knt1 = knt1 - 1 + goto 11 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c if(iob.gt.istart+1) iim2 = indx(iob-2) +c -------------------------------------- + iim2 = 0 + knt2 = knt1 - 1 + 21 if(knt2.ge.istart) then + iim2 = indx(knt2) + if(c_qc(iim2)(1:1).eq.'d'.or. + $ c_qc(iim2)(2:2).eq.'I'.or. + $ c_qc(iim2)(2:2).eq.'K'.or. + $ c_qc(iim2)(3:4).eq.'II'.or. + $ c_qc(iim2)(5:5).eq.'I'.or. + $ c_qc(iim2)(5:5).eq.'i') then + knt2 = knt2 - 1 + goto 21 + endif + else + iim2 = 0 + endif +c +c Compute ii+1 index +c if(iob.lt.iend) iip1 = indx(iob+1) +c ------------------------------------ + iip1 = 0 + iobp1 = 0 + knt3 = iob + 1 + 41 if(knt3.le.iend) then + iip1 = indx(knt3) + iobp1 = knt3 + if(c_qc(iip1)(1:1).eq.'d'.or. + $ c_qc(iip1)(2:2).eq.'I'.or. + $ c_qc(iip1)(2:2).eq.'K'.or. + $ c_qc(iip1)(3:4).eq.'II'.or. + $ c_qc(iip1)(5:5).eq.'I'.or. + $ c_qc(iip1)(5:5).eq.'i') then + knt3 = knt3 + 1 + goto 41 + endif + else + iip1 = 0 + iobp1 = 0 + endif +c +c Compute ii+2 index +c if(iob.lt.iend-1) iip2 = indx(iob+2) +c ------------------------------------ + iip2 = 0 + iobp2 = 0 + knt4 = knt3 + 1 + 51 if(knt4.le.iend) then + iip2 = indx(knt4) + iobp2 = knt4 + if(c_qc(iip2)(1:1).eq.'d'.or. + $ c_qc(iip2)(2:2).eq.'I'.or. + $ c_qc(iip2)(2:2).eq.'K'.or. + $ c_qc(iip2)(3:4).eq.'II'.or. + $ c_qc(iip2)(5:5).eq.'I'.or. + $ c_qc(iip2)(5:5).eq.'i') then + knt4 = knt4 + 1 + goto 51 + endif + else + iip2 = 0 + iobp2 = 0 + endif +c +c Determine if reports are manual AIREPs +c -------------------------------------- + l_ii_man_airep = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) l_ii_man_airep = .true. +c + l_iim1_man_airep = .false. + if(iim1.ne.0) then + if(itype(iim1).eq.i_man_airep.or. + $ itype(iim1).eq.i_man_Yairep) l_iim1_man_airep = .true. + endif +c + l_iip1_man_airep = .false. + if(iip1.ne.0) then + if(itype(iip1).eq.i_man_airep.or. + $ itype(iip1).eq.i_man_Yairep) l_iip1_man_airep = .true. + endif +c + l_iip2_man_airep = .false. + if(iip2.ne.0) then + if(itype(iip2).eq.i_man_airep.or. + $ itype(iip2).eq.i_man_Yairep) l_iip2_man_airep = .true. + endif +c +c Set up temporary variables for ii point +c --------------------------------------- + alat0 = alat(ii) + alon0 = alon(ii) + ht_ft0 = ht_ft(ii) + idt0 = idt(ii) +c +c if(c_qc(ii)(7:8).ne.'..') then +c uwind0 = amiss +c vwind0 = amiss +c else +c uwind0 = -sin(ob_dir(ii)*d2r)*ob_spd(ii) +c vwind0 = -cos(ob_dir(ii)*d2r)*ob_spd(ii) +c endif +c +c Set up temporary variables for iim1 point +c ----------------------------------------- + if(iim1.ne.0) then + alatm1 = alat(iim1) + alonm1 = alon(iim1) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonm1.gt.270.0) + $ alonm1 = 360.0 - alonm1 + if(alon0.gt.270.0.and.alonm1.lt.90.0) + $ alonm1 = 360.0 + alonm1 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm1 = ht_ft(iim1) + idtm1 = idt(iim1) +c +c if(c_qc(iim1)(7:8).ne.'..') then +c uwindm1 = amiss +c vwindm1 = amiss +c else +c uwindm1 = -sin(ob_dir(iim1)*d2r)*ob_spd(iim1) +c vwindm1 = -cos(ob_dir(iim1)*d2r)*ob_spd(iim1) +c endif +c +c Compute groundspeed vector components between ii and iim1 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtm1.ne.imiss) then + idt_dif0 = abs(idt0 - idtm1) + else + idt_dif0 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatm1.ne.amiss.and.alonm1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif0.ne.imiss) then + udist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iim1),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(ii)-alon(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist0 = -udist0 + vdist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii ),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(ii)-alat(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist0 = -vdist0 + dist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii ),alon(ii )) + if(idt_dif0.gt.0) then + upspd0 = udist0 / float(idt_dif0) + vpspd0 = vdist0 / float(idt_dif0) + pspd0 = dist0 / float(idt_dif0) + else + upspd0 = udist0 / float(idt_dif0+60) + vpspd0 = vdist0 / float(idt_dif0+60) + pspd0 = dist0 / float(idt_dif0+60) + endif + if(upspd0.eq.0.0.and.vpspd0.eq.0.0) then + pdir0 = 0.0 + else + pdir0 = atan2(upspd0,vpspd0) / d2r + 180.0 + endif + dist0 = dist0 / 1000.0 + else + udist0 = amiss + vdist0 = amiss + dist0 = amiss + upspd0 = amiss + vpspd0 = amiss + pspd0 = amiss + pdir0 = amiss + endif +c +c Compute airspeed between ii and iim1 points +c ------------------------------------------- +c if(uwind0.ne.amiss.and.upspd0.ne.amiss) then +c uairspd0 = upspd0 - uwind0 +c vairspd0 = vpspd0 - vwind0 +c airspd0 = sqrt(uairspd0**2+vairspd0**2) +c + if(ob_dir(ii).ne.amiss.and.ob_spd(ii).ne.amiss) then + airspd0 = sqrt(pspd0**2 + ob_spd(ii)**2 + $ - 2.0*pspd0*ob_spd(ii)*cos((pdir0-ob_dir(ii))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspd0.gt.spd_thresh.and. + $ (abs(idt_dif0).eq.60.or. + $ (abs(idt_dif0).lt.60.and. + $ ((idt(ii )/60)*60.eq.idt(ii ).or. + $ (idt(iim1)/60)*60.eq.idt(iim1))))) then +c + airspd0 = airspd0 / 2.0 +c + endif +c +c if(uairspd0.eq.0.0.and.vairspd0.eq.0.0) then +c airdir0 = 0.0 +c else +c airdir0 = atan2(uairspd0,vairspd0) / d2r + 180.0 +c endif +c + else +c uairspd0 = amiss +c vairspd0 = amiss + airspd0 = pspd0 +c airdir0 = pdir0 + endif +c +c Compute vertical speed between ii and iim1 points +c ------------------------------------------------- + if(ht_ft0.ne.amiss.and.ht_ftm1.ne.amiss) then + ht_dif0 = ht_ft(ii) - ht_ft(iim1) + else + ht_dif0 = amiss + endif + if(ht_dif0.eq.amiss.or.idt_dif0.eq.imiss) then + vspd0 = amiss + elseif(idt_dif0.gt.0) then + vspd0 = ht_dif0 / float(idt_dif0) + else + vspd0 = ht_dif0 / float(idt_dif0+60) + endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm1 = amiss + alonm1 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm1 = amiss + idtm1 = amiss +c uwindm1 = amiss +c vwindm1 = amiss +c + idt_dif0 = imiss + udist0 = amiss + vdist0 = amiss + dist0 = amiss + upspd0 = amiss + vpspd0 = amiss + pspd0 = amiss + pdir0 = amiss +c +c uairspd0 = amiss +c vairspd0 = amiss + airspd0 = amiss +c airdir0 = amiss +c + ht_dif0 = amiss + vspd0 = amiss + endif +c +c Set up temporary variables for iim2 point +c ----------------------------------------- + if(iim2.ne.0.and.iim1.ne.0) then + alatm2 = alat(iim2) + alonm2 = alon(iim2) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonm2.gt.270.0) + $ alonm2 = 360.0 - alonm2 + if(alon0.gt.270.0.and.alonm2.lt.90.0) + $ alonm2 = 360.0 + alonm2 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm2 = ht_ft(iim2) + idtm2 = idt(iim2) +c +c if(c_qc(iim2)(7:8).ne.'..') then +c uwindm2 = amiss +c vwindm2 = amiss +c else +c uwindm2 = -sin(ob_dir(iim2)*d2r)*ob_spd(iim2) +c vwindm2 = -cos(ob_dir(iim2)*d2r)*ob_spd(iim2) +c endif +c +c Compute groundspeed vector components between iim2 and iim1 points +c ------------------------------------------------------------------ + if(idtm1.ne.imiss.and.idtm2.ne.imiss) then + idt_difm1 = abs(idtm1 - idtm2) + else + idt_difm1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatm2.ne.amiss.and.alonm2.ne.amiss.and. + $ alatm1.ne.amiss.and.alonm1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difm1.ne.imiss) then + udistm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim2),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iim1)-alon(iim2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistm1 = -udistm1 + vdistm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iim1)-alat(iim2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistm1 = -vdistm1 + distm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim1)) + if(idt_difm1.gt.0) then + upspdm1 = udistm1 / float(idt_difm1) + vpspdm1 = vdistm1 / float(idt_difm1) + pspdm1 = distm1 / float(idt_difm1) + else + upspdm1 = udistm1 / float(idt_difm1+60) + vpspdm1 = vdistm1 / float(idt_difm1+60) + pspdm1 = distm1 / float(idt_difm1+60) + endif + if(upspdm1.eq.0.0.and.vpspdm1.eq.0.0) then + pdirm1 = 0.0 + else + pdirm1 = atan2(upspdm1,vpspdm1) / d2r + 180.0 + endif + distm1 = distm1 / 1000.0 + else + udistm1 = amiss + vdistm1 = amiss + distm1 = amiss + upspdm1 = amiss + vpspdm1 = amiss + pspdm1 = amiss + pdirm1 = amiss + endif +c +c Compute airspeed between iim2 and iim1 points +c --------------------------------------------- +c if(uwindm1.ne.amiss.and.upspdm1.ne.amiss) then +c uairspdm1 = upspdm1 - uwindm1 +c vairspdm1 = vpspdm1 - vwindm1 +c airspdm1 = sqrt(uairspdm1**2+vairspdm1**2) +c + if(ob_dir(iim1).ne.amiss.and.ob_spd(iim1).ne.amiss) then + airspdm1 = sqrt(pspdm1**2 + ob_spd(iim1)**2 + $ - 2.0*pspdm1*ob_spd(iim1) + $ *cos((pdirm1-ob_dir(iim1))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspdm1.gt.spd_thresh.and. + $ (abs(idt_difm1).eq.60.or. + $ (abs(idt_difm1).lt.60.and. + $ ((idt(iim1)/60)*60.eq.idt(iim1).or. + $ (idt(iim2)/60)*60.eq.idt(iim2))))) then +c + airspdm1 = airspdm1 / 2.0 +c + endif +c +c if(uairspdm1.eq.0.0.and.vairspdm1.eq.0.0) then +c airdirm1 = 0.0 +c else +c airdirm1 = atan2(uairspdm1,vairspdm1) / d2r + 180.0 +c endif +c + else +c uairspdm1 = amiss +c vairspdm1 = amiss + airspdm1 = pspdm1 +c airdirm1 = pdirm1 + endif +c +c Compute vertical speed between iim2 and iim1 points +c --------------------------------------------------- + if(ht_ftm2.ne.amiss.and.ht_ftm1.ne.amiss) then + ht_difm1 = ht_ft(iim1) - ht_ft(iim2) + else + ht_difm1 = amiss + endif + if(ht_difm1.eq.amiss.or.idt_difm1.eq.imiss) then + vspdm1 = amiss + elseif(idt_difm1.gt.0) then + vspdm1 = ht_difm1 / float(idt_difm1) + else + vspdm1 = ht_difm1 / float(idt_difm1+60) + endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm2 = amiss + alonm2 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm2 = amiss + idtm2 = amiss +c uwindm2 = amiss +c vwindm2 = amiss +c + idt_difm1 = imiss + udistm1 = amiss + vdistm1 = amiss + distm1 = amiss + upspdm1 = amiss + vpspdm1 = amiss + pspdm1 = amiss + pdirm1 = amiss +c +c uairspdm1 = amiss +c vairspdm1 = amiss + airspdm1 = amiss +c airdirm1 = amiss +c + ht_difm1 = amiss + vspdm1 = amiss + endif +c +c Set other variables to missing +c ------------------------------ +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm3 = amiss + alonm3 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm3 = amiss + idtm3 = amiss +c uwindm3 = amiss +c vwindm3 = amiss +c + idt_difm2 = imiss + udistm2 = amiss + vdistm2 = amiss + distm2 = amiss + upspdm2 = amiss + vpspdm2 = amiss + pspdm2 = amiss + pdirm2 = amiss +c +c uairspdm2 = amiss +c vairspdm2 = amiss + airspdm2 = amiss +c airdirm2 = amiss +c + ht_difm2 = amiss + vspdm2 = amiss +c +c Set up temporary variables for iip1 point +c ----------------------------------------- + if(iip1.ne.0) then + alatp1 = alat(iip1) + alonp1 = alon(iip1) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonp1.gt.270.0) + $ alonp1 = 360.0 - alonp1 + if(alon0.gt.270.0.and.alonp1.lt.90.0) + $ alonp1 = 360.0 + alonp1 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp1 = ht_ft(iip1) + idtp1 = idt(iip1) +c +c if(c_qc(iip1)(7:8).ne.'..') then +c uwindp1 = amiss +c vwindp1 = amiss +c else +c uwindp1 = -sin(ob_dir(iip1)*d2r)*ob_spd(iip1) +c vwindp1 = -cos(ob_dir(iip1)*d2r)*ob_spd(iip1) +c endif +c +c Compute groundspeed vector components between ii and iip1 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtp1.ne.imiss) then + idt_difp1 = abs(idt0 - idtp1) + else + idt_difp1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatp1.ne.amiss.and.alonp1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difp1.ne.imiss) then + udistp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(ii ),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip1)-alon(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistp1 = -udistp1 + vdistp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip1),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip1)-alat(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistp1 = -vdistp1 + distp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip1),alon(iip1)) + if(idt_difp1.gt.0) then + upspdp1 = udistp1 / float(idt_difp1) + vpspdp1 = vdistp1 / float(idt_difp1) + pspdp1 = distp1 / float(idt_difp1) + else + upspdp1 = udistp1 / float(idt_difp1+60) + vpspdp1 = vdistp1 / float(idt_difp1+60) + pspdp1 = distp1 / float(idt_difp1+60) + endif + if(upspdp1.eq.0.0.and.vpspdp1.eq.0.0) then + pdirp1 = 0.0 + else + pdirp1 = atan2(upspdp1,vpspdp1) / d2r + 180.0 + endif + distp1 = distp1 / 1000.0 + else + udistp1 = amiss + vdistp1 = amiss + distp1 = amiss + upspdp1 = amiss + vpspdp1 = amiss + pspdp1 = amiss + pdirp1 = amiss + endif +c +c Compute airspeed between ii and iip1 points +c ------------------------------------------- +c if(uwindp1.ne.amiss.and.upspdp1.ne.amiss) then +c uairspdp1 = upspdp1 - uwindp1 +c vairspdp1 = vpspdp1 - vwindp1 +c airspdp1 = sqrt(uairspdp1**2+vairspdp1**2) +c + if(ob_dir(iip1).ne.amiss.and.ob_spd(iip1).ne.amiss) then + airspdp1 = sqrt(pspdp1**2 + ob_spd(iip1)**2 + $ - 2.0*pspdp1*ob_spd(iip1) + $ *cos((pdirp1-ob_dir(iip1))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspdp1.gt.spd_thresh.and. + $ (abs(idt_difp1).eq.60.or. + $ (abs(idt_difp1).lt.60.and. + $ ((idt(ii )/60)*60.eq.idt(ii ).or. + $ (idt(iip1)/60)*60.eq.idt(iip1))))) then +c + airspdp1 = airspdp1 / 2.0 +c + endif +c +c if(uairspdp1.eq.0.0.and.vairspdp1.eq.0.0) then +c airdirp1 = 0.0 +c else +c airdirp1 = atan2(uairspdp1,vairspdp1) / d2r + 180.0 +c endif +c + else +c uairspdp1 = amiss +c vairspdp1 = amiss + airspdp1 = pspdp1 +c airdirp1 = pdirp1 + endif +c +c Compute vertical speed between ii and iip1 points +c ------------------------------------------------- + if(ht_ft0.ne.amiss.and.ht_ftp1.ne.amiss) then + ht_difp1 = ht_ft(iip1) - ht_ft(ii) + else + ht_difp1 = amiss + endif + if(ht_difp1.eq.amiss.or.idt_difp1.eq.imiss) then + vspdp1 = amiss + elseif(idt_difp1.gt.0) then + vspdp1 = ht_difp1 / float(idt_difp1) + else + vspdp1 = ht_difp1 / float(idt_difp1+60) + endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp1 = amiss + alonp1 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp1 = amiss + idtp1 = amiss +c uwindp1 = amiss +c vwindp1 = amiss +c + idt_difp1 = imiss + udistp1 = amiss + vdistp1 = amiss + distp1 = amiss + upspdp1 = amiss + vpspdp1 = amiss + pspdp1 = amiss + pdirp1 = amiss +c +c uairspdp1 = amiss +c vairspdp1 = amiss + airspdp1 = amiss +c airdirp1 = amiss +c + ht_difp1 = amiss + vspdp1 = amiss + endif +c +c Set up temporary variables for iip2 point +c ----------------------------------------- + if(iip2.ne.0) then + alatp2 = alat(iip2) + alonp2 = alon(iip2) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonp2.gt.270.0) + $ alonp2 = 360.0 - alonp2 + if(alon0.gt.270.0.and.alonp2.lt.90.0) + $ alonp2 = 360.0 + alonp2 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp2 = ht_ft(iip2) + idtp2 = idt(iip2) +c +c if(c_qc(iip2)(7:8).ne.'..') then +c uwindp2 = amiss +c vwindp2 = amiss +c else +c uwindp2 = -sin(ob_dir(iip2)*d2r)*ob_spd(iip2) +c vwindp2 = -cos(ob_dir(iip2)*d2r)*ob_spd(iip2) +c endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp2 = amiss + alonp2 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp2 = amiss + idtp2 = amiss +c uwindp2 = amiss +c vwindp2 = amiss + endif +c + if(iip2.ne.0.and.iip1.ne.0) then +c +c Compute groundspeed vector components between iip1 and iip2 points +c ------------------------------------------------------------------ + if(idtp1.ne.imiss.and.idtp2.ne.imiss) then + idt_difp2 = abs(idtp1 - idtp2) + else + idt_difp2 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatp1.ne.amiss.and.alonp1.ne.amiss.and. + $ alatp2.ne.amiss.and.alonp2.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difp2.ne.imiss) then + udistp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip1),alon(iip2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip2)-alon(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistp2 = -udistp2 + vdistp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip2),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip2)-alat(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistp2 = -vdistp2 + distp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip2),alon(iip2)) + if(idt_difp2.gt.0) then + upspdp2 = udistp2 / float(idt_difp2) + vpspdp2 = vdistp2 / float(idt_difp2) + pspdp2 = distp2 / float(idt_difp2) + else + upspdp2 = udistp2 / float(idt_difp2+60) + vpspdp2 = vdistp2 / float(idt_difp2+60) + pspdp2 = distp2 / float(idt_difp2+60) + endif + if(upspdp2.eq.0.0.and.vpspdp2.eq.0.0) then + pdirp2 = 0.0 + else + pdirp2 = atan2(upspdp2,vpspdp2) / d2r + 180.0 + endif + distp2 = distp2 / 1000.0 + else + udistp2 = amiss + vdistp2 = amiss + distp2 = amiss + upspdp2 = amiss + vpspdp2 = amiss + pspdp2 = amiss + pdirp2 = amiss + endif +c +c Compute airspeed between iip1 and iip2 points +c --------------------------------------------- +c if(uwindp2.ne.amiss.and.upspdp2.ne.amiss) then +c uairspdp2 = upspdp2 - uwindp2 +c vairspdp2 = vpspdp2 - vwindp2 +c airspdp2 = sqrt(uairspdp2**2+vairspdp2**2) +c + if(ob_dir(iip2).ne.amiss.and.ob_spd(iip2).ne.amiss) then + airspdp2 = sqrt(pspdp2**2 + ob_spd(iip2)**2 + $ - 2.0*pspdp2*ob_spd(iip2) + $ *cos((pdirp2-ob_dir(iip2))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspdp2.gt.spd_thresh.and. + $ (abs(idt_difp2).eq.60.or. + $ (abs(idt_difp2).lt.60.and. + $ ((idt(iip1)/60)*60.eq.idt(iip1).or. + $ (idt(iip2)/60)*60.eq.idt(iip2))))) then +c + airspdp2 = airspdp2 / 2.0 +c + endif +c +c if(uairspdp2.eq.0.0.and.vairspdp2.eq.0.0) then +c airdirp2 = 0.0 +c else +c airdirp2 = atan2(uairspdp2,vairspdp2) / d2r + 180.0 +c endif +c + else +c uairspdp2 = amiss +c vairspdp2 = amiss + airspdp2 = pspdp2 +c airdirp2 = pdirp2 + endif +c +c Compute vertical speed between iip1 and iip2 points +c --------------------------------------------------- + if(ht_ftp1.ne.amiss.and.ht_ftp2.ne.amiss) then + ht_difp2 = ht_ft(iip2) - ht_ft(iip1) + else + ht_difp2 = amiss + endif + if(ht_difp2.eq.amiss.or.idt_difp2.eq.imiss) then + vspdp2 = amiss + elseif(idt_difp2.gt.0) then + vspdp2 = ht_difp2 / float(idt_difp2) + else + vspdp2 = ht_difp2 / float(idt_difp2+60) + endif +c + else + idt_difp2 = imiss + udistp2 = amiss + vdistp2 = amiss + distp2 = amiss + upspdp2 = amiss + vpspdp2 = amiss + pspdp2 = amiss + pdirp2 = amiss +c +c uairspdp2 = amiss +c vairspdp2 = amiss + airspdp2 = amiss +c airdirp2 = amiss +c + ht_difp2 = amiss + vspdp2 = amiss + endif +c +c Set other variables to zero +c --------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp3 = amiss + alonp3 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp3 = amiss + idtp3 = amiss +c uwindp3 = amiss +c vwindp3 = amiss +c + idt_difp3 = imiss + udistp3 = amiss + vdistp3 = amiss + distp3 = amiss + upspdp3 = amiss + vpspdp3 = amiss + pspdp3 = amiss + pdirp3 = amiss +c +c uairspdp3 = amiss +c vairspdp3 = amiss + airspdp3 = amiss +c airdirp3 = amiss +c + ht_difp3 = amiss + vspdp3 = amiss +c +c Compute speeds without ii report +c -------------------------------- + if(iim1.ne.0.and.iip1.ne.0.and. + $ idtp1.ne.amiss.and.idtm1.ne.amiss) then +c +c Compute groundspeed vector components between iim1 and iip1 points +c ------------------------------------------------------------------ + if(idtm1.ne.imiss.and.idtp1.ne.imiss) then + idt_dif_wo0 = abs(idtp1 - idtm1) + else + idt_dif_wo0 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatm1.ne.amiss.and.alonm1.ne.amiss.and. + $ alatp1.ne.amiss.and.alonp1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_wo0.ne.imiss) then + udist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iim1),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip1)-alon(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_wo0 = -udist_wo0 + vdist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iip1),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip1)-alat(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_wo0 = -vdist_wo0 + dist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iip1),alon(iip1)) + if(idt_dif_wo0.gt.0) then + upspd_wo0 = udist_wo0 / float(idt_dif_wo0) + vpspd_wo0 = vdist_wo0 / float(idt_dif_wo0) + pspd_wo0 = dist_wo0 / float(idt_dif_wo0) + else + upspd_wo0 = udist_wo0 / float(idt_dif_wo0+60) + vpspd_wo0 = vdist_wo0 / float(idt_dif_wo0+60) + pspd_wo0 = dist_wo0 / float(idt_dif_wo0+60) + endif + if(upspd_wo0.eq.0.0.and.vpspd_wo0.eq.0.0) then + pdir_wo0 = 0.0 + else + pdir_wo0 = atan2(upspd_wo0,vpspd_wo0) + $ / d2r + 180.0 + endif + dist_wo0 = dist_wo0 / 1000.0 + else + udist_wo0 = amiss + vdist_wo0 = amiss + dist_wo0 = amiss + upspd_wo0 = amiss + vpspd_wo0 = amiss + pspd_wo0 = amiss + pdir_wo0 = amiss + endif +c +c Compute airspeed between iim1 and iip1 points +c --------------------------------------------- +c if(uwindp1.ne.amiss.and.upspd_wo0.ne.amiss) then +c uairspd_wo0 = upspd_wo0 - uwindp1 +c vairspd_wo0 = vpspd_wo0 - vwindp1 +c airspd_wo0 = sqrt(uairspd_wo0**2+vairspd_wo0**2) +c + if(ob_dir(iip1).ne.amiss.and.ob_spd(iip1).ne.amiss) then + airspd_wo0 = sqrt(pspd_wo0**2 + ob_spd(iip1)**2 + $ - 2.0*pspd_wo0*ob_spd(iip1) + $ *cos((pdir_wo0-ob_dir(iip1))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspd_wo0.gt.spd_thresh.and. + $ (abs(idt_dif_wo0).eq.60.or. + $ (abs(idt_dif_wo0).lt.60.and. + $ ((idt(iim1)/60)*60.eq.idt(iim1).or. + $ (idt(iip1)/60)*60.eq.idt(iip1))))) then +c + airspd_wo0 = airspd_wo0 / 2.0 +c + endif +c +c if(uairspd_wo0.eq.0.0.and.vairspd_wo0.eq.0.0) then +c airdir_wo0 = 0.0 +c else +c airdir_wo0 = atan2(uairspd_wo0,vairspd_wo0) +c $ / d2r + 180.0 +c endif +c + else +c uairspd_wo0 = amiss +c vairspd_wo0 = amiss + airspd_wo0 = pspd_wo0 +c airdir_wo0 = pdir_wo0 + endif +c + else + udist_wo0 = amiss + vdist_wo0 = amiss + dist_wo0 = amiss + upspd_wo0 = amiss + vpspd_wo0 = amiss + pspd_wo0 = amiss + pdir_wo0 = amiss +c +c uairspd_wo0 = amiss +c vairspd_wo0 = amiss + airspd_wo0 = amiss +c airdir_wo0 = amiss + endif +c +c Compute vertical speed between iim1 and iip1 points +c --------------------------------------------------- + if(ht_ftp1.ne.amiss.and.ht_ftm1.ne.amiss) then + ht_dif_wo0 = ht_ftp1 - ht_ftm1 + else + ht_dif_wo0 = amiss + endif + if(ht_dif_wo0.eq.amiss.or.idt_dif_wo0.eq.imiss) then + vspd_wo0 = amiss + elseif(idt_dif_wo0.gt.0) then + vspd_wo0 = ht_dif_wo0 / float(idt_dif_wo0) + else + vspd_wo0 = ht_dif_wo0 / float(idt_dif_wo0+60) + endif +c +c Compute speeds without iip1 report +c ---------------------------------- + if(iip2.ne.0.and. + $ idt0.ne.amiss.and.idtp2.ne.amiss) then +c +c Compute groundspeed vector components between ii and iip2 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtp2.ne.imiss) then + idt_dif_wop1 = abs(idtp2 - idt0) + else + idt_dif_wop1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatp2.ne.amiss.and.alonp2.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_wop1.ne.imiss) then + udist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(ii ),alon(iip2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip2)-alon(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_wop1 = -udist_wop1 + vdist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip2),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip2)-alat(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_wop1 = -vdist_wop1 + dist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip2),alon(iip2)) + if(idt_dif_wop1.gt.0) then + upspd_wop1 = udist_wop1 / float(idt_dif_wop1) + vpspd_wop1 = vdist_wop1 / float(idt_dif_wop1) + pspd_wop1 = dist_wop1 / float(idt_dif_wop1) + else + upspd_wop1 = udist_wop1 / float(idt_dif_wop1+60) + vpspd_wop1 = vdist_wop1 / float(idt_dif_wop1+60) + pspd_wop1 = dist_wop1 / float(idt_dif_wop1+60) + endif + if(upspd_wop1.eq.0.0.and.vpspd_wop1.eq.0.0) then + pdir_wop1 = 0.0 + else + pdir_wop1 = atan2(upspd_wop1,vpspd_wop1) + $ / d2r + 180.0 + endif + dist_wop1 = dist_wop1 / 1000.0 + else + udist_wop1 = amiss + vdist_wop1 = amiss + dist_wop1 = amiss + upspd_wop1 = amiss + vpspd_wop1 = amiss + pspd_wop1 = amiss + pdir_wop1 = amiss + endif +c +c Compute airspeed between ii and iip2 points +c ------------------------------------------- +c if(uwindp2.ne.amiss.and.upspd_wop1.ne.amiss) then +c uairspd_wop1 = upspd_wop1 - uwindp2 +c vairspd_wop1 = vpspd_wop1 - vwindp2 +c airspd_wop1 = sqrt(uairspd_wop1**2+vairspd_wop1**2) +c + if(ob_dir(iip2).ne.amiss.and.ob_spd(iip2).ne.amiss) then + airspd_wop1 = sqrt(pspd_wop1**2 + ob_spd(iip2)**2 + $ - 2.0*pspd_wop1*ob_spd(iip2) + $ *cos((pdir_wop1-ob_dir(iip2))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspd_wop1.gt.spd_thresh.and. + $ (abs(idt_dif_wop1).eq.60.or. + $ (abs(idt_dif_wop1).lt.60.and. + $ ((idt(ii )/60)*60.eq.idt(ii ).or. + $ (idt(iip2)/60)*60.eq.idt(iip2))))) then +c + airspd_wop1 = airspd_wop1 / 2.0 +c + endif +c +c if(uairspd_wop1.eq.0.0.and.vairspd_wop1.eq.0.0) then +c airdir_wop1 = 0.0 +c else +c airdir_wop1 = atan2(uairspd_wop1,vairspd_wop1) +c $ / d2r + 180.0 +c endif +c + else +c uairspd_wop1 = amiss +c vairspd_wop1 = amiss + airspd_wop1 = pspd_wop1 +c airdir_wop1 = pdir_wop1 + endif +c + else + udist_wop1 = amiss + vdist_wop1 = amiss + dist_wop1 = amiss + upspd_wop1 = amiss + vpspd_wop1 = amiss + pspd_wop1 = amiss + pdir_wop1 = amiss +c +c uairspd_wop1 = amiss +c vairspd_wop1 = amiss + airspd_wop1 = amiss +c airdir_wop1 = amiss + endif +c +c Compute vertical speed between ii and iip2 points +c ------------------------------------------------- + if(ht_ftp2.ne.amiss.and.ht_ft0.ne.amiss) then + ht_dif_wop1 = ht_ftp2 - ht_ft0 + else + ht_dif_wop1 = amiss + endif + if(ht_dif_wop1.eq.amiss.or.idt_dif_wop1.eq.imiss) then + vspd_wop1 = amiss + elseif(idt_dif_wop1.gt.0) then + vspd_wop1 = ht_dif_wop1 / float(idt_dif_wop1) + else + vspd_wop1 = ht_dif_wop1 / float(idt_dif_wop1+60) + endif +c +c Set other variables to zero +c --------------------------- + udist_wop2 = amiss + vdist_wop2 = amiss + dist_wop2 = amiss + upspd_wop2 = amiss + vpspd_wop2 = amiss + pspd_wop2 = amiss + pdir_wop2 = amiss +c +c uairspd_wop2 = amiss +c vairspd_wop2 = amiss + airspd_wop2 = amiss +c airdir_wop2 = amiss +c + ht_dif_wop2 = amiss +c + vspd_wop2 = amiss +c +c Compute speeds between previous two bad points +c ---------------------------------------------- + if(last_bad.ne.0.and.last_bad_m1.ne.0) then +c +c Compute groundspeed vector components between last_bad and last_bad_m1 points +c ----------------------------------------------------------------------------- + if(idt(last_bad_m1).ne.imiss.and. + $ idt(last_bad).ne.imiss) then + idt_dif_bad0 = abs(idt(last_bad) - idt(last_bad_m1)) + else + idt_dif_bad0 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(last_bad).ne.amiss.and. + $ alon(last_bad).ne.amiss.and. + $ alat(last_bad_m1).ne.amiss.and. + $ alon(last_bad_m1).ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_bad0.ne.imiss) then + udist_bad0 = gcirc_qc(alat(last_bad_m1), + $ alon(last_bad_m1), + $ alat(last_bad_m1), + $ alon(last_bad)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(last_bad)-alon(last_bad_m1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_bad0 = -udist_bad0 + vdist_bad0 = gcirc_qc(alat(last_bad_m1), + $ alon(last_bad_m1), + $ alat(last_bad), + $ alon(last_bad_m1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(last_bad)-alat(last_bad_m1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_bad0 = -vdist_bad0 + dist_bad0 = gcirc_qc(alat(last_bad_m1), + $ alon(last_bad_m1), + $ alat(last_bad ), + $ alon(last_bad )) + if(idt_dif_bad0.gt.0) then + upspd_bad0 = udist_bad0 / float(idt_dif_bad0) + vpspd_bad0 = vdist_bad0 / float(idt_dif_bad0) + pspd_bad0 = dist_bad0 / float(idt_dif_bad0) + else + upspd_bad0 = udist_bad0 / float(idt_dif_bad0+60) + vpspd_bad0 = vdist_bad0 / float(idt_dif_bad0+60) + pspd_bad0 = dist_bad0 / float(idt_dif_bad0+60) + endif + if(upspd_bad0.eq.0.0.and.vpspd_bad0.eq.0.0) then + pdir_bad0 = 0.0 + else + pdir_bad0 = atan2(upspd_bad0,vpspd_bad0) + $ / d2r + 180.0 + endif + dist_bad0 = dist_bad0 / 1000.0 + else + udist_bad0 = amiss + vdist_bad0 = amiss + dist_bad0 = amiss + upspd_bad0 = amiss + vpspd_bad0 = amiss + pspd_bad0 = amiss + pdir_bad0 = amiss + endif +c +c Compute airspeed between last_bad and last_bad_m1 points +c -------------------------------------------------------- +c if(uwind_last.ne.amiss.and.upspd_bad0.ne.amiss) then +c uairspd_bad0 = upspd_bad0 - uwind_last +c vairspd_bad0 = vpspd_bad0 - vwind_last +c airspd_bad0 = sqrt(uairspd_bad0**2+vairspd_bad0**2) +c + if(wdir_last.ne.amiss.and.wspd_last.ne.amiss) then + airspd_bad0 = sqrt(pspd_bad0**2 + wspd_last**2 + $ - 2.0*pspd_bad0*wspd_last + $ *cos((pdir_bad0-wdir_last)*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspd_bad0.gt.spd_thresh.and. + $ (abs(idt_dif_bad0).eq.60.or. + $ (abs(idt_dif_bad0).lt.60.and. + $ ((idt(last_bad_m1)/60)*60.eq.idt(last_bad_m1).or. + $ (idt(last_bad)/60)*60.eq.idt(last_bad))))) then +c + airspd_bad0 = airspd_bad0 / 2.0 +c + endif +c +c if(uairspd_bad0.eq.0.0.and.vairspd_bad0.eq.0.0) then +c airdir_bad0 = 0.0 +c else +c airdir_bad0 = atan2(uairspd_bad0,vairspd_bad0) +c $ / d2r + 180.0 +c endif +c + else +c uairspd_bad0 = amiss +c vairspd_bad0 = amiss + airspd_bad0 = pspd_bad0 +c airdir_bad0 = pspd_bad0 + endif +c +c Compute vertical speed between last_bad and last_bad_m1 points +c -------------------------------------------------------------- + if(ht_ft(last_bad).ne.amiss.and. + $ ht_ft(last_bad_m1).ne.amiss) then + ht_dif_bad0 = ht_ft(last_bad) - ht_ft(last_bad_m1) + else + ht_dif_bad0 = amiss + endif + if(ht_dif_bad0.eq.amiss.or.idt_dif_bad0.eq.imiss) then + vspd_bad0 = amiss + elseif(idt_dif_bad0.gt.0) then + vspd_bad0 = ht_dif_bad0 / float(idt_dif_bad0) + else + vspd_bad0 = ht_dif_bad0 / float(idt_dif_bad0+60) + endif +c + else + udist_bad0 = amiss + vdist_bad0 = amiss + dist_bad0 = amiss + upspd_bad0 = amiss + vpspd_bad0 = amiss + pspd_bad0 = amiss + pdir_bad0 = amiss +c +c uairspd_bad0 = amiss +c vairspd_bad0 = amiss + airspd_bad0 = amiss +c airdir_bad0 = amiss +c + ht_dif_bad0 = amiss + vspd_bad0 = amiss + endif +c +c Compute speeds between last bad point and iip1 point +c ---------------------------------------------------- + if(last_bad.ne.0.and.iip1.ne.0) then +c + idt_last_bad = idt(last_bad) +c +c Compute groundspeed vector components between last_bad and iip1 points +c ---------------------------------------------------------------------- + if(idtp1.ne.imiss.and.idt(last_bad).ne.imiss) then + idt_dif_badp1 = abs(idtp1 - idt(last_bad)) + else + idt_dif_badp1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatp1.ne.amiss.and.alonp1.ne.amiss.and. + $ alat(last_bad).ne.amiss.and. + $ alon(last_bad).ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_badp1.ne.imiss) then + udist_badp1 = gcirc_qc(alat(last_bad),alon(last_bad), + $ alat(last_bad),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip1)-alon(last_bad))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_badp1 = -udist_badp1 + vdist_badp1 = gcirc_qc(alat(last_bad),alon(last_bad), + $ alat(iip1 ),alon(last_bad)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip1)-alat(last_bad))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_badp1 = -vdist_badp1 + dist_badp1 = gcirc_qc(alat(last_bad),alon(last_bad), + $ alat(iip1),alon(iip1)) + if(idt_dif_badp1.gt.0) then + upspd_badp1 = udist_badp1 / float(idt_dif_badp1) + vpspd_badp1 = vdist_badp1 / float(idt_dif_badp1) + pspd_badp1 = dist_badp1 / float(idt_dif_badp1) + else + upspd_badp1= udist_badp1 / float(idt_dif_badp1+60) + vpspd_badp1= vdist_badp1 / float(idt_dif_badp1+60) + pspd_badp1 = dist_badp1 / float(idt_dif_badp1+60) + endif + if(upspd_badp1.eq.0.0.and.vpspd_badp1.eq.0.0) then + pdir_badp1 = 0.0 + else + pdir_badp1 = atan2(upspd_badp1,vpspd_badp1) + $ / d2r + 180.0 + endif + dist_badp1 = dist_badp1 / 1000.0 + else + udist_badp1 = amiss + vdist_badp1 = amiss + dist_badp1 = amiss + upspd_badp1 = amiss + vpspd_badp1 = amiss + pspd_badp1 = amiss + pdir_badp1 = amiss + endif +c +c Compute airspeed between last_bad and iip1 points +c ------------------------------------------------- +c if(uwindp1.ne.amiss.and.upspd_badp1.ne.amiss) then +c uairspd_badp1 = upspd_badp1 - uwindp1 +c vairspd_badp1 = vpspd_badp1 - vwindp1 +c airspd_badp1 = +c $ sqrt(uairspd_badp1**2+vairspd_badp1**2) +c + if(ob_dir(iip1).ne.amiss.and.ob_spd(iip1).ne.amiss) then + airspd_badp1 = sqrt(pspd_badp1**2 + ob_spd(iip1)**2 + $ - 2.0*pspd_badp1*ob_spd(iip1) + $ *cos((pdir_badp1-ob_dir(iip1))*d2r)) +c +c Make allowances for aircraft that round time to the +c nearest minute--divide by 120 sec rather than 60 sec +c (modified to allow for mixture of reports with time +c rounded to the nearest minute and interpolated time +c to the nearest second in ascents--P.M.Pauley 6/11/01) +c ---------------------------------------------------- + if(airspd_badp1.gt.spd_thresh.and. + $ (abs(idt_dif_badp1).eq.60.or. + $ (abs(idt_dif_badp1).lt.60.and. + $ ((idt(last_bad)/60)*60.eq.idt(last_bad).or. + $ (idt(iip1)/60)*60.eq.idt(iip1))))) then +c + airspd_badp1 = airspd_badp1 / 2.0 +c + endif +c +c if(uairspd_badp1.eq.0.0.and. +c $ vairspd_badp1.eq.0.0) then +c airdir_badp1 = 0.0 +c else +c airdir_badp1 = atan2(uairspd_badp1,vairspd_badp1) +c $ / d2r + 180.0 +c endif +c + else +c uairspd_badp1 = amiss +c vairspd_badp1 = amiss + airspd_badp1 = pspd_badp1 +c airdir_badp1 = pspd_badp1 + endif +c +c Compute vertical speed between last_bad and iip1 points +c ------------------------------------------------------- + if(ht_ftp1.ne.amiss.and. + $ ht_ft(last_bad).ne.amiss) then + ht_dif_badp1 = ht_ft(iip1) - ht_ft(last_bad) + else + ht_dif_badp1 = amiss + endif + if(ht_dif_badp1.eq.amiss.or.idt_dif_badp1.eq.imiss) then + vspd_badp1 = amiss + elseif(idt_dif_badp1.gt.0) then + vspd_badp1 = ht_dif_badp1 / float(idt_dif_badp1) + else + vspd_badp1 = ht_dif_badp1 / float(idt_dif_badp1+60) + endif +c + else + idt_last_bad = imiss +c + udist_badp1 = amiss + vdist_badp1 = amiss + dist_badp1 = amiss + upspd_badp1 = amiss + vpspd_badp1 = amiss + pspd_badp1 = amiss + pdir_badp1 = amiss +c +c uairspd_badp1 = amiss +c vairspd_badp1 = amiss + airspd_badp1 = amiss +c airdir_badp1 = amiss +c + ht_dif_badp1 = amiss + vspd_badp1 = amiss + endif +c +c Compute magnitude of temperature, direction, and speed differences +c (constrain direction difference to be less than 180 deg) +c ------------------------------------------------------------------ + if(iip1.ne.0) then +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0.eq.amiss.or.alatp1.eq.amiss) then + alat_dif = amiss + alon_dif = amiss + else + alat_dif = abs(alat0 - alatp1) + alon_dif = abs(alon0 - alonp1) + if(alon_dif.gt.180.) alon_dif = 360. - alon_dif +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + endif + if(ob_t(ii).eq.amiss.or. + $ ob_t(iip1).eq.amiss) then + dif_t = amiss + else + dif_t = abs(ob_t(iip1)-ob_t(ii)) + endif + if(ob_dir(ii).eq.amiss.or. + $ ob_dir(iip1).eq.amiss) then + dif_dir = amiss + else + dif_dir = abs(ob_dir(iip1)-ob_dir(ii)) + if(dif_dir.gt.180.) dif_dir = 360. - dif_dir + endif + if(ob_spd(ii).eq.amiss.or. + $ ob_spd(iip1).eq.amiss) then + dif_spd = amiss + else + dif_spd = abs(ob_spd(iip1)-ob_spd(ii)) + endif + else + dif_t = amiss + dif_dir = amiss + dif_spd = amiss + endif +c + job = iob + jjstart = ii + iifirst = ii + iobfirst = iob + iilast = iiend + ioblast = iend +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat_min = 9999.9 + alat_max = -9999.9 + alon_min = 9999.9 + alon_max = -9999.9 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + idt_start = imiss + idt_end = imiss +c + udist_track = amiss + vdist_track = amiss + dist_track = amiss + upspd_track = amiss + vpspd_track = amiss + pspd_track = amiss + pdir_track = amiss +c +c uairspd_track = amiss +c vairspd_track = amiss + airspd_track = amiss +c airdir_track = amiss +c + ht_dif_track = amiss + vspd_track = amiss +c +c Check for manAIREP location duplicates +c -------------------------------------- + if(iip1.ne.0.and. + $ l_ii_man_airep.and. + $ l_iip1_man_airep.and. +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + $ alat_dif.ne.amiss.and.alat_dif.lt.0.015.and. + $ alon_dif.ne.amiss.and.alon_dif.lt.0.015.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ht_ft0.gt.21000.) then +c + if((ht_difp2.ne.amiss.and. + $ abs(ht_difp2).lt.htdif_same).or. + $ (ht_dif_wo0.ne.amiss.and. + $ abs(ht_dif_wo0).lt.htdif_same).or. + $ (airspd_wop1.ne.amiss.and. + $ airspd_wop1.gt.spd_thresh).or. + $ (abs(ht_difp2).lt.3000.0.and. + $ abs(ht_dif_wop1).gt.3000.0).or. + $ (ht_dif0.ne.amiss.and. + $ abs(ht_dif_wo0).lt.3000.0.and. + $ abs(ht_dif0).gt.3000.0)) then +c + c_qc(ii)(1:1) = 'd' + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'manAIREP location duplicate ii',ii + endif +c + elseif((ht_dif0.ne.amiss.and. + $ abs(ht_dif0).lt.htdif_same).or. + $ (ht_dif_wop1.ne.amiss.and. + $ abs(ht_dif_wop1).lt.htdif_same).or. + $ (airspd_wo0.ne.amiss.and. + $ airspd_wo0.gt.spd_thresh).or. + $ (abs(ht_dif_wop1).lt.3000.0.and. + $ abs(ht_difp2).gt.3000.0).or. + $ (abs(ht_dif0).lt.3000.0.and. + $ abs(ht_dif_wo0).gt.3000.0)) then +c + c_qc(iip1)(1:1) = 'd' + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'manAIREP location duplicate iip1',iip1 + endif +c + else +c + c_qc(ii)(1:1) = 'd' + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'manAIREP location duplicate ii?',ii + endif + endif +c +c If previous reject had a stuck clock, check if current +c report has the same time +c ------------------------------------------------------ + elseif(l_stuck.and. + $ idt_last_bad.ne.imiss.and. + $ idt(ii).eq.idt_last_bad) then +c + c_qc(ii)(2:2) = 'K' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + last_bad = ii + last_bad_m1 = iim1 +c uwind_last = uwind0 +c vwind_last = vwind0 + wspd_last = ob_spd(ii) + wdir_last = ob_dir(ii) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Another stuck clock found: ii=',ii + endif +c +c If previous reject had a stuck clock, check if iip1 +c report has the same time +c --------------------------------------------------- + elseif(l_stuck.and.iip1.ne.0.and. + $ last_bad.ne.0.and. + $ idt_dif_badp1.eq.0) then +c + c_qc(iip1)(2:2) = 'K' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Another stuck clock found: iip1=',iip1 + endif +c +c If previous reject(s) saved, see if iip1 point is +c closer to previous point or to last rejected point +c ---------------------------------------------------- + elseif(airspd_badp1.ne.amiss.and. + $ airspd_badp1.lt.spd_thresh.and. + $ dist_badp1.ne.amiss.and. + $ distp1.ne.amiss.and. + $ dist_badp1.lt.distp1.and. + $ (dist_badp1.lt.50.0.or. + $ (pdir_bad0.ne.amiss.and. + $ (dist_badp1.lt.100.0.and. + $ cos((pdir_badp1-pdir_bad0)*d2r).gt.0.0).or. + $ cos((pdir_badp1-pdir_bad0)*d2r).gt.0.70710678)) + $ .and.vspd_badp1.ne.amiss.and. + $ abs(vspd_badp1).lt.vspd_thresh*2.0/3.0.and. + $ ht_dif_badp1.ne.amiss.and. + $ ht_dif_wo0.ne.amiss.and. + $ (dist_badp1.gt.250.0.or. + $ abs(ht_dif_badp1).lt.abs(ht_difp1).or. + $ abs(ht_difp1-ht_dif_badp1).lt.1000.0)) then +c + c_qc(iip1)(1:1) = 'p' + c_qc(iip1)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'iip1 point closer to last bad pt',iip1 + endif +c +c Perform bounce test for ii point +c -------------------------------- + elseif(vspd0.ne.amiss.and.vspdp1.ne.amiss.and. + $ vspd0*vspdp1.lt.0.0.and. + $ abs(vspd0).gt.vspd_bounce.and. + $ abs(vspdp1).gt.vspd_bounce) then +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + if(iim1.ne.0) then + itypem1 = itype(iim1) + else + itypem1 = imiss + endif +c + if(itypem1.ne.imiss.and. + $ ((itypem1.eq.i_mdcrs_asc.or. + $ itypem1.eq.i_mdcrs_des).and. + $ (itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl).and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des)).or. + $ ((itypem1.eq.i_acars_asc.or. + $ itypem1.eq.i_acars_des).and. + $ (itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl).and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des))) then +c + c_qc(ii)(2:2) = 'I' +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + elseif((itype(ii).eq.i_mdcrs.and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des.or. + $ itype(iip1).eq.i_mdcrs_lvl)).or. + $ (itype(ii).eq.i_acars.and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des.or. + $ itype(iip1).eq.i_acars_lvl))) then +c + c_qc(ii)(2:2) = 'I' +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + else + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + last_bad = ii + last_bad_m1 = iim1 +c uwind_last = uwind0 +c vwind_last = vwind0 + wspd_last = ob_spd(ii) + wdir_last = ob_dir(ii) + endif +c + c_qc(ii)(1:1) = 'v' + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Bounce test failed in report ii--',ii + endif +c +c Perform bounce test for iip1 point +c ---------------------------------- + elseif(vspdp1.ne.amiss.and.vspdp2.ne.amiss.and. + $ vspdp1*vspdp2.lt.0.0.and. + $ abs(vspdp1).gt.vspd_bounce.and. + $ abs(vspdp2).gt.vspd_bounce) then +c + l_ii_pspd_ok = .false. +c + if(((itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des).and. + $ (itype(iip1).eq.i_mdcrs.or. + $ itype(iip1).eq.i_mdcrs_lvl).and. + $ (itype(iip2).eq.i_mdcrs_asc.or. + $ itype(iip2).eq.i_mdcrs_des)).or. + $ ((itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des).and. + $ (itype(iip1).eq.i_acars.or. + $ itype(iip1).eq.i_acars_lvl).and. + $ (itype(iip2).eq.i_acars_asc.or. + $ itype(iip2).eq.i_acars_des))) then +c + c_qc(iip1)(2:2) = 'I' +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + elseif((itype(iip1).eq.i_mdcrs.and. + $ (itype(iip2).eq.i_mdcrs_asc.or. + $ itype(iip2).eq.i_mdcrs_des.or. + $ itype(iip2).eq.i_mdcrs_lvl)).or. + $ (itype(iip1).eq.i_acars.and. + $ (itype(iip2).eq.i_acars_asc.or. + $ itype(iip2).eq.i_acars_des.or. + $ itype(iip2).eq.i_acars_lvl))) then +c + c_qc(iip1)(2:2) = 'I' +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + else + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + c_qc(iip1)(1:1) = 'v' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Bounce test failed in rep iip1--',iip1 + endif +c +c Check for discontinuities in ascents +c ------------------------------------ + elseif(vspd0.ne.amiss.and. + $ vspdp1.ne.amiss.and. + $ vspdp2.ne.amiss.and. + $ vspd0.gt.0.0.and. + $ vspdp1.lt.0.0.and. + $ vspdp2.gt.0.0.and. + $ abs(vspdp1).gt.vspd_thresh/2.0.and. + $ abs(vspdp1).lt.vspd_thresh)then +c +c Check if iip1 report is a position report +c ----------------------------------------- + if((itype(iip1).eq.i_mdcrs.and. + $ (itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_lvl)).or. + $ (itype(iip1).eq.i_acars.and. + $ (itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_lvl))) then +c + c_qc(iip1)(2:2) = 'I' +c + l_ii_pspd_ok = .false. +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Ascent discontinuity in iip1--',iip1 + write(io8,*) 'position report' + endif +c +c Check if ii report is a position report +c --------------------------------------- + elseif((itype(ii).eq.i_mdcrs.and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des.or. + $ itype(iip1).eq.i_mdcrs_lvl)).or. + $ (itype(ii).eq.i_acars.and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des.or. + $ itype(iip1).eq.i_acars_lvl))) then +c + c_qc(ii)(2:2) = 'I' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Ascent discontinuity in ii--',ii + write(io8,*) 'position report' + endif +c + else + c_qc(iip1)(1:1) = 'V' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Ascent discontinuity in iip1--',iip1 + endif + endif +c +c Check for unrealistic airspeeds between ii and iip1 points +c Check airspeeds greater than spd_thresh +c (or spd_man_thresh if the time difference is greater than 10 min) +c ----------------------------------------------------------------- + elseif(iip1.ne.0.and. + $ ((c_acftid(ii)(1:3).eq.'AFR'.or. + $ c_acftid(ii)(1:3).eq.'BAW').and. + $ airspdp1.gt.2.0*spd_man_thresh).or. + $ ((c_acftid(ii)(1:3).ne.'AFR'.and. + $ c_acftid(ii)(1:3).ne.'BAW').and. + $ (airspdp1.gt.spd_thresh.or. + $ (idt_difp1.gt.600.and. + $ airspdp1.gt.spd_man_thresh))).and. + $ (.not.l_ii_pspd_ok)) then +c +c If neighboring points not available, reject both points +c ------------------------------------------------------- + if(airspd_wo0.eq.amiss.and. + $ airspd_wop1.eq.amiss) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + endif +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Rejecting both points' + endif +c +c Check if ii report is a position report +c (rejects not saved for second flight check) +c ------------------------------------------- + elseif(idt_difp1.le.60.and. + $ ((itype(ii).eq.i_mdcrs.and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des.or. + $ itype(iip1).eq.i_mdcrs_lvl)).or. + $ (itype(ii).eq.i_acars.and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des.or. + $ itype(iip1).eq.i_acars_lvl)))) then +c + c_qc(ii)(2:2) = 'I' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Is ii a position report?' + endif +c +c Check if iip1 report is a position report +c (rejects not saved for second flight check) +c --------------------------------------------- + elseif(idt_difp1.le.60.and. + $ ((itype(iip1).eq.i_mdcrs.and. + $ (itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_lvl)).or. + $ (itype(iip1).eq.i_acars.and. + $ (itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_lvl)))) then +c + c_qc(iip1)(2:2) = 'I' +c + l_ii_pspd_ok = .false. +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Is iip1 a position report?' + endif +c +c Check if ii report is a MDCRS report with zero latitude or longitude +c (rejects not saved for second flight check) +c -------------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif((abs(alat(ii)).lt.0.005.or. + $ abs(alon(ii)).lt.0.005).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ((itype(ii).eq.i_mdcrs.and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des.or. + $ itype(iip1).eq.i_mdcrs_lvl)).or. + $ (itype(ii).eq.i_acars.and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des.or. + $ itype(iip1).eq.i_acars_lvl)))) then +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(abs(alat(ii)).lt.0.005) c_qc(ii)(3:3) = 'B' + if(abs(alon(ii)).lt.0.005) c_qc(ii)(4:4) = 'B' +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'ii report has zero lat or lon' + endif +c +c Check if iip1 report is a MDCRS report with zero latitude or longitude +c (rejects not saved for second flight check) +c ---------------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif((abs(alat(iip1)).lt.0.005.or. + $ abs(alon(iip1)).lt.0.005).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ ((itype(iip1).eq.i_mdcrs.and. + $ (itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_lvl)).or. + $ (itype(iip1).eq.i_acars.and. + $ (itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_lvl)))) then +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(abs(alat(ii)).lt.0.005) c_qc(ii)(3:3) = 'B' + if(abs(alon(ii)).lt.0.005) c_qc(ii)(4:4) = 'B' +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + l_ii_pspd_ok = .false. +c + l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 report has zero lat or lon' + endif +c +c Check if ii report is an AMDAR report with rounded latitude +c (rejects not saved for second flight check) +c ----------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(float(int(alat(ii))).eq.alat(ii).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_lvl).and. + $ (itype(iip1).eq.i_amdar.or. + $ itype(iip1).eq.i_amdar_asc.or. + $ itype(iip1).eq.i_amdar_des.or. + $ itype(iip1).eq.i_amdar_lvl)) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + if(c_acftreg(ii)(1:2).eq.'IT') then + l_print = .true. + else + l_print = .true. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'AMDAR rep ii has rounded lat' + endif +c +c Check if iip1 report is an AMDAR report with rounded latitude +c (rejects not saved for second flight check) +c ------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(float(int(alat(iip1))).eq.alat(iip1).and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_lvl).and. + $ (itype(iip1).eq.i_amdar.or. + $ itype(iip1).eq.i_amdar_asc.or. + $ itype(iip1).eq.i_amdar_des.or. + $ itype(iip1).eq.i_amdar_lvl)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + if(c_acftreg(ii)(1:2).eq.'IT') then + l_print = .true. + else + l_print = .true. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'AMDAR rep iip1 has rounded lat' + endif +c +c Check if ii report is an AMDAR report with the wrong sign on the longitude +c (rejects not saved for second flight check) +c -------------------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(alon(ii ).lt.25.0.and. + $ alon(iip1).gt.335.0.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_lvl).and. + $ (itype(iip1).eq.i_amdar.or. + $ itype(iip1).eq.i_amdar_asc.or. + $ itype(iip1).eq.i_amdar_des.or. + $ itype(iip1).eq.i_amdar_lvl)) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c +c Search backwards for minimum longitude +c Reject points between min and prime meridian +c -------------------------------------------- + if(iim1.ne.0) then + if(alon(iim1).lt.alon(ii)) then + nob = iob - 1 + do while(nob.gt.istart) + nn = indx(nob) + nnm1 = indx(nob-1) + if(alon(nnm1).lt.alon(nn)) then +c write(io8,*) +c write(io8,*) 'nn not min--',alon(nn),alon(nnm1) + nob = nob - 1 + c_qc(nn)(1:1) = 'P' + c_qc(nn)(3:4) = 'II' + else + nob = istart + endif + enddo + endif + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'AMDAR rep ii has wrong sign on lon' + endif +c +c Go back and recheck flight after printing output +c ------------------------------------------------ + l_retest = .true. +c +c Check if iip1 report is an AMDAR report with the wrong sign on the longitude +c (rejects not saved for second flight check) +c ---------------------------------------------------------------------------- +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + elseif(alon(iip1).lt.25.0.and. + $ alon(ii ).gt.335.0.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ (itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_lvl).and. + $ (itype(iip1).eq.i_amdar.or. + $ itype(iip1).eq.i_amdar_asc.or. + $ itype(iip1).eq.i_amdar_des.or. + $ itype(iip1).eq.i_amdar_lvl)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c +c Search forwards for minimum longitude +c ------------------------------------- + if(iip2.ne.0) then + if(alon(iip2).lt.alon(iip1)) then + nob = iob + 2 + do while(nob.lt.iend) + nn = indx(nob) + nnp1 = indx(nob+1) + if(alon(nnp1).lt.alon(nn)) then + write(io8,*) + write(io8,*)'nn not min--',alon(nn),alon(nnp1) + nob = nob + 1 + c_qc(nn)(1:1) = 'P' + c_qc(nn)(3:4) = 'II' + else + write(io8,*) + write(io8,*) 'nn is min--',alon(nn),alon(nnp1) + nob = iend + endif + enddo + endif + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'AMDAR rep iip1 has wrong sign on lon' + endif +c +c Go back and recheck flight after printing output +c ------------------------------------------------ + l_retest = .true. +cc +cc Check if ii manAIREP yielded a too-high speed +cc (rejects not saved for second flight check) +cc --------------------------------------------- +c elseif(l_ii_man_airep.and.(.not.l_iip1_man_airep)) then +cc +c c_qc(ii)(1:1) = 'P' +c c_qc(ii)(3:4) = 'II' +c +c iob = iob + 1 +c l_ii_pspd_ok = .false. +cc +c l_print = .true. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'Air speed--',airspdp1, +c $ '--too high in report--',ii +c write(io8,*) 'manAIREP ii does not fit' +c endif +cc +cc Check if iip1 manAIREP yielded a too-high speed +cc (rejects not saved for second flight check) +cc ----------------------------------------------- +c elseif(l_iip1_man_airep.and.(.not.l_ii_man_airep)) then +cc +c c_qc(iip1)(1:1) = 'P' +c c_qc(iip1)(3:4) = 'II' +c +c l_ii_pspd_ok = .false. +cc +c l_print = .false. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'Air speed--',airspdp1, +c $ '--too high in report--',ii +c write(io8,*) 'manAIREP iip1 does not fit' +c endif +c +c Check valid supersonic manAIREP flights +c (rejects not saved for second flight check) +c ------------------------------------------- + elseif(l_ii_man_airep.and.l_iip1_man_airep.and. + $ (l_iim1_man_airep.or.l_iip2_man_airep).and. + $ (c_acftid(ii)(1:3).eq.'AFR'.or. + $ c_acftid(ii)(1:3).eq.'BAW')) then +c +c Print but don't reject speeds from 700 to 750 m/s +c ------------------------------------------------- + if((airspdp1.le.750.0.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ abs(airspd_wo0-airspd_wop1).lt.50.0).or. + $ (airspd0 .ne.amiss.and.airspd0 .le.750.0.and. + $ airspdp1.ne.amiss.and.airspdp1.le.750.0.and. + $ abs(airspd0-airspdp1).lt.50.0).or. + $ (airspdp1.ne.amiss.and.airspdp1.le.750.0.and. + $ airspdp2.ne.amiss.and.airspdp2.le.750.0.and. + $ abs(airspdp1-airspdp2).lt.50.0)) then + + l_ii_pspd_ok = .true. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'manAIREP airspeed below 750 m/s ok' + endif +c +c Check if ii report is bad by other airspeeds +c -------------------------------------------- + elseif((l_iim1_man_airep.and.l_iip2_man_airep.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wo0.lt.2.0*spd_man_thresh.and. + $ (airspd_wop1.gt.2.0*spd_man_thresh.or. + $ airspd_wop1-airspd_wo0.gt.60.0).and. + $ cos((pdir0-pdirp1)*d2r).lt.0.0.and. + $ cos((pdirp2-pdir_wo0)*d2r).gt.0.0).or. + $ (l_iim1_man_airep.and. + $ airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd0.gt.2.0*spd_man_thresh).or. + $ (l_iip2_man_airep.and. + $ airspdp2.ne.amiss.and. + $ airspd_wo0.eq.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.2.0*spd_man_thresh.and. + $ (airspd_wop1.gt.2.0*spd_man_thresh.or. + $ airspd_wop1.lt.2.0*spd_man_thresh/3.0))) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'manAIREP ii is bad' + endif +c +c Check if iip1 is bad by other airspeeds +c --------------------------------------- + elseif((l_iim1_man_airep.and.l_iip2_man_airep.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.2.0*spd_man_thresh.and. + $ (airspd_wo0.gt.2.0*spd_man_thresh.or. + $ airspd_wo0-airspd_wop1.gt.60.0).and. + $ cos((pdirp1-pdirp2 )*d2r).lt.0.0.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.0).or. + $ (l_iim1_man_airep.and. + $ airspd0.ne.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.eq.amiss.and. + $ airspd0.lt.2.0*spd_man_thresh.and. + $ airspd_wo0.gt.2.0*spd_man_thresh).or. + $ (l_iip2_man_airep.and. + $ airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.2.0*spd_man_thresh).or. + $ (airspd0 .ne.amiss.and. + $ airspd0 .lt.2.0*spd_man_thresh.and. + $ airspdp1.ne.amiss.and. + $ airspdp1.gt.2.0*spd_man_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.2.0*spd_man_thresh.and. + $ airspd_wo0 .ne.amiss.and. + $ airspd_wo0 .lt.2.0*spd_man_thresh.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.2.0*spd_man_thresh)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'manAIREP iip1 is bad' + endif +c +c Check if first report in flight is bad +c -------------------------------------- + elseif(airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.2.0*spd_man_thresh.and. + $ airspd_wop1.lt.2.0*spd_man_thresh.and. + $ cos((pdirp1-pdirp2)*d2r).gt.0.0) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) '1st manAIREP is bad' + endif +c +c Check if last report in flight is bad +c ------------------------------------- + elseif(airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd0.lt.2.0*spd_man_thresh.and. + $ airspd_wo0.lt.2.0*spd_man_thresh.and. + $ cos((pdir0-pdirp1)*d2r).gt.0.0) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'last manAIREP is bad' + endif +c +c Handle remaining points +c ----------------------- + else +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Supersonic air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Uncategorized manAIREP' + write(io8,*) 'Rejecting both points' + endif + endif +c +c Check flights with time differences greater than 10 min +c (rejects not saved for second flight check) +c ---------------------------------------------------------------- +c elseif(l_ii_man_airep.and.l_iip1_man_airep.and. +c $ (l_iim1_man_airep.or.l_iip2_man_airep).and. +c $ (c_acftid(ii)(1:3).ne.'AFR'.and. +c + elseif((c_acftid(ii)(1:3).ne.'AFR'.and. + $ c_acftid(ii)(1:3).ne.'BAW').and. + $ idt_difp1.gt.600) then +c +c Print but don't reject speeds from 350 to 375 m/s +c ------------------------------------------------- + if((airspdp1.le.375.0.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ abs(airspd_wo0-airspd_wop1).lt.50.0).or. + $ (airspd0 .ne.amiss.and.airspd0 .le.375.0.and. + $ airspdp1.ne.amiss.and.airspdp1.le.375.0.and. + $ abs(airspd0-airspdp1).lt.25.0).or. + $ (airspdp1.ne.amiss.and.airspdp1.le.375.0.and. + $ airspdp2.ne.amiss.and.airspdp2.le.375.0.and. + $ abs(airspdp1-airspdp2).lt.25.0)) then + + l_ii_pspd_ok = .true. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Airspeed below 375 m/s ok' + endif +c +c Check if ii report is bad by other airspeeds +c -------------------------------------------- +c elseif((l_iim1_man_airep.and.l_iip2_man_airep.and. +c $ airspd_wo0.ne.amiss.and. +c + elseif((airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wo0.lt.spd_man_thresh.and. + $ (airspd_wop1.gt.spd_man_thresh.or. + $ airspd_wop1-airspd_wo0.gt.60.0).and. + $ cos((pdir0-pdirp1)*d2r).lt.0.0.and. + $ cos((pdirp2-pdir_wo0)*d2r).gt.0.0).or. +c +c $ (l_iim1_man_airep.and. +c + $ (airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd0.gt.spd_man_thresh).or. +c +c $ (l_iip2_man_airep.and. +c + $ (airspdp2.ne.amiss.and. + $ airspd_wo0.eq.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.spd_man_thresh.and. + $ (airspd_wop1.gt.spd_man_thresh.or. + $ airspd_wop1.lt.spd_man_thresh/3.0))) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '-- > 350 m/s in report--',ii + write(io8,*) 'Report ii is bad' + endif +c +c Check if iip1 is bad by other airspeeds +c --------------------------------------- +c elseif((l_iim1_man_airep.and.l_iip2_man_airep.and. +c $ airspd_wo0.ne.amiss.and. +c + elseif((airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.spd_man_thresh.and. + $ (airspd_wo0.gt.spd_man_thresh.or. + $ airspd_wo0-airspd_wop1.gt.60.0).and. + $ cos((pdirp1-pdirp2 )*d2r).lt.0.0.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.0).or. +c +c $ (l_iim1_man_airep.and. +c + $ (airspd0.ne.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.eq.amiss.and. + $ airspd0.lt.spd_man_thresh.and. + $ airspd_wo0.gt.spd_man_thresh).or. +c +c $ (l_iip2_man_airep.and. +c + $ (airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_man_thresh).or. + $ (airspd0 .ne.amiss.and. + $ airspd0 .lt.spd_man_thresh.and. + $ airspdp1.ne.amiss.and. + $ airspdp1.gt.spd_man_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_man_thresh.and. + $ airspd_wo0 .ne.amiss.and. + $ airspd_wo0 .lt.spd_man_thresh.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.spd_man_thresh)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '-- > 350 m/s in report--',ii + write(io8,*) 'Report iip1 is bad' + endif +c +c Check if first report in flight is bad +c -------------------------------------- + elseif(airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.spd_man_thresh.and. + $ airspd_wop1.lt.spd_man_thresh.and. + $ cos((pdirp1-pdirp2)*d2r).gt.0.0) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '-- > 350 m/s in report--',ii + write(io8,*) '1st report is bad' + endif +c +c Check if last report in flight is bad +c ------------------------------------- + elseif(airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd0.lt.spd_man_thresh.and. + $ airspd_wo0.lt.spd_man_thresh.and. + $ cos((pdir0-pdirp1)*d2r).gt.0.0) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '-- > 350 m/s in report--',ii + write(io8,*) 'last report is bad' + endif +c +c Handle remaining points +c ----------------------- + else +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '-- > 350 m/s in report--',ii + write(io8,*) 'Uncategorized report' + write(io8,*) 'Rejecting both points' + endif + endif +c +c Check for previously undetected stuck clocks +c (rejects not saved for second flight check) +c -------------------------------------------- + elseif(idt_difp2.eq.0.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wo0.gt.spd_thresh.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.gt.spd_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_thresh) then +c + c_qc(iip1)(2:2) = 'K' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + endif +c + c_qc(iip2)(2:2) = 'K' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!' + $ ,iip2 + else + indx_save(ll) = iip2 + knt_bad = knt_bad + 1 + last_bad = iip2 + last_bad_m1 = iip1 +c uwind_last = uwindp2 +c vwind_last = vwindp2 + wspd_last = ob_spd(iip2) + wdir_last = ob_dir(iip2) + endif +c + l_ii_pspd_ok = .false. + l_stuck = .true. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1, iip2 reports have same time' + endif +c +c Print but don't reject speeds from 525 to 550 m/s +c ------------------------------------------------- + elseif((airspdp1.le.550.0.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ abs(airspd_wo0-airspd_wop1).lt.50.0).or. + $ (airspd0 .ne.amiss.and.airspd0 .le.550.0.and. + $ airspdp1.ne.amiss.and.airspdp1.le.550.0.and. + $ abs(airspd0-airspdp1).lt.25.0).or. + $ (airspdp1.ne.amiss.and.airspdp1.le.550.0.and. + $ airspdp2.ne.amiss.and.airspdp2.le.550.0.and. + $ abs(airspdp1-airspdp2).lt.25.0)) then +c + l_ii_pspd_ok = .true. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Airspeed below 550 m/s ok' + endif +c +c Check if ii is problem point by other airspeeds +c ----------------------------------------------- + elseif((airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wo0.lt.spd_thresh.and. + $ (airspd_wop1.gt.spd_thresh.or. + $ airspd_wop1-airspd_wo0.gt.90.0).and. + $ cos((pdir0-pdirp1)*d2r).lt.0.0.and. + $ cos((pdirp2-pdir_wo0)*d2r).gt.0.0).or. + $ (airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd0.gt.spd_thresh).or. + $ (airspdp2.ne.amiss.and. + $ airspd_wo0.eq.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.spd_thresh.and. + $ (airspd_wop1.gt.spd_thresh.or. + $ airspd_wop1.lt.spd_thresh/3.0))) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + last_bad = ii + last_bad_m1 = iim1 +c uwind_last = uwind0 +c vwind_last = vwind0 + wspd_last = ob_spd(ii) + wdir_last = ob_dir(ii) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'ii is problem point' + endif +c +c Check if iip1 is problem point by other airspeeds +c ------------------------------------------------- + elseif((airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.spd_thresh.and. + $ (airspd_wo0.gt.spd_thresh.or. + $ airspd_wo0-airspd_wop1.gt.90.0).and. + $ cos((pdirp1-pdirp2 )*d2r).lt.0.0.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.0).or. + $ (airspd0.ne.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd_wop1.eq.amiss.and. + $ airspd0.lt.spd_thresh.and. + $ airspd_wo0.gt.spd_thresh).or. + $ (airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_thresh).or. + $ (airspd0 .ne.amiss.and. + $ airspd0 .lt.spd_thresh.and. + $ airspdp1.ne.amiss.and. + $ airspdp1.gt.spd_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_thresh.and. + $ airspd_wo0 .ne.amiss.and. + $ airspd_wo0 .lt.spd_thresh.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.lt.spd_thresh)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 is problem point' + endif +c +c Check if first report in flight is bad +c -------------------------------------- + elseif(airspd0.eq.amiss.and. + $ airspdp2.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspdp2.lt.spd_thresh.and. + $ airspd_wop1.lt.spd_thresh.and. + $ cos((pdirp1-pdirp2)*d2r).gt.0.0) then +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) '1st report is bad' + endif +c +c Check if last report in flight is bad +c ------------------------------------- + elseif(airspd0.ne.amiss.and. + $ airspdp2.eq.amiss.and. + $ airspd_wo0.ne.amiss.and. + $ airspd0.lt.spd_thresh.and. + $ airspd_wo0.lt.spd_thresh.and. + $ cos((pdir0-pdirp1)*d2r).gt.0.0) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'last report is bad' + endif +c +c Check if iip1 and iip2 points are from a different flight +c --------------------------------------------------------- + elseif((vspd0 .ne.amiss.and. + $ abs(vspd0 ).lt.vspd_thresh*2.0/3.0.and. + $ vspdp1.ne.amiss.and. + $ abs(vspdp1).gt.vspd_thresh*2.0/3.0.and. + $ vspdp2.ne.amiss.and. + $ abs(vspdp2).lt.vspd_thresh*2.0/3.0).or. + $ (airspd0 .ne.amiss.and. + $ airspd0 .lt.spd_thresh.and. + $ airspdp1.ne.amiss.and. + $ airspdp1.gt.spd_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.lt.spd_thresh).or. + $ (airspd0 .ne.amiss.and. + $ airspd0 .lt.spd_thresh.and. + $ airspdp1.ne.amiss.and. + $ airspdp1.gt.spd_thresh.and. + $ airspdp2.ne.amiss.and. + $ airspdp2.gt.spd_thresh.and. + $ airspd_wo0 .ne.amiss.and. + $ airspd_wo0 .gt.spd_thresh.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wop1.gt.spd_thresh)) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!' + $ ,iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + endif +c + c_qc(iip2)(1:1) = 'P' + c_qc(iip2)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!' + $ ,iip2 + else + indx_save(ll) = iip2 + knt_bad = knt_bad + 1 + last_bad = iip2 + last_bad_m1 = iip1 +c uwind_last = uwindp2 +c vwind_last = vwindp2 + wspd_last = ob_spd(iip2) + wdir_last = ob_dir(iip2) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 and iip2 reports from new flight' + endif +c +c Check if iip1 is problem point by other airspeeds--clock problem +c ---------------------------------------------------------------- + elseif(airspd_wo0.ne.amiss.and. + $ airspd_wop1.ne.amiss.and. + $ airspd_wo0.lt.spd_thresh.and. + $ (airspd_wop1.gt.spd_thresh.or. + $ airspd_wop1-airspd_wo0.gt.90.0).and. + $ airspdp2.gt.spd_thresh.and. + $ cos((pdir0-pdirp1)*d2r).gt.0.5.and. + $ cos((pdirp2-pdir_wo0)*d2r).gt.0.5) then +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 has clock problem' + endif +c +c Handle remaining points +c ----------------------- + else +c + c_qc(ii)(1:1) = 'P' + c_qc(ii)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + endif +c + c_qc(iip1)(1:1) = 'P' + c_qc(iip1)(3:4) = 'II' + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Air speed--',airspdp1, + $ '--too high in report--',ii + write(io8,*) 'Uncategorized report' + write(io8,*) 'Rejecting both points' + endif + endif +c +c Check for unrealistic vertical speeds between ii and iip1 points +c ---------------------------------------------------------------- + elseif(iip1.ne.0.and. + $ vspdp1.ne.amiss.and. + $ (abs(vspdp1).gt.vspd_thresh.or. + $ (idt_difp1.gt.600.and. + $ abs(vspdp1).gt.vspd_thresh*2.0/3.0))) then +c +c If neighboring points not available, reject both points +c ------------------------------------------------------- + if(vspd_wo0.eq.amiss.and.vspd_wop1.eq.amiss) then +c + c_qc(ii)(1:1) = 'V' + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + endif +c + c_qc(iip1)(1:1) = 'V' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'Rejecting both points' + endif +c +c Check if ii report is a position report +c (rejects not saved for second flight check) +c ------------------------------------------- + elseif(idt_difp1.le.60.and. + $ ((itype(ii).eq.i_mdcrs.and. + $ (itype(iip1).eq.i_mdcrs_asc.or. + $ itype(iip1).eq.i_mdcrs_des.or. + $ itype(iip1).eq.i_mdcrs_lvl)).or. + $ (itype(ii).eq.i_acars.and. + $ (itype(iip1).eq.i_acars_asc.or. + $ itype(iip1).eq.i_acars_des.or. + $ itype(iip1).eq.i_acars_lvl)))) then +c + c_qc(ii)(2:2) = 'I' +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'Is ii a position report?' + endif +c +c Check if iip1 report is a position report +c (rejects not saved for second flight check) +c --------------------------------------------- + elseif(idt_difp1.le.60.and. + $ ((itype(iip1).eq.i_mdcrs.and. + $ (itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des.or. + $ itype(ii).eq.i_mdcrs_lvl)).or. + $ (itype(iip1).eq.i_acars.and. + $ (itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des.or. + $ itype(ii).eq.i_acars_lvl)))) then +c + c_qc(iip1)(2:2) = 'I' +c + l_ii_pspd_ok = .false. +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'Is iip1 a position report?' + endif +cc +cc Check if ii manAIREP yielded a too-high speed +cc --------------------------------------------- +c elseif(l_ii_man_airep.and.(.not.l_iip1_man_airep)) then +cc +c c_qc(ii)(1:1) = 'V' +c if(c_qc(ii)(5:5).eq.'R') then +c c_qc(ii)(5:5) = 'i' +c else +c c_qc(ii)(5:5) = 'I' +c endif +c iob = iob + 1 +c l_ii_pspd_ok = .false. +cc +c l_print = .true. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'Vertical speed--',vspdp1, +c $ '--too high in report--',ii +c write(io8,*) 'manAIREP ii does not fit' +c endif +cc +cc Check if iip1 manAIREP yielded a too-high speed +cc ----------------------------------------------- +c elseif(l_iip1_man_airep.and.(.not.l_ii_man_airep)) then +cc +c c_qc(iip1)(1:1) = 'V' +c if(c_qc(iip1)(5:5).eq.'R') then +c c_qc(iip1)(5:5) = 'i' +c else +c c_qc(iip1)(5:5) = 'I' +c endif +c l_ii_pspd_ok = .false. +cc +c l_print = .true. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'Vertical speed--',vspdp1, +c $ '--too high in report--',ii +c write(io8,*) 'manAIREP iip1 does not fit' +c endif +c +c Check if iip1 and iip2 points are from a different flight +c --------------------------------------------------------- + elseif(vspd0.ne.amiss.and.vspdp2.ne.amiss.and. + $ abs(vspd0).lt.vspd_thresh*2.0/3.0.and. + $ abs(vspdp2).lt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wo0).gt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wop1).gt.vspd_thresh*2.0/3.0) then +c $ abs(vspd_wo0)-abs(vspd0).gt.50.0.and. +c $ abs(vspd_wop1)-abs(vspdp2).gt.50.0) then +c + c_qc(iip1)(1:1) = 'V' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + endif +c + c_qc(iip2)(1:1) = 'V' + if(c_qc(iip2)(5:5).eq.'R') then + c_qc(iip2)(5:5) = 'i' + else + c_qc(iip2)(5:5) = 'I' + endif + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip2 + else + indx_save(ll) = iip2 + knt_bad = knt_bad + 1 + last_bad = iip2 + last_bad_m1 = iip1 +c uwind_last = uwindp2 +c vwind_last = vwindp2 + wspd_last = ob_spd(iip2) + wdir_last = ob_dir(iip2) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 and iip2 reports from new flight' + endif +c +c Check if ii is problem point by other vertical speeds +c ----------------------------------------------------- + elseif((vspd0.ne.amiss.and.vspdp2.ne.amiss.and. + $ vspd_wo0.ne.amiss.and.vspd_wop1.ne.amiss.and. + $ abs(vspdp2).lt.vspd_thresh*2.0/3.0.and. + $ (abs(vspd0).gt.vspd_thresh*2.0/3.0.or. + $ abs(vspd_wop1)-abs(vspd_wo0).gt.50.0)).or. + $ (vspd0.ne.amiss.and.vspd_wo0.ne.amiss.and. + $ abs(vspd0).gt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wo0).lt.vspd_thresh*2.0/3.0).or. + $ (vspdp2.ne.amiss.and.vspd_wop1.ne.amiss.and. + $ abs(vspdp2).lt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wop1).gt.vspd_thresh*2.0/3.0)) then +c $ abs(vspdp2).lt.vspd_thresh*2.0/3.0.and. +c $ (abs(vspd0).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspd_wop1)-abs(vspd_wo0)).gt.50.0)).or. +c $ (vspd0.ne.amiss.and.vspd_wo0.ne.amiss.and. +c $ (abs(vspd0).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspd0)-abs(vspd_wo0)).gt.50.0)).or. +c $ (vspdp2.ne.amiss.and.vspd_wop1.ne.amiss.and. +c $ abs(vspdp2).lt.vspd_thresh*2.0/3.0.and. +c $ (abs(vspd_wop1).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspd_wop1)-abs(vspdp2)).gt.50.0))) then +c + c_qc(ii)(1:1) = 'V' + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + last_bad = ii + last_bad_m1 = iim1 +c uwind_last = uwind0 +c vwind_last = vwind0 + wspd_last = ob_spd(ii) + wdir_last = ob_dir(ii) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'ii is problem point' + endif +c +c Check if iip1 is problem point by other vertical speeds +c ------------------------------------------------------- + elseif((vspd0.ne.amiss.and.vspdp2.ne.amiss.and. + $ vspd_wo0.ne.amiss.and.vspd_wop1.ne.amiss.and. + $ abs(vspd0).lt.vspd_thresh*2.0/3.0.and. + $ (abs(vspdp2).gt.vspd_thresh*2.0/3.0.or. + $ abs(vspd_wo0)-abs(vspd_wop1).gt.50.0)).or. + $ (vspdp2.ne.amiss.and.vspd_wop1.ne.amiss.and. + $ (abs(vspdp2).gt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wop1).lt.vspd_thresh*2.0/3.0)).or. + $ (vspd0.ne.amiss.and.vspd_wo0.ne.amiss.and. + $ abs(vspd0).lt.vspd_thresh*2.0/3.0.and. + $ abs(vspd_wo0).gt.vspd_thresh*2.0/3.0)) then +c $ abs(vspd0).lt.vspd_thresh*2.0/3.0.and. +c $ (abs(vspdp2).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspd_wo0)-abs(vspd_wop1)).gt.50.0)).or. +c $ (vspdp2.ne.amiss.and.vspd_wop1.ne.amiss.and. +c $ (abs(vspdp2).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspdp2)-abs(vspd_wop1)).gt.50.0)).or. +c $ (vspd0.ne.amiss.and.vspd_wo0.ne.amiss.and. +c $ abs(vspd0).lt.vspd_thresh*2.0/3.0.and. +c $ (abs(vspd_wo0).gt.vspd_thresh*2.0/3.0.or. +c $ abs(abs(vspd_wo0)-abs(vspd0)).gt.50.0))) then +c + c_qc(iip1)(1:1) = 'V' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'iip1 is problem point' + endif +c +c Handle remaining points +c ----------------------- + else +c + c_qc(ii)(1:1) = 'V' + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ ii + else + indx_save(ll) = ii + knt_bad = knt_bad + 1 + endif +c + c_qc(iip1)(1:1) = 'V' + if(c_qc(iip1)(5:5).eq.'R') then + c_qc(iip1)(5:5) = 'i' + else + c_qc(iip1)(5:5) = 'I' + endif +c + ll = ll + 1 + if(ll.gt.200) then + write(io8,*) 'll limit exceeded--indx not saved!', + $ iip1 + else + indx_save(ll) = iip1 + knt_bad = knt_bad + 1 + last_bad = iip1 + last_bad_m1 = ii +c uwind_last = uwindp1 +c vwind_last = vwindp1 + wspd_last = ob_spd(iip1) + wdir_last = ob_dir(iip1) + endif +c + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Vertical speed--',vspdp1, + $ '--too high in report--',ii + write(io8,*) 'Uncategorized report' + write(io8,*) 'Rejecting both points' + endif + endif +c +c Check if neighboring points are not available +c If so, skip remaining tests +c --------------------------------------------------- + elseif(iim1.eq.0.and.iip2.eq.0) then +c + c_qc(ii)(11:11) = 'I' + if(iip1.ne.0) c_qc(iip1)(11:11) = 'I' + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Neighboring points not available',ii + endif +c + elseif(iim2.eq.0.and.iip1.eq.0) then +c + if(iim1.ne.0) c_qc(iim1)(11:11) = 'I' + c_qc(ii)(11:11) = 'I' + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Neighboring points not available',ii + endif +c +c Check for anomalous points at the beginnings of ascents +c ------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ (iim1.ne.0.and.idt_dif0.gt.idt_near)).and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_ft0.lt.10000.0.and. + $ abs(ht_difp1).gt.htdif_same/2.0.and. + $ ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2) then +c + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Anomalous point before ascent' + endif +c +c Check for anomalous points at the ends of descents +c -------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ (iip1.eq.0.or. + $ (iip1.ne.0.and.idt_difp1.gt.idt_near)).and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ ht_ft0.lt.10000.0.and. + $ abs(ht_dif0).gt.htdif_same/2.0.and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ) then +c + if(c_qc(ii)(5:5).eq.'R') then + c_qc(ii)(5:5) = 'i' + else + c_qc(ii)(5:5) = 'I' + endif + iob = iob + 1 + l_ii_pspd_ok = .false. +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Anomalous point after descent' + endif +c +c Check for isolated off-track points at beginning of track +c Use ii, iip1, iip2 points +c --------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near*2).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*4)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ pdirp1.ne.amiss.and. + $ pdirp2.ne.amiss.and. + $ pdirp3.ne.amiss.and. + $ pdir_wop2.ne.amiss.and. + $ distp2.gt.50.0.and. + $ distp3.gt.50.0.and. + $ distp2.gt.dist_wop2.and. + $ distp3.gt.dist_wop2.and. + $ cos((pdirp1-pdirp2)*d2r).lt.0.5.and. + $ ((cos((pdirp2-pdirp3 )*d2r).lt.-0.5.and. + $ cos((pdirp1-pdir_wop2)*d2r).gt.0.5).or. +c $ (cos((pdirp2-pdirp3 )*d2r).lt.0.25881904.and. + $ cos((pdirp1-pdir_wop2)*d2r).gt.0.70710678)) then +c + c_qc(iip2)(1:1) = 'O' + c_qc(iip2)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated off-track pt--iip2 = ',iip2 + endif +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near*2).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*4)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ pdir0 .ne.amiss.and. + $ pdirp1.ne.amiss.and. + $ pdirp2.ne.amiss.and. + $ pdir_wop1.ne.amiss.and. + $ distp1.gt.50.0.and. + $ distp2.gt.50.0.and. + $ distp1.gt.dist_wop1.and. + $ distp2.gt.dist_wop1.and. + $ ((cos((pdirp1-pdirp2 )*d2r).lt.-0.5.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.5).or. +c $ (cos((pdirp1-pdirp2 )*d2r).lt.0.25881904.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.70710678)) then +c + c_qc(iip1)(1:1) = 'O' + c_qc(iip1)(3:4) = 'II' +c + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated off-track pt--iip1 = ',iip1 + endif +c +c Check for isolated off-track points in middle of track +c Use iim1, ii, iip1 points +c ------------------------------------------------------ + elseif(iim1.ne.0.and.iip1.ne.0.and.iip2.ne.0.and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ pdir0 .ne.amiss.and. + $ pdirp1.ne.amiss.and. + $ pdirm1.ne.amiss.and. + $ pdir_wo0.ne.amiss.and. + $ dist0.gt.50.0.and. + $ distp1.gt.50.0.and. + $ dist0.gt.dist_wo0.and. + $ distp1.gt.dist_wo0.and. + $ ((cos((pdir0 -pdirp1 )*d2r).lt.-0.5.and. + $ cos((pdirm1-pdir_wo0)*d2r).gt.0.5).or. +c $ (cos((pdir0 -pdirp1 )*d2r).lt.0.25881904.and. + $ cos((pdirm1-pdir_wo0)*d2r).gt.0.70710678)) then +c + c_qc(ii)(1:1) = 'O' + c_qc(ii)(3:4) = 'II' +c + iob = iob - 1 + l_ii_pspd_ok = .false. +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated off-track pt--ii = ',ii + endif +c +c Increment counters if no errors are found +c ----------------------------------------- + else + iob = iob + 1 + l_ii_pspd_ok = .false. + endif +c +c Write reports used in testing if desired +c ---------------------------------------- + if(l_print) then + write(io8,'(a18,2i6,a18,2i6)') + $ ' iistart,iiend = ',iistart,iiend, + $ ' iifirst,iilast = ',iifirst,iilast + write(io8,'('' '',12a10)') + $ 'iim2','iim1','ii','wo0', + $ 'iip1','wop1','iip2','wop2','iip3', + $ 'bad0','badp1','track' + write(io8,'(''indices'',3i10,3(10x,i10))') + $ iim2,iim1,ii, + $ iip1,iip2,iip3 + write(io8,'(''dist = '',12f10.2)') + $ distm2,distm1,dist0,dist_wo0, + $ distp1,dist_wop1,distp2,dist_wop2,distp3, + $ dist_bad0,dist_badp1,dist_track +c write(io8,'(''udis = '',12f10.2)') +c $ udistm2/1000.,udistm1/1000.,udist0/1000., +c $ udist_wo0/1000.,udistp1/1000.,udist_wop1/1000., +c $ udistp2/1000.,udist_wop2/1000.,udistp3/1000., +c $ udist_bad0/1000.,udist_badp1/1000.,udist_track/1000. +c write(io8,'(''vdis = '',12f10.2)') +c $ vdistm2/1000.,vdistm1/1000.,vdist0/1000., +c $ vdist_wo0/1000.,vdistp1/1000.,vdist_wop1/1000., +c $ vdistp2/1000.,vdist_wop2/1000.,vdistp3/1000., +c $ vdist_bad0/1000.,vdist_badp1/1000.,vdist_track/1000. + write(io8,'(''ht_d = '',12f10.2)') + $ ht_difm2,ht_difm1,ht_dif0,ht_dif_wo0, + $ ht_difp1,ht_dif_wop1,ht_difp2,ht_dif_wop2,ht_difp3, + $ ht_dif_bad0,ht_dif_badp1,ht_dif_track +c write(io8,'(''uwnd = '',3f10.2,3(10x,f10.2),)') +c $ uwindm2,uwindm1,uwind0, +c $ uwindp1,uwindp2,uwindp3 +c write(io8,'(''vwnd = '',3f10.2,3(10x,f10.2),)') +c $ vwindm2,vwindm1,vwind0, +c $ vwindp1,vwindp2,vwindp3 +c write(io8,'(''upsp = '',12f10.2)') +c $ upspdm2,upspdm1,upspd0,upspd_wo0, +c $ upspdp1,upspd_wop1,upspdp2,upspd_wop2,upspdp3, +c $ upspd_bad0,upspd_badp1,upspd_track +c write(io8,'(''vpsp = '',12f10.2)') +c $ vpspdm2,vpspdm1,vpspd0,vpspd_wo0, +c $ vpspdp1,vpspd_wop1,vpspdp2,vpspd_wop2,vpspdp3, +c $ vpspd_bad0,vpspd_badp1,vpspd_track + write(io8,'(''pspd = '',12f10.2)') + $ pspdm2,pspdm1,pspd0,pspd_wo0, + $ pspdp1,pspd_wop1,pspdp2,pspd_wop2,pspdp3, + $ pspd_bad0,pspd_badp1,pspd_track + write(io8,'(''pdir = '',12f10.2)') + $ pdirm2,pdirm1,pdir0,pdir_wo0, + $ pdirp1,pdir_wop1,pdirp2,pdir_wop2,pdirp3, + $ pdir_bad0,pdir_badp1,pdir_track +c write(io8,'(''uair = '',12f10.2)') +c $ uairspdm2,uairspdm1,uairspd0,uairspd_wo0, +c $ uairspdp1,uairspd_wop1,uairspdp2,uairspd_wop2, +c $ uairspdp3,uairspd_bad0,uairspd_badp1,uairspd_track +c write(io8,'(''vair = '',12f10.2)') +c $ vairspdm2,vairspdm1,vairspd0,vairspd_wo0, +c $ vairspdp1,vairspd_wop1,vairspdp2,vairspd_wop2, +c $ vairspdp3,vairspd_bad0,vairspd_badp1,vairspd_track + write(io8,'(''aspd = '',12f10.2)') + $ airspdm2,airspdm1,airspd0,airspd_wo0, + $ airspdp1,airspd_wop1,airspdp2,airspd_wop2,airspdp3, + $ airspd_bad0,airspd_badp1,airspd_track +c write(io8,'(''adir = '',12f10.2)') +c $ airdirm2,airdirm1,airdir0,airdir_wo0, +c $ airdirp1,airdir_wop1,airdirp2,airdir_wop2,airdirp3, +c $ airdir_bad0,airdir_badp1,airdir_track + write(io8,'(''vspd = '',12f10.2)') + $ vspdm2,vspdm1,vspd0,vspd_wo0, + $ vspdp1,vspd_wop1,vspdp2,vspd_wop2,vspdp3, + $ vspd_bad0,vspd_badp1,vspd_track +c + if(iim2.ne.0) then + write(io8,8002) kk,iim2 + x, c_insty_ob(itype(iim2)) + x, c_acftreg(iim2),c_acftid(iim2) + x, idt(iim2),alat(iim2),alon(iim2) + x, pres(iim2),ht_ft(iim2) + x, t_prcn(iim2),ob_t(iim2),xiv_t(iim2),ichk_t(iim2) + x, ob_q(iim2),xiv_q(iim2),ichk_q(iim2) + x, ob_dir(iim2),xiv_d(iim2),ichk_d(iim2) + x, ob_spd(iim2),xiv_s(iim2),ichk_s(iim2) + x, c_qc(iim2) + endif +c + if(iim1.ne.0) then + write(io8,8002) kk,iim1 + x, c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + endif +c + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) +c + if(iip1.ne.0) then + write(io8,8002) kk,iip1 + x, c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1) + x, pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1) + endif +c + if(iip2.ne.0) then + write(io8,8002) kk,iip2 + x, c_insty_ob(itype(iip2)) + x, c_acftreg(iip2),c_acftid(iip2) + x, idt(iip2),alat(iip2),alon(iip2) + x, pres(iip2),ht_ft(iip2) + x, t_prcn(iip2),ob_t(iip2),xiv_t(iip2),ichk_t(iip2) + x, ob_q(iip2),xiv_q(iip2),ichk_q(iip2) + x, ob_dir(iip2),xiv_d(iip2),ichk_d(iip2) + x, ob_spd(iip2),xiv_s(iip2),ichk_s(iip2) + x, c_qc(iip2) + endif +c + 8002 format(i4,1x,i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Retest flight if specified +c -------------------------- + if(l_retest) goto 5500 +c + endif + enddo +c +c If second flight found, save indices +c Don't save indices for stuck clock segments +c Don't redo check +c ------------------------------------------- + ii = indx(istart) +c + if(knt_bad.gt.3.and. + $ .not.l_stuck.and. + $ c_acftid(ii)(9:9).ne.'z') then +c + write(io8,*) + write(io8,*) 'Second flight found--',knt_bad,'--reports' +c +c Consolidate first flight +c ------------------------ + ll = 0 + keep = istart-1 +c + do iob=istart,iend + ii = indx(iob) +c +c If report rejected... +c --------------------- + if(c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i') then +c +c write(io8,*) 'Skipping report from 2nd flt',ii + ll = ll + 1 + indx_save(ll) = ii +c +c If report not rejected... +c ------------------------- + else +c write(io8,*) 'Keeping report from 2nd flt',ii + keep = keep + 1 + indx(keep) = indx(iob) +c + endif + enddo +c +c Save second flight +c ------------------ + istart = keep + 1 + knt_bad = ll + do ll=1,knt_bad +c + if(keep.gt.iend) then + write(io8,*) + write(io8,*) 'Keep exceeds iend!' +c + else +c write(io8,*) 'Saving report from 2nd flt', +c $ indx_save(ll) + keep = keep + 1 + indx(keep) = indx_save(ll) + ii = indx(keep) + c_acftid(ii)(9:9) = 'z' + endif + enddo +c +c Compute length of second flight +c ------------------------------- + ii = indx_save(1) + iip1 = indx_save(knt_bad) + dist_2ndflt = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip1),alon(iip1)) +c + write(io8,*) 'Second flight is ',dist_2ndflt,' m long' !!! units fixed +c +c Save second flight only if it is long enough +c -------------------------------------------- + if(dist_2ndflt.gt.100 000.0.and. +! vvvvvDAK-future change perhaps to account for incr. lat/lon precision + $ alat(ii).ne.0.0.and. + $ alat(iip1).ne.0.0) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c + write(io8,*) 'Re-testing second flight' + write(io8,*) +c + do ll=1,knt_bad + ii = indx_save(ll) +c +c Reset QC flags +c -------------- + if(c_qc(ii)(3:4).eq.'II') then + c_qc(ii)(1:1) = '2' + c_qc(ii)(3:4) = '..' +c + elseif(c_qc(ii)(5:5).eq.'I') then + c_qc(ii)(1:1) = '2' + c_qc(ii)(5:5) = '.' +c + elseif(c_qc(ii)(5:5).eq.'i') then + c_qc(ii)(1:1) = '2' + c_qc(ii)(5:5) = 'R' + endif +c + enddo +c +c Reset flight parameters for old flight +c -------------------------------------- + ntot_flt(kk) = ntot_flt(kk) - knt_bad +c +c Go back and re-check flight +c --------------------------- + goto 5500 +c +c Reset 9th character if second flight not saved +c ---------------------------------------------- + else + do ll=1,knt_bad + ii = indx_save(ll) + c_acftid(ii)(9:9) = ' ' + enddo +c + endif + endif +c +c Perform second scan to check for odd manuevers +c ---------------------------------------------- + iob = istart +c + knt_iob = 1 + iob_sav = 0 +c + knt_iip1_bad = 0 +c +c Loop over reports for current flight +c ------------------------------------ + do while(iob.le.iend) + l_print = .false. +c + knt0 = iob + ii = indx(iob) +c + if(iob.eq.iob_sav) then + knt_iob = knt_iob + 1 + else + iob_sav = iob + knt_iob = 1 + endif +c + if(knt_iob.gt.75) then + write(io8,*) + write(io8,*) 'Too many reps with the same iob',iob + write(io8,*) ' Sorted index ii = ',ii + write(io8,*) ' Number of reps = ',knt_iob + iob = iob + 1 + knt_iip1_bad = 0 + iob_sav = iob + knt_iob = 1 +c +c elseif(knt_iob.gt.10) then +c write(io8,*) +c write(io8,*) 'More than 10 reps with same iob',iob +c write(io8,*) 'knt_iob = ',knt_iob +c write(io8,'(a18,2i6,a18,2i6)') +c $ ' iistart,iiend = ',iistart,iiend, +c $ ' iifirst,iilast = ',iifirst,iilast +c write(io8,'(7x,12a10)') +c $ 'iim2','iim1','ii','wo0', +c $ 'iip1','wop1','iip2','wop2','iip3', +c $ 'bad0','badp1','track' +c write(io8,'(''indices'',3i10,3(10x,i10))') +c $ iim2,iim1,ii, +c $ iip1,iip2,iip3 +c write(io8,'(''dist = '',12f10.2)') +c $ distm2,distm1,dist0,dist_wo0, +c $ distp1,dist_wop1,distp2,dist_wop2,distp3, +c $ dist_bad0,dist_badp1,dist_track +c write(io8,'(''ht_d = '',12f10.2)') +c $ ht_difm2,ht_difm1,ht_dif0,ht_dif_wo0, +c $ ht_difp1,ht_dif_wop1,ht_difp2,ht_dif_wop2,ht_difp3, +c $ ht_dif_bad0,ht_dif_badp1,ht_dif_track +c write(io8,'(''pspd = '',12f10.2)') +c $ pspdm2,pspdm1,pspd0,pspd_wo0, +c $ pspdp1,pspd_wop1,pspdp2,pspd_wop2,pspdp3, +c $ pspd_bad0,pspd_badp1,pspd_track +c write(io8,'(''pdir = '',12f10.2)') +c $ pdirm2,pdirm1,pdir0,pdir_wo0, +c $ pdirp1,pdir_wop1,pdirp2,pdir_wop2,pdirp3, +c $ pdir_bad0,pdir_badp1,pdir_track +c +c if(iim2.ne.0) then +c write(io8,8002) kk,iim2 +c x, c_insty_ob(itype(iim2)) +c x, c_acftreg(iim2),c_acftid(iim2) +c x, idt(iim2),alat(iim2),alon(iim2) +c x, pres(iim2),ht_ft(iim2) +c x, t_prcn(iim2),ob_t(iim2),xiv_t(iim2),ichk_t(iim2) +c x, ob_q(iim2),xiv_q(iim2),ichk_q(iim2) +c x, ob_dir(iim2),xiv_d(iim2),ichk_d(iim2) +c x, ob_spd(iim2),xiv_s(iim2),ichk_s(iim2) +c x, c_qc(iim2) +c endif +c +c if(iim1.ne.0) then +c write(io8,8002) kk,iim1 +c x, c_insty_ob(itype(iim1)) +c x, c_acftreg(iim1),c_acftid(iim1) +c x, idt(iim1),alat(iim1),alon(iim1) +c x, pres(iim1),ht_ft(iim1) +c x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) +c x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) +c x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) +c x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) +c x, c_qc(iim1) +c endif +cc +c write(io8,8002) kk,ii,c_insty_ob(itype(ii)) +c x, c_acftreg(ii),c_acftid(ii) +c x, idt(ii),alat(ii),alon(ii) +c x, pres(ii),ht_ft(ii) +c x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) +c x, ob_q(ii),xiv_q(ii),ichk_q(ii) +c x, ob_dir(ii),xiv_d(ii),ichk_d(ii) +c x, ob_spd(ii),xiv_s(ii),ichk_s(ii) +c x, c_qc(ii) +cc +c if(iip1.ne.0) then +c write(io8,8002) kk,iip1 +c x, c_insty_ob(itype(iip1)) +c x, c_acftreg(iip1),c_acftid(iip1) +c x, idt(iip1),alat(iip1),alon(iip1) +c x, pres(iip1),ht_ft(iip1) +c x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) +c x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) +c x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) +c x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) +c x, c_qc(iip1) +c endif +cc +c if(iip2.ne.0) then +c write(io8,8002) kk,iip2 +c x, c_insty_ob(itype(iip2)) +c x, c_acftreg(iip2),c_acftid(iip2) +c x, idt(iip2),alat(iip2),alon(iip2) +c x, pres(iip2),ht_ft(iip2) +c x, t_prcn(iip2),ob_t(iip2),xiv_t(iip2),ichk_t(iip2) +c x, ob_q(iip2),xiv_q(iip2),ichk_q(iip2) +c x, ob_dir(iip2),xiv_d(iip2),ichk_d(iip2) +c x, ob_spd(iip2),xiv_s(iip2),ichk_s(iip2) +c x, c_qc(iip2) +c endif +c + endif +c +c Go to next report if ii index is invalid +c ---------------------------------------- + if(c_qc(ii)(1:1).eq.'d'.or. + $ c_qc(ii)(2:2).eq.'I'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) 'Index invalid: ii = ',ii + endif +c +c Check out ordering etc for valid indices +c ---------------------------------------- + else +c +c Compute ii-1 index +c if(iob.gt.istart) iim1 = indx(iob-1) +c -------------------------------------- + iim1 = 0 + knt1 = iob - 1 +111 if(knt1.ge.istart) then + iim1 = indx(knt1) + if(c_qc(iim1)(1:1).eq.'d'.or. + $ c_qc(iim1)(2:2).eq.'I'.or. + $ c_qc(iim1)(2:2).eq.'K'.or. + $ c_qc(iim1)(3:4).eq.'II'.or. + $ c_qc(iim1)(5:5).eq.'I'.or. + $ c_qc(iim1)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt1 = knt1 - 1 + goto 111 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c if(iob.gt.istart+1) iim2 = indx(iob-2) +c -------------------------------------- + iim2 = 0 + knt2 = knt1 - 1 +121 if(knt2.ge.istart) then + iim2 = indx(knt2) + if(c_qc(iim2)(1:1).eq.'d'.or. + $ c_qc(iim2)(2:2).eq.'I'.or. + $ c_qc(iim2)(2:2).eq.'K'.or. + $ c_qc(iim2)(3:4).eq.'II'.or. + $ c_qc(iim2)(5:5).eq.'I'.or. + $ c_qc(iim2)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt2 = knt2 - 1 + goto 121 + endif + else + iim2 = 0 + endif +c +c Compute ii-3 index +c if(iob.gt.istart+2) iim3 = indx(iob-3) +c -------------------------------------- + iim3 = 0 + knt5 = knt2 - 1 +131 if(knt5.ge.istart) then + iim3 = indx(knt5) + if(c_qc(iim3)(1:1).eq.'d'.or. + $ c_qc(iim3)(2:2).eq.'I'.or. + $ c_qc(iim3)(2:2).eq.'K'.or. + $ c_qc(iim3)(3:4).eq.'II'.or. + $ c_qc(iim3)(5:5).eq.'I'.or. + $ c_qc(iim3)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt5 = knt5 - 1 + goto 131 + endif + else + iim3 = 0 + endif +c +c Compute ii+1 index +c if(iob.lt.iend) iip1 = indx(iob+1) +c ------------------------------------ + iip1 = 0 + iobp1 = 0 + knt3 = iob + 1 +141 if(knt3.le.iend) then + iip1 = indx(knt3) + iobp1 = knt3 + if(c_qc(iip1)(1:1).eq.'d'.or. + $ c_qc(iip1)(2:2).eq.'I'.or. + $ c_qc(iip1)(2:2).eq.'K'.or. + $ c_qc(iip1)(3:4).eq.'II'.or. + $ c_qc(iip1)(5:5).eq.'I'.or. + $ c_qc(iip1)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt3 = knt3 + 1 + goto 141 + endif + else + iip1 = 0 + iobp1 = 0 + endif +c +c Compute ii+2 index +c if(iob.lt.iend-1) iip2 = indx(iob+2) +c ------------------------------------ + iip2 = 0 + iobp2 = 0 + knt4 = knt3 + 1 +151 if(knt4.le.iend) then + iip2 = indx(knt4) + iobp2 = knt4 + if(c_qc(iip2)(1:1).eq.'d'.or. + $ c_qc(iip2)(2:2).eq.'I'.or. + $ c_qc(iip2)(2:2).eq.'K'.or. + $ c_qc(iip2)(3:4).eq.'II'.or. + $ c_qc(iip2)(5:5).eq.'I'.or. + $ c_qc(iip2)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt4 = knt4 + 1 + goto 151 + endif + else + iip2 = 0 + iobp2 = 0 + endif +c +c Compute ii+3 index +c if(iob.lt.iend-2) iip3 = indx(iob+3) +c ------------------------------------ + iip3 = 0 + knt6 = knt4 + 1 +161 if(knt6.le.iend) then + iip3 = indx(knt6) + if(c_qc(iip3)(1:1).eq.'d'.or. + $ c_qc(iip3)(2:2).eq.'I'.or. + $ c_qc(iip3)(2:2).eq.'K'.or. + $ c_qc(iip3)(3:4).eq.'II'.or. + $ c_qc(iip3)(5:5).eq.'I'.or. + $ c_qc(iip3)(5:5).eq.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then + knt6 = knt6 + 1 + goto 161 + endif + else + iip3 = 0 + endif +c +c Determine if reports are manual AIREPs +c -------------------------------------- + l_ii_man_airep = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) l_ii_man_airep = .true. +c + l_iim1_man_airep = .false. + if(iim1.ne.0) then + if(itype(iim1).eq.i_man_airep.or. + $ itype(iim1).eq.i_man_Yairep) l_iim1_man_airep = .true. + endif +c + l_iim2_man_airep = .false. + if(iim2.ne.0) then + if(itype(iim2).eq.i_man_airep.or. + $ itype(iim2).eq.i_man_Yairep) l_iim2_man_airep = .true. + endif +c + l_iim3_man_airep = .false. + if(iim3.ne.0) then + if(itype(iim3).eq.i_man_airep.or. + $ itype(iim3).eq.i_man_Yairep) l_iim3_man_airep = .true. + endif +c + l_iip1_man_airep = .false. + if(iip1.ne.0) then + if(itype(iip1).eq.i_man_airep.or. + $ itype(iip1).eq.i_man_Yairep) l_iip1_man_airep = .true. + endif +c + l_iip2_man_airep = .false. + if(iip2.ne.0) then + if(itype(iip2).eq.i_man_airep.or. + $ itype(iip2).eq.i_man_Yairep) l_iip2_man_airep = .true. + endif +c +c Set up temporary variables for ii point +c --------------------------------------- + itype0 = itype(ii) + alat0 = alat(ii) + alon0 = alon(ii) + ht_ft0 = ht_ft(ii) + idt0 = idt(ii) +c +c if(c_qc(ii)(7:8).ne.'..') then +c uwind0 = amiss +c vwind0 = amiss +c else +c uwind0 = -sin(ob_dir(ii)*d2r)*ob_spd(ii) +c vwind0 = -cos(ob_dir(ii)*d2r)*ob_spd(ii) +c endif +c +c Set up temporary variables for iim1 point +c ----------------------------------------- + if(iim1.ne.0) then + itypem1 = itype(iim1) + alatm1 = alat(iim1) + alonm1 = alon(iim1) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonm1.gt.270.0) + $ alonm1 = 360.0 - alonm1 + if(alon0.gt.270.0.and.alonm1.lt.90.0) + $ alonm1 = 360.0 + alonm1 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm1 = ht_ft(iim1) + idtm1 = idt(iim1) +c +c if(c_qc(iim1)(7:8).ne.'..') then +c uwindm1 = amiss +c vwindm1 = amiss +c else +c uwindm1 = -sin(ob_dir(iim1)*d2r)*ob_spd(iim1) +c vwindm1 = -cos(ob_dir(iim1)*d2r)*ob_spd(iim1) +c endif +c +c Compute groundspeed vector components between ii and iim1 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtm1.ne.imiss) then + idt_dif0 = abs(idt0 - idtm1) + else + idt_dif0 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatm1.ne.amiss.and.alonm1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif0.ne.imiss) then + udist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iim1),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(ii)-alon(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist0 = -udist0 + vdist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii ),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(ii)-alat(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist0 = -vdist0 + dist0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(ii ),alon(ii )) + if(idt_dif0.gt.0) then + upspd0 = udist0 / float(idt_dif0) + vpspd0 = vdist0 / float(idt_dif0) + pspd0 = dist0 / float(idt_dif0) + else + upspd0 = udist0 / float(idt_dif0+60) + vpspd0 = vdist0 / float(idt_dif0+60) + pspd0 = dist0 / float(idt_dif0+60) + endif + if(upspd0.eq.0.0.and.vpspd0.eq.0.0) then + pdir0 = 0.0 + else + pdir0 = atan2(upspd0,vpspd0) / d2r + 180.0 + endif + dist0 = dist0 / 1000.0 + else + udist0 = amiss + vdist0 = amiss + dist0 = amiss + upspd0 = amiss + vpspd0 = amiss + pspd0 = amiss + pdir0 = amiss + endif +c + if(ht_ft(ii).ne.amiss.and.ht_ft(iim1).ne.amiss) then + ht_dif0 = ht_ft(ii) - ht_ft(iim1) + else + ht_dif0 = amiss + endif +c + else + itypem1 = imiss +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm1 = amiss + alonm1 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm1 = amiss + idtm1 = amiss +c uwindm1 = amiss +c vwindm1 = amiss +c + idt_dif0 = imiss + udist0 = amiss + vdist0 = amiss + dist0 = amiss + upspd0 = amiss + vpspd0 = amiss + pspd0 = amiss + pdir0 = amiss +c + ht_dif0 = amiss + endif +c +c Set up temporary variables for iim2 point +c ----------------------------------------- + if(iim2.ne.0) then + alatm2 = alat(iim2) + alonm2 = alon(iim2) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonm2.gt.270.0) + $ alonm2 = 360.0 - alonm2 + if(alon0.gt.270.0.and.alonm2.lt.90.0) + $ alonm2 = 360.0 + alonm2 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm2 = ht_ft(iim2) + idtm2 = idt(iim2) +c +c if(c_qc(iim2)(7:8).ne.'..') then +c uwindm2 = amiss +c vwindm2 = amiss +c else +c uwindm2 = -sin(ob_dir(iim2)*d2r)*ob_spd(iim2) +c vwindm2 = -cos(ob_dir(iim2)*d2r)*ob_spd(iim2) +c endif +c +c Compute groundspeed vector components between iim2 and iim1 points +c ------------------------------------------------------------------ + if(idtm1.ne.imiss.and.idtm2.ne.imiss) then + idt_difm1 = abs(idtm1 - idtm2) + else + idt_difm1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatm2.ne.amiss.and.alonm2.ne.amiss.and. + $ alatm1.ne.amiss.and.alonm1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difm1.ne.imiss) then + udistm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim2),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iim1)-alon(iim2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistm1 = -udistm1 + vdistm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iim1)-alat(iim2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistm1 = -vdistm1 + distm1 = gcirc_qc(alat(iim2),alon(iim2), + $ alat(iim1),alon(iim1)) + if(idt_difm1.gt.0) then + upspdm1 = udistm1 / float(idt_difm1) + vpspdm1 = vdistm1 / float(idt_difm1) + pspdm1 = distm1 / float(idt_difm1) + else + upspdm1 = udistm1 / float(idt_difm1+60) + vpspdm1 = vdistm1 / float(idt_difm1+60) + pspdm1 = distm1 / float(idt_difm1+60) + endif + if(upspdm1.eq.0.0.and.vpspdm1.eq.0.0) then + pdirm1 = 0.0 + else + pdirm1 = atan2(upspdm1,vpspdm1) / d2r + 180.0 + endif + distm1 = distm1 / 1000.0 + else + udistm1 = amiss + vdistm1 = amiss + distm1 = amiss + upspdm1 = amiss + vpspdm1 = amiss + pspdm1 = amiss + pdirm1 = amiss + endif +c + if(ht_ft(iim2).ne.amiss.and.ht_ft(iim1).ne.amiss) then + ht_difm1 = ht_ft(iim1) - ht_ft(iim2) + else + ht_difm1 = amiss + endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm2 = amiss + alonm2 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm2 = amiss + idtm2 = amiss +c uwindm2 = amiss +c vwindm2 = amiss +c + idt_difm1 = imiss + udistm1 = amiss + vdistm1 = amiss + distm1 = amiss + upspdm1 = amiss + vpspdm1 = amiss + pspdm1 = amiss + pdirm1 = amiss +c + ht_difm1 = amiss + endif +c +c Set up temporary variables for iim3 point +c ----------------------------------------- + if(iim3.ne.0) then + alatm3 = alat(iim3) + alonm3 = alon(iim3) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonm3.gt.270.0) + $ alonm3 = 360.0 - alonm3 + if(alon0.gt.270.0.and.alonm3.lt.90.0) + $ alonm3 = 360.0 + alonm3 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm3 = ht_ft(iim3) + idtm3 = idt(iim3) +c +c if(c_qc(iim3)(7:8).ne.'..') then +c uwindm3 = amiss +c vwindm3 = amiss +c else +c uwindm3 = -sin(ob_dir(iim3)*d2r)*ob_spd(iim3) +c vwindm3 = -cos(ob_dir(iim3)*d2r)*ob_spd(iim3) +c endif +c +c Compute groundspeed vector components between iim3 and iim2 points +c ------------------------------------------------------------------ + if(idtm2.ne.imiss.and.idtm3.ne.imiss) then + idt_difm2 = abs(idtm2 - idtm3) + else + idt_difm2 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatm3.ne.amiss.and.alonm3.ne.amiss.and. + $ alatm2.ne.amiss.and.alonm2.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difm2.ne.imiss) then + udistm2 = gcirc_qc(alat(iim3),alon(iim3), + $ alat(iim3),alon(iim2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iim2)-alon(iim3))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistm2 = -udistm2 + vdistm2 = gcirc_qc(alat(iim3),alon(iim3), + $ alat(iim2),alon(iim3)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iim2)-alat(iim3))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistm2 = -vdistm2 + distm2 = gcirc_qc(alat(iim3),alon(iim3), + $ alat(iim2),alon(iim2)) + if(idt_difm2.gt.0) then + upspdm2 = udistm2 / float(idt_difm2) + vpspdm2 = vdistm2 / float(idt_difm2) + pspdm2 = distm2 / float(idt_difm2) + else + upspdm2 = udistm2 / float(idt_difm2+60) + vpspdm2 = vdistm2 / float(idt_difm2+60) + pspdm2 = distm2 / float(idt_difm2+60) + endif + if(upspdm2.eq.0.0.and.vpspdm2.eq.0.0) then + pdirm2 = 0.0 + else + pdirm2 = atan2(upspdm2,vpspdm2) / d2r + 180.0 + endif + distm2 = distm2 / 1000.0 + else + udistm2 = amiss + vdistm2 = amiss + distm2 = amiss + upspdm2 = amiss + vpspdm2 = amiss + pspdm2 = amiss + pdirm2 = amiss + endif +c + if(ht_ft(iim3).ne.amiss.and.ht_ft(iim2).ne.amiss) then + ht_difm2 = ht_ft(iim2) - ht_ft(iim3) + else + ht_difm2 = amiss + endif +c + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatm3 = amiss + alonm3 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftm3 = amiss + idtm3 = amiss +c uwindm3 = amiss +c vwindm3 = amiss +c + idt_difm2 = imiss + udistm2 = amiss + vdistm2 = amiss + distm2 = amiss + upspdm2 = amiss + vpspdm2 = amiss + pspdm2 = amiss + pdirm2 = amiss +c + ht_difm2 = amiss + endif +c +c Set up temporary variables for iip1 point +c ----------------------------------------- + if(iip1.ne.0) then + itypep1 = itype(iip1) + alatp1 = alat(iip1) + alonp1 = alon(iip1) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonp1.gt.270.0) + $ alonp1 = 360.0 - alonp1 + if(alon0.gt.270.0.and.alonp1.lt.90.0) + $ alonp1 = 360.0 + alonp1 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp1 = ht_ft(iip1) + idtp1 = idt(iip1) +c +c if(c_qc(iip1)(7:8).ne.'..') then +c uwindp1 = amiss +c vwindp1 = amiss +c else +c uwindp1 = -sin(ob_dir(iip1)*d2r)*ob_spd(iip1) +c vwindp1 = -cos(ob_dir(iip1)*d2r)*ob_spd(iip1) +c endif +c +c Compute groundspeed vector components between ii and iip1 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtp1.ne.imiss) then + idt_difp1 = abs(idt0 - idtp1) + else + idt_difp1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatp1.ne.amiss.and.alonp1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difp1.ne.imiss) then + udistp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(ii ),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip1)-alon(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistp1 = -udistp1 + vdistp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip1),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip1)-alat(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistp1 = -vdistp1 + distp1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip1),alon(iip1)) + if(idt_difp1.gt.0) then + upspdp1 = udistp1 / float(idt_difp1) + vpspdp1 = vdistp1 / float(idt_difp1) + pspdp1 = distp1 / float(idt_difp1) + else + upspdp1 = udistp1 / float(idt_difp1+60) + vpspdp1 = vdistp1 / float(idt_difp1+60) + pspdp1 = distp1 / float(idt_difp1+60) + endif + if(upspdp1.eq.0.0.and.vpspdp1.eq.0.0) then + pdirp1 = 0.0 + else + pdirp1 = atan2(upspdp1,vpspdp1) / d2r + 180.0 + endif + distp1 = distp1 / 1000.0 + else + udistp1 = amiss + vdistp1 = amiss + distp1 = amiss + upspdp1 = amiss + vpspdp1 = amiss + pspdp1 = amiss + pdirp1 = amiss + endif +c + if(ht_ft(ii).ne.amiss.and.ht_ft(iip1).ne.amiss) then + ht_difp1 = ht_ft(iip1) - ht_ft(ii) + else + ht_difp1 = amiss + endif +c + else + itypep1 = imiss +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp1 = amiss + alonp1 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp1 = amiss + idtp1 = amiss +c uwindp1 = amiss +c vwindp1 = amiss +c + idt_difp1 = imiss + udistp1 = amiss + vdistp1 = amiss + distp1 = amiss + upspdp1 = amiss + vpspdp1 = amiss + pspdp1 = amiss + pdirp1 = amiss +c + ht_difp1 = amiss + endif +c +c Set up temporary variables for iip2 point +c ----------------------------------------- + if(iip2.ne.0) then + itypep2 = itype(iip2) + alatp2 = alat(iip2) + alonp2 = alon(iip2) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonp2.gt.270.0) + $ alonp2 = 360.0 - alonp2 + if(alon0.gt.270.0.and.alonp2.lt.90.0) + $ alonp2 = 360.0 + alonp2 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp2 = ht_ft(iip2) + idtp2 = idt(iip2) +c +c if(c_qc(iip2)(7:8).ne.'..') then +c uwindp2 = amiss +c vwindp2 = amiss +c else +c uwindp2 = -sin(ob_dir(iip2)*d2r)*ob_spd(iip2) +c vwindp2 = -cos(ob_dir(iip2)*d2r)*ob_spd(iip2) +c endif + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp2 = amiss + alonp2 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp2 = amiss + idtp2 = amiss +c uwindp2 = amiss +c vwindp2 = amiss + endif +c + if(iip2.ne.0.and.iip1.ne.0) then +c +c Compute groundspeed vector components between iip1 and iip2 points +c ------------------------------------------------------------------ + if(idtp1.ne.imiss.and.idtp2.ne.imiss) then + idt_difp2 = abs(idtp1 - idtp2) + else + idt_difp2 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatp1.ne.amiss.and.alonp1.ne.amiss.and. + $ alatp2.ne.amiss.and.alonp2.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difp2.ne.imiss) then + udistp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip1),alon(iip2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip2)-alon(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistp2 = -udistp2 + vdistp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip2),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip2)-alat(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistp2 = -vdistp2 + distp2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip2),alon(iip2)) + if(idt_difp2.gt.0) then + upspdp2 = udistp2 / float(idt_difp2) + vpspdp2 = vdistp2 / float(idt_difp2) + pspdp2 = distp2 / float(idt_difp2) + else + upspdp2 = udistp2 / float(idt_difp2+60) + vpspdp2 = vdistp2 / float(idt_difp2+60) + pspdp2 = distp2 / float(idt_difp2+60) + endif + if(upspdp2.eq.0.0.and.vpspdp2.eq.0.0) then + pdirp2 = 0.0 + else + pdirp2 = atan2(upspdp2,vpspdp2) / d2r + 180.0 + endif + distp2 = distp2 / 1000.0 + else + udistp2 = amiss + vdistp2 = amiss + distp2 = amiss + upspdp2 = amiss + vpspdp2 = amiss + pspdp2 = amiss + pdirp2 = amiss + endif +c + if(ht_ft(iip1).ne.amiss.and.ht_ft(iip2).ne.amiss) then + ht_difp2 = ht_ft(iip2) - ht_ft(iip1) + else + ht_difp2 = amiss + endif +c + else + idt_difp2 = imiss + udistp2 = amiss + vdistp2 = amiss + distp2 = amiss + upspdp2 = amiss + vpspdp2 = amiss + pspdp2 = amiss + pdirp2 = amiss +c + ht_difp2 = amiss + endif +c +c Set up temporary variables for iip3 point +c ----------------------------------------- + if(iip3.ne.0) then + alatp3 = alat(iip3) + alonp3 = alon(iip3) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alon0.lt.90.0.and.alonp3.gt.270.0) + $ alonp3 = 360.0 - alonp3 + if(alon0.gt.270.0.and.alonp3.lt.90.0) + $ alonp3 = 360.0 + alonp3 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp3 = ht_ft(iip3) + idtp3 = idt(iip3) +c +c if(c_qc(iip3)(7:8).ne.'..') then +c uwindp3 = amiss +c vwindp3 = amiss +c else +c uwindp3 = -sin(ob_dir(iip3)*d2r)*ob_spd(iip3) +c vwindp3 = -cos(ob_dir(iip3)*d2r)*ob_spd(iip3) +c endif + else +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alatp3 = amiss + alonp3 = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + ht_ftp3 = amiss + idtp3 = amiss +c uwindp3 = amiss +c vwindp3 = amiss + endif +c + if(iip3.ne.0.and.iip2.ne.0) then +c +c Compute groundspeed vector components between iip2 and iip3 points +c ------------------------------------------------------------------ + if(idtp2.ne.imiss.and.idtp3.ne.imiss) then + idt_difp3 = abs(idtp2 - idtp3) + else + idt_difp3 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatp2.ne.amiss.and.alonp2.ne.amiss.and. + $ alatp3.ne.amiss.and.alonp3.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_difp3.ne.imiss) then + udistp3 = gcirc_qc(alat(iip2),alon(iip2), + $ alat(iip2),alon(iip3)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip3)-alon(iip2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udistp3 = -udistp3 + vdistp3 = gcirc_qc(alat(iip2),alon(iip2), + $ alat(iip3),alon(iip2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip3)-alat(iip2))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdistp3 = -vdistp3 + distp3 = gcirc_qc(alat(iip2),alon(iip2), + $ alat(iip3),alon(iip3)) + if(idt_difp3.gt.0) then + upspdp3 = udistp3 / float(idt_difp3) + vpspdp3 = vdistp3 / float(idt_difp3) + pspdp3 = distp3 / float(idt_difp3) + else + upspdp3 = udistp3 / float(idt_difp3+60) + vpspdp3 = vdistp3 / float(idt_difp3+60) + pspdp3 = distp3 / float(idt_difp3+60) + endif + if(upspdp3.eq.0.0.and.vpspdp3.eq.0.0) then + pdirp3 = 0.0 + else + pdirp3 = atan2(upspdp3,vpspdp3) / d2r + 180.0 + endif + distp3 = distp3 / 1000.0 + else + udistp3 = amiss + vdistp3 = amiss + distp3 = amiss + upspdp3 = amiss + vpspdp3 = amiss + pspdp3 = amiss + pdirp3 = amiss + endif +c + if(ht_ft(iip2).ne.amiss.and.ht_ft(iip3).ne.amiss) then + ht_difp3 = ht_ft(iip3) - ht_ft(iip2) + else + ht_difp3 = amiss + endif +c + else + idt_difp3 = imiss + udistp3 = amiss + vdistp3 = amiss + distp3 = amiss + upspdp3 = amiss + vpspdp3 = amiss + pspdp3 = amiss + pdirp3 = amiss +c + ht_difp3 = amiss + endif +c +c Compute speeds without ii report +c -------------------------------- + if(iim1.ne.0.and. + $ idtp1.ne.amiss.and.idtm1.ne.amiss) then +c +c Compute groundspeed vector components between iim1 and iip1 points +c ------------------------------------------------------------------ + if(idtm1.ne.imiss.and.idtp1.ne.imiss) then + idt_dif_wo0 = abs(idtp1 - idtm1) + else + idt_dif_wo0 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatm1.ne.amiss.and.alonm1.ne.amiss.and. + $ alatp1.ne.amiss.and.alonp1.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_wo0.ne.imiss) then + udist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iim1),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip1)-alon(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_wo0 = -udist_wo0 + vdist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iip1),alon(iim1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip1)-alat(iim1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_wo0 = -vdist_wo0 + dist_wo0 = gcirc_qc(alat(iim1),alon(iim1), + $ alat(iip1),alon(iip1)) + if(idt_dif_wo0.gt.0) then + upspd_wo0 = udist_wo0 / float(idt_dif_wo0) + vpspd_wo0 = vdist_wo0 / float(idt_dif_wo0) + pspd_wo0 = dist_wo0 / float(idt_dif_wo0) + else + upspd_wo0 = udist_wo0 / float(idt_dif_wo0+60) + vpspd_wo0 = vdist_wo0 / float(idt_dif_wo0+60) + pspd_wo0 = dist_wo0 / float(idt_dif_wo0+60) + endif + if(upspd_wo0.eq.0.0.and.vpspd_wo0.eq.0.0) then + pdir_wo0 = 0.0 + else + pdir_wo0 = atan2(upspd_wo0,vpspd_wo0) + $ / d2r + 180.0 + endif + dist_wo0 = dist_wo0 / 1000.0 + else + udist_wo0 = amiss + vdist_wo0 = amiss + dist_wo0 = amiss + upspd_wo0 = amiss + vpspd_wo0 = amiss + pspd_wo0 = amiss + pdir_wo0 = amiss + endif +c + else + udist_wo0 = amiss + vdist_wo0 = amiss + dist_wo0 = amiss + upspd_wo0 = amiss + vpspd_wo0 = amiss + pspd_wo0 = amiss + pdir_wo0 = amiss + endif +c + if(ht_ftp1.ne.amiss.and.ht_ftm1.ne.amiss) then + ht_dif_wo0 = ht_ftp1 - ht_ftm1 + else + ht_dif_wo0 = amiss + endif +c +c Compute speeds without iip1 report +c ---------------------------------- + if(iip2.ne.0.and. + $ idt0.ne.amiss.and.idtp2.ne.amiss) then +c +c Compute groundspeed vector components between ii and iip2 points +c ---------------------------------------------------------------- + if(idt0.ne.imiss.and.idtp2.ne.imiss) then + idt_dif_wop1 = abs(idtp2 - idt0) + else + idt_dif_wop1 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat0 .ne.amiss.and.alon0 .ne.amiss.and. + $ alatp2.ne.amiss.and.alonp2.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_wop1.ne.imiss) then + udist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(ii ),alon(iip2)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip2)-alon(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_wop1 = -udist_wop1 + vdist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip2),alon(ii )) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip2)-alat(ii))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_wop1 = -vdist_wop1 + dist_wop1 = gcirc_qc(alat(ii ),alon(ii ), + $ alat(iip2),alon(iip2)) + if(idt_dif_wop1.gt.0) then + upspd_wop1 = udist_wop1 / float(idt_dif_wop1) + vpspd_wop1 = vdist_wop1 / float(idt_dif_wop1) + pspd_wop1 = dist_wop1 / float(idt_dif_wop1) + else + upspd_wop1 = udist_wop1 / float(idt_dif_wop1+60) + vpspd_wop1 = vdist_wop1 / float(idt_dif_wop1+60) + pspd_wop1 = dist_wop1 / float(idt_dif_wop1+60) + endif + if(upspd_wop1.eq.0.0.and.vpspd_wop1.eq.0.0) then + pdir_wop1 = 0.0 + else + pdir_wop1 = atan2(upspd_wop1,vpspd_wop1) + $ / d2r + 180.0 + endif + dist_wop1 = dist_wop1 / 1000.0 + else + udist_wop1 = amiss + vdist_wop1 = amiss + dist_wop1 = amiss + upspd_wop1 = amiss + vpspd_wop1 = amiss + pspd_wop1 = amiss + pdir_wop1 = amiss + endif +c + else + udist_wop1 = amiss + vdist_wop1 = amiss + dist_wop1 = amiss + upspd_wop1 = amiss + vpspd_wop1 = amiss + pspd_wop1 = amiss + pdir_wop1 = amiss + endif +c + if(ht_ftp2.ne.amiss.and.ht_ft0.ne.amiss) then + ht_dif_wop1 = ht_ft(iip2) - ht_ft(ii) + else + ht_dif_wop1 = amiss + endif +c +c Compute speeds without iip2 report +c ---------------------------------- + if(iip3.ne.0.and. + $ idtp1.ne.amiss.and.idtp3.ne.amiss) then +c +c Compute groundspeed vector components between iip1 and iip3 points +c ------------------------------------------------------------------ + if(idtp1.ne.imiss.and.idtp3.ne.imiss) then + idt_dif_wop2 = abs(idtp3 - idtp1) + else + idt_dif_wop2 = imiss + endif +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alatp1.ne.amiss.and.alonp1.ne.amiss.and. + $ alatp3.ne.amiss.and.alonp3.ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_wop2.ne.imiss) then + udist_wop2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip1),alon(iip3)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iip3)-alon(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_wop2 = -udist_wop2 + vdist_wop2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip3),alon(iip1)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iip3)-alat(iip1))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_wop2 = -vdist_wop2 + dist_wop2 = gcirc_qc(alat(iip1),alon(iip1), + $ alat(iip3),alon(iip3)) + if(idt_dif_wop2.gt.0) then + upspd_wop2 = udist_wop2 / float(idt_dif_wop2) + vpspd_wop2 = vdist_wop2 / float(idt_dif_wop2) + pspd_wop2 = dist_wop2 / float(idt_dif_wop2) + else + upspd_wop2 = udist_wop2 / float(idt_dif_wop2+60) + vpspd_wop2 = vdist_wop2 / float(idt_dif_wop2+60) + pspd_wop2 = dist_wop2 / float(idt_dif_wop2+60) + endif + if(upspd_wop2.eq.0.0.and.vpspd_wop2.eq.0.0) then + pdir_wop2 = 0.0 + else + pdir_wop2 = atan2(upspd_wop2,vpspd_wop2) + $ / d2r + 180.0 + endif + dist_wop2 = dist_wop2 / 1000.0 + else + udist_wop2 = amiss + vdist_wop2 = amiss + dist_wop2 = amiss + upspd_wop2 = amiss + vpspd_wop2 = amiss + pspd_wop2 = amiss + pdir_wop2 = amiss + endif +c + else + udist_wop2 = amiss + vdist_wop2 = amiss + dist_wop2 = amiss + upspd_wop2 = amiss + vpspd_wop2 = amiss + pspd_wop2 = amiss + pdir_wop2 = amiss + endif +c + if(ht_ftp3.ne.amiss.and.ht_ftp1.ne.amiss) then + ht_dif_wop2 = ht_ftp3 - ht_ftp1 + else + ht_dif_wop2 = amiss + endif +c +c Set other variables to missing +c ------------------------------ + udist_bad0 = amiss + vdist_bad0 = amiss + dist_bad0 = amiss + upspd_bad0 = amiss + vpspd_bad0 = amiss + pspd_bad0 = amiss + pdir_bad0 = amiss +c + ht_dif_bad0 = amiss +c + idt_last_bad = imiss +c + udist_badp1 = amiss + vdist_badp1 = amiss + dist_badp1 = amiss + upspd_badp1 = amiss + vpspd_badp1 = amiss + pspd_badp1 = amiss + pdir_badp1 = amiss +c + ht_dif_badp1 = amiss +c +c Compute mean direction for current flight segment +c ------------------------------------------------- + if(iob.eq.istart.or. + $ iob.gt.ioblast.or. + $ ioblast.eq.imiss) then +c + job = iob + jjstart = ii + iifirst = ii + iobfirst = iob + iilast = iiend + ioblast = iend +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat_min = 9999.9 + alat_max = -9999.9 + alon_min = 9999.9 + alon_max = -9999.9 +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Loop over flight to find end of current segment +c ----------------------------------------------- + do while(job.le.iend) +c + jj = indx(job) + if(job.eq.iend) then + jjp1 = 0 + else + jjp1 = indx(job+1) + endif +c +c Compute distance between jj and jjstart +c --------------------------------------- + dist_track = gcirc_qc(alat(jjstart),alon(jjstart), + $ alat(jj ),alon(jj )) +c + dist_track = dist_track / 1000.0 +c +c Save max/min lat and lon +c ------------------------ + if(c_qc(jj)(1:1).ne.'d'.and. + $ c_qc(jj)(2:2).ne.'I'.and. + $ c_qc(jj)(2:2).ne.'K'.and. + $ c_qc(jj)(3:4).ne.'II'.and. + $ c_qc(jj)(5:5).ne.'I'.and. + $ c_qc(jj)(5:5).ne.'i'.or. + $ c_qc(ii)(11:11).eq.'I') then +c + if(alat(jj).lt.alat_min) then + alat_min = alat(jj) + job_alat_min = job + jj_alat_min = jj + endif +c + if(alat(jj).gt.alat_max) then + alat_max = alat(jj) + job_alat_max = job + jj_alat_max = jj + endif +c + if(alon(jj).lt.alon_min) then + alon_min = alon(jj) + job_alon_min = job + jj_alon_min = jj + endif +c + if(alon(jj).gt.alon_max) then + alon_max = alon(jj) + job_alon_max = job + jj_alon_max = jj + endif + endif +c +c End flight segment if significant time gap found +c ------------------------------------------------ + if(jjp1.ne.0) then + if((((.not.(l_ii_man_airep.and.l_iip1_man_airep).and. + $ (idt(jjp1)-idt(jj)).gt.idt_near).or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ (idt(jjp1)-idt(jj)).gt.idt_near*2))).and. + $ dist_track.gt.100.0) then +c + iilast = jj + ioblast = job + job = iend + 1 +c + else + job = job + 1 + endif +c + else + job = job + 1 + endif + enddo +c +c End segment if significant turn is present prior to previous end of segment +c --------------------------------------------------------------------------- + if((alat_max.eq.alat(iifirst).or. + $ alat_max.eq.alat(iilast)).and. + $ (alat_min.eq.alat(iifirst).or. + $ alat_min.eq.alat(iilast))) then +c + if((alon_max.eq.alon(iifirst).or. + $ alon_max.eq.alon(iilast)).and. + $ (alon_min.eq.alon(iifirst).or. + $ alon_min.eq.alon(iilast))) then +c +c write(io8,*) +c write(io8,*) 'Latitude max/min at start/end',kk +c write(io8,*) 'Longitude max/min at start/end of flt' +c write(io8,*) 'Segment endpoints not altered' +c + elseif(job_alon_max.ge.iobfirst.and. + $ job_alon_max.le.ioblast) then +c + dist_track = gcirc_qc(alat(iifirst),alon_max, + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alon_max + iilast = jj_alon_max +c write(io8,*) +c write(io8,*) 'Latitude max/min at start/end',kk +c write(io8,*) 'Ending segment at longitude max' +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Latitude max/min at start/end',kk +c write(io8,*) 'Longitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif +c + elseif(job_alon_min.ge.iobfirst.and. + $ job_alon_min.le.ioblast) then +c + dist_track = gcirc_qc(alat(iifirst),alon_min, + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alon_min + iilast = jj_alon_min +c write(io8,*) +c write(io8,*) 'Latitude max/min at start/end',kk +c write(io8,*) 'Ending segment at longitude min' +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Latitude max/min at start/end',kk +c write(io8,*) 'Longitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif +c + else + write(io8,*) + write(io8,*) 'Latitude max/min at start/end',kk + write(io8,*) 'Longitude min/max not handled' + write(io8,*) 'Segment endpoints not altered' + endif +c + elseif((alon_max.eq.alon(iifirst).or. + $ alon_max.eq.alon(iilast)).and. + $ (alon_min.eq.alon(iifirst).or. + $ alon_min.eq.alon(iilast))) then +c + if((alat_max.eq.alat(iifirst).or. + $ alat_max.eq.alat(iilast)).and. + $ (alat_min.eq.alat(iifirst).or. + $ alat_min.eq.alat(iilast))) then +c +c write(io8,*) +c write(io8,*) 'Lon max/min at start/end',kk +c write(io8,*) 'Latitude max/min at start/end of flt' +c write(io8,*) 'Segment endpoints not altered' +c + elseif(job_alat_max.ge.iobfirst.and. + $ job_alat_max.le.ioblast) then +c + dist_track = gcirc_qc(alat_max ,alon(iifirst), + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alat_max + iilast = jj_alat_max +c write(io8,*) +c write(io8,*) 'Lon max/min at start/end',kk +c write(io8,*) 'Ending segment at latitude max' +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Lon max/min at start/end',kk +c write(io8,*) 'Latitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif +c + elseif(job_alat_min.ge.iobfirst.and. + $ job_alat_min.le.ioblast) then +c + dist_track = gcirc_qc(alat_min ,alon(iifirst), + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alat_min + iilast = jj_alat_min +c write(io8,*) +c write(io8,*) 'Lon max/min at start/end',kk +c write(io8,*) 'Ending segment at latitude min' +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Lon max/min at start/end',kk +c write(io8,*) 'Latitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif +c + else + write(io8,*) + write(io8,*) 'Lon max/min at start/end',kk + write(io8,*) 'Longitude min/max not handled' + write(io8,*) 'Segment endpoints not altered' + endif +c + else +c + if(job_alat_max.ge.iobfirst.and. + $ job_alat_max.le.ioblast) then +c + dist_track = gcirc_qc(alat_max ,alon(iifirst), + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alat_max + iilast = jj_alat_max +c write(io8,*) +c write(io8,*) 'Ending segment at latitude max',kk +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Latitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif + endif +c + if(job_alat_min.ge.iobfirst.and. + $ job_alat_min.le.ioblast) then +c + dist_track = gcirc_qc(alat_min ,alon(iifirst), + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alat_min + iilast = jj_alat_min +c write(io8,*) +c write(io8,*) 'Ending segment at latitude min',kk +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Latitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif + endif +c + if(job_alon_max.ge.iobfirst.and. + $ job_alon_max.le.ioblast) then +c + dist_track = gcirc_qc(alat(iifirst),alon_max, + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alon_max + iilast = jj_alon_max +c write(io8,*) +c write(io8,*) 'Ending segment at longitude max',kk +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Longitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif + endif +c + if(job_alon_min.ge.iobfirst.and. + $ job_alon_min.le.ioblast) then +c + dist_track = gcirc_qc(alat(iifirst),alon_min, + $ alat(iifirst),alon(iifirst)) + dist_track = dist_track / 1000.0 +c + if(dist_track.gt.100.0) then +c + ioblast = job_alon_min + iilast = jj_alon_min +c write(io8,*) +c write(io8,*) 'Ending segment at longitude min',kk +c write(io8,*) 'ioblast = ',ioblast +c +c else +c write(io8,*) +c write(io8,*) 'Longitude difference too small' +c write(io8,*) 'Segment endpoints not altered' + endif + endif + endif +c +c Compute speeds for current flight segment +c ----------------------------------------- + if(iifirst.ne.0.and.iilast.ne.0) then +c + idt_start = idt(iifirst) + idt_end = idt(iilast) +c +c if(c_qc(iifirst)(7:8).ne.'..') then +c uwind_start = amiss +c vwind_start = amiss +c else +c uwind_start = -sin(ob_dir(iifirst)*d2r) +c $ *ob_spd(iifirst) +c vwind_start = -cos(ob_dir(iifirst)*d2r) +c $ *ob_spd(iifirst) +c endif +c if(c_qc(iilast)(7:8).ne.'..') then +c uwind_end = amiss +c vwind_end = amiss +c else +c uwind_end = -sin(ob_dir(iilast)*d2r)*ob_spd(iilast) +c vwind_end = -cos(ob_dir(iilast)*d2r)*ob_spd(iilast) +c endif +c +c Compute groundspeed vector components for current flight segment +c ---------------------------------------------------------------- + if(idt_start.ne.imiss.and. + $ idt_end .ne.imiss) then + idt_dif_track = abs(idt_end - idt_start) + else + idt_dif_track = imiss + endif +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(iifirst).ne.amiss.and. + $ alon(iifirst).ne.amiss.and. + $ alat(iilast) .ne.amiss.and. + $ alon(iilast) .ne.amiss.and. +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ idt_dif_track.ne.imiss) then +c + udist_track = gcirc_qc(alat(iilast),alon(iilast), + $ alat(iilast),alon(iifirst)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alon(iilast)-alon(iifirst))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ udist_track = -udist_track + vdist_track = gcirc_qc(alat(iilast),alon(iilast), + $ alat(iifirst),alon(iilast)) +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(sin((alat(iilast)-alat(iifirst))*d2r).lt.0.0) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + $ vdist_track = -vdist_track + dist_track = gcirc_qc(alat(iilast),alon(iilast), + $ alat(iifirst),alon(iifirst)) + if(idt_dif_track.gt.0) then + upspd_track = udist_track / float(idt_dif_track) + vpspd_track = vdist_track / float(idt_dif_track) + pspd_track = dist_track / float(idt_dif_track) + else + upspd_track= udist_track / float(idt_dif_track+60) + vpspd_track= vdist_track / float(idt_dif_track+60) + pspd_track = dist_track / float(idt_dif_track+60) + endif + if(upspd_track.eq.0.0.and.vpspd_track.eq.0.0) then + pdir_track = 0.0 + else + pdir_track = atan2(upspd_track,vpspd_track) + $ / d2r + 180.0 + endif + dist_track = dist_track / 1000.0 +c + else + udist_track = amiss + vdist_track = amiss + dist_track = amiss + upspd_track = amiss + vpspd_track = amiss + pspd_track = amiss + pdir_track = amiss + endif +c +c Compute vertical speed for current flight segment +c ------------------------------------------------- + if(ht_ft(iilast).ne.amiss.and. + $ ht_ft(iifirst).ne.amiss) then + ht_dif_track = ht_ft(iilast) - ht_ft(iifirst) + else + ht_dif_track = amiss + endif +c + else + idt_start = imiss + idt_end = imiss +c + udist_track = amiss + vdist_track = amiss + dist_track = amiss + upspd_track = amiss + vpspd_track = amiss + pspd_track = amiss + pdir_track = amiss +c + ht_dif_track = amiss + endif + endif +c +c Check if neighboring points are not available +c If so, skip remaining tests +c --------------------------------------------------- + if(iim1.eq.0.and.iip2.eq.0) then +c + c_qc(ii)(11:11) = 'I' + if(iip1.ne.0) c_qc(iip1)(11:11) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Neighboring points not available',ii + endif +c + elseif(iim2.eq.0.and.iip1.eq.0) then +c + if(iim1.ne.0) c_qc(iim1)(11:11) = 'I' + c_qc(ii)(11:11) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Neighboring points not available',ii + endif +c +c Check beginning of ascents and descents with low-level manuevers +c ---------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*2)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*2))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*2))).and. + $ (cos((pdirp1-pdirp2)*d2r).gt.0.0.or. + $ (distp1.lt.55.0.and. + $ distp2.lt.55.0.and. + $ abs(ht_difp1).lt.4000.0.and. + $ abs(ht_difp2).lt.4000.0.and. + $ abs(ht_difp1).ge.htdif_same*1.5.and. + $ abs(ht_difp2).ge.htdif_same*1.5).or. + $ ((distp1.lt.15.0.and. + $ abs(ht_difp1).lt.1500.0.and. + $ abs(ht_difp1).ge.htdif_same*0.5).or. + $ (distp2.lt.15.0.and. + $ abs(ht_difp2).lt.1500.0.and. + $ abs(ht_difp2).ge.htdif_same*0.5))).and. + $ ht_ft0.lt.21000.0.and. + $ ((ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2).or. + $ ((ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1).and. + $ abs(ht_difp2).lt.htdif_same*1.5).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ (ht_ftp1.lt.ht_ftp2.or. + $ ht_ftp1.gt.ht_ftp2)).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ abs(ht_difp2).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Low-level manuever ok at 1st pt',ii + endif +c +c Check middle of ascents and descents with low-level manuevers +c ------------------------------------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*2))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*2))).and. + $ (cos((pdir0-pdirp1)*d2r).gt.0.0.or. + $ (dist0 .lt.55.0.and. + $ distp1.lt.55.0.and. + $ abs(ht_dif0) .lt.4000.0.and. + $ abs(ht_difp1).lt.4000.0.and. + $ abs(ht_dif0) .ge.htdif_same*1.5.and. + $ abs(ht_difp1).ge.htdif_same*1.5).or. + $ ((dist0 .lt.15.0.and. + $ abs(ht_dif0) .lt.2000.0.and. + $ abs(ht_dif0) .ge.htdif_same*0.5).or. + $ (distp1.lt.15.0.and. + $ abs(ht_difp1).lt.2000.0.and. + $ abs(ht_difp1).ge.htdif_same*0.5))).and. + $ (ht_ft0 .lt.21000.0.or. + $ ht_ftp1.lt.21000.0).and. + $ ((ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1).or. + $ (ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1).or. + $ ((ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 ).and. + $ abs(ht_difp1).lt.htdif_same*1.5).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ (ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1)).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ abs(ht_difp1).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Low-level manuever ok',ii + endif +c +c Check middle of ascents and descents with low-level manuevers +c ------------------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ iip1.ne.0.and.iip2.ne.0.and. + $ (idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_iim1_man_airep.and.l_iim2_man_airep.and. + $ idt_difm1.le.idt_near*2))).and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*2))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*2))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*2))).and. + $ (cos((pdir0-pdirp1)*d2r).gt.0.0.or. + $ (dist0 .lt.55.0.and. + $ distp1.lt.55.0.and. + $ abs(ht_dif0) .lt.4000.0.and. + $ abs(ht_difp1).lt.4000.0.and. + $ abs(ht_dif0) .ge.htdif_same*1.5.and. + $ abs(ht_difp1).ge.htdif_same*1.5).or. + $ ((dist0 .lt.15.0.and. + $ abs(ht_dif0) .lt.2000.0.and. + $ abs(ht_dif0) .ge.htdif_same*0.5).or. + $ (distp1.lt.15.0.and. + $ abs(ht_difp1).lt.2000.0.and. + $ abs(ht_difp1).ge.htdif_same*0.5))).and. + $ (ht_ft0 .lt.21000.0.or. + $ ht_ftp1.lt.21000.0).and. + $ (ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2)) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Low-level manuever with alt max ok',ii + endif +c +c Check end of ascents and descents with low-level manuevers +c ---------------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ (iip1.eq.0.or. + $ idt_difp1.eq.imiss.or. + $ (idt_difp1.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iip1_man_airep).and. + $ idt_difp1.gt.idt_near).or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.gt.idt_near*2)))).and. + $ (idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_iim1_man_airep.and.l_iim2_man_airep.and. + $ idt_difm1.le.idt_near*2))).and. + $ (idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*2))).and. + $ (cos((pdirm1-pdir0)*d2r).gt.0.0.or. + $ (distm1.lt.55.0.and. + $ dist0.lt.55.0.and. + $ abs(ht_difm1).lt.4000.0.and. + $ abs(ht_dif0) .lt.4000.0.and. + $ abs(ht_difm1).ge.htdif_same*1.5.and. + $ abs(ht_dif0) .ge.htdif_same*1.5).or. + $ ((dist0 .lt.15.0.and. + $ abs(ht_dif0) .lt.1500.0.and. + $ abs(ht_dif0) .ge.htdif_same*0.5).or. + $ (distm1.lt.15.0.and. + $ abs(ht_difm1).lt.1500.0.and. + $ abs(ht_difm1).ge.htdif_same*0.5))).and. + $ ht_ft0.lt.21000.0.and. + $ ((ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ).or. + $ (ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ).or. + $ ((ht_ftm2.lt.ht_ftm1.or. + $ ht_ftm2.gt.ht_ftm1).and. + $ abs(ht_dif0 ).lt.htdif_same*1.5).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ (ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 )).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ abs(ht_dif0 ).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Low-level manuever ok at last pt',ii + endif +c +c Check bottom points of ascents/descents with low-level manuevers +c Use iim2, iim1, ii points +c ---------------------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_near.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_near.and. + $ ht_ftm1.lt.21000.0.and. + $ (((iip1.eq.0.or.idt_difp1.gt.idt_near).and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0.and. + $ (dist0 .lt.25.0.or. + $ cos((pdirm1-pdir0)*d2r).gt.-0.70710567)).or. + $ ((iim3.eq.0.or.idt_difm2.gt.idt_near).and. + $ ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 .and. + $ (distm1.lt.25.0.or. + $ cos((pdirm1-pdir0)*d2r).gt.-0.70710567)))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bottom of ascent/descent ok-1-',ii + endif +c +c Check bottom points of ascents/descents with low-level manuevers +c Use iim1, ii, iip1 points +c ---------------------------------------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_near.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_near.and. + $ ht_ft0.lt.21000.0.and. + $ (((iip2.eq.0.or.idt_difp2.gt.idt_near).and. + $ ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1.and. + $ (distp1.lt.25.0.or. + $ cos((pdir0-pdirp1)*d2r).gt.-0.70710567)).or. + $ ((iim2.eq.0.or.idt_difm1.gt.idt_near).and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1.and. + $ (dist0.lt.25.0.or. + $ cos((pdir0-pdirp1)*d2r).gt.-0.70710567)))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bottom of ascent/descent ok-2-',ii + endif +c +c Check bottom points of ascents/descents with low-level manuevers +c Use ii, iip1, iip2 points +c ---------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_near.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_near.and. + $ ht_ftp1.lt.21000.0.and. + $ (((iip3.eq.0.or.idt_difp3.gt.idt_near).and. + $ ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2.and. + $ (distp2.lt.25.0.or. + $ cos((pdirp1-pdirp2)*d2r).gt.-0.70710567)).or. + $ ((iim1.eq.0.or.idt_dif0.gt.idt_near).and. + $ ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2.and. + $ (distp1.lt.25.0.or. + $ cos((pdirp1-pdirp2)*d2r).gt.-0.70710567)))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Bottom of ascent/descent ok-3-',ii + endif +c +c Check if first point in flight/first point in hi-res segment is good +c Use ii, iip1, iip2 points +c -------------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.ne.imiss.and.idt_dif0.gt.idt_near).and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ cos((pdirp1-pdirp2)*d2r).gt.0.8660254.and. + $ ((ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2).or. + $ ((ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1).and. + $ abs(ht_difp2).lt.htdif_same*1.5).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ (ht_ftp1.lt.ht_ftp2.or. + $ ht_ftp1.gt.ht_ftp2)).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ abs(ht_difp2).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Hi-res time,posn agree for 1st point',ii + endif +c +c Check if middle point in hi-res segment is good +c Use iim1, ii, iip1 points +c -------------------------------------------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ cos((pdir0-pdirp1)*d2r).gt.0.8660254.and. + $ ((ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1).or. + $ (ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1).or. + $ ((ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 ).and. + $ abs(ht_difp1).lt.htdif_same*1.5).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ (ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1)).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ abs(ht_difp1).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Hi-res time,posn agree',ii + endif +c +c Check if last point in flight/last point of hi-res segment is good +c Use iim2, iim1, ii points +c ------------------------------------------------------------------ + elseif(iim1.ne.0.and.iim2.ne.0.and. + $ (iip1.eq.0.or. + $ idt_difp1.ne.imiss.and.idt_difp1.gt.idt_near).and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ cos((pdirm1-pdir0)*d2r).gt.0.8660254.and. + $ ((ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ).or. + $ (ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ).or. + $ ((ht_ftm2.lt.ht_ftm1.or. + $ ht_ftm2.gt.ht_ftm1).and. + $ abs(ht_dif0 ).lt.htdif_same*1.5).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ (ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 )).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ abs(ht_dif0 ).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Hi-res time,posn agree for last pt',ii + endif +c +c Check if track is doubling back on itself +c Compare direction of first segment with mean direction of track +c Use ii, iip1 points +c --------------------------------------------------------------- + elseif(iip1.ne.0.and.iobp1.le.ioblast.and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ pdirp1.ne.amiss.and. +c $ ifix(distp1*10.0).ne.0.and. + $ (.not.(distp1.lt.5.0.or. + $ (distp1.lt.15.0.and.ht_ft0.lt.10000.))).and. + $ pdir_track.ne.amiss.and. + $ dist_track.gt.100.0.and. + $ cos((pdirp1-pdir_track)*d2r).lt.-0.258819) then +c + if(ii.eq.iifirst.or. + $ (itype0.eq.i_mdcrs.and. + $ (itypep1.eq.i_mdcrs_asc.or. + $ itypep1.eq.i_mdcrs_des.or. + $ itypep1.eq.i_mdcrs_lvl)).or. + $ (itype0.eq.i_acars.and. + $ (itypep1.eq.i_acars_asc.or. + $ itypep1.eq.i_acars_des.or. + $ itypep1.eq.i_acars_lvl))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + c_qc(ii)(2:2) = 'I' + l_print = .false. + else + c_qc(ii)(1:1) = 'r' + c_qc(ii)(3:4) = 'II' + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) '1 Pt is headed backwards ii= ',ii + endif +c + else +c + knt_iip1_bad = knt_iip1_bad + 1 +c + if((itypep1.eq.i_mdcrs.and. + $ (itype0.eq.i_mdcrs_asc.or. + $ itype0.eq.i_mdcrs_des.or. + $ itype0.eq.i_mdcrs_lvl)).or. + $ (itypep1.eq.i_acars.and. + $ (itype0.eq.i_acars_asc.or. + $ itype0.eq.i_acars_des.or. + $ itype0.eq.i_acars_lvl))) then +c + c_qc(iip1)(2:2) = 'I' +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + else + c_qc(iip1)(1:1) = 'r' + c_qc(iip1)(3:4) = 'II' + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) '2 Pt is headed backwards iip1= ',iip1 + endif + endif +c +c Check if track is doubling back on itself +c Compare direction of first segment with mean direction of track +c Exclude allowed low-level manuevers +c Use iip1, iip2 points +c --------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and.iobp2.le.ioblast.and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ pdirp2.ne.amiss.and. +c $ ifix(distp2*10.0).ne.0.and. + $ (.not.(distp2.lt.5.0.or. + $ (distp2.lt.15.0.and.ht_ftp1.lt.10000.))).and. + $ pdir_track.ne.amiss.and. + $ dist_track.gt.100.0.and. + $ cos((pdirp2-pdir_track)*d2r).lt.-0.258819.and. + $ .not. + $ (ht_ft0.lt.21000.0.and. + $ (cos((pdirp1-pdirp2)*d2r).gt.0.0.or. + $ (distp1.lt.55.0.and. + $ distp2.lt.55.0.and. + $ abs(ht_difp1).lt.4000.0.and. + $ abs(ht_difp2).lt.4000.0.and. + $ abs(ht_difp1).ge.htdif_same*1.5.and. + $ abs(ht_difp2).ge.htdif_same*1.5).or. + $ ((distp1.lt.15.0.and. + $ abs(ht_difp1).lt.1500.0.and. + $ abs(ht_difp1).ge.htdif_same*0.5).or. + $ (distp2.lt.15.0.and. + $ abs(ht_difp2).lt.1500.0.and. + $ abs(ht_difp2).ge.htdif_same*0.5))))) then +c + knt_iip1_bad = knt_iip1_bad + 1 +c + if((itypep1.eq.i_mdcrs.and. + $ (itypep2.eq.i_mdcrs_asc.or. + $ itypep2.eq.i_mdcrs_des.or. + $ itypep2.eq.i_mdcrs_lvl)).or. + $ (itypep1.eq.i_acars.and. + $ (itypep2.eq.i_acars_asc.or. + $ itypep2.eq.i_acars_des.or. + $ itypep2.eq.i_acars_lvl))) then +c + c_qc(iip1)(2:2) = 'I' +c + if(c_acftreg(iip1)(4:5).eq.'GU'.or. + $ c_acftreg(iip1)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) '3 Pt is headed backwards iip1= ',iip1 + endif +c + elseif((itypep2.eq.i_mdcrs.and. + $ (itypep1.eq.i_mdcrs_asc.or. + $ itypep1.eq.i_mdcrs_des.or. + $ itypep1.eq.i_mdcrs_lvl)).or. + $ (itypep2.eq.i_acars.and. + $ (itypep1.eq.i_acars_asc.or. + $ itypep1.eq.i_acars_des.or. + $ itypep1.eq.i_acars_lvl))) then +c + c_qc(iip2)(2:2) = 'I' +c + if(c_acftreg(iip2)(4:5).eq.'GU'.or. + $ c_acftreg(iip2)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) '4 Pt is headed backwards iip2= ',iip2 + endif +c + else + c_qc(iip2)(1:1) = 'r' + c_qc(iip2)(3:4) = 'II' + l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) '5 Pt is headed backwards iip2= ',iip2 + endif + endif +c +c Check if first point in flight/first point after time gap is good +c Use ii, iip1, iip2 points +c ----------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*2)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ (cos((pdirp1-pdirp2)*d2r).gt.0.25881904.or. + $ (distp1.lt.15.0.and.ht_ftp1.lt.10000.0).or. + $ (distp2.lt.15.0.and.ht_ftp2.lt.10000.0).or. + $ (distp1.lt.5.0).or. + $ (distp2.lt.5.0)).and. + $ ((ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2).or. + $ (ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2.and. + $ (abs(ht_difp1).lt.7000.0.or. + $ abs(ht_difp2).lt.7000.0)).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2.and. + $ (abs(ht_difp1).lt.3000.0.or. + $ abs(ht_difp2).lt.3000.0)).or. + $ ((ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1).and. + $ abs(ht_difp2).lt.htdif_same*1.5).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ (ht_ftp1.lt.ht_ftp2.or. + $ ht_ftp1.gt.ht_ftp2)).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ abs(ht_difp2).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Time, pos, alt agree for 1st pt',ii + endif +c +c Check if middle point in flight is good +c Use iim1, ii, iip1 points +c --------------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (cos((pdir0-pdirp1)*d2r).gt.0.25881904.or. + $ (dist0 .lt.15.0.and.ht_ft0 .lt.10000.0).or. + $ (distp1.lt.15.0.and.ht_ftp1.lt.10000.0).or. + $ (dist0 .lt.5.0).or. + $ (distp1.lt.5.0)).and. + $ ((ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1).or. + $ (ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1).or. + $ (ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1.and. + $ (abs(ht_dif0) .lt.7000.0.or. + $ abs(ht_difp1).lt.7000.0)).or. + $ (ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1.and. + $ (abs(ht_dif0) .lt.3000.0.or. + $ abs(ht_difp1).lt.3000.0)).or. + $ ((ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 ).and. + $ abs(ht_difp1).lt.htdif_same*1.5).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ (ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1)).or. + $ (abs(ht_dif0 ).lt.htdif_same*1.5.and. + $ abs(ht_difp1).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Time, pos, alt agree',ii + endif +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ (distp1.lt.5.0.or. + $ distp2.lt.5.0).and. + $ ((ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2).or. + $ (ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2.and. + $ (abs(ht_difp1).lt.7000.0.or. + $ abs(ht_difp2).lt.7000.0)).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2.and. + $ (abs(ht_difp1).lt.3000.0.or. + $ abs(ht_difp2).lt.3000.0)).or. + $ ((ht_ft0 .lt.ht_ftp1.or. + $ ht_ft0 .gt.ht_ftp1).and. + $ abs(ht_difp2).lt.htdif_same*1.5).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ (ht_ftp1.lt.ht_ftp2.or. + $ ht_ftp1.gt.ht_ftp2)).or. + $ (abs(ht_difp1).lt.htdif_same*1.5.and. + $ abs(ht_difp2).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Time, pos, alt agree for near pts',ii + endif +c +c Check if last point in flight/last point before time gap is good +c Use iim2, iim1, ii points +c ---------------------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ (iip1.eq.0.or. + $ idt_difp1.eq.imiss.or. + $ (idt_difp1.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iip1_man_airep).and. + $ idt_difp1.gt.idt_near).or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.gt.idt_near*2)))).and. + $ (idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near*2.or. + $ (l_iim1_man_airep.and.l_iim2_man_airep.and. + $ idt_difm1.le.idt_near*4))).and. + $ (idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ (cos((pdirm1-pdir0)*d2r).gt.0.25881904.or. + $ (distm1.lt.15.0.and.ht_ftm1.lt.10000.0).or. + $ (dist0 .lt.15.0.and.ht_ft0 .lt.10000.0).or. + $ (distm1.lt.5.0).or. + $ (dist0 .lt.5.0)).and. + $ ((ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ).or. + $ (ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ).or. + $ (ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 .and. + $ (abs(ht_difm1).lt.7000.0.or. + $ abs(ht_dif0) .lt.7000.0)).or. + $ (ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 .and. + $ (abs(ht_difm1).lt.3000.0.or. + $ abs(ht_dif0) .lt.3000.0)).or. + $ ((ht_ftm2.lt.ht_ftm1.or. + $ ht_ftm2.gt.ht_ftm1).and. + $ abs(ht_dif0 ).lt.htdif_same*1.5).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ (ht_ftm1.lt.ht_ft0 .or. + $ ht_ftm1.gt.ht_ft0 )).or. + $ (abs(ht_difm1).lt.htdif_same*1.5.and. + $ abs(ht_dif0 ).lt.htdif_same*1.5))) then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Time, pos, alt agree for last pt',ii + endif +c +c Check for isolated manAIREPs +c ---------------------------- + elseif(l_ii_man_airep.and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp2.gt.idt_near*2))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2)))then +c + c_qc(ii)(11:11) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated manAIREP(s)',ii + endif +c +c Check for other isolated reports +c -------------------------------- + elseif((.not.l_ii_man_airep).and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp2.gt.idt_near*2/3))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2/3).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2/3).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2/3).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2/3)))then +c + c_qc(ii)(11:11) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated point(s)',ii + endif +c +c Check for position reports +c ------------------------------ + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0 .ne.imiss.and. + $ idt_dif0 .le.idt_near.and. + $ idt_difp1.ne.imiss.and. + $ idt_difp1.le.idt_near.and. + $ (((itypem1.eq.i_mdcrs_asc.or. + $ itypem1.eq.i_mdcrs_des.or. + $ itypem1.eq.i_mdcrs_lvl).and. + $ itype0.eq.i_mdcrs.and. + $ (itypep1.eq.i_mdcrs_asc.or. + $ itypep1.eq.i_mdcrs_des.or. + $ itypep1.eq.i_mdcrs_lvl)).or. + $ (itypem1.eq.i_mdcrs_asc.and. + $ itype0.eq.i_mdcrs.and. + $ itypep1.eq.i_mdcrs.and. + $ ht_ftm1.gt.20000.0).or. + $ (itypem1.eq.i_mdcrs.and. + $ itype0.eq.i_mdcrs.and. + $ itypep1.eq.i_mdcrs_des.and. + $ ht_ftp1.gt.20000.0).or. + $ ((itypem1.eq.i_acars_asc.or. + $ itypem1.eq.i_acars_des.or. + $ itypem1.eq.i_acars_lvl).and. + $ itype0.eq.i_acars.and. + $ (itypep1.eq.i_acars_asc.or. + $ itypep1.eq.i_acars_des.or. + $ itypep1.eq.i_acars_lvl)).or. + $ (itypem1.eq.i_acars_asc.and. + $ itype0.eq.i_acars.and. + $ itypep1.eq.i_acars.and. + $ ht_ftm1.gt.20000.0).or. + $ (itypem1.eq.i_acars.and. + $ itype0.eq.i_acars.and. + $ itypep1.eq.i_acars_des.and. + $ ht_ftp1.gt.20000.0))) then +c + c_qc(ii)(2:2) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'ii is position report' + endif +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1 .ne.imiss.and. + $ idt_difp1.le.idt_near.and. + $ idt_difp2.ne.imiss.and. + $ idt_difp2.le.idt_near.and. + $ (((itype0.eq.i_mdcrs_asc.or. + $ itype0.eq.i_mdcrs_des.or. + $ itype0.eq.i_mdcrs_lvl).and. + $ itypep1.eq.i_mdcrs.and. + $ (itypep2.eq.i_mdcrs_asc.or. + $ itypep2.eq.i_mdcrs_des.or. + $ itypep2.eq.i_mdcrs_lvl)).or. + $ (itype0.eq.i_mdcrs_asc.and. + $ itypep1.eq.i_mdcrs.and. + $ itypep2.eq.i_mdcrs.and. + $ ht_ft0.gt.20000.0).or. + $ (itype0.eq.i_mdcrs.and. + $ itypep1.eq.i_mdcrs.and. + $ itypep2.eq.i_mdcrs_des.and. + $ ht_ftp2.gt.20000.0).or. + $ ((itype0.eq.i_acars_asc.or. + $ itype0.eq.i_acars_des.or. + $ itype0.eq.i_acars_lvl).and. + $ itypep1.eq.i_acars.and. + $ (itypep2.eq.i_acars_asc.or. + $ itypep2.eq.i_acars_des.or. + $ itypep2.eq.i_acars_lvl)).or. + $ (itype0.eq.i_acars_asc.and. + $ itypep1.eq.i_acars.and. + $ itypep2.eq.i_acars.and. + $ ht_ft0.gt.20000.0).or. + $ (itype0.eq.i_acars.and. + $ itypep1.eq.i_acars.and. + $ itypep2.eq.i_acars_des.and. + $ ht_ftp2.gt.20000.0))) then +c + c_qc(iip1)(2:2) = 'I' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + if(c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'WU') then + l_print = .false. + else + l_print = .true. + endif +c + if(l_print) then + write(io8,*) + write(io8,*) 'iip1 is position report' + endif +cc +cc Check for manAIREPs that don't fit the track properly +cc ----------------------------------------------------- +c elseif(iim1.ne.0.and.iip1.ne.0.and. +c $ idt_dif0 .ne.imiss.and. +c $ idt_dif0 .le.idt_near.and. +c $ idt_difp1.ne.imiss.and. +c $ idt_difp1.le.idt_near.and. +c $ ( ((itype(iim1).eq.i_mdcrs_asc.or. +c $ itype(iim1).eq.i_mdcrs_des.or. +c $ itype(iim1).eq.i_mdcrs_lvl.or. +c $ itype(iim1).eq.i_mdcrs).and. +c $ (itype(ii).eq.i_man_airep.or. +c $ itype(ii).eq.i_man_Yairep).and. +c $ (itype(iip1).eq.i_mdcrs_asc.or. +c $ itype(iip1).eq.i_mdcrs_des.or. +c $ itype(iip1).eq.i_mdcrs_lvl.or. +c $ itype(iip1).eq.i_mdcrs)).or. +c $ ((itype(iim1).eq.i_acars_asc.or. +c $ itype(iim1).eq.i_acars_des.or. +c $ itype(iim1).eq.i_acars_lvl.or. +c $ itype(iim1).eq.i_acars).and. +c $ (itype(ii).eq.i_man_airep.or. +c $ itype(ii).eq.i_man_Yairep).and. +c $ (itype(iip1).eq.i_acars_asc.or. +c $ itype(iip1).eq.i_acars_des.or. +c $ itype(iip1).eq.i_acars_lvl.or. +c $ itype(iip1).eq.i_acars)) )) then +cc +c c_qc(ii)(1:1) = 'X' +c c_qc(ii)(3:4) = 'II' +c +c iob = iob + 1 +c knt_iip1_bad = 0 +cc +c l_print = .false. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'manAIREP ii does not fit' +c endif +cc +c elseif(iip1.ne.0.and.iip2.ne.0.and. +c $ idt_difp1 .ne.imiss.and. +c $ idt_difp1.le.idt_near.and. +c $ idt_difp2.ne.imiss.and. +c $ idt_difp2.le.idt_near.and. +c $ (((itype(ii).eq.i_mdcrs_asc.or. +c $ itype(ii).eq.i_mdcrs_des.or. +c $ itype(ii).eq.i_mdcrs_lvl.or. +c $ itype(ii).eq.i_mdcrs).and. +c $ (itype(iip1).eq.i_man_airep.or. +c $ itype(iip1).eq.i_man_Yairep).and. +c $ (itype(iip2).eq.i_mdcrs_asc.or. +c $ itype(iip2).eq.i_mdcrs_des.or. +c $ itype(iip2).eq.i_mdcrs_lvl.or. +c $ itype(iip2).eq.i_mdcrs))).or. +c $ ((itype(ii).eq.i_acars_asc.or. +c $ itype(ii).eq.i_acars_des.or. +c $ itype(ii).eq.i_acars_lvl.or. +c $ itype(ii).eq.i_acars).and. +c $ (itype(iip1).eq.i_man_airep.or. +c $ itype(iip1).eq.i_man_Yairep).and. +c $ (itype(iip2).eq.i_acars_asc.or. +c $ itype(iip2).eq.i_acars_des.or. +c $ itype(iip2).eq.i_acars_lvl.or. +c $ itype(iip2).eq.i_acars))) then +cc +c c_qc(iip1)(1:1) = 'X' +c c_qc(iip1)(3:4) = 'II' +c +c knt_iip1_bad = knt_iip1_bad + 1 +cc +c l_print = .false. +c if(l_print) then +c write(io8,*) +c write(io8,*) 'manAIREP iip1 does not fit' +c endif +c +c Reject isolated altitude maxima +c Use iim1, ii, and iip1 points +c ------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near*2).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*4)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ ((ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2.and. + $ abs(ht_difp1).ge.7000.0.and. + $ abs(ht_difp2).ge.7000.0).or. + $ (ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2.and. + $ abs(ht_difp1).ge.3000.0.and. + $ abs(ht_difp2).ge.3000.0))) then +c + c_qc(iip1)(1:1) = 'X' + c_qc(iip1)(5:5) = 'I' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated alt max: iip1 = ',iip1 + endif +c +c Reject isolated altitude maxima +c Use iim1, ii, and iip1 points +c ------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ ((ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1.and. + $ abs(ht_dif0) .ge.7000.0.and. + $ abs(ht_difp1).ge.7000.0).or. + $ (ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1.and. + $ abs(ht_dif0) .ge.3000.0.and. + $ abs(ht_difp1).ge.3000.0))) then +c + c_qc(ii)(1:1) = 'X' + c_qc(ii)(5:5) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Isolated alt max: ii = ',ii + endif +c +c Check if first point in flight/first point after time gap is bad +c Use ii, iip1, iip2 points +c ---------------------------------------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ (iim1.eq.0.or. + $ idt_dif0.eq.imiss.or. + $ (idt_dif0.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iim1_man_airep).and. + $ idt_dif0.gt.idt_near*2).or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0.gt.idt_near*4)))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ (idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near*2.or. + $ (l_iip1_man_airep.and.l_iip2_man_airep.and. + $ idt_difp2.le.idt_near*4))).and. + $ distp1.gt.5.0.and.distp2.gt.5.0.and. ! new + $ cos((pdirp1-pdirp2)*d2r).lt.0.5) then +c +c Reject isolated off-track point at point iip2 +c --------------------------------------------- + if(pdirp1.ne.amiss.and. + $ pdirp2.ne.amiss.and. + $ pdirp3.ne.amiss.and. + $ pdir_wop2.ne.amiss.and. + $ ((cos((pdirp2-pdirp3 )*d2r).lt.-0.5.and. + $ cos((pdirp1-pdir_wop2)*d2r).gt.0.25881904).or. +c $ (cos((pdirp2-pdirp3 )*d2r).lt.0.25881904.and. + $ cos((pdirp1-pdir_wop2)*d2r).gt.0.70710678)) then +c + c_qc(iip2)(1:1) = 'X' + c_qc(iip2)(3:4) = 'II' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever for 1st pt--iip2 = ',iip2 + endif +c +c Reject isolated off-track point at point iip1 +c --------------------------------------------- + elseif(pdir0 .ne.amiss.and. + $ pdirp1.ne.amiss.and. + $ pdirp2.ne.amiss.and. + $ pdir_wop1.ne.amiss.and. + $ ((cos((pdirp1-pdirp2 )*d2r).lt.-0.5.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.25881904).or. +c $ (cos((pdirp1-pdirp2 )*d2r).lt.0.25881904.and. + $ cos((pdir0 -pdir_wop1)*d2r).gt.0.70710678) + $ ) then +c + c_qc(iip1)(1:1) = 'X' + c_qc(iip1)(3:4) = 'II' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever for 1st pt--iip1 = ',iip1 + endif +c +c Reject beginning of circling manuever at point iip2 +c --------------------------------------------------- + elseif(pdirp1.ne.amiss.and. + $ pdirp2.ne.amiss.and. + $ pdirp3.ne.amiss.and. + $ pdir_wop2.ne.amiss.and. + $ ((cos((pdirp1-pdirp3 )*d2r).lt.-0.5.and. + $ cos((pdirp1-pdir_wop2)*d2r).lt.0.5).or. + $ (cos((pdirp1-pdirp2 )*d2r).lt.-0.5.and. + $ cos((pdirp1-pdir_wop2)*d2r).lt.0.5))) then +c + c_qc(iip2)(1:1) = 'X' + c_qc(iip2)(3:4) = 'II' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Circle near 1st pt--iip2 = ',iip2 + endif +c +c Otherwise reject first point +c ---------------------------- + else +c + c_qc(ii)(1:1) = 'X' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever for 1st pt--ii = ',ii + endif + endif +c +c Check if middle point in flight is bad +c Use iim1, ii, iip1 points +c -------------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ (idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ (idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.le.idt_near*4))).and. + $ dist0.gt.5.0.and.distp1.gt.5.0.and. ! new + $ cos((pdir0-pdirp1)*d2r).lt.0.5) then +c + if(pdir0 .ne.amiss.and. + $ pdirp1.ne.amiss.and. + $ pdirm1.ne.amiss.and. + $ pdir_wo0.ne.amiss.and. + $ iip2.ne.0.and. + $ ((cos((pdir0 -pdirp1 )*d2r).lt.-0.5.and. + $ cos((pdirm1-pdir_wo0)*d2r).gt.0.25881904).or. +c $ (cos((pdir0 -pdirp1 )*d2r).lt.0.25881904.and. + $ cos((pdirm1-pdir_wo0)*d2r).gt.0.70710678.or. + $ knt_iip1_bad.gt.0)) then +c + c_qc(ii)(1:1) = 'X' + c_qc(ii)(3:4) = 'II' +c + if(iob.gt.istart) then + iob = iob - 1 + else + iob = iob + 1 + endif + knt_iip1_bad = 0 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever--ii = ',ii + endif +c + else +c + c_qc(iip1)(1:1) = 'X' + c_qc(iip1)(3:4) = 'II' +c + knt_iip1_bad = knt_iip1_bad + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever--iip1 = ',iip1 + endif +c + endif +c +c Check if last point in flight/last point before time gap is bad +c Use iim2, iim1, ii points +c --------------------------------------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ (iip1.eq.0.or. + $ idt_difp1.eq.imiss.or. + $ (idt_difp1.ne.imiss.and. + $ ((.not.(l_ii_man_airep.and.l_iip1_man_airep).and. + $ idt_difp1.gt.idt_near*2).or. + $ (l_ii_man_airep.and.l_iip1_man_airep.and. + $ idt_difp1.gt.idt_near*4)))).and. + $ (idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near*2.or. + $ (l_iim1_man_airep.and.l_iim2_man_airep.and. + $ idt_difm1.le.idt_near*4))).and. + $ (idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near*2.or. + $ (l_ii_man_airep.and.l_iim1_man_airep.and. + $ idt_dif0 .le.idt_near*4))).and. + $ distm1.gt.5.0.and.dist0.gt.5.0.and. ! new + $ cos((pdirm1-pdir0)*d2r).lt.0.5) then +c + c_qc(ii)(1:1) = 'X' + c_qc(ii)(3:4) = 'II' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Bad manuever for last pt--ii = ',ii + endif +c +c Flag points not categorized above +c --------------------------------- + else +c + if(c_qc(ii)(11:11).ne.'N') then +c + c_qc(ii)(2:2) = 'I' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Cannot categorize report',ii + endif +c + elseif(c_qc(ii)(11:11).eq.'N') then +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Time diff too long to check',ii + endif +c + else + write(io8,*) 'How did I get here?' +c + iob = iob + 1 + knt_iip1_bad = 0 +c + l_print = .true. + endif + endif +c +c Check good points one last time +c ------------------------------- + if(c_qc(ii)(1:1).ne.'d' .and. + $ c_qc(ii)(2:2).ne.'I' .and. + $ c_qc(ii)(2:2).ne.'K' .and. + $ c_qc(ii)(3:4).ne.'II'.and. + $ c_qc(ii)(5:5).ne.'I' .and. + $ c_qc(ii)(5:5).ne.'i' ) then +c +c Check winds for anomalies at ends of descents +c --------------------------------------------- + if((iip1.eq.0.or.iip2.eq.0).and.iim1.ne.0) then + if(idt_dif0.le.idt_near.and. + $ ht_ft0.lt.8000.0.and. + $ (ht_ftm1-ht_ft0).gt.0.0.and. + $ (ht_ftm1-ht_ft0).lt.1000.0.and. + $ ob_spd(ii).ne.amiss.and. + $ ob_spd(iim1).ne.amiss.and. + $ ob_spd(ii)-ob_spd(iim1).gt.10.0) then +c + c_qc(ii)(8:8) = 'A' + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Anomalous wind speed found',ii + endif + endif + endif +c +c Reset suspect values if accepted as part of a track +c --------------------------------------------------- + if(c_qc(ii)(11:11).ne.'I') then +c +c Time is ok if time for either neighboring reports is nonzero +c ------------------------------------------------------------ + if(c_qc(ii)(2:2).eq.'S'.and. + $ (idtm1.ne.0.or. + $ idtp1.ne.0.or. + $ ht_ft(ii).lt.8000.0)) then + c_qc(ii)(2:2) = '.' +c write(io8,*) +c write(io8,*) 'Suspect time is ok' +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c Latitude is ok if latitude for both neighboring reports is nonzero +c ------------------------------------------------------------------ + elseif(c_qc(ii)(3:3).eq.'S'.and. + $ (int(alatm1*100.).ne.0.0.and. + $ int(alatp1*100.).ne.0.0)) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + c_qc(ii)(3:3) = '.' +c write(io8,*) +c write(io8,*) 'Suspect latitude is ok' +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c Longitude in AMDAR report is ok if longitude for either neighboring +c report is nonzero +c ------------------------------------------------------------------- + elseif(c_qc(ii)(4:4).eq.'S'.and. + $ (itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar).and. + $ (int(alonm1*100.).ne.0.0.or. + $ int(alonp1*100.).ne.0.0)) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + c_qc(ii)(4:4) = '.' +c write(io8,*) +c write(io8,*) 'Suspect AMDAR longitude is ok' +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c Longitude in other reports is ok if longitude for both neighboring +c report is nonzero +c ------------------------------------------------------------------ + elseif(c_qc(ii)(4:4).eq.'S'.and. + $ (int(alonm1*100.).ne.0.0.and. + $ int(alonp1*100.).ne.0.0)) then +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + c_qc(ii)(4:4) = '.' +c write(io8,*) +c write(io8,*) 'Suspect longitude is ok' +c +c Altitude is ok if report made it this far +c ----------------------------------------- + elseif(c_qc(ii)(5:5).eq.'S') then + c_qc(ii)(5:5) = '.' +c write(io8,*) +c write(io8,*) 'Suspect altitude is ok' + endif +c + endif + endif +c +c Write reports used in testing if desired +c ---------------------------------------- + if(l_print) then + write(io8,'(a18,2i6,a18,2i6)') + $ ' iistart,iiend = ',iistart,iiend, + $ ' iifirst,iilast = ',iifirst,iilast + write(io8,'(7x,12a10)') + $ 'iim2','iim1','ii','wo0', + $ 'iip1','wop1','iip2','wop2','iip3', + $ 'bad0','badp1','track' + write(io8,'(''indices'',3i10,3(10x,i10))') + $ iim2,iim1,ii, + $ iip1,iip2,iip3 +c write(io8,'(''idt = '',12i10)') +c $ idtm2,idtm1,idt0,imiss, +c $ idtp1,imiss,idtp2,imiss,idtp3, +c $ imiss,imiss,imiss +c write(io8,'(''idtdif='',12i10)') +c $ idt_difm2,idt_difm1,idt_dif0,idt_dif_wo0, +c $ idt_difp1,idt_dif_wop1,idt_difp2,idt_dif_wop2, +c $ idt_difp3,idt_dif_bad0,idt_dif_badp1,idt_dif_track + write(io8,'(''dist = '',12f10.2)') + $ distm2,distm1,dist0,dist_wo0, + $ distp1,dist_wop1,distp2,dist_wop2,distp3, + $ dist_bad0,dist_badp1,dist_track + write(io8,'(''ht_d = '',12f10.2)') + $ ht_difm2,ht_difm1,ht_dif0,ht_dif_wo0, + $ ht_difp1,ht_dif_wop1,ht_difp2,ht_dif_wop2,ht_difp3, + $ ht_dif_bad0,ht_dif_badp1,ht_dif_track + write(io8,'(''pspd = '',12f10.2)') + $ pspdm2,pspdm1,pspd0,pspd_wo0, + $ pspdp1,pspd_wop1,pspdp2,pspd_wop2,pspdp3, + $ pspd_bad0,pspd_badp1,pspd_track + write(io8,'(''pdir = '',12f10.2)') + $ pdirm2,pdirm1,pdir0,pdir_wo0, + $ pdirp1,pdir_wop1,pdirp2,pdir_wop2,pdirp3, + $ pdir_bad0,pdir_badp1,pdir_track +c + if(iim2.ne.0) then + write(io8,8002) kk,iim2 + x, c_insty_ob(itype(iim2)) + x, c_acftreg(iim2),c_acftid(iim2) + x, idt(iim2),alat(iim2),alon(iim2) + x, pres(iim2),ht_ft(iim2) + x, t_prcn(iim2),ob_t(iim2),xiv_t(iim2),ichk_t(iim2) + x, ob_q(iim2),xiv_q(iim2),ichk_q(iim2) + x, ob_dir(iim2),xiv_d(iim2),ichk_d(iim2) + x, ob_spd(iim2),xiv_s(iim2),ichk_s(iim2) + x, c_qc(iim2) + endif +c + if(iim1.ne.0) then + write(io8,8002) kk,iim1 + x, c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + endif +c + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) +c + if(iip1.ne.0) then + write(io8,8002) kk,iip1 + x, c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1) + x, pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1) + endif +c + if(iip2.ne.0) then + write(io8,8002) kk,iip2 + x, c_insty_ob(itype(iip2)) + x, c_acftreg(iip2),c_acftid(iip2) + x, idt(iip2),alat(iip2),alon(iip2) + x, pres(iip2),ht_ft(iip2) + x, t_prcn(iip2),ob_t(iip2),xiv_t(iip2),ichk_t(iip2) + x, ob_q(iip2),xiv_q(iip2),ichk_q(iip2) + x, ob_dir(iip2),xiv_d(iip2),ichk_d(iip2) + x, ob_spd(iip2),xiv_s(iip2),ichk_s(iip2) + x, c_qc(iip2) + endif +c + endif +c +c Check if last point of segment was deleted +c ------------------------------------------ + if((c_qc(ii)(1:1).eq.'d'.or. + $ c_qc(ii)(2:2).eq.'I'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i').and. + $ ioblast.eq.iob) then +c + ioblast = imiss + iilast = imiss +c + endif +c + if(iip1.ne.0) then + if((c_qc(iip1)(1:1).eq.'d'.or. + $ c_qc(iip1)(2:2).eq.'I'.or. + $ c_qc(iip1)(2:2).eq.'K'.or. + $ c_qc(iip1)(3:4).eq.'II'.or. + $ c_qc(iip1)(5:5).eq.'I'.or. + $ c_qc(iip1)(5:5).eq.'i').and. + $ ioblast.eq.iobp1) then +c + ioblast = imiss + iilast = imiss + endif +c + endif +c + endif +c + enddo +c +c Redo flight phase of reports +c ---------------------------- + do iob=istart,iend + l_print = .false. +c + ii = indx(iob) +c +c Decide if report is a manual airep +c ---------------------------------- + l_ii_man_airep = .false. + if(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) l_ii_man_airep = .true. +c +c Compute ii-1 index +c if(iob.gt.istart) iim1 = indx(iob-1) +c -------------------------------------- + iim1 = 0 + knt1 = iob - 1 + 12 if(knt1.ge.istart) then + iim1 = indx(knt1) + if(c_qc(iim1)(1:1).eq.'d'.or. + $ c_qc(iim1)(2:2).eq.'I'.or. + $ c_qc(iim1)(2:2).eq.'K'.or. + $ c_qc(iim1)(3:4).eq.'II'.or. + $ c_qc(iim1)(5:5).eq.'I'.or. + $ c_qc(iim1)(5:5).eq.'i') then + knt1 = knt1 - 1 + goto 12 + endif + else + iim1 = 0 + endif +c +c Compute ii-2 index +c if(iob.gt.istart+1) iim2 = indx(iob-2) +c -------------------------------------- + iim2 = 0 + knt2 = knt1 - 1 + 22 if(knt2.ge.istart) then + iim2 = indx(knt2) + if(c_qc(iim2)(1:1).eq.'d'.or. + $ c_qc(iim2)(2:2).eq.'I'.or. + $ c_qc(iim2)(2:2).eq.'K'.or. + $ c_qc(iim2)(3:4).eq.'II'.or. + $ c_qc(iim2)(5:5).eq.'I'.or. + $ c_qc(iim2)(5:5).eq.'i') then + knt2 = knt2 - 1 + goto 22 + endif + else + iim2 = 0 + endif +c +c Compute ii+1 index +c if(iob.lt.iend) iip1 = indx(iob+1) +c ------------------------------------ + iip1 = 0 + knt3 = iob + 1 + 32 if(knt3.le.iend) then + iip1 = indx(knt3) + if(c_qc(iip1)(1:1).eq.'d'.or. + $ c_qc(iip1)(2:2).eq.'I'.or. + $ c_qc(iip1)(2:2).eq.'K'.or. + $ c_qc(iip1)(3:4).eq.'II'.or. + $ c_qc(iip1)(5:5).eq.'I'.or. + $ c_qc(iip1)(5:5).eq.'i') then + knt3 = knt3 + 1 + goto 32 + endif + else + iip1 = 0 + endif +c +c Compute ii+2 index +c if(iob.lt.iend-1) iip2 = indx(iob+2) +c ------------------------------------ + iip2 = 0 + knt4 = knt3 + 1 + 42 if(knt4.le.iend) then + iip2 = indx(knt4) + if(c_qc(iip2)(1:1).eq.'d'.or. + $ c_qc(iip2)(2:2).eq.'I'.or. + $ c_qc(iip2)(2:2).eq.'K'.or. + $ c_qc(iip2)(3:4).eq.'II'.or. + $ c_qc(iip2)(5:5).eq.'I'.or. + $ c_qc(iip2)(5:5).eq.'i') then + knt4 = knt4 + 1 + goto 42 + endif + else + iip2 = 0 + endif +c +c Compute time and height differences +c ----------------------------------- + alat0 = alat(ii) + alon0 = alon(ii) + ht_ft0 = ht_ft(ii) +c + if(iim1.ne.0) then + idt_dif0 = abs(idt(ii) - idt(iim1)) + ht_dif0 = abs(ht_ft(ii) - ht_ft(iim1)) + ht_ftm1 = ht_ft(iim1) + else + idt_dif0 = imiss + ht_dif0 = amiss + ht_ftm1 = amiss + endif +c + if(iim2.ne.0) then + ht_ftm2 = ht_ft(iim2) + else + ht_ftm2 = amiss + endif +c + if(iim1.ne.0.and.iim2.ne.0) then + idt_difm1 = abs(idt(iim1) - idt(iim2)) + ht_difm1 = abs(ht_ft(iim1) - ht_ft(iim2)) + else + idt_difm1 = imiss + ht_difm1 = amiss + endif +c + if(iip1.ne.0) then + idt_difp1 = abs(idt(iip1) - idt(ii)) + ht_difp1 = abs(ht_ft(iip1) - ht_ft(ii)) + ht_ftp1 = ht_ft(iip1) + else + idt_difp1 = imiss + ht_difp1 = amiss + ht_ftp1 = amiss + endif +c + if(iip2.ne.0) then + ht_ftp2 = ht_ft(iip2) + else + ht_ftp2 = amiss + endif +c + if(iip2.ne.0.and.iip1.ne.0) then + idt_difp2 = abs(idt(iip2) - idt(iip1)) + ht_difp2 = abs(ht_ft(iip2) - ht_ft(iip1)) + else + idt_difp2 = imiss + ht_difp2 = amiss + endif +c +c Look for high resolution level legs +c ----------------------------------- +c +c Use iim1, ii, iip1 points +c ----------------------------------- + if(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_dif0 .lt.htdif_same+0.5.and. + $ ht_difp1.lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c -------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0 .ne.imiss.and.idt_dif0 .le.idt_updn.and. + $ ht_difm1.lt.htdif_same+0.5.and. + $ ht_dif0 .lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iip1.ne.0.and.idt_difp1.lt.idt_updn.and. + $ ht_difp1.gt.htdif_same+0.5.and. + $ ht_difp1.lt.5000.) then + if(ht_ftp1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + if(ht_ftp1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + endif +c +c Use ii, iip1, iip2 points +c -------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_difp1.lt.htdif_same+0.5.and. + $ ht_difp2.lt.htdif_same+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iim1.ne.0.and.idt_dif0.lt.idt_updn.and. + $ ht_dif0.gt.htdif_same+0.5.and. + $ ht_dif0.lt.5000.) then + if(ht_ftm1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + if(ht_ftm1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + endif +c +c Look for high resolution ascents and descents +c --------------------------------------------- +c +c Use iim1, ii, iip1 points +c ----------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'D' +c +c Use iim2, iim1, ii points +c ----------------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and.idt_difm1.le.idt_updn.and. + $ idt_dif0.ne.imiss.and.idt_dif0.le.idt_updn.and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'D' +c +c Use ii, iip1, iip2 points +c ----------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'A' +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and.idt_difp1.le.idt_updn.and. + $ idt_difp2.ne.imiss.and.idt_difp2.le.idt_updn.and. + $ ht_ft0.gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'D' +c +c Look for other level legs +c ------------------------- +c +c Use iim1, ii, iip1 points +c ------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*3)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*3)).and. + $ ht_dif0.lt.htdif_same*1.5+0.5.and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*3)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*3)).and. + $ ht_difm1.lt.htdif_same*1.5+0.5.and. + $ ht_dif0 .lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iip1.ne.0.and.idt_difp1.lt.idt_updn.and. + $ ht_difp1.gt.htdif_same+0.5.and. + $ ht_difp1.lt.5000.) then + if(ht_ftp1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + if(ht_ftp1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + endif +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*3)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*3)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5.and. + $ ht_difp2.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + if(iim1.ne.0.and.idt_dif0.lt.idt_updn.and. + $ ht_dif0.gt.htdif_same+0.5.and. + $ ht_dif0.lt.5000.) then + if(ht_ftm1.gt.ht_ft0) + $ c_qc(ii)(11:11) = 'D' ! Descending + if(ht_ftm1.lt.ht_ft0) + $ c_qc(ii)(11:11) = 'A' ! Ascending + endif +c +c Look for other ascents and descents +c ----------------------------------- +c +c Use iim1, ii, iip1 points +c -------------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_ftm1.lt.ht_ft0 .and. + $ ht_ft0 .lt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_ftm1.gt.ht_ft0 .and. + $ ht_ft0 .gt.ht_ftp1) then +c + c_qc(ii)(11:11) = 'd' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_ftm2.lt.ht_ftm1.and. + $ ht_ftm1.lt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_ftm2.gt.ht_ftm1.and. + $ ht_ftm1.gt.ht_ft0 ) then +c + c_qc(ii)(11:11) = 'd' +c +c Use ii, iip1, iip2 points +c -------------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_ft0 .lt.ht_ftp1.and. + $ ht_ftp1.lt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'a' +c + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_ft0 .gt.ht_ftp1.and. + $ ht_ftp1.gt.ht_ftp2) then +c + c_qc(ii)(11:11) = 'd' +c +c Look for 2-point level legs +c --------------------------- +c +c Use iim1, ii, iip1 points +c ------------------------- + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_dif0.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c + elseif(iim1.ne.0.and.iip1.ne.0.and. + $ idt_dif0.ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_dif0 .lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_difp1.lt.htdif_same*1.5+0.5) then +c + c_qc(ii)(11:11) = 'L' +c +c Look for isolated ascending and descending points +c ------------------------------------------------- +c +c Use iim2, iim1, ii points +c ------------------------- + elseif(iim2.ne.0.and.iim1.ne.0.and. + $ idt_difm1.ne.imiss.and. + $ (idt_difm1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difm1.le.idt_near*2)).and. + $ idt_dif0 .ne.imiss.and. + $ (idt_dif0 .le.idt_near.or. + $ (l_ii_man_airep.and.idt_dif0 .le.idt_near*2)).and. + $ ht_difm1.lt.htdif_same*1.5+0.5) then +c + if(ht_ft0.lt.ht_ftm1) then + c_qc(ii)(11:11) = 'd' + elseif(ht_ft0.gt.ht_ftm1) then + c_qc(ii)(11:11) = 'a' + else + write(io8,*) + write(io8,*) 'unidentified isolated point found!' + write(io8,*) 'hts:',ht_ftm2,ht_ftm1,ht_ft0 + c_qc(ii)(11:11) = 'U' + endif +c +c Use ii, iip1, iip2 points +c ------------------------- + elseif(iip1.ne.0.and.iip2.ne.0.and. + $ idt_difp1.ne.imiss.and. + $ (idt_difp1.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp1.le.idt_near*2)).and. + $ idt_difp2.ne.imiss.and. + $ (idt_difp2.le.idt_near.or. + $ (l_ii_man_airep.and.idt_difp2.le.idt_near*2)).and. + $ ht_difp2.lt.htdif_same*1.5+0.5) then +c + if(ht_ft0.gt.ht_ftp1) then + c_qc(ii)(11:11) = 'd' + elseif(ht_ft0.lt.ht_ftp1) then + c_qc(ii)(11:11) = 'a' + else + write(io8,*) + write(io8,*) 'unidentified isolated point found!' + write(io8,*) 'hts:',ht_ft0,ht_ftp1,ht_ftp2 + c_qc(ii)(11:11) = 'U' + endif +c +c Check if time difference is too great to categorize manAIREPs +c ------------------------------------------------------------- + elseif(l_ii_man_airep.and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp1.gt.idt_near*2).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp2.gt.idt_near*2))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2)))then +c + c_qc(ii)(11:11) = 'I' +c +c Check if time difference is too great to categorize remaining types +c ------------------------------------------------------------------- + elseif((.not.l_ii_man_airep).and. + $ ((iim1.ne.0.and.iip1.ne.0.and. + $ ((idt_difm1.gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (idt_dif0 .gt.idt_near*2/3.and. + $ idt_difp2.gt.idt_near*2/3))).or. + $ (iim1.eq.0.and.idt_difp1.gt.idt_near*2/3).or. + $ (iim1.eq.0.and.idt_difp2.gt.idt_near*2/3).or. + $ (iim2.eq.0.and.iim1.ne.0.and. + $ idt_difp1.gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_dif0 .gt.idt_near*2/3).or. + $ (iip1.eq.0.and.idt_difm1.gt.idt_near*2/3).or. + $ (iip2.eq.0.and.iip1.ne.0.and. + $ idt_dif0 .gt.idt_near*2/3)))then +c + c_qc(ii)(11:11) = 'I' +c +c Label everything else as unknown +c -------------------------------- + else + c_qc(ii)(11:11) = 'U' + endif +c +c Save flight phase +c ----------------- + l_print = .true. +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_des) then +c + if(c_qc(ii)(11:11).eq.'L') then + if(itype(ii).ne.i_mdcrs_lvl.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to mdcrs_lvl' + endif + itype(ii) = i_mdcrs_lvl +c + elseif(c_qc(ii)(11:11).eq.'a'.or. + $ c_qc(ii)(11:11).eq.'A') then + if(itype(ii).ne.i_mdcrs_asc.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to mdcrs_asc' + endif + itype(ii) = i_mdcrs_asc +c + elseif(c_qc(ii)(11:11).eq.'d'.or. + $ c_qc(ii)(11:11).eq.'D') then + if(itype(ii).ne.i_mdcrs_des.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to mdcrs_des' + endif + itype(ii) = i_mdcrs_des +c + else + if(itype(ii).ne.i_mdcrs.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to mdcrs' + endif + itype(ii) = i_mdcrs +c + endif +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_des) then +c + if(c_qc(ii)(11:11).eq.'L') then + if(itype(ii).ne.i_acars_lvl.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to acars_lvl' + endif + itype(ii) = i_acars_lvl +c + elseif(c_qc(ii)(11:11).eq.'a'.or. + $ c_qc(ii)(11:11).eq.'A') then + if(itype(ii).ne.i_acars_asc.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to acars_asc' + endif + itype(ii) = i_acars_asc +c + elseif(c_qc(ii)(11:11).eq.'d'.or. + $ c_qc(ii)(11:11).eq.'D') then + if(itype(ii).ne.i_acars_des.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to acars_des' + endif + itype(ii) = i_acars_des +c + else + if(itype(ii).ne.i_acars.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to acars' + endif + itype(ii) = i_acars +c + endif +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_des) then +c + if(c_qc(ii)(11:11).eq.'L') then + if(itype(ii).ne.i_airep_lvl.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to airep_lvl' + endif + itype(ii) = i_airep_lvl +c + elseif(c_qc(ii)(11:11).eq.'a'.or. + $ c_qc(ii)(11:11).eq.'A') then + if(itype(ii).ne.i_airep_asc.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to airep_asc' + endif + itype(ii) = i_airep_asc +c + elseif(c_qc(ii)(11:11).eq.'d'.or. + $ c_qc(ii)(11:11).eq.'D') then + if(itype(ii).ne.i_airep_des.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to airep_des' + endif + itype(ii) = i_airep_des +c + else + if(itype(ii).ne.i_airep.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to airep' + endif + itype(ii) = i_airep +c + endif +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_des) then +c + if(c_qc(ii)(11:11).eq.'L') then + if(itype(ii).ne.i_amdar_lvl.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to amdar_lvl' + endif + itype(ii) = i_amdar_lvl +c + elseif(c_qc(ii)(11:11).eq.'a'.or. + $ c_qc(ii)(11:11).eq.'A') then + if(itype(ii).ne.i_amdar_asc.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to amdar_asc' + endif + itype(ii) = i_amdar_asc +c + elseif(c_qc(ii)(11:11).eq.'d'.or. + $ c_qc(ii)(11:11).eq.'D') then + if(itype(ii).ne.i_amdar_des.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to amdar_des' + endif + itype(ii) = i_amdar_des +c + else + if(itype(ii).ne.i_amdar.and. + $ l_print) then +c write(io8,*) +c write(io8,*) 'Changing phase at ',ii,' from ', +c $ c_insty_ob(itype(ii)),' to amdar' + endif + itype(ii) = i_amdar +c + endif +c + endif +c + enddo +c +c Mark small flights +c ------------------ + else + do iob=istart,iend + ii = indx(iob) + c_qc(ii)(11:11) = 'N' + enddo + endif +c +c End loop over flights +c --------------------- + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io36,*) + write(io36,*)'Ordering errors' + write(io36,*)'---------------' + write(io36,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + kbad = 0 +c + do iob = 1,numreps + ii = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c + if(ktype.eq.1) then + nrep_Md = nrep_Md + 1 + elseif(ktype.eq.2) then + nrep_Ac = nrep_Ac + 1 + elseif(ktype.eq.3) then + nrep_Am = nrep_Am + 1 + elseif(ktype.eq.4) then + nrep_Ar = nrep_Ar + 1 + elseif(ktype.eq.5) then + nrep_Ma = nrep_Ma + 1 + endif +c + if(c_qc(ii)(1:1).eq.'d'.or. + $ c_qc(ii)(1:1).eq.'2'.or. + $ c_qc(ii)(2:2).eq.'I'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i'.or. + $ c_qc(ii)(8:8).eq.'A') then +c + if(.not.l_operational) then + write(io36,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count number of rejected winds by tail number +c --------------------------------------------- + if(c_qc(ii)(8:8).eq.'A') then + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + if(ktype.gt.0.and.ktype.le.5) + $ nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif +c +c Count by category +c ----------------- + if(c_qc(ii)(1:1).eq.'d') then + nord_dup(ktype) = nord_dup(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'K') then + nord_stk(ktype) = nord_stk(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'I') then + nord_time(ktype) = nord_time(ktype) + 1 + elseif(c_qc(ii)(3:4).eq.'II') then + if(c_qc(ii)(1:1).eq.'p') then + nord_near(ktype) = nord_near(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'P') then + nord_aspd(ktype) = nord_aspd(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'O') then + nord_lone(ktype) = nord_lone(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'r') then + nord_dble(ktype) = nord_dble(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'X') then + nord_turn(ktype) = nord_turn(ktype) + 1 + endif + elseif(c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i') then + nord_alt(ktype) = nord_alt(ktype) + 1 + elseif(c_qc(ii)(8:8).eq.'A') then + nord_wind(ktype) = nord_wind(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'2') then + nord_2nd(ktype) = nord_2nd(ktype) + 1 + endif +c +c Reject reports with inconsistent heights and positions +c ------------------------------------------------------ + if(c_qc(ii)(1:1).eq.'d'.or. + $ c_qc(ii)(2:2).eq.'I'.or. + $ c_qc(ii)(2:2).eq.'K'.or. + $ c_qc(ii)(3:4).eq.'II'.or. + $ c_qc(ii)(5:5).eq.'I'.or. + $ c_qc(ii)(5:5).eq.'i') then +c + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(ktype.eq.1) then + nord_Md = nord_Md + 1 + elseif(ktype.eq.2) then + nord_Ac = nord_Ac + 1 + elseif(ktype.eq.3) then + nord_Am = nord_Am + 1 + elseif(ktype.eq.4) then + nord_Ar = nord_Ar + 1 + elseif(ktype.eq.5) then + nord_Ma = nord_Ma + 1 + endif + endif +c + endif +c + enddo +c + if(.not.l_operational) then + write(io36,*) + write(io36,*) ' Number of MDCRS reps rej by ord = ',kbad(1) +ccccdak write(io36,*) ' Number of ACARS reps rej by ord = ',kbad(2) + write(io36,*) ' Number of TAMDAR reps rej by ord = ',kbad(2) + write(io36,*) ' Number of AMDAR reps rej by ord = ',kbad(3) + write(io36,*) ' Number of AIREP reps rej by ord = ',kbad(4) + write(io36,*) ' Number of manAIREP reps rej by ord = ',kbad(5) + endif +c + write(io8,*) + write(io8,*) ' Reports with ordering errors--rejected' + write(io8,*) ' --------------------------------------' + write(io8,*) ' Number of MDCRS reps rej by ord = ',kbad(1) +ccccdak write(io8,*) ' Number of ACARS reps rej by ord = ',kbad(2) + write(io8,*) ' Number of TAMDAR reps rej by ord = ',kbad(2) + write(io8,*) ' Number of AMDAR reps rej by ord = ',kbad(3) + write(io8,*) ' Number of AIREP reps rej by ord = ',kbad(4) + write(io8,*) ' Number of manAIREP reps rej by ord = ',kbad(5) +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers for reports with anomalous winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' ---------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) 'Ordering check data counts' + write(io8,*) '--------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ nord_Md,nord_Ac,nord_Am,nord_Ar,nord_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Near duplicate '',5(1x,i7))') + $ (nord_dup(ii),ii=1,5) + write(io8,'(''Stuck time '',5(1x,i7))') + $ (nord_stk(ii),ii=1,5) + write(io8,'(''Incons. time '',5(1x,i7))') + $ (nord_time(ii),ii=1,5) + write(io8,'(''Close to reject'',5(1x,i7))') + $ (nord_near(ii),ii=1,5) + write(io8,'(''High airspeed '',5(1x,i7))') + $ (nord_aspd(ii),ii=1,5) + write(io8,'(''Off-track pt '',5(1x,i7))') + $ (nord_lone(ii),ii=1,5) + write(io8,'(''Reversed track '',5(1x,i7))') + $ (nord_dble(ii),ii=1,5) + write(io8,'(''Large turn '',5(1x,i7))') + $ (nord_turn(ii),ii=1,5) + write(io8,'(''Bad alt order '',5(1x,i7))') + $ (nord_alt(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Second flight '',5(1x,i7))') + $ (nord_2nd(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Anomalous winds'',5(1x,i7))') + $ (nord_wind(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in ordering check' +c + return + end +c +c ################################################################### +c subroutine suspect_qc +c ################################################################### +c + subroutine suspect_qc(numreps,max_reps,indx,csort,imiss,idt_near + $, amiss,c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, maxflt,kflight,creg_flt,nobs_flt,ntot_flt + $, nrej_flt,iobs_flt,kreg,creg_reg,nobs_reg,nwind_reg + $, ntot_reg,kbadtot,io8,io37,l_operational,l_init) +c +c Re-examine suspect data points +c Also, mark as suspect reports from flights with only one or two reports +c remainder of reports from flights with excessive rejects +c +c modified by p.m.pauley (4/3/01) to decrease threshold percentage for bad flight +c rejects from 50% to 35% +c + implicit none +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Flight statistics +c ----------------- + integer maxflt ! max number of flights allowed + $, kflight ! number of flights in dataset + character*8 creg_flt(maxflt) ! tail number for each flight + integer nobs_flt(maxflt) ! number of reports per flight + $, ntot_flt(maxflt) ! previous value of total number of reports per flight + $, nrej_flt(maxflt) ! number of reports rejected per flight + $, iobs_flt(maxflt) ! index for first report in each flight +c + integer istart ! index for 1st rep in current flight + $, iistart ! index from pointer array for istart + $, iend ! index for last rep in current flight + $, iiend ! index from pointer array for iend +c +c Tail number statistics +c ---------------------- + integer kreg ! actual number of tail#s in dataset + character*8 creg_reg(maxflt) ! tail numbers + integer nobs_reg(maxflt,5) ! number of reports per tail# per type + integer ntot_reg(maxflt,5) ! total number of reports rejected per tail# + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds +c +c Counters +c -------- + integer nsus_small(5) ! number of reports from small flights + $, nsus_perct(5) ! number of reports from bad flights + $, nsus_time(5) ! number of reports with bad times + $, nsus_lat(5) ! number of reports with bad latitudes + $, nsus_lon(5) ! number of reports with bad longitudes + $, nsus_alt(5) ! number of reports with bad altitudes + $, nsus_wind(5) ! number of reports with bad windspeeds + $, nsus_roll(5) ! number of reports with bad roll angles + integer kbad(5) ! counter for number of bad reports + $, kbadtot ! counter for total number of bad reports +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak integer nsus_Ac ! number of acars reports rejected + integer nsus_Ac ! number of tamdar reports rejected + $, nsus_Md ! number of mdcrs reports rejected + $, nsus_Ma ! number of manual airep reports rejected + $, nsus_Ar ! number of airep reports rejected + $, nsus_Am ! number of amdar reports rejected +c +c Instrument types +c ---------------- +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + $, ktype ! +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io37 ! i/o unit number for suspect data check rejects +c + real perct_flt ! percent of rejected reports for this flight + $, perct_reg ! percent of rejected reports for this aircraft + $, spdm1 ! speed in iim1 report + $, spdp1 ! speed in iip1 report + $, amiss ! real missing value flag +c + integer imiss ! integer missing value + integer iob ! do loop index + $, ii ! index pointing to current report + $, iim1 ! index pointing to previous report + $, iip1 ! index pointing to following report + integer knt ! counter used to define iim1 index + $, knt0 ! counter used to define iip1 index +c + integer kk,mm ! do loop index + $, ntot ! sum over data types of ntot_reg + $, nobs ! sum over data types of nobs_reg + $, idt_dif0 ! time difference (current - previous report) + $, idt_difp1 ! time difference (current - following report) + integer idt_near ! time difference between "near" neighbors +c + logical l_print ! switch for printing + $, l_init ! if true, initialize counters + $, l_operational ! true if operational mode used +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + nsus_small = 0 + nsus_perct = 0 + nsus_time = 0 + nsus_lat = 0 + nsus_lon = 0 + nsus_alt = 0 + nsus_wind = 0 + nsus_roll = 0 + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nsus_Ac = 0 + nsus_Md = 0 + nsus_Ma = 0 + nsus_Ar = 0 + nsus_Am = 0 + endif +c + nwind_reg = 0 +c +c Begin loop over flights +c ----------------------- + do kk = 1,kflight +c +c Initialize variables +c -------------------- + istart = iobs_flt(kk) + iistart = indx(istart) + iend = iobs_flt(kk) + nobs_flt(kk) - 1 + iiend = indx(iend) +c +c Mark as suspect reports from flights with only one or two reports +c ----------------------------------------------------------------- + if(nobs_flt(kk).eq.1.and. + $ itype(iistart).ne.i_man_airep.and. + $ itype(iistart).ne.i_man_Yairep) then + c_qc(iistart)(1:1) = 's' +c + elseif(nobs_flt(kk).eq.2.and. + $ itype(iistart).ne.i_man_airep.and. + $ itype(iistart).ne.i_man_Yairep) then + c_qc(iistart)(1:1) = 's' + c_qc(iiend)(1:1) = 's' +c +c Do further checks on flights with 3 or more reports +c --------------------------------------------------- + elseif(nobs_flt(kk).ge.3) then +c +c Loop over flights +c ----------------- + do iob=istart,iend + ii = indx(iob) + l_print = .false. +c +c Check suspect time, lat, lon, height, or winds +c ---------------------------------------------- + if(c_qc(ii)(2:2).eq.'S'.or. + $ c_qc(ii)(3:3).eq.'S'.or. + $ c_qc(ii)(4:4).eq.'S'.or. + $ c_qc(ii)(5:5).eq.'S'.or. + $ c_qc(ii)(8:8).eq.'S'.or. + $ ichk_s(ii).eq.-10) then +c +c Compute ii-1 index +c ------------------ + knt = iob - 1 + 10 if(knt.ge.istart) then + iim1 = indx(knt) + if(c_qc(iim1)(1:1).eq.'s'.or. + $ c_qc(iim1)(2:2).eq.'B'.or. + $ c_qc(iim1)(3:3).eq.'B'.or. + $ c_qc(iim1)(4:4).eq.'B'.or. + $ c_qc(iim1)(5:5).eq.'B') then + knt = knt - 1 + goto 10 + endif + else + iim1 = 0 + endif +c +c Compute ii+1 index +c ------------------ + knt0 = iob + 1 + 20 if(knt0.le.iend) then + iip1 = indx(knt0) + if(c_qc(iip1)(1:1).eq.'s'.or. + $ c_qc(iip1)(2:2).eq.'B'.or. + $ c_qc(iip1)(3:3).eq.'B'.or. + $ c_qc(iip1)(4:4).eq.'B'.or. + $ c_qc(iip1)(5:5).eq.'B') then + knt0 = knt0 + 1 + goto 20 + endif + else + iip1 = 0 + endif +c +c Compute time differences +c ------------------------ + if(iim1.ne.0) then + idt_dif0 = abs(idt(ii) - idt(iim1)) + spdm1 = ob_spd(iim1) + else + idt_dif0 = imiss + spdm1 = amiss + endif +c + if(iip1.ne.0) then + idt_difp1 = abs(idt(iip1) - idt(ii)) + spdp1 = ob_spd(iip1) + else + idt_difp1 = imiss + spdp1 = amiss + endif +c +c Check suspect winds +c ------------------- + if(c_qc(ii)(8:8).eq.'S'.and.ob_spd(ii).eq.0.0) then +c + if((idt_dif0 .le.idt_near*2.and.idt_dif0 .ne.imiss.and. + $ idt_difp1.le.idt_near*2.and.idt_difp1.ne.imiss.and. + $ (spdm1.ne.0.0.or.spdp1.ne.0.0).and. + $ ((spdm1.le.5.0.and.spdm1.ne.amiss.and. + $ spdp1.le.5.0.and.spdp1.ne.amiss).or. + $ ht_ft(ii).le.5000.)).or. + $ (idt_dif0 .le.idt_near*2.and.idt_dif0.ne.imiss.and. + $ idt_difp1.gt.idt_near*2.and. + $ spdm1.ne.0.0.and.spdm1.ne.amiss.and. + $ (spdm1.le.5.0.or.ht_ft(ii).le.5000.)).or. + $ (idt_dif0 .gt.idt_near*2.and. + $ idt_difp1.le.idt_near*2.and.idt_difp1.ne.imiss.and. + $ spdp1.ne.0.0.and.spdp1.ne.amiss.and. + $ (spdp1.le.5.0.or.ht_ft(ii).le.5000.))) then +c + c_qc(ii)(8:8) = '.' +c + if(ht_ft(ii).gt.10000.0) then + l_print = .true. + else + l_print = .false. + endif + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect winds are ok at ii = ',ii + endif +c + else + c_qc(ii)(8:8) = 'B' +c + l_print = .false. + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect winds are NOT ok at ii = ',ii + endif + endif +c +c Reject remaining suspect times, latitudes, longitudes, altitudes +c (Previously checked in ordchek and ok'ed values reset) +c ------------------------------------------------------ + elseif(c_qc(ii)(2:2).eq.'S') then +c + c_qc(ii)(2:2) = 'B' + nrej_flt(kk) = nrej_flt(kk) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect time is NOT ok at ii =',ii + endif +c + elseif(c_qc(ii)(3:3).eq.'S') then +c + c_qc(ii)(3:3) = 'B' + nrej_flt(kk) = nrej_flt(kk) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect latitude is NOT ok at ii = ',ii + endif +c + elseif(c_qc(ii)(4:4).eq.'S') then +c + c_qc(ii)(4:4) = 'B' + nrej_flt(kk) = nrej_flt(kk) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect longitude is NOT ok at ii = ',ii + endif +c + elseif(c_qc(ii)(5:5).eq.'S') then +c + c_qc(ii)(5:5) = 'B' + nrej_flt(kk) = nrej_flt(kk) + 1 +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Suspect altitude is NOT ok at ii = ',ii + endif + endif +c +c Check if roll angle qc flag is set +c ---------------------------------- + if(ichk_s(ii).eq.-10) then + if(c_acftreg(ii)(4:5).eq.'WU'.or. + $ c_acftreg(ii)(4:5).eq.'GU'.or. + $ c_acftreg(ii)(4:5).eq.'KJ'.or. + $ c_acftreg(ii)(4:5).eq.'0J'.or. + $ c_acftreg(ii)(4:5).eq.'YC'.or. + $ c_acftreg(ii)(4:5).eq.'IC'.or. + $ c_acftreg(ii)(4:5).eq.'EI'.or. + $ c_acftreg(ii)(4:5).eq.'UI'.or. + $ c_acftreg(ii)(1:2).eq.'AU'.or. + $ c_acftreg(ii)(1:2).eq.'EU') then + l_print = .false. + else + l_print = .true. + endif +c + c_qc(ii)(7:8) = 'ss' +c + if(l_print) then + write(io8,*) + write(io8,*) 'Bad roll angle QC flag on unlisted acft' + endif + endif + endif +c +c Print set of reports if print flag is set +c ----------------------------------------- + if(l_print) then + if(iim1.ne.0) then + write(io8,8002) kk,iim1 + x, c_insty_ob(itype(iim1)) + x, c_acftreg(iim1),c_acftid(iim1) + x, idt(iim1),alat(iim1),alon(iim1) + x, pres(iim1),ht_ft(iim1) + x, t_prcn(iim1),ob_t(iim1),xiv_t(iim1),ichk_t(iim1) + x, ob_q(iim1),xiv_q(iim1),ichk_q(iim1) + x, ob_dir(iim1),xiv_d(iim1),ichk_d(iim1) + x, ob_spd(iim1),xiv_s(iim1),ichk_s(iim1) + x, c_qc(iim1) + endif +c + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) +c + if(iip1.ne.0) then + write(io8,8002) kk,iip1 + x, c_insty_ob(itype(iip1)) + x, c_acftreg(iip1),c_acftid(iip1) + x, idt(iip1),alat(iip1),alon(iip1) + x, pres(iip1),ht_ft(iip1) + x, t_prcn(iip1),ob_t(iip1),xiv_t(iip1),ichk_t(iip1) + x, ob_q(iip1),xiv_q(iip1),ichk_q(iip1) + x, ob_dir(iip1),xiv_d(iip1),ichk_d(iip1) + x, ob_spd(iip1),xiv_s(iip1),ichk_s(iip1) + x, c_qc(iip1) + endif + 8002 format(i4,1x,i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif + enddo +c +c Check if excessive rejects are present for this flight +c ------------------------------------------------------ + if(ntot_flt(kk).eq.0) then + write(io8,*) + write(io8,*) 'ntot_flt(kk) = 0 for kk =',kk,' ',creg_flt(kk) + perct_flt = -9999. + else + perct_flt = 100.0 * float(nrej_flt(kk))/float(ntot_flt(kk)) + endif +c +c Check if excessive rejects are present for this aircraft +c -------------------------------------------------------- + if(nrej_flt(kk).ne.ntot_flt(kk)) then + mm = 1 + perct_reg = 0.0 + do while(mm.le.kreg) + if(creg_flt(kk).eq.creg_reg(mm)) then + ntot = ntot_reg(mm,1) + ntot_reg(mm,2) + $ + ntot_reg(mm,3) + ntot_reg(mm,4) + ntot_reg(mm,5) + nobs = nobs_reg(mm,1) + nobs_reg(mm,2) + $ + nobs_reg(mm,3) + nobs_reg(mm,4) + nobs_reg(mm,5) + if(nobs.eq.0) then + write(io8,*) + write(io8,*) 'nobs_reg(mm) = 0 for mm = ',mm + perct_flt = -9999. + else + perct_reg = 100.0 * float(ntot) / float(nobs) + endif + mm = kreg + 1 + endif + mm = mm + 1 + enddo +c +c Check percentage of reports from flight and percentage of +c reports from non-manAIREP tail numbers +c --------------------------------------------------------- + if((perct_flt.ne.-9999..and.perct_flt.gt.35.0).or. + $ (creg_flt(kk)(5:8).ne.' '.and. + $ (perct_reg.ne.-9999..and.perct_reg.gt.35.0))) then +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Excessive rejects found for flight ',kk + write(io8,*) '% flt = ',perct_flt,' nrej = ', + $ nrej_flt(kk),' nobs = ',ntot_flt(kk) + write(io8,*) '% reg = ',perct_reg,' nrej = ',ntot, + $ ' nobs = ',nobs + endif +c +c Loop over flights +c ----------------- + do iob=istart,iend + ii = indx(iob) + if(c_qc(ii)(1:1).ne.'s'.and. + $ c_qc(ii)(2:2).ne.'B'.and. + $ c_qc(ii)(3:3).ne.'B'.and. + $ c_qc(ii)(4:4).ne.'B'.and. + $ c_qc(ii)(5:5).ne.'B') then +c + c_qc(ii)(1:1) = 'S' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) +c + endif + enddo + endif + endif + endif +c +c End loop over flights +c --------------------- + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io37,*) + write(io37,*) 'Suspect data check' + write(io37,*) '------------------' + write(io37,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + kbad = 0 +c + do iob = 1,numreps + ii = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c + if(ktype.eq.1) then + nrep_Md = nrep_Md + 1 + elseif(ktype.eq.2) then + nrep_Ac = nrep_Ac + 1 + elseif(ktype.eq.3) then + nrep_Am = nrep_Am + 1 + elseif(ktype.eq.4) then + nrep_Ar = nrep_Ar + 1 + elseif(ktype.eq.5) then + nrep_Ma = nrep_Ma + 1 + endif +c + if(c_qc(ii)(1:1).eq.'s'.or. + $ c_qc(ii)(1:1).eq.'S'.or. + $ c_qc(ii)(2:2).eq.'B'.or. + $ c_qc(ii)(3:3).eq.'B'.or. + $ c_qc(ii)(4:4).eq.'B'.or. + $ c_qc(ii)(5:5).eq.'B'.or. + $ c_qc(ii)(8:8).eq.'B'.or. + $ c_qc(ii)(7:8).eq.'ss') then +c + if(.not.l_operational) then + write(io37,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count number of rejected temps/winds by tail number +c --------------------------------------------------- + if(c_qc(ii)(8:8).eq.'B') then + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + if(ktype.gt.0.and.ktype.le.5) + $ nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif +c +c Count by category +c ----------------- + if(c_qc(ii)(1:1).eq.'s') then + nsus_small(ktype) = nsus_small(ktype) + 1 + elseif(c_qc(ii)(1:1).eq.'S') then + nsus_perct(ktype) = nsus_perct(ktype) + 1 + elseif(c_qc(ii)(2:2).eq.'B') then + nsus_time(ktype) = nsus_time(ktype) + 1 + elseif(c_qc(ii)(3:3).eq.'B') then + nsus_lat(ktype) = nsus_lat(ktype) + 1 + elseif(c_qc(ii)(4:4).eq.'B') then + nsus_lon(ktype) = nsus_lon(ktype) + 1 + elseif(c_qc(ii)(5:5).eq.'B') then + nsus_alt(ktype) = nsus_alt(ktype) + 1 + elseif(c_qc(ii)(8:8).eq.'B') then + nsus_wind(ktype) = nsus_wind(ktype) + 1 + elseif(c_qc(ii)(7:8).eq.'ss') then + nsus_roll(ktype) = nsus_roll(ktype) + 1 + endif +c +c Reject reports with inconsistent heights and positions +c ------------------------------------------------------ + if(c_qc(ii)(1:1).eq.'s'.or. + $ c_qc(ii)(1:1).eq.'S'.or. + $ c_qc(ii)(2:2).eq.'B'.or. + $ c_qc(ii)(3:3).eq.'B'.or. + $ c_qc(ii)(4:4).eq.'B'.or. + $ c_qc(ii)(5:5).eq.'B') then +c + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(ktype.eq.1) then + nsus_Md = nsus_Md + 1 + elseif(ktype.eq.2) then + nsus_Ac = nsus_Ac + 1 + elseif(ktype.eq.3) then + nsus_Am = nsus_Am + 1 + elseif(ktype.eq.4) then + nsus_Ar = nsus_Ar + 1 + elseif(ktype.eq.5) then + nsus_Ma = nsus_Ma + 1 + endif + endif +c + endif + enddo +c + if(.not.l_operational) then + write(io37,*) + write(io37,*) ' Number of MDCRS reps rej by sus = ',kbad(1) +ccccdak write(io37,*) ' Number of ACARS reps rej by sus = ',kbad(2) + write(io37,*) ' Number of TAMDAR reps rej by sus = ',kbad(2) + write(io37,*) ' Number of AMDAR reps rej by sus = ',kbad(3) + write(io37,*) ' Number of AIREP reps rej by sus = ',kbad(4) + write(io37,*) ' Number of manAIREP reps rej by sus = ',kbad(5) + endif +c + write(io8,*) + write(io8,*) ' Reports with suspect data errors--rejected' + write(io8,*) ' ------------------------------------------' + write(io8,*) ' Number of MDCRS reps rej by sus = ',kbad(1) +ccccdak write(io8,*) ' Number of ACARS reps rej by sus = ',kbad(2) + write(io8,*) ' Number of TAMDAR reps rej by sus = ',kbad(2) + write(io8,*) ' Number of AMDAR reps rej by sus = ',kbad(3) + write(io8,*) ' Number of AIREP reps rej by sus = ',kbad(4) + write(io8,*) ' Number of manAIREP reps rej by sus = ',kbad(5) +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers for reps with rejected zero winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' ----------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) 'Suspect data check counts' + write(io8,*) '-------------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ nsus_Md,nsus_Ac,nsus_Am,nsus_Ar,nsus_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Small flights '',5(1x,i7))') + $ (nsus_small(ii),ii=1,5) + write(io8,'(''Bad flights '',5(1x,i7))') + $ (nsus_perct(ii),ii=1,5) + write(io8,'(''Bad times '',5(1x,i7))') + $ (nsus_time(ii),ii=1,5) + write(io8,'(''Bad lats '',5(1x,i7))') + $ (nsus_lat(ii),ii=1,5) + write(io8,'(''Bad lons '',5(1x,i7))') + $ (nsus_lon(ii),ii=1,5) + write(io8,'(''Bad alts '',5(1x,i7))') + $ (nsus_alt(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Bad winds '',5(1x,i7))') + $ (nsus_wind(ii),ii=1,5) + write(io8,'(''Bad roll angle '',5(1x,i7))') + $ (nsus_roll(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in suspect data check' +c + return + end +c +c ################################################################### +c subroutine rejlist_qc +c ################################################################### +c + subroutine rejlist_qc(numreps,max_reps,indx,csort + $, c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s + $, idt,itype,ichk_t,ichk_q,ichk_d,ichk_s + $, nchk_t,nchk_q,nchk_d,nchk_s + $, maxflt,kreg,creg_reg,nwind_reg,ntemp_reg + $, kbadtot,io8,io38,l_operational,l_init,l_ncep) +c +c Reject temperatures and winds from aircraft on reject list +c +c Just reject manAIREP aircraft for now. Suspect airlines determined +c by Colin Parrett (UKMet) are listed in a data statement. +c +c Written by P.M. Pauley (6/5/02) +c + implicit none +c +c Parameter statements +c -------------------- + integer nwind ! number of aircraft on wind reject list + integer ntemp ! number of aircraft on temperature reject list + parameter(nwind = 12,ntemp = 12) +c +c Declaration statements +c ---------------------- + integer max_reps ! maximum number of reports +c + character*11 c_qc(max_reps) ! internal qc flags +c +c Data arrays +c ----------- + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + integer nchk_t(max_reps) ! NCEP QC flag for temperature ob + $, nchk_q(max_reps) ! NCEP QC flag for specific humidity ob + $, nchk_d(max_reps) ! NCEP QC flag for wind direction ob + $, nchk_s(max_reps) ! NCEP QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Tail number statistics +c ---------------------- + integer maxflt ! max number of flights allowed + integer kreg ! actual number of tail#s in dataset + character*8 creg_reg(maxflt) ! tail numbers + integer nwind_reg(maxflt,5) ! number of reports w. rejected winds + integer ntemp_reg(maxflt,5) ! number of reports w. rejected temperatures +c +c Counters +c -------- + integer kbad(5) ! counter for number of bad reports + $, kbadtot ! counter for total number of bad reports +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak integer nlst_Ac ! number of acars reports rejected + integer nlst_Ac ! number of tamdar reports rejected + $, nlst_Md ! number of mdcrs reports rejected + $, nlst_Ma ! number of manual airep reports rejected + $, nlst_Ar ! number of airep reports rejected + $, nlst_Am ! number of amdar reports rejected +c + integer nlst_wind(5) ! number of winds rejected by aircraft type + $, nlst_temp(5) ! number of temperatures rejected by aircraft type + $, nlst_both(5) ! number of both winds/temps by aircraft type +c +c Instrument types +c ---------------- +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent + $, ktype ! index for instrument type +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io38 ! i/o unit number for reject list rejects +c + integer kwind ! index for wind list + $, ktemp ! index for temperature list +c + integer iob ! index for observations + $, ii ! index for sorted observations + $, mm ! index for tail numbers + $, kk ! index for flight (not used in this way - dak - ??) +c + logical l_print ! switch for printing + $, l_init ! if true, initialize counters + $, l_operational ! true if operational mode used + $, l_ncep ! run QC w/ NCEP preferences if true +c +c Reject list +c ----------- + character*8 c_reg_wind(nwind) ! reject list for wind data + $, c_reg_temp(ntemp) ! reject list for temperature data +c +c Data statements +c Last tail number in each list must be blank +c ------------------------------------------- + +c Per Pat Pauley on 9/27/05, these reject lists are very old and should +c be set to all blanks. +cc data c_reg_wind/'CCA ','EIA ','GCO ','RCH ' +cc $, 'VRG ','WA ',' ',' ' +cc $, ' ',' ',' ',' '/ + data c_reg_wind/' ',' ',' ',' ' + $, ' ',' ',' ',' ' + $, ' ',' ',' ',' '/ +c +cc data c_reg_temp/'RCH ','RZO ','VRG ','AR ' +cc $, 'WA ',' ',' ',' ' +cc $, ' ',' ',' ',' '/ + data c_reg_temp/' ',' ',' ',' ' + $, ' ',' ',' ',' ' + $, ' ',' ',' ',' '/ +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize counters +c ------------------- + if(l_init) then + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 +c + nlst_Ac = 0 + nlst_Md = 0 + nlst_Ma = 0 + nlst_Ar = 0 + nlst_Am = 0 + endif +c + nwind_reg = 0 + ntemp_reg = 0 +c DAK: kk was never initialized - set it to -99 (used in several prints below) + kk = -99 + + nlst_wind = 0 + nlst_temp = 0 + nlst_both = 0 + +c +c Begin loop over obs +c ------------------- + do iob=1,numreps + ii = indx(iob) +c +c Check wind reject list +c ---------------------- + if(.not.l_ncep) then + + kwind = 1 + do while(c_reg_wind(kwind)(1:1).ne.' ') +c +c Tail number found on list +c ------------------------- + if(c_acftreg(ii)(1:8).eq.c_reg_wind(kwind)(1:8)) then +c + c_qc(ii)(10:10) = 'W' +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Aircraft found on NRL wind reject list' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 8002 format(i4,1x,i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c + kwind = nwind +c + else + kwind = kwind + 1 + endif + enddo + else + +c For NCEP runs, if NCEP/PREPBUFR QM of 14 found on wind dir or spd, this report's wind is on +c NCEP's SDMEDIT reject list which is read prior to PREPBUFR processing - set byte 10 to +c 'W" so that this report's wind also fails NRL QC reject data check +c ------------------------------------------------------------------------------------------- + if(nchk_d(ii).eq.14.or.nchk_s(ii).eq.14) then + c_qc(ii)(10:10) = 'W' + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Aircraft found on NCEP wind reject list' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif + endif + endif +c +c Check temperature reject list +c ----------------------------- + if(.not.l_ncep) then + + ktemp = 1 + do while(c_reg_temp(ktemp)(1:1).ne.' ') +c +c Tail number found on list +c ------------------------- + if(c_acftreg(ii)(1:8).eq.c_reg_temp(ktemp)(1:8)) then +c + if(c_qc(ii)(10:10).eq.'W') then + c_qc(ii)(10:10) = 'O' + else + c_qc(ii)(10:10) = 'T' + endif +c + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Aircraft found on NRL temperature reject list' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif +c + ktemp = ntemp +c + else + ktemp = ktemp + 1 + endif + enddo + else + +c For NCEP runs, if NCEP/PREPBUFR QM of 14 found on temperature, this report's temperature is +c on NCEP's SDMEDIT reject list which is read prior to PREPBUFR processing - set byte 10 to +c 'T" so that this report's temperature fails NRL QC reject data check, or if wind for this +c report is also on NCEP's SDMEDIT reject list set byte 10 to 'O' so that this report's +c wind and temperature fail NRL QC reject data check +c ------------------------------------------------------------------------------------------- + if(nchk_t(ii).eq.14) then + if(c_qc(ii)(10:10).eq.'W') then + c_qc(ii)(10:10) = 'O' + else + c_qc(ii)(10:10) = 'T' + endif + l_print = .true. + if(l_print) then + write(io8,*) + write(io8,*) 'Aircraft found on NCEP temperature reject list' + write(io8,8002) kk,ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif + endif + endif +c + enddo +c +c Write out bad reports +c --------------------- + if(.not.l_operational) then + write(io38,*) + write(io38,*) 'Reject list check' + write(io38,*) '-----------------' + write(io38,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c + kbad = 0 +c + do iob = 1,numreps + ii = indx(iob) +c + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then + ktype = 1 +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then + ktype = 2 +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then + ktype = 3 +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then + ktype = 4 +c + elseif(itype(ii).eq.i_man_airep.or. + $ itype(ii).eq.i_man_Yairep) then + ktype = 5 + endif +c + if(ktype.eq.1) then + nrep_Md = nrep_Md + 1 + elseif(ktype.eq.2) then + nrep_Ac = nrep_Ac + 1 + elseif(ktype.eq.3) then + nrep_Am = nrep_Am + 1 + elseif(ktype.eq.4) then + nrep_Ar = nrep_Ar + 1 + elseif(ktype.eq.5) then + nrep_Ma = nrep_Ma + 1 + endif +c + if(c_qc(ii)(10:10).eq.'T'.or. + $ c_qc(ii)(10:10).eq.'W'.or. + $ c_qc(ii)(10:10).eq.'O') then +c + if(.not.l_operational) then + write(io38,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0 + x, 1x,f5.2,4(2(1x,f8.2),1x,i5),1x,'!',a11,'!') + endif +c +c Count number of rejected winds by tail number +c --------------------------------------------- + if(c_qc(ii)(10:10).eq.'W'.or. + $ c_qc(ii)(10:10).eq.'O') then + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + if(ktype.gt.0.and.ktype.le.5) + $ nwind_reg(mm,ktype) = nwind_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif +c +c Count number of rejected temperatures by tail number +c ---------------------------------------------------- + if(c_qc(ii)(10:10).eq.'T'.or. + $ c_qc(ii)(10:10).eq.'O') then + mm = 1 + do while(mm.le.kreg) + if(c_acftreg(ii).eq.creg_reg(mm)) then + if(ktype.gt.0.and.ktype.le.5) + $ ntemp_reg(mm,ktype) = ntemp_reg(mm,ktype) + 1 + mm = kreg + 1 + endif + mm = mm + 1 + enddo + endif +c +c Count by category +c ----------------- + if(c_qc(ii)(10:10).eq.'W') then + nlst_wind(ktype) = nlst_wind(ktype) + 1 + elseif(c_qc(ii)(10:10).eq.'T') then + nlst_temp(ktype) = nlst_temp(ktype) + 1 + elseif(c_qc(ii)(10:10).eq.'O') then + nlst_both(ktype) = nlst_both(ktype) + 1 + endif +c +c Reject reports with inconsistent heights and positions +c ------------------------------------------------------ + if(c_qc(ii)(10:10).eq.'O') then +c + csort(ii)(1:5) = 'badob' +c + kbad(ktype) = kbad(ktype) + 1 +c + if(ktype.eq.1) then + nlst_Md = nlst_Md + 1 + elseif(ktype.eq.2) then + nlst_Ac = nlst_Ac + 1 + elseif(ktype.eq.3) then + nlst_Am = nlst_Am + 1 + elseif(ktype.eq.4) then + nlst_Ar = nlst_Ar + 1 + elseif(ktype.eq.5) then + nlst_Ma = nlst_Ma + 1 + endif + endif +c + endif + enddo +c + if(.not.l_operational) then + write(io38,*) + write(io38,*) ' Number of MDCRS reps rej by lst = ',kbad(1) +ccccdak write(io38,*) ' Number of ACARS reps rej by lst = ',kbad(2) + write(io38,*) ' Number of TAMDAR reps rej by lst = ',kbad(2) + write(io38,*) ' Number of AMDAR reps rej by lst = ',kbad(3) + write(io38,*) ' Number of AIREP reps rej by lst = ',kbad(4) + write(io38,*) ' Number of manAIREP reps rej by lst = ',kbad(5) + endif +c + write(io8,*) + write(io8,*) ' Reports on reject list--rejected' + write(io8,*) ' --------------------------------' + write(io8,*) ' Number of MDCRS reps rej by lst = ',kbad(1) +ccccdak write(io8,*) ' Number of ACARS reps rej by lst = ',kbad(2) + write(io8,*) ' Number of TAMDAR reps rej by lst = ',kbad(2) + write(io8,*) ' Number of AMDAR reps rej by lst = ',kbad(3) + write(io8,*) ' Number of AIREP reps rej by lst = ',kbad(4) + write(io8,*) ' Number of manAIREP reps rej by lst = ',kbad(5) +c +c Output tail number counts +c ------------------------- + write(io8,*) + write(io8,*) ' Tail numbers on reject list for winds' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' ----------------------------------------------' +c + do mm=1,kreg + if( nwind_reg(mm,1)+nwind_reg(mm,2)+nwind_reg(mm,3) + $ +nwind_reg(mm,4)+nwind_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(nwind_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) ' Tail numbers on reject list for temperatures' +ccccdak write(io8,*) ' Tail Num MDCRS ACARS AMDAR AIREP MAN ' + write(io8,*) ' Tail Num MDCRS TAMDAR AMDAR AIREP MAN ' + write(io8,*) ' ----------------------------------------------' +c + do mm=1,kreg + if( ntemp_reg(mm,1)+ntemp_reg(mm,2)+ntemp_reg(mm,3) + $ +ntemp_reg(mm,4)+ntemp_reg(mm,5).gt.0) then + write(io8,'(2x,a8,5(1x,i6))') + $ creg_reg(mm),(ntemp_reg(mm,kk),kk=1,5) + endif + enddo +c + write(io8,*) + write(io8,*) 'Reject list counts' + write(io8,*) '------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ nlst_Md,nlst_Ac,nlst_Am,nlst_Ar,nlst_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Listed winds '',5(1x,i7))') + $ (nlst_wind(ii),ii=1,5) + write(io8,'(''Listed temps '',5(1x,i7))') + $ (nlst_temp(ii),ii=1,5) + write(io8,'(''Listed both '',5(1x,i7))') + $ (nlst_both(ii),ii=1,5) + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + kbadtot = kbad(1) + kbad(2) + kbad(3) + $ + kbad(4) + kbad(5) +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in reject list check' +c + return + end +c +c ################################################################### +c subroutine p2ht_qc +c ################################################################### +c + subroutine p2ht_qc(pressure,height_m,amiss) +c +c Compute height from pressure after checking for gross errors +c + implicit none +c + real pressure ! input pressure (mb) + x, height_m ! output height (m) + x, amiss ! missing value flag +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Check for missing value +c ----------------------- + if(pressure.eq.amiss) then +c write(io8,*) +c write(io8,*) 'Pressure missing' + height_m = amiss +c +c Check for gross errors +c ---------------------- + elseif(pressure.gt.1080..or. + $ pressure.lt.50.) then +c write(io8,*) +c write(io8,*) 'Bad pressure--',pressure + height_m = amiss +c +c Compute height for high pressures +c --------------------------------- + elseif(pressure.ge.226.313) then +c +c Function below is inverse of Dennis Keyser's function +c ----------------------------------------------------- +c height_m = 288.15/.0065 * (1.-(pressure/1013.25)**.190259) +c +c Function below is from Manual of Barometry +c ------------------------------------------ + height_m = 288.15/.0065 * (1.-(pressure/1013.25)**.1902632) +c write(io8,*) +c write(io8,*) 'Computed height',height_m, +c $ ' for high pressure = ',pressure +c +c Compute height for low pressures +c -------------------------------- + elseif(pressure.lt.226.313) then +c +c Function below is inverse of Dennis Keyser's function +c ----------------------------------------------------- + height_m = 11000. - alog(pressure/226.3) / 1.576106E-4 +c write(io8,*) +c write(io8,*) 'Computed height',height_m, +c $ ' for low pressure = ',pressure + endif +c + return + end +c +c ################################################################### +c subroutine ht2fl_qc +c ################################################################### +c + subroutine ht2fl_qc(height_m,height_ft,amiss,ft2m) +c +c Compute height in feet and round to nearest hundred feet +c (This is done to recover original altitudes, which were +c presumably rounded to the nearest hundred feet.) +c + implicit none +c + real height_m ! input height (m) + x, height_ft ! output height (ft) + x, amiss ! missing value flag + x, ft2m ! conversion factor for m to ft +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + if(height_m.ne.amiss) then + height_ft = height_m * ft2m + else + height_ft = amiss + endif +c + return + end +c +c ################################################################### +c function gcirc_qc +c ################################################################### +c +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + function gcirc_qc(rlat1,rlon1,rlat2,rlon2) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c This function computes great circle distances using the Haversine formula. +c Reference: http://www.census.gov/cgi-bin/geo/gisfaq?Q5.1 +c Programmer: P.M. Pauley 2/24/2000 +c + implicit none +c + real pi,deg_rad,radius + parameter (pi = 3.14159274, deg_rad = pi/180.) ! conversion factor + parameter (radius = 6371229.) ! earth's radius in m +c + real gcirc_qc ! great circle distance + real*8 rlat1 ! first latitude (degrees) + $, rlat2 ! second latitude (degrees) + $, rlon1 ! first longitude (degrees) + $, rlon2 ! second longitude (degrees) + real*8 dlon ! difference in longitude / 2 (radians) + $, dlat ! difference in latitude / 2 (radians) + real*8 arg ! argument for the arcsin +c + dlon = (rlon2 - rlon1) * deg_rad * 0.5 + dlat = (rlat2 - rlat1) * deg_rad * 0.5 +c +c What if longitudes are equal? +c ----------------------------- + if(int(rlon1*100.0).eq.int(rlon2*100.0)) then + gcirc_qc = radius * abs(rlat2 - rlat1) * deg_rad +c +c What if latitudes are equal? +c ---------------------------- + elseif(int(rlat1*100.0).eq.int(rlat2*100.0)) then + arg = abs(cos(rlat1*deg_rad) * sin(dlon)) + gcirc_qc = radius * 2.0 * asin(min(1.0,arg)) +c +c What if neither are equal? +c -------------------------- + else + arg = (sin(dlat))**2 + $ + cos(rlat1*deg_rad) * cos(rlat2*deg_rad) * (sin(dlon))**2 + gcirc_qc = radius * 2.0 * asin(min(1.0,sqrt(arg))) + endif +c + return + end +c +c ################################################################### +c subroutine p_ddtg +c ################################################################### +c + subroutine p_ddtg(c_hdg,io8) +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c prints message with the system date and time +c +c by p.pauley +c - Update by D. Keyser 2/7/13: Use GNU standard call +c "date_and_time" instead of calls to "date" and "time" to avoid +c ifort compiler warning on NCEP WCOSS +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c + implicit none +c + integer io8 +c + character*(*) c_hdg ! message + character*8 cdate ! system date + character*10 ctime ! system time + character*5 czone ! time zone + character*3 cmonth(13) ! month + integer idat(8) + data cmonth /'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug', + + 'Sep','Oct','Nov','Dec','???'/ +c + call date_and_time(cdate,ctime,czone,idat) + if(idat(2).lt.1 .or. idat(2).gt.12) idat(2) = 13 +c + write(io8,*) + write(io8,*) c_hdg + write(io8,*) ' System date/time: ',cdate(7:8),'-', + + cmonth(idat(2)),'-',cdate(3:4),' ',ctime(1:2),':',ctime(3:4), + + ':',ctime(5:6) +c + return + end +c +c ################################################################### +c subroutine spike_qc +c ################################################################### +c + subroutine spike_qc(numreps,max_reps,c_acftreg,c_acftid,c_qc + $, alat,alon,pres,ht_ft,t_prcn,ob_t,ob_q,ob_dir,ob_spd + $, xiv_t,xiv_q,xiv_d,xiv_s,idt,itype,ichk_t,ichk_q + $, ichk_d,ichk_s,kbadtot,indx,csort,amiss,imiss,io8 + $, io31,cdtg_an,l_operational,l_init) +c +c Check for spikes in the time distribution of data. +c Erroneous AIREPs from Tinker tend to be clustered by minute. +c + implicit none +c +c Parameter statements +c -------------------- + integer max_min ! number of minutes in one file +cc smb parameter(max_min=361) + parameter(max_min=721) + integer min_offset ! offset used to compute index +cc smb parameter(min_offset=181) + parameter(min_offset=361) +c +c Data arrays +c ----------- + character*10 cdtg_an ! date time group for analysis + integer max_reps ! maximum number of reports + integer numreps ! actual number of reports + integer itype(max_reps) ! type of aircraft data + integer idt(max_reps) ! time in seconds to analysis time + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number + character*9 c_acftid(max_reps) ! aircraft flight number + real*8 alat(max_reps) ! latitude + $, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + $, ht_ft(max_reps) ! height in feet + real t_prcn(max_reps) ! temperature precision + real ob_t(max_reps) ! temperature + $, ob_q(max_reps) ! specific humidity + $, ob_dir(max_reps) ! wind direction + $, ob_spd(max_reps) ! wind speed + real xiv_t(max_reps) ! temperature innovation (ob - bk) + $, xiv_q(max_reps) ! specific humidity innovation (ob - bk) + $, xiv_d(max_reps) ! wind direction innovation (ob - bk) + $, xiv_s(max_reps) ! wind speed innovation (ob - bk) + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + $, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + $, ichk_d(max_reps) ! NRL QC flag for wind direction ob + $, ichk_s(max_reps) ! NRL QC flag for wind speed ob + character*25 csort(max_reps) ! sort variable + character*11 c_qc(max_reps) ! internal qc flags +c +c Pointers +c -------- + integer indx(max_reps) ! pointer index for good reports +c +c Functions +c --------- + character*16 c_insty_ob ! function to convert integer instrument + ! type to character instrument type +c + integer insty_ob_fun ! function to convert character + ! instrument type to integer +c +c Other variables +c --------------- + integer io8 ! i/o unit number for log file + integer io31 ! i/o unit number for rejected dups +c + integer imiss ! integer missing value flag + real amiss ! real missing value flag +c + integer n_minute(6,max_min) ! counter for obs by type and minute + $, n_min_avg(6) ! average number of obs per minute by type + $, n_min_knt(6) ! number of minutes with obs by type + $, i_min ! minute index + $, ii_min ! minute index + $, n_thresh ! threshold used to define a spike + $, idiff_before ! difference w.r.t. previous count + $, idiff_after ! difference w.r.t. following count + real xiv_minute(6,max_min) ! average innovation by type and minute +c + integer iob ! do loop index + $, ibeg ! beginning index + integer ii ! do loop index + $, kk ! do loop index + $, kkbeg ! beginning index + integer kbad(6) ! counter for number of bad reports + $, kbadtot ! counter for total number of bad reports +c +ccccdak integer i_acars ! instrument type for acars + integer i_acars ! instrument type for tamdar +ccccdak $, i_acars_lvl ! instrument type for acars--level flt + $, i_acars_lvl ! instrument type for tamdar--level flt +ccccdak $, i_acars_asc ! instrument type for acars--ascent + $, i_acars_asc ! instrument type for tamdar--ascent +ccccdak $, i_acars_des ! instrument type for acars--descent + $, i_acars_des ! instrument type for tamdar--descent + $, i_mdcrs ! instrument type for mdcrs + $, i_mdcrs_lvl ! instrument type for mdcrs--level flt + $, i_mdcrs_asc ! instrument type for mdcrs--ascent + $, i_mdcrs_des ! instrument type for mdcrs--descent + $, i_man_airep ! instrument type for manual aireps + $, i_man_Yairep ! instrument type for manual aireps (YRXX) + $, i_airep ! instrument type for airep + $, i_airep_lvl ! instrument type for airep--level flt + $, i_airep_asc ! instrument type for airep--ascent + $, i_airep_des ! instrument type for airep--descent + $, i_amdar ! instrument type for amdar + $, i_amdar_lvl ! instrument type for amdar--level flt + $, i_amdar_asc ! instrument type for amdar--ascent + $, i_amdar_des ! instrument type for amdar--descent +c +ccccdak integer nrep_Ac ! number of acars reports considered + integer nrep_Ac ! number of tamdar reports considered + $, nrep_Md ! number of mdcrs reports considered + $, nrep_Ma ! number of manual airep reports considered + $, nrep_Ar ! number of airep reports considered + $, nrep_Am ! number of amdar reports considered +ccccdak $, nbad_Ac ! number of bad acars + $, nbad_Ac ! number of bad tamdar + $, nbad_Md ! number of bad mdcrs + $, nbad_Ma ! number of bad manual aireps + $, nbad_Ar ! number of bad aireps + $, nbad_Am ! number of bad amdar +c +c Switches +c -------- + logical l_print ! print values if true + $, l_operational ! run QC in operational mode if true + $, l_init ! initialize counters if true + $, l_all_types ! spike check all types if true +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c +c Initialize aircraft data types +c ------------------------------ + i_acars = insty_ob_fun('acars') + i_acars_lvl = insty_ob_fun('acars_lvl') + i_acars_asc = insty_ob_fun('acars_asc') + i_acars_des = insty_ob_fun('acars_des') + i_mdcrs = insty_ob_fun('mdcrs') + i_mdcrs_lvl = insty_ob_fun('mdcrs_lvl') + i_mdcrs_asc = insty_ob_fun('mdcrs_asc') + i_mdcrs_des = insty_ob_fun('mdcrs_des') + i_man_airep = insty_ob_fun('man-airep') + i_man_Yairep = insty_ob_fun('man-Yairep') + i_airep = insty_ob_fun('airep') + i_airep_lvl = insty_ob_fun('airep_lvl') + i_airep_asc = insty_ob_fun('airep_asc') + i_airep_des = insty_ob_fun('airep_des') + i_amdar = insty_ob_fun('amdar') + i_amdar_lvl = insty_ob_fun('amdar_lvl') + i_amdar_asc = insty_ob_fun('amdar_asc') + i_amdar_des = insty_ob_fun('amdar_des') +c +c Initialize other arrays +c ----------------------- + n_min_avg = 0 + n_min_knt = 0 + kbad = 0 +c + n_minute = 0 + xiv_minute = 0.0 +c +c Initialize counters +c ------------------- + if(l_init) then + nrep_Ac = 0 + nrep_Md = 0 + nrep_Ma = 0 + nrep_Ar = 0 + nrep_Am = 0 + nbad_Ac = 0 + nbad_Md = 0 + nbad_Ma = 0 + nbad_Ar = 0 + nbad_Am = 0 + endif +c +c Loop over reports +c ----------------- + do iob=1,numreps +c + ii = indx(iob) +c +c Compute minute index +c -------------------- + if(idt(ii).ne.imiss) then + i_min = idt(ii)/60 + min_offset + else + i_min = max_min + endif +c + if(i_min.lt.1.or. + $ i_min.gt.max_min) then + write(io8,*) + write(io8,*) 'i_min out of bounds',ii,iob, + + c_acftreg(ii),c_acftid(ii) + write(io8,*) ' i_min = ',i_min + write(io8,*) ' idt = ',idt(ii) + i_min = max_min + endif +c +c Accumulate distribution of obs and speed innovations +c ---------------------------------------------------- + if(itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des) then +c + nrep_Md = nrep_Md + 1 + n_minute(1,i_min) = n_minute(1,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(1,i_min) = xiv_minute(1,i_min) + abs(xiv_s(ii)) + endif +c + elseif(itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des) then +c + nrep_Ac = nrep_Ac + 1 + n_minute(2,i_min) = n_minute(2,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(2,i_min) = xiv_minute(2,i_min) + abs(xiv_s(ii)) + endif +c + elseif(itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des) then +c + nrep_Am = nrep_Am + 1 + n_minute(3,i_min) = n_minute(3,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(3,i_min) = xiv_minute(3,i_min) + abs(xiv_s(ii)) + endif +c + elseif(itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des) then +c + nrep_Ar = nrep_Ar + 1 + n_minute(4,i_min) = n_minute(4,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(4,i_min) = xiv_minute(4,i_min) + abs(xiv_s(ii)) + endif +c + elseif(itype(ii).eq.i_man_Yairep) then +c + nrep_Ma = nrep_Ma + 1 + n_minute(5,i_min) = n_minute(5,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(5,i_min) = xiv_minute(5,i_min) + abs(xiv_s(ii)) + endif +c + elseif(itype(ii).eq.i_man_airep) then +c + nrep_Ma = nrep_Ma + 1 + n_minute(6,i_min) = n_minute(6,i_min) + 1 + if(xiv_s(ii).ne.amiss) then + xiv_minute(6,i_min) = xiv_minute(6,i_min) + abs(xiv_s(ii)) + endif + endif + enddo +c + l_print = .true. +c + if(l_print) then + write(io8,*) + write(io8,*) 'Distribution of reports by type and minute' + write(io8,*) '------------------------------------------' + write(io8,*) +ccccdak $ 'min MDCRS ACARS AMDAR AIREP YRXX voice innov' + $ 'min MDCRS TAMDAR AMDAR AIREP YRXX voice innov' + write(io8,*) + $ '---- ------ ------ ------ ------ ------ ------ --------' + endif +c + do i_min=1,max_min + if(n_minute(6,i_min).ne.0) then + xiv_minute(6,i_min) = xiv_minute(6,i_min) + $ / float(n_minute(6,i_min)) + else + xiv_minute(6,i_min) = amiss + endif + if(l_print) write(io8,'(i4,6(1x,i6),1x,f8.2)') + $ i_min,(n_minute(kk,i_min),kk=1,6),xiv_minute(6,i_min) +c + do kk=1,6 + if(n_minute(kk,i_min).gt.0) then + n_min_avg(kk) = n_min_avg(kk) + n_minute(kk,i_min) + n_min_knt(kk) = n_min_knt(kk) + 1 + endif + enddo + enddo +c + do kk=1,6 + if(n_min_knt(kk).gt.0) then + n_min_avg(kk) = n_min_avg(kk) / n_min_knt(kk) + else + n_min_avg(kk) = imiss + endif + enddo +c + if(l_print) then + write(io8,*) + $ '--- ------ ------ ------ ------ ------ ------ --------' + write(io8,'(''avg'',6(1x,i6))') (n_min_avg(kk),kk=1,6) + write(io8,*) + $ '--- ------ ------ ------ ------ ------ ------ --------' + endif +c + if(.not.l_operational) then + write(io31,*) + write(io31,*) 'Spike reports' + write(io31,*) '-------------' + write(io31,3001) + 3001 format(' index type tail num flight time lat' + x, ' lon pres height ' + x, 't-prcn temp innov ichk' + x, ' spec hum innov ichk' + x, ' ob_dir innov ichk' + x, ' ob_spd innov ichk' + x, ' qc flag') + endif +c +c Go back and look for spikes (>3x average number per minute) +c ----------------------------------------------------------- + l_print = .true. +c + l_all_types = .false. + if(l_all_types) then + kkbeg = 1 + else + kkbeg = 6 + endif +c + write(io8,*) + write(io8,*) '---------------------------------------------' + write(io8,*) 'Perform spike check on all types--',l_all_types + write(io8,*) '(If not, just spike check voice AIREP data)' + write(io8,*) '---------------------------------------------' +c + do kk=kkbeg,6 +c + ibeg = 1 +c + if(n_min_avg(kk).le.3) then + n_thresh = 9 + else + n_thresh = n_min_avg(kk) * 3 + endif +c + if(kk.eq.4) n_thresh = ifix(float(n_thresh) * 1.5) +c +c Look for spikes +c --------------- + do i_min=1,max_min +c + if(i_min.eq.1) then + idiff_before = n_minute(kk,i_min)-n_minute(kk,i_min+1) + idiff_after = idiff_before + elseif(i_min.eq.max_min) then + idiff_before = n_minute(kk,i_min)-n_minute(kk,i_min-1) !!!!! + idiff_after = idiff_before + else + idiff_before = n_minute(kk,i_min)-n_minute(kk,i_min-1) !!!!! + idiff_after = n_minute(kk,i_min)-n_minute(kk,i_min+1) + endif +c + if(n_minute(kk,i_min).ge.n_thresh.and. + $ idiff_before.gt.n_thresh/2.and. + $ idiff_after.gt.n_thresh/2) then +c + if(kk.eq.1) then + if(l_print) then + write(io8,*) + write(io8,*) 'Spike in MDCRS data at min = ',i_min + write(io8,*) '----------------------------------' + endif + elseif(kk.eq.2) then + if(l_print) then + write(io8,*) +ccccdak write(io8,*) 'Spike in ACARS data at min = ',i_min + write(io8,*) 'Spike in TAMDAR data at min = ',i_min + write(io8,*) '----------------------------------' + endif + elseif(kk.eq.3) then + if(l_print) then + write(io8,*) + write(io8,*) 'Spike in AMDAR data at min = ',i_min + write(io8,*) '----------------------------------' + endif + elseif(kk.eq.4) then + if(l_print) then + write(io8,*) + write(io8,*) 'Spike in autoAIREP data at min = ',i_min + write(io8,*) '----------------------------------' + endif + elseif(kk.eq.5) then + if(l_print) then + write(io8,*) + write(io8,*) 'Spike in YRXX86 data at min = ',i_min + write(io8,*) '----------------------------------' + endif + elseif(kk.eq.6) then + if(l_print) then + write(io8,*) + write(io8,*) 'Spike in voice data at min = ',i_min + write(io8,*) '----------------------------------' + endif + endif +c +c Loop over obs to reject data in spike +c ------------------------------------- + iob = ibeg + do while(iob.le.numreps) + ii = indx(iob) +c + ii_min = idt(ii)/60 + min_offset +c + if(ii_min.lt.1.or. + $ ii_min.gt.max_min) then + write(io8,*) + write(io8,*) 'ii_min out of bounds' + write(io8,*) ' ii_min = ',i_min + write(io8,*) ' idt = ',idt(ii) + ii_min = max_min + endif +c + if(ii_min.eq.i_min) then + if(kk.eq.1.and. + $ (itype(ii).eq.i_mdcrs.or. + $ itype(ii).eq.i_mdcrs_lvl.or. + $ itype(ii).eq.i_mdcrs_asc.or. + $ itype(ii).eq.i_mdcrs_des)) then +c + csort(ii)(1:5) = 'badob' + nbad_Md = nbad_Md + 1 +c + elseif(kk.eq.2.and. + $ (itype(ii).eq.i_acars.or. + $ itype(ii).eq.i_acars_lvl.or. + $ itype(ii).eq.i_acars_asc.or. + $ itype(ii).eq.i_acars_des)) then +c + csort(ii)(1:5) = 'badob' + nbad_Ac = nbad_Ac + 1 +c + elseif(kk.eq.3.and. + $ (itype(ii).eq.i_amdar.or. + $ itype(ii).eq.i_amdar_lvl.or. + $ itype(ii).eq.i_amdar_asc.or. + $ itype(ii).eq.i_amdar_des)) then +c + csort(ii)(1:5) = 'badob' + nbad_Am = nbad_Am + 1 +c + elseif(kk.eq.4.and. + $ (itype(ii).eq.i_airep.or. + $ itype(ii).eq.i_airep_lvl.or. + $ itype(ii).eq.i_airep_asc.or. + $ itype(ii).eq.i_airep_des)) then +c + csort(ii)(1:5) = 'badob' + nbad_Ar = nbad_Ar + 1 +c + elseif(kk.eq.5.and. + $ (itype(ii).eq.i_man_Yairep)) then +c + csort(ii)(1:5) = 'badob' + nbad_Ma = nbad_Ma + 1 +c + elseif(kk.eq.6.and. + $ (itype(ii).eq.i_man_airep)) then +c + csort(ii)(1:5) = 'badob' + nbad_Ma = nbad_Ma + 1 + endif +c + if(csort(ii)(1:5).eq.'badob') then +c + kbad(kk) = kbad(kk) + 1 + c_qc(ii)(2:2) = 'B' +c + if(l_print) then + write(io8,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + endif +c + if(.not.l_operational) then + write(io31,3002) ii,c_insty_ob(itype(ii)) + x, c_acftreg(ii),c_acftid(ii) + x, idt(ii),alat(ii),alon(ii) + x, pres(ii),ht_ft(ii) + x, t_prcn(ii),ob_t(ii),xiv_t(ii),ichk_t(ii) + x, ob_q(ii),xiv_q(ii),ichk_q(ii) + x, ob_dir(ii),xiv_d(ii),ichk_d(ii) + x, ob_spd(ii),xiv_s(ii),ichk_s(ii) + x, c_qc(ii) + 3002 format(i6,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x + x, f8.1,1x,f7.0,1x,f5.2,4(2(1x,f8.2),1x,i5),1x + x, '!',a11,'!') + endif + endif +c + elseif(ii_min.gt.i_min) then + ibeg = iob + iob = numreps + 1 + endif + iob = iob + 1 + enddo + endif + enddo + enddo +c + kbad(5) = kbad(5) + kbad(6) +c +c Output statistics +c ----------------- + if(.not.l_operational) then + write(io31,*) + write(io31,*)' Number of spike MDCRS reps rejected = ' +cc smb $, kbad(1) + $, nbad_Md +ccccdak write(io31,*)' Number of spike ACARS reps rejected = ' + write(io31,*)' Number of spike TAMDAR reps rejected = ' +cc smb $, kbad(2) + $, nbad_Ac + write(io31,*)' Number of spike AMDAR reps rejected = ' +cc smb $, kbad(3) + $, nbad_Am + write(io31,*)' Number of spike AIREP reps rejected = ' +cc smb $, kbad(4) + $, nbad_Ar + write(io31,*)' Number of spike manAIREP reps rejected = ' +cc smb $, kbad(5) + $, nbad_Ma + endif +c + write(io8,*) + write(io8,*) ' Spike reports--rejected' + write(io8,*) ' -----------------------' + write(io8,*)' Number of spike MDCRS reps rejected = ' +cc smb $, kbad(1) + $, nbad_Md +ccccdak write(io8,*)' Number of spike ACARS reps rejected = ' + write(io8,*)' Number of spike TAMDAR reps rejected = ' +cc smb $, kbad(2) + $, nbad_Ac + write(io8,*)' Number of spike AMDAR reps rejected = ' +cc smb $, kbad(3) + $, nbad_Am + write(io8,*)' Number of spike AIREP reps rejected = ' +cc smb $, kbad(4) + $, nbad_Ar + write(io8,*)' Number of spike manAIREP reps rejected = ' +cc smb $, kbad(5) + $, nbad_Ma +c +c Output detailed stats +c --------------------- + write(*,*) + write(*,*) 'Spike check data counts--',cdtg_an + write(*,*) '-----------------------------------' + write(*,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(*,'('' Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(*,'('' Total rejected '',5(1x,i7))') + $ nbad_Md,nbad_Ac,nbad_Am,nbad_Ar,nbad_Ma + write(*,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c + write(io8,*) + write(io8,*) 'Spike check data counts' + write(io8,*) '-----------------------' + write(io8,'(1x,a55)') +ccccdak $ 'Type of check MDCRS ACARS AMDAR AIREP man' + $ 'Type of check MDCRS TAMDAR AMDAR AIREP man' + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' + write(io8,'(''Num considered '',5(1x,i7))') + $ nrep_Md,nrep_Ac,nrep_Am,nrep_Ar,nrep_Ma + write(io8,'(''Total rejected '',5(1x,i7))') + $ nbad_Md,nbad_Ac,nbad_Am,nbad_Ar,nbad_Ma + write(io8,'(1x,a55)') + $ '--------------- ------- ------- ------- ------- -------' +c +cc smb kbadtot = kbad(1) + kbad(2) + kbad(3) +cc smb $ + kbad(4) + kbad(5) + + kbadtot = nbad_Md + nbad_Ac + nbad_Am + nbad_Ar + nbad_Ma + +c + write(io8,*) + write(io8,*) numreps,' good reports processed' + write(io8,*) kbadtot,' reports failed qc in spike check' +c + return + end + +c ################################################################### +c function c_insty_ob +c ################################################################### +c + character*16 function c_insty_ob(num) +c +c Return character instrument type for number code +c + parameter (mx_nm=42) +c + integer nc(mx_nm) + character*16 c_label(mx_nm),c_rec(mx_nm) +c + data(nc(n),c_rec(n), c_label(n),n=1,mx_nm) + x / 1, 'SMX', 'sfc land' ! Land observations (coastal, manual, automated) + x , 10, 'SHX', 'sfc ship' ! Surface obs from ships, fixed and mobile, drifting buoys + x , 25, 'XRX', 'man-airep' ! Manual AIREP (header XRXX) + x , 26, 'XRX', 'man-Yairep' ! Manual AIREP (header YRXX) + x , 30, 'S0A', 'airep' ! Aircraft data (aireps) + x , 131, 'S0A', 'airep_asc' ! AIREP ascending profile + x , 132, 'S0A', 'airep_des' ! AIREP descending profile + x , 33, 'S0A', 'airep_lvl' ! AIREP level flight + x , 34, 'AIR', 'airep_msg' ! Aircraft data (AIREP)--missing category + x , 35, 'AMD', 'amdar' ! Automated aircraft data (AMDAR) + x , 136, 'AMD', 'amdar_asc' ! AMDAR ascending profile + x , 137, 'AMD', 'amdar_des' ! AMDAR descending profile + x , 38, 'AMD', 'amdar_lvl' ! AMDAR level flight +ccccdak x , 40, 'ACR', 'acars' ! Automated aircraft (ACARS) prior to acars_qc + x , 40, 'ACR', 'acars' ! Automated aircraft (TAMDAR) prior to acars_qc +ccccdak x , 141, 'ACR', 'acars_asc' ! ACARS ascending profile + x , 141, 'ACR', 'acars_asc' ! TAMDAR ascending profile +ccccdak x , 142, 'ACR', 'acars_des' ! ACARS descending profile + x , 142, 'ACR', 'acars_des' ! TAMDAR descending profile +ccccdak x , 43, 'ACR', 'acars_lvl' ! ACARS level flight + x , 43, 'ACR', 'acars_lvl' ! TAMDAR level flight + x , 45, 'MCR', 'mdcrs' ! Automated aircraft (MDCRS) prior to acars_qc + x , 146, 'MCR', 'mdcrs_asc' ! MDCRS ascending profile + x , 147, 'MCR', 'mdcrs_des' ! MDCRS descending profile + x , 48, 'MCR', 'mdcrs_lvl' ! MDCRS level flight + x , 50, 'TSX', 'cld wnds1' ! Satellite-derived wind observations + x , 51, 'TWX', 'cld wnds2' ! Satellite-derived wind observations + x , 54, 'GMT1', 'METEO-7' ! SSEC Satellite-derived wind observations + x , 55, 'GOSW', 'GOES-10' ! SSEC Satellite-derived wind observations + x , 56, 'GOSE', 'GOES-8' ! SSEC Satellite-derived wind observations + x , 57, 'GMSN', 'GMS_NH' ! SSEC Satellite-derived wind observations + x , 58, 'GMSS', 'GMS_SH' ! SSEC Satellite-derived wind observations + x , 60, 'ssmi_', 'ssmi ff1' ! SSM/I wind speed, air-sea EDR + x , 61, 'SS5', 'ssmi ff2' ! SSM/I wind speed, air-sea EDR + x , 70, 'scat_', 'scat winds' ! scatterometer ocean surface winds + x , 90, 'PAB' , 'Aus synth' ! Australian sea-level pres synthetic + x , 101, 'S0X', 'raob' ! Rawinsondes (land,ship,drop,mobil) + x , 110, 'PIB', 'pibal' ! Pilot balloons (land,ship,mobil) + x , 120, 'analytic' , 'analytic' ! synthetic obs derived from analytic conditions + x , 140, 'S0F', 'tovs T' ! tovs retrieved by nesdis + x , 190, 'GTO' , 'TC synth' ! tropical cyclone synthetic observations + x , 210, 'atovs_', 'atovs bT' ! ATOVS brightness temp + x , 220, 'rtovs_', 'rtovs bT' ! RTOVS brightness temp + x , 230, 'ssmt_', 'ssmt1 bT' ! SSM/T1 brightness temp + x , 240, 'ssmt2_', 'ssmt2 bT' ! SSM/T2 brightness temp + x , 250, 'ssmi_', 'ssmi TPPW' / ! ssm/i total precipitable water +c + do n=1,mx_nm + if(num.eq.nc(n))then + c_insty_ob = c_label(n) + return + endif + end do +c +c not found +c + c_insty_ob = 'typ not found' +c + return + end + +c ################################################################### +c function insty_ob_fun +c ################################################################### +c + integer function insty_ob_fun(c_record) +c +c Return number code for character instrument type +c + parameter (mx_nm=42) +c + character*(*) c_record + integer nc(mx_nm) + character*16 c_label(mx_nm),c_rec(mx_nm) +c + data(nc(n),c_rec(n), c_label(n),n=1,mx_nm) + x / 1, 'SMX', 'sfc land' ! Land observations (coastal, manual, automated) + x , 10, 'SHX', 'sfc ship' ! Surface obs from ships, fixed and mobile, drifting buoys + x , 25, 'XRX', 'man-airep' ! Manual AIREP (header XRXX) + x , 26, 'XRX', 'man-Yairep' ! Manual AIREP (header YRXX) + x , 30, 'S0A', 'airep' ! Aircraft data (aireps) + x , 131, 'S0A', 'airep_asc' ! AIREP ascending profile + x , 132, 'S0A', 'airep_des' ! AIREP descending profile + x , 33, 'S0A', 'airep_lvl' ! AIREP level flight + x , 34, 'AIR', 'airep_msg' ! Aircraft data (AIREP)--missing category + x , 35, 'AMD', 'amdar' ! Automated aircraft data (AMDAR) + x , 136, 'AMD', 'amdar_asc' ! AMDAR ascending profile + x , 137, 'AMD', 'amdar_des' ! AMDAR descending profile + x , 38, 'AMD', 'amdar_lvl' ! AMDAR level flight +ccccdak x , 40, 'ACR', 'acars' ! Automated aircraft (ACARS) prior to acars_qc + x , 40, 'ACR', 'acars' ! Automated aircraft (TAMDAR) prior to acars_qc +ccccdak x , 141, 'ACR', 'acars_asc' ! ACARS ascending profile + x , 141, 'ACR', 'acars_asc' ! TAMDAR ascending profile +ccccdak x , 142, 'ACR', 'acars_des' ! ACARS descending profile + x , 142, 'ACR', 'acars_des' ! TAMDAR descending profile +ccccdak x , 43, 'ACR', 'acars_lvl' ! ACARS level flight + x , 43, 'ACR', 'acars_lvl' ! TAMDAR level flight + x , 45, 'MCR', 'mdcrs' ! Automated aircraft (MDCRS) prior to acars_qc + x , 146, 'MCR', 'mdcrs_asc' ! MDCRS ascending profile + x , 147, 'MCR', 'mdcrs_des' ! MDCRS descending profile + x , 48, 'MCR', 'mdcrs_lvl' ! MDCRS level flight + x , 50, 'TSX', 'cld wnds1' ! Satellite-derived wind observations + x , 51, 'TWX', 'cld wnds2' ! Satellite-derived wind observations + x , 54, 'GMT1', 'METEO-7' ! SSEC Satellite-derived wind observations + x , 55, 'GOSW', 'GOES-10' ! SSEC Satellite-derived wind observations + x , 56, 'GOSE', 'GOES-8' ! SSEC Satellite-derived wind observations + x , 57, 'GMSN', 'GMS_NH' ! SSEC Satellite-derived wind observations + x , 58, 'GMSS', 'GMS_SH' ! SSEC Satellite-derived wind observations + x , 60, 'ssmi_', 'ssmi ff1' ! SSM/I wind speed, air-sea EDR + x , 61, 'SS5', 'ssmi ff2' ! SSM/I wind speed, air-sea EDR + x , 70, 'scat_', 'scat winds' ! scatterometer ocean surface winds + x , 90, 'PAB' , 'Aus synth' ! Australian sea-level pres synthetic + x , 101, 'S0X', 'raob' ! Rawinsondes (land,ship,drop,mobil) + x , 110, 'PIB', 'pibal' ! Pilot balloons (land,ship,mobil) + x , 120, 'analytic' , 'analytic' ! synthetic obs derived from analytic conditions + x , 140, 'S0F', 'tovs T' ! tovs retrieved by nesdis + x , 190, 'GTO' , 'TC synth' ! tropical cyclone synthetic observations + x , 210, 'atovs_', 'atovs bT' ! ATOVS brightness temp + x , 220, 'rtovs_', 'rtovs bT' ! RTOVS brightness temp + x , 230, 'ssmt_', 'ssmt1 bT' ! SSM/T1 brightness temp + x , 240, 'ssmt2_', 'ssmt2 bT' ! SSM/T2 brightness temp + x , 250, 'ssmi_', 'ssmi TPPW' / ! ssm/i total precipitable water +C + do n=1,mx_nm + if(c_record.eq.c_label(n))then + insty_ob_fun=nc(n) + return + endif + end do +c +c not found +c + insty_ob_fun=0 + write(*,*) + write(*,*) ' *****VVVVV*****' + write(*,*) ' WARNING: insty_ob_fun could not find c_record=', + + c_record + write(*,*) ' *****^^^^^*****' + write(*,*) +c + return + end +c +c ################################################################### +c subroutine slen +c ################################################################### +c + subroutine slen (cstr,lenc) +c +c#include +c rcs keywords: $RCSfile: slen.F,v $ +c $Revision: 1.1.1.1 $ $Date: 1996/10/01 18:10:37 $ +c + implicit none +c + integer maxlen ! dimension of string cstr + $, lenc ! output length of contents of cstr + $, i ! index +c + character*(*) cstr ! input string + character*1 tab ! contains tab character + $, carriage_return ! contains carriage return character + $, linefeed ! contains linefeed character +c +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # +c + tab = char(9) + linefeed = char(10) + carriage_return = char(13) +c +c Get the size of character string +c -------------------------------- + maxlen = len(cstr) +c + lenc = 0 + do 10 i=1,maxlen + if ( (cstr(i:i).eq.' ') .or. (cstr(i:i).eq.tab) .or. + & (cstr(i:i).eq.carriage_return) .or. (cstr(i:i).eq.linefeed) ) + & return +c + lenc = i +c + 10 continue +c + return + end +c diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/indexc40.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/indexc40.f new file mode 100644 index 00000000..a0aed083 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/indexc40.f @@ -0,0 +1,103 @@ +c$$$ subprogram documentation block +c +c subprogram: indexc40 +c Programmer: D. Keyser Org: NP22 Date: 2012-05-08 +c +c Abstract: Uses efficient sort algorithm to produce index sort list for a 40-character +c array. Does not rearrange the file. +c +c Program History Log: +c 1993-06-05 R Kistler -- FORTRAN version of C-program +c 1993-07-15 P. Julian -- Modified to sort 12-character array +c 1994-08-25 D. Keyser -- Modified to sort 16-character array +c 1995-05-30 D. Keyser -- Tests for < 2 elements in sort list, if so returns without +c sorting (but fills indx array) +c ????-??-?? P. M. Pauley (NRL) -- Size of carrin changed to character*24 +c 2010-11-15 S. Bender -- Size of carrin changed to character*40 +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c +c Usage: call indexc40(n,carrin,indx) +c +c Input argument list: +c n - Size of array to be sorted +c carrin - 40-character array to be sorted +c +c Output argument list: +c indx - Array of pointers giving sort order of carrin in ascending order {e.g., +c carrin(indx(i)) is sorted in ascending order for original i = 1, ... ,n} +c +c Remarks: Called by main program. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine indexc40(n,carrin,indx) + + implicit none + + integer n ! dimension of array to be sorted + +, j ! do loop index, sort variable + +, i ! sort variable + +, l ! variable used to decide if sort is finished + +, ir ! " " + +, indx(n) ! pointer array + +, indxt ! pointer used in sort + + character*40 carrin(n) ! input array to be sorted + +, cc ! character variable used in sort + +c # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # + + do j = 1,n + indx(j) = j + enddo + +c Must be > 1 element in sort list, else return +c --------------------------------------------- + + 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 + endif + endif + + 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 + endif + if(cc.lt.carrin(indx(j))) then + indx(i) = indx(j) + i = j + j = j + i + else + j = ir + 1 + endif + endif + + if(j.le.ir) go to 30 + indx(i) = indxt + go to 33 + + end + diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/input_acqc.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/input_acqc.f new file mode 100644 index 00000000..6b5100f5 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/input_acqc.f @@ -0,0 +1,1952 @@ +c$$$ Subprogram Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Subprogram: input_acqc +c Programmer: D. Keyser Org: NP22 Date: 2016-12-09 +c +c Abstract: Reads aircraft reports (mass and wind pieces) out of the input PREPBUFR file (in +c message types 'AIRCAR' and 'AIRCFT') and stores merged (mass and wind) data into memory +c (e.g., alat, alon, ht_ft, idt, ob_*, xiv_* and ichk_* arrays) for later use by the NRL QC +c kernel (acftobs_qc). Some NCEP data values are translated to NRL standards (e.g., u/v to +c dir/spd, quality information, and report type). Also stores merged input "event" +c information into memory (e.g., nevents, *ob_ev, *qm_ev, *pc_ev, *rc_ev, *pg and *pp +c arrays) for use when later constructing merged (mass and wind) profile reports in +c PREPBUFR-like file (if requested, i.e., l_doprofiles=T). +c +c Program History Log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c 2012-11-20 J. Woollen -- Initial port to WCOSS +c 2013-02-07 D. Keyser -- Will now store pressure and pressure-altitude only from the first +c (mass) piece of a mass/wind piece pair rather than re-store it +c again from the second (wind) piece - even though they "should" be +c the same in both pieces (see % below for exception), there can be +c rare cases when at least pressure-altitude is missing in the wind +c piece (due to a bug in PREPDATA where unreasonably-high winds are +c set to missing and an "empty" wind piece is still encoded into +c PREPBUFR, this can lead to floating point exception errors in the +c construction of profiles {note that pressure & pressure-altitude +c from reports with only a wind piece will be read since it is the +c first (only) piece of the report}: % - there can be cases where +c the pressure qualty mark (PQM) is different in the mass piece vs. +c the wind piece (e.g., when it is set to 10 for reports near +c tropical systems by SYNDATA), so it is better to pick up PQM from +c the mass report for use in the merged mass/wind profiles, an added +c benefit of this chg; if the total number of merged (mass + wind +c piece) aircraft-type reports read in from PREPBUFR file is at +c least 90% of maximum allowed, print diagnostic warning message +c to production joblog file prior to returning from this subroutine +c 2013-02-07 D. Keyser -- Final changes to run on WCOSS: use formatted print statements +c where previously unformatted print was > 80 characters +c 2014-09-03 D. Keyser -- If no aircraft reports of any type are read from input PREPBUFR +c file, no further processing is performed other than the usual +c stdout print summary at the end. +c 2013-10-07 Sienkiewicz -- add initialization for 'nmswd' (for gfortran compile) +c 2016-12-09 D. Keyser -- +c - Nomenclature change: replaced "MDCRS/ACARS" with just "MDCRS". +c - New LATAM AMDARs contain an encrypted flight number (in addition to a tail +c number, all other AMDARs have only a tail number which is copied into +c flight number). Read this in and use in QC processing. +c BENEFIT: Improves track-checking and other QC for LATAM AMDARs. +c - Latitude/longitdue arrays "alat" and "alon" passed out of this subroutine +c now double precision. XOB and YOB in PREPBUFR file now scaled to 10**5 +c (was 10**2) to handle new v7 AMDAR and MDCRS reports which have this +c higher precision. +c BENEFIT: Retains exact precison here. Improves QC processing. +c - Note: QC here can be improved further by changing logic to account +c for the increased precision. This needs to be investigated. +c For now, location in code where this seems possible is noted by +c the spanning comments: +c ! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c ! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c +c Usage: call input_acqc(inlun,max_reps,mxnmev,bmiss,imiss,amiss, +c m2ft,mxlv,nrpts4QC,cdtg_an,alat,alon,ht_ft, +c idt,c_dtg,itype,phase,t_prcn,c_acftreg, +c c_acftid,pres,ob_t,ob_q,ob_dir,ob_spd, +c ichk_t,ichk_q,ichk_d,ichk_s, +c nchk_t,nchk_q,nchk_d,nchk_s, +c xiv_t,xiv_q,xiv_d,xiv_s, +c l_minus9C,nevents,hdr,acid,rct,drinfo, +c acft_seq,turb1seq,turb2seq,turb3seq, +c prewxseq,cloudseq,afic_seq,mstq,cat,rolf, +c nnestreps,sqn,procn, +c pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, +c zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, +c tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, +c qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, +c uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev,wbg,wpp, +c ddo_ev,ffo_ev,dfq_ev,dfp_ev,dfr_ev, +c l_allev_pf) +c +c Input argument list: +c inlun - Unit number for the input pre-PREPACQC PREPBUFR file containing all data +c (separate mass/wind pieces) +c max_reps - Maximum number of reports accepted by acftobs_qc +c mxnmev - Maximum number of events allowed, per variable type +c bmiss - BUFRLIB missing value (set in main program) +c imiss - NRL integer missing value flag (99999) +c amiss - NRL real missing value flag (-9999.) +c m2ft - NRL conversion factor to convert meters to feet +c mxlv - Maximum number of levels allowed in a report profile +c l_allev_pf - Logical whether to process latest (likely NRLACQC) event plus all prior +c events (TRUE) or only latest event (FALSE) into profiles PREPBUFR-like +c file (if TRUE means read in these pre-existing events here) +c +c Output argument list: +c nrpts4QC - Total number of input merged (mass + wind piece) aircraft-type reports +c read in from PREPBUFR file +c cdtg_an - Date/analysis time (YYYYMMDDCC) +c alat - Array of latitudes for the "merged" reports +c alon - Array of longitudes for the "merged" reports +c ht_ft - Array of altitudes for the "merged" reports +c idt - Array of ob-cycle times for the "merged" reports (in seconds) +c itype - Array of aircraft type for the "merged" reports +c phase - Array of phase of flight for aircraft for the "merged" reports +c t_prcn - Array of temperature precision for the "merged" reports +c c_acftreg - Array of aircraft tail numbers for the "merged" reports to later be used +c in NRL QC processing +c c_acftid - Array of aircraft flight numbers for the "merged" reports to later be +c used in NRL QC processing +c pres - Array of pressure for the "merged" reports +c ob_t - Array of aircraft temperature for the "merged" reports +c ob_q - Array of aircraft moisture (specific humidity) for the "merged" reports +c ob_dir - Array of aircraft wind direction for the "merged" reports +c ob_spd - Array of aircraft wind speed for the "merged" reports +c ichk_t - NRL QC flag for temperature ob +c ichk_q - NRL QC flag for moisture ob +c ichk_d - NRL QC flag for wind direction ob +c ichk_s - NRL QC flag for wind speed ob +c nchk_t - NCEP PREPBUFR QC flag for temperature ob +c nchk_q - NCEP PREPBUFR QC flag for moisture ob +c nchk_d - NCEP PREPBUFR QC flag for wind direction ob +c nchk_s - NCEP PREPBUFR QC flag for wind speed ob +c xiv_t - Array of aircraft temperature innovations (ob-bg) for "merged" reports +c xiv_q - Array of aircraft moisture innovations (ob-bg) for "merged" reports +c xiv_d - Array of aircraft wind direction innovations (ob-bg) for "merged" reports +c xiv_s - Array of aircraft wind speed innovations (ob-bg) for "merged" reports +c l_minus9C - Array of logicals denoting aircraft with -9C temperature for "merged" +c reports +c nevents - Array tracking number of events for all variables (p, q, t, z, u/v, +c dir/spd) for "merged" reports +c hdr - Array of aircraft report headers info for "merged" reports +c acid - Array of aircraft report flight numbers for "merged" MDCRS and AMDAR +c (LATAM only) reports (read in from 'ACID' in input PREPBUFR file) +c rct - Array of aircraft report receipt times for "merged" reports +c drinfo - Array of aircraft "drift" info (just XOB, YOB, DHR right now) for +c "merged" reports +c acft_seq - Array of temperature precision and phase of flight for aircraft for the +c "merged" reports +c turb1seq - Array of type 1 aircraft turbulence for the "merged" reports +c turb2seq - Array of type 2 aircraft turbulence for the "merged" reports +c turb3seq - Array of type 3 aircraft turbulence for the "merged" reports +c prewxseq - Array of present weather info for the "merged" reports +c cloudseq - Array of cloud info for the "merged" reports +c afic_seq - Array of aircraft icing info for the "merged" reports +c mstq - Array of aircraft moisture flags for the "merged" reports +c cat - Array of PREPBUFR level category values ("CAT") for the "merged" reports +c rolf - Aircraft of aircraft roll angle flags for the "merged" reports +c nnestreps - Array containing the Number of "nested replications" for turbulence, +c present weather, cloud and icing for the "merged" reports +c sqn - Array containing the original PREPBUFR mass and wind piece sequence +c numbers ("SQN") for the "merged" reports +c procn - Array containing the original PREPBUFR mass and wind piece poe process +c numbers ("PROCN") for the "merged" reports +c pob_ev - Array of pressure event obs for "merged" reports +c pqm_ev - Array of pressure event quality marks for "merged" reports +c ppc_ev - Array of pressure event program codes for "merged" reports +c prc_ev - Array of pressure event reason codes for "merged" reports +c pbg - Array of pressure background data for "merged" reports +c ppp - Array of pressure post-processing info for "merged" reports +c zob_ev - Array of altitude event obs for "merged" reports +c zqm_ev - Array of altitude event quality marks for "merged" reports +c zpc_ev - Array of altitude event program codes for "merged" reports +c zrc_ev - Array of altitude event reason codes for "merged" reports +c zbg - Array of altitude background data for "merged" reports +c zpp - Array of altitude post-processing info for "merged" reports +c tob_ev - Array of temperature event obs for "merged" reports +c tqm_ev - Array of temperature event quality marks for "merged" reports +c tpc_ev - Array of temperature event program codes for "merged" reports +c trc_ev - Array of temperature event reason codes for "merged" reports +c tbg - Array of temperature background data "merged" reports +c tpp - Array of temperature post-processing info for "merged" reports +c qob_ev - Array of moisture event obs for "merged" reports +c qqm_ev - Array of moisture event quality marks for "merged" reports +c qpc_ev - Array of moisture event program codes for "merged" reports +c qrc_ev - Array of moisture event reason codes for "merged" reports +c qbg - Array of moisture background data for "merged" reports +c qpp - Array of moisture post-processing info for "merged" reports +c uob_ev - Array of wind/u-comp event obs for "merged" reports +c vob_ev - Array of wind/v-comp event obs for "merged" reports +c wqm_ev - Array of wind event quality marks for "merged" reports +c wpc_ev - Array of wind event program codes for "merged" reports +c wrc_ev - Array of wind event reason codes for "merged" reports +c wbg - Array of wind background data for "merged" reports +c wpp - Array of wind post-processing info for "merged" reports +c ddo_ev - Array of wind direction event obs for "merged" reports +c ffo_ev - Array of wind speed event obs for "merged" reports +c dfq_ev - Array of wind direction/speed quality marks for "merged" reports +c dfp_ev - Array of wind direction/speed program codes for "merged" reports +c dfr_ev - Array of wind direction/speed reason codes for "merged" reports +c +c Input files: +c Unit inlun - PREPBUFR file containing all obs, prior to any processing by this program +c +c Output files: +c Unit 06 - Standard output print +c +c Subprograms called: +c Unique: none +c Library: +c SYSTEM: SYSTEM +c W3NCO: ERREXIT W3TAGE W3MOVDAT +c W3EMC: W3FC05 +c BUFRLIB: IREADMG IREADSB UFBINT UFBSEQ UFBEVN READNS IBFMS +c +c Exit States: +c Cond = 0 - successful run +c 23 - unexpected return code from readns; problems reading BUFR file +c +c Remarks: Called by main program. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine input_acqc(inlun,max_reps,mxnmev,bmiss,imiss,amiss, + + m2ft,mxlv,nrpts4QC,cdtg_an,alat,alon,ht_ft, + + idt,c_dtg,itype,phase,t_prcn,c_acftreg, + + c_acftid,pres,ob_t,ob_q,ob_dir,ob_spd, + + ichk_t,ichk_q,ichk_d,ichk_s, + + nchk_t,nchk_q,nchk_d,nchk_s, + + xiv_t,xiv_q,xiv_d,xiv_s, + + l_minus9C,nevents,hdr,acid,rct,drinfo, + + acft_seq,turb1seq,turb2seq,turb3seq, + + prewxseq,cloudseq,afic_seq,mstq,cat,rolf, + + nnestreps,sqn,procn, + + pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, + + zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, + + tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, + + qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev,wbg,wpp, + + ddo_ev,ffo_ev,dfq_ev,dfp_ev,dfr_ev, + + l_allev_pf) + + implicit none + +c ------------------------------ +c Parameter statements/constants +c ------------------------------ + integer inlun ! input unit number (for pre-prepacqc PREPBUFR file + ! containing all obs) + integer max_reps ! maximum number of input merged (mass + wind piece) + ! aircraft-type reports allowed +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c replace above with this in event of future switch to dynamic memory allocation + +calloc integer max_reps ! original number of input merged (mass + wind piece) +calloc ! aircraft-type reports (obtained from first pass through +calloc ! input PREPBUFR file to get total for array +calloc ! allocation should = nrpts4QC) +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + character*6 cmax_reps ! character form of max_reps + integer imiss ! NRL integer missing value flag + real amiss ! NRL real missing value flag + real*8 bmiss ! BUFRLIB missing value (set in main program) + real m2ft ! NRL conversion factor to convert m to ft + integer mxlv ! maximum number of report levels allowed in aircraft + ! profiles + +c ---------------------- +c Declaration statements +c ---------------------- + +c Variables for BUFRLIB interface +c ------------------------------- + character*8 mesgtype ! BUFR message type (e.g., 'AIRCFT ') + integer mesgdate ! date time from BUFR message (YYYYMMDDHH) + +c Logicals controlling processing (read in from namelist in main program) +c ----------------------------------------------------------------------- + logical l_allev_pf ! T=process latest (likely NRLACQC) events plus all prior + ! events into profiles PREPBUFR-like file (here means must + ! read in these pre-existing events) + ! **CAUTION: More complete option, but will make code take + ! longer to run!!! + ! F=process ONLY latest (likely NRLACQC) events into profiles + ! PREPBUFR-like file (here means read in only latest events + ! which will likely be written over later by NRLACQC events) + ! + ! Note 1: Hardwired to F if l_doprofiles=F + ! Note 2: All pre-existing events plus latest (likely NRLACQC) + ! events are always encoded into full PREPBUFR file) + +c Indices/counters +c ---------------- + integer i,j ! loop indeces + +, invi ! "inverse" of the i counter + +c for BUFR messages: + integer nACmsg_tot ! number of acft-type BUFR messages in input PREPBUFR file + +c for BUFR subsets/reports: + integer nrptsaircar ! number of AIRCAR BUFR subsets read from PREPBUFR file + ! (should = nmswd(2,1) + nmswd(2,2)) + +, nrptsaircft ! number of AIRCFT BUFR subsets read from PREPBUFR file + ! (should = nmswd(1,1) + nmswd(1,2)) + +, nmswd(2,2) ! number of ((AIRCFT,AIRCAR),(mass,wind)) BUFR subsets + ! read from PREPBUFR file + +, nrpts_rd ! total number of aircraft-type BUFR subsets read from + ! PREPBUFR file (should = + ! nmswd(1,1) + nmswd(1,2) + nmswd(2,1) + nmswd(2,2)) + +, nrpts4QC ! total number of input merged (mass + wind piece) + ! aircraft-type reports read in from PREPBUFR file + ! (should = numpairs + numorph) + + integer numpairs ! number of input merged (mass + wind piece) aircraft- + ! type reports read in from PREPBUFR file where there + ! is BOTH mass and wind data + ! (should = numAIRCFTpairs + numAIRCARpairs) + +, numorph ! number of input merged (mass + wind piece) aircraft- + ! type reports read in from PREPBUFR file where there + ! is either ONLY mass data or only wind data (deemed + ! "orphans", of course in reality there is no merging + ! here) (should = numAIRCFTorph + numAIRCARorph) + +, numAIRCFTpairs ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! where there is BOTH mass and wind data + +, numAIRCARpairs ! number of input merged (mass + wind piece) reports + ! read in from AIRCAR BUFR messages in PREPBUFR file + ! where there is BOTH mass and wind data + +, numAIRCFTorph ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! where there is either ONLY mass data or only wind + ! data (deemed "orphans", of course in reality there + ! is no merging here) + +, numAIRCARorph ! number of input merged (mass + wind piece) reports + ! read in from AIRCAR BUFR messages in PREPBUFR file + ! where there is either ONLY mass data or only wind + ! data (deemed "orphans", of course in reality there + ! is no merging here) + + integer nPIREP ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be "PIREP" reports + +, nAUTOAIREP ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be automated AIREP reports + +, nMANAIREP ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be Manual AIREP (all "voice") + ! reports + +, nAMDAR ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be AMDAR reports (excluding + ! Canadian AMDAR) + +, nAMDARcan ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be Canadian AMDAR reports + +, nMDCRS ! number of input merged (mass + wind piece) reports + ! read in from AIRCAR BUFR messages in PREPBUFR file + ! (all are MDCRS reports) + +, nTAMDAR ! number of input merged (mass + wind piece) reports + ! read in from AIRCFT BUFR messages in PREPBUFR file + ! that are deemed to be TAMDAR reports + +c Functions +c --------- + integer ireadmg ! BUFRLIB - for reading messages + +, ireadsb ! BUFRLIB - for reading subsets + +, ibfms ! BUFRLIB - for testing for missing + +c Observation arrays +c ------------------ + character*10 cdtg_an ! date-time group for analysis (YYYYMMDDCC) + character*14 c_dtg(max_reps) ! full date-time group (yyyymmddhhmmss) + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number (used in NRL + ! QC processing) + character*9 c_acftid(max_reps) ! aircraft flight number (used in NRL QC processing) + real*8 alat(max_reps) ! latitude + +, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + +, ht_ft(max_reps) ! altitude in feet + +, t_prcn(max_reps) ! temperature precision + +, ob_t(max_reps) ! temperature + +, ob_q(max_reps) ! moisture (specific humidity) + +, ob_dir(max_reps) ! wind direction + +, ob_spd(max_reps) ! wind speed + +, xiv_t(max_reps) ! temperature innovation/increment (ob-bg) + +, xiv_q(max_reps) ! specific humidity innovation/increment (ob-bg) + +, xiv_d(max_reps) ! wind direction innovation/increment (ob-bg) + +, xiv_s(max_reps) ! wind speed innovation/increment (ob-bg) + integer itype(max_reps) ! instrument (aircraft) type + +, idt(max_reps) ! time in seconds to anal. time (- before, + after) + +, ichk_t(max_reps) ! NRL QC flag for temperature ob + +, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + +, ichk_d(max_reps) ! NRL QC flag for wind direction ob + +, ichk_s(max_reps) ! NRL QC flag for wind speed ob + +, nchk_t(max_reps) ! NCEP QC flag for temperature ob + +, nchk_q(max_reps) ! NCEP QC flag for specific humidity ob + +, nchk_d(max_reps) ! NCEP QC flag for wind direction ob + +, nchk_s(max_reps) ! NCEP QC flag for wind speed ob + +, phase(max_reps) ! phase of flight for aircraft + + logical l_minus9c(max_reps) ! true for MDCRS -9C temperatures + +c Variables for reading numeric data out of BUFR files via BUFRLIB +c ---------------------------------------------------------------- + real*8 arr_8(15,10) ! array holding BUFR subset values from BUFRLIB call to + ! input PREPBUFR file + integer nlev ! number of report levels returned from BUFRLIB call + +, iret ! return code for call to BUFRLIB routine readns + +c Variables for reading character data out of BUFR files w/ BUFRLIB +c ----------------------------------------------------------------- + real*8 c_arr_8 ! real*8 PREPBUFR report id ("SID") + character*8 charstr ! character*8 equivalent of c_arr_8 + + equivalence(charstr,c_arr_8) + +c Variables for reading event values out of BUFR files w/ BUFRLIB +c --------------------------------------- ----------------------- + integer mxevdt ! maximum number of events allowed for each ob type + parameter (mxevdt = 10) + + integer mxnmev ! maximum number of events allowed in stack + +, mxvt ! maximum number of variable types (P, Q, T, Z, U, V) + parameter (mxvt = 6) + + integer qms(4) ! pointers to ichk_[t,q,d,s] + character*1 QM_types(4) ! characters for QM variable types + + /'T','Q','D','S'/ + + real*8 pqtzuvEV(mxevdt,mxlv,mxnmev,mxvt) ! holds values read from PREPBUFR file + ! (according to type,level,event,variable) + + character*80 EVstr(mxvt) ! mnemonic string for populating pqtzuvEV + + /'POB PQM PPC PRC PFC PAN CAT', ! pressure + + 'QOB QQM QPC QRC QFC QAN CAT', ! moisture + + 'TOB TQM TPC TRC TFC TAN CAT', ! temperature + + 'ZOB ZQM ZPC ZRC ZFC ZAN CAT', ! altitude + + 'UOB WQM WPC WRC UFC UAN CAT', ! u-wind + + 'VOB WQM WPC WRC VFC VAN CAT'/ ! v-wind + + real uob ! u-component wind for a single report + +, vob ! v-component wind for a single report + +, ufc ! u-component background wind for a single report + +, vfc ! v-component background wind for a single report + +, dir_fc ! wind direction background for a single report + +, spd_fc ! wind speed background for a single report + + integer evknt ! counter used when determining number of events per + ! variable type + + real*8 df_arr(5,mxlv,mxnmev) ! array used to read out wind (dir/spd) events + +c Variables for determining whether consecutive reports are mass and wind pieces that belong +c together +c ------------------------------------------------------------------------------------------ + logical l_massrpt ! TRUE if report read in from PREPBUFR is a mass piece + +, l_windrpt ! TRUE if report read in from PREPBUFR is a wind piece + +, l_match ! TRUE if mass and wind reports currently being + ! processed match (they are part of the same total + ! aircraft report) + + real sqn_current ! PREPBUFR sequence number ("SQN") of current report + +, sqn_next ! PREPBUFR sequence number ("SQN") of previous report + +, procn_current ! PREPBUFR poes process number ("PROC") of current + ! report + +c Variables for converting idt to YYYYMMDDHHMMSS format (stored in array c_dtg) +c ----------------------------------------------------------------------------- + integer year ! year of analysis time + +, month ! month of analysis time + +, day ! day of analysis time + +, hour ! hour of analysis time + +, idat(8) ! input array for call to w3movdat + +, jdat(8) ! output array for call to w3movdat + real rinc(5) ! array containing time increment for w3movdat + + +c Variables used to hold original aircraft data read from the input PREPBUFR file - necessary +c for carrying data through program so that it can be written to output profiles PREPBUFR- +c like file from memory instead of going back to input PREPBUFR file and re-reading that +c file before adding any QC events resulting from a decision made by the NRL QC routine (not +c applicable for case of single-level QC'd reports written back to full PREPBUFR file) +c -------------------------------------------------------------------------------------------- + integer nevents(max_reps,6) ! array tracking number of events for variables for + ! each report: + ! 1 - number of pressure events + ! 2 - number of specific humidity events + ! 3 - number of temperature events + ! 4 - number of altitude events + ! 5 - number of wind (u/v) events + ! 6 - number of wind (direction/speed) events + + integer nnestreps(4,max_reps) ! number of "nested replications" for TURB3SEQ, + ! PREWXSEQ, CLOUDSEQ, AFIC_SEQ + + integer nrep ! number of "nested replications" for TURB3SEQ + ! PREWXSEQ, CLOUDSEQ, AFIC_SEQ prior to setting to + ! nnestreps + + real*8 pob_ev(max_reps,mxnmev) ! POB values for each report, including all events + +, pqm_ev(max_reps,mxnmev) ! PQM values for each report, including all events + +, ppc_ev(max_reps,mxnmev) ! PPC values for each report, including all events + +, prc_ev(max_reps,mxnmev) ! PRC values for each report, including all events + +, zob_ev(max_reps,mxnmev) ! ZOB values for each report, including all events + +, zqm_ev(max_reps,mxnmev) ! ZQM values for each report, including all events + +, zpc_ev(max_reps,mxnmev) ! ZPC values for each report, including all events + +, zrc_ev(max_reps,mxnmev) ! ZRC values for each report, including all events + +, tob_ev(max_reps,mxnmev) ! TOB values for each report, including all events + +, tqm_ev(max_reps,mxnmev) ! TQM values for each report, including all events + +, tpc_ev(max_reps,mxnmev) ! TPC values for each report, including all events + +, trc_ev(max_reps,mxnmev) ! TRC values for each report, including all events + +, qob_ev(max_reps,mxnmev) ! QOB values for each report, including all events + +, qqm_ev(max_reps,mxnmev) ! QQM values for each report, including all events + +, qpc_ev(max_reps,mxnmev) ! QPC values for each report, including all events + +, qrc_ev(max_reps,mxnmev) ! QRC values for each report, including all events + +, uob_ev(max_reps,mxnmev) ! UOB values for each report, including all events + +, vob_ev(max_reps,mxnmev) ! VOB values for each report, including all events + +, wqm_ev(max_reps,mxnmev) ! WQM values for each report, including all events + +, wpc_ev(max_reps,mxnmev) ! WPC values for each report, including all events + +, wrc_ev(max_reps,mxnmev) ! WRC values for each report, including all events + +, ddo_ev(max_reps,mxnmev) ! DDO values for each report, including all events + +, ffo_ev(max_reps,mxnmev) ! FFO values for each report, including all events + +, dfq_ev(max_reps,mxnmev) ! DFQ values for each report, including all events + +, dfp_ev(max_reps,mxnmev) ! DFP values for each report, including all events + +, dfr_ev(max_reps,mxnmev) ! DFR values for each report, including all events + + +, hdr(max_reps,15) ! SID XOB YOB DHR ELV TYP T29 TSB ITP SQN PROCN RPT + ! TCOR RSRD EXRSRD + +, acid(max_reps) ! ACID + +, rct(max_reps) ! RCT + + +, pbg(max_reps,3) ! POE PFC PFCMOD + +, zbg(max_reps,3) ! ZOE ZFC ZFCMOD + +, tbg(max_reps,3) ! TOE TFC TFCMOD + +, qbg(max_reps,3) ! QOE QFC QFCMOD + +, wbg(max_reps,5) ! WOE UFC VFC UFCMOD VFCMOD + + +, ppp(max_reps,3) ! PAN PCL PCS + +, zpp(max_reps,3) ! ZAN ZCL ZCS + +, tpp(max_reps,3) ! TAN TCL TCS + +, qpp(max_reps,3) ! QAN QCL QCS + +, wpp(max_reps,6) ! UAN VAN UCL VCL UCS VCS + + +, drinfo(max_reps,3) ! XOB YOB DHR + +, acft_seq(max_reps,2) ! PCAT POAF + + +, turb1seq(max_reps) ! TRBX + +, turb2seq(max_reps,4) ! TRBX10 TRBX21 TRBX32 TRBX43 + +, turb3seq(3,max_reps,5) ! DGOT HBOT HTOT + +, prewxseq(1,max_reps,5) ! PRWE + +, cloudseq(5,max_reps,5) ! VSSO CLAM CLTP HOCB HOCT + +, afic_seq(3,max_reps,5) ! AFIC HBOI HTOI + +, mstq(max_reps) ! MSTQ + +, cat(max_reps) ! CAT + +, rolf(max_reps) ! ROLF + + +, sqn(max_reps,2) ! SQN (1=SQN for mass, 2=SQN for wind) + +, procn(max_reps,2) ! PROCN (1=PROCN for mass, 2=PROCN for wind) + +c ******************************************************************* + +c Start subroutine +c ---------------- + write(*,*) + write(*,*) '**********************' + write(*,*) 'Welcome to input_acqc.' + call system('date') + write(*,*) '**********************' + write(*,*) + +c Input PREPBUFR file is open and ready for reading by BUFRLIB +c ------------------------------------------------------------ + + print *, 'Initializing...' + +c Initialize observation arrays +c ----------------------------- + ob_t = amiss + ob_q = amiss + ob_dir = amiss + ob_spd = amiss + xiv_t = amiss + xiv_q = amiss + xiv_d = amiss + xiv_s = amiss + + nchk_t = -9 + nchk_q = -9 + nchk_d = -9 + nchk_s = -9 + +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + alat = amiss + alon = amiss +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + pres = amiss + ht_ft = amiss + itype = imiss + idt = imiss + + c_acftreg = ' ' + c_acftid = ' ' + c_dtg = ' ' + + nevents = 0 + + pob_ev = bmiss + pqm_ev = bmiss + ppc_ev = bmiss + prc_ev = bmiss + + zob_ev = bmiss + zqm_ev = bmiss + zpc_ev = bmiss + zrc_ev = bmiss + + tob_ev = bmiss + tqm_ev = bmiss + tpc_ev = bmiss + trc_ev = bmiss + + qob_ev = bmiss + qqm_ev = bmiss + qpc_ev = bmiss + qrc_ev = bmiss + + uob_ev = bmiss + vob_ev = bmiss + wqm_ev = bmiss + wpc_ev = bmiss + wrc_ev = bmiss + + ddo_ev = bmiss + ffo_ev = bmiss + dfq_ev = bmiss + dfp_ev = bmiss + dfr_ev = bmiss + + hdr = bmiss + rct = bmiss + acid = bmiss + + pbg = bmiss + zbg = bmiss + qbg = bmiss + tbg = bmiss + wbg = bmiss + + ppp = bmiss + zpp = bmiss + qpp = bmiss + tpp = bmiss + wpp = bmiss + + drinfo = bmiss + turb1seq = bmiss + turb2seq = bmiss + turb3seq = bmiss + prewxseq = bmiss + cloudseq = bmiss + afic_seq = bmiss + mstq = bmiss + cat = bmiss + rolf = bmiss + + sqn = 999999 + procn = 999999 + + nnestreps = 0 + + l_minus9C = .false. + + print *, 'Done initializing arrays...' + +c Initialize counters +c ------------------- + nACmsg_tot = 0 + numpairs = 0 + numorph = 0 + + nrptsaircar = 0 + nrptsaircft = 0 + + nrpts_rd = 0 + nrpts4QC = 0 + + numAIRCFTpairs = 0 + numAIRCARpairs = 0 + numAIRCFTorph = 0 + numAIRCARorph = 0 + + nPIREP = 0 + nAUTOAIREP = 0 + nMANAIREP = 0 + nAMDAR = 0 + nAMDARcan = 0 + nMDCRS = 0 + nTAMDAR = 0 + + nmswd = 0 + + print *, 'Done initializing counters...' + +c Initialize logicals +c ------------------- + l_massrpt = .false. + l_windrpt = .false. + + l_match = .false. + + print *, 'Done initializing logicals...' + +c Read data from pre-QC PREPBUFR file +c ----------------------------------- + write(*,*) 'Beginning data read!' + +c Start reading messages +c ---------------------- + loop2: do while(ireadmg(inlun,mesgtype,mesgdate).eq.0) + +c Only consider reports from messages with type 'AIRCFT' or 'AIRCAR' +c ------------------------------------------------------------------ + if(mesgtype.eq.'AIRCFT'.or.mesgtype.eq.'AIRCAR') then + +c Update counters of messages read in and considered +c -------------------------------------------------- + nACmsg_tot = nACmsg_tot + 1 + +c The date in all NCEP PREPBUFR messages is the date/cycle time - use this for the variable +c cdtg_an - no need to read in the cycle time from std input +c ----------------------------------------------------------------------------------------- + if(nACmsg_tot.eq.1) then ! obtain date/cycle from the first PREPBUFR message read + write(cdtg_an,'(i10)') mesgdate ! Convert mesgdate to character + write(*,*) 'Cycle date/time in PREPBUFR messages: ',cdtg_an + endif + +c Using the function ireadsb, read the PREPBUFR subsets/reports, which are separated into +c mass and wind pieces (NCEP convention) - we will need to pull out values and populate the +c following arrays, which will be used by the NRL aircraft QC routine: +c itype, alat, alon, pres, ht_ft,idt, c_dtg, c_acftreg, c_acftid, t_prcn, ob_t, ob_q, +c ob_dir, ob_spd, ichk_t, ichk_q, ichk_d, ichk_s, l_minus9C +c ------------------------------------------------------------------------------------------ + do while(ireadsb(inlun).eq.0) + + 4001 continue + l_match = .false. ! Reset match indicator. second halves of matches are read + ! starting at statement 6001 + + if(mesgtype.eq.'AIRCAR') then + nrptsaircar = nrptsaircar + 1 + elseif (mesgtype.eq.'AIRCFT') then + nrptsaircft = nrptsaircft + 1 + else ! not an aircraft-type message, cycle back to message reading loop & see if + ! there are more in file + print *, '---> MESGTYPE NOT AIRCRAFT TYPE!!!',' "', + + mesgtype,'"' + print *, '---> keep looping through messages in case any', + + ' more are in file' + cycle loop2 + endif + nrpts_rd = nrpts_rd + 1 ! number of aircraft-type BUFR subsets read from + ! PREPBUFR file + + 5001 continue ! will come here if we've just stored the second of a pair or an orphan; + ! need to increment index for the report-oriented arrays + if(nrpts4QC+1.gt.max_reps) then +c....................................................................... +c There are more reports in input file than "max_reps" -- do not process any more reports +c --------------------------------------------------------------------------------------- + print 53, max_reps,max_reps + 53 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + 'REPORTS IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER NAME', + + ' "MAX_REPS" - WILL CONTINUE ON PROCESSING ONLY ',I6,' REPORTS'/) + write(cmax_reps,'(i6)') max_reps +! call system('[ -n "$jlogfile" ] && $DATA/postmsg'// +! + ' "$jlogfile" "***WARNING:'//cmax_reps//' AIRCRAFT '// +! + 'REPORT LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// +! + cmax_reps//' RPTS PROCESSED"') + exit loop2 +c....................................................................... + endif + nrpts4QC = nrpts4QC + 1 ! number of input merged (mass + wind piece) aircraft- + ! type reports read in from PREPBUFR file (for QC code/ + ! index for arrays that will be used by acftobs_qc) + 6001 continue ! will come here if we need to check subset n+1 and see if it matches + ! the one just stored (treat subset n+1 as a new subset n) + +c Pull out the "header" info for subset n, which will either be a mass or wind piece - header +c mnemonics are: YOB XOB ELV DHR POAF TYP PCAT, along w/ SID +c ------------------------------------------------------------------------------------------- + arr_8 = bmiss + + call ufbint(inlun,arr_8,15,10,nlev, + +'YOB XOB ELV DHR TYP T29 TSB ITP SQN PROCN RPT TCOR RSRD EXPRSRD') + +cccccc hdr(nrpts4QC,1) = SID - stored later in code + hdr(nrpts4QC,2) = arr_8(2,1) ! XOB + hdr(nrpts4QC,3) = arr_8(1,1) ! YOB + hdr(nrpts4QC,4) = arr_8(4,1) ! DHR + hdr(nrpts4QC,5) = arr_8(3,1) ! ELV + hdr(nrpts4QC,6:15) = arr_8(5:14,1) ! TYP T29 TSB ITP SQN PROCN RPT TCOR RSRD + ! EXRSRD + +c Drift information +c ----------------- + drinfo(nrpts4QC,1) = arr_8(2,1) ! XOB/XDR + drinfo(nrpts4QC,2) = arr_8(1,1) ! YOB/YDR + drinfo(nrpts4QC,3) = arr_8(4,1) ! DHR/HRDR + +c Arrays used in NRL QC routine itself +c ------------------------------------ + alat(nrpts4QC) = arr_8(1,1) ! YOB + alon(nrpts4QC) = arr_8(2,1) ! XOB + ht_ft(nrpts4QC) = nint(arr_8(3,1)*m2ft) ! ELV in PREPBUFR is in meters NRL QC + ! wants feet + idt(nrpts4QC) = nint(arr_8(4,1)*3600.) ! NRL QC expects idt in sec + +c Determine whether this is a temperature or a wind report +c -------------------------------------------------------- + if(int(arr_8(5,1))/100.eq.1) then + l_massrpt = .true. + l_windrpt = .false. + + if(mesgtype.eq.'AIRCFT') then + nmswd(1,1) = nmswd(1,1) + 1 + elseif(mesgtype.eq.'AIRCAR') then + nmswd(2,1) = nmswd(2,1) + 1 + endif + + elseif(int(arr_8(5,1))/100.eq.2) then + l_massrpt = .false. + l_windrpt = .true. + + if(mesgtype.eq.'AIRCFT') then + nmswd(1,2) = nmswd(1,2) + 1 + elseif(mesgtype.eq.'AIRCAR') then + nmswd(2,2) = nmswd(2,2) + 1 + endif + + endif + + itype(nrpts4QC) = mod(int(hdr(nrpts4QC,6)),100) + ! 30 = NCEP: AIREP (NRL Manual AIREP/voice) + ! 30 = NCEP: PIREP (NRL Manual AIREP/voice) + ! 31 = NCEP: AMDAR (all types except Canadian) (NRL: AMDAR) + ! 32 = NCEP; RECCOs, but these are in ADPUPA msgs + ! 33 = NCEP: MDCRS (NRL: MDCRS) + ! 34 = NCEP: TAMDAR (NRL: ACARS) + ! 35 = NCEP: Canadian AMDAR (NRL: AMDAR) + +c Process SQN/PROCN - they will be used to construct full reports from mass and wind pieces +c ----------------------------------------------------------------------------------------- + sqn_current = hdr(nrpts4QC,10) + procn_current = hdr(nrpts4QC,11) + +c Get turbulence values, present weather (PRWE), cloud data, etc. (these are all nested- +c replicated) +c +c Note: These values, while there may be multiple replications of them, should be present +c only on a single level upon input (aircraft data is organized as single-level data +c upon input to this program - prior step is PREPDATA) +c ---------------------------------------------------------------------------------------- + +c turb3seq values: DGOT HBOT HTOT +c -- since this is not encoded to PREPBUFR-like (profiles) right now, no need to read in +ccccc arr_8 = bmiss +ccccc +ccccc call ufbseq(inlun,arr_8,15,10,nrep,'TURB3SEQ') +ccccc +ccccc nnestreps(1,nrpts4QC) = nrep +ccccc +ccccc if(nrep.ne.0) then ! There is turb3seq data to store +ccccc do i = 1,nrep +ccccc +ccccc if(nrep.le.5) then +ccccc turb3seq(:,nrpts4QC,nnestreps(1,nrpts4QC)-nrep+i) +ccccc+ = arr_8(1:3,i) +ccccc else ! there are more than 5 replications of TURB3SEQ +ccccc print *,'there are more than 5 reps of TURB3SEQ' +ccccc print *,'report #', nrpts4QC +ccccc endif ! if(nrep.le.5) +ccccc +ccccc enddo ! do i = 1,nrep +ccccc endif ! if(nrep.ne.0) + +c prewxseq values: PRWE +c -- since this is not encoded to PREPBUFR-like (profiles) right now, no need to read in +ccccc arr_8 = bmiss +ccccc +ccccc call ufbseq(inlun,arr_8,15,10,nrep,'PREWXSEQ') +ccccc +ccccc nnestreps(2,nrpts4QC) = nrep +ccccc +ccccc if(nrep.gt.0) then +ccccc do i = 1,nrep +ccccc +ccccc if(nrep.le.5) then +ccccc prewxseq(1,nrpts4QC,nnestreps(2,nrpts4QC)-nrep+i) +ccccc+ = arr_8(1,i) +ccccc else ! there are more than 5 replications of PREWXSEQ +ccccc print *,'there are more than 5 reps of PREWXSEQ' +ccccc print *,'report #', nrpts4QC +ccccc endif ! if(nrep.le.5) +ccccc +ccccc enddo ! do i = 1,nrep +ccccc endif ! if(nrep.gt.0) + +c cloudseq values: VSSO CLAM CLTP HOCB HOCT +c -- since this is not encoded to PREPBUFR-like (profiles) right now, no need to read in +ccccc arr_8 = bmiss +ccccc +ccccc call ufbseq(inlun,arr_8,15,10,nrep,'CLOUDSEQ') +ccccc +ccccc nnestreps(3,nrpts4QC) = nrep +ccccc +ccccc if(nrep.gt.0) then +ccccc do i = 1,nrep +ccccc +ccccc if(nrep.le.5) then +ccccc cloudseq(:,nrpts4QC,nnestreps(3,nrpts4QC)-nrep+i) +ccccc+ = arr_8(1:5,i) +ccccc else ! there are more than 5 replications of the cloud data +ccccc print *,'there are more than 5 reps of CLOUDSEQ' +ccccc print *,'report #', nrpts4QC +ccccc endif ! if(nrep.le.5) +ccccc +ccccc enddo ! do i = 1,nrep +ccccc endif ! if(nrep.gt.0) + +c afic_seq values: AFIC HBOI HTOI +c -- since this is not encoded to PREPBUFR-like (profiles) right now, no need to read in +ccccc arr_8 = bmiss +ccccc +ccccc call ufbseq(inlun,arr_8,15,10,nrep,'AFIC_SEQ') +ccccc +ccccc nnestreps(4,nrpts4QC) = nrep +ccccc +ccccc if(nrep.gt.0) then +ccccc do i = 1,nrep +ccccc +ccccc if(nrep.le.5) then +ccccc afic_seq(:,nrpts4QC,nnestreps(4,nrpts4QC)-nrep+i) +ccccc+ = arr_8(1:3,i) +ccccc else ! there are more than 5 replications of the aircraft icing data +ccccc print *,'there are more than 5 reps of AFIC_SEQ' +ccccc print *,'report #', nrpts4QC +ccccc endif ! if(nrep.le.5) +ccccc +ccccc enddo ! do i = 1,nrep +ccccc endif ! if(nrep.gt.0) + +c Start pulling out non-nested-replicated values +c ---------------------------------------------- + +c acft_seq values: PCAT POAF + arr_8 = bmiss + + call ufbint(inlun,arr_8,15,10,nlev,'PCAT POAF') + + acft_seq(nrpts4QC,:) = arr_8(1:2,1) + + if(ibfms(arr_8(2,1)).ne.0 .or. arr_8(2,1).eq.7.) then + phase(nrpts4QC) = 9 ! NRL sets a missing value of + else ! phase of flight = 9 + phase(nrpts4QC) = int(arr_8(2,1)) + endif + + if (ibfms(arr_8(1,1)) .ne. 0 ) then + t_prcn(nrpts4QC) = amiss + else + t_prcn(nrpts4QC) = arr_8(1,1) + endif + +c turb[1,2]seq values: TRBX TRBX10 TRBX21 TRBX32 TRBX43 + arr_8 = bmiss + + call ufbint(inlun,arr_8,15,10,nlev, + + 'TRBX TRBX10 TRBX21 TRBX32 TRBX43') + + turb1seq(nrpts4QC) = arr_8(1,1) + turb2seq(nrpts4QC,:) = arr_8(2:5,1) + +c Other misc. values: RCT, ROLF, MSTQ, CAT + arr_8 = bmiss + + call ufbint(inlun,arr_8,15,10,nlev,'RCT ROLF MSTQ CAT') + + rct(nrpts4QC) = arr_8(1,1) + mstq(nrpts4QC) = arr_8(3,1) + cat(nrpts4QC) = arr_8(4,1) + rolf(nrpts4QC) = arr_8(2,1) + +c ---------------------------------------------------------------------------------------- +c ---------------------------------------------------------------------------------------- +c Populate flight number and tail number arrays (c_acftid and c_acftreg, resp.) +c ---------------------------------------------------------------------------------------- + call ufbint(inlun,c_arr_8,1,1,nlev,'SID') + + hdr(nrpts4QC,1) = c_arr_8 + + if(mesgtype.eq.'AIRCFT') then + if(itype(nrpts4QC).eq.31 .or. + + itype(nrpts4QC).eq.35) then + +c All AMDAR types currently store tail number in 'SID', while flight number is missing or all +c blanks for all types except for LATAM (Chile) - if flight number is missing or all blanks, +c copy 'SID' into BOTH tail number and flight number locations in NRL arrays; if flight +c number is present and nnot all blanks (LATAM), copy flight number (from 'ACID') into flight +c number location in NRL array +c (Note: European AMDARs may have a valid flight number but it is not yet available in +c PREPBUFR, when it is it will be in mnemonic 'ACID' - DAK) +c ------------------------------------------------------------------------------------------ + c_acftreg(nrpts4QC) = charstr ! tail number + c_acftid(nrpts4QC) = charstr ! flight number (default is tail number) + call ufbint(inlun,c_arr_8,1,1,nlev,'ACID') + if(ibfms(c_arr_8).eq.0) then + if(charstr.ne.' ') then + c_acftid(nrpts4QC) = charstr ! flight number ('ACID' if present, always) + acid(nrpts4QC) = c_arr_8 ! the case for LATAM AMDAR + endif + endif + + elseif(itype(nrpts4QC).eq.30 .or. + + itype(nrpts4QC).eq.34) then + +c AIREP currently stores flight number in 'SID', while PIREP and TAMDAR currently store a +c manufactured ID in 'SID' - copy this into ONLY flight number location in NRL array +c (tail number location will store an all blank tail number - missing) +c --------------------------------------------------------------------------------------- + c_acftid(nrpts4QC) = charstr ! flight number + c_acftreg(nrpts4QC) = ' '! tail number + + if(itype(nrpts4QC).eq.34) ! TAMDARs replace '000' in characters 1-3 + + c_acftid(nrpts4QC)(1:3) = 'TAM'! of flight # with 'TAM' so they will pass + ! "invalid data" check in acftobs_qc + endif + + elseif(mesgtype.eq.'AIRCAR') then + +c MDCRS from ARINC currently store tail number in 'SID' and flight number in 'ACID' - copy +c these into tail number and flight number locations in NRL arrays +c (Note: MDCRS from AFWA was a rarely used backup to those from ARINC until it was +c discontinued on 10/30/2009 - it apparently stored flight number in 'SID' and +c in 'ACID' - store flight number in 'SID' as tail number and flight number in +c 'ACID' (if present) as flight number (even those would be the same here) +c --------------------------------------------------------------------------------------- + c_acftreg(nrpts4QC) = charstr ! tail number + call ufbint(inlun,c_arr_8,1,1,nlev,'ACID') + if(ibfms(c_arr_8).eq.0) then + c_acftid(nrpts4QC) = charstr ! flight number ('ACID' if present, always) + acid(nrpts4QC) = c_arr_8 ! the case for MDCRS from ARINC) + else + c_acftid(nrpts4QC) = ' '! store flight number as missing (all blanks) + ! if not present (may be the case for MDCRS + ! from AWFA) + endif + endif +c ---------------------------------------------------------------------------------------- +c ---------------------------------------------------------------------------------------- + +c Pull out obs and events for subset n +c ------------------------------------ + +c ******************************** +c PRES, OB_T, OB_Q, OB_DIR, OB_SPD +c ******************************** + +c If l_allev_pf is TRUE, use ufbevn to get at data values & events - all pre-existing events +c will be encoded into output PREPBUFR-like (profiles) file, (if l_doprofiles=T) along with +c any new NRLQCQC events on top of them (Note: All pre-existing events are always encoded +c into full PREPBUFR file) +c +c |---------> data types (1=ob, 2=qm, 3=pc, 4=rc, 5=fc, 6=an, 7=cat) +c | |-------> number of levels in the rpt (aircraft data is single level data; +c | | set j=1) +c | | |-----> number of events (will store all events, but only use latest event in +c | | | in the top of the stack (k=1) is used by the core NRL QC code) +c | | | |---> variable types (1=p,2=q,3=t,4=z,5=u,6=v) +c pqtzuvEV(i,j,k,l) +c +c example: pqtzuvEV(2,1,1,5) = QM for U in latest (top-of-stack) event on the 1st level + +c OTHERWISE: +c If l_allev_pf is FALSE, use ufbint to get at data values for only latest (top-of-stack) +c event - only latest event will be encoded into output PREPBUFR-like (profiles) file, (if +c l_doprofiles=T) along with any new NRLQCQC events on top of it (runs faster but pre- +c existing events are not recorded in output PREPBUFR-like file) (Note: All pre-existing +c events are always encoded into full PREPBUFR file) +c +c |---------> data types (1=ob, 2=qm, 3=pc, 4=rc, 5=fc, 6=an, 7=cat) +c | |-------> number of levels in the rpt (aircraft data is single level data; +c | | set j=1) +c | | |-----> always 1 since only one (the latest top-of-stack) event is returned +c | | | here +c | | | |---> variable types (1=p,2=q,3=t,4=z,5=u,6=v) +c pqtzuvEV(i,j,1,l) +c +c example: pqtzuvEV(2,1,1,5) = QM for U in latest (top-of-stack) event on the 1st level +c ------------------------------------------------------------------------------------------ + if(.not.l_allev_pf) then + do i = 1,mxvt + call ufbint(inlun,pqtzuvEV(1,1,1,i),mxevdt,mxlv,nlev, + + EVstr(i)) + enddo + else + do i = 1,mxvt + call ufbevn(inlun,pqtzuvEV(1,1,1,i),mxevdt,mxlv,mxnmev, + + nlev,EVstr(i)) + enddo + endif + + if(.not.l_match) then + +c pressure and pressure/altitude will only be read in and stored from the first (mass) piece +c of a mass/wind piece report pair or from the first (only) piece of a wind-only report +c rather than being re-read and re-stored again from the second (wind) piece (if a second +c piece exists) - this not only avoids wasted processing time (since the pressure and +c pressure-altitude should be the same in both pieces), it also prevents this code from +c reading a missing pressure-altitude in the second piece for those rare cases when +c unreasonably-high winds can be set to missing in PREPDATA resulting in an "empty" wind +c piece being encoded into PREPBUFR (and leading to problems in later profile generation in +c this code) (this is a bug in PREPDATA which will eventually be corrected) + +c Count the number of pressure/altitude events in this report +c ----------------------------------------------------------- +c pressure (1) +c ------------ + if(l_allev_pf) then + evknt = 0 + do j = 1,mxnmev +c |---> pressure + if(ibfms(pqtzuvEV(1,1,j,1)).ne.0) then + nevents(nrpts4QC,1) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + nevents(nrpts4QC,1) = 1 + endif + +c altitude (4) +c ------------ + if(l_allev_pf) then + evknt = 0 + do j = 1,mxnmev +c |---> altitude + if(ibfms(pqtzuvEV(1,1,j,4)).ne.0) then + nevents(nrpts4QC,4) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + nevents(nrpts4QC,4) = 1 + endif + +c Store pressure in array needed by subroutine acftobs_qc +c ------------------------------------------------------- + if(ibfms(pqtzuvEV(1,1,1,1)).eq.0) then + pres(nrpts4QC) = pqtzuvEV(1,1,1,1) ! POB at top of stack = pressure fed to + ! NRL QC + endif + +c Store pressure events in "corral" arrays to carry through this code +c ------------------------------------------------------------------- + if(nevents(nrpts4QC,1).gt.0) then + do i = 1,nevents(nrpts4QC,1) + invi = nevents(nrpts4QC,1)-i+1 + +c |---> acft data upon input = "single level"/ +c | 1 replication of PRSLVLA +c | |---> pressure + pob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,1) + pqm_ev(nrpts4QC,i) = pqtzuvEV(2,1,invi,1) + ppc_ev(nrpts4QC,i) = pqtzuvEV(3,1,invi,1) + prc_ev(nrpts4QC,i) = pqtzuvEV(4,1,invi,1) + enddo + endif + +c Store pressure background info in "corral" arrays to carry through this code +c ---------------------------------------------------------------------------- + call ufbint(inlun,arr_8,15,10,nlev,'POE PFC PFCMOD') ! only one occurence of bg + ! info per report/level + pbg(nrpts4QC,:) = arr_8(1:3,1) + + call ufbint(inlun,arr_8,15,10,nlev,'PAN PCL PCS') ! only one occurence of post-p + ! info per report/level + ppp(nrpts4QC,:) = arr_8(1:3,1) + +c Store altitude events in "corral" arrays to carry through this code - the actual value of +c altitude is pulled from ELV and stored in the ht_ft array (needed by acftobs_qc) when the +c rest of the report header information is pulled +c ------------------------------------------------------------------------------------------ + if(nevents(nrpts4QC,4).gt.0) then + do i = 1,nevents(nrpts4QC,4) + invi = nevents(nrpts4QC,4)-i+1 + +c |---> altitude + zob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,4) + zqm_ev(nrpts4QC,i) = pqtzuvEV(2,1,invi,4) + zpc_ev(nrpts4QC,i) = pqtzuvEV(3,1,invi,4) + zrc_ev(nrpts4QC,i) = pqtzuvEV(4,1,invi,4) + enddo + endif + +c Store altitude background info in "corral" arrays to carry through this code +c ---------------------------------------------------------------------------- + call ufbint(inlun,arr_8,15,10,nlev,'ZOE ZFC ZFCMOD') ! only one occurence of bg + ! info per report/level + zbg(nrpts4QC,:) = arr_8(1:3,1) + + call ufbint(inlun,arr_8,15,10,nlev,'ZAN ZCL ZCS') ! only one occurence of post-p + ! info per report/level + zpp(nrpts4QC,:) = arr_8(1:3,1) + + endif + +c Get temperature & moisture obs, increments, quality marks +c --------------------------------------------------------- + if(l_massrpt) then ! pull mass data + + sqn(nrpts4QC,1) = sqn_current ! SQN (sequence number) for mass piece + procn(nrpts4QC,1) = procn_current ! PROCN (process number) for mass piece + +c Count the number of moisture events in this report +c -------------------------------------------------- +c moisture (2) +c ------------ + if(l_allev_pf) then + evknt = 0 + do j = 1,mxnmev +c |---> moisture + if(ibfms(pqtzuvEV(1,1,j,2)).ne.0) then + nevents(nrpts4QC,2) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + nevents(nrpts4QC,2) = 1 + endif + +c Moisture (specific humidity) - use QOB from the top of event stack (pqtzuvEV(1,1,1,2) +c ------------------------------------------------------------------------------------- + if(ibfms(pqtzuvEV(1,1,1,2)).eq.0) then + ob_q(nrpts4QC) = pqtzuvEV(1,1,1,2)*0.001 ! NRL code requires g/kg; QOB in + ! PREPBUFR file is in mg/kg + xiv_q(nrpts4QC) = (pqtzuvEV(1,1,1,2) - + + pqtzuvEV(5,1,1,2))*0.001 ! use QOB at top of stack; also, there is only + ! one QFC per report + + nchk_q(nrpts4QC) = int(pqtzuvEV(2,1,1,2)) ! QQM from top of event stack + endif + +c Store moisture events in "corral" arrays to carry through this code +c ------------------------------------------------------------------- + if(nevents(nrpts4QC,2).gt.0) then + do i = 1,nevents(nrpts4QC,2) + invi = nevents(nrpts4QC,2)-i+1 + +c |---> moisture + qob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,2) + qqm_ev(nrpts4QC,i) = pqtzuvEV(2,1,invi,2) + qpc_ev(nrpts4QC,i) = pqtzuvEV(3,1,invi,2) + qrc_ev(nrpts4QC,i) = pqtzuvEV(4,1,invi,2) + enddo + endif + +c Store moisture background info in "corral" arrays to carry through this code +c ---------------------------------------------------------------------------- + call ufbint(inlun,arr_8,15,10,nlev,'QOE QFC QFCMOD') ! only one occurence of bg + ! info per report/level + qbg(nrpts4QC,:) = arr_8(1:3,1) + + call ufbint(inlun,arr_8,15,10,nlev,'QAN QCL QCS') ! only one occurence of post- + ! p info per report/level + qpp(nrpts4QC,:) = arr_8(1:3,1) + +c Count the number of temperature events in this report +c ----------------------------------------------------- +c temperature (3) +c --------------- + if(l_allev_pf) then + evknt = 0 + do j = 1,mxnmev +c |---> temperature + if(ibfms(pqtzuvEV(1,1,j,3)).ne.0) then + nevents(nrpts4QC,3) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + nevents(nrpts4QC,3) = 1 + endif + +c Temperature - use TOB from the top of event stack (pqtzuvEV(1,1,1,3) +c -------------------------------------------------------------------- + if(ibfms(pqtzuvEV(1,1,1,3)).eq.0) then + ob_t(nrpts4QC) = pqtzuvEV(1,1,1,3) + 273.16 ! convert to K + xiv_t(nrpts4QC) = pqtzuvEV(1,1,1,3) - pqtzuvEV(5,1,1,3) ! use TOB at top of + ! stack; also, there + ! is only one TFC + ! per report + nchk_t(nrpts4QC) = int(pqtzuvEV(2,1,1,3)) ! TQM from top of event stack + +c Check for -9C temperature (MDCRS only) +c -------------------------------------- + l_minus9C(nrpts4QC) = .false. + + if(itype(nrpts4QC).eq.33) then + if(abs(ob_t(nrpts4QC)-264.16).lt.0.05) then + l_minus9c(nrpts4QC) = .true. + endif + endif ! check for -9C temp in type = 33 + endif ! check for missing + +c Store temperature events in "corral" arrays to carry through this code +c ---------------------------------------------------------------------- + if(nevents(nrpts4QC,3).gt.0) then + do i = 1,nevents(nrpts4QC,3) + invi = nevents(nrpts4QC,3)-i+1 + +c |---> temperature + tob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,3) + tqm_ev(nrpts4QC,i) = pqtzuvEV(2,1,invi,3) + tpc_ev(nrpts4QC,i) = pqtzuvEV(3,1,invi,3) + trc_ev(nrpts4QC,i) = pqtzuvEV(4,1,invi,3) + enddo + endif + +c Store temperature background info in "corral" arrays to carry through this code +c ------------------------------------------------------------------------------- + call ufbint(inlun,arr_8,15,10,nlev,'TOE TFC TFCMOD') ! only one occurence of bg + ! info per report/level + + tbg(nrpts4QC,:) = arr_8(1:3,1) + + call ufbint(inlun,arr_8,15,10,nlev,'TAN TCL TCS') ! only one occurence of post- + ! p info per report/level + tpp(nrpts4QC,:) = arr_8(1:3,1) + +c Get u & v obs, increments, quality marks - convert u & v to direction & speed +c ----------------------------------------------------------------------------- + elseif(l_windrpt) then ! pull u, v, convert to direction & speed + + sqn(nrpts4QC,2) = sqn_current ! SQN (sequence number) for wind piece + procn(nrpts4QC,2) = procn_current ! PROCN (process number) for wind piece + +c Count the number of wind events in this report +c ---------------------------------------------- +c Wind (5/6) - use U/VOB from the top of event stack (pqtzuvEV(1,1,1,5) and +c (pqtzuvEV(1,1,1,6) +c ------------------------------------------------------------------------- + if(l_allev_pf) then + evknt = 0 + do j = 1,mxnmev +c |---> 5=u-comp, 6=v-comp + if(ibfms(pqtzuvEV(1,1,j,5)).ne.0 .or. + + ibfms(pqtzuvEV(1,1,j,6)).ne.0) then + nevents(nrpts4QC,5) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + nevents(nrpts4QC,5) = 1 + endif + + uob = pqtzuvEV(1,1,1,5) + vob = pqtzuvEV(1,1,1,6) + + ufc = pqtzuvEV(5,1,1,5) ! only one UFC per report + vfc = pqtzuvEV(5,1,1,6) ! only one VFC per report + + if(ibfms(pqtzuvEV(1,1,1,5)).eq.0 .and. + + ibfms(pqtzuvEV(1,1,1,6)).eq.0 ) then + +c Calculate speed & direction from U & V components (for both obs and forecast values) +c +c Per Dennis Keyser on 8/29/05, w3fc05 returns a wind direction of true meteorological nature +c (e.g., a wind w/ dir =270 is a wind from the west) +c +c ALSO NOTE: w3fc05 adds 0.001 to the direction - in order to get around this (without +c immediately changing this routine in W3EMC), set any wind directions between +c 360.000 and 360.002 back to 360.00 - might be a good idea to remove the addition +c of 0.001 to the wind direction in the W3EMC routine w3fc05 some day +c ------------------------------------------------------------------------------------------- + call w3fc05(uob,vob,ob_dir(nrpts4QC),ob_spd(nrpts4QC)) + +c If-statement below is used to negate effect of 0.001 being added to the wind direction in +c the W3EMC routine w3fc05 +c ----------------------------------------------------------------------------------------- + + if(ob_dir(nrpts4QC).gt.360.000 .and. + + ob_dir(nrpts4QC).lt.360.002) then + + ob_dir(nrpts4QC) = 360.00 + + endif + + call w3fc05(ufc,vfc,dir_fc,spd_fc) ! similar to cqcbufr/incrw +c increments +c --------- + xiv_s(nrpts4QC) = ob_spd(nrpts4QC) - spd_fc + xiv_d(nrpts4QC) = ob_dir(nrpts4QC) - dir_fc +c quality marks +c ------------- + nchk_s(nrpts4QC)= + + int(pqtzuvEV(2,1,1,5)) ! use u-component QM + nchk_d(nrpts4QC)= + + int(pqtzuvEV(2,1,1,5)) ! use u-component QM + + endif ! Check for missings + +c Store wind events in "corral" arrays to carry through this code +c --------------------------------------------------------------- + if(nevents(nrpts4QC,5).gt.0) then + do i = 1,nevents(nrpts4QC,5) + invi = nevents(nrpts4QC,5)-i+1 + +c |---> wind + uob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,5) + vob_ev(nrpts4QC,i) = pqtzuvEV(1,1,invi,6) + wqm_ev(nrpts4QC,i) = pqtzuvEV(2,1,invi,5) + wpc_ev(nrpts4QC,i) = pqtzuvEV(3,1,invi,5) + wrc_ev(nrpts4QC,i) = pqtzuvEV(4,1,invi,5) + enddo + endif + +c Store wind background info in "corral" arrays to carry through this code +c ------------------------------------------------------------------------ + call ufbint(inlun,arr_8,15,10,nlev, + + 'WOE UFC VFC UFCMOD VFCMOD') ! only one occurence of bg info per + ! report/level + wbg(nrpts4QC,:) = arr_8(1:5,1) + + call ufbint(inlun,arr_8,15,10,nlev, + + 'UAN VAN UCL VCL UCS VCS') ! only one occurence of post-p info per + ! report/level + wpp(nrpts4QC,:) = arr_8(1:6,1) + +c Pull wind (direction/speed) events +c ---------------------------------- + if(.not.l_allev_pf) then + call ufbint(inlun,df_arr,5,mxlv,nlev, + + 'DDO FFO DFQ DFP DFR') + else + call ufbevn(inlun,df_arr,5,mxlv,mxnmev,nlev, + + 'DDO FFO DFQ DFP DFR') + endif + +c Count the number of wind events (dir/speed) events in this report +c ----------------------------------------------------------------- + if(l_allev_pf) then + ddo_ev(nrpts4QC,:) = df_arr(1,1,:) + ffo_ev(nrpts4QC,:) = df_arr(2,1,:) + dfq_ev(nrpts4QC,:) = df_arr(3,1,:) + dfp_ev(nrpts4QC,:) = df_arr(4,1,:) + dfr_ev(nrpts4QC,:) = df_arr(5,1,:) + evknt = 0 + do j = 1,mxnmev + if(ibfms(df_arr(1,1,j)).ne.0 .or. + + ibfms(df_arr(2,1,j)).ne.0) then + nevents(nrpts4QC,6) = evknt + exit ! exit j do loop + else + evknt = evknt + 1 + endif + enddo + else + ddo_ev(nrpts4QC,1) = df_arr(1,1,1) + ffo_ev(nrpts4QC,1) = df_arr(2,1,1) + dfq_ev(nrpts4QC,1) = df_arr(3,1,1) + dfp_ev(nrpts4QC,1) = df_arr(4,1,1) + dfr_ev(nrpts4QC,1) = df_arr(5,1,1) + nevents(nrpts4QC,6) = 1 + endif + + endif ! Check for mass or wind report + + if(l_match) then ! report just stored was the second half + call readns(inlun,mesgtype,mesgdate,iret) ! Advance pointer to next subset + if(iret.eq.-1) then ! there are no more subsets to read in the PREPBUFR file + print *, 'READNS: NO MORE SUBSETS TO READ IN THE BUFR'// + + ' FILE' + exit + elseif(iret.eq.0) then ! there are still subsets to read; pull the next one + go to 4001 + else + print *, 'Unexpected return code(iret=',iret,') from ', + + 'readns!' + call w3tage('PREPOBS_PREPACQC') + call errexit(23) ! Problems reading BUFR file + endif + endif + +c At this point, we are done reading in subset n - call readns to get subset n+1 - see if it +c is the wind part for subset n - store in same report in local arrays if so - if subset n+1 +c is not the second piece of subset n, pull its header along with the data values and +c events, and store it in its own report +c ------------------------------------------------------------------------------------------- + call readns(inlun,mesgtype,mesgdate,iret) + if(iret.eq.-1) then ! there are no more subsets to read in the PREPBUFR file + print *, 'READNS: NO MORE SUBSETS TO READ IN THE BUFR '// + + 'FILE' + exit + elseif(iret.eq.0) then ! there are still subsets to read; pull the next one + +c Update counters +c --------------- + if(mesgtype.eq.'AIRCFT') then + nrptsaircft = nrptsaircft + 1 + elseif(mesgtype.eq.'AIRCAR') then + nrptsaircar = nrptsaircar + 1 + else ! We're done reading the aircraft-type messages out of this file + print *, '---> MESGTYPE NOT AIRCRAFT TYPE!!!',' "', + + mesgtype,'"' + print *, '---> keep looping through messages in case', + + ' any more are in file' + cycle loop2 + endif + nrpts_rd = nrpts_rd + 1 + +c Pull out the value of SQN for subset n+1, which will wither be a mass piece or a wind piece +c (most likely a wind piece for subset n). +c ------------------------------------------------------------------------------------------- + call ufbint(inlun,arr_8,15,10,nlev,'SQN') + sqn_next = arr_8(1,1) + +c Check and see if the report pulled by readns (subset n+1) is the second part for the report +c pulled by an iteration of do ireadsb (subset n) +c ------------------------------------------------------------------------------------------- + if(sqn_next.eq.sqn_current) then ! subset n+1 is the second part of subset n. + ! alat,alon,ht_ft,c_acftid (or c_acftreg) + ! and idt have already been populated; no + ! need to pull these twice + numpairs = numpairs + 1 + + if(mesgtype.eq.'AIRCFT') then + numAIRCFTpairs = numAIRCFTpairs + 1 + elseif(mesgtype.eq.'AIRCAR') then + numAIRCARpairs = numAIRCARpairs + 1 + endif + + l_match = .true. + + go to 6001 ! SQN will be read again but nrpts4QC won't be incremented - + ! we've just found the 2nd half of the report previously read + else ! subset n+1 is NOT the second part of subset n (n is an orphan) + +c If we get here, we know that subsets n and n+1 are not parts of a pair - subset n is an +c "orphan" and has already been stored - at this point, we don't yet know whether subset +c n+1 is another orphan or whether it is the second half of a match - whether subset n+1 is +c an orphan or part of a pair will be determined on the next iteration of this loop +c +c However, we do know that subset n+1 doesn't belong with subset n because their values of +c SQN are different - so, we need to increment nrpts4QC before storing subset n+1 in the +c report-oriented arrays (do so by sending the program to statement 5001) +c +c Send subset n+1 back through the program, treating subset n+1 as the new n +c ------------------------------------------------------------------------------------------ + numorph = numorph + 1 + + if(mesgtype.eq.'AIRCFT') then + numAIRCFTorph = numAIRCFTorph + 1 + elseif(mesgtype.eq.'AIRCAR') then + numAIRCARorph = numAIRCARorph + 1 + endif + + l_match = .false. + +c Leave BUFRLIB pointers where they are and treat subset n+1 as a new n +c --------------------------------------------------------------------- + go to 5001 + + endif ! check to see if subset n+1 is the second part of subset n + else + print *, 'Unexpected return code(iret=',iret,') from ', + + 'readns!' + call w3tage('PREPOBS_PREPACQC') + call errexit(23) ! Problems reading BUFR file + endif ! if(iret.eq.-1) then + + enddo ! do loop for reading BUFR subsets/reports (ireadsb) + endif ! check for message type + enddo loop2 ! do loop for reading messages + print *, '---> DONE READING FROM THIS FILE!!!' + print *, '---> nrpts_rd = ', nrpts_rd + + if(nrpts_rd.gt.0) then + +c Determine ITYPE, C_DTG, etc. +c ---------------------------- + do i=1,nrpts4QC + +c nevents can never be zero, otherwise array out-of-bounds issues will occur downstream - +c make sure nevents is always at least 1 for all variables and all reports +c --------------------------------------------------------------------------------------- + nevents(i,:) = max(nevents(i,:),1) + +c ******************************************** +c ITYPE --> REMAP FROM NCEP VALUE TO NRL VALUE +c ******************************************** + +c Determine type of aircraft report (itype) +c +c Need to check phase of flight and PREPBUFR report type +c PREPBUFR report types (mnemonic = TYP) where x is either: 1=mass, 2=wind part: +c x30 = NCEP: AIREP (NRL Manual AIREP/voice) +c x30 = NCEP: PIREP (NRL Manual AIREP/voice) +c x31 = NCEP: AMDAR (all types except Canadian) (NRL: AMDAR) +c x33 = NCEP: MDCRS (NRL: MDCRS) +c x34 = NCEP: TAMDAR (NRL: ACARS) +c x35 = NCEP: Canadian AMDAR (NRL: AMDAR) +c +c NCEP BUFR MNEMONIC POAF (phase of flight)/BUFR desc. 0-08-004: +c 0-1 = reserved +c 2 = Unsteady +c 3 = Level flight, routine observation +c 4 = Level flight, highest wind encountered +c 5 = Ascending +c 6 = Descending +c 7 = missing (set to 9 prior to this to match NRL's missing value) +c bmiss = missing (set to 9 prior to this to match NRL's missing value) +c +c ############################################################## +c NRL settings for itype (see function insty_ob_fun): +c --> Use value of POAF to determine whether ob was taken while the aircraft was ascending, +c descending, etc. +c +c Below * means used by NCEP +c +c -------------------------------------------------------------- +c ---> NRL AIREPs +c * 25/'man-airep' = Manual AIREP (header XRXX)/"typical voice AIREP" +c -- NOTE: Assign PIREPs (used at NCEP but not at NRL) to this "typical voice +c AIREP" category +c -- NOTE: Assign all AIREPs (for now) to this "typical voice AIREP" category +c 26/'man-Yairep' = Manual AIREP (header YRXX)/keypad AIREP +c -- NOTE: NCEP does not assign anything to this at the current time +c 30/'airep' = automated "AIREPs" (AMDAR or UAL MDCRS re-encoded as AIREPs by AFWA) +c -- NOTE: NCEP does not assign anything to this at the current time +c AFWA stopped re-encoding AMDAR and MDCRS into AIREP in Oct 2009 +c 131/'airep_asc' = AIREP ascending profile +c -- NOTE: NCEP does not assign anything to this at the current time +c 132/'airep_des' = AIREP descending profile +c -- NOTE: NCEP does not assign anything to this at the current time +c 33/'airep_lvl' = AIREP level flight +c -- NOTE: NCEP does not assign anything to this at the current time +C 34/'airep_msg' = AIREP w/ missing category (if rpt is not 25, 26, or 30) +c -- NOTE: NCEP does not assign anything to this at the current time +c -------------------------------------------------------------- +c ---> NRL AMDARs +c * 35/'amdar' = Automated aircraft data (AMDAR) (POAF cannot be determined) +c *136/'amdar_asc' = AMDAR ascending profile +c *137/'amdar_des' = AMDAR descending profile +c * 38/'amdar_lvl' = AMDAR level flight +c -------------------------------------------------------------- +c ---> NRL ACARS {NOTE: Originally deemed "ACARS" by NRL, but this is currently not used by +c NRL (per email from Pat Pauley 1/12/05); NCEP will use them to provide +c a separate category for TAMDARs and rename them as TAMDAR in all +c printouts from acftobs_qc.f} +c 40/'acars' = Automated aircraft (TAMDAR) (POAF cannot be determined) +c 141/'acars_asc' = TAMDAR ascending profile +c 142/'acars_des' = TAMDAR descending profile +c 43/'acars_lvl' = TAMDAR level flight +c -------------------------------------------------------------- +c ---> NRL MDCRS +c * 45/'mdcrs' = Automated aircraft (MDCRS) (POAF cannot be determined) +c *146/'mdcrs_asc' = MDCRS ascending profile +c *147/'mdcrs_des' = MDCRS descending profile +c * 48/'mdcrs_lvl' = MDCRS level flight +c ############################################################## + + if(itype(i).eq.30) then ! NCEP: AIREP (NRL Manual AIREP/voice) or + ! NCEP: PIREP (NRL Manual AIREP/voice) + phase(i) = 9 ! NRL leaves phase of flight as missing for all + ! AIREP/PIREP types (fine since NCEP does not have + ! phase of flight info for AIREPs or PIREPs) + + if(c_acftid(i)(1:1).eq.'P'.and.c_acftid(i)(6:6).eq.'P') then ! NCEP PIREPs (BUFR + ! tank b004/xx002) + +c SMB: Data type label changed from 34 -> 25 on 5/5/05. PIREPs are probably more along the +c lines of "typical voice reports" than AIREPs with a "missing" category +c DAK: Agreed, if we are still going to use PIREPs lump them into Manual AIREP/voice category + itype(i) = 25 + nPIREP = nPIREP + 1 + + else ! NCEP AIREPs (BUFR tank b004/xx001) +c SMB: Originally set these to 30 (reformatted something else's/"automated AIREPs") +c DAK: Changed these to 25 on 3/23/12 (30 is reserved for AFWA re-encoded AIREPS, orig. AMDAR +c or MDCRS - there are none of these after Oct. 2009 per Eric Wise/AFWA) +c We may want to try to isolate ADS's in N. Atlantic as type 30 (NRL does this) but not +c at this point (right now ADS's go into NCO's airep decoder and come out in b004/xx001 +c tank) +ccccccccc itype(i) = 30 +ccccccccc nAUTOAIREP = nAUTOAIREP + 1 + itype(i) = 25 + nMANAIREP = nMANAIREP + 1 + endif + + elseif(itype(i).eq.31) then ! NCEP: AMDAR (all types except Canadian) (NRL: AMDAR) + ! (BUFR tanks b004/xx003, b004/xx006, b004/xx011, b004/xx103) + nAMDAR = nAMDAR + 1 + if(phase(i).eq.3 .or. phase(i).eq.4) then + itype(i) = 38 ! level flight + elseif(phase(i).eq.5) then + itype(i) = 136 ! ascending flight + elseif(phase(i).eq.6) then + itype(i) = 137 ! descending flight + else + itype(i) = 35 ! unknown phase of flight + endif + + elseif(itype(i).eq.33) then ! NCEP: MDCRS (NRL: MDCRS) (BUFR tank b004/xx004) + nMDCRS = nMDCRS + 1 + if(phase(i).eq.3 .or. phase(i).eq.4) then + itype(i) = 48 ! level flight + elseif(phase(i).eq.5) then + itype(i) = 146 ! ascending flight + elseif(phase(i).eq.6) then + itype(i) = 147 ! descending flight + else + itype(i) = 45 ! unknown phase of flight + endif + + elseif(itype(i).eq.34) then ! NCEP: TAMDAR (NRL: ACARS) + ! (BUFR tanks b004/xx008, b004/xx010, b004/xx012, b004/xx013) +c DAK: Changed these from NRL AMDAR to NRL ACARS at suggestion of P. Pauley (3/2012), (to hold +c NCEP TAMDARs) - allows them to be treated in a separate category for stratifying +c statistics - also seems to flag more AMDARs as bad which is a good thing since there +c are so many anyway + nTAMDAR = nTAMDAR + 1 + ! NOTE: MADIS-feed TAMDARs currently have missing phase of flight and will + ! get set to unknown value initially (may later change) + ! AirDAT/Panasonic BUFR-feed TAMDARs do contain phase of flight) + if(phase(i).eq.3 .or. phase(i).eq.4) then +ccccccccccc itype(i) = 38 ! level flight + itype(i) = 43 ! level flight + elseif(phase(i).eq.5) then +ccccccccccc itype(i) = 136 ! ascending flight + itype(i) = 141 ! ascending flight + elseif(phase(i).eq.6) then +ccccccccccc itype(i) = 137 ! descending flight + itype(i) = 142 ! descending flight + else +ccccccccccc itype(i) = 35 ! unknown phase of flight + itype(i) = 40 ! unknown phase of flight + endif + + elseif(itype(i).eq.35) then ! Canadian AMDAR (NRL: AMDAR) (BUFR tank b004/xx009) + nAMDARcan = nAMDARcan + 1 + if(phase(i).eq.3 .or. phase(i).eq.4) then + itype(i) = 38 ! level flight + elseif(phase(i).eq.5) then + itype(i) = 136 ! ascending flight + elseif(phase(i).eq.6) then + itype(i) = 137 ! descending flight + else + itype(i) = 35 ! unknown phase of flight + endif + + else + print'(" Unexpected value for PREPBUFR report type! (itype=", + + I0," & should be 30, 31, 33, 34, or 35)")', itype(i) + print *, 'i=',i + + endif + +c ***** +c C_DTG +c ***** + +c Convert idt to YYYYMMDDHHMMSS format +c ------------------------------------ + read(cdtg_an(1:4),'(i4.4)') year + read(cdtg_an(5:6),'(i2.2)') month + read(cdtg_an(7:8),'(i2.2)') day + read(cdtg_an(9:10),'(i2.2)') hour + +c Time increment (offset from cycle time) +c --------------------------------------- + rinc(1) = 0. ! days + rinc(2) = 0. ! hours + rinc(3) = 0. ! mins + rinc(4) = idt(i) ! seconds + rinc(5) = 0. ! milliseconds + +c Date/time for cycle time +c ------------------------ + idat(1) = year + idat(2) = month + idat(3) = day + idat(4) = 0 ! time zone + idat(5) = hour + idat(6) = 0 ! mins + idat(7) = 0 ! secs + idat(8) = 0 ! millisecs + +c Use W3NCO routine w3movdat to get date/time of actual observation +c ----------------------------------------------------------------- + call w3movdat(rinc,idat,jdat) + +c Convert jdat values to date/time string in yyyymmddhhmmss format +c ----------------------------------------------------------------- + write(c_dtg(i)(1:4),'(i4.4)') jdat(1) + write(c_dtg(i)(5:6),'(i2.2)') jdat(2) + write(c_dtg(i)(7:8),'(i2.2)') jdat(3) + write(c_dtg(i)(9:10),'(i2.2)') jdat(5) + write(c_dtg(i)(11:12),'(i2.2)') jdat(6) + write(c_dtg(i)(13:14),'(i2.2)') jdat(7) + +c **************************************** +c TRANSLATE NCEP QC FLAGS TO NRL STANDARDS +c (Store in arrays ichk_[t,q,d,s]) +c **************************************** + +c QM type: NCEP values: NRL values: +c nchk_* ichk_*h +c Not checked/neutral 2 0 +c Good 1 -1 +c Suspect 3 -2 +c Bad 4-15 -3 +c Initial/missing value -9 -9 +c --------------------------------------------------- + qms(1) = nchk_t(i) + qms(2) = nchk_q(i) + qms(3) = nchk_d(i) + qms(4) = nchk_s(i) + +c DAK: this could be coded up more efficiently! + do J=1,4 + if(qms(j).eq.2) then + qms(j) = 0 + elseif(qms(j).eq.1) then + qms(j) = -1 + elseif(qms(j).eq.3) then + qms(j) = -2 + elseif(qms(j).ge.4 .and. qms(j).le.15) then + qms(j) = -3 + +cc smb 8/19/05 +c For now, let qms(j)/ichk_q = 0 for non-missing q - this is to bypass ichk_q checks in +c grchek_qc +c ------------------------------------------------------------------------------------- + if(ob_q(i).ne.amiss) then + qms(j) = 0 + endif + + elseif(qms(j).eq.-9) then ! leave it as is + qms(j) = -9 + else ! Store QM = NRL's missing value + qms(j) = -9 + print'(" Unexpected value of NCEP j=",I0,"/",A," QM (",I0, + + ") for report number",I0,"!")',j,QM_types(j),qms(j),i + endif + +c If ob is missing, then store NRL quality mark as -9 +c --------------------------------------------------- +c DAK: this could be coded up more efficiently! + if(j.eq.1 .and. ob_t(i).eq.amiss) then + qms(j) = -9 + elseif(j.eq.2 .and. ob_q(i).eq.amiss) then + qms(j) = -9 + elseif(j.eq.3 .and. ob_dir(i).eq.amiss) then + qms(j) = -9 + elseif(j.eq.4 .and. ob_spd(i).eq.amiss) then + qms(j) = -9 + endif + +c Store altered quality marks into NRL QM arrays +c ---------------------------------------------- +c DAK: this could be coded up more efficiently! + if(j.eq.1) then + ichk_t(i) = qms(j) + elseif(j.eq.2) then + ichk_q(i) = qms(j) + elseif(j.eq.3) then + ichk_d(i) = qms(j) + elseif(j.eq.4) then + ichk_s(i) = qms(j) + endif + + enddo ! over j + enddo ! over i + endif ! nrpts_rd.gt.0 + +c Output counts +c ------------- + write(*,*) 'NUMBER OF "AIRCFT" RPTS: ',nrptsaircft + write(*,*) ' --> MASS: ', nmswd(1,1) + write(*,*) ' --> WIND: ', nmswd(1,2) + write(*,*) 'NUMBER OF "AIRCAR" RPTS: ',nrptsaircar + write(*,*) ' --> MASS: ', nmswd(2,1) + write(*,*) ' --> WIND: ', nmswd(2,2) + write(*,*) 'TOTAL NUMBER OF MASS AND WIND REPORTS READ: ', + + nrpts_rd + write(*,*) 'TOTAL NUMBER OF PAIRS (merged mass+wind): ',numpairs + write(*,*) 'TOTAL NUMBER OF ORPHANS (only mass or only wind ', + + 'present): ', numorph + write(*,*) 'NUMBER OF "AIRCFT" PAIRS/ORPHANS: ', numAIRCFTpairs, + + '/', numAIRCFTorph + write(*,*) 'NUMBER OF "AIRCAR" PAIRS/ORPHANS: ', numAIRCARpairs, + + '/', numAIRCARorph + + + write(*,*) + write(*,*) 'TOTAL NUMBER OF REPORTS FOR QC CODE: ', nrpts4QC + + write(*,*) + write(*,*) 'NUMBER OF PIREPS (MANUAL AIREP/voice): ',nPIREP + write(*,*) 'NUMBER OF AUTO AIREPS: ',nAUTOAIREP + write(*,*) 'NUMBER OF AIREPS (MANUAL AIREPS/voice): ',nMANAIREP + write(*,*) 'NUMBER OF AMDAR (excl. Canadian): ',nAMDAR + write(*,*) 'NUMBER OF CANADIAN AMDAR: ',nAMDARcan + write(*,*) 'NUMBER OF MDCRS: ',nMDCRS + write(*,*) 'NUMBER OF TAMDAR: ',nTAMDAR + +c End program +c ----------- + + if(nrpts4QC/.90.gt.max_reps .and. nrpts4QC.lt.max_reps ) then + +c If the total number of merged (mass + wind piece) aircraft-type reports read in from +c PREPBUFR file is at least 90% of the maximum allowed ("max_reps"), print diagnostic +c warning message to production joblog file +c ------------------------------------------------------------------------------------ + + print 153, nrpts4QC,max_reps + 153 format(/' #####> WARNING: THE ',I6,' AIRCRAFT RPTS IN INPUT ', + + 'FILE ARE > 90% OF UPPER LIMIT OF ',I6,' -- INCREASE SIZE OF ', + + '"MAX_REPS" SOON!'/) + write(cmax_reps,'(i6)') max_reps +! call system('[ -n "$jlogfile" ] && $DATA/postmsg "$jlogfile" '// +! + '"***WARNING: HIT 90% OF '//cmax_reps//' AIRCRAFT REPORT '// +! + 'LIMIT IN PREPOBS_PREPACQC, INCREASE SIZE OF PARM MAX_REPS"') + endif + + write(*,*) + write(*,*) '********************' + write(*,*) 'input_acqc has ended' + call system('date') + write(*,*) '--> # reports = ',nrpts4QC + write(*,*) '********************' + write(*,*) + + return + + end + diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_noprof.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_noprof.f new file mode 100644 index 00000000..06d18bf0 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_noprof.f @@ -0,0 +1,1581 @@ +c$$$ Subprogram Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Subprogram: output_acqc_noprof +c Programmer: D. Keyser Org: NP22 Date: 2015-12-09 +c +c Abstract: Reads an input, pre-PREPACQC PREPBUFR file and matches the subsets within to the +c "merged" reports contained within the arrays output by the NRL aircraft QC subroutine +c acftobs_qc. Calls subroutine tranQCflags to translate the QC information (for each +c variable: pressure, altitude, temperature and moisture for the mass piece; and pressure, +c altitude and wind for the wind piece) from NRL standards (c_qc array) to their NCEP +c counterparts and to establish event reason codes for each variable. All of this QC +c information is then encoded as event stacks in the output PREPBUFR file which will be +c identical to the input PREPBUFR file except for the new events added by this program and +c aircraft reports that are removed (possibly) for being outside the requested time window +c or geographical domain). +c +c Program History Log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c 2012-11-20 J. Woollen -- Initial port to WCOSS +c 2013-02-07 D. Keyser -- If the maximum number of merged reports that can be processed +c ("max_reps") is exceeded when updating reports in PREPBUFR file +c with QC changes, program will no longer stop with r.c. 31, as +c though there is an indexing error, instead all original reports +c above "max_reps" will be written out without any QC and a message +c will be printed to stdout (a diagnostic will have already been +c sent to the production joblog file in this case when reports were +c first read in by subroutine INPUT_ACQC) +c 2013-02-07 D. Keyser -- Final changes to run on WCOSS: use formatted print statements +c where previously unformatted print was > 80 characters +c 2014-03-06 D. Keyser -- Moved BUFRLIB routine OPENMB call to after time window and +c geographic domain checks to prevent creation of an empty, but +c open, BUFR message (type AIRCAR) in (rare) cases where absolutely +c no aircraft reports pass these checks (would cause a BUFRLIB +c abort due to previous message being open when attempting to copy +c first non-aircraft message from input to output PREPBUFR file +c 2013-10-07 Sienkiewicz -- Initialize some uninitialized variables for 'gfortran' compile +c 2015-03-16 D. Keyser -- Fixed a bug which, for cases where the maximum number of merged +c reports that can be processed ("max_reps") is exceeded, prevented +c any original reports above "max_reps" from being written out +c (without any QC). +c 2015-12-09 D. Keyser -- +c - Variables holding latitude and longitude data (including input +c arguments "alat" and "alon") now double precision. XOB and YOB in +c PREPBUFR file now scaled to 10**5 (was 10**2) to handle new v7 AMDAR +c and MDCRS reports which have this higher precision. +c BENEFIT: Retains exact precison here. Improves QC processing. +c - The format for all print statements containing latitude and longitude +c changed to print to 5 decimal places. +c +c Usage: call output_acqc_noprof(inlun,outlun,nrpts4QC_pre,max_reps, +c bmiss,alat,alon,ht_ft,idt,c_qc, +c trad,l_otw,l_nhonly, +c ncep_qm_p,ncep_rc_p, +c ncep_qm_z,ncep_rc_z, +c ncep_qm_t,ncep_rc_t, +c ncep_qm_q,ncep_rc_q, +c ncep_qm_w,ncep_rc_w, +c ncep_rej, +c nrlacqc_pc) +c +c Input argument list: +c inlun - Unit number for the input pre-PREPACQC PREPBUFR file containing all data +c (separate mass/wind pieces) +c outlun - Unit number for the output PREPBUFR file containing all data plus now +c with NRLACQC events (separate mass/wind pieces) +c nrpts4QC_pre - Number of reports in the "merged" single-level aircraft report arrays +c max_reps - Maximum number of reports accepted by acftobs_qc +c bmiss - BUFRLIB missing value (set in main program) +c alat - Array of latitudes for the "merged" reports +c alon - Array of longitudes for the "merged" reports +c ht_ft - Array of altitudes for the "merged" reports +c idt - Array of ob-cycle times for the "merged" reports (in seconds) +c c_qc - Array of NRLACQC quality information (11 char. string) ("merged" reports) +c trad - Time window radius for outputting reports (if l_otw=T) (read in via +c namelist) +c l_otw - Logical whether or not to eliminate reports outside the time window +c radius (trad) (read in via namelist) +c l_nhonly - Logical Whether or not to eliminate reports south of 20S latitude (i.e, +c outside the tropics and N. Hemisphere) (read in via namelist) +c nrlacqc_pc - PREPBUFR program code for the NRLACQC step +c +c Output argument list: +c ncep_qm_p - Array of NCEP PREPBUFR quality marks on pressure for the "merged" reports +c ncep_rc_p - Array of NCEP PREPBUFR reason codes on pressure for the "merged" reports +c ncep_qm_z - Array of NCEP PREPBUFR quality marks on altitude for the "merged" rpts +c ncep_rc_z - Array of NCEP PREPBUFR reason codes on altitude for the "merged" rpts +c ncep_qm_t - Array of NCEP PREPBUFR quality marks on temperature for the "merged" rpts +c ncep_rc_t - Array of NCEP PREPBUFR reason codes on temperature for the "merged" rpts +c ncep_qm_q - Array of NCEP PREPBUFR quality marks on moisture for the "merged" reports +c ncep_rc_q - Array of NCEP PREPBUFR reason codes on moisture for the "merged" reports +c ncep_qm_w - Array of NCEP PREPBUFR quality marks on wind for the "merged" reports +c ncep_rc_w - Array of NCEP PREPBUFR reason codes on wind for the "merged" reports +c ncep_rej - Array indicating if "merged" report is (=0) or is not (=1) to be written +c to output PREPBUFR file +c Input files: +c Unit inlun - PREPBUFR file containing all obs, prior to any processing by this program +c +c Output files: +c Unit 06 - Standard output print +c Unit outlun - PREPBUFR file identical to input except containing NRLACQC events +c +c Subprograms called: +c Unique: TRANQCFLAGS +c Library: +c SYSTEM: SYSTEM +c W3NCO: ERREXIT W3TAGE +c BUFRLIB: IREADMG COPYMG OPENMB IREADSB UFBINT UFBCPY WRITSB +c WRITLC CLOSMG IBFMS +c +c Exit States: +c Cond = 0 - successful run +c 31 - indexing problem encountered when trying to match QC'd data in arrays to +c mass and wind pieces in original PREPBUFR file +c +c Remarks: Called by main program. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine output_acqc_noprof(inlun,outlun,nrpts4QC_pre,max_reps, + + bmiss,alat,alon,ht_ft,idt,c_qc, + + trad,l_otw,l_nhonly,l_qmwrite, + + ncep_qm_p,ncep_rc_p, + + ncep_qm_z,ncep_rc_z, + + ncep_qm_t,ncep_rc_t, + + ncep_qm_q,ncep_rc_q, + + ncep_qm_w,ncep_rc_w, + + ncep_rej, + + nrlacqc_pc) + + implicit none + +c ------------------------------ +c Parameter statements/constants +c ------------------------------ + integer inlun ! input unit number for pre-PREPACQC PREPBUFR file to + ! which we are adding NRLACQC events + +, outlun ! output unit number for post-PREPACQC PREPBUFR file + ! with added NRLACQC events + +, max_reps ! maximum number of input merged (mass + wind piece) + ! aircraft-type reports allowed + real m2ft + parameter (m2ft = 3.28084) ! conversion factor to convert m to ft +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c replace above with this in event of future switch to dynamic memory allocation + +calloc integer max_reps ! original number of input reports obtained from +calloc ! first pass through to get total for array allocation +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + real*8 bmiss ! BUFRLIB missing value (set in main program) + + +c ---------------------- +c Declaration statements +c ---------------------- + +c Variables for BUFRLIB interface +c ------------------------------- + character*8 mesgtype ! BUFR message type (e.g., 'AIRCFT ') + integer mesgdate ! date time from BUFR message (YYYYMMDDHH) + +c Indices/counters +c ---------------- + integer i,j ! loop indices + + integer nrpts4QC_pre ! original number of input merged (mass + wind piece) + ! aircraft-type reports (read in from PREPBUFR file) + +c Functions +c --------- + integer ireadmg ! BUFRLIB - for reading messages + +, ireadsb ! BUFRLIB - for reading subsets + +, ibfms ! BUFRLIB - for testing for missing + + character*11 c_qc(max_reps) ! character QC flags output from NRL QC code + ! 1st char - info about reject (if ob was rejected) + ! 2nd char - reason why time was rejected + ! 3rd char - reason why latitude was rejected + ! 4th char - reason why longitude was rejected + ! 5th char - reason why pressure/atitude was rejected + ! 6th char - readon why temperature was rejected + ! 7th char - reason why wind direction was rejected + ! 8th char - reason why wind speed was rejected + ! 9th char - reason why mixing ratio was rejected + ! 10th char - reason for blacklisting the aircraft + ! 11th char - info about flight phase + + real*8 alat(max_reps) ! latitude + +, alon(max_reps) ! longitude + real ht_ft(max_reps) ! altitude in feet + integer idt(max_reps) ! time in seconds to anal. time (- before, + after) + integer ncep_qm_p(max_reps) ! NCEP PREPBUFR quality mark pressure (PQM) + +, ncep_rc_p(max_reps) ! NCEP PREPBUFR NRLACQC pressure event reason code(PRC) + +, ncep_qm_z(max_reps) ! NCEP PREPBUFR quality mark on altitude (ZQM) + +, ncep_rc_z(max_reps) ! NCEP PREPBUFR NRLACQC alt/hght event reason code(ZRC) + +, ncep_qm_t(max_reps) ! NCEP PREPBUFR quality mark on temperature (TQM) + +, ncep_rc_t(max_reps) ! NCEP PREPBUFR NRLACQC temperature evnt rea. code(TRC) + +, ncep_qm_q(max_reps) ! NCEP PREPBUFR quality mark on moisture (QQM) + +, ncep_rc_q(max_reps) ! NCEP PREPBUFR NRLACQC moisture reason code (QRC) + +, ncep_qm_w(max_reps) ! NCEP PREPBUFR quality mark on wind (WQM) + +, ncep_rc_w(max_reps) ! NCEP PREPBUFR NRLACQC wind event reason code (WRC) + +, ncep_rej(max_reps) ! NCEP PREPBUFR rejection indicator + +c Variables for reading (writing) numeric data out of (in to) BUFR files via BUFRLIB +c ---------------------------------------------------------------------------------- + real*8 arr_8(10,10) ! array holding BUFR subset values from BUFRLIB call to + ! input PREPBUFR file + +, dhr_corr(2) ! array holding rehabilitated time (DHR TCOR) + +, yob_corr(3) ! array holding rehabilitated latitude (YOB YCOR YORG) + +, xob_corr(3) ! array holding rehabilitated longitude (XOB XCOR XORG) + + integer nlev ! number of report levels returned from BUFRLIB call + ! (should always be 1 !) + integer iret ! return code for call to BUFRLIB routine ufbint when + ! writing to PREPBUFR file + +c Variables for updating input PREPBUFR reports with QC results/events from NRLACQC +c --------------------------------------------------------------------------------- + integer ninssrd ! number of subsets read in from the input PREPBUFR file + +, QCdrptsidx ! index for report-oriented arrays that are output from + ! acftobs_qc + + real*8 p_event(4) ! array used to update a pressure event stack + +, z_event(4) ! array used to update an altitude event stack + +, t_event(4) ! array used to update a temperature event stack + +, q_event(4) ! array used to update a moisture event stack + +, w_event(5) ! array used to update a wind event stack + + logical l_eventupdate ! T = event was added for the last PREPBUFR report read + ! F = no events were added to the last PREPBUFR rpt read + + integer input_sqn ! sequence number of input PREPBUFR report for which we + ! are attempting to add events + +, input_sqn_last ! sequence number of previous PREPBUFR report for which + ! we had attempted to add events + real*8 input_alat ! latitude of input PREPBUFR report for which we are + ! attempting to add events + +, input_alon ! longitude of input PREPBUFR report for which we are + ! attempting to add events + real input_ht_ft ! altitude of input PREPBUFR report for which we are + ! attempting to add events + +, input_dhr ! ob time - cycle time in decimal hours + + integer input_idt ! ob time - cycle time in seconds of input PREPBUFR + ! report for which we are attempting to add events + +, input_typ ! PREPBUFR report type for input report for which we are + ! attempting to add events + logical l_badrpt_p ! T = pressure/altitude is bad per NRLACQC info (c_qc) + +, l_badrpt_z ! T = pressure/altitude is bad per NRLACQC info (c_qc) + +, l_badrpt_t ! T = temperature is bad per NRLACQC info (c_qc) + +, l_badrpt_q ! T = moisture is bad per NRLACQC info (c_qc) + +, l_badrpt_w ! T = wind is bad per NRLACQC info (c_qc) + + logical l_duprpt ! T = report is marked as a duplicate per NRLACQC info + ! (c_qc(1:1)=D/d) + + integer ipqm_topstk ! event PQM at top of stack before adding any events + ! containing info from NRLACQC + +, izqm_topstk ! event ZQM at top of stack before adding any events + ! containing info from NRLACQC + +, itqm_topstk ! event TQM at top of stack before adding any events + ! containing info from NRLACQC + +, iqqm_topstk ! event QQM at top of stack before adding any events + ! containing info from NRLACQC + +, iwqm_topstk ! event WQM at top of stack before adding any events + ! containing info from NRLACQC + + integer ipqm_nrlacqc ! value for pressure q.m. (PQM) returned from tranQCflags + +, iprc_nrlacqc ! value for pressure r.c. (PRC) returned from tranQCflags + +, izqm_nrlacqc ! value for altitude q.m. (ZQM) returned from tranQCflags + +, izrc_nrlacqc ! value for altitude r.c. (ZRC) returned from tranQCflags + +, itqm_nrlacqc ! value for temperature q.m. (TQM) returned from tranQCflags + +, itrc_nrlacqc ! value for temperature r.c. (TRC) returned from tranQCflags + +, iqqm_nrlacqc ! value for moisture q.m. (QQM) returned from tranQCflags + +, iqrc_nrlacqc ! value for moisture r.c. (QRC) returned from tranQCflags + +, iwqm_nrlacqc ! value for wind q.m. (WQM) returned from tranQCflags + +, iwrc_nrlacqc ! value for wind r.c. (WRC) returned from tranQCflags + +c Event counters +c -------------- + integer nevrd(5) + integer nevwrt(5) ! number of [p,z,t,q,w] events written to output PREPBUFR + ! file + integer nev_noupd(5) ! number of subsets from input PREPBUFR file with no + ! updated [p,z,t,q,w] event + integer qm_knt(5,0:15,0:15) ! count of [p,z,t,q,w] NCEP quality marks changed from i + ! (input PREPBUFR value) to j (output PREPBUFR value) + ! by NRLACQC + integer p_qm_knt_tot ! total number of pressure QMs (and therefore events) + ! added to the output PREPBUFR file + +, z_qm_knt_tot ! total number of altitude QMs (and therefore events) + ! added to the output PREPBUFR file + +, t_qm_knt_tot ! total number of temperature QMs (and therefore events) + ! added to the output PREPBUFR file + +, q_qm_knt_tot ! total number of moisture QMs (and therefore events) + ! added to the output PREPBUFR file + +, w_qm_knt_tot ! total number of wind QMs (and therefore events) + ! added to the output PREPBUFR file + + integer npqm_msg_in ! number of PQM that are missing in input PREPBUFR file + +, npqm_msg_out ! number of PQM that are missing in output PREPBUFR file + +, nzqm_msg_in ! number of ZQM that are missing in input PREPBUFR file + +, nzqm_msg_out ! number of ZQM that are missing in output PREPBUFR file + +, ntqm_msg_in ! number of TQM that are missing in input PREPBUFR file + +, ntqm_msg_out ! number of TQM that are missing in output PREPBUFR file + +, nqqm_msg_in ! number of QQM that are missing in input PREPBUFR file + +, nqqm_msg_out ! number of QQM that are missing in output PREPBUFR file + +, nwqm_msg_in ! number of WQM that are missing in input PREPBUFR file + +, nwqm_msg_out ! number of WQM that are missing in output PREPBUFR file + +c Switches controlling processing (read in from namelist in main program) +c ----------------------------------------------------------------------- + real trad ! Time window radius for outputting reports (if l_otw=T) + logical l_otw ! T=eliminate reports outside cycle time window radius (trad) + +, l_nhonly ! T=filter out obs outside tropics and Northern Hemisphere + +, l_qmwrite ! T=write NRL quality marks F=skip it (use with old BUFR formats) + +c Counters + integer elim_knt(2,3) ! Count of input PREPBUFR reports (subsets) eliminated from + ! write to output PREPBUFR file, and those kept for write to + ! output PREPBUFR file - + ! first index, message type: 1 - AIRCFT, 2 - AIRCAR + ! second index: + ! 1 - # of reports (subsets) eliminated due to being + ! outside time window radius (prior to any + ! geographical domain checking) + ! 2 - # of reports (subsets) eliminated due to being + ! outside geographical domain (had passed time window + ! radius check) + ! 3 - # of reports (subsets) passing both time window + ! radius and geographical domain checks and thus + ! retained for processing into output PREPBUFR file + + +c Variables to add NRLACQC quality marks to reports +c ------------------------------------------------- + character*11 c_nrlqm ! variable used to store NRLACQC quality marks + ! in output PREPBUFR file + +c MISC +c ---- + real nrlacqc_pc ! PREPBUFR program code for the NRLACQC step + + logical l_skip ! If true, skip block of code, otherwise exectute block of code + logical l_hit_limit! If true, hit limit for number of reports that can be QC'd + + integer i_hit_limit_first ! flag indicating whether l_hit_limit has occurred prior + ! to this point (if yes, = 1; if no, = 0) + +c ******************************************************************* + +c Initialize variables +c -------------------- + nevwrt = 0 + ninssrd = 0 + ncep_qm_p = 9999 + ncep_rc_p = 9999 + ncep_qm_z = 9999 + ncep_rc_z = 9999 + ncep_qm_t = 9999 + ncep_rc_t = 9999 + ncep_qm_q = 9999 + ncep_rc_q = 9999 + ncep_qm_w = 9999 + ncep_rc_w = 9999 + ncep_rej = 0 + elim_knt = 0 + + i_hit_limit_first = 0 + + npqm_msg_in = 0 + npqm_msg_out = 0 + nzqm_msg_in = 0 + nzqm_msg_out = 0 + ntqm_msg_in = 0 + ntqm_msg_out = 0 + nqqm_msg_in = 0 + nqqm_msg_out = 0 + nwqm_msg_in = 0 + nwqm_msg_out = 0 + + p_qm_knt_tot = 0 + z_qm_knt_tot = 0 + t_qm_knt_tot = 0 + q_qm_knt_tot = 0 + w_qm_knt_tot = 0 + + nevrd = 0 + nev_noupd = 0 + qm_knt = 0 + +c Start subroutine +c ---------------- + write(*,*) + write(*,*) '******************************' + write(*,*) 'Welcome to output_acqc_noprof.' + call system('date') + write(*,*) '******************************' + write(*,*) + +c ---------------------------------------------------------------------- +c Translate NRLACQC flags to NCEP events and add events to PREPBUFR file +c ---------------------------------------------------------------------- + l_eventupdate = .false. + + print * + print *, 'Input/Output PREPBUFR files are open.' + print * + print *, 'Reading input PREPBUFR file...' + print *, 'Applying NRLACQC events to reports...' + + QCdrptsidx = 0 ! starting point for QC'd data arrays' index + input_sqn_last = -99 ! initial value for last report's sequence number (ensures no + ! match for first report read in) + + l_hit_limit = .false. + + do while(ireadmg(inlun,mesgtype,mesgdate).eq.0) + + if(mesgtype.ne.'AIRCFT'.and.mesgtype.ne.'AIRCAR') then + if(l_eventupdate) then ! need to close leftover AIRCAR or AIRCFT message originally + ! opened by openmb before copymg can copy over an entire + ! message from input to output + call closmg(outlun) + l_eventupdate = .false. + endif + + call copymg(inlun,outlun) ! for non-aircraft BUFR messages, just copy to output + else + do while(ireadsb(inlun).eq.0) + +c Initialize variables +c -------------------- + ipqm_topstk = 9999 + izqm_topstk = 9999 + itqm_topstk = 9999 + iqqm_topstk = 9999 + iwqm_topstk = 9999 + + ninssrd = ninssrd + 1 ! number of input subsets read + +c Unpack lat/lon, altitude, ob time, report type and sequence number - will be used to make +c sure PREPBUFR and QC'd obs are lining up OK +c ----------------------------------------------------------------------------------------- + call ufbint(inlun,arr_8,10,10,nlev, + + 'YOB XOB ELV DHR TYP SQN SID') + + input_alat = arr_8(1,1) + input_alon = arr_8(2,1) + input_ht_ft = nint(arr_8(3,1)*m2ft) + input_dhr = arr_8(4,1) + input_idt = nint(arr_8(4,1)*3600.) + input_typ = nint(arr_8(5,1)) + input_sqn = nint(arr_8(6,1)) + if(input_sqn.ne.input_sqn_last) then + +c This input report's sequence number is different that that for the previous report read in +c - we are at the next report in the QC'd data arrays so increment index QCdrptsidx by 1 + QCdrptsidx = QCdrptsidx + 1 +ccccc if(QCdrptsidx.eq.47955) print *,'WE ARE AT ',QCdrptsidx,'!' + + if(QCdrptsidx.gt.nrpts4QC_pre) then + +c .... the number of merged mass + wind reports read in from the input (non-QC'd) PREPBUFR +c file exceeds the number of reports QC'd in acftobs_qc - likely due to there being more +c than "max_reps" merged aircraft reports in the input PREPBUFR file -- in this case no +c more input PREPBUFR aircraft reports can be QC'd - all remaining reports in input +c PREPBUFR file will be copied to output PREPBUFR file but they will not be QC'd + if(i_hit_limit_first.eq.0) then + print * + print *, '#####VVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVVV' + print *, 'WARNING: QD''d data array index exceeds ', + + 'the limit of ', nrpts4QC_pre,' - no more reports ', + + 'can be QC''d' + print *, '#####^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^' + print * + endif + i_hit_limit_first = 1 + l_hit_limit = .true. + go to 3400 + endif + + if(QCdrptsidx.gt.1) then + if(c_qc(QCdrptsidx-1)(2:2).eq.'R'.or. ! time rehabilitated + + c_qc(QCdrptsidx-1)(3:3).eq.'R'.or. ! latitude rehabilitated + + c_qc(QCdrptsidx-1)(4:4).eq.'R'.or. ! longitude rehabilitated + + c_qc(QCdrptsidx-1)(5:5).eq.'R'.or. ! pressure/altitude rehabilitated + + c_qc(QCdrptsidx-1)(6:6).eq.'R'.or. ! temperature rehabilitated + + c_qc(QCdrptsidx-1)(5:5).eq.'r') print 65 ! pressure/altitude rehabilitated + 65 format(131('^')) ! print ^^^ at end of report + endif + if(c_qc(QCdrptsidx)(2:2).eq.'R'.or. ! time rehabilitated + + c_qc(QCdrptsidx)(3:3).eq.'R'.or. ! latitude rehabilitated + + c_qc(QCdrptsidx)(4:4).eq.'R'.or. ! longitude rehabilitated + + c_qc(QCdrptsidx)(5:5).eq.'R'.or. ! pressure/altitude rehabilitated + + c_qc(QCdrptsidx)(6:6).eq.'R'.or. ! temperature rehabilitated + + c_qc(QCdrptsidx)(5:5).eq.'r') then ! pressure/altitude rehabilitated + print 61 ! print ^^^ at beginning of report + 61 format(131('v')) + if(c_qc(QCdrptsidx)(2:2).eq.'R') then + +c Case where time was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------ + print 62, QCdrptsidx,arr_8(7,1),input_alat, + + input_alon,input_dhr,nint(arr_8(3,1)), + + c_qc(QCdrptsidx) + 62 format(' TIME rehabilitated: input rpt # ',i6,': id ',A8, + + ', lat ',f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6, + + ', NRLQMS "',A11,'"') + print 63, input_dhr,input_idt + 63 format(' INPUT time from PRE-QC PREPBUFR file [DHR,idt(sec)] ', + + 'is: ',f10.5,i8) + print 64, idt(QCdrptsidx)/3600.,idt(QCdrptsidx) + 64 format(' REHABILITATED time from acftobs_qc [DHR,idt(sec)] ', + + 'is: ',f10.5,i8) + endif + if(c_qc(QCdrptsidx)(3:3).eq.'R') then + +c Case where latitude was rehabiltated by NRLACQC, make note of it +c ---------------------------------------------------------------- + print 72, QCdrptsidx,arr_8(7,1),input_alat, + + input_alon,input_dhr,nint(arr_8(3,1)), + + c_qc(QCdrptsidx) + 72 format(' LAT rehabilitated: input rpt # ',i6,': id ',A8, + + ', lat ',f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6, + + ', NRLQMS "',A11,'"') + print 73, input_alat + 73 format(' INPUT latitude from PRE-QC PREPBUFR file (YOB) is: ', + + f9.5) + print 74, alat(QCdrptsidx) + 74 format(' REHABILITATED latitude from acftobs_qc (YOB) is: ', + + f9.5) + endif + if(c_qc(QCdrptsidx)(4:4).eq.'R') then + +c Case where longitude was rehabiltated by NRLACQC, make note of it +c ----------------------------------------------------------------- + print 82, QCdrptsidx,arr_8(7,1),input_alat, + + input_alon,input_dhr,nint(arr_8(3,1)), + + c_qc(QCdrptsidx) + 82 format(' LON rehabilitated: input rpt # ',i6,': id ',A8, + + ', lat ',f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6, + + ', NRLQMS "',A11,'"') + print 83, input_alon + 83 format(' INPUT longitude from PRE-QC PREPBUFR file (XOB) is: ', + + f9.5) + print 84, alon(QCdrptsidx) + 84 format(' REHABILITATED longitude from acftobs_qc (XOB) is: ', + + f9.5) + endif + if(c_qc(QCdrptsidx)(5:5).eq.'R'.or. + + c_qc(QCdrptsidx)(5:5).eq.'r') then + +c Case where pressure/altitude was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------------------- + print 92, QCdrptsidx,arr_8(7,1),input_alat, + + input_alon,input_dhr,nint(arr_8(3,1)), + + c_qc(QCdrptsidx) + 92 format(' P/A rehabilitated: input rpt # ',i6,': id ',A8, + + ', lat ',f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6, + + ', NRLQMS "',A11,'"') + print 93 + 93 format(' %%%%%%%%%%'/' %%%%% WARNING: Currently not accounted ', + + 'for in output PREPBUFR file'/' %%%%%%%%%%') + endif + if(c_qc(QCdrptsidx)(6:6).eq.'R') then + +c Case where temperature was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------------- + print 102, QCdrptsidx,arr_8(7,1),input_alat, + + input_alon,input_dhr,nint(arr_8(3,1)), + + c_qc(QCdrptsidx) + 102 format(' TMP rehabilitated: input rpt # ',i6,': id ',A8, + + ', lat ',f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6, + + ', NRLQMS "',A11,'"') + print 93 + endif + endif ! if any rehabilitated + endif ! if(input_sqn.ne.input_sqn_last) + + dhr_corr = bmiss + yob_corr = bmiss + xob_corr = bmiss + if(c_qc(QCdrptsidx)(2:2).eq.'R') then ! Rehabilitated time + dhr_corr(1) = idt(QCdrptsidx)/3600. ! Store updated d-time (DHR) + dhr_corr(2) = 3 ! Set correction indicator (TCOR) to 3 + ! Original time already stored in RPT + input_idt = idt(QCdrptsidx) ! Prevents match check below from failing + input_dhr = idt(QCdrptsidx)/3600. ! Allows time window check below to use + ! rehabilitated time + endif + if(c_qc(QCdrptsidx)(3:3).eq.'R') then ! Rehabilitated latitude + yob_corr(1) = alat(QCdrptsidx) ! Store updated latitude (YOB) + yob_corr(2) = 3 ! Set correction indicator (YCOR) to 3 + yob_corr(3) = input_alat ! Store original latitude (YORG) + input_alat = alat(QCdrptsidx) ! Prevents match check below from failing + ! and allows geographic domain check below + ! to use rehabilitated latitude + endif + if(c_qc(QCdrptsidx)(4:4).eq.'R') then ! Rehabilitated longitude + xob_corr(1) = alon(QCdrptsidx) ! Store updated longitude (XOB) + xob_corr(2) = 3 ! Set correction indicator (XCOR) to 3 + xob_corr(3) = input_alon ! Store original longitude (XORG) + input_alon = alon(QCdrptsidx) ! Prevents match check below from failing + ! and allows geographic domain check below + ! to use rehabilitated longitude + endif + + input_sqn_last = input_sqn + +c At every 10,000'th QC'd (merged mass + wind) aircraft-type report and at last report, test +c its lat/lon, time and altitude against corresponding PREPBUFR report values - if values DO +c NOT match, PROBLEM!!! +c ------------------------------------------------------------------------------------------- + if(mod(QCdrptsidx,10000).eq.0.or. + + QCdrptsidx.eq.nrpts4QC_pre) then + print *, 'ipoint match check at report # ',QCdrptsidx + if(alat(QCdrptsidx).ne.input_alat .or. + + alon(QCdrptsidx).ne.input_alon .or. + + ht_ft(QCdrptsidx).ne.input_ht_ft .or. + + idt(QCdrptsidx).ne. input_idt) then + print *, 'NO MATCH AT QCdrptsidx = ',QCdrptsidx + print'(" Indexing problem... could not find the ", + + "current input PREPBUFR report in the report-", + + "oriented arrays.")' + print *, 'EXITING PROGRAM.' + + call w3tage('PREPOBS_PREPACQC') + call errexit(31) + endif + print *, 'MATCH AT QCdrptsidx = ',QCdrptsidx + endif + + 3400 continue + +c Before processing this input PREPBUFR report (subset) any further, make sure it is within +c the requested time window (defined by namelist switch trad) and it is within the requested +c geographical domain (here north of 20S latitude, if namelist switch l_nhonly is true) +c ------------------------------------------------------------------------------------------- + + if(l_otw) then ! check if report (subset) is outside time window (prior to any + ! geographical domain checking) + if(input_dhr.lt.-trad.or.input_dhr.gt.trad) then + if(mesgtype.eq.'AIRCFT') then + elim_knt(1,1) = elim_knt(1,1) + 1 + elseif(mesgtype.eq.'AIRCAR') then + elim_knt(2,1) = elim_knt(2,1) + 1 + endif + if(.not.l_hit_limit) then + ncep_rej(QCdrptsidx) = 1 + endif + cycle ! don't write this subset to output file, move on to next subset + endif + endif + + if(l_nhonly) then ! if report (subset) passed time window radius check, then + ! check to see if it is outside geographical domain (i.e., + ! south of 20S) + if(input_alat.lt.-20.0) then + if(mesgtype.eq.'AIRCFT') then + elim_knt(1,2) = elim_knt(1,2) + 1 + elseif(mesgtype.eq.'AIRCAR') then + elim_knt(2,2) = elim_knt(2,2) + 1 + endif + if(.not.l_hit_limit) then + ncep_rej(QCdrptsidx) = 1 + endif + cycle ! don't write this subset to output file, move on to next subset + endif + endif + +c Counter for number of PREPBUFR reports (subsets) kept +c ----------------------------------------------------- + if(mesgtype.eq.'AIRCFT') then + elim_knt(1,3) = elim_knt(1,3) + 1 + elseif(mesgtype.eq.'AIRCAR') then + elim_knt(2,3) = elim_knt(2,3) + 1 + endif + +c If the report passes the time window and geographic domain checks, copy the subset to the +c output PREPBUFR file in anticipation of adding events +c ----------------------------------------------------------------------------------------- + call openmb(outlun,mesgtype,mesgdate) + + call ufbcpy(inlun,outlun) + + if(l_hit_limit) then + +c If this subset exceeds the "max_rep" limit, don't attempt to add QC to it because there is +c none, instead just write subset to the output PREPBUFR file and move on to next subset +c (which won't be QC'd either) +c------------------------------------------------------------------------------------------- + + call writsb(outlun) + cycle + endif + + if(c_qc(QCdrptsidx)(2:2).eq.'R') then + +c Encode rehabilitated time and time correction indicator +c ------------------------------------------------------- + print 66, dhr_corr,input_typ,QCdrptsidx + 66 format(' ENCODE REHABILITATED time ',f10.5, ' as DHR with TCOR=', + + f3.0,' into PREPBUFR file, rtyp = ',i3,', for input report # ', + + i8) + call ufbint(outlun,dhr_corr,2,1,iret,'DHR TCOR') + endif + if(c_qc(QCdrptsidx)(3:3).eq.'R') then + +c Encode rehabilitated latitude, latitude correction indicator and original latitude +c ---------------------------------------------------------------------------------- + print 76, yob_corr,input_typ,QCdrptsidx + 76 format(' ENCODE REHABILITATED latitude ',f9.5, ' as YOB with ', + + 'YCOR=',f3.0,' and YORG=',f9.5,' into PREPBUFR file, rtyp = ',i3, + + ', for input rpt # ',i8) + call ufbint(outlun,yob_corr,3,1,iret,'YOB YCOR YORG') + endif + if(c_qc(QCdrptsidx)(4:4).eq.'R') then + +c Encode rehabilitated longitude, longitude correction indicator and original longitude +c ------------------------------------------------------------------------------------- + print 86, xob_corr,input_typ,QCdrptsidx + 86 format(' ENCODE REHABILITATED longitude ',f9.5, ' as XOB with ', + + 'XCOR=',f3.0,' and XORG=',f9.5,' into PREPBUFR file, rtyp = ',i3, + + ', for input rpt # ',i8) + call ufbint(outlun,xob_corr,3,1,iret,'XOB XCOR XORG') + endif + +c If the input PREPBUFR report is a mass report, update the event stack with mass events +c +c If the input PREPBUFR report is a wind rpt, update the event stack with wind events +c +c Also, first initialize the "bad report", "suspect report", and "duplicate report" flags as +c false - these flags will be set to true if the NRLACQC quality information (array c_qc) +c indicates that the report or any part of it is bad, suspect or a duplicate +c ------------------------------------------------------------------------------------------ + l_badrpt_p = .false. + l_badrpt_z = .false. + l_badrpt_t = .false. + l_badrpt_q = .false. + l_badrpt_w = .false. + + l_duprpt = .false. + +c Pressure +c -------- + +c Get POB and PQM at top of stack coming in and store in array p_event, translate NRLACQC +c quality flags in c_qc to NCEP standards for pressure and store in ipqm_nrlacqc, also store +c reason code in iprc_nrlacqc (pressure data apply to both mass and wind obs) +c ------------------------------------------------------------------------------------------- + call ufbint(inlun,p_event,4,1,nlev,'POB PQM') +ccccc if(QCdrptsidx.eq.47955) print *,'input p_event = ',p_event + nevrd(1) = nevrd(1) + 1 + + if(ibfms(p_event(2)).eq.0) then + if(nint(p_event(2)).ge.0.and.nint(p_event(2)).le.15) then +c PQM for event at top of stack (prior to adding any NRLACQC events) + ipqm_topstk = nint(p_event(2)) + else + npqm_msg_in = npqm_msg_in + 1 + endif + else + npqm_msg_in = npqm_msg_in + 1 + endif + +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'prior to tranQCflags p_event = ',p_event + call tranQCflags(c_qc(QCdrptsidx),'p',ipqm_nrlacqc, + + iprc_nrlacqc,l_badrpt_p,l_duprpt) + +c if PQM = 2 and PRC = 099 returned from tranQCflags, then can't translate! + if(ipqm_nrlacqc.eq.2 .and. iprc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc flag on pressure/altitude:', + + c_qc(QCdrptsidx)(5:5) + print *, 'PREPBUFR aircraft report number: ',ninssrd + print *, 'QC ob array index: ',QCdrptsidx + print * + endif +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'after call to tranQCflags PQM, PRC = ', +ccccc+ ipqm_nrlacqc,iprc_nrlacqc + +c Altitude +c -------- + +c Get ZOB and ZQM at top of stack coming in and store in array z_event, translate NRLACQC +c quality flags in c_qc to NCEP standards for altitude and store in izqm_nrlacqc, also store +c reason code in izrc_nrlacqc (altitude applies to both mass and wind obs) +c +c Use same quality marks for altitude as were used for pressure - NRLACQC has one flag for +c both (c_qc(5:5)) +c ------------------------------------------------------------------------------------------- + call ufbint(inlun,z_event,4,1,nlev,'ZOB ZQM') + nevrd(2) = nevrd(2) + 1 + + if(ibfms(z_event(2)).eq.0) then + if(nint(z_event(2)).ge.0.and.nint(z_event(2)).le.15) then +c ZQM for event at top of stack (prior to adding any NRLACQC events) + izqm_topstk = nint(z_event(2)) + else + nzqm_msg_in = nzqm_msg_in + 1 + endif + else + nzqm_msg_in = nzqm_msg_in + 1 + endif + + call tranQCflags(c_qc(QCdrptsidx),'z',izqm_nrlacqc, + + izrc_nrlacqc,l_badrpt_z,l_duprpt) + +c if ZQM = 2 and ZRC = 099 returned from tranQCflags, then can't translate! + if(izqm_nrlacqc.eq.2 .and. izrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc flag on pressure/altitude:', + + c_qc(QCdrptsidx)(5:5) + print *, 'PREPBUFR aircraft report number: ',ninssrd + print *, 'QC ob array index: ',QCdrptsidx + print * + endif + +c If the input PREPBUFR report is a mass report, then see if we need to add an event for +c temperature and moisture - if the input PREPBUFR report is a wind report, then see if we +c need to add an event for wind +c ----------------------------------------------------------------------------------------- + + if(int(input_typ/100).eq.1) then + +c ----------- +c MASS REPORT +c ----------- + +c Temperature +c ----------- + +c Get TOB and TQM at top of stack coming in and store in array t_event, translate NRLACQC +c quality flags in c_qc to NCEP standards for temperature and store in itqm_nrlacqc, also +c store reason code in itrc_nrlacqc +c ---------------------------------------------------------------------------------------- + call ufbint(inlun,t_event,4,1,nlev,'TOB TQM') +ccccc if(QCdrptsidx.eq.47955) print *,'input t_event = ',t_event + nevrd(3) = nevrd(3) + 1 + + if(ibfms(t_event(2)).eq.0) then + if(nint(t_event(2)).ge.0.and.nint(t_event(2)).le.15)then +c TQM for event at top of stack (prior to adding any NRLACQC events) + itqm_topstk = nint(t_event(2)) + else + ntqm_msg_in = ntqm_msg_in + 1 + endif + else + ntqm_msg_in = ntqm_msg_in + 1 + endif + +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'prior to tranQCflags t_event = ',t_event + call tranQCflags(c_qc(QCdrptsidx),'t',itqm_nrlacqc, + + itrc_nrlacqc,l_badrpt_t,l_duprpt) + +c if TQM = 2 and TRC = 099 returned from tranQCflags, then can't translate! + if(itqm_nrlacqc.eq.2 .and. itrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc flag on temperature:', + + c_qc(QCdrptsidx)(6:6) + print *, 'PREPBUFR aircraft report number: ',ninssrd + print *, 'QC ob array index: ',QCdrptsidx + print * + endif +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'after call to tranQCflags TQM, TRC = ', +ccccc+ itqm_nrlacqc,itrc_nrlacqc + + +c Moisture +c -------- + +c Get QOB and QQM at top of stack coming in and store in array q_event, translate NRLACQC +c quality flags in c_qc to NCEP standards for moisture and store in iqqm_nrlacqc, also store +c reason code in iqrc_nrlacqc +c ------------------------------------------------------------------------------------------- + call ufbint(inlun,q_event,4,1,nlev,'QOB QQM') + nevrd(4) = nevrd(4) + 1 + + if(ibfms(q_event(2)).eq.0) then + if(nint(q_event(2)).ge.0.and.nint(q_event(2)).le.15)then +c QQM for event at top of stack (prior to adding any NRLACQC events) + iqqm_topstk = nint(q_event(2)) + else + nqqm_msg_in = nqqm_msg_in + 1 + endif + else + nqqm_msg_in = nqqm_msg_in + 1 + endif + + call tranQCflags(c_qc(QCdrptsidx),'q',iqqm_nrlacqc, + + iqrc_nrlacqc,l_badrpt_q,l_duprpt) + +c if QQM = 2 and QRC = 099 returned from tranQCflags, then can't translate! + if(iqqm_nrlacqc.eq.2 .and. iqrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc flag on moisture:', + + c_qc(QCdrptsidx)(9:9) + print *, 'PREPBUFR aircraft report number: ',ninssrd + print *, 'QC ob array index: ',QCdrptsidx + print * + endif + + elseif(int(input_typ/100).eq.2) then + +c ----------- +c WIND REPORT +c ----------- + +c Wind +c ---- + +c Get UOB, VOB and WQM at top of stack coming in and store in array w_event, translate +c NRLACQC quality flags in c_qc to NCEP standards for wind and store in iwqm_nrlacqc, also +c store reason code in iwrc_nrlacqc +c ----------------------------------------------------------------------------------------- + call ufbint(inlun,w_event,5,1,nlev,'UOB VOB WQM') + nevrd(5) = nevrd(5) + 1 + + if(ibfms(w_event(3)).eq.0) then + if(nint(w_event(3)).ge.0.and.nint(w_event(3)).le.15)then +c WQM for event at top of stack (prior to adding any NRLACQC events) + iwqm_topstk = nint(w_event(3)) + else + nwqm_msg_in = nwqm_msg_in + 1 + endif + else + nwqm_msg_in = nwqm_msg_in + 1 + endif + + call tranQCflags(c_qc(QCdrptsidx),'w',iwqm_nrlacqc, + + iwrc_nrlacqc,l_badrpt_w,l_duprpt) + +c if WQM = 2 and WRC = 099 returned from tranQCflags, then can't translate! + if(iwqm_nrlacqc.eq.2 .and. iwrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc flag on wind:', + + c_qc(QCdrptsidx)(7:7),'/',c_qc(QCdrptsidx)(8:8) + print *, 'PREPBUFR aircraft report number: ',ninssrd + print *, 'QC ob array index: ',QCdrptsidx + print * + endif + + endif ! int(input_typ/100) = 1 or 2 + +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'prior to entire rpt rej PQM, PRC = ', +ccccc+ ipqm_nrlacqc,iprc_nrlacqc + +c If entire report is to be rejected, put reject flags (QM=13) on pressure, altitude, +c temperature, moisture, and wind +c ----------------------------------------------------------------------------------- + if(l_badrpt_p .or. l_badrpt_z .or. + + l_badrpt_t .or. l_badrpt_q .or. l_badrpt_w) then + +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *, 'we are in reject report logic' + + ipqm_nrlacqc = 13 ! PQM + ! PRC already encoded into iprc_nrlacqc in subr. tranQCflags + + izqm_nrlacqc = 13 ! ZQM + ! ZRC already encoded into izrc_nrlacqc in subr. tranQCflags + + if(int(input_typ/100).eq.1) then + itqm_nrlacqc = 13 ! TQM + ! TRC already encoded into itrc_nrlacqc in subr. tranQCflags + + iqqm_nrlacqc = 13 ! QQM + ! QRC already encoded into iqrc_nrlacqc in subr. tranQCflags + + elseif(int(input_typ/100).eq.2) then + + iwqm_nrlacqc = 13 ! WQM + ! WRC already encoded into iwrc_nrlacqc in subr. tranQCflags + + endif ! int(input_typ/100) = 1 or 2 + endif ! l_badrpt_[p,z,t,q,w] + +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'after entire rpt rej PQM, PRC = ', +ccccc+ ipqm_nrlacqc,iprc_nrlacqc + +c If report is marked as a duplicate (c_qc(1:1) = d or D), then mark the entire report with +c a bad NCEP quality mark (=13) +c ----------------------------------------------------------------------------------------- + if(l_duprpt) then + ipqm_nrlacqc = 13 ! PQM + ! PRC already encoded into iprc_nrlacqc in subr. tranQCflags + + izqm_nrlacqc = 13 ! ZQM + ! ZRC already encoded into izrc_nrlacqc in subr. tranQCflags + + if(int(input_typ/100).eq.1) then + itqm_nrlacqc = 13 ! TQM + ! TRC already encoded into itrc_nrlacqc in subr. tranQCflags + + iqqm_nrlacqc = 13 ! QQM + ! QRC already encoded into iqrc_nrlacqc in subr. tranQCflags + + elseif(int(input_typ/100).eq.2) then + + iwqm_nrlacqc = 13 ! WQM + ! WRC already encoded into iwrc_nrlacqc in subr. tranQCflags + + endif ! int(input_typ/100) = 1 or 2 + endif ! l_duprpt + +c Update pressure, altitude, temperature, moisture and wind stacks with new event in output +c PREPBUFR file when there has been a qualty mark change by NRLACQC (don't need to write out +c an event if quality mark has not been changed by this program) +c +c EXCEPTION: Retain (honor) the incoming quality mark at the top of the stack (i.e., do not +c write event) when: +c +c (1) The incoming quality mark at the top of the stack is 0 (keep flag) +c (2) The incoming quality mark at the top of the stack is between 4 and 15 (bad) - +c except when NRLACQC itself generates a BAD quality mark (translated to NCEP +c value of 13), allows reason code to denote why action taken by NRLACQC to mark +c obs as bad +c (3) The incoming quality mark at the top of the stack is not between 0 and 15 +c (i.e.,missing) +c (4) The incoming quality mark at the top of the stack is 3 (suspect) and the NRLACQC +c generates a GOOD or NEUTRAL or SUSPECT quality mark (translated to NCEP values of +c 1, 2 and 3 resp.) {in other words, unless an ob previously marked as suspect was +c marked bad by NRLACQC, don't change a suspect quality mark assigned by a PREPBUFR +c processing step prior to the NRLACQC step} +c (5) The quality mark translated to its NCEP value is 2 (neutral) and the reason code +c is returned from tranQCflags is 099 - this indicates that the NRLACQC quality +c flags in c_qc pertaining to this ob are unknown to transQCflags (the routine +c tranQCflags may need to be updated to account for the c_qc flags that is coming +c out of the NRLACQC QC routine for this ob - this would probably only happen if +c NRL provides an updated/upgraded acftobs_qc module to NCEP) +c (6) The NCEP equivalent of the NRLACQC is the same as the incoming quality mark of +c the stack - if there is no change in the quality mark, then do not add a new +c event and leave the event at the top of the event stack as is with TWO +c exceptions: +c a) NRLACQC itself generates a GOOD quality mark (translated to NCEP value of +c 1) +c b) NRLACQC itself generates a BAD quality mark (translated to NCEP value of +c 13) (see 2 above for more on this) +c ------------------------------------------------------------------------------------------- + +c Pressure +c -------- +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'prior to writing ? event p_event = ',p_event(1), +ccccc+ ipqm_nrlacqc,p_event(3),iprc_nrlacqc + + l_skip = .true. ! SKIP LOGIC TO WRITE PRESSURE EVENTS - there is no need to do so + ! since pressure is a vertical coordinate and it is not analyzed, + ! in addition, adding pressure events complicates reason code + ! logic + + if(.not.l_skip) then + +c .... if here, include logic to write pressure events + if(ipqm_topstk.eq.0 .or. + + (ipqm_topstk.ge.4 .and. ipqm_topstk.le.15) .or. ! ob has already been marked + ! bad by NCEP codes + + ipqm_topstk.eq.9999 .or. + + (ipqm_topstk.eq.3.and.ipqm_nrlacqc.le.3) .or. + + (ipqm_nrlacqc.eq.2.and.iprc_nrlacqc.eq.099) .or. + + (ipqm_topstk.eq.ipqm_nrlacqc.and.ipqm_nrlacqc.ne.1) + + ) then ! no event needed; leave PQM as is + + ipqm_nrlacqc = ipqm_topstk + + nev_noupd(1) = nev_noupd(1) + 1 + else ! NRL QC produced an event; add this event to top of stack in output + ! PREPBUFR file + p_event(2) = ipqm_nrlacqc + p_event(3) = nrlacqc_pc + p_event(4) = iprc_nrlacqc + call ufbint(outlun,p_event,4,1,iret,'POB PQM PPC PRC') ! pressure & altitude + ! apply to both mass + ! & wind + nevwrt(1) = nevwrt(1) + 1 + ncep_rc_p(QCdrptsidx) = iprc_nrlacqc +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'after writing event p_event = ',p_event +ccccc if(QCdrptsidx.eq.47955) print *,'after writing event ', +ccccc+ ncep_rc_p = ',ncep_rc_p(QCdrptsidx) + endif +ccccc if(QCdrptsidx.eq.47955) print *,'after writing event ', +ccccc+ ncep_qm_p = 'ncep_qm_p(QCdrptsidx) + + if((ipqm_nrlacqc.ge.0.and.ipqm_nrlacqc.le.15).and. + + (ipqm_topstk.ge.0.and.ipqm_topstk.le.15)) then + ncep_qm_p(QCdrptsidx) = ipqm_nrlacqc + qm_knt(1,ipqm_topstk,ipqm_nrlacqc) = + + qm_knt(1,ipqm_topstk,ipqm_nrlacqc) + 1 + else + npqm_msg_out = npqm_msg_out + 1 + endif + + else + +c .... if here, SKIP logic to write pressure events + ipqm_nrlacqc = ipqm_topstk + nev_noupd(1) = nev_noupd(1) + 1 + if((ipqm_nrlacqc.ge.0.and.ipqm_nrlacqc.le.15).and. + + (ipqm_topstk.ge.0.and.ipqm_topstk.le.15)) then + ncep_qm_p(QCdrptsidx) = ipqm_nrlacqc + qm_knt(1,ipqm_topstk,ipqm_nrlacqc) = + + qm_knt(1,ipqm_topstk,ipqm_nrlacqc) + 1 + else + npqm_msg_out = npqm_msg_out + 1 + endif + + endif + +c Altitude +c -------- + + l_skip = .true. ! SKIP LOGIC TO WRITE ALTITUDE EVENTS - there is no need to do so + ! since altitude is a vertical coordinate and it is not analyzed, + ! in addition, adding altitude events complicates reason code + ! logic + + if(.not.l_skip) then + +c .... if here, include logic to write altitude events + if(izqm_topstk.eq.0 .or. + + (izqm_topstk.ge.4 .and. izqm_topstk.le.15) .or. ! ob has already been marked + ! bad by NCEP codes + + izqm_topstk.eq.9999 .or. + + (izqm_topstk.eq.3.and.izqm_nrlacqc.le.3) .or. + + (izqm_nrlacqc.eq.2.and.izrc_nrlacqc.eq.099) .or. + + (izqm_topstk.eq.izqm_nrlacqc.and.izqm_nrlacqc.ne.1) + + ) then ! no event needed; leave ZQM as is + izqm_nrlacqc = izqm_topstk + + nev_noupd(2) = nev_noupd(2) + 1 + else ! NRL QC produced an event; add this event to top of stack in output + ! PREPBUFR file + z_event(2) = izqm_nrlacqc + z_event(3) = nrlacqc_pc + z_event(4) = izrc_nrlacqc + call ufbint(outlun,z_event,4,1,iret,'ZOB ZQM ZPC ZRC') ! pressure & altitude + ! apply to both mass + ! & wind + nevwrt(2) = nevwrt(2) + 1 + ncep_rc_z(QCdrptsidx) = izrc_nrlacqc + endif + + if((izqm_nrlacqc.ge.0.and.izqm_nrlacqc.le.15).and. + + (izqm_topstk.ge.0.and.izqm_topstk.le.15)) then + ncep_qm_z(QCdrptsidx) = izqm_nrlacqc + qm_knt(2,izqm_topstk,izqm_nrlacqc) = + + qm_knt(2,izqm_topstk,izqm_nrlacqc) + 1 + else + nzqm_msg_out = nzqm_msg_out + 1 + endif + + else + +c .... if here, SKIP logic to write altitude events + izqm_nrlacqc = izqm_topstk + nev_noupd(2) = nev_noupd(2) + 1 + if((izqm_nrlacqc.ge.0.and.izqm_nrlacqc.le.15).and. + + (izqm_topstk.ge.0.and.izqm_topstk.le.15)) then + ncep_qm_z(QCdrptsidx) = izqm_nrlacqc + qm_knt(2,izqm_topstk,izqm_nrlacqc) = + + qm_knt(2,izqm_topstk,izqm_nrlacqc) + 1 + else + nzqm_msg_out = nzqm_msg_out + 1 + endif + + endif + + if(int(input_typ/100).eq.1) then + +c Temperature +c ----------- + +c Obs/Events + if((itqm_topstk.eq.0 .or. + + (itqm_topstk.ge.4 .and. itqm_topstk.le.15) .or. ! ob has already been marked + ! bad by NCEP codes + + itqm_topstk.eq.9999 .or. + + (itqm_topstk.eq.3.and.itqm_nrlacqc.le.3) .or. + + (itqm_nrlacqc.eq.2.and.itrc_nrlacqc.eq.099) .or. + + (itqm_topstk.eq.itqm_nrlacqc.and.itqm_nrlacqc.ne.1) + + ) .and. (itqm_nrlacqc.ne.13.or. + + itqm_topstk.eq.9999)) then ! no event needed; leave TQM as is +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'no t_event written for ',QCdrptsidx + itqm_nrlacqc = itqm_topstk + + nev_noupd(3) = nev_noupd(3) + 1 + + else ! NRL QC produced an event; add this event to top of stack in output + ! PREPBUFR file +ccccc if(QCdrptsidx.eq.47955) +ccccc+ print *,'new t_event written for ',QCdrptsidx + if(int(itrc_nrlacqc/100).eq.9 .and. + + itqm_nrlacqc.eq.13) itqm_nrlacqc = 14 ! if temperature marked bad here + ! due to it being on reject list, + ! reset TQM to 14 + t_event(2) = itqm_nrlacqc + t_event(3) = nrlacqc_pc + t_event(4) = itrc_nrlacqc + call ufbint(outlun,t_event,4,1,iret,'TOB TQM TPC TRC') + nevwrt(3) = nevwrt(3) + 1 + ncep_rc_t(QCdrptsidx) = itrc_nrlacqc + endif + + if((itqm_nrlacqc.ge.0.and.itqm_nrlacqc.le.15).and. + + (itqm_topstk.ge.0.and.itqm_topstk.le.15)) then + ncep_qm_t(QCdrptsidx) = itqm_nrlacqc + qm_knt(3,itqm_topstk,itqm_nrlacqc) = + + qm_knt(3,itqm_topstk,itqm_nrlacqc) + 1 + else + ntqm_msg_out = ntqm_msg_out + 1 + endif + +c Moisture +c -------- + +c Obs/Events + if((iqqm_topstk.eq.0 .or. + + (iqqm_topstk.ge.4 .and. iqqm_topstk.le.15) .or. ! ob has already been marked + ! bad by NCEP codes + + iqqm_topstk.eq.9999 .or. + + (iqqm_topstk.eq.3 .and. iqqm_nrlacqc.le.3) .or. + + (iqqm_nrlacqc.eq.2.and.iqrc_nrlacqc.eq.099) .or. + + (iqqm_topstk.eq.iqqm_nrlacqc.and.iqqm_nrlacqc.ne.1) + + ) .and. (iqqm_nrlacqc.ne.13.or. + + iqqm_topstk.eq.9999)) then ! no event needed; leave QQM as is + iqqm_nrlacqc = iqqm_topstk + + nev_noupd(4) = nev_noupd(4) + 1 + + else ! NRL QC produced a new event; add this event to top of stack in output + ! PREPBUFR file + if(int(iqrc_nrlacqc/100).eq.9 .and. + + iqqm_nrlacqc.eq.13) iqqm_nrlacqc = 14 ! if moisture marked bad here due + ! to temperature being on reject + ! list, reset QQM to 14 + q_event(2) = iqqm_nrlacqc + q_event(3) = nrlacqc_pc + q_event(4) = iqrc_nrlacqc + call ufbint(outlun,q_event,4,1,iret,'QOB QQM QPC QRC') + nevwrt(4) = nevwrt(4) + 1 + ncep_rc_q(QCdrptsidx) = iqrc_nrlacqc + endif + + if((iqqm_nrlacqc.ge.0.and.iqqm_nrlacqc.le.15).and. + + (iqqm_topstk.ge.0.and.iqqm_topstk.le.15))then + ncep_qm_q(QCdrptsidx) = iqqm_nrlacqc + qm_knt(4,iqqm_topstk,iqqm_nrlacqc) = + + qm_knt(4,iqqm_topstk,iqqm_nrlacqc) + 1 + else + nqqm_msg_out = nqqm_msg_out + 1 + endif + + elseif(int(input_typ/100).eq.2) then + +c Wind +C ---- + +c Obs/Events + if((iwqm_topstk.eq.0 .or. + + (iwqm_topstk.ge.4 .and. iwqm_topstk.le.15) .or. ! ob has already been marked + ! bad by NCEP codes + + iwqm_topstk.eq.9999 .or. + + (iwqm_topstk.eq.3 .and. iwqm_nrlacqc.le.3) .or. + + (iwqm_nrlacqc.eq.2.and.iwrc_nrlacqc.eq.099) .or. + + (iwqm_topstk.eq.iwqm_nrlacqc.and.iwqm_nrlacqc.ne.1) + + ) .and. (iwqm_nrlacqc.ne.13.or. + + iwqm_topstk.eq.9999)) then ! no event needed; leave WQM as is + iwqm_nrlacqc = iwqm_topstk + + nev_noupd(5) = nev_noupd(5) + 1 + + else ! NRL QC produced a new event; add this event to top of stack in output + ! PREPBUFR file + if(int(iwrc_nrlacqc/100).eq.9 .and. + + iwqm_nrlacqc.eq.13) iwqm_nrlacqc = 14 ! if wind marked bad here due to it + ! being on reject list, reset WQM + ! to 14 + w_event(3) = iwqm_nrlacqc + w_event(4) = nrlacqc_pc + w_event(5) = iwrc_nrlacqc + call ufbint(outlun,w_event,5,1,iret,'UOB VOB WQM WPC WRC') + nevwrt(5) = nevwrt(5) + 1 + ncep_rc_w(QCdrptsidx) = iwrc_nrlacqc + endif + + if((iwqm_nrlacqc.ge.0.and.iwqm_nrlacqc.le.15).and. + + (iwqm_topstk.ge.0.and.iwqm_topstk.le.15))then + ncep_qm_w(QCdrptsidx) = iwqm_nrlacqc + qm_knt(5,iwqm_topstk,iwqm_nrlacqc) = + + qm_knt(5,iwqm_topstk,iwqm_nrlacqc) + 1 + else + nwqm_msg_out = nwqm_msg_out + 1 + endif + + endif + + l_eventupdate = .true. + +c After updating all event stacks {pressure (maybe), altitude (maybe), temperature, moisture +c and wind), write subset to the output PREPBUFR file - also add NRLACQC quality string to +c this subset, since the string is of length 11 characters, must call WRITLC after call to +c WRITSB +c ------------------------------------------------------------------------------------------ + call writsb(outlun) + +c ***** ----> BUFRLIB routine WRITLC trims the string that is stored, cutting off any blank +c (" ") characters - since blank characters have meaning in the originally- +c defined NRLACQC quality string (usually indicating passed all tests and thus +c good), we earlier (in subroutine acftobs_qc) replaced blank characters with dot +c (".") characters so these would be retained by WRITLC +c ------------------------------------------------------------------------------------------- + c_nrlqm = c_qc(QCdrptsidx) + +ccccc print *, 'in *noprof.f, writing c_nrlqm=', c_nrlqm + + if (l_qmwrite) then + call writlc(outlun,c_nrlqm,'NRLQMS') + end if +c Close loops here +c ---------------- + enddo ! ireadsb + endif ! check for AIRCFT and AIRCAR messages + enddo ! ireadmg + +c Output counts +c ------------- + +c Detailed counts of reports eliminated from final PREPBUFR file +c -------------------------------------------------------------- + print * + print *, '----------------------------------------------------' + print *, 'Info about reports tossed from final PREPBUFR file: ' + print *, '----------------------------------------------------' + print * + if(l_otw) then + print 96, trad,elim_knt(1,1) + 96 format(' Subsets from AIRCFT msgs tossed because outside req. ', + + 'time window radius of',F6.2,'hrs (prior to geographical domain', + + ' chking):',i6) + print 97, trad,elim_knt(2,1) + 97 format(' Subsets from AIRCAR msgs tossed because outside req. ', + + 'time window radius of',F6.2,'hrs (prior to geographical domain', + + ' chking):',i6) + else + print *, 'Time window radius check NOT performed, l_otw=',l_otw, + + ' (ZERO reports tossed)' + endif + print * + if(l_nhonly) then + print'(" Subsets from AIRCFT messages passing time window ", + + "radius check but outside geographical domain (i.e., S ", + + "of 20S lat): ",I0)', elim_knt(1,2) + print'(" Subsets from AIRCAR messages passing time window ", + + "radius check but outside geographical domain (i.e., S ", + + "of 20S lat): ",I0)', elim_knt(2,2) + else + print'(" Geographical domain check not performed, l_nhonly=",L, + + " (ZERO reports tossed)")', l_nhonly + endif + print * + print'(" Number of subsets from AIRCFT messages passing checks ", + + "and kept: ",I0)', elim_knt(1,3) + print'(" Number of subsets from AIRCAR messages passing checks ", + + "and kept: ",I0)', elim_knt(2,3) + print * + print'(" TOTAL NUMBER OF SUBSETS WRITTEN BACK OUT: ",I0)', + + elim_knt(1,3)+elim_knt(2,3) + +c Pressure details +c ---------------- + print * + print *, '***********************' + print *, 'PQM changes/status quo: ' + + print * + print *, 'Input PQM info:' + print *, 'PQMs read from PREPBUFR:',nevrd(1) + print *, 'Obs with MISSING PQMs upon input:',npqm_msg_in + print * + + print *, 'Output PQM info:' + print *, 'PQMs written to output PREPBUFR:',nevwrt(1) + print *, 'Obs with MISSING PQMs (not written to output):', + + npqm_msg_out + print *, 'Obs with NRLACQC QM equal to previous QM (no new ', + + 'event): ',nev_noupd(1) + + print * + print *, 'Non-missing PQM Breakdown:' + do i=0,15 + do j=0,15 + if(qm_knt(1,i,j).ne.0) then + print 50, 'PQM:',i,'->',j,':',qm_knt(1,i,j) + p_qm_knt_tot = p_qm_knt_tot + qm_knt(1,i,j) + endif + enddo + enddo + + if(p_qm_knt_tot.eq.0) then + print *, 'NO PQM RESULTS!' + else + print 51 + print 52,'TOTAL:',p_qm_knt_tot + endif + + 50 format(1x,a4,1x,i2,1x,a2,1x,i2,a1,1x,i6) + 51 format(1x,'---------------------') + 52 format(1x,a6,9x,i6) + +c Altitude details +c ---------------- + print * + print *, '***********************' + print *, 'ZQM changes/status quo: ' + + print * + print *, 'Input ZQM info:' + print *, 'ZQMs read from PREPBUFR:',nevrd(2) + print *, 'Obs with MISSING ZQMs upon input:',nzqm_msg_in + print * + + print *, 'Output ZQM info:' + print *, 'ZQMs written to output PREPBUFR:',nevwrt(2) + print *, 'Obs with MISSING ZQMs (not written to output):', + + nzqm_msg_out + print *, 'Obs with NRLACQC QM equal to previous QM (no new ', + + 'event): ',nev_noupd(2) + + print * + print *, 'Non-missing ZQM Breakdown:' + do i=0,15 + do j=0,15 + if(qm_knt(2,i,j).ne.0) then + print 50, 'ZQM:',i,'->',j,':',qm_knt(2,i,j) + z_qm_knt_tot = z_qm_knt_tot + qm_knt(2,i,j) + endif + enddo + enddo + + if(z_qm_knt_tot.eq.0) then + print *, 'NO ZQM RESULTS!' + else + print 51 + print 52,'TOTAL:',z_qm_knt_tot + endif + +c Temperature details +c ------------------- + print * + print *, '***********************' + print *, 'TQM changes/status quo: ' + + print * + print *, 'Input TQM info:' + print *, 'TQMs read from PREPBUFR:',nevrd(3) + print *, 'Obs with MISSING TQMs upon input:',ntqm_msg_in + print * + + print *, 'Output TQM info:' + print *, 'TQMs written to output PREPBUFR:',nevwrt(3) + print *, 'Obs with MISSING TQMs (not written to output):', + + ntqm_msg_out + print *, 'Obs with NRLACQC QM equal to previous QM (no new ', + + 'event): ',nev_noupd(3) + + print * + print *, 'Non-missing TQM Breakdown:' + do i=0,15 + do j=0,15 + if(qm_knt(3,i,j).ne.0) then + print 50, 'TQM:',i,'->',j,':',qm_knt(3,i,j) + t_qm_knt_tot = t_qm_knt_tot + qm_knt(3,i,j) + endif + enddo + enddo + + if(t_qm_knt_tot.eq.0) then + print *, 'NO TQM RESULTS!' + else + print 51 + print 52,'TOTAL:',t_qm_knt_tot + endif + +c Moisture details +c ---------------- + print * + print *, '***********************' + print *, 'QQM changes/status quo: ' + + print * + print *, 'Input QQM info:' + print *, 'QQMs read from PREPBUFR:',nevrd(4) + print *, 'Obs with MISSING QQMs upon input:',nqqm_msg_in + print * + + print *, 'Output QQM info:' + print *, 'QQMs written to output PREPBUFR:',nevwrt(4) + print *, 'Obs with MISSING QQMs (not written to output):', + + nqqm_msg_out + print *, 'Obs with NRLACQC QM equal to previous QM (no new ', + + 'event): ',nev_noupd(4) + + print * + print *, 'Non-missing QQM Breakdown:' + do i=0,15 + do j=0,15 + if(qm_knt(4,i,j).ne.0) then + print 50, 'QQM:',i,'->',j,':',qm_knt(4,i,j) + q_qm_knt_tot = q_qm_knt_tot + qm_knt(4,i,j) + endif + enddo + enddo + + if(q_qm_knt_tot.eq.0) then + print *, 'NO QQM RESULTS!' + else + print 51 + print 52,'TOTAL:',q_qm_knt_tot + endif + +c Wind details +c ------------ + print * + print *, '***********************' + print *, 'WQM changes/status quo: ' + + print * + print *, 'Input WQM info:' + print *, 'WQMs read from PREPBUFR:',nevrd(5) + print *, 'Obs with MISSING WQMs upon input:',nwqm_msg_in + print * + + print *, 'Output WQM info:' + print *, 'WQMs written to output PREPBUFR:',nevwrt(5) + print *, 'Obs with MISSING WQMs (not written to output):', + + nwqm_msg_out + print *, 'Obs with NRLACQC QM equal to previous QM (no new ', + + 'event): ',nev_noupd(5) + + print * + print *, 'Non-missing WQM Breakdown:' + do i=0,15 + do j=0,15 + if(qm_knt(5,i,j).ne.0) then + print 50, 'WQM:',i,'->',j,':',qm_knt(5,i,j) + w_qm_knt_tot = w_qm_knt_tot + qm_knt(5,i,j) + endif + enddo + enddo + + if(w_qm_knt_tot.eq.0) then + print *, 'NO WQM RESULTS!' + else + print 51 + print 52,'TOTAL:',w_qm_knt_tot + endif + + + write(*,*) + write(*,*) '****************************' + write(*,*) 'output_acqc_noprof has ended' + call system('date') + write(*,*) '****************************' + write(*,*) + + return + + end diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_prof.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_prof.f new file mode 100644 index 00000000..a2e56d5c --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/output_acqc_prof.f @@ -0,0 +1,1441 @@ +c$$$ Subprogram Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Subprogram: output_acqc_prof +c Programmer: D. Keyser Org: NP22 Date: 2016-12-09 +c +c Abstract: Reads in sorted NRLACQC quality controlled single-level aircraft reports and +c constructs profiles from ascending or descending flights. Encodes these profiles as +c merged (mass and wind) reports (subsets) along with (when l_prof1lvl=T) merged +c single(flight)-level aircraft reports not part of any profile into a PREPBUFR-like file +c containing only these data. Single-level reports get PREPBUFR report type 3xx (where xx +c is original type in 1xx mass and 2xx wind reports), ascending profile reports get +c PREPBUFR report type 4xx, and descending profile reports get PREPBUFR report type 5xx. +c +c Program History Log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c 2012-11-20 J. Woollen -- Initial port to WCOSS +c 2013-02-07 D. Keyser -- Final changes to run on WCOSS: use formatted print statements +c where previously unformatted print was > 80 characters +c 2016-12-09 D. Keyser -- +c - Nomenclature change: replaced "MDCRS/ACARS" with just "MDCRS". +c - Latitude/longitdue arrays "alat" and "alon" passed into of this subroutine +c now double precision. XOB and YOB in PREPBUFR file now scaled to 10**5 +c (was 10**2) to handle new v7 AMDAR and MDCRS reports which have this +c higher precision. +c BENEFIT: Retains exact precison here. Improves QC processing. +c - The format for all print statements containing latitude and longitude +c changed to print to 5 decimal places. +c +c Usage: call output_acqc_prof(proflun,nrpts4QC_pre,max_reps,mxnmev, +c mxlv,bmiss,cdtg_an,alat,alon,ht_ft, +c idt,c_qc,trad,l_otw,l_nhonly,sortidx, +c c_acftreg,c_acftid,ob_t,nevents,hdr, +c acid,rct,drinfo,acft_seq,mstq,cat, +c pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, +c zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, +c tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, +c qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, +c uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, +c wbg,wpp,ddo_ev,ffo_ev,dfq_ev,dfp_ev, +c dfr_ev,nrlacqc_pc,l_allev_pf, +c l_prof1lvl,l_mandlvl,tsplines,l_operational,lwr) +c +c Input argument list: +c proflun - Unit number for the output post-PREPACQC PREPBUFR-like file containing +c merged profile reports (always) and single(flight)-level reports not +c part of any profile (when l_prof1lvl=T) with added NRLACQC events +c (aircraft data only) +c nrpts4QC_pre - Number of reports in the "merged" single-level aircraft report arrays +c max_reps - Maximum number of reports accepted by acftobs_qc +c mxnmev - Maximum number of events allowed, per variable type +c mxlv - Maximum number of levels allowed in a report profile +c bmiss - BUFRLIB missing value (set in main program) +c cdtg_an - Date/analysis time (YYYYMMDDCC) +c alat - Array of latitudes for the "merged" reports +c alon - Array of longitudes for the "merged" reports +c ht_ft - Array of altitudes for the "merged" reports +c idt - Array of ob-cycle times for the "merged" reports (in seconds) +c c_qc - Array of NRLACQC quality information (11 char. string) ("merged" reports) +c trad - Time window radius for outputting reports (if l_otw=T) (read in via +c namelist) +c l_otw - Logical whether or not to eliminate reports outside the time window +c radius (trad) (read in via namelist) +c l_nhonly - Logical Whether or not to eliminate reports south of 20S latitude (i.e, +c outside the tropics and N. Hemisphere) (read in via namelist) +c sortidx - Sort index that specifies the order in which the reports should be +c written to the output PREPBUFR-like profiles file +c c_acftreg - Array of aircraft tail numbers for the "merged" reports as used in +c NRL QC processing +c c_acftid - Array of aircraft flight numbers for the "merged" reports as used in +c NRL QC processing +c ob_t - Array of aircraft temperatures for the "merged" reports +c nevents - Array tracking number of events for variables for each report +c hdr - Array containing header information for the "merged" reports {word 1 is +c flight number for AIREPs, tail number for AMDARs (all types) and MDCRS, +c and manfactured id for PIREPs and TAMDARs - this will be later be +c encoded into 'SID' for aircraft reports in output PREPBUFR-like file) +c acid - Array containing flight numbers for the "merged" MDCRS and AMDAR (LATAM +c only) reports {this will be encoded into 'ACID' for MDCRS and AMDAR +c (LATAM only) reports in output PREPBUFR-like profiles file} +c rct - Array containing receipt times for the "merged" reports +c drinfo - Array containing drift information for the "merged" reports +c acft_seq - Array containing temperature precision and phase of flight for the +c "merged" reports +c mstq - Array containing moisture quality flags for the "merged" reports +c cat - Array containing level category for the "merged" reports +c pob_ev - Pressure event obs +c pqm_ev - Pressure event quality marks +c ppc_ev - Pressure event program codes +c prc_ev - Pressure event reason codes +c pbg - Pressure background data (POE PFC PFCMOD) +c ppp - Pressure post-processing info (PAN PCL PCS) +c zob_ev - Altitude event obs +c zqm_ev - Altitude event quality marks +c zpc_ev - Altitude event program codes +c zrc_ev - Altitude event reason codes +c zbg - Altitude background data (ZOE ZFC ZFCMOD) +c zpp - Altitude post-processing info (ZAN ZCL ZCS) +c tob_ev - Temperature event obs +c tqm_ev - Temperature event quality marks +c tpc_ev - Temperature event program codes +c trc_ev - Temperature event reason codes +c tbg - Temperature background data (TOE TFC TFCMOD) +c tpp - Temperature post-processing info (TAN TCL TCS) +c qob_ev - Moisture event obs +c qqm_ev - Moisture event quality marks +c qpc_ev - Moisture event program codes +c qrc_ev - Moisture event reason codes +c qbg - Moisture background data (QOE QFC QFCMOD) +c qpp - Moisture post-processing info (QAN QCL QCS) +c uob_ev - Wind/u-comp event obs +c vob_ev - Wind/v-comp event obs +c wqm_ev - Wind event quality marks +c wpc_ev - Wind event program codes +c wrc_ev - Wind event reason codes +c wbg - Wind background data (WOE UFC VFC UFCMOD VFCMOD) +c wpp - Wind post-processing info (UAN VAN UCL VCL UCS VCS) +c ddo_ev - Wind direction event obs +c ffo_ev - Wind speed event obs +c dfq_ev - Wind direction/speed quality mark +c dfp_ev - Wind direction/speed program code +c dfr_ev - Wind direction/speed reason code +c nrlacqc_pc - PREPBUFR program code for the NRLACQC step +c l_allev_pf - Logical whether to process latest (likely NRLACQC) event plus all prior +c events (TRUE) or only latest event (FALSE) into profiles PREPBUFR-like +c file +c l_prof1lvl - Logical whether to encode merged single(flight)-level aircraft reports +c with NRLACQC events that are not part of any profile into PREPBUFR-like +c file (along with, always, merged profiles from aircraft ascents and +c descents) +c l_mandlvl - Logical whether to interpolate to mandatory levels in profile generation +c tsplines - Logical whether to use tension-splines for aircraft vertical velocity +c calculation +c l_operational- Run program in operational mode if true +c lwr - Machine word length in bytes (either 4 or 8) +c +c Output files: +c Unit proflun - PREPBUFR-like file containing merged (mass and wind) profile reports +c (always) and single(flight)-level reports not part of any profile (when +c l_prof1lvl=T) with NRLACQC events +c Unit 06 - Standard output print +c Unit 52 - Text file containing listing of all QC'd merged aircraft reports written +c to profiles PREPBUFR-like file +c +c Subprograms called: +c Unique: SUB2MEM_MER SUB2MEM_UM +c Library: +c SYSTEM: SYSTEM +c BUFRLIB: OPENMB WRITSB +c +c Exit States: +c Cond = 0 - successful run +c +c Remarks: Called by main program. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine output_acqc_prof(proflun,nrpts4QC_pre,max_reps,mxnmev, + + mxlv,bmiss,cdtg_an,alat,alon,ht_ft, + + idt,c_qc,trad,l_otw,l_nhonly,sortidx, + + c_acftreg,c_acftid,ob_t,nevents,hdr, + + acid,rct,drinfo,acft_seq,mstq,cat, + + pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, + + zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, + + tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, + + qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, + + wbg,wpp,ddo_ev,ffo_ev,dfq_ev,dfp_ev, + + dfr_ev,nrlacqc_pc,l_allev_pf, + + l_prof1lvl,l_mandlvl,tsplines, + + l_operational,lwr) + + implicit none + integer mevwrt(1) ! DAK: This is a "dummy" variable, not used anywhere. For some + ! reason if one removes this, moves it to any other place in + ! this subr., changes the dimension, or does not initialize it + ! as zero (look below) the compiler can fail under -O3 with + ! debugging turned on ("An error occurred during code + ! generation. The code generation return code was 40." + ! "Compilation failed for file output_acqc_prof.f." + +c ------------------------------ +c Parameter statements/constants +c ------------------------------ + integer proflun ! output unit number for post-PREPACQC PREPBUFR-like + ! file containing merged profile reports (always) and + ! single(flight)-level reports not part of any profile + ! (when l_prof1lvl=T) with added NRLACQC events + + integer max_reps ! maximum number of input merged (mass + wind piece) + ! aircraft-type reports allowed +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c replace above with this in event of future switch to dynamic memory allocation + +calloc integer max_reps ! original number of input reports obtained from +calloc ! first pass through to get total for array allocation +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + real*8 bmiss ! BUFRLIB missing value (set in main program) + +c ---------------------- +c Declaration statements +c ---------------------- + +c Variables for BUFRLIB interface +c ------------------------------- + character*10 cdtg_an ! date-time group for analysis (YYYYMMDDCC) + ! (all messages in a PREPBUFR-like file should have + integer icdtg_an ! same YYYYMMDDCC) + +c Indices/counters +c ---------------- + integer i,j,k,ii ! loop indices + + integer nrpts4QC_pre ! original number of input merged (mass + wind piece) + ! aircraft-type reports (read in from PREPBUFR file) + + integer sortidx(max_reps) ! index if reports are to be written back out in a + ! certain order (determined by calling routine) + + character*11 c_qc(max_reps) ! character QC flags output from NRL QC code + ! 1st char - info about reject (if ob was rejected) + ! 2nd char - reason why time was rejected + ! 3rd char - reason why latitude was rejected + ! 4th char - reason why longitude was rejected + ! 5th char - reason why pressure/atitude was rejected + ! 6th char - readon why temperature was rejected + ! 7th char - reason why wind direction was rejected + ! 8th char - reason why wind speed was rejected + ! 9th char - reason why mixing ratio was rejected + ! 10th char - reason for blacklisting the aircraft + ! 11th char - info about flight phase + + real*8 alat(max_reps) ! latitude + +, alon(max_reps) ! longitude + real ht_ft(max_reps) ! altitude in feet + + integer idt(max_reps) ! time in seconds to anal. time (- before, + after) + character*8 c_acftreg(max_reps)! aircraft registration (tail) number as used in NRL + ! QC processing + character*9 c_acftid(max_reps) ! aircraft flight number as used in NRL QC processing + + real ob_t(max_reps) ! temperature + +c Logicals controlling processing (read in from namelist in main program) +c ----------------------------------------------------------------------- + real trad ! Time window radius for outputting reports (if l_otw=T) + logical l_otw ! T=eliminate reports outside cycle time window radius (trad) + +, l_nhonly ! T=filter out obs outside tropics and Northern Hemisphere + +, l_allev_pf ! T=process latest (likely NRLACQC) events plus all prior + ! events into profiles PREPBUFR-like file + ! **CAUTION: More complete option, but will make code take + ! longer to run!!! + ! F=process ONLY latest (likely NRLACQC) events into profiles + ! PREPBUFR-like file + ! + ! Note : All pre-existing events plus latest (likely NRLACQC) + ! events are always encoded into full PREPBUFR file) + + +, l_prof1lvl ! T=encode merged single(flight)-level aircraft reports with + ! NRLACQC events that are not part of any profile into + ! PREPBUFR-like file, along with merged profiles from + ! aircraft ascents and descents + ! **CAUTION: Will make code take a bit longer to run!! + ! F=do not encode merged single(flight)-level aircraft + ! reports with NRLACQC events into PREPBUFR-like file - + ! only merged profiles from aircraft ascents and descents + ! will be encoded into this file + +, l_mandlvl ! T=interpolate to mandatory levels in profile generation + ! F=do not interpolate to mandatory levels in profile + ! generation + +, tsplines ! T=use tension-splines for aircraft vertical velocity + ! calculation + ! F=use finite-differencing for aircraft vertical velocity + ! calculation + + +c Logicals controlling processing (not read in from namelist in main program) +c --------------------------------------------------------------------------- + logical l_operational ! Run program in operational mode if true + +c Counters +c -------- + integer elim_knt(3) ! Count of reports eliminated and kept + ! 1 - # of merged reports outside time radius (prior to any + ! geographical domain checking) + ! 2 - # of merged reports outside geographical domain (had + ! passed time window radius check) + ! 3 - # of merged reports passing both time window radius + ! and geographical domain checks and thus retained + ! for eventual processing into PREPBUFR-like profiles + ! file + +c Variables used to write data to output PREPBUFR-like file in sorted order +c ------------------------------------------------------------------------- + character*8 msgtyp2wrt ! BUFR message type to write to output PREPBUFR-like file + + integer mxlv ! maximum number of report levels allowed in aircraft + ! profiles + character*6 cmxlv ! character form of mxlv + + integer mxnmev ! maximum number of events allowed in stack + + integer lvlsinprof(mxlv) ! array containing a list of pressure levels that are + ! present in the current profile + + logical l_newprofile ! T = start a new profile + + integer nprofiles ! number of "profile" reports identified + +, nprofiles_encoded ! number of "profile" reports actually encoded into + ! PREPBUFR-like file + +, mxe4prof ! maximum number of events in a single-level merged report + ! (i.e., the maximum amongst the number of pressure, + ! moisture, temperature, altitude, u/v wind and dir/speed + ! wind events) + +, nlvinprof ! number of levels in a profile + +, nlvinprof_last ! index for level number of last level (for duplicate + ! pressure level removal option #1) + +, nlvinprof_temp ! temporary level number index needed for duplicate + ! pressure level removal + + character*8 tail_curr, ! aircraft registration (tail) number of current report + + tail_prev ! aircraft registration (tail) number of previous report + + character*9 flt_curr, ! flight number of current report + + flt_prev ! flight number of previous report + + real elv_curr, ! elevation of current report + + elv_prev ! elevation of previous report + + integer idt_curr, ! time of current report + + idt_prev ! time of previous report + + integer idz_curr, ! altitude of current report + + idz_prev ! altitude of previous report + + real*8 hdr2wrt(15) ! array used to pass header info to subroutine + ! sub2mem_mer + character*8 c_sid ! SID from PREPBUFR file = Site ID + equivalence(c_sid,hdr2wrt(1)) + + real*8 drinfo_accum(3,mxlv) ! array used to accumulate drift info across profile + ! levels + + real*8 acft_seq_accum(2,mxlv) ! array used to accumulate ACFT_SEQ (PCAT - + ! temperature precision, POAF - phase of flight) + ! info across profile levels + +, mstq_accum(1,mxlv) ! array used to accumulate moisture QC marks across + ! profile levels + +, cat_accum(1,mxlv) ! array used to accumulate level category markers + ! across profile levels + +, elv_accum(1,mxlv) ! array used to accumulate elevation across profile + ! levels + +, rpt_accum(1,mxlv) ! array used to accumulate reported obs time across + ! profile levels + +, tcor_accum(1,mxlv) ! array used to accumulate time correction indicator + ! across profile levels + +, rct_accum(1,mxlv) ! array used to accumulate receipt time across + ! profile levels + + real*8 pevn_accum(4,mxlv,mxnmev)! array used to accumulate pressure data/events for a + ! single profile, across profile levels + +, pbg_accum(3,mxlv) ! array used to accumulate pressure background info + ! (POE, PFC, PFCMOD) for a single profile, across + ! profile levels + +, ppp_accum(3,mxlv) ! array used to accumulate pressure post-processing + ! info (PAN, PCL, PCS) for a single profile, across + ! profile levels + + real*8 qevn_accum(4,mxlv,mxnmev)! array used to accumulate moisture data/events for a + ! single profile, across profile levels + +, qbg_accum(3,mxlv) ! array used to accumulate moisture background info + ! (QOE, QFC, QFCMOD) for a single profile, across + ! profile levels + +, qpp_accum(3,mxlv) ! array used to accumulate moisture post-processing + ! info (QAN, QCL, QCS) for a single profile, across + ! profile levels + + real*8 tevn_accum(4,mxlv,mxnmev)! array used to accumulate temperature data/events + ! for a single profile, across profile levels + +, tbg_accum(3,mxlv) ! array used to accumulate temperature background + ! info (TOE, TFC, TFCMOD) for a single profile, + ! across profile levels + +, tpp_accum(3,mxlv) ! array used to accumulate temperature post- + ! processing info (TAN, TCL, TCS) for a single + ! profile, across profile levels + + real*8 zevn_accum(4,mxlv,mxnmev)! array used to accumulate altitude data/events for a + ! single profile, across profile levels + +, zbg_accum(3,mxlv) ! array used to accumulate altitude background info + ! (ZOE, ZFC, ZFCMOD) for a single profile, across + ! profile levels + +, zpp_accum(3,mxlv) ! array used to accumulate altitude post-processing + ! info (ZAN, ZCL, ZCS) for a single profile, across + ! profile levels + + real*8 wuvevn_accum(5,mxlv,mxnmev)! array used to accumulate wind data/events (u/v + ! components) for a single profile, across profile + ! levels + +, wuvbg_accum(5,mxlv) ! array used to accumulate wind background info (WOE, + ! UFC, VFC, UFCMOD, VFCMOD) for a single profile, + ! across profile levels + +, wuvpp_accum(6,mxlv) ! array used to accumulate wind post-processing info + ! (UAN, VAN, UCL, VCL, UCS, VCS) for a single + ! profile, across profile levels + + real*8 wdsevn_accum(5,mxlv,mxnmev)! array used to accumulate wind data/events + ! (direction/speed) for a single profile, across + ! profile levels + + character*11 c_qc_accum(mxlv) ! array used to accumulate NRLACQC quality information + ! on individual obs in a profile, across profile + ! levels + +c Summary counters +c ---------------- + integer num_events_prof ! total number of events on an ob, across all levels, + ! across all reports, written in the PREPBUFR-like + ! (profiles) file (this value is the same for each + ! ob type) + +c Mandatory levels settings +c ------------------------- + integer maxmandlvls ! maxmum number of mandatory pressure levels to + ! consider for aircraft profiles + parameter(maxmandlvls = 9) + + integer mandlvls(maxmandlvls) ! list of mandatory pressure levels to consider for + ! aircraft profiles + + data mandlvls/1000,1500,2000,3000,4000,5000,7000,8500,10000/ + +c Variables used to hold original aircraft data read from input PREPBUFR file - necessary for +c carrying data through program so that it can be later written to output PREPBUFR-like +c profiles file from memory instead of going back to input PREPBUFR file and re-reading that +c file before adding any NRLACQC events +c ------------------------------------------------------------------------------------------- + integer nevents(max_reps,6) ! array tracking number of events for variables for + ! each report: + ! 1 - number of pressure events + ! 2 - number of moisture events + ! 3 - number of temperature events + ! 4 - number of altitude events + ! 5 - number of wind (u/v) events + ! 6 - number of wind (direction/speed) events + + real*8 pob_ev(max_reps,mxnmev) ! POB values for each report, including all events + +, pqm_ev(max_reps,mxnmev) ! PQM values for each report, including all events + +, ppc_ev(max_reps,mxnmev) ! PPC values for each report, including all events + +, prc_ev(max_reps,mxnmev) ! PRC values for each report, including all events + +, zob_ev(max_reps,mxnmev) ! ZOB values for each report, including all events + +, zqm_ev(max_reps,mxnmev) ! ZQM values for each report, including all events + +, zpc_ev(max_reps,mxnmev) ! ZPC values for each report, including all events + +, zrc_ev(max_reps,mxnmev) ! ZRC values for each report, including all events + +, tob_ev(max_reps,mxnmev) ! TOB values for each report, including all events + +, tqm_ev(max_reps,mxnmev) ! TQM values for each report, including all events + +, tpc_ev(max_reps,mxnmev) ! TPC values for each report, including all events + +, trc_ev(max_reps,mxnmev) ! TRC values for each report, including all events + +, qob_ev(max_reps,mxnmev) ! QOB values for each report, including all events + +, qqm_ev(max_reps,mxnmev) ! QQM values for each report, including all events + +, qpc_ev(max_reps,mxnmev) ! QPC values for each report, including all events + +, qrc_ev(max_reps,mxnmev) ! QRC values for each report, including all events + +, uob_ev(max_reps,mxnmev) ! UOB values for each report, including all events + +, vob_ev(max_reps,mxnmev) ! VOB values for each report, including all events + +, wqm_ev(max_reps,mxnmev) ! WQM values for each report, including all events + +, wpc_ev(max_reps,mxnmev) ! WPC values for each report, including all events + +, wrc_ev(max_reps,mxnmev) ! WRC values for each report, including all events + +, ddo_ev(max_reps,mxnmev) ! DDO values for each report, including all events + +, ffo_ev(max_reps,mxnmev) ! FFO values for each report, including all events + +, dfq_ev(max_reps,mxnmev) ! DFQ values for each report, including all events + +, dfp_ev(max_reps,mxnmev) ! DFP values for each report, including all events + +, dfr_ev(max_reps,mxnmev) ! DFR values for each report, including all events + + +, hdr(max_reps,15) ! SID XOB YOB DHR ELV TYP T29 TSB ITP SQN PROCN RPT + ! TCOR RSRD EXRSRD + +, acid(max_reps) ! ACID + +, rct(max_reps) ! RCT + +, mstq(max_reps) ! MSTQ + +, cat(max_reps) ! CAT + + +, pbg(max_reps,3) ! POE PFC PFCMOD + +, zbg(max_reps,3) ! ZOE ZFC ZFCMOD + +, tbg(max_reps,3) ! TOE TFC TFCMOD + +, qbg(max_reps,3) ! QOE QFC QFCMOD + +, wbg(max_reps,5) ! WOE UFC VFC UFCMOD VFCMOD + + +, ppp(max_reps,3) ! PAN PCL PCS + +, zpp(max_reps,3) ! ZAN ZCL ZCS + +, tpp(max_reps,3) ! TAN TCL TCS + +, qpp(max_reps,3) ! QAN QCL QCS + +, wpp(max_reps,6) ! UAN VAN UCL VCL UCS VCS + + +, drinfo(max_reps,3) ! XOB YOB DHR + +, acft_seq(max_reps,2) ! PCAT POAF + + real*8 acid_last_profile ! ACID (aircraft flight number) for last (or only) + ! MDCRS or AMDAR (LATAM only) report in profile (passed + ! into subroutine sub2mem_mer) + + character*9 c_acftid_last_profile ! aircraft flight number (as processed by NRL QC + ! procesing) for last (or only) report in profile + ! (passed into subroutine sub2mem_mer for printing + ! purposes only) + + character*8 c_acftreg_last_profile ! aircraft tail number (as processed by NRL QC + ! procesing) for last (or only) report in profile + ! (passed into subroutine sub2mem_mer for printing + ! purposes only) + + real del_time ! report time difference between two levels, used by + ! profile gross check + +, del_hght ! report time difference between two levels, used by + ! profile gross check + +, vvel ! vertical velocity between two levels, used by profile + ! gross check + +c Misc. +c ----- + integer i_option ! Duplicate pressure removal option (1 or 2) + +, lwr ! machine word length in bytes (either 4 or 8) + + real nrlacqc_pc ! PREPBUFR program code for the NRLACQC step + +ccccc integer iprint ! Switch controlling extra diagnostic printout + +c ******************************************************************* + +c Initialize variables +c -------------------- + + tail_prev = 'XXXXXXXX' + flt_prev = 'XXXXXXXXX' + elv_prev = 99999 + idt_prev = 99999 + idz_prev = 99999 + + mxe4prof = 0 + nlvinprof = 0 + nlvinprof_last = 0 + + lvlsinprof = 99999 + + pevn_accum = bmiss + pbg_accum = bmiss + ppp_accum = bmiss + + tevn_accum = bmiss + tbg_accum = bmiss + tpp_accum = bmiss + + qevn_accum = bmiss + qbg_accum = bmiss + qpp_accum = bmiss + + zevn_accum = bmiss + zbg_accum = bmiss + zpp_accum = bmiss + + wuvevn_accum = bmiss + wuvbg_accum = bmiss + wuvpp_accum = bmiss + + wdsevn_accum = bmiss + + drinfo_accum = bmiss + acft_seq_accum = bmiss + mstq_accum = bmiss + cat_accum = bmiss + elv_accum = bmiss + rpt_accum = bmiss + tcor_accum = bmiss + rct_accum = bmiss + + c_qc_accum = 'XXXXXXXXXXX' + + hdr2wrt = bmiss + + acid_last_profile = bmiss + c_acftid_last_profile = ' ' + c_acftreg_last_profile = ' ' + + nprofiles = 0 + nprofiles_encoded = 0 + mevwrt = 0 ! DAK: This is a "dummy" variable, not used anywhere. For some + ! reason if one removes this, moves its declaration (look + ! above) to any other place in this subr., changes the + ! dimension, or does not initialize it as zero (here) the + ! CCS XLF compiler can fail under -O3 with debugging turned + ! on ("An error occurred during code generation. The code + ! generation return code was 40." "Compilation failed for + ! file output_acqc_prof.f." -- Not sure what might happen + ! with ifort compiler on WCOSS + + elim_knt = 0 + num_events_prof = 0 + + +c Start subroutine +c ---------------- + write(*,*) + write(*,*) '***************************' + write(*,*) 'Welcome to output_acqc_prof' + call system('date') + write(*,*) '***************************' + write(*,*) + + write(*,*) + write(*,'(" --> Output to PREPBUFR-like file (holding merged QCd", + + " aircraft profile rpts & when l_prof1lvl=T single", + + "(flight)-level aircraft rpts)")') + write(*,*) + + if(.not.l_operational) then ! this is currently invoked because l_operational + ! is hardwired to F for l_ncep=T + +c Write merged profile reports and resulting QC decisions to an output file for later perusal +c ------------------------------------------------------------------------------------------- + + open(52,file='merged.profile_reports.post_acftobs_qc.sorted', + + form='formatted') + write(52,*) + write(52,'(" Final listing of all aircraft profile reports in ", + + "pseudo-PREPBUFR file after NRLACQC")') + write(52,'(" -------------------------------------------------", + + "----------------------------------")') + write(52,*) + write(52,'(" TAMDAR reports here replace characters 1-3 of ", + + "manufactured flight # (''000'') with (''TAM'') in ", + + "order to create truncated tail # ''TAM'' for ", + + "NRLACQC sorting - the PREPBUFR file continues to ", + + "encode ''000'' in")') + write(52,'(" characters 1-3 of manufactured flight # for ", + + "TAMDAR (stored as both ''SID'' and ''ACID'')")') + + write(52,*) + write(52,'(" AIREP and PIREP reports report only a flight # ", + + "(manufactured for PIREPs) - a tail # for NRLACQC ", + + "sorting is created by truncating the flight # - ", + + "the PREPBUFR file will not encode these truncated ", + + "tail #''s")') + + write(52,*) + write(52,'(" All AMDAR reports except LATAM report only a tail", + + " # - this is stored as both flight # and tail # for", + + " NRLACQC sorting - the PREPBUFR file continues to ", + + "encode only tail # (stored in ''SID'')")') + write(52,*) + write(52,'(" AMDAR reports from LATAM report both a tail # and", + + " a flight # - these are used as reported for ", + + "NRLACQC sorting - the PREPBUFR file continues to ", + + "encode both tail # and flight # (as ''SID'' and ", + + "''ACID'',")') + write(52,*) 'resp.)' + write(52,*) + write(52,'(" MDCRS reports from ARINC report both a tail # and", + + " a flight # - these are used as reported for", + + " NRLACQC sorting - the PREPBUFR file continues to ", + + "encode both tail # and flight # (as ''SID'' and ", + + "''ACID'',")') + write(52,*) 'resp.)' + + write(52,*) + write(52,3001) + 3001 format(172x,'! _PREPBUFR_QMs_!NRLACQC_REASON_CODE'/ + + 'index flight tail num itp pf lat lon', + + ' time hght pres temp/evnt spec_h/evnt uwnd ', + + 'vwnd/evnt t-prec !__qc_flag__!rcptm mstq cat wspd ', + + 'wdir rtyp ! Pq Zq Tq Qq Wq!Prc Zrc Trc Qrc ', + + 'Wrc'/ + + '----- --------- -------- --- -- -------- --------', + + '- ------ ----- ------ --------- ----------- ------ ', + + '--------- ------ -----------!----- ---- --- ----- ', + + '---- ---- ! -- -- -- -- --!--- --- --- --- ', + + '---') + endif +C-------------------------------------------------------------------------------------------- +C Options for handling duplicate pressures read in for a profile: +C Option 1: For duplicate pressures read in for a profile, the first duplicate read in is +C tossed and the second one is kept. Note: This is how the code originally +C performed this duplicate check. Updated logic to make code run faster may cause +C this option to not always work as expected - not sure. Also, when debugging is +C turned on, this option may not compile unless -qhot is added to FFLAGS in +C makefile (not always the case, however). +C Option 2: For duplicate pressures read in for a profile, the second duplicate read in is +C tossed. This appears to be less problematic than option 1. +C Currently Option 2 is selected in this code. + i_option = 2 +C-------------------------------------------------------------------------------------------- + +c Now, loop over NRLACQC arrays and write aircraft type reports to output file in sorted +c order as specified by sortidx +c -------------------------------------------------------------------------------------- + loop1: do i = 1,nrpts4QC_pre + j = sortidx(i) + +ccccc print 4077, j,acid(j),rct(j) +c4077 format(1x,'for j = ',i6,', acid(j) = ',a8,', rct(j) = ',f10.3) + +c Check to be sure the report is within the requested time window (defined by namelist switch +c trad) and it is within the requested geographical domain (here north of 20S latitude, if +c namelist switch l_nhonly is true) +c {Note: alat(j) and idt(j) will have already been updated with rehabilitated values if +c NRLACQC performed this task, so these checks will be more precise ...} +c ------------------------------------------------------------------------------------------- + + if(l_otw) then ! check if report is outside time window (prior to any geographical + ! domain checking) + if(idt(j).lt.-trad*3600..or.idt(j).gt.trad*3600.) then + elim_knt(1) = elim_knt(1) + 1 + cycle ! skip processing of this report, move on to next report + endif + endif + + if(l_nhonly) then ! if report passed time window radius check, then check to see if + ! it is outside geographical domain (i.e., south of 20S) + if(alat(j).lt.-20.0) then + elim_knt(2) = elim_knt(2) + 1 + cycle ! skip processing of this report, move on to next report + endif + endif + +c If this point is reached, the report is not to be eliminated +c ------------------------------------------------------------ +ccccc print *, 'keep this report!' + +c Counter for number of merged reports kept + elim_knt(3) = elim_knt(3) + 1 + +c Check if this ob should be included in current profile +c ------------------------------------------------------ + l_newprofile = .false. + + tail_curr = c_acftreg(j) + flt_curr = c_acftid(j) + elv_curr = ht_ft(j) + idt_curr = idt(j) + idz_curr = zob_ev(j,nevents(j,4)) + + if(tail_curr.eq.tail_prev .and.flt_curr.eq.flt_prev) then ! report may be part of current profile; need to make + ! sure it's not the start of a separate profile from + ! the same aircraft and flight + +ccccc iprint=0 +ccccc if(tail_curr.eq.'MSHWUURA ') iprint=1 +ccccc if(flt_curr.eq.'AFZA41 ') iprint=1 + +c By this point, reports have been sorted with a sort key of: +c +c type//phase-of-flight//tail//flight//time//elevation//lat//lon +c +c (see csort_wbad in main program) - phase-of-flight in c_qc(11:11) indicates that the +c report is indeed part of an ascent or descent - if tail and flight number are equal, check +c for elev(n)<= for ascents (c_qc(11:11) = a or A) and for elev(n) >=elev(n-1) for descents +c (c_qc(11:11) = d or D) -- reaching these elevation criteria will signal the start of a new +c profile +c ------------------------------------------------------------------------------------------- + if( + + ((c_qc(j)(11:11).eq.'a' .or. + + c_qc(j)(11:11).eq.'A') .and. + + (elv_curr .lt. elv_prev)) .or. ! new profile from the same aircraft/flight + + c_qc(j)(11:11).eq.'I' .or. ! perhaps the aircraft made a stop + + c_qc(j)(11:11).eq.'L' .or. ! somewhere and the flight number didn't + + c_qc(j)(11:11).eq.'N' .or. ! change - or, this report is isolated (I), + + c_qc(j)(11:11).eq.'U' .or. ! level (L), or its ascent/descent status is + + c_qc(j)(11:11).eq.'-' .or. ! unknown (U). Need to close off the + + ((c_qc(j)(11:11).eq.'d' .or. ! current profile, write it to output, + + c_qc(j)(11:11).eq.'D') .and. ! and start a new one + + (elv_curr .gt. elv_prev)) + + ) then + +ccccc if(iprint.eq.1) print *,'new profile - same flight number' + + l_newprofile = .true. + nprofiles = nprofiles + 1 + + else + +ccccc if(iprint.eq.1) print *,'keep accumulating' + + ! keep accumulating data into the current profile + +c Perform a gross check on the report times of adjacent levels in the "profile" ... +C Stop accumulating levels and start a new profile on this level if either: +C 1) The report time difference between this level and the previous level is > 1500 sec +C 2) The report time difference between this level and the previous level is > 1000 sec +C and 1 + ! still come back as single-level + ! reports - this check keeps them + ! out of PREPBUFR-like file when + ! l_prof1lvl=F + nprofiles_encoded = nprofiles_encoded + 1 + +ccccc if(iprint.eq.1) print *,'call writsb - 1st location' + + call writsb(proflun) + endif + endif + +c Clear out accumulation arrays and start over with clear arrays for next profile +c ------------------------------------------------------------------------------- + nlvinprof = 0 + nlvinprof_last = 0 + + lvlsinprof = 99999 + + pevn_accum = bmiss + pbg_accum = bmiss + ppp_accum = bmiss + + qevn_accum = bmiss + qbg_accum = bmiss + qpp_accum = bmiss + + tevn_accum = bmiss + tbg_accum = bmiss + tpp_accum = bmiss + + zevn_accum = bmiss + zbg_accum = bmiss + zpp_accum = bmiss + + wuvevn_accum = bmiss + wuvbg_accum = bmiss + wuvpp_accum = bmiss + + wdsevn_accum = bmiss + + drinfo_accum = bmiss + acft_seq_accum = bmiss + mstq_accum = bmiss + cat_accum = bmiss + elv_accum = bmiss + rpt_accum = bmiss + tcor_accum = bmiss + rct_accum = bmiss + + c_qc_accum = 'XXXXXXXXXXX' + + hdr2wrt = bmiss + + mxe4prof = 0 + + endif ! l_newprofile + +c Determine message date and type for output PREPBUFR-like file +c ------------------------------------------------------------- + read(cdtg_an,'(i10.10)') icdtg_an + if(mod(int(hdr(j,6)),100).eq.33) then + msgtyp2wrt = 'AIRCAR' + else + msgtyp2wrt = 'AIRCFT' + endif + + if(i_option.eq.1) then + nlvinprof = nlvinprof_last + 1 + else + nlvinprof = nlvinprof + 1 + endif + + if(nlvinprof.gt.mxlv) then +C....................................................................... +C There are more levels in profile than "mxlv" -- do not process any more levels +C ------------------------------------------------------------------------------ + print 53, mxlv,mxlv + 53 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' LEVELS IN ', + + 'THIS PROFILE -- WILL CONTINUE ON PROCESSING ONLY ',I6,' LEVELS', + + ' FOR THIS PROFILE'/) + write(cmxlv,'(i6)') mxlv + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmxlv//' AIRCRAFT PROFILE '// + + 'LEVEL LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// + + cmxlv//' LEVELS PROCESSED"') + exit loop1 +C....................................................................... + endif + +c Subroutine sub2mem_um will update events in memory for this single-level "merged" report - +c upon output the *_ev arrays will contain the events generated from the NRLACQC decisions +c ------------------------------------------------------------------------------------------ + +ccccc if(iprint.eq.1) print *,'call sub2mem_um' + + call sub2mem_um(c_qc(j),max_reps,mxnmev,j,nevents, + + pob_ev,pqm_ev,ppc_ev,prc_ev, + + zob_ev,zqm_ev,zpc_ev,zrc_ev, + + tob_ev,tqm_ev,tpc_ev,trc_ev, + + qob_ev,qqm_ev,qpc_ev,qrc_ev, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, + + nrlacqc_pc,l_allev_pf) + + mxe4prof = max(mxe4prof,nevents(j,1),nevents(j,2),nevents(j,3), + + nevents(j,4),nevents(j,5),nevents(j,6)) + + +c Gather data into profile arrays before actually writing profile to output file +c ------------------------------------------------------------------------------ + +c Get header data +c --------------- + hdr2wrt(:) = hdr(j,:) + +ccccc if(iprint.eq.1) print *,'HDR2WRT: ',hdr2wrt + +c ------------------------------------------------------------ +c Store pressure events, background data, analysis, climo data +c ------------------------------------------------------------ + lvlsinprof(nlvinprof) = int(pob_ev(j,nevents(j,1))*10) + if(i_option.eq.1) nlvinprof_last = nlvinprof + nlvinprof_temp = 0 + +ccccc if(iprint.eq.1) print *,'nlvinprof = ',nlvinprof + + if(nlvinprof.gt.1) then + do ii=1,nlvinprof-1 + +ccccc if(iprint.eq.1) print *,'new ii: lvlsinprof(nlvinprof), ', +ccccc+ 'lvlsinprof(ii): ', +ccccc+ lvlsinprof(nlvinprof), +ccccc+ lvlsinprof(ii) + + if(lvlsinprof(nlvinprof).eq.lvlsinprof(ii)) then + +ccccc if(i_option.eq.1) then +ccccc print'(" WARNING: Pressure level ",I0," was previously", +ccccc+ " filled for this report - index ",I0," refill ", +ccccc+ "with this one !!")', lvlsinprof(nlvinprof),ii +ccccc else +ccccc print'(" WARNING: Pressure level ",I0," was previously", +ccccc+ " filled for this report - index ',I0,'keep it,", +ccccc+ " toss this one !!")', lvlsinprof(nlvinprof),ii +ccccc endif +ccccc print *, hdr2wrt + + nlvinprof_temp = ii + exit + endif + enddo + endif + if(nlvinprof_temp.gt.0) then + if(i_option.eq.1) then + nlvinprof_last = nlvinprof - 1 + nlvinprof = nlvinprof_temp ! DAK: W/ DEBUG ON **MAY** NOT COMPFILE UNLESS ADD + ! -qhot + else + nlvinprof = nlvinprof - 1 + cycle ! skip processing + endif + endif + + if(l_prof1lvl.or.nlvinprof.gt.1) then + acid_last_profile = acid(j) + c_acftid_last_profile = c_acftid(j) + c_acftreg_last_profile = c_acftreg(j) + endif + +c Store non-NRLACQC events in the "profile" arrays before adding any new events (done later +c in subroutine sub2mem_mer) +c ----------------------------------------------------------------------------------------- + pevn_accum(1,nlvinprof,1:nevents(j,1))= pob_ev(j,1:nevents(j,1)) + pevn_accum(2,nlvinprof,1:nevents(j,1))= pqm_ev(j,1:nevents(j,1)) + pevn_accum(3,nlvinprof,1:nevents(j,1))= ppc_ev(j,1:nevents(j,1)) + pevn_accum(4,nlvinprof,1:nevents(j,1))= prc_ev(j,1:nevents(j,1)) + +c Background info +c --------------- + pbg_accum(:,nlvinprof) = pbg(j,:) ! single-level upon input + +c Post processing info +c -------------------- + ppp_accum(:,nlvinprof) = ppp(j,:) ! single-level upon input + +c ------------------------------------------------------------ +c Store altitude events, background data, analysis, climo data +c ------------------------------------------------------------ + +c Store non-NRLACQC events in the "profile" arrays before adding any new events (done later +c in subroutine sub2mem_mer) +c ----------------------------------------------------------------------------------------- + zevn_accum(1,nlvinprof,1:nevents(j,4))= zob_ev(j,1:nevents(j,4)) + zevn_accum(2,nlvinprof,1:nevents(j,4))= zqm_ev(j,1:nevents(j,4)) + zevn_accum(3,nlvinprof,1:nevents(j,4))= zpc_ev(j,1:nevents(j,4)) + zevn_accum(4,nlvinprof,1:nevents(j,4))= zrc_ev(j,1:nevents(j,4)) + +c Background info +c --------------- + zbg_accum(:,nlvinprof) = zbg(j,:) ! single-level upon input + +c Post processing info +c -------------------- + zpp_accum(:,nlvinprof) = zpp(j,:) ! single-level upon input + +c Get drift data - use XOB YOB DHR for drift coordinates when accumulating data into profiles +c ------------------------------------------------------------------------------------------- + drinfo_accum(:,nlvinprof) = drinfo(j,:) + +c Get time correction factor +c -------------------------- + tcor_accum(1,nlvinprof) = hdr(j,13) + +c ------------------------------------------------------------------------- +c ------------------------------------------------------------------------- +c Take into account possible rehabilitation of certain paramters by NRLACQC +c - these will be written into profiles rather than original values +c - Note: Right now we do not encode updates to XORG, XCOR, YORG or YCOR +c into PREPBUFR-like profiles file!! +c ------------------------------------------------------------------------- + + + if(c_qc(j)(2:2).eq.'R'.or. ! time reabilitated + + c_qc(j)(3:3).eq.'R'.or. ! latitude reabilitated + + c_qc(j)(4:4).eq.'R'.or. ! longitude reabilitated + + c_qc(j)(5:5).eq.'R'.or. ! pressure/altitude reabilitated + + c_qc(j)(6:6).eq.'R'.or. ! temperature reabilitated + + c_qc(j)(5:5).eq.'r') then ! pressure/altitude reabilitated + print 61 + 61 format(131('v')) + + if(c_qc(j)(2:2).eq.'R') then + +c Case where time was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------ + print 62, j,hdr(j,1),hdr(j,3),hdr(j,2),hdr(j,4), + + nint(hdr(j,5)),c_qc(j) + 62 format(' TIME rehab. (prof): input rpt # ',i6,': id ',a8,', lat ', + + f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6,', NRLQMS "', + + A11,'"') + print 63, hdr(j,4),nint(hdr(j,4)*3600.) + 63 format(' INPUT time from PRE-QC PREPBUFR file [DHR,idt(sec)] ', + + 'is: ',f10.5,i8) + print 64, idt(j)/3600.,idt(j) + 64 format(' REHAB. (prof) time from acftobs_qc [DHR,idt(sec)] ', + + 'is: ',f10.5,i8,' use this in profile if created') + hdr2wrt(4) = idt(j)/3600. + drinfo_accum(3,nlvinprof) = idt(j)/3600. + hdr2wrt(13) = 3 + tcor_accum(1,nlvinprof) = 3 ! Set time correction indicator (TCOR) to 3 + print 44, tcor_accum(1,nlvinprof) + 44 format(' --> Time correction indicator (TCOR) changed to ',f3.0) + endif + if(c_qc(j)(3:3).eq.'R') then + +c Case where latitude was rehabiltated by NRLACQC, make note of it +c ---------------------------------------------------------------- + print 72, j,hdr(j,1),hdr(j,3),hdr(j,2),hdr(j,4), + + nint(hdr(j,5)),c_qc(j) + 72 format(' LAT rehab. (prof): input rpt # ',i6,': id ',A8,', lat ', + + f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6,', NRLQMS "', + + A11,'"') + print 73, hdr(j,3) + 73 format(' INPUT latitude from PRE-QC PREPBUFR file (YOB) is: ', + + f9.5) + print 74, alat(j) + 74 format(' REHAB. (prof) latitude from acftobs_qc (YOB) is: ', + + f9.5,' use this in profile if created') + hdr2wrt(3) = alat(j) + drinfo_accum(2,nlvinprof) = alat(j) + endif + if(c_qc(j)(4:4).eq.'R') then + +c Case where longitude was rehabiltated by NRLACQC, make note of it +c ----------------------------------------------------------------- + print 82, j,hdr(j,1),hdr(j,3),hdr(j,2),hdr(j,4), + + nint(hdr(j,5)),c_qc(j) + 82 format(' LON rehab. (prof): input rpt # ',i6,': id ',A8,', lat ', + + f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6,', NRLQMS "', + + A11,'"') + print 83, hdr(j,2) + 83 format(' INPUT longitude from PRE-QC PREPBUFR file (XOB) is: ', + + f9.5) + print 84, alon(j) + 84 format(' REHAB. (prof) longitude from acftobs_qc (XOB) is: ', + + f9.5,' use this in profile if created') + hdr2wrt(2) = alon(j) + drinfo_accum(1,nlvinprof) = alon(j) + endif + if(c_qc(j)(5:5).eq.'R'.or.c_qc(j)(5:5).eq.'r') then + +c Case where pressure/altitude was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------------------- + print 92, j,hdr(j,1),hdr(j,3),hdr(j,2),hdr(j,4), + + nint(hdr(j,5)),c_qc(j) + 92 format(' P/A rehab. (prof): input rpt # ',i6,': id ',A8,', lat ', + + f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6,', NRLQMS "', + + A11,'"') + print 93 + 93 format(' %%%%%%%%%%'/' %%%%% Currently not accounted for in ', + + 'output PREPBUFR-like profiles file'/' %%%%%%%%%%') + endif + if(c_qc(j)(6:6).eq.'R') then + +c Case where temperature was rehabiltated by NRLACQC, make note of it +c ------------------------------------------------------------------- + print 102, j,hdr(j,1),hdr(j,3),hdr(j,2),hdr(j,4), + + nint(hdr(j,5)),c_qc(j) + 102 format(' TMP rehabilitated: input rpt # ',i6,': id ',A8,', lat ', + + f9.5,', lon ',f9.5,', dhr ',f10.5,', hght(m)',i6,', NRLQMS "', + + A11,'"') + print 93 + endif + print 65 + 65 format(131('^')) + endif +c ------------------------------------------------------------------------- +c ------------------------------------------------------------------------- + +c Get ACFT_SEQ data +c ----------------- + acft_seq_accum(:,nlvinprof) = acft_seq(j,:) + +c Get MSTQ +c -------- + mstq_accum(1,nlvinprof) = mstq(j) + +c Get level category, elevation, reported observation time +c -------------------------------------------------------- + cat_accum(1,nlvinprof) = cat(j) + elv_accum(1,nlvinprof) = hdr(j,5) + rpt_accum(1,nlvinprof) = hdr(j,12) + rct_accum(1,nlvinprof) = rct(j) + +c Check for mandatory levels (CAT = 1), present temperatures (CAT = 2), missing temperatures +c (CAT = 3) + + if(ob_t(j).eq.-9999.) then ! temperature is missing + cat_accum(1,nlvinprof) = 3 + else + cat_accum(1,nlvinprof) = 2 + endif + +c Mandatory level can override other CAT settings + + do k = 1,maxmandlvls + if(lvlsinprof(nlvinprof).eq.mandlvls(k)) then + cat_accum(1,nlvinprof) = 1 + exit ! exit do loop + endif + enddo + +c Get NRLACQC quality string for this ob in the profile +c ----------------------------------------------------- + c_qc_accum(nlvinprof) = c_qc(j) + +c ---------------------------------------------------------- +c Get moisture events, background data, analysis, climo data +c ---------------------------------------------------------- + +c Store non-NRLACQC events in the "profile" arrays before adding any new events (done later +c in subroutine sub2mem_mer) +c ----------------------------------------------------------------------------------------- + qevn_accum(1,nlvinprof,1:nevents(j,2))= qob_ev(j,1:nevents(j,2)) + qevn_accum(2,nlvinprof,1:nevents(j,2))= qqm_ev(j,1:nevents(j,2)) + qevn_accum(3,nlvinprof,1:nevents(j,2))= qpc_ev(j,1:nevents(j,2)) + qevn_accum(4,nlvinprof,1:nevents(j,2))= qrc_ev(j,1:nevents(j,2)) + +c Background info +c --------------- + qbg_accum(:,nlvinprof) = qbg(j,:) ! single-level upon input + +c Post processing info +c -------------------- + qpp_accum(:,nlvinprof) = qpp(j,:) ! single-level upon input + +c ------------------------------------------------------------- +c Get temperature events, background data, analysis, climo data +c ------------------------------------------------------------- + +c Store non-NRLACQC events in the "profile" arrays before adding any new events (done later +c in subroutine sub2mem_mer) +c ----------------------------------------------------------------------------------------- + tevn_accum(1,nlvinprof,1:nevents(j,3))= tob_ev(j,1:nevents(j,3)) + tevn_accum(2,nlvinprof,1:nevents(j,3))= tqm_ev(j,1:nevents(j,3)) + tevn_accum(3,nlvinprof,1:nevents(j,3))= tpc_ev(j,1:nevents(j,3)) + tevn_accum(4,nlvinprof,1:nevents(j,3))= trc_ev(j,1:nevents(j,3)) + +c Background info +c --------------- + tbg_accum(:,nlvinprof) = tbg(j,:) ! single-level upon input + +c Post processing info +c -------------------- + tpp_accum(:,nlvinprof) = tpp(j,:) ! single-level upon input + +c ----------------------------------------------------------------------- +c Get wind (u/v components) events, background data, analysis, climo data +c ----------------------------------------------------------------------- + +c Store non-NRLACQC events in the "profile" arrays before adding any new events (done later +c in subroutine sub2mem_mer) +c ----------------------------------------------------------------------------------------- + wuvevn_accum(1,nlvinprof,1:nevents(j,5)) = + + uob_ev(j,1:nevents(j,5)) + wuvevn_accum(2,nlvinprof,1:nevents(j,5)) = + + vob_ev(j,1:nevents(j,5)) + wuvevn_accum(3,nlvinprof,1:nevents(j,5)) = + + wqm_ev(j,1:nevents(j,5)) + wuvevn_accum(4,nlvinprof,1:nevents(j,5)) = + + wpc_ev(j,1:nevents(j,5)) + wuvevn_accum(5,nlvinprof,1:nevents(j,5)) = + + wrc_ev(j,1:nevents(j,5)) + +c Background info +c --------------- + wuvbg_accum(:,nlvinprof) = wbg(j,:) ! single-level upon input + +c Post Processing info +c -------------------- + wuvpp_accum(:,nlvinprof) = wpp(j,:) ! single-level upon input + +c --------------------------- +c Get wind (dir/speed) events +c --------------------------- + wdsevn_accum(1,nlvinprof,1:nevents(j,6)) = + + ddo_ev(j,1:nevents(j,6)) + wdsevn_accum(2,nlvinprof,1:nevents(j,6)) = + + ffo_ev(j,1:nevents(j,6)) + wdsevn_accum(3,nlvinprof,1:nevents(j,6)) = + + dfq_ev(j,1:nevents(j,6)) + wdsevn_accum(4,nlvinprof,1:nevents(j,6)) = + + dfp_ev(j,1:nevents(j,6)) + wdsevn_accum(5,nlvinprof,1:nevents(j,6)) = + + dfr_ev(j,1:nevents(j,6)) + +c Set tail_prev, flt_prev, elv_prev, idt_prev for comparison to next report to see if we need +c to start a new profile - also set idz_prev for possible gross check +c ------------------------------------------------------------------------------------------- + tail_prev = c_acftreg(j) + flt_prev = c_acftid(j) + elv_prev = ht_ft(j) + idt_prev = idt(j) + idz_prev = zob_ev(j,nevents(j,4)) + +c Close loops here +c ---------------- + enddo loop1 ! i=1,nrpts4QC_pre + + if(l_prof1lvl.or.nlvinprof.gt.1) then + +c Close out last remaining profile and write it to output - open message if necessary +c ----------------------------------------------------------------------------------- + call openmb(proflun,msgtyp2wrt,icdtg_an) + +c Store contents of the current observation (profile or single/flight-level) into BUFRLIB +c memory via subroutine sub2mem_mer +c --------------------------------------------------------------------------------------- + +ccccc print 4079, sortidx(i-1),acid(sortidx(i-1)),acid_last_profile +c4079 format(1x,'2-call sub2mem_mer, last report j-1 = ',i6, +ccccc+ ', acid(j-1) = ',a8,', acid_last_profile = ',a8) + + call sub2mem_mer(proflun,bmiss,mxlv,mxnmev,maxmandlvls,mandlvls, + + msgtyp2wrt,hdr2wrt, + + acid_last_profile, ! use ACID of last (or only) report in profile + + c_acftid_last_profile, ! use aircraft flight # (from NRLACQC) of + ! last (or only) report in profile + + c_acftreg_last_profile,! use aircraft tail # (from NRLACQC) of last + ! (or only) report in profile + + rct_accum,drinfo_accum,acft_seq_accum, + + mstq_accum,cat_accum,elv_accum,rpt_accum, + + tcor_accum, + + pevn_accum,pbg_accum,ppp_accum, + + qevn_accum,qbg_accum,qpp_accum, + + tevn_accum,tbg_accum,tpp_accum, + + zevn_accum,zbg_accum,zpp_accum, + + wuvevn_accum,wuvbg_accum,wuvpp_accum, + + wdsevn_accum,mxe4prof,c_qc_accum, + + num_events_prof,lvlsinprof,nlvinprof, + + nrlacqc_pc,l_mandlvl,tsplines, + + l_operational,lwr) + +c Write the current profile to output +c ----------------------------------- + if(hdr2wrt(6).gt.399.or.l_prof1lvl) then ! sometimes reports with nlvinprof > 1 + ! still come back as single-level reports + ! - this check keeps them out of PREPBUFR- + ! like file when when l_prof1lvl=F + nprofiles_encoded = nprofiles_encoded + 1 + call writsb(proflun) + endif + endif + + if(.not.l_operational) close(52) + +c Output counts +c ------------- + +c Detailed counts of reports eliminated from final PREPBUFR-like file +c ------------------------------------------------------------------- + print * + print *, '----------------------------------------------------' + print *, 'Info about merged aircraft reports not encoded into ' + print *, 'output PREPBUFR-like (profiles) file:' + print *, '----------------------------------------------------' + print * + if(l_otw) then + print 76, trad,elim_knt(1) + 76 format(' Number of merged reports tossed because outside req. ', + + 'time window radius of',F6.2,'hrs (prior to geographical ', + + 'domain checking):',i6/) + else + print *, 'Time window radius check NOT performed, l_otw=',l_otw, + + ' (ZERO reports tossed)' + endif + print * + if(l_nhonly) then + print'(" Number of merged reports passing time window radius ", + + "chk but tossed because outside geographical domain ", + + "(i.e., S of 20S lat): ",I0)', elim_knt(2) + else + print *, 'Geographical domain check not performed, l_nhonly=', + + l_nhonly,' (ZERO reports tossed)' + endif + print * + print *, 'Number of merged reports passing checks and kept: ', + + elim_knt(3) + print * + +c Info about PREPBUFR-like files containing merged profile and (maybe) single(flight)-level +c reports +c ----------------------------------------------------------------------------------------- + print * + print'(" -------------------------------------------------------", + + "-------------------------")' + print'(" Info about QMs applied to merged mass and wind reports", + + " in the PREPBUFR-like file")' + print'(" -------------------------------------------------------", + + "-------------------------")' + print * + print'(" Number of merged ""profile"" reports written to output ", + + "PREPBUFR-like file = "I0)', nprofiles_encoded + print * +! DAK: num_events_prof does not seem to be the right number when single level reports are not +! encoded... + print'(" Total number of events for an ob type, across all ", + + "levels, across all reports, written to output PREPBUFR-", + + "like")' + print'(" (profiles) file = ",I0," (this value is the same for ", + + "each ob type)")', num_events_prof + print * + + write(*,*) + write(*,*) '**************************' + write(*,*) 'output_acqc_prof has ended' + call system('date') + write(*,*) '**************************' + write(*,*) + + return + + end diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pietc.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pietc.f90 new file mode 100644 index 00000000..c3d56d9e --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pietc.f90 @@ -0,0 +1,95 @@ +! +!============================================================================= +module pietc +!============================================================================= +! R. J. Purser (jim.purser@noaa.gov) 2014 +! Some of the commonly used constants (pi etc) mainly for double-precision +! subroutines. +! ms10 etc are needed to satisfy the some (eg., gnu fortran) compilers' +! more rigorous standards regarding the way "data" statements are initialized. +! Zero and the first few units are u0,u1,u2, etc., their reciprocals being, +! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc. +!============================================================================= +use pkind, only: dp,dpc +implicit none +logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops +real(dp),parameter:: & + u0=0,u1=1,mu1=-u1,u2=2,mu2=-u2,u3=3,mu3=-u3,u4=4,mu4=-u4,u5=5,mu5=-u5, & + u6=6,mu6=-u6,o2=u1/2,o3=u1/3,o4=u1/4,o5=u1/5,o6=u1/6, & + pi =3.1415926535897932384626433832795028841971693993751058209749e0_dp, & + pi2=6.2831853071795864769252867665590057683943387987502116419498e0_dp, & + pih=1.5707963267948966192313216916397514420985846996875529104874e0_dp, & + rpi=1.7724538509055160272981674833411451827975494561223871282138e0_dp, & +! Important square-roots + r2 =1.4142135623730950488016887242096980785696718753769480731766e0_dp, & + r3 =1.7320508075688772935274463415058723669428052538103806280558e0_dp, & + r5 =2.2360679774997896964091736687312762354406183596115257242708e0_dp, & + or2=u1/r2,or3=u1/r3,or5=u1/r5, & +! Golden number: + phi=1.6180339887498948482045868343656381177203091798057628621354e0_dp, & +! Euler-Mascheroni constant: + euler=0.57721566490153286060651209008240243104215933593992359880e0_dp, & +! Degree to radians; radians to degrees: + dtor=pi/180,rtod=180/pi, & +! Sines of all main fractions of 90 degrees (down to ninths): + s10=.173648177666930348851716626769314796000375677184069387236241e0_dp,& + s11=.195090322016128267848284868477022240927691617751954807754502e0_dp,& + s13=.222520933956314404288902564496794759466355568764544955311987e0_dp,& + s15=.258819045102520762348898837624048328349068901319930513814003e0_dp,& + s18=.309016994374947424102293417182819058860154589902881431067724e0_dp,& + s20=.342020143325668733044099614682259580763083367514160628465048e0_dp,& + s22=.382683432365089771728459984030398866761344562485627041433800e0_dp,& + s26=.433883739117558120475768332848358754609990727787459876444547e0_dp,& + s30=o2, & + s34=.555570233019602224742830813948532874374937190754804045924153e0_dp,& + s36=.587785252292473129168705954639072768597652437643145991072272e0_dp,& + s39=.623489801858733530525004884004239810632274730896402105365549e0_dp,& + s40=.642787609686539326322643409907263432907559884205681790324977e0_dp,& + s45=or2, & + s50=.766044443118978035202392650555416673935832457080395245854045e0_dp,& + s51=.781831482468029808708444526674057750232334518708687528980634e0_dp,& + s54=.809016994374947424102293417182819058860154589902881431067724e0_dp,& + s56=.831469612302545237078788377617905756738560811987249963446124e0_dp,& + s60=r3*o2, & + s64=.900968867902419126236102319507445051165919162131857150053562e0_dp,& + s68=.923879532511286756128183189396788286822416625863642486115097e0_dp,& + s70=.939692620785908384054109277324731469936208134264464633090286e0_dp,& + s72=.951056516295153572116439333379382143405698634125750222447305e0_dp,& + s75=.965925826289068286749743199728897367633904839008404550402343e0_dp,& + s77=.974927912181823607018131682993931217232785800619997437648079e0_dp,& + s79=.980785280403230449126182236134239036973933730893336095002916e0_dp,& + s80=.984807753012208059366743024589523013670643251719842418790025e0_dp,& +! ... and their minuses: + ms10=-s10,ms11=-s11,ms13=-s13,ms15=-s15,ms18=-s18,ms20=-s20,ms22=-s22,& + ms26=-s26,ms30=-s30,ms34=-s34,ms36=-s36,ms39=-s39,ms40=-s40,ms45=-s45,& + ms50=-s50,ms51=-s51,ms54=-s54,ms56=-s56,ms60=-s60,ms64=-s64,ms68=-s68,& + ms70=-s70,ms72=-s72,ms75=-s75,ms77=-s77,ms79=-s79,ms80=-s80 + +complex(dpc),parameter:: & + c0=(u0,u0),c1=(u1,u0),mc1=-c1,ci=(u0,u1),mci=-ci,cipi=ci*pi, & +! Main fractional rotations, as unimodualr complex numbers: + z000=c1 ,z010=( s80,s10),z011=( s79,s11),z013=( s77,s13),& + z015=( s75,s15),z018=( s72,s18),z020=( s70,s20),z022=( s68,s22),& + z026=( s64,s26),z030=( s60,s30),z034=( s56,s34),z036=( s54,s36),& + z039=( s51,s39),z040=( s50,s40),z045=( s45,s45),z050=( s40,s50),& + z051=( s39,s51),z054=( s36,s54),z056=( s34,s56),z060=( s30,s60),& + z064=( s26,s64),z068=( s22,s68),z070=( s20,s70),z072=( s18,s72),& + z075=( s15,s75),z077=( s13,s77),z079=( s11,s79),z080=( s10,s80),& + z090=ci, z100=(ms10,s80),z101=(ms11,s79),z103=(ms13,s77),& + z105=(ms15,s75),z108=(ms18,s72),z110=(ms20,s70),z112=(ms22,s68),& + z116=(ms26,s64),z120=(ms30,s60),z124=(ms34,s56),z126=(ms36,s54),& + z129=(ms39,s51),z130=(ms40,s50),z135=(ms45,s45),z140=(ms50,s40),& + z141=(ms51,s39),z144=(ms54,s36),z146=(ms56,s34),z150=(ms60,s30),& + z154=(ms64,s26),z158=(ms68,s22),z160=(ms70,s20),z162=(ms72,s18),& + z165=(ms75,s15),z167=(ms77,s13),z169=(ms79,s11),z170=(ms80,s10),& + z180=-z000,z190=-z010,z191=-z011,z193=-z013,z195=-z015,z198=-z018,& + z200=-z020,z202=-z022,z206=-z026,z210=-z030,z214=-z034,z216=-z036,& + z219=-z039,z220=-z040,z225=-z045,z230=-z050,z231=-z051,z234=-z054,& + z236=-z056,z240=-z060,z244=-z064,z248=-z068,z250=-z070,z252=-z072,& + z255=-z075,z257=-z077,z259=-z079,z260=-z080,z270=-z090,z280=-z100,& + z281=-z101,z283=-z103,z285=-z105,z288=-z108,z290=-z110,z292=-z112,& + z296=-z116,z300=-z120,z304=-z124,z306=-z126,z309=-z129,z310=-z130,& + z315=-z135,z320=-z140,z321=-z141,z324=-z144,z326=-z146,z330=-z150,& + z334=-z154,z338=-z158,z340=-z160,z342=-z162,z345=-z165,z347=-z167,& + z349=-z169,z350=-z170 +end module pietc diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pkind.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pkind.f90 new file mode 100644 index 00000000..8c0124fe --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pkind.f90 @@ -0,0 +1,8 @@ +module pkind +private:: one_dpi; integer(8),parameter:: one_dpi=1 +integer,parameter:: dpi=kind(one_dpi) +integer,parameter:: sp=kind(1.0) +integer,parameter:: dp=kind(1.0d0) +integer,parameter:: spc=kind((1.0,1.0)) +integer,parameter:: dpc=kind((1.0d0,1.0d0)) +end module pkind diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat.f90 new file mode 100644 index 00000000..3f65fd36 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat.f90 @@ -0,0 +1,1086 @@ +! +! ********************************************** +! * MODULE pmat * +! * R. J. Purser, NOAA/NCEP/EMC 1993 * +! * and Tsukasa Fujita, visiting scientist * +! * from JMA. * +! * Major modifications: 2002, 2009, 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! Utility routines for various linear inversions and Cholesky. +! Dependency: modules pkind, pietc +! Originally, these routines were copies of the purely "inversion" members +! of pmat1.f90 (a most extensive collection of matrix routines -- not just +! inversions). As well as having both single and double precision versions +! of each routine, these versions also make provision for a more graceful +! termination in cases where the system matrix is detected to be +! essentially singular (and therefore noninvertible). This provision takes +! the form of an optional "failure flag", FF, which is normally returned +! as .FALSE., but is returned as .TRUE. when inversion fails. +! In Sep 2012, these routines were collected together into pmat.f90 so +! that all the main matrix routines could be in the same library, pmat.a. +! +! Last modified: +! Keyser (2014-12-12) - print written to unit 41 rather than stdout (for use in +! prepobs_prepacqc program - limits amount of stdout) +! +! DIRECT DEPENDENCIES: +! Modules: pietc, pkind +! +!============================================================================= +module pmat +!============================================================================= +use pkind, only: sp,dp,spc,dpc +use pietc, only: t,f +implicit none +private +public:: ldum,udlmm,inv,L1Lm,LdLm,invl,invu +interface swpvv; module procedure sswpvv,dswpvv,cswpvv; end interface +interface ldum + module procedure sldum,dldum,cldum,sldumf,dldumf,cldumf; end interface +interface udlmm + module procedure sudlmm,dudlmm,cudlmm,sudlmv,dudlmv,cudlmv; end interface +interface inv + module procedure & +sinvmt, dinvmt, cinvmt, slinmmt, dlinmmt, clinmmt, slinmvt, dlinmvt, clinmvt, & +sinvmtf,dinvmtf,cinvmtf,slinmmtf,dlinmmtf,clinmmtf,slinmvtf,dlinmvtf,clinmvtf,& +iinvf + end interface +interface L1Lm; module procedure sL1Lm,dL1Lm,sL1Lmf,dL1Lmf; end interface +interface LdLm; module procedure sLdLm,dLdLm,sLdLmf,dLdLmf; end interface +interface invl; module procedure sinvl,dinvl,slinlv,dlinlv; end interface +interface invu; module procedure sinvu,dinvu,slinuv,dlinuv; end interface + +contains + +!============================================================================= +subroutine sswpvv(d,e)! [swpvv] +!============================================================================= +! Swap vectors +!------------- +real(sp), intent(inout) :: d(:), e(:) +real(sp) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine sswpvv +!============================================================================= +subroutine dswpvv(d,e)! [swpvv] +!============================================================================= +real(dp), intent(inout) :: d(:), e(:) +real(dp) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine dswpvv +!============================================================================= +subroutine cswpvv(d,e)! [swpvv] +!============================================================================= +complex(dpc),intent(inout) :: d(:), e(:) +complex(dpc) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine cswpvv + +!============================================================================= +subroutine sinvmt(a)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(INOUT):: a +logical :: ff +call sinvmtf(a,ff) +if(ff)stop 'In sinvmt; Unable to invert matrix' +end subroutine sinvmt +!============================================================================= +subroutine dinvmt(a)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +logical :: ff +call dinvmtf(a,ff) +if(ff)stop 'In dinvmt; Unable to invert matrix' +end subroutine dinvmt +!============================================================================= +subroutine cinvmt(a)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a +logical :: ff +call cinvmtf(a,ff) +if(ff)stop 'In cinvmt; Unable to invert matrix' +end subroutine cinvmt +!============================================================================= +subroutine sinvmtf(a,ff)! [inv] +!============================================================================= +! Invert matrix (or flag if can't) +!---------------- +real(sp),dimension(:,:),intent(inout):: a +logical, intent( out):: ff +integer :: m,i,j,jp,l +real(sp) :: d +integer,dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In sinvmtf; matrix passed to sinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call sldumf(a,ipiv,d,ff) +if(ff)then + write(41,'(" In sinvmtf; failed call to sldumf")') + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1./a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo + do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call sswpvv(a(:,j),a(:,l)); enddo +end subroutine sinvmtf +!============================================================================= +subroutine dinvmtf(a,ff)! [inv] +!============================================================================= +real(DP),dimension(:,:),intent(INOUT):: a +logical, intent( OUT):: ff +integer :: m,i,j,jp,l +real(DP) :: d +integer, dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call dldumf(a,ipiv,d,ff) +if(ff)then + write(41,'(" In dinvmtf; failed call to dldumf")') + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo + do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call dswpvv(a(:,j),a(:,l)); enddo +end subroutine dinvmtf +!============================================================================= +subroutine cinvmtf(a,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(INOUT):: a +logical, intent( OUT):: ff +integer :: m,i,j,jp,l +complex(dpc) :: d +integer, dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to cinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call cldumf(a,ipiv,d,ff) +if(ff)then + write(41,'(" In cinvmtf; failed call to cldumf")') + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*sum(a(i:j-1,j)*a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-sum(a(jp:i-1,j)*a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+sum(a(jp:m,j)*a(i,jp:m)); enddo + do i=jp,m; a(i,j)=sum(a(i:m,j)*a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call cswpvv(a(:,j),a(:,l)); enddo +end subroutine cinvmtf + +!============================================================================= +subroutine slinmmt(a,b)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a,b +logical :: ff +call slinmmtf(a,b,ff) +if(ff)stop 'In slinmmt; unable to invert linear system' +end subroutine slinmmt +!============================================================================= +subroutine dlinmmt(a,b)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a,b +logical :: ff +call dlinmmtf(a,b,ff) +if(ff)stop 'In dlinmmt; unable to invert linear system' +end subroutine dlinmmt +!============================================================================= +subroutine clinmmt(a,b)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a,b +logical :: ff +call clinmmtf(a,b,ff) +if(ff)stop 'In clinmmt; unable to invert linear system' +end subroutine clinmmt +!============================================================================= +subroutine slinmmtf(a,b,ff)! [inv] +!============================================================================= +real(SP), dimension(:,:),intent(INOUT):: a,b +logical, intent( OUT):: ff +integer,dimension(size(a,1)) :: ipiv +integer :: m +real(sp) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to slinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in slinmmtf have unmatched sizes' +call sldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In slinmmtf; failed call to sldumf")') + return +endif +call sudlmm(a,b,ipiv) +end subroutine slinmmtf +!============================================================================= +subroutine dlinmmtf(a,b,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:), intent(inout):: a,b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +integer :: m +real(dp) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes' +call dldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In dlinmmtf; failed call to dldumf")') + return +endif +call dudlmm(a,b,ipiv) +end subroutine dlinmmtf +!============================================================================= +subroutine clinmmtf(a,b,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(INOUT):: a,b +logical, intent( OUT):: ff +integer, dimension(size(a,1)) :: ipiv +integer :: m +complex(dpc) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes' +call cldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In clinmmtf; failed call to cldumf")') + return +endif +call cudlmm(a,b,ipiv) +end subroutine clinmmtf + +!============================================================================= +subroutine slinmvt(a,b)! [inv] +!============================================================================= +real(sp), dimension(:,:),intent(inout):: a +real(sp), dimension(:), intent(inout):: b +logical :: ff +call slinmvtf(a,b,ff) +if(ff)stop 'In slinmvt; matrix singular, unable to continue' +end subroutine slinmvt +!============================================================================= +subroutine dlinmvt(a,b)! [inv] +!============================================================================= +real(dp), dimension(:,:),intent(inout):: a +real(dp), dimension(:), intent(inout):: b +logical :: ff +call dlinmvtf(a,b,ff) +if(ff)stop 'In dlinmvt; matrix singular, unable to continue' +end subroutine dlinmvt +!============================================================================= +subroutine clinmvt(a,b)! [inv] +!============================================================================= +complex(dpc), dimension(:,:),intent(inout):: a +complex(dpc), dimension(:), intent(inout):: b +logical :: ff +call clinmvtf(a,b,ff) +if(ff)stop 'In clinmvt; matrix singular, unable to continue' +end subroutine clinmvt +!============================================================================= +subroutine slinmvtf(a,b,ff)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a +real(sp),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer,dimension(size(a,1)) :: ipiv +real(sp) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; In slinmvtf; incompatible array dimensions' +call sldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In slinmvtf; failed call to sldumf")') + return +endif +call sudlmv(a,b,ipiv) +end subroutine slinmvtf +!============================================================================= +subroutine dlinmvtf(a,b,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +real(dp),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +real(dp) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; incompatible array dimensions passed to dlinmvtf' +call dldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In dlinmvtf; failed call to dldumf")') + return +endif +call dudlmv(a,b,ipiv) +end subroutine dlinmvtf +!============================================================================= +subroutine clinmvtf(a,b,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a +complex(dpc),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +complex(dpc) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; incompatible array dimensions passed to clinmvtf' +call cldumf(a,ipiv,d,ff) +if(ff)then + write(41,'("In clinmvtf; failed call to cldumf")') + return +endif +call cudlmv(a,b,ipiv) +end subroutine clinmvtf + +!============================================================================= +subroutine iinvf(imat,ff)! [inv] +!============================================================================= +! Invert integer square array, imat, if possible, but flag ff=.true. +! if not possible. (Determinant of imat must be +1 or -1 +!============================================================================= +integer,dimension(:,:),intent(INOUT):: imat +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-1_dp +real(dp),dimension(size(imat,1),size(imat,1)):: dmat +integer :: m,i,j +!============================================================================= +m=size(imat,1) +if(m /= size(imat,2))stop 'In inv; matrix passed to iinvf is not square' +dmat=imat; call inv(dmat,ff) +if(.not.ff)then + do j=1,m + do i=1,m + imat(i,j)=nint(dmat(i,j)); if(abs(dmat(i,j)-imat(i,j))>eps)ff=t + enddo + enddo +endif +end subroutine iinvf + +!============================================================================= +subroutine sldum(a,ipiv,d)! [ldum] +!============================================================================= +real(sp),intent(inout) :: a(:,:) +real(sp),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical:: ff +call sldumf(a,ipiv,d,ff) +if(ff)stop 'In sldum; matrix singular, unable to continue' +end subroutine sldum +!============================================================================= +subroutine dldum(a,ipiv,d)! [ldum] +!============================================================================= +real(dp),intent(inout) :: a(:,:) +real(dp),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical:: ff +call dldumf(a,ipiv,d,ff) +if(ff)stop 'In dldum; matrix singular, unable to continue' +end subroutine dldum +!============================================================================= +subroutine cldum(a,ipiv,d)! [ldum] +!============================================================================= +complex(dpc),intent(inout) :: a(:,:) +complex(dpc),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical:: ff +call cldumf(a,ipiv,d,ff) +if(ff)stop 'In cldum; matrix singular, unable to continue' +end subroutine cldum +!============================================================================= +subroutine sldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +! R.J.Purser, NCEP, Washington D.C. 1996 +! SUBROUTINE LDUM +! perform l-d-u decomposition of square matrix a in place with +! pivoting. +! +! <-> a square matrix to be factorized +! <-- ipiv array encoding the pivoting sequence +! <-- d indicator for possible sign change of determinant +! <-- ff: failure flag, set to .true. when determinant of a vanishes. +!============================================================================= +real(SP),intent(INOUT) :: a(:,:) +real(SP),intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +real(SP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + write(41,'("In sldumf; row ",i6," of matrix vanishes")'),i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call sswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == 0)then + jm=j-1 + write(41,'(" failure in sldumf:"/" matrix singular, rank=",i3)'),jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine sldumf +!============================================================================= +subroutine DLDUMf(A,IPIV,D,ff)! [ldum] +!============================================================================= +real(DP), intent(INOUT) :: a(:,:) +real(DP), intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +real(DP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + write(41,'("In dldumf; row ",i6," of matrix vanishes")'),i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call dswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == 0)then + jm=j-1 + write(41,'(" Failure in dldumf:"/" matrix singular, rank=",i3)'),jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine DLDUMf +!============================================================================= +subroutine cldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +use pietc, only: c0 +complex(dpc), intent(INOUT) :: a(:,:) +complex(dpc), intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +complex(dpc) :: ajj, ajji, aij +real(dp) :: aam,aa,abig +real(dp),dimension(size(a,1)):: s +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + write(41,'("In cldumf; row ",i6," of matrix vanishes")'),i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call cswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == c0)then + jm=j-1 + write(41,'(" Failure in cldumf:"/" matrix singular, rank=",i3)'),jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine cldumf + +!============================================================================= +subroutine sudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMM +! use l-u factors in A to back-substitute for several rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrux +! <-> B rt-hand-sides vectors on input, corresponding solutions on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +integer, dimension(:), intent(in) :: ipiv +real(sp),dimension(:,:),intent(in) :: a +real(sp),dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1,size(b,2) !loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine sudlmm +!============================================================================= +subroutine dudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv +real(dp), dimension(:,:),intent(in ) :: a +real(dp), dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine dudlmm +!============================================================================= +subroutine cudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv +complex(dpc),dimension(:,:),intent(in ) :: a +complex(dpc),dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +complex(dpc) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine cudlmm + +!============================================================================= +subroutine sudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMV +! use l-u factors in A to back-substitute for 1 rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrix +! <-> B right-hand-side vector on input, corresponding solution on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +integer, dimension(:), intent(in) :: ipiv +real(sp),dimension(:,:),intent(in) :: a +real(sp),dimension(:), intent(inout) :: b +integer :: m,i, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine sudlmv +!============================================================================= +subroutine dudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv(:) +real(dp), dimension(:,:),intent(in ) :: a(:,:) +real(dp), dimension(:), intent(inout) :: b(:) +integer :: m,i, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine dudlmv +!============================================================================= +subroutine cudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv(:) +complex(dpc),dimension(:,:),intent(in ) :: a(:,:) +complex(dpc),dimension(:), intent(inout) :: b(:) +integer :: m,i, l +complex(dpc) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine cudlmv + +!============================================================================= +subroutine sl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(in ) :: a(:,:) +real(sp), intent(inout) :: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call sl1lmf(a,b,ff) +if(ff)stop 'In sl1lm; matrix singular, unable to continue' +end subroutine sl1lm +!============================================================================= +subroutine dl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call dl1lmf(a,b,ff) +if(ff)stop 'In dl1lm; matrix singular, unable to continue' +end subroutine dl1lm + +!============================================================================= +subroutine sl1lmf(a,b,ff)! [L1Lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(IN ) :: a(:,:) +real(sp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(sp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(S <= 0) + if(ff)then + write(41,'("sL1Lmf detects nonpositive a, rank=",i6)'),jm + return + endif + b(j,j)=sqrt(s) + bjji=1/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = 0 +enddo +end subroutine sl1lmf +!============================================================================= +subroutine dl1lmf(a,b,ff) ! [L1Lm] +!============================================================================= +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(dp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(s <= 0) + if(ff)then + write(41,'("dL1LMF detects nonpositive A, rank=",i6)'),jm + return + endif + b(j,j)=sqrt(s) + bjji=1/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = 0 +enddo +return +end subroutine dl1lmf + +!============================================================================= +subroutine sldlm(a,b,d)! [LdLm] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call sldlmf(a,b,d,ff) +if(ff)stop 'In sldlm; matrix singular, unable to continue' +end subroutine sldlm +!============================================================================= +subroutine dldlm(a,b,d)! [LdLm] +!============================================================================= +real(dp), intent(IN ):: a(:,:) +real(dp), intent(INOUT):: b(:,:) +real(dp), intent( OUT):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call dldlmf(a,b,d,ff) +if(ff)stop 'In dldlm; matrix singular, unable to continue' +end subroutine dldlm + +!============================================================================= +subroutine sldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U +!============================================================================= +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(sp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1 + ff=(d(j) == 0) + if(ff)then + write(41,'("In sldlmf; singularity of matrix detected")') + write(41,'("Rank of matrix: ",i6)'),jm + return + endif + bjji=1/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=0 +enddo +end subroutine sldlmf +!============================================================================= +subroutine dldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +real(dp), intent( OUT) :: d(:) +logical, intent( OUT) :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(dp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m; jm=j-1; jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1 + ff=(d(j) == 0) + if(ff)then + write(41,'("In dldlmf; singularity of matrix detected")') + write(41,'("Rank of matrix: ",i6)'),jm + return + endif + bjji=1/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=0 +enddo +end subroutine dldlmf + +!============================================================================== +subroutine sinvu(a)! [invu] +!============================================================================== +! Invert the upper triangular matrix in place by transposing, calling +! invl, and transposing again. +!============================================================================== +real,dimension(:,:),intent(inout):: a +a=transpose(a); call sinvl(a); a=transpose(a) +end subroutine sinvu +!============================================================================== +subroutine dinvu(a)! [invu] +!============================================================================== +real(dp),dimension(:,:),intent(inout):: a +a=transpose(a); call dinvl(a); a=transpose(a) +end subroutine dinvu +!============================================================================== +subroutine sinvl(a)! [invl] +!============================================================================== +! Invert lower triangular matrix in place +!============================================================================== +real(sp), intent(inout) :: a(:,:) +integer :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0 + a(j,j)=1./a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine sinvl +!============================================================================== +subroutine dinvl(a)! [invl] +!============================================================================== +real(dp), intent(inout) :: a(:,:) +integer :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0 + a(j,j)=1./a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine dinvl + +!============================================================================== +subroutine slinlv(a,u)! [invl] +!============================================================================== +! Solve linear system involving lower triangular system matrix. +!============================================================================== +real, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In slinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine slinlv +!============================================================================== +subroutine dlinlv(a,u)! [invl] +!============================================================================== +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine dlinlv + +!============================================================================== +subroutine slinuv(a,u)! [invu] +!============================================================================== +! Solve linear system involving upper triangular system matrix. +!============================================================================== +real, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In linuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine slinuv +!============================================================================== +subroutine dlinuv(a,u)! [invu] +!============================================================================== +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine dlinuv + +end module pmat + diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat2.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat2.f90 new file mode 100644 index 00000000..a315fc67 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat2.f90 @@ -0,0 +1,1231 @@ +! +! ********************************************** +! * MODULE pmat2 * +! * R. J. Purser, NOAA/NCEP/EMC 1994/1999 * +! * jim.purser@noaa.gov * +! * Tsukasa Fujita (JMA) 1999 * +! * * +! ********************************************** +! +! Routines dealing with the operations of banded matrices +! The three special routines allow the construction of compact or +! conventional interpolation and differencing stencils to a general +! order of accuracy. These are: +! AVCO: Averaging, or interpolating; +! DFCO: Differentiating (once); +! DFCO2: Differentiating (twice). +! +! Other routines provide the tools for applying compact schemes, and for +! the construction and application of recursive filters. +! +! Programmers: R. J. Purser and T. Fujita +! National Centers for Environmental Prediction. +! Last modified (Purser): January 6th 2005 +! added nonredundant ldltb and ltdlbv routines for symmetric matrices, +! and remove obsolescent routines. +! Keyser (2014-12-12) - print written to unit 41 rather than stdout (for use in +! prepobs_prepacqc program - limits amount of stdout) +! +! DIRECT DEPENDENCIES +! Libraries[their modules]: pmat[pmat] +! Additional Modules : pkind +! +!============================================================================= +module pmat2 +!============================================================================ +use pkind +implicit none +private +public:: avco,dfco,dfco2, clipb,cad1b,csb1b,cad2b,csb2b, & + ldub,ldltb,udlb,l1ubb,l1ueb,ltdlbv, & + udlbv,udlbx,udlby,udlvb,udlxb,udlyb,u1lbv,u1lbx,u1lby,u1lvb,u1lxb, & + u1lyb,linbv,wrtb +real(dp),parameter:: zero=0 + +interface AVCO; module procedure AVCO, DAVCO, TAVCO; end interface +interface DFCO; module procedure DFCO, DDFCO, TDFCO; end interface +interface DFCO2; module procedure DFCO2, DDFCO2, TDFCO2; end interface +interface CLIPB; module procedure clib, clib_d, clib_c; end interface +interface CAD1B; module procedure CAD1B; end interface +interface CSB1B; module procedure CSB1B; end interface +interface CAD2B; module procedure CAD2B; end interface +interface CSB2B; module procedure CSB2B; end interface +interface LDUB; module procedure LDUB, DLDUB; end interface +interface LDLTB; module procedure LDLTB, DLDLTB; end interface +interface L1UBB; module procedure L1UBB, DL1UBB; end interface +interface L1UEB; module procedure L1UEB, DL1UEB; end interface +interface ltDLBV; module procedure ltdlbv,dltdlbv; end interface +interface UDLB; module procedure UDLB, DUDLB; end interface +interface UDLBV; module procedure UDLBV, dudlbv; end interface +interface UDLBX; module procedure UDLBX; end interface +interface UDLBY; module procedure UDLBY; end interface +interface UDLVB; module procedure UDLVB; end interface +interface UDLXB; module procedure UDLXB; end interface +interface UDLYB; module procedure UDLYB; end interface +interface U1LBV; module procedure U1LBV; end interface +interface U1LBX; module procedure U1LBX; end interface +interface U1LBY; module procedure U1LBY; end interface +interface U1LVB; module procedure U1LVB; end interface +interface U1LXB; module procedure U1LXB; end interface +interface U1LYB; module procedure U1LYB; end interface +interface LINBV; module procedure LINBV; end interface +interface WRTB; module procedure WRTB; end interface +contains + +!============================================================================= +subroutine AVCO(na,nb,za,zb,z0,a,b) ! [AVCO] +!============================================================================= +! SUBROUTINE AVCO +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! jim.purser@noaa.gov 1999 +! +! Compute one row of the coefficients for the compact mid-interval +! interpolation scheme characterized by matrix equation of the form, +! A.t = B.s (*) +! Where s is the vector of "source" values, t the staggered "target" values. +! +! --> NA: number of t-points operated on by this row of the A of (*) +! --> NB: number of s-points operated on by this row of the B of (*) +! --> ZA: coordinates of t-points used in this row of (*) +! --> ZB: coordinates of s-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! <-- A: the NA coefficients A for this scheme +! <-- B: the NB coefficients B for this scheme +!============================================================================= +use pmat, only: inv +integer, intent(IN ) :: na,nb +real, intent(IN ) :: za(na),zb(nb),z0 +real, intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer :: na1,nab,i +real, dimension(na+nb,na+nb):: w +real, dimension(na) :: za0,pa +real, dimension(nb) :: zb0,pb +real, dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=2,nab; w(i,1:na)=pa; pa=pa*za0; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine AVCO +!============================================================================= +subroutine DAVCO(na,nb,za,zb,z0,a,b) ! [AVCO] +!============================================================================= +use pmat, only: inv +integer, intent(IN ) :: na,nb +real(dp), intent(IN ) :: za(na),zb(nb),z0 +real(dp), intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer :: na1,nab,i +real(dp),dimension(na+nb,na+nb):: w +real(dp),dimension(na) :: za0,pa +real(dp),dimension(nb) :: zb0,pb +real(dp),dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=2,nab; w(i,1:na)=pa; pa=pa*za0; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DAVCO +!============================================================================= +subroutine TAVCO(xa,xb,a,b)! [AVCO] +!============================================================================= +real(dp),dimension(:),intent(IN ):: xa,xb +real(dp),dimension(:),intent(OUT):: a,b +!----------------------------------------------------------------------------- +integer:: na,nb +!============================================================================= +na=size(xa); if(na /= size(a))stop 'In tavco; sizes of a and xa different' +nb=size(xb); if(nb /= size(b))stop 'In tavco; sizes of b and xb different' +call DAVCO(na,nb,xa,xb,zero,a,b) +end subroutine TAVCO + +!============================================================================= +subroutine DFCO(na,nb,za,zb,z0,a,b)! [DFCO] +!============================================================================= +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! jim.purser@noaa.gov 1999 +! SUBROUTINE DFCO +! +! Compute one row of the coefficients for either the compact differencing or +! quadrature scheme characterized by matrix equation of the form, +! A.d = B.c (*) +! In either case, d is the derivative of c. +! +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! --> ZA: coordinates of d-points used in this row of (*) +! --> ZB: coordinates of c-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! <-- A: the A-coefficients for this scheme +! <-- B: the B-coefficients for this scheme +!============================================================================= +use pmat, only: inv +integer, intent(IN ) :: na,nb +real, intent(IN ) :: za(na),zb(nb),z0 +real, intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer:: na1,nab,i +real, dimension(na+nb,na+nb):: w +real, dimension(na) :: za0,pa +real, dimension(nb) :: zb0,pb +real, dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=3,nab; w(i,1:na) =pa*(i-2); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DFCO +!============================================================================= +subroutine DDFCO(na,nb,za,zb,z0,a,b) ! Real(dp) version of [DFCO] +!============================================================================= +use pmat, only: inv +integer, intent(IN) :: na,nb +real(dp), intent(IN) :: za(na),zb(nb),z0 +real(dp), intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer :: na1,nab,i +real(dp), dimension(na+nb,na+nb):: w +real(dp), dimension(na) :: za0,pa +real(dp), dimension(nb) :: zb0,pb +real(dp), dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=3,nab; w(i,1:na) =pa*(i-2); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DDFCO +!============================================================================= +subroutine TDFCO(xa,xb,a,b)! [DFCO] +!============================================================================= +real(dp),dimension(:),intent(IN ):: xa,xb +real(dp),dimension(:),intent(OUT):: a,b +!----------------------------------------------------------------------------- +integer:: na,nb +!============================================================================= +na=size(xa); if(na /= size(a))stop 'In tdfco; sizes of a and xa different' +nb=size(xb); if(nb /= size(b))stop 'In tdfco; sizes of b and xb different' +call DDFCO(na,nb,xa,xb,zero,a,b) +end subroutine TDFCO + + +!============================================================================= +subroutine DFCO2(na,nb,za,zb,z0,a,b)! [DFCO2] +!============================================================================= +! SUBROUTINE DFCO2 +! R.J.Purser, National Centers for Environmental Prediction, Washington D.C. +! jim.purser@noaa.gov 1999 +! +! Compute one row of the coefficients for either the compact second- +! differencing scheme characterized by matrix equation of the form, +! A.d = B.c (*) +! Where d is the second-derivative of c. +! +! --> NA: number of d-points operated on by this row of the A of (*) +! --> NB: number of c-points operated on by this row of the B of (*) +! --> ZA: coordinates of d-points used in this row of (*) +! --> ZB: coordinates of c-points used in this row of (*) +! --> Z0: nominal point of application of this row of (*) +! <-- A: the NA coefficients A for this scheme +! <-- B: the NB coefficients B for this scheme +!============================================================================= +use pmat, only: inv +integer, intent(IN ) :: na,nb +real, intent(IN ) :: za(na),zb(nb),z0 +real, intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer:: na1,nab,i +real, dimension(na+nb,na+nb):: w +real, dimension(na) :: za0,pa +real, dimension(nb) :: zb0,pb +real, dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=4,nab; w(i,1:na) =pa*(i-2)*(i-3); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine DFCO2 +!============================================================================= +subroutine DDFCO2(na,nb,za,zb,z0,a,b) ! Real(dp) version of [DFCO2] +!============================================================================= +use pmat, only: inv +integer, intent(IN ) :: na,nb +real(dp), intent(IN ) :: za(na),zb(nb),z0 +real(dp), intent(OUT) :: a(na),b(nb) +!----------------------------------------------------------------------------- +integer :: na1,nab,i +real(dp), dimension(na+nb,na+nb):: w +real(dp), dimension(na) :: za0,pa +real(dp), dimension(nb) :: zb0,pb +real(dp), dimension(na+nb) :: ab +!============================================================================= +na1=na+1; nab=na+nb +za0=za-z0; zb0=zb-z0 +pa=1.; pb=-1. +w=0.; ab=0. +w(1,1:na)=1.; ab(1)=1. +do i=4,nab; w(i,1:na) =pa*(i-2)*(i-3); pa=pa*za0; enddo +do i=2,nab; w(i,na1:nab)=pb; pb=pb*zb0; enddo +call INV(w,ab) +a=ab(1:na); b=ab(na1:nab) +end subroutine ddfco2 +!============================================================================= +subroutine TDFCO2(xa,xb,a,b)! [DFCO2] +!============================================================================= +real(dp),dimension(:),intent(IN ):: xa,xb +real(dp),dimension(:),intent(OUT):: a,b +!----------------------------------------------------------------------------- +integer:: na,nb +!============================================================================= +na=size(xa); if(na /= size(a))stop 'In tdfco2; sizes of a and xa different' +nb=size(xb); if(nb /= size(b))stop 'In tdfco2; sizes of b and xb different' +call DDFCO2(na,nb,xa,xb,zero,a,b) +end subroutine TDFCO2 + + +!============================================================================= +pure subroutine CLIB(m1,m2,mah1,mah2,a)! [CLIPB] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +real, intent(INOUT) :: a(m1,-mah1:mah2) +integer :: j +do j=1,mah1; a(1:min(m1,j),-j)=0.; enddo +do j=m2-m1+1,mah2; a(max(1,m2-j+1):m1,j)=0.; enddo +end subroutine CLIB +!============================================================================= +pure subroutine clib_d(m1,m2,mah1,mah2,a)! [CLIPB] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +real(dp), intent(INOUT) :: a(m1,-mah1:mah2) +integer :: j +do j=1,mah1; a(1:min(m1,j),-j)=0; enddo +do j=m2-m1+1,mah2; a(max(1,m2-j+1):m1,j)=0; enddo +end subroutine clib_d +!============================================================================= +pure subroutine clib_c(m1,m2,mah1,mah2,a)! [CLIPB] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +complex(dpc), intent(INOUT) :: a(m1,-mah1:mah2) +integer :: j +do j=1,mah1; a(1:min(m1,j),-j)=0; enddo +do j=m2-m1+1,mah2; a(max(1,m2-j+1):m1,j)=0; enddo +end subroutine clib_c + +!============================================================================= +subroutine CAD1B(m1,mah1,mah2,mirror2,a)! [CAD1B] +!============================================================================= +! Incorporate operand symmetry near end-1 of a band matrix operator +! +! <-> A: Input as unclipped operator, output as symmetrized and clipped. +! m1, m2: Sizes of implied full matrix +! mah1, mah2: Left and right semi-bandwidths of A. +! mirror2: 2*location of symmetry axis relative to end-1 operand element. +! Note: although m2 is not used here, it IS used in companion routines +! cad2b and csb2b; it is retained in the interests of uniformity. +!============================================================================= +integer, intent(IN ):: m1,mah1,mah2,mirror2 +real, intent(INOUT):: a(0:m1-1,-mah1:mah2) +!----------------------------------------------------------------------------- +integer :: i,i2,jm,jp,jpmax +!============================================================================= +if(mirror2+mah1 > mah2)stop 'In CAD1B; mah2 insufficient' +do i=0,m1-1; i2=i*2; jpmax=mirror2+mah1-i2; if(jpmax <= -mah1)exit + do jm=-mah1,mah2; jp=mirror2-jm-i2; if(jp <= jm)exit + a(i,jp)=a(i,jp)+a(i,jm) ! Reflect and add + a(i,jm)=0. ! zero the exterior part + enddo +enddo +end subroutine CAD1B + +!============================================================================= +subroutine CSB1B(m1,mah1,mah2,mirror2,a)! [CSB1B] +!============================================================================= +! Like cad1b, but for antisymmetric operand +!============================================================================= +integer, intent(IN ):: m1,mah1,mah2,mirror2 +real, intent(INOUT):: a(0:m1-1,-mah1:mah2) +!----------------------------------------------------------------------------- +integer :: i,i2,jm,jp,jpmax +!============================================================================= +if(mirror2+mah1 > mah2)stop 'In CSB1B; mah2 insufficient' +do i=0,m1-1; i2=i*2; jpmax=mirror2+mah1-i2; if(jpmax < -mah1)exit + do jm=-mah1,mah2; jp=mirror2-jm-i2; if(jp < jm)exit + a(i,jp)=a(i,jp)-a(i,jm) ! Reflect and subtract + a(i,jm)=0. ! zero the exterior part + enddo +enddo +end subroutine CSB1B + +!============================================================================= +subroutine CAD2B(m1,m2,mah1,mah2,mirror2,a)! [CAD2B] +!============================================================================= +! Incorporate operand symmetry near end-2 of a band matrix operator +! +! <-> A: Input as unclipped operator, output as symmetrized and clipped. +! m1, m2: Sizes of implied full matrix +! mah1, mah2: Left and right semi-bandwidths of A. +! mirror2: 2*location of symmetry axis relative to end-2 operand element. +!============================================================================= +integer, intent(IN ):: m1,m2,mah1,mah2,mirror2 +real, intent(INOUT):: a(1-m1:0,m1-m2-mah1:m1-m2+mah2) +!----------------------------------------------------------------------------- +integer :: i,i2,jm,jp,jmmin,nah1,nah2 +!============================================================================= +nah1=mah1+m2-m1; nah2=mah2+m1-m2 ! Effective 2nd-index bounds of A +if(mirror2-nah1 > -nah2)stop 'In CAD2B; mah1 insufficient' +do i=0,1-m1,-1; i2=i*2; jmmin=mirror2-nah2-i2; if(jmmin >= nah2)exit + do jp=nah2,nah1,-1; jm=mirror2-jp-i2; if(jm >= jp)exit + a(i,jm)=a(i,jm)+a(i,jp) ! Reflect and add + a(i,jp)=0. ! zero the exterior part + enddo +enddo +end subroutine CAD2B + +!============================================================================= +subroutine CSB2B(m1,m2,mah1,mah2,mirror2,a)! [CSB2B] +!============================================================================= +integer, intent(IN ):: m1,m2,mah1,mah2,mirror2 +real, intent(INOUT):: a(1-m1:0,m1-m2-mah1:m1-m2+mah2) +!----------------------------------------------------------------------------- +integer :: i,i2,jm,jp,jmmin,nah1,nah2 +!============================================================================= +nah1=mah1+m2-m1; nah2=mah2+m1-m2 ! Effective 2nd-index bounds of A +if(mirror2-nah1 > -nah2)stop 'In CSB2B; mah1 insufficient' +do i=0,1-m1,-1; i2=i*2; jmmin=mirror2-nah2-i2; if(jmmin > nah2)exit + do jp=nah2,nah1,-1; jm=mirror2-jp-i2; if(jm > jp)exit + a(i,jm)=a(i,jm)-a(i,jp) ! Reflect and subtract + a(i,jp)=0. ! zero the exterior part + enddo +enddo +end subroutine CSB2B + +!============================================================================= +!SUBROUTINE CEX2B(a,m1,m2,mah1,mah2,mirror2) +!============================================================================= +!INTEGER, INTENT(IN) :: m1,m2,mah1,mah2,mirror2 +!REAL, INTENT(INOUT):: a(1-m1:0,m1-m2-mah1:m1-m2+mah2) +!----------------------------------------------------------------------------- +!INTEGER :: i,i2,jm,jp,jmmin,nah1,nah2,mirror,j0 +!============================================================================= +!nah1=mah1+m2-m1; nah2=mah2+m1-m2 ! Effective 2nd-index bounds of A +!IF(mirror2-nah1 > -nah2)STOP 'In CEX2B; mah1 insufficient' +!mirror=mirror2/2 +!IF(mirror*2 /= mirror2)STOP 'In CEX2B; mirror2 is not even' +!DO i=0,1-m1,-1; i2=i*2; jmmin=mirror2-nah2-i2; IF(jmmin >= nah2)EXIT +! j0=mirror-i +! DO jp=nah2,nah1,-1; jm=mirror2-jp-i2; IF(jm >= jp)EXIT +! a(i,jm)=a(i,jm)-a(i,jp) ! Reflect and subtract +! a(i,j0)=a(i,j0)+2.*a(i,jp) ! Apply double the coefficient to end +! a(i,jp)=0. ! zero the exterior part +! ENDDO +!ENDDO +!END SUBROUTINE CEX2B + +!============================================================================= +subroutine LDUB(m,mah1,mah2,a)! [LDUB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE LDUB +! Compute [L]*[D**-1]*[U] decomposition of asymmetric band-matrix +! +! <-> A: input as the asymmetric band matrix. On output, it contains +! the [L]*[D**-1]*[U] factorization of the input matrix, where +! [L] is lower triangular with unit main diagonal +! [D] is a diagonal matrix +! [U] is upper triangular with unit main diagonal +! --> M: The number of rows of array A +! --> MAH1: the left half-bandwidth of fortran array A +! --> MAH2: the right half-bandwidth of fortran array A +!============================================================================= +integer, intent(IN ) :: m,mah1, mah2 +real, intent(INOUT) :: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jp, i +real :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jp=j+1 + ajj=a(j,0) + if(ajj == 0.)then + write(41,'(" Failure in LDUB:"/" Matrix requires pivoting or is singular")') + stop + endif + ajji=1./ajj + a(j,0)=ajji + do i=jp,imost + aij=ajji*a(i,j-i) + a(i,j-i)=aij + a(i,jp-i:jmost-i)=a(i,jp-i:jmost-i)-aij*a(j,1:jmost-j) + enddo + a(j,1:jmost-j)=ajji*a(j,1:jmost-j) +enddo +end subroutine LDUB +!============================================================================= +subroutine DLDUB(m,mah1,mah2,a) ! Real(dp) version of [LDUB] +!============================================================================= +integer, intent(IN ) :: m,mah1, mah2 +real(dp), intent(INOUT) :: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jp, i +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jp=j+1 + ajj=a(j,0) + if(ajj == 0)then + write(41,'(" Fails in LDUB_d:"/" Matrix requires pivoting or is singular")') + stop + endif + ajji=1./ajj + a(j,0)=ajji + do i=jp,imost + aij=ajji*a(i,j-i) + a(i,j-i)=aij + a(i,jp-i:jmost-i)=a(i,jp-i:jmost-i)-aij*a(j,1:jmost-j) + enddo + a(j,1:jmost-j)=ajji*a(j,1:jmost-j) +enddo +end subroutine DLDUB + +!============================================================================= +subroutine LDLTB(m,mah1,a) ! Real(sp) version of [LDLTB] +!============================================================================= +integer, intent(IN ) :: m,mah1 +real(sp), intent(INOUT) :: a(m,-mah1:0) +!----------------------------------------------------------------------------- +integer :: j, imost, jp, i,k +real(sp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0)then + write(41,'(" Fails in LDLTB:"/" Matrix requires pivoting or is singular")') + stop + endif + ajji=1./ajj + a(j,0)=ajji + do i=jp,imost + aij=a(i,j-i) + a(i,j-i)=ajji*aij + do k=jp,i + a(i,k-i)=a(i,k-i)-aij*a(k,j-k) + enddo + enddo +enddo +end subroutine LDLTB +!============================================================================= +subroutine DLDLTB(m,mah1,a) ! Real(dp) version of [LDLTB] +!============================================================================= +integer, intent(IN ) :: m,mah1 +real(dp), intent(INOUT) :: a(m,-mah1:0) +!----------------------------------------------------------------------------- +integer :: j, imost, jp, i,k +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0)then + write(41,'(" Fails in LDLTB_d:"/" Matrix requires pivoting or is singular")') + stop + endif + ajji=1./ajj + a(j,0)=ajji + do i=jp,imost + aij=a(i,j-i) + a(i,j-i)=ajji*aij + do k=jp,i + a(i,k-i)=a(i,k-i)-aij*a(k,j-k) + enddo + enddo +enddo +end subroutine DLDLTB + + +!============================================================================= +subroutine UDLB(m,mah1,mah2,a) ! Reversed-index version of ldub [UDLB] +!============================================================================= +integer, intent(IN ) :: m,mah1,mah2 +real, dimension(m,-mah1:mah2),intent(INOUT) :: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +real, dimension(m,-mah2:mah1) :: at +!============================================================================= +at=a(m:1:-1,mah2:-mah1:-1); call LDUB(m,mah2,mah1,at) +a=at(m:1:-1,mah1:-mah2:-1) +end subroutine UDLB +!============================================================================= +subroutine DUDLB(m,mah1,mah2,a) ! real(dp) version of udlb [UDLB] +!============================================================================= +integer, intent(IN ) :: m,mah1,mah2 +real(dp),dimension(m,-mah1:mah2),intent(INOUT) :: a(m,-mah1:mah2) +!----------------------------------------------------------------------------- +real(dp),dimension(m,-mah2:mah1) :: at +!============================================================================= +at=a(m:1:-1,mah2:-mah1:-1); call DLDUB(m,mah2,mah1,at) +a=at(m:1:-1,mah1:-mah2:-1) +end subroutine DUDLB + +!============================================================================= +subroutine L1UBB(m,mah1,mah2,mbh1,mbh2,a,b)! [L1UBB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE L1UBB +! Form the [L]*[D]*[U] decomposition of asymmetric band-matrix [A] replace +! lower triangular elements of [A] by [D**-1]*[L]*[D], the upper by [U], +! replace matrix [B] by [D**-1]*[B]. +! +! <-> A input as band matrix, output as lower and upper triangulars with 1s +! implicitly assumed to lie on the main diagonal. The product of these +! triangular matrices is [D**-1]*[A], where [D] is a diagonal matrix. +! <-> B in as band matrix, out as same but premultiplied by diagonal [D**-1] +! --> M Number of rows of A and B +! --> MAH1 left half-width of fortran array A +! --> MAH2 right half-width of fortran array A +! --> MBH1 left half-width of fortran array B +! --> MBH2 right half-width of fortran array B +!============================================================================= +integer, intent(IN ) :: m,mah1, mah2, mbh1, mbh2 +real, intent(INOUT) :: a(m,-mah1:mah2), b(m,-mbh1:mbh2) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jleast, jp, i +real :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(1,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0.)stop 'In L1UBB; zero element found in diagonal factor' + ajji=1./ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=1. + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine L1UBB +!============================================================================= +subroutine DL1UBB(m,mah1,mah2,mbh1,mbh2,a,b) ! Real(dp) version of [L1UBB] +!============================================================================= +integer, intent(IN ) :: m,mah1, mah2, mbh1, mbh2 +real(dp), intent(INOUT) :: a(m,-mah1:mah2), b(m,-mbh1:mbh2) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jleast, jp, i +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(1,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0)stop 'In L1UBB_d; zero element found in diagonal factor' + ajji=1./ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=1. + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine DL1UBB + +!============================================================================= +subroutine L1UEB(m,mah1,mah2,mbh1,mbh2,a,b)! [L1UEB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1998 +! SUBROUTINE L1UEB +! Form the [L]*[D]*[U] decomposition of asymmetric band-matrix [A] replace +! all but row zero of the +! lower triangular elements of [A] by [D**-1]*[L]*[D], the upper by [U], +! replace matrix [B] by [D**-1]*[B]. +! This is a special adaptation of L1UBB used to process quadarature weights +! for QEDBV etc in which the initial quadrature value is provided as input +! instead of being implicitly assumed zero (which is the case for QZDBV etc). +! +! <-> A input as band matrix, output as lower and upper triangulars with 1s +! implicitly assumed to lie on the main diagonal. The product of these +! triangular matrices is [D**-1]*[A], where [D] is a diagonal matrix. +! <-> B in as band matrix, out as same but premultiplied by diagonal [D**-1] +! --> M number of rows of B, one less than the rows of A (which has "row 0") +! --> MAH1 left half-width of fortran array A +! --> MAH2 right half-width of fortran array A +! --> MBH1 left half-width of fortran array B +! --> MBH2 right half-width of fortran array B +!============================================================================= +integer, intent(IN ) :: m,mah1, mah2, mbh1, mbh2 +real, intent(INOUT) :: a(0:m,-mah1:mah2), b(m,-mbh1:mbh2) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jleast, jp, i +real :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(0,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0.)stop 'In L1UEB; zero element found in diagonal factor' + ajji=1./ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=1. + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine L1UEB +!============================================================================= +subroutine DL1UEB(m,mah1,mah2,mbh1,mbh2,a,b) ! Real(dp) version of [L1UEB] +!============================================================================= +integer, intent(IN ):: m,mah1, mah2, mbh1, mbh2 +real(dp), intent(INOUT):: a(0:,-mah1:), b(:,-mbh1:) +!----------------------------------------------------------------------------- +integer :: j, imost, jmost, jleast, jp, i +real(dp) :: ajj, ajji, aij +!============================================================================= +do j=1,m + imost=min(m,j+mah1) + jmost=min(m,j+mah2) + jleast=max(0,j-mah1) + jp=j+1 + ajj=a(j,0) + if(ajj == 0)stop 'In L1UEB_D; zero element found in diagonal factor' + ajji=1./ajj + a(j,jleast-j:jmost-j) = ajji * a(j,jleast-j:jmost-j) + do i=jp,imost + aij=a(i,j-i) + a(i,jp-i:jmost-i) = a(i,jp-i:jmost-i) - aij*a(j,jp-j:jmost-j) + enddo + a(j,0)=1. + b(j,-mbh1:mbh2) = ajji * b(j,-mbh1:mbh2) +enddo +end subroutine DL1UEB + +!============================================================================= +subroutine UDLBV(m,mah1,mah2,a,v)! [UDLBV] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLBV +! BACk-substitution step of linear inversion involving +! Banded matrix and Vector. +! +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! <-> V input as right-hand-side vector, output as solution vector +! --> M the number of rows assumed for A and for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real, intent(IN ) :: a(m,-mah1:mah2) +real, intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah2),j-1; v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +end subroutine UDLBV +!============================================================================= +subroutine dudlbv(m,mah1,mah2,a,v)! [udlbv] +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real(dp), intent(IN ) :: a(m,-mah1:mah2) +real(dp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real(dp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah2),j-1; v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +end subroutine dudlbv + +!============================================================================= +subroutine ltdlbv(m,mah1,a,v)! [ltdlbv] +!============================================================================= +! Like udlbv, except assuming a is the ltdl decomposition of a SYMMETRIC +! banded matrix, with only the non-upper part provided (to avoid redundancy) +!============================================================================= +integer, intent(IN ) :: m, mah1 +real(sp), intent(IN ) :: a(m,-mah1:0) +real(sp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real(sp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah1),j-1; v(i)=v(i)-a(j,i-j)*vj; enddo +enddo +end subroutine ltdlbv +!============================================================================= +subroutine dltdlbv(m,mah1,a,v)! [ltdlbv] +!============================================================================= +! Like udlbv, except assuming a is the ltdl decomposition of a SYMMETRIC +! banded matrix, with only the non-upper part provided (to avoid redundancy) +!============================================================================= +integer, intent(IN ) :: m, mah1 +real(dp), intent(IN ) :: a(m,-mah1:0) +real(dp), intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real(dp) :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo; v(j)=a(j,0)*vj +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah1),j-1; v(i)=v(i)-a(j,i-j)*vj; enddo +enddo +end subroutine dltdlbv + +!============================================================================= +subroutine UDLBX(mx,mah1,mah2,my,a,v)! [UDLBX] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLBX +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and X-Vectors. +! +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB or, if N=NA, by LDUB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +integer, intent(IN ) :: mx, mah1, mah2, my +real, intent(IN ) :: a(mx,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: jx, ix +!============================================================================= +do jx=1,mx + do ix=jx+1,min(mx,jx+mah1); v(ix,:) = v(ix,:) - a(ix,jx-ix)*v(jx,:); enddo + v(jx,:) = a(jx,0) * v(jx,:) +enddo +do jx=mx,2,-1 + do ix=max(1,jx-mah2),jx-1; v(ix,:) = v(ix,:) - a(ix,jx-ix)*v(jx,:); enddo +enddo +end subroutine UDLBX + +!============================================================================= +subroutine UDLBY(my,mah1,mah2,mx,a,v)! [UDLBY] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLBY +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and Y-Vectors. +! +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB or, if N=NA, by LDUB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +integer, intent(IN ) :: my, mah1, mah2, mx +real, intent(IN ) :: a(my,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: iy, jy +!============================================================================= +do jy=1,my + do iy=jy+1,min(my,jy+mah1); v(:,iy) = v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo + v(:,jy)=a(jy,0)*v(:,jy) +enddo +do jy=my,2,-1 + do iy=max(1,jy-mah2),jy-1; v(:,iy)=v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo +enddo +end subroutine UDLBY + +!============================================================================= +subroutine UDLVB(m,mah1,mah2,v,a)! [UDLVB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLVB +! BACk-substitution step of linear inversion involving +! row-Vector and Banded matrix. +! +! <-> V input as right-hand-side row-vector, output as solution vector +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! --> M the number of rows assumed for A and columns for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real, intent(IN ) :: a(m,-mah1:mah2) +real, intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real :: vi +!============================================================================= +do i=1,m + vi=v(i) + do j=i+1,min(m,i+mah2); v(j)=v(j)-vi*a(i,j-i); enddo + v(i)=vi*a(i,0) +enddo +do i=m,2,-1 + vi=v(i) + do j=max(1,i-mah1),i-1; v(j)=v(j)-vi*a(i,j-i); enddo +enddo +end subroutine UDLVB + +!============================================================================= +subroutine UDLXB(mx,mah1,mah2,my,v,a)! [UDLXB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLXB +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and row-X-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +integer, intent(IN ) :: mx, mah1, mah2, my +real, intent(IN ) :: a(mx,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: ix, jx +!============================================================================= +do ix=1,mx + do jx=ix+1,min(mx,ix+mah2); v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo + v(ix,:)=v(ix,:)*a(ix,0) +enddo +do ix=mx,2,-1 + do jx=max(1,ix-mah1),ix-1; v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo +enddo +end subroutine UDLXB + +!============================================================================= +subroutine UDLYB(my,mah1,mah2,mx,v,a)! [UDLYB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE UDLYB +! BACk-substitution step of parallel linear inversion involving +! Banded matrix and row-Y-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the (L)*(D**-1)*(U) factorization of the linear-system +! matrix, as supplied by subroutine LDUB +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +integer, intent(IN ) :: my, mah1, mah2, mx +real, intent(IN ) :: a(my,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: iy, jy +!============================================================================= +do iy=1,my + do jy=iy+1,min(my,iy+mah2); v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo + v(:,iy)=v(:,iy)*a(iy,0) +enddo +do iy=my,2,-1 + do jy=max(1,iy-mah1),iy-1; v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo +enddo +end subroutine UDLYB + +!============================================================================= +subroutine U1LBV(m,mah1,mah2,a,v)! [U1LBV] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LBV +! BACk-substitution step ((U**-1)*(L**-1)) of linear inversion involving +! special Banded matrix and right-Vector. +! +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! <-> V input as right-hand-side vector, output as solution vector +! --> M the number of rows assumed for A and for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real, intent(IN ) :: a(m,-mah1:mah2) +real, intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real :: vj +!============================================================================= +do j=1,m + vj=v(j) + do i=j+1,min(m,j+mah1); v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +do j=m,2,-1 + vj=v(j) + do i=max(1,j-mah2),j-1; v(i)=v(i)-a(i,j-i)*vj; enddo +enddo +end subroutine U1LBV + +!============================================================================= +subroutine U1LBX(mx,mah1,mah2,my,a,v)! [U1LBX] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LBX +! Special BaCk-substitution step of parallel linear inversion involving +! Banded matrix and X-right-Vectors. +! +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +integer, intent(IN ) :: mx, mah1, mah2, my +real, intent(IN ) :: a(mx,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: ix, jx +!============================================================================= +do jx=1,mx + do ix=jx+1,min(mx,jx+mah1); v(ix,:)=v(ix,:)-a(ix,jx-ix)*v(jx,:); enddo +enddo +do jx=mx,2,-1 + do ix=max(1,jx-mah2),jx-1; v(ix,:)=v(ix,:)-a(ix,jx-ix)*v(jx,:); enddo +enddo +end subroutine U1LBX + +!============================================================================= +subroutine U1LBY(my,mah1,mah2,mx,a,v)! [U1LBY] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LBY +! Special BaCk-substitution step of parallel linear inversion involving +! Banded matrix and Y-right-Vectors. +! +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! <-> V input as right-hand-side vectors, output as solution vectors +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +integer, intent(IN ) :: my, mah1, mah2, mx +real, intent(IN ) :: a(my,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: iy, jy +!============================================================================= +do jy=1,my + do iy=jy+1,min(my,jy+mah1); v(:,iy)=v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo +enddo +do jy=my,2,-1 + do iy=max(1,jy-mah2),jy-1; v(:,iy)=v(:,iy)-a(iy,jy-iy)*v(:,jy); enddo +enddo +end subroutine U1LBY + +!============================================================================= +subroutine U1LVB(m,mah1,mah2,v,a)! [U1LVB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LVB +! Special BaCk-substitution step of linear inversion involving +! left-Vector and Banded matrix. +! +! <-> V input as right-hand-side row-vector, output as solution vector +! --> A encodes the special [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! --> M the number of rows assumed for A and columns for V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real, intent(IN ) :: a(m,-mah1:mah2) +real, intent(INOUT) :: v(m) +!----------------------------------------------------------------------------- +integer :: i, j +real :: vi +!============================================================================= +do i=1,m + vi=v(i) + do j=i+1,min(m,i+mah2); v(j)=v(j)-vi*a(i,j-i); enddo +enddo +do i=m,2,-1 + vi=v(i) + do j=max(1,i-mah1),i-1; v(j)=v(j)-vi*a(i,j-i); enddo +enddo +end subroutine U1LVB + +!============================================================================= +subroutine U1LXB(mx,mah1,mah2,my,v,a)! [U1LXB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LXB +! Special BaCk-substitution step of parallel linear inversion involving +! Banded matrix and X-left-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the special [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! --> MX the number of rows assumed for A and length of +! X-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MY number of parallel X-vectors inverted +!============================================================================= +integer, intent(IN ) :: mx, mah1, mah2, my +real, intent(IN ) :: a(mx,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: ix, jx +!============================================================================= +do ix=1,mx + do jx=ix+1,min(mx,ix+mah2); v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo +enddo +do ix=mx,2,-1 + do jx=max(1,ix-mah1),ix-1; v(jx,:)=v(jx,:)-v(ix,:)*a(ix,jx-ix); enddo +enddo +end subroutine U1LXB + +!============================================================================= +subroutine U1LYB(my,mah1,mah2,mx,v,a)! [U1LYB] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1996 +! SUBROUTINE U1LYB +! Special BaCk-substitution step of parallel linear inversion involving +! special Banded matrix and Y-left-Vectors. +! +! <-> V input as right-hand-side vectors, output as solution vectors +! --> A encodes the [L]*[U] factorization of the linear-system +! matrix, as supplied by subroutine L1UBB +! --> MY the number of rows assumed for A and length of +! Y-vectors stored in V +! --> MAH1 the left half-bandwidth of fortran array A +! --> MAH2 the right half-bandwidth of fortran array A +! --> MX number of parallel Y-vectors inverted +!============================================================================= +integer, intent(IN ) :: my, mah1, mah2, mx +real, intent(IN ) :: a(my,-mah1:mah2) +real, intent(INOUT) :: v(mx,my) +!----------------------------------------------------------------------------- +integer :: iy, jy +!============================================================================= +do iy=1,my + do jy=iy+1,min(my,iy+mah2); v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo +enddo +do iy=my,2,-1 + do jy=max(1,iy-mah1),iy-1; v(:,jy)=v(:,jy)-v(:,iy)*a(iy,jy-iy); enddo +enddo +end subroutine U1LYB + +!============================================================================= +subroutine LINBV(m,mah1,mah2,a,v)! [LINBV] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1994 +! SUBROUTINE LINBV +! Solve LINear system with square Banded-matrix and vector V +! +! <-> A system matrix on input, its [L]*[D**-1]*[U] factorization on exit +! <-> V vector of right-hand-sides on input, solution vector on exit +! --> M order of matrix A +! --> MAH1 left half-bandwidth of A +! --> MAH2 right half-bandwidth of A +!============================================================================= +integer, intent(IN ) :: m, mah1, mah2 +real, intent(INOUT) :: a(m,-mah1:mah2), v(m) +!============================================================================= +call LDUB(m,mah1,mah2,a) +call UDLBV(m,mah1,mah2,a,v) +end subroutine LINBV + +!============================================================================= +subroutine WRTB(m1,m2,mah1,mah2,a)! [WRTB] +!============================================================================= +integer, intent(IN) :: m1, m2, mah1, mah2 +real, intent(IN) :: a(m1,-mah1:mah2) +!----------------------------------------------------------------------------- +integer :: i1, i2, i, j1, j2, j, nj1 +!============================================================================= +do i1=1,m1,20 + i2=min(i1+19,m1) + write(41,'(7x,6(i2,10x))'),(j,j=-mah1,mah2) + do i=i1,i2 + j1=max(-mah1,1-i) + j2=min(mah2,m2-i) + nj1=j1+mah1 + if(nj1==0) write(41,'(1x,i3,6(1x,e12.5))'), i,(a(i,j),j=j1,j2) + if(nj1==1) write(41,'(1x,i3,12x,5(1x,e12.5))'),i,(a(i,j),j=j1,j2) + if(nj1==2) write(41,'(1x,i3,24x,4(1x,e12.5))'),i,(a(i,j),j=j1,j2) + if(nj1==3) write(41,'(1x,i3,36x,3(1x,e12.5))'),i,(a(i,j),j=j1,j2) + if(nj1==4) write(41,'(1x,i3,48x,2(1x,e12.5))'),i,(a(i,j),j=j1,j2) + if(nj1==5) write(41,'(1x,i3,60x,1(1x,e12.5))'),i,(a(i,j),j=j1,j2) + enddo + read(*,*) +enddo +end subroutine WRTB + +end module pmat2 diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat3.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat3.f90 new file mode 100644 index 00000000..93099d9e --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pmat3.f90 @@ -0,0 +1,912 @@ +! +! ********************************************** +! * MODULE pmat3 * +! * R. J. Purser, NOAA/NCEP/EMC Oct 2012 * +! * jim.purser@noaa.gov * +! * * +! ********************************************** +! +! Basic generic matrix routines that can each be expressed conveniently as a +! fortran PURE FUNCTION, or, where matrix inversion is involved, as a +! fortran FUNCTION at least +! +! Single precision real and complex routines are not accommodated here. +! Where it generally makes sense to include an integer version, this is +! included and signified by a function name ending "_i". +! The real functions have names ending "_d". +! The complex functions have names ending "_c". +! +! Last modified: +! Keyser (2014-12-12) - print written to unit 41 rather than stdout (for use in +! prepobs_prepacqc program - limits amount of stdout) +! +! DIRECT DEPENDENCIES +! Libraries[their Modules]: pmat[pmat,pmat2] +! Additional Modules : pietc, pkind +! +!============================================================================= +module pmat3 +!============================================================================= +use pkind, only: dp,dpc +implicit none +private +public:: norv,mulmd,muldm,diag,inv,mulpp,difp,intp,invp,powp,polps,polpp, & + copbm,copmb,transposeb,mulbb,mulbd,muldb,mulbv,mulbx,mulby, & + mulvb,mulxb,mulyb,L1Lb,u1ub,LdLb,udub + +interface norv; module procedure norv_d,norv_c; end interface +interface mulmd; module procedure mulmd_i,mulmd_d,mulmd_c; end interface +interface muldm; module procedure muldm_i,muldm_d,muldm_c; end interface +interface diag + module procedure diagmofd_i,diagmofd_d,diagmofd_c, & + diagdofm_i,diagdofm_d,diagdofm_c + end interface +interface inv; module procedure invm_d,invm_c, finvm_d,finvm_c, & + invmv_d,invmv_c,finvmv_d,finvmv_c + end interface +interface mulpp; module procedure mulpp_i,mulpp_d,mulpp_c; end interface +interface difp; module procedure difp_d,difp_c,ndifp_d,ndifp_c; end interface +interface intp; module procedure intp_d,intp_c,nintp_d,nintp_c; end interface +interface invp; module procedure ninvp_d,ninvp_c; end interface +interface powp; module procedure npowp_d,npowp_c; end interface +interface polps; module procedure polps_d,polps_c, & + npolps_d,npolps_c; end interface +interface polpp; module procedure npolpp_d,npolpp_c; end interface +!----------------------------------------------------------------------------- +! Banded matrix functions: +interface copbm; module procedure copbm_d,copbm_c; end interface +interface copmb; module procedure copmb_d,copmb_c; end interface +interface transposeb; module procedure transposeb_d,transposeb_c; end interface +interface mulbb; module procedure mulbb_d; end interface +interface mulbd; module procedure mulbd_d; end interface +interface muldb; module procedure muldb_d; end interface +interface mulbv; module procedure mulbv_d; end interface +interface mulbx; module procedure mulbx_d; end interface +interface mulby; module procedure mulby_d; end interface +interface mulvb; module procedure mulvb_d; end interface +interface mulxb; module procedure mulxb_d; end interface +interface mulyb; module procedure mulyb_d; end interface +interface L1Lb; module procedure L1Lb_d,fL1Lb_d; end interface +interface u1ub; module procedure u1ub_d,fu1ub_d; end interface +interface LdLb; module procedure LdLb_d,fLdLb_d; end interface +interface udub; module procedure udub_d,fudub_d; end interface + +contains +!============================================================================= +pure function norv_d(a)result(b)! [norv] +!============================================================================= +! Norm of vector a +!------------------------------ +real(dp),dimension(:),intent(in):: a +real(dp) :: b +b=sqrt(dot_product(a,a)) +end function norv_d +!============================================================================= +pure function norv_c(a)result(b)! [norv] +!============================================================================= +! Norm of vector a +!------------------------------ +complex(dpc),dimension(:),intent(in):: a +real(dp) :: b +b=sqrt(real(dot_product(a,a))) +end function norv_c + +!============================================================================= +pure function mulmd_i(a,d)result(b)! [mulmd] +!============================================================================= +! matrix times diagonal +!------------------------------ +integer,dimension(:,:), intent(in):: a +integer,dimension(:) , intent(in):: d +integer,dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,2))b(:,i)=a(:,i)*d(i) +end function mulmd_i +!============================================================================= +pure function mulmd_d(a,d)result(b)! [mulmd] +!============================================================================= +! matrix times diagonal +!------------------------------ +real(dp),dimension(:,:), intent(in):: a +real(dp),dimension(:) , intent(in):: d +real(dp),dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,2))b(:,i)=a(:,i)*d(i) +end function mulmd_d +!============================================================================= +pure function mulmd_c(a,d)result(b)! [mulmd] +!============================================================================= +! matrix times diagonal +!------------------------------ +complex(dpc),dimension(:,:), intent(in):: a +complex(dpc),dimension(:) , intent(in):: d +complex(dpc),dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,2))b(:,i)=a(:,i)*d(i) +end function mulmd_c + +!============================================================================= +pure function muldm_i(d,a)result(b)! [muldm] +!============================================================================= +! matrix times diagonal +!------------------------------ +integer,dimension(:) , intent(in):: d +integer,dimension(:,:), intent(in):: a +integer,dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,1))b(i,:)=d(i)*a(i,:) +end function muldm_i +!============================================================================= +pure function muldm_d(d,a)result(b)! [muldm] +!============================================================================= +! matrix times diagonal +!------------------------------ +real(dp),dimension(:) , intent(in):: d +real(dp),dimension(:,:), intent(in):: a +real(dp),dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,1))b(i,:)=d(i)*a(i,:) +end function muldm_d +!============================================================================= +pure function muldm_c(d,a)result(b)! [muldm] +!============================================================================= +! matrix times diagonal +!------------------------------ +complex(dpc),dimension(:) , intent(in):: d +complex(dpc),dimension(:,:), intent(in):: a +complex(dpc),dimension(size(a,1),size(a,2)):: b +integer :: i +forall(i=1:size(a,1))b(i,:)=d(i)*a(i,:) +end function muldm_c + +!============================================================================= +pure function diagmofd_i(d)result(a)! [diag] +!============================================================================= +! Diagonal matrix possessing given diagonal elements +!------------------------------ +integer,dimension(:), intent(in):: d +integer,dimension(size(d),size(d)):: a +integer :: i +a=0; forall(i=1:size(d))a(i,i)=d(i) +end function diagmofd_i +!============================================================================= +pure function diagmofd_d(d)result(a)! [diag] +!============================================================================= +! Diagonal matrix possessing given diagonal elements +!------------------------------ +real(dp),dimension(:), intent(in):: d +real(dp),dimension(size(d),size(d)):: a +integer :: i +a=0; forall(i=1:size(d))a(i,i)=d(i) +end function diagmofd_d +!============================================================================= +pure function diagmofd_c(d)result(a)! [diag] +!============================================================================= +! Diagonal matrix possessing given diagonal elements +!------------------------------ +complex(dpc),dimension(:), intent(in):: d +complex(dpc),dimension(size(d),size(d)):: a +integer :: i +a=0; forall(i=1:size(d))a(i,i)=d(i) +end function diagmofd_c + +!============================================================================= +pure function diagdofm_i(a)result(d)! [diag] +!============================================================================= +! Diagonal vector of principal diagonal elements of square matrix +!------------------------------ +integer,dimension(:,:),intent(in):: a +integer,dimension(size(a,1)) :: d +integer :: i +forall(i=1:size(a,1))d(i)=a(i,i) +end function diagdofm_i +!============================================================================= +pure function diagdofm_d(a)result(d)! [diag] +!============================================================================= +! Diagonal vector of principal diagonal elements of square matrix +!------------------------------ +real(dp),dimension(:,:),intent(in):: a +real(dp),dimension(size(a,1)) :: d +integer :: i +forall(i=1:size(a,1))d(i)=a(i,i) +end function diagdofm_d +!============================================================================= +pure function diagdofm_c(a)result(d)! [diag] +!============================================================================= +! Diagonal vector of principal diagonal elements of square matrix +!------------------------------ +complex(dpc),dimension(:,:),intent(in):: a +complex(dpc),dimension(size(a,1)) :: d +integer :: i +forall(i=1:size(a,1))d(i)=a(i,i) +end function diagdofm_c + +!============================================================================= +function invm_d(a)result(b)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +real(dp),dimension(:,:), intent(in):: a +real(dp),dimension(size(a,1),size(a,1)):: b +logical :: ff +b=a; call sinv(b,ff) +if(ff)stop 'In function invm_d; matrix singular, unable to continue' +end function invm_d +!============================================================================= +function invm_c(a)result(b)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +complex(dpc),dimension(:,:), intent(in):: a +complex(dpc),dimension(size(a,1),size(a,1)):: b +logical :: ff +b=a; call sinv(b,ff) +if(ff)stop 'In function invm_c; matrix singular, unable to continue' +end function invm_c +!============================================================================= +function finvm_d(a,ff)result(b)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +real(dp),dimension(:,:), intent(in ):: a +logical, intent(out):: ff +real(dp),dimension(size(a,1),size(a,1)) :: b +b=a; call sinv(b,ff) +if(ff) write(41,'("In function finvm_d; singular matrix")') +end function finvm_d +!============================================================================= +function finvm_c(a,ff)result(b)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +complex(dpc),dimension(:,:), intent(in ):: a +logical, intent(out):: ff +complex(dpc),dimension(size(a,1),size(a,1)) :: b +b=a; call sinv(b,ff) +if(ff) write(41,'("In function finvm_c; singular matrix")') +end function finvm_c + +!============================================================================= +function invmv_d(a,v)result(u)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +real(dp),dimension(:,:), intent(in):: a +real(dp),dimension(:) , intent(in):: v +real(dp),dimension(size(a,1),size(a,1)):: b +real(dp),dimension(size(a,1)) :: u +logical :: ff +b=a; u=v; call sinv(b,u,ff) +if(ff)stop 'IN function invmv_d; matrix singular, unable to continue' +end function invmv_d +!============================================================================= +function invmv_c(a,v)result(u)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +complex(dpc),dimension(:,:), intent(in):: a +complex(dpc),dimension(:) , intent(in):: v +complex(dpc),dimension(size(a,1),size(a,1)):: b +complex(dpc),dimension(size(a,1)) :: u +logical :: ff +b=a; u=v; call sinv(b,u,ff) +if(ff)stop 'IN function invmv_c; matrix singular, unable to continue' +end function invmv_c +!============================================================================= +function finvmv_d(a,v,ff)result(u)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +real(dp),dimension(:,:), intent(in):: a +real(dp),dimension(:) , intent(in):: v +logical, intent(out):: ff +real(dp),dimension(size(a,1),size(a,1)) :: b +real(dp),dimension(size(a,1)) :: u +b=a; u=v; call sinv(b,u,ff) +if(ff) write(41,'("In function finvmv_d; singular matrix")') +end function finvmv_d +!============================================================================= +function finvmv_c(a,v,ff)result(u)! [inv] +!============================================================================= +use pmat, only: sinv=>inv +complex(dpc),dimension(:,:), intent(in ):: a +complex(dpc),dimension(:) , intent(in ):: v +logical, intent(out):: ff +complex(dpc),dimension(size(a,1),size(a,1)) :: b +complex(dpc),dimension(size(a,1)) :: u +b=a; u=v; call sinv(b,u,ff) +if(ff) write(41,'("In function finvmv_c; singular matrix")') +end function finvmv_c + +!============================================================================= +pure function mulpp_i(a,b)result(c)! [mulpp] +!============================================================================= +! Multiply two polynomials expressed by their coefficients, or convolve +! two one-sided discrete distributions of not necessarily equal size. +!============================================================================= +integer,dimension(0:),intent(in) :: a,b +integer,dimension(0:size(a)+size(b)-2):: c +integer :: i,j +integer :: ai +c=0;do i=0,size(a)-1;ai=a(i);forall(j=0:size(b)-1)c(i+j)=c(i+j)+ai*b(j); enddo +end function mulpp_i +!============================================================================= +pure function mulpp_d(a,b)result(c)! [mulpp] +!============================================================================= +real(dp),dimension(0:),intent(in) :: a,b +real(dp),dimension(0:size(a)+size(b)-2):: c +integer :: i,j +real(dp) :: ai +c=0;do i=0,size(a)-1;ai=a(i);forall(j=0:size(b)-1)c(i+j)=c(i+j)+ai*b(j); enddo +end function mulpp_d +!============================================================================= +pure function mulpp_c(a,b)result(c)! [mulpp] +!============================================================================= +complex(dpc),dimension(0:),intent(in) :: a,b +complex(dpc),dimension(0:size(a)+size(b)-2):: c +integer :: i,j +complex(dpc) :: ai +c=0;do i=0,size(a)-1;ai=a(i);forall(j=0:size(b)-1)c(i+j)=c(i+j)+ai*b(j); enddo +end function mulpp_c + +!============================================================================= +pure function nmulpp_i(n,a,b)result(c)! [mulpp] +!============================================================================= +! Multiply two polynomials expressed by their coefficients, or convolve +! two one-sided discrete distributions of fixed size, truncating the result +! to the same size. +!============================================================================= +integer, intent(in):: n +integer,dimension(0:n),intent(in):: a,b +integer,dimension(0:n) :: c +integer :: i,j +integer :: ai +c=0; do i=0,n; ai=a(i);forall(j=0:n-i)c(i+j)=c(i+j)+ai*b(j); enddo +end function nmulpp_i +!============================================================================= +pure function nmulpp_d(n,a,b)result(c)! [mulpp] +!============================================================================= +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a,b +real(dp),dimension(0:n) :: c +integer :: i,j +real(dp) :: ai +c=0; do i=0,n; ai=a(i);forall(j=0:n-i)c(i+j)=c(i+j)+ai*b(j); enddo +end function nmulpp_d +!============================================================================= +pure function nmulpp_c(n,a,b)result(c)! [mulpp] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a,b +complex(dpc),dimension(0:n) :: c +integer :: i,j +complex(dpc) :: ai +c=0; do i=0,n; ai=a(i);forall(j=0:n-i)c(i+j)=c(i+j)+ai*b(j); enddo +end function nmulpp_c + +!============================================================================= +pure function difp_d(a)result(b)! [difp] +!============================================================================= +! Differentiate the polynomial, result being of degree one less. +!============================================================================= +real(dp),dimension(0:),intent(in):: a +real(dp),dimension(0:size(a)-2) :: b +integer :: i +forall(i=1:size(a)-1)b(i-1)=i*a(i) +end function difp_d +!============================================================================= +pure function difp_c(a)result(b)! [difp] +!============================================================================= +complex(dpc),dimension(0:),intent(in):: a +complex(dpc),dimension(0:size(a)-2) :: b +integer :: i +forall(i=1:size(a)-1)b(i-1)=i*a(i) +end function difp_c +!============================================================================= +pure function ndifp_d(n,a)result(b)! [difp] +!============================================================================= +! Differentiate the polynomial of fixed degree, force result to be same degree +!============================================================================= +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a +real(dp),dimension(0:n) :: b +integer :: i +b(n)=0; forall(i=1:n)b(i-1)=i*a(i) +end function ndifp_d +!============================================================================= +pure function ndifp_c(n,a)result(b)! [difp] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a +complex(dpc),dimension(0:n) :: b +integer :: i +b(n)=0; forall(i=1:n)b(i-1)=i*a(i) +end function ndifp_c + +!============================================================================= +pure function intp_d(a)result(b)! [intp] +!============================================================================= +! Integrate the polynomial, result being of degree one greater. +!============================================================================= +real(dp),dimension(0:),intent(in):: a +real(dp),dimension(0:size(a)) :: b +integer :: i +b(0)=0; forall(i=1:size(a))b(i)=a(i-1)/i +end function intp_d +!============================================================================= +pure function intp_c(a)result(b)! [intp] +!============================================================================= +complex(dpc),dimension(0:),intent(in):: a +complex(dpc),dimension(0:size(a)) :: b +integer :: i +b(0)=0; forall(i=1:size(a))b(i)=a(i-1)/i +end function intp_c +!============================================================================= +pure function nintp_d(n,a)result(b)! [intp] +!============================================================================= +! Integrate the polynomial of fixed degree, force result to be same degree +!============================================================================= +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a +real(dp),dimension(0:n) :: b +integer :: i +b(0)=0; forall(i=1:n)b(i)=a(i-1)/i +end function nintp_d +!============================================================================= +pure function nintp_c(n,a)result(b)! [intp] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a +complex(dpc),dimension(0:n) :: b +integer :: i +b(0)=0; forall(i=1:n)b(i)=a(i-1)/i +end function nintp_c + +!============================================================================= +pure function ninvp_d(n,a)result(b)! [invp] +!============================================================================= +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a +real(dp),dimension(0:n) :: b +integer :: i +real(dp) :: b0 +b0=1/a(0); b(0)=b0; do i=1,n; b(i)=-b0*sum(b(i-1:0:-1)*a(1:i)); enddo +end function ninvp_d +!============================================================================= +pure function ninvp_c(n,a)result(b)! [invp] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a +complex(dpc),dimension(0:n) :: b +integer :: i +complex(dpc) :: b0 +b0=1/a(0); b(0)=b0; do i=1,n; b(i)=-b0*sum(b(i-1:0:-1)*a(1:i)); enddo +end function ninvp_c + +!============================================================================= +pure function npowp_d(n,a,m)result(b)! [powp] +!============================================================================= +integer, intent(in):: n,m +real(dp),dimension(0:n),intent(in):: a +real(dp),dimension(0:n) :: b +integer :: i +b=0; b(0)=1; do i=1,m; b=nmulpp_d(n,a,b); enddo +end function npowp_d +!============================================================================= +pure function npowp_c(n,a,m)result(b)! [powp] +!============================================================================= +integer, intent(in):: n,m +complex(dpc),dimension(0:n),intent(in):: a +complex(dpc),dimension(0:n) :: b +integer :: i +b=0; b(0)=1; do i=1,m; b=nmulpp_c(n,a,b); enddo +end function npowp_c + +!============================================================================= +pure function polps_d(a,s1)result(s2) ! [polps] +!============================================================================= +real(dp),dimension(0:),intent(in):: a +real(dp), intent(in):: s1 +real(dp) :: s2 +integer :: i,n +n=size(a)-1; s2=a(n); do i=n-1,0,-1; s2=s2*s1+a(i); enddo +end function polps_d +!============================================================================= +pure function polps_c(a,s1)result(s2) ! [polps] +!============================================================================= +complex(dpc),dimension(0:),intent(in):: a +complex(dpc), intent(in):: s1 +complex(dpc) :: s2 +integer :: i,n +n=size(a)-1; s2=a(n); do i=n-1,0,-1; s2=s2*s1+a(i); enddo +end function polps_c +!============================================================================= +pure function npolps_d(n,a,s1)result(s2) ! [polps] +!============================================================================= +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a +real(dp), intent(in):: s1 +real(dp) :: s2 +integer :: i +s2=a(n); do i=n-1,0,-1; s2=s2*s1+a(i); enddo +end function npolps_d +!============================================================================= +pure function npolps_c(n,a,s1)result(s2) ! [polps] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a +complex(dpc), intent(in):: s1 +complex(dpc) :: s2 +integer :: i +s2=a(n); do i=n-1,0,-1; s2=s2*s1+a(i); enddo +end function npolps_c + +!============================================================================= +pure function npolpp_d(n,a,b)result(c)! [polpp] +!============================================================================= +! Up to degree n, get polynomial series c(x)=a(b(x)) +!-------------------------------- +integer, intent(in):: n +real(dp),dimension(0:n),intent(in):: a,b +real(dp),dimension(0:n) :: c +integer :: i +c=a(n); do i=n-1,0,-1; c=nmulpp_d(n,c,b)+a(i); enddo +end function npolpp_d +!============================================================================= +pure function npolpp_c(n,a,b)result(c)! [polpp] +!============================================================================= +integer, intent(in):: n +complex(dpc),dimension(0:n),intent(in):: a,b +complex(dpc),dimension(0:n) :: c +integer :: i +c=a(n); do i=n-1,0,-1; c=nmulpp_c(n,c,b)+a(i); enddo +end function npolpp_c + +!----------------------------------------------------------------------------- +! Banded matrix functions begin here: + +!============================================================================= +pure function copbm_d(m1,m2,mah1,mah2,aband)result(afull)! [copbm] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +real(dp),dimension(m1,-mah1:mah2),intent(IN ) :: aband +real(dp),dimension(m1,m2) :: afull +integer :: i1,i2, i, j +!============================================================================= +afull=0. +do j=1,m1; i1=max(1,1-j); i2=min(m1,m2-j) + do i=i1,i2; afull(i,j+i)= aband(i,j); enddo +enddo +end function copbm_d +!============================================================================= +pure function copbm_c(m1,m2,mah1,mah2,aband)result(afull)! [copbm] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +complex(dpc),dimension(m1,-mah1:mah2),intent(IN ) :: aband +complex(dpc),dimension(m1,m2) :: afull +integer :: i1,i2, i, j +!============================================================================= +afull=0. +do j=1,m1; i1=max(1,1-j); i2=min(m1,m2-j) + do i=i1,i2; afull(i,j+i)= aband(i,j); enddo +enddo +end function copbm_c + +!============================================================================= +pure function copmb_d(m1,m2,mah1,mah2,afull)result(aband)! [copmb] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN ):: m1, m2, mah1, mah2 +real(dp),dimension(m1,m2), intent(IN ):: afull +real(dp),dimension(m1,-mah1:mah2) :: aband +integer :: i1,i2, i, j +!============================================================================= +call clipb(m1,m2,mah1,mah2,aband) +do j=1,m1; i1=max(1,1-j); i2=min(m1,m2-j) + do i=i1,i2; aband(i,j)= afull(i,j+i); enddo +enddo +end function copmb_d +!============================================================================= +pure function copmb_c(m1,m2,mah1,mah2,afull)result(aband)! [copmb] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN ):: m1, m2, mah1, mah2 +complex(dpc),dimension(m1,m2), intent(IN ):: afull +complex(dpc),dimension(m1,-mah1:mah2) :: aband +integer :: i1,i2, i, j +!============================================================================= +call clipb(m1,m2,mah1,mah2,aband) +do j=1,m1; i1=max(1,1-j); i2=min(m1,m2-j) + do i=i1,i2; aband(i,j)= afull(i,j+i); enddo +enddo +end function copmb_c + +!============================================================================= +pure function transposeb_d(m1,m2,mah1,mah2,a)result(b)! [transposeb] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN):: m1, m2, mah1, mah2 +real(dp),dimension(m1,-mah1:mah2),intent(IN):: a +real(dp),dimension(m2,-mah2:mah1) :: b +integer :: j, i +!============================================================================= +call CLIPB(m2,m1,mah2,mah1,b) +do j=-mah1,mah2 + forall(i = max(1,1-j) : min(m1,m2-j))b(j+i,-j)=a(i,j) +enddo +end function transposeb_d +!============================================================================= +pure function transposeb_c(m1,m2,mah1,mah2,a)result(b)! [transposeb] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN):: m1, m2, mah1, mah2 +complex(dpc),dimension(m1,-mah1:mah2),intent(IN):: a +complex(dpc),dimension(m2,-mah2:mah1) :: b +integer :: j, i +!============================================================================= +call CLIPB(m2,m1,mah2,mah1,b) +do j=-mah1,mah2 + forall(i = max(1,1-j) : min(m1,m2-j))b(j+i,-j)=a(i,j) +enddo +end function transposeb_c + +!============================================================================= +pure function mulbb_d(m1,m2,mah1,mah2,mbh1,mbh2, a,b)result(c)! [mulbb] +!============================================================================= +integer, intent(IN):: m1,m2,mah1,mah2,mbh1,mbh2 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2,-mbh1:mbh2),intent(in):: b +real(dp) :: c(m1,-mah1-mbh1:mah2+mbh2) +integer:: j,k,jpk,i1,i2 +c=0 +do j=-mah1,mah2; do k=-mbh1,mbh2; jpk=j+k; i1=max(1,1-j); i2=min(m1,m2-j) + c(i1:i2,jpk)=c(i1:i2,jpk)+a(i1:i2,j)*b(j+i1:j+i2,k) +enddo; enddo +end function mulbb_d + +!============================================================================= +pure function mulbd_d(m1,m2,mah1,mah2,a,d)result(b)! [mulbd] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN):: m1, m2, mah1, mah2 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2) ,intent(in):: d +real(dp),dimension(m1,-mah1:mah2) :: b +integer :: j, i1,i2 +!============================================================================= +call CLIPB(m1,m2,mah1,mah2,b) +do j=-mah1,mah2; i1=max(1,1-j); i2=min(m1,m2-j) + b(i1:i2,j)=a(i1:i2,j)*d(j+i1:j+i2) +enddo +end function mulbd_d + +!============================================================================= +pure function muldb_d(m1,m2,mah1,mah2,d,a)result(b)! [muldb] +!============================================================================= +use pmat2, only: clipb +integer, intent(IN):: m1, m2, mah1, mah2 +real(dp),dimension(m1) ,intent(in):: d +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m1,-mah1:mah2) :: b +integer :: j +call CLIPB(m1,m2,mah1,mah2,b) +do j=-mah1,mah2; b(:,j)=d(:)*a(:,j); enddo +forall(j=-mah1:mah2)b(:,j)=d(:)*a(:,j) +end function muldb_d + +!============================================================================= +pure function mulbv_d(m1,m2,mah1,mah2,a,v1)result(v2)! [mulbv] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2), intent(in):: v1 +real(dp),dimension(m1) :: v2 +integer :: j, i1,i2 +v2=0 +do j=-mah1,mah2; i1=max(1,1-j); i2=min(m1,m2-j) + v2(i1:i2) = v2(i1:i2) + a(i1:i2,j)*v1(j+i1:j+i2) +enddo +end function mulbv_d + +!============================================================================= +pure function mulbx_d(m1,m2,mah1,mah2,my,a,v1)result(v2)! [mulbx] +!============================================================================= +integer, intent(IN) :: m1, m2, mah1, mah2, my +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2,my), intent(in):: v1 +real(dp),dimension(m1,my) :: v2 +integer :: i,j +v2=0 +do j=-mah1,mah2 + do i=max(1,1-j),min(m1,m2-j); v2(i,:)=v2(i,:)+a(i,j)*v1(i+j,:); enddo + forall(i=max(1,1-j):min(m1,m2-j))v2(i,:)=v2(i,:)+a(i,j)*v1(i+j,:) +enddo +end function mulbx_d + +!============================================================================= +pure function mulby_d(m1,m2,mah1,mah2,mx,a,v1)result(v2)! [mulby] +!============================================================================= +integer, intent(IN ) :: m1, m2, mah1, mah2, mx +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(mx,m2), intent(in):: v1 +real(dp),dimension(mx,m1) :: v2 +integer :: i,j +v2=0 +do j=-mah1,mah2 + forall(i=max(1,1-j):min(m1,m2-j))v2(:,i)=v2(:,i)+a(i,j)*v1(:,i+j) +enddo +end function mulby_d + +!============================================================================= +pure function mulvb_d(m1,m2,mah1,mah2,v1,a)result(v2)! [mulvb] +!============================================================================= +integer, intent(IN) :: m1, m2, mah1, mah2 +real(dp),dimension(m1), intent(in):: v1 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2) :: v2 +integer :: j, i1,i2 +v2=0 +do j=-mah1,mah2; i1=max(1,1-j); i2=min(m1,m2-j) + v2(j+i1:j+i2)=v2(j+i1:j+i2)+v1(i1:i2)*a(i1:i2,j) +enddo +end function mulvb_d + +!============================================================================= +pure function mulxb_d(m1,m2,mah1,mah2,my,v1,a)result(v2)! [mulxb] +!============================================================================= +integer, intent(IN) :: m1, m2, mah1, mah2, my +real(dp),dimension(m1,my), intent(in):: v1 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(m2,my) :: v2 +integer :: i,j +v2=0 +do j=-mah1,mah2 + forall(i=max(1,1-j):min(m1,m2-j))v2(j+i,:)=v2(j+i,:)+v1(i,:)*a(i,j) +enddo +end function mulxb_d + +!============================================================================= +pure function mulyb_d(m1,m2,mah1,mah2,mx,v1,a)result(v2)! [mulyb] +!============================================================================= +integer, intent(IN):: m1, m2, mah1, mah2, mx +real(dp),dimension(mx,m1), intent(in):: v1 +real(dp),dimension(m1,-mah1:mah2),intent(in):: a +real(dp),dimension(mx,m2) :: v2 +integer :: i,j +v2=0 +do j=-mah1,mah2 + forall(i=max(1,1-j):min(m1,m2-j))v2(:,j+i)=v2(:,j+i)+v1(:,i)*a(i,j) +enddo +end function mulyb_d + +!============================================================================= +function L1Lb_d(m,mah,a)result(b)! [L1Lb] +!============================================================================= +integer, intent(IN ):: m, mah +real(dp),dimension(m,-mah:mah), intent(IN ):: a +real(dp),dimension(m,-mah:0) :: b +logical :: ff +b=fL1Lb_d(m,mah,a,ff) +if(ff)stop 'In L1Lb_d; matrix non-positive, cannot continue' +end function L1Lb_d +!============================================================================= +function fL1Lb_d(m,mah,a,ff)result(b)! [L1Lb] +!============================================================================= +use pietc, only: T,F +use pmat2, only: clipb +integer, intent(IN ):: m, mah +real(dp),dimension(m,-mah:mah), intent(IN ):: a +logical, intent(out):: ff ! <- failure flag +real(dp),dimension(m,-mah:0) :: b +integer :: i, j,jmi +real(dp) :: s +!============================================================================= +ff=F +call CLIPB(m,m,mah,0,b) +do j=1,m + s=a(j,0)-dot_product(b(j,-mah:-1),b(j,-mah:-1)) + if(s <= 0)then + ff=T + write(41,'("In fL1LB_d; non-positivity at diagonal index",i5)'),j + return + endif + s=sqrt(s); b(j,0)=s; s=1/s + do i=j+1,min(m,j+mah); jmi=j-i + b(i,jmi)=s*(a(i,jmi)-dot_product(b(i,-mah:jmi-1),b(j,-mah-jmi:-1))) + enddo +enddo +end function fL1Lb_d + +!============================================================================= +function u1ub_d(m,mah,a)result(b)! [u1ub] +!============================================================================= +integer, intent(IN ):: m, mah +real(dp),dimension(m,-mah:mah), intent(IN ):: a +real(dp),dimension(m,-mah:0) :: b +real(dp),dimension(m,-mah:mah) :: at +real(dp),dimension(m,-mah:0 ) :: bt +!============================================================================= +at=a(m:1:-1,mah:-mah:-1); bt=l1lb_d(m,mah,at); b=bt(m:1:-1,0:-mah:-1) +end function u1ub_d +!============================================================================= +function fu1ub_d(m,mah,a,ff)result(b)! [u1ub] +!============================================================================= +integer, intent(IN ):: m, mah +real(dp),dimension(m,-mah:mah), intent(IN ):: a +logical, intent(out):: ff ! <- failure flag +real(dp),dimension(m,-mah:0) :: b +real(dp),dimension(m,-mah:mah) :: at +real(dp),dimension(m,-mah:0 ) :: bt +!============================================================================= +at=a(m:1:-1,mah:-mah:-1); bt=fl1lb_d(m,mah,at,ff) +if(ff)then; write(41,'("In fulub_d; non-positive matrix")'); return; endif +b=bt(m:1:-1,0:-mah:-1) +end function fu1ub_d + +!============================================================================= +function LdLb_d(m,mah,a)result(b)! [LdLb] +!============================================================================= +integer, intent(IN):: m, mah +real(dp),dimension(m,-mah:mah),intent(IN):: a +real(dp),dimension(m,-mah:0) :: b +logical :: ff +b=fLdLb_d(m,mah,a,ff) +if(ff)stop 'In LdLb_d; matrix non-positive, unable to continue' +end function LdLb_d +!============================================================================= +function fLdLb_d(m,mah,a,ff)result(b)! [LdLb] +!============================================================================= +use pietc, only: T,F +use pmat2, only: clipb +integer, intent(IN ):: m, mah +real(dp),dimension(m,-mah:mah),intent(IN ):: a +logical, intent(out):: ff ! <- failure flag +real(dp),dimension(m,-mah:0) :: b +integer :: i, j,k,jmi,lj,li +real(dp) :: s,te +!============================================================================= +ff=F +call clipb(m,m,mah,0,b); b(:,0)=1 +do j=1,m; lj=max(-mah,1-j) + s=a(j,0) + do k=lj,-1 + s=s-b(j,k)**2*b(k+j,0) + enddo + if(s <= 0)then + ff=T + write(41,'(" In fLDLB_d; non-positivity at diagonal index",i5)'),j + return + endif + b(j,0)=s; s=1/s + do i=j+1,min(m,j+mah); jmi=j-i + li=max(-mah,1-i); + lj=li-jmi; + te=a(i,jmi) + do k=li,jmi-1 + te=te-b(i,k)*b(j,k-jmi)*b(i+k,0) + enddo + b(i,jmi)=s*te + enddo +enddo +b(:,0)=1/b(:,0) +end function fLdLb_d + +!============================================================================= +function udub_d(m,mah,a)result(b)! [udub] +!============================================================================= +integer, intent(in):: m, mah +real(dp),dimension(m,-mah:mah),intent(in):: a +real(dp),dimension(m,0:mah) :: b +real(dp),dimension(m,-mah:mah) :: at +real(dp),dimension(m,-mah:0) :: bt +at=a(m:1:-1,mah:-mah:-1);bt=LdLb_d(m,mah,at); b=bt(m:1:-1, 0:-mah:-1) +end function udub_d +!============================================================================= +function fudub_d(m,mah,a,ff)result(b)! [udub] +!============================================================================= +integer, intent(in ):: m, mah +real(dp),dimension(m,-mah:mah),intent(in ):: a +logical, intent(out):: ff ! <- failure flag +real(dp),dimension(m,0:mah) :: b +real(dp),dimension(m,-mah:mah) :: at +real(dp),dimension(m,-mah:0) :: bt +at=a(m:1:-1,mah:-mah:-1);bt=fLdLb_d(m,mah,at,ff) +if(ff)then; write(41,'("In fudub_d; matrix non-positive")'); return; endif +b=bt(m:1:-1, 0:-mah:-1) +end function fudub_d + + +end module pmat3 diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepacqc.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepacqc.f index 53bd62b1..e9f9e9d9 100755 --- a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepacqc.f +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepacqc.f @@ -1,7862 +1,1691 @@ -C$$$ MAIN PROGRAM DOCUMENTATION BLOCK -C -C MAIN PROGRAM: PREPOBS_PREPACQC -C PRGMMR: KEYSER ORG: NP22 DATE: 2008-07-30 -C -C ABSTRACT: READS IN PREPBUFR FILE CONTAINING ALL PREPROCESSED DATA -C TYPES. {ONLY BUFR TABLE A ENTRY MESSAGES "AIRCFT " ARE OPERATED -C ON.} SORTS BY STATION ID, DOES TRACK CHECKING, AND AGGRAGATES OBS -C BY POSITION (CALLED A 'STACK'). DOES QUALITY CONTROL BY MAKING -C TRACK CHECKS ON FLIGHTS, REMOVING DUPLICATES, COMPARING COLOCATED -C OBSERVATIONS, AND, IF REQUESTED, FORMING SUPEROBS OF THOSE WINDS -C PASSING THE QUALITY CHECKS. A SERIES OF NEW PREPBUFR QUALITY MARKS -C ARE ATTACHED TO EACH OBSERVATION (SEE REMARKS). FINALLY: WRITES -C STACKED EVENTS (CONSISTING OF THE UPDATED PREPBUFR QUALITY MARKS) -C ONTO THE EXISTING PREPBUFR DATA FOR THOSE OBS WHICH ARE NOT -C ORIGINALLY "BAD". IN ALL CASES, THE NEW FILE CONTAINS ALL OF THE -C ORIGINAL OBSERVATIONAL DATA (P-ALT, TEMP, WIND) MINUS THE -C DUPLICATES AND THOSE OUTSIDE THE DESIRED TIME WINDOW. IF -C APPLICABLE, ADDITIONAL SUPEROBS WILL BE ADDED. OBSERVATIONS THAT -C ARE USED TO GENERATE A SUPEROB ARE FLAGGED IN THE WIND AND -C TEMPERATURE QUALITY MARKERS TO ENSURE THAT THEY ARE OMITTED FROM -C THE ANALYSIS SCHEME. AIREP/PIREP AND SUPEROB REPORTS OVER -C CONTINENTAL U.S. AND SURROUNDING ENVIRONS MAY ALSO BE FLAGGED AND -C EXCLUDED FROM ANALYSIS SCHEME IF REQUESTED. -C -C PROGRAM HISTORY LOG: -C 1989-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1990-03-29 P. JULIAN -- MODIFIED TO HONOR SDM/QCAIRCFT PURGE FOR -C STACKED OBSERVATIONS (OBS. INCRMENT CHECK) -C 1990-04-16 P. JULIAN -- MODIFIED TO PACK SUPEROBS ONE AT A -C TIME ON SINGLE LEVELS ONLY -C 1990-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 1990-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 1990-09-18 D. A. KEYSER -- MINOR ERROR IN LOGIC CORRECTED, SOME ORIG. -C REPORTS WERE BEING GIVEN 'O' Q. MARK BY MISTAKE -C 1990-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 1991-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 1991-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 1992-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 1993-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 1993-06-05 P. JULIAN-- THIS VERSION REVISED TO PRODUCE CODE FOR -C EITHER HDS OR CRAY. SORT ROUTINES ARE LOCAL. -C 1994-01-01 P. JULIAN-- THIS VERSION REVISED TO PRODUCE CODE FOR -C OPERATIONAL USE. QUAL MARKS REVISED ONCE AGAIN -C 1994-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 PREPBUFR FILE AND ADD STACKED -C EVENTS CONSISTING OF UPDATED WIND AND TEMPERATURE -C QUALITY MARKERS; SEVERAL ERRORS DETECTED AND CORRECTED -C 1995-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 1995-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 1995-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 1995-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 1995-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 PREPBUFR 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 PREPBUFR -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 ASDAR/AMDAR REPORTS NOW GET TEMPERATURE AND WIND Q. -C MARKS SET TO "SUSPECT" (AND ARE ASSIGNED THE NEW REASON -C CODE "330" FOR OUTPUT TO PREPBUFR FILE) IF THE -C PHASE OF FLIGHT INDICATOR IS MISSING (INDICATES A -C PROBABLE "BANKING" AIRCRAFT WITH SUSPECT DATA QUALITY) -C 1995-11-08 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETER "LSIZE" -C FROM 26 TO 50 -C 1996-01-26 D. A. KEYSER -- CORRECTED DIVIDE-BY-ZERO POSSIBILITY IN -C THE CALCULATION OF MULTIPLE CORRELATIONS IN SUBROUTINE -C 'SUPROB' -C 1996-10-18 D. A. KEYSER -- NOW CLOSES INPUT BUFR DATA SET AFTER ALL -C REPORTS HAVE BEEN READ IN BY SUBR. IBUFR, UPDATED BUFRLIB -C CAUSES PGM TO ABORT WITH CALL TO OPENBF IN SUBR. OBUFR -C W/O THIS FIX -C 1996-12-10 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX" -C FROM 5000 TO 10000, "ISMX" FROM 500 TO 1000, "ISUP" FROM -C 250 TO 500, AND "ITMX" FROM 500 TO 1000 - ALL TO -C ACCOUNT FOR INCREASED NUMBER OF REPORTS PROCESSED BY NEW -C UNIX DECODERS -C 1997-06-03 D. A. KEYSER -- FOR INPUT PREPBUFR FORMAT, ASDAR/AMDAR -C REPORTS ARE NOW IDENTIFIED BY "TYP" OF 131/231 RATHER -C THAN BY A 'Z' IN 6'TH POSITION OF STNID SINCE STNID IN -C PREPBUFR NOW CONTAINS ACTUAL ASDAR/AMDAR STNID (UP TO -C 8-CHARACTERS, NO LONGER 'Z' IN 6'TH POS. OF STNID) -C 1998-02-17 D. A. KEYSER -- REMOVED LOGIC PERTAINING TO INPUT AND -C OUTPUT IN OFFICE NOTE 29 FORMAT (OBSOLETE); IMPROVED -C PRINT IN SDMACQC FILE IN UNIT 52 -C 1998-10-07 D.A. KEYSER -- PROGRAM NOW Y2K AND FORTRAN 90 COMPLIANT -C 1999-08-23 D.A. KEYSER -- MODIFIED TO RUN ON IBM SP MACHINE; ADDED -C HIGHER ORDERS IN CHARACTER SORTS TO HOPEFULLY ALWAYS -C GIVE SAME SORT ORDER REGARDLESS OF INPUT REPORT ORDER; -C CHANGED ALL TAGS AND QMARKS THAT WERE BLANK (' ') TO '-' -C TO IMPROVE STDOUT PRINT APPEARANCE -C 1999-09-23 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX" -C FROM 10000 TO 20000, "ISMX" FROM 1000 TO 2000, "ISUP" -C FROM 500 TO 1000, AND "ITMX" FROM 1000 TO 2000 - ALL TO -C ACCOUNT FOR INCREASED NUMBER OF AMDAR/ASDAR REPORTS -C NOW BEING DECODED -C 1999-09-26 D. A. KEYSER -- CHANGES TO MAKE CODE MORE PORTABLE -C 2002-11-20 D. A. KEYSER -- REMOVED ASSUMPTION THAT AN SDM PURGE ON -C TEMP ONLY ALSO RESULTS IN AN SDM PURGE ON WIND, BUT STILL -C ASSUMES THAT AN SDM PURGE ON WIND ONLY ALSO MEANS AN SDM -C PURGE ON TEMP (VIA ACTIONS TAKEN BY PREVIOUS -C PREPOBS_PREPDATA PROGRAM), ONLY REPORTS WITH SDM PURGE ON -C WIND ARE REMOVED FROM ANY SUBSEQUENT Q.C.; THERE IS ALSO -C NO LONGER ANY RELATIONSHIP BETWEEN AN SDM KEEP ON WIND -C VS. A KEEP ON TEMP - THEY ARE INDENDENDENT OF EACH OTHER -C AND FULL Q.C. IS STILL PERFORMED ON REPORTS WITH A KEEP -C FLAG ON EITHER, ALTHOUGH THE ORIGINAL KEEP FLAGS ARE -C STILL HONORED -C 2004-11-16 D. A. KEYSER -- MAXIMUM TEMPERATURE OVER WHICH TEMP IS -C FLAGGED FOR NON-USE BY ASSIMILATION IS CHANGED FROM 12 -C TO 32 DEG. C (EVENT REASON CODE 303), THIS WILL ALLOW -C REASONABLE LOW-LEVEL TEMPS TO BE ASSIMILATED; NOW CALLS -C BUFRLIB ROUTINE "UFBQCD" TO GET PROGRAM CODE FOR THIS -C Q.C. STEP ("PREPACQC") RATHER THAN HARDWIRING IT TO 7 -C AS BEFORE -C 2005-01-25 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX" -C FROM 20000 TO 40000, "ISMX" FROM 2000 TO 4000, "ISUP" -C FROM 1000 TO 2000, AND "ITMX" FROM 2000 TO 4000 - ALL TO -C ACCOUNT FOR INCREASED NUMBER OF AMDAR/ASDAR REPORTS -C NOW BEING DECODED AND TO ACCOUNT FOR THE NEW INCLUSION -C OF E-ADAS REPORTS -C 2007-08-16 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETERS "IRMX" -C FROM 40000 TO 80000, "ISMX" FROM 4000 TO 8000, "ISUP" -C FROM 2000 TO 4000, AND "ITMX" FROM 4000 TO 8000 - ALL TO -C ACCOUNT FOR INCREASED NUMBER OF REPORTS NOW BEING DECODED -C DUE TO THE NEW INCLUSION OF TAMDAR AND CANADIAN AMDAR -C REPORTS -C 2007-10-17 D. A. KEYSER -- CHECKS TO SEE IF PARAMETER "ITRKL" IS -C EXCEEDED IN A NUMBER OF TRACK CHECK TESTS, IF SO STOPS -C ABNORMALLY WITH CONDITION CODES 26-30 (DEPENDING ON WHAT -C CAUSES "ITRKL" TO BE EXCEEDED), BEFORE COULD RUN TO -C COMPLETION BUT CLOBBER MEMORY OR MAYBE SEG FAULT; -C INCREASED THE SIZE OF PARAMETER "ITRKL" FROM 20 TO 500 - -C TO PREVENT ARRAYS OVERFLOWS IN NEARLY EVERY PRODUCTION -C RUN; INCREASED SIZE OF ARRAY "IPTTRK" FROM 5 TO PARAMETER -C "ITRKL" (NOW 500) (THIS HOLDS POINTER TO REPORTS IN A -C TRACK WITH LARGE POSITION ERRORS), BEFORE THE VALUE OF 5 -C WAS OFTEN EXCEEDED AND MEMORY WAS UNKNOWINGLY BEING -C CLOBBERED; ANY REPORTS WITH ID "UNKNOWN" ARE NOT -C CONSIDERED FOR TRACK CHECKING (THIS WAS PLACED ON SOME -C REPORTS IN REANALYSIS WHEN NO ID WAS PRESENT - SINCE -C THESE ARE NOT NORMALLY PART OF THE SAME FLIGHT THEY -C CANNOT BE TRACK CHECKED); CHANGES TO TREAT TAMDAR AND -C CANADIAN AMDAR REPORTS THE SAME AS ASDAR/AMDAR REPORTS -C 2008-07-30 D. A. KEYSER -- RECEIPT TIME TEST IS NO LONGER DONE FOR -C TAMDAR REPORTS (REGARDLESS OF SWITCH "RCPTST" BECAUSE -C TAMDAR REPORTS CAN BE RESENT MANY TIMES OVER AND THE -C RECEIPT TIME FOR VERY LATE (E.G., T-12 NDAS) RUNS MAY -C INCORRECTLY DISPLAY WHAT LOOKS LIKE A "STRANGE" RECEIPT -C TIME); IN RESPONSE TO CHANGE FROM SINGLE LEVEL TO -C DELAYED REPLICATION FOR "AIRCFT" REPORT LEVEL DATA NOW IN -C PREPBUFR FILE (IN PREPARATION FOR NRL AIRCRAFT QC PROGRAM -C WHICH WILL REPLACE THIS PROGRAM AND CAN GENERATE AIRCRAFT -C "PROFILES"), RECEIPT TIME (RCT) (WHICH IS NOW PART OF -C LEVEL DATA) IS NO LONGER RETRIEVED IN SAME CALL TO UFBINT -C AS REMAINING SINGLE-LEVEL HEADER DATA (TO AVOID BUFRLIB -C ERROR) (ALL LEVEL DATA HERE STILL HAS JUST ONE -C REPLICATION AT THIS POINT); PRIOR TO WRITING OUT EVENT, -C TESTS ORIG. T & W QM'S - IF > 3, WILL NOT WRITE OUT EVENT -C (HONORS ORIGINAL T & W QM'S IF BAD), THIS NEEDED BECAUSE -C TAMDAR AND CANADIAN AMDAR CURRENTLY HAVE T & W QM=9 -C COMING IN (MISSING OBS ERROR) WHICH CODE WAS IGNORING -C (AND WRITING OUT EVENT WITH GOOD QM MOST OF THE TIME - -C THIS CAUSED OIQC TO USE THESE OBS IN ITS DECISION MAKING -C PROCESS - THESE OBS ARE CURRENTLY ONLY MONITORED BY GSI -C AND SHOULD NOT BE CONSIDERED BY OIQC) -C -C -C USAGE: -C INPUT FILES: -C UNIT 05 - NAMELIST INPUT -C UNIT 14 - PREPBUFR 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. CONUS 1 DEG -C LAT/LON YES/NO INDICATOR -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 UNIT 52 - TEXT FILE FOR SDM PERUSAL (LIST OF ISOLATED REPORTS -C - THAT ARE FLAGGED FOR NON-USE BY THIS PROGRAM AS WELL -C - AS THOSE WITH LARGE INCREMENTS) -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 ON WIND AND/OR TEMP) -C UNIT 61 - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACFT QC) -C -C SUBPROGRAMS CALLED: -C UNIQUE: - SUPROB SHEAR AVEROB RPACKR STATS -C - INDEXF LAPSE INDEXC TRKCHK WAYPT -C - ACOUNT PRELIM IDSORT FORSDM NOEQ2 -C - CHOOSE AVEDIR DBUFR IBUFR OBUFR -C SUBFR CMDDFF +c$$$ Main Program Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Main Program: PREPOBS_PREPACQC +c Programmer: D. Keyser Org: NP22 Date: 2016-12-09 +c +c Abstract: Performs the NRL aircraft data quality control on all types of reports (AIREP, +c PIREP, AMDAR, TAMDAR, MDCRS). Replaces the previous routine of the same name originally +c written by Paul Julian (which was less comprehensive and did not handle MDCRS reports). +c It reads in a PREPBUFR file containing all reports, pulls out "AIRCAR" and "AIRCFT" +c reports, merges the mass and wind pieces, translates information into NRL "standards" and +c stores in internal memory. These are then passed into the NRL quality control kernel +c (acftqc_obs). Once the NRL quality control is completed, translates information back to +c NCEP/PREPBUFR "standards" and encodes the updated information into the full PREPBUFR file +c as "events" with new NRLACQC reason codes. The events consist of quality mark changes, +c although NRLACQC can also remove duplicate reports and rehabilitate (update) the report +c time, latitude and longitude for some AIREP reports. An option is to also generate a +c PREPBUFR-like profiles file containing only aircraft reports in "raob-lookalike" +c profiles (merged mass and wind data). These can be used for air quality and verification +c codes. +c +c Program History Log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c 2012-11-20 J. Woollen -- Initial port to WCOSS +c 2012-12-11 S. Hsiao -- Increased maximum number of merged reports that can be processed +c "max_reps" from 150K to 155K to handle increase in MDCRS reports +c 2013-02-07 D. Keyser -- Interface with input PREPBUFR file will now store pressure and +c pressure-altitude only from the first (mass) piece of a mass/wind +c piece pair rather than re-store it again from the second (wind) +c piece - even though they "should" be the same in both pieces (see +c % below for exception), there can be rare cases when at least +c pressure-altitude is missing in the wind piece (due to a bug in +c PREPDATA where unreasonably-high winds are set to missing and an +c "empty" wind piece is still encoded into PREPBUFR, this can lead +c to floating point exception errors in construction of profiles +c {note that pressure & pressure-altitude from reports with only a +c wind piece will be read since it is the first (only) piece of the +c report}: % - there can be cases where the pressure qualty mark +c (PQM) is different in the mass piece vs. the wind piece (e.g., +c when it is set to 10 for reports near tropical systems by +c SYNDATA), so it is better to pick up PQM from the mass report for +c use in the merged mass/wind profiles, an added benefit of this +c change; increased maximum number of merged reports that can be +c processed "max_reps" from 155K to 185K to handle future increase +c all types of aircraft rpts; if the total number of merged (mass +c + wind piece) aircraft-type reports read in from PREPBUFR file is +c at least 90% of the maximum allowed, print diagnostic warning +c message to production joblog file prior to returning from +c subroutine INPUT_ACQC; if the maximum number of merged reports +c that can be processed ("max_reps") is exceeded when updating +c reports in PREPBUFR file with QC changes in subroutine +c OUTPUT_ACQC_NOPROF, program will no longer stop with r.c. 31, as +c though there is an indexing error, instead all original reports +c above "max_reps" will be written out without any QC and a message +c will be printed to stdout (a diagnostic will have already been +c sent to the production joblog file in this case when reports were +c first read in by subroutine INPUT_ACQC) +c 2013-02-07 D. Keyser -- Final changes to run on WCOSS: Set BUFRLIB missing (BMISS) to +c 10E8 rather than 10E10 to avoid integer overflow; use formatted +c print statements where previously unformatted print was > 80 +c characters +c 2014-03-06 D. Keyser -- Moved BUFRLIB routine OPENMB call in subroutine +c output_acqc_noprof to after time window and geographic domain +c checks to prevent creation of an empty, but open, BUFR message +c (type AIRCAR) in (rare) cases where absolutely no aircraft +c reports pass these checks (would cause a BUFRLIB abort due to +c previous message being open when attempting to copy first non- +c aircraft message from input to output PREPBUFR file +c 2014-07-18 D. Keyser -- +c - Increased maximum number of flights that can be processed "maxflt" from +c 5000 to 7500 to account for increase in aircraft reports. +c - Increased maximum number of merged reports that can be processed +c "max_reps" from 185K to 220K to handle future increase in all types of +c aircraft reports. +c - If subroutine acftobs_qc returns abnormally to main program due to the +c maximum value for number of flights calculated at some point during its +c processing exceeding the allowed limit ("maxflt"), no longer stop with +c r.c. 98. Instead continue on with processing and post a diagnostic +c warning message to the production joblog file. The assumption is that +c the resultant PREPBUFR file may not contain fully QC'd aircraft data, +c especially if the actual number of flights calculated greatly exceeds +c "maxflt" (since obs in flights above the "maxflt" limit may partially be +c skipped over in the QC process), but the vast majority should be QC'd, +c and all reports originally in the PREPBUFR file will be at least be +c retained. (Note that a gradual increase will trigger a warning in the +c production joblog now when numbers get too close to the limit - see +c change to subroutine acftobs_qc below). +c - Increased format width from I5 to I6 in all places where aircraft obs +c index is listed out (since there now can be > 99999 reports). +c - Subroutine acftobs_qc and its child subroutines: +c - Keep track of maximum value for number of flights calculated at some +c point during the processing of subroutine acftobs_qc. If, at the end +c of acftobs_qc, this value is at least 90% of the allowed limit +c ("maxflt", set in the main program), post a diagnostic warning message +c to the production joblog file prior to exiting from acftobs_qc. +c - In subr. do_flt and do_reg, return (abnormally) immediately if +c "maxflt" is exceeded rather than waiting to test for this at end of +c do_flt and do_reg and then return (abnormally). Prior to return +c subtract 1 from number of flights so it will remain at "maxflt". The +c immediate return avoids clobbering of memory in these cases. +c - In subr. reorder, where any new flight exceeding "maxflt" replaces the +c previous flight at index "maxflt" in the arrays to avoid an array +c overflow (done in two places in original NRL version), post diagnostic +c warning message to the production joblog file (found a third instance +c where this needs to be done in subr. reorder - original NRL version +c did not trap it and arrays limited to length "maxflt" would have +c overflowed). +c - If "maxflt" is exceeded in subr. dupchk (1 place possible) or in subr. +c do_flt (2 places possible), the abnormal return back to subr. +c acftobs_qc results in subr. acftobs_qc now continuing on but setting a +c flag for "maxflt_exceeded". Prior to this, subr. acftobs_qc itself +c immediately performed an abnormal return back to main program in such +c cases resulting in no more NRL QC processing. Now NRL QC processing +c will continue on to the end of subr. acftobs_qc where the abnormal +c return back to the main program will be triggered by the +c "maxflt_exceeded" flag. +c - There is one, apparently rare, condition where "maxflt" could be +c exceeded in subr. acft_obs itself (within logic which generates master +c list of tail numbers and counts). Since it can't be determined if +c continuing on without processing (QC'ing) any more data would yield +c acceptable results, the program now immediately stops with condition +c code 98 and a diagnostic warning message is posted to the production +c joblog file noting that "maxflt" needs to be increased. Prior to this +c it returned to the main program where it also immediately stopped with +c condition code 98 (so no real change in what happens here, just where +c it happens). +c 2014-09-03 D. Keyser -- If no aircraft reports of any type are read from input PREPBUFR +c file by subr. input_acqc, no further processing is performed in this +c subr. other than the usual stdout print summary at its end. After its +c return back to the calling main program, the main program also, in +c this case, does no further processing. Instead the main program stops +c with condition code 4 (to alert executing script prepobs_prepacqc.sh) +c after printing a diagnostic message to stdout. +c 2014-12-09 J. Purser/Y. Zhu -- Added new namelist switches "l_mandlvl" and "tsplines", +c used by subroutine sub2mem_mer to modify the calculation of vertical +c velocity rate in the profiles {l_mandlvl=F excludes interpolation to +c mandatory levels; tsplines=T calculates vertical velocity rate using +c Jim Purser's tension-spline interpolation utility (source in-lined in +c this program at this time) to get continuous gradient results in a +c profile and mitigate missing time information; tsplines=F uses finite- +c difference method to obtain vertical velocity rate, calculated for +c both ascents and descents using the nearest neighboring pair which are +c at least one minute apart (before, only finite-difference method was +c used to obtain vertical velocity rate and it could only be calculated +c for descents). +c 2014-12-12 D. Keyser -- Printout from vertical velocity rate calculation information for +c QC'd merged aircraft reports written to profiles PREPBUFR-like file is +c written to unit 41 rather than stdout. +c 2015-03-16 D. Keyser -- +c - Increased maximum number of merged reports that can be processed +c "max_reps" from 220K to 300K to handle future increase in all types of +c aircraft reports. +c - In subr. output_acqc_prof, fixed a bug which, for cases where the maximum +c number of merged reports that can be processed ("max_reps") is exceeded, +c prevented any original reports above "max_reps" from being written out +c (without any QC). +c 2015-04-17 J. Purser -- Updates to tension-spline interpolation utility pspl: +c In April 2015 some significant changes were made to pspl.f90 to improve +c the robustness of the algorithm and the usefulness of the energy +c diagnostic: +c 1) The allowance of B iterations was increased from 40 to 80 owing to +c a single failure in a parallel run (where 43 iterations were +c required) (and the halfgate parameter was increased to 30 for all +c data in the parallels, which also increases robustness). +c 2) There was included an explicit energy check at each A iteration to +c force an exit when this energy fails to decrease. This change was +c prompted by a single failure in a parallel run (courtesy Russ +c Treadon) in which the A and B iterations flip-flopped at zero +c energy change in a case of grazing contact with a gatepost. +c 3) The energy is now normalized by the energy that would be computed +c from a spline that fits only the first and last gateposts. The +c renormalized energy diagnostic tells how sinuous the final profile +c is -- very large values are indiciative of a halfgate chosen to be +c too narrow for the given profile data. +c 4) The normalized time data are now handled as integer arrays instead +c of reals in those parts of the code dealing with the combinatorics +c of routes. This is just better coding practice. +c 2015-04-17 Y. Zhu -- Updates to subroutine sub2mem_mer: +c 1) Subroutine is more robust. If there is an error in the generation +c of vertical velocity rate in the tension-spline interpolation +c utility pspl (called in this subroutine), this subroutine (and thus +c the program itself) will no longer abort (with either c. code 62, +c 63 or 64 depending upon which routine inside pspl generated the +c error) but will instead revert to the finite difference method for +c calculating vertical velocity rate. +c 2) Previously, halfgate was set to be 30 for the data profiles that +c don't have second information in time, but a tighter value of 10 +c for the data profiles that do have second information in time. Now +c halfgate is relaxed to be 30 for the data profiles that do have +c complete time information. +c 2016-10-11 M.Sienkiewicz Added a namelist variable and additional code to allow use of an +c alternate BUFR table definition file when generating the profile file. +c (Solves a problem with mixed BUFR files used for input.) +c 2016-11-09 C. Hill ----- +c - Increased the maximum number of flights that can be processed, "MAXFLT", +c from 7500 to 12500 to resolve >90% warning. +c 2016-12-09 D. Keyser -- +c - Nomenclature change: replaced "MDCRS/ACARS" with just "MDCRS". +c - New LATAM AMDARs contain an encrypted flight number (in addition to a tail +c number, all other AMDARs have only a tail number which is copied into +c flight number). Read this in and use in QC processing. +c BENEFIT: Improves track-checking and other QC for LATAM AMDARs. +c - Since "ACARS" as referred to in NRL QC kernal (acftobs_qc.f) is not used +c there and we earlier decided to use this to provide a separate category +c for TAMDARs in the NRL QC kernal (for stratifying statistics), all +c printout in acftobs_qc.f changes the term "ACARS" to "TAMDAR". In +c addition, all comments now refer to "TAMDAR" instead of "ACARS". +c - Variables holding latitude and longitude data (including arrays "alat" and +c "alon" passed between subroutines) now double precision. XOB and YOB in +c PREPBUFR file now scaled to 10**5 (was 10**2) to handle new v7 AMDAR and +c MDCRS reports which have this higher precision. +c BENEFIT: Retains exact precison here. Improves QC processing. +c - Note: QC here can be improved further by changing logic in many +c places to account for the increased precision. This needs to be +c investigated. For now, locations in code where this seems +c possible are noted by the spanning comments: +c ! vvvv DAK-future change perhaps to account for incr. lat/lon precision +c ! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision +c - The format for all print statements containing latitude and longitude +c changed to print to 5 decimal places. +c +c Usage: +c Input files: +c Unit 05 - Standard input (namelist) +c Unit 11 - PREPBUFR file containing all obs, prior to any processing by this program +c Unit 12 - file with external table for profile output (if needed) +c +c Output files: +c Unit 06 - Standard output print +c Unit 08 - Text file containing full log of all NRL QC information +c Unit 30 - Text file containing duplicate data check information +c Unit 31 - Text file containing spike data check information +c Unit 32 - Text file containing invalid data check information +c Unit 33 - Text file containing stuck data check information +c Unit 34 - Text file containing gross check information +c Unit 35 - Text file containing position check information +c Unit 36 - Text file containing ordering check information +c Unit 37 - Text file containing suspect data check information +c Unit 38 - Text file containing reject list information +c Unit 41 - Text file containing vertical velocity rate calculation information for QC'd +c merged aircraft reports written to profiles PREPBUFR-like file +c Unit 51 - Text file containing sorted listing of all single-level QC'd aircraft +c reports written back to full PREPBUFR file +c Unit 52 - Text file containing sorted listing of all QC'd merged aircraft reports +c written to profiles PREPBUFR-like file +c Unit 61 - PREPBUFR file identical to input except containing NRLACQC events +c Unit 62 - PREPBUFR-like file containing merged (mass and wind) profile reports +c (always) and single(flight)-level reports not part of any profile (when +c l_prof1lvl=T) with NRLACQC events +c +c Subprograms called: +c Unique: - ACFTOBS_QC PR_WORKDATA INDEXC DUPCHEK_QC +c - REORDER DO_FLT DO_REG INNOV_QC +c - BENFORD_QC INVALID_QC STK_VAL_QC GRCHEK_QC +c - POSCHEK_QC ORDDUP_QC ORDCHEK_QC SUSPECT_QC +c - REJLIST_QC P2HT_QC HT2FL_QC P_DDTG +c - SPIKE_QC SLEN INSTY_OB_FUN C_INSTY_OB +c - GCIRC_QC INDEXC40 INPUT_ACQC OUTPUT_ACQC_NOPROF +c - OUTPUT_ACQC_PROF SUB2MEM_MER SUB2MEM_UM TRANQCFLAGS C LIBRARY: -C W3LIB : - W3FI04 ERREXIT -C BUFRLIB: - DATELEN OPENBF READMG READSB UFBINT -C - CLOSBF OPENMB UFBCPY WRITSB UFBCNT -C - COPYMG UFBQCD CLOSMG -C -C EXIT STATES: -C COND = 0 - SUCCESSFUL RUN -C COND = 04 - NO REPORTS WERE PROCESSED (NO "AIRCFT" TABLE A -C MESSAGES FOUND) -C COND = 20 - THE NUMBER OF AIRCRAFT REPORTS IN THE INPUT FILE -C - EXCEEDS THE MAXIMUM LIMIT SET BY THIS PROGRAM, -C - MUST INCREASE THE SIZE OF PARAMETER NAME "IRMX" -C COND = 21 - THE NUMBER OF AIRCRAFT REPORTS IN A STACK OF CO- -C - LOCATED OBSERVATIONS EXCEEDS THE MAXIMUM LIMIT -C - SET BY THIS PROGRAM, MUST INCREASE THE SIZE OF -C - PARAMETER NAME "ISMX" -C COND = 22 - CHARACTERS ON THIS MACHINE ARE NEITHER ASCII NOR -C - EBCDIC -C COND = 23 - THE NUMBER OF SUPEROBED AIRCRAFT REPORTS GENERATED -C - EXCEEDS THE MAXIMUM LIMIT SET BY THIS PROGRAM, -C - MUST INCREASE THE SIZE OF PARAMETER NAME "ISUP" -C - (ONLY APPL. FOR NAMELIST SWITCH DOSPOB = TRUE) -C COND = 24 - THE NUMBER OF AIRCRAFT REPORTS IN A SINGLE TRACK -C - (FOR CHECKING) EXCEEDS THE MAXIMUM LIMIT SET BY -C - THIS PROGRAM, MUST INCREASE THE SIZE OF PARAMETER -C - NAME "ITMX" -C COND = 25 - THE NUMBER OF LATITUDE/LONGITUDE CORRECTIONS IN -C - THE EXTERNAL WAYPOINT CORRECTION FILE EXCEEDS THE -C - MAXIMUM LIMIT SET BY THIS PROGRAM, MUST INCREASE -C - THE SIZE OF PARAMETER NAME "LSIZE" -C COND = 26 - THE NUMBER OF REPORTS IN THE POINTER SUMMARY FOR A -C - TRACK EXCEEDS THE MAXIMUM LIMIT SET BY THIS PROGRAM, -C - MUST INCREASE THE SIZE OF PARAMETER NAME "ITRKL" -C COND = 27 - THE NUMBER OF REPORTS WITH ADJUSTABLE CONSTANTS FOR -C - AIRCRAFT GROUND SPEED LIMITS IN A TRACK EXCEEDS THE -C - MAXIMUM LIMIT SET BY THIS PROGRAM, MUST INCREASE THE -C - SIZE OF PARAMETER NAME "ITRKL" -C COND = 28 - THE NUMBER OF POINTERS FOR NON-ADJACENT REPORTS IN A -C - TRACK EXCEEDS THE MAXIMUM LIMIT SET BY THIS PROGRAM, -C - MUST INCREASE THE SIZE OF PARAMETER NAME "ITRKL" -C COND = 29 - THE NUMBER OF DUPLICATE TYPES IN A TRACK EXCEEDS THE -C - MAXIMUM LIMIT SET BY THIS PROGRAM, MUST INCREASE THE -C - SIZE OF PARAMETER NAME "ITRKL" -C COND = 30 - THE NUMBER OF REPORTS IN A TRACK WITH LARGE POSTION -C - ERRORS EXCEEDS THE MAXIMUM LIMIT SET BY THIS -C - PROGRAM, MUST INCREASE THE SIZE OF PARAMETER NAME -C - "ITRKL" -C COND = 70 - THE NUMBER OF LEVELS IN A DECODED REPORT'S HEADER -C - AND/OR OBS. AND/OR FCST LVL IS NOT 1 -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 POSSIBLE OUTPUT QUALITY MARKERS ARE DEFINED AS FOLLOWS: -C (WHERE: 'T' IS TEMPERATURE, 'W' IS WIND) -C -C PREPBUFR -C ORIGINAL SDM KEEP FLAG MAINTAINED (T/W) ......... 0 -C CHECKED BY THIS PROGRAM AND GOOD (T/W) .......... 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) ....... 3 -C CHECKED BY THIS PROGRAM AND BAD/FAILED (T/W) .... 13 -C OMIT FLAG -- USED TO GENERATE SUPEROB (T/W) ..... 10 -C ORIGINAL SDM PURGE FLAG MAINTAINED (T/W) ........ 14 -C NEW SUPEROBED REPORT (STNID IS 'SUPROB') (T/W) .. 1 -C FLAGGED REPORT OVER CONTINENTAL U.S. (T/W) ...... 15 -C -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ -CC -C ***** VARIABLES IN NAMELIST INPUT READ IN MAIN PROGRAM ***** -CC -C INIDST - TYPE OF INPUT FILE -C INIDST = 2 ---> PREPBUFR FILE IN UNIT 14 (ONLY CHOICE!) -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 {NOTE: THE MAXIMUM VALUE FOR WINDOW IS 5.75 (5-HOURS, -C 45-MINUTES; ANYTHING LARGER WILL RESULT IN ERROR!} -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 1: 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, -C THE REPORT IS SKIPPED SINCE ITS VALIDITY IS IN -C QUESTION) -C (NOTE 2: THIS TEST IS NOT DONE FOR TAMDAR REPORTS BECAUSE -C THEY ARE RESENT MANY TIMES OVER AND THE RECEIPT TIME -C FOR VERY LATE (E.G., T-12 NDAS) RUNS MAY INCORRECTLY -C DISPLAY WHAT LOOKS LIKE A STRANGE RECEIPT TIME) -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) -CC -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, 70 TO 90 DEGREES (N +) -CC -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/) -CC -C IFLGUS - WHEN IFLGUS = 1 OR 2 ---> WILL DO THE FOLLOWING TO -C CONVENTIONAL AIREP/PIREP AIRCRAFT REPORTS OVER CONUS: -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) IF IFLGUS = 1: WILL FLAG SUCH RPTS FOR NON-USE BY -C ANALYSIS BY SETTING TEMPERATURE AND WIND QUALITY -C MARKERS TO 15 -C IF IFLGUS = 2; WILL EXCLUDE SUCH RPTS FROM BEING -C OUTPUT -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 EWRITE - SWITCH TO GET STANDARD OUTPUT PRINTOUT OF "EVENTS" -C (WHEN A BUFR EVENT OCCURS, I.E. CHANGING A QUALITY MARK) -C EWRITE=.TRUE. ---> PRODUCE PRINTOUT -C EWRITE=.FALSE. --> NO PRINTOUT (DEFAULT) -CCCCC - PROGRAM PREPOBS_PREPACQC -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 - PARAMETER (IRMX= 80000, ISMX= 8000) -C PARAMETER NAME "ISUP" THROUGHOUT THIS PROGRAM SETS THE MAXIMUM -C NUMBER OF SUPEROBED REPORTS THAT CAN BE PROCESSED - PARAMETER (ISUP= 4000) -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) - PARAMETER (ISIZE= 16) - LOGICAL FWRITE,SWRITE,IWRITE,EWRITE,DOSPOB,DOACRS,WAYPIN,RCPTST - CHARACTER*1 CF,QCACMK(15),PF - CHARACTER*4 SSMARK - CHARACTER*5 SPEC5,SPEC6,QMARKI - CHARACTER*8 ACID,SAID,IDENT,AAID(IRMX) - CHARACTER*14 TAG,CTAG(IRMX),STAG(IRMX) - INTEGER IDATA(1608),NNQM(15),IDSTR(400,2) - REAL RDATA(1608) - COMMON/OUTPUT/KNTOUT(5) - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - 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) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),RCPTST - COMMON/TSTACAR/KTACAR - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - COMMON/MASK/GDNH(362,91),GDSH(145,37),GDUS(362,91) - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - COMMON/CBUFR/IDENT,IRCTME,RDATA,KIX,QMARKI,CF,PF - 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/STDATE/IDATE(5) - COMMON/WORD/ICHTP - NAMELIST/INPUT/DOSPOB,DOACRS,WINDOW,TIMINC,STCLIM,WAYPIN,INIDST, - $ FWRITE,SWRITE,IWRITE,EWRITE,IFLGUS,JAMASS,JAWIND,RCPTST - EQUIVALENCE (RDATA,IDATA) - DATA XMSG/99999./,ITOL/55/,QCACMK/'Q','R','S','T','U','V','W', - $ 'X','Y','Z','C','P','H','-','D'/ - CALL W3TAGB('PREPOBS_PREPACQC',2008,0212,0087,'NP22') - - PRINT 2111 - 2111 FORMAT('1',19X,'***** WELCOME TO THE AIRCRAFT QUALITY CONTROL ', - $'PROGRAM PREPACQC -- VERSION 30 JUL 2008 *****'/) -C CALL W3FI04 TO DETERMINE MACHINE WORD LENGTH (BYTES) -C AND TO TEST FOR ASCII(ICHTP=0) OR EBCDIC(ICHTP=1) CHARACTERS - CALL W3FI04(IENDN,ICHTP,LW) - PRINT 2213, LW, ICHTP, IENDN - 2213 FORMAT(/' ---> CALL TO W3FI04 RETURNS: LW = ',I3,', ICHTP = ',I3, - $ ', IENDN = ',I3/) - IF(ICHTP.GT.1) THEN -C----------------------------------------------------------------------- -C CHARACTERS ON THIS MACHINE ARE NEITHER ASCII OR EBCDIC!! -- STOP 22 - PRINT 217 - 217 FORMAT(/5X,'++ CHARACTERS ON THIS MACHINE ARE NEITHER ASCII', - $ ' NOR EBCDIC - STOP 22'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(22) -C----------------------------------------------------------------------- - END IF - RAD = 3.14159/180. -C INITIALIZE CONSTANTS FOR ACCOUNTING - KT = 0 - KSDM = 0 - ICNT1 = 0 - ICNT2 = 0 - ICNT3 = 0 - ICNT45 = 0 - ICNT69 = 0 - ICNTX = 0 - KDUP = 0 - KTACAR = 0 - KQM2F = 0 - KISO = 0 - KNQM = 0 - NNQM = 0 - KTYPS = 0 - CALL SETBMISS(10E8_8) -C READ IN NAMELIST, FIRST SET-UP ANY DEFAULTS - WINDOW = 3.00 - TIMINC = 1.00 - RCPTST = .TRUE. - STCLIM = 41.9 - DOSPOB = .TRUE. - DOACRS = .FALSE. - WAYPIN = .FALSE. - IFLGUS = 1 - FWRITE = .FALSE. - SWRITE = .FALSE. - IWRITE = .FALSE. - EWRITE = .FALSE. - JAMASS = 0 - JAWIND = 0 - READ(5,INPUT,END=9222) - INIDST = 2 - 9222 CONTINUE - IF(DOSPOB) PRINT 2112 - 2112 FORMAT(40X,'> > > > > SUPEROBS WILL BE GENERATED < < < < <'/) - IF(.NOT.DOSPOB) PRINT 2113 - 2113 FORMAT(38X,'> > > > > SUPEROBS WILL NOT BE GENERATED ', - $ '< < < < <'/) - CALL DBUFR(IDATEP) - IDATE(1) = IDATEP/1000000 - IDATE(2) = MOD((IDATEP/10000),100) - IDATE(3) = MOD((IDATEP/100),100) - IDATE(4) = MOD(IDATEP,100) - LATEST = 9999 - IDATE(5) = 0 - KOUNT = 0 - KNTIN = 0 - KNTOUT = 0 - TBASE = REAL(IDATE(4) * 100.) - IF(NINT(TBASE).LT.600) TBASE = TBASE + 2400. -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.) - 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: ',I6,4I4,/, - $ 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',//) - WRITE(6,INPUT) -C READ IN N.H. CONUS MASK (1 DEG GRID); IF MASK > 0 THEN GRID LOCATED -C HERE -- THIS IS NEEDED LATER IN PROGRAM - PRINT 101 - 101 FORMAT(/1X,'**** OPEN UNIT 15 TO GET CONUS GRID FOR LOCATION ', - $ 'CHECKS ****'/) - READ(15,ERR=8814) GDNH - READ(15,ERR=8814) GDSH - READ(15,ERR=8814) GDUS - GO TO 8812 -C----------------------------------------------------------------------- - 8814 CONTINUE -C PROBLEM W/ READ; INIT. GDUS ARRAY TO 0 - (HAVE TO ASSUME ALL N.H. OBS. -C ARE OUTSIDE OF CONUS REGION) - GDUS = 0.0 - PRINT 102 - 102 FORMAT(/' +++> TROUBLE READING U.S. MASK FILE; ASSUME ALL N.H. ', - $ 'DATA OUTSIDE CONUS REGION IN ANY CONUS TEST'/) -C----------------------------------------------------------------------- - 8812 CONTINUE - IF(IWRITE) PRINT 6176 - 6176 FORMAT(/' LISTING OF ORIGINAL DATA BEFORE IDSORT----'/9X,'ACID', - $ 8X,'LAT WLON UTC ALT TEMP WDIR WSPD -----TAGS', - $ '----- ITYPE RPTIME KNTINI GALT GTEMP GDIR GSPD'/) - 5 CONTINUE - ALTF = XMSG - DIRF = XMSG - SPDF = XMSG - TMPF = XMSG -C*********************************************************************** -C READ IN NEXT AIRCRAFT REPORT -C*********************************************************************** - IY = 43 - SPEC5 = '----' - SPEC6 = '----' - CALL IBUFR(ALTF,DIRF,SPDF,TMPF,*2) - SPEC5(3:3) = PF - SPEC6(3:3) = CF - KOUNT = KOUNT + 1 - KNTIN = KNTIN + 1 - KNTINI(KOUNT) = KNTIN - IF(KOUNT.GT.IRMX) THEN -C*********************************************************************** -C FATAL ERROR: THERE ARE MORE RPTS IN INPUT FILE THAN "IRMX" -- STOP 20 - PRINT 53, IRMX - 53 FORMAT(/' THERE ARE MORE THAN',I5,' AIRCRAFT REPORTS IN INPUT ', - $ 'FILE -- MUST INCREASE SIZE OF PARAMETER NAME "IRMX" - STOP 20'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(20) -C*********************************************************************** - END IF - TAG(KOUNT)(12:12) = '-' - ALAT(KOUNT) = RDATA(1) - ALON(KOUNT) = RDATA(2) - INTP(KOUNT) = IDATA(8) - IF(NINT(ALON(KOUNT)).EQ.36000) ALON(KOUNT) = 0.0 -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) - IF(NINT(ALAT(KOUNT)).GT.9000.OR.NINT(ALAT(KOUNT)).LT.-9000) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE LAT SET TO MSG!!' -CAAAAA%%%%% - ALAT(KOUNT) = XMSG - TAG(KOUNT)(12:12) = '@' - ELSE - ALAT(KOUNT) = ALAT(KOUNT) * .01 - END IF - IF(NINT(ALON(KOUNT)).GT.36000.OR.NINT(ALON(KOUNT)).LT.0) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE LON SET TO MSG!!' -CAAAAA%%%%% - ALON(KOUNT) = XMSG - TAG(KOUNT)(12:12) = '@' - ELSE - ALON(KOUNT) = ALON(KOUNT) * .01 - END IF - ACID(KOUNT) = IDENT - TIME(KOUNT) = RDATA(4) -CVVVVV%%%%% - IF(NINT(TIME(KOUNT)).GT.2400.OR.NINT(TIME(KOUNT)).LT.0) - $ PRINT *,'~~~~~ HERE IS A MISSING/UNREASONABLE TIME, TOSSED?' -CAAAAA%%%%% - IRTM(KOUNT) = IRCTME -C DO A TIME CHECK ON REPORT -- IF OUTSIDE EXPANDED INPUT WINDOW TOSS IT - ITIME = NINT(TIME(KOUNT)) - IF(NINT(TBASE).GT.2300.AND.NINT(TIME(KOUNT)).LE. - $ (IDATE(4)*100)+600) TIME(KOUNT) = TIME(KOUNT) + 2400. - IF(TIME(KOUNT).LT.TMIN.OR.TIME(KOUNT).GT.TMAX) THEN -C SKIP REPORTS OUTSIDE REQUESTED TIME WINDOW -CCCCCC PRINT 9002,KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT),TIME(KOUNT) -C9002 FORMAT(/' ##########: MAIN; REPORTS OUTSIDE TIME WINDOW SKIPPED.', -CCCCC$ I5,2X,A8,2F8.2,F6.0) - KOUNT = KOUNT - 1 - GO TO 5 - END IF - IF(RCPTST.AND.IRCTME.LE.2400.AND.MOD(KIX,10).NE.4) THEN -C FOR ALL TYPES EXCEPT TAMDAR, CHECK FOR DATA WITH STRANGE RECEIPT TIME -C COMPARED TO REPORT TIME - MAY BE YESTERDAY'S REPORT PROCESSED TODAY -C -- IF THE RECEIPT TIME IS OUTSIDE THE RANGE OF REPORT TIME MINUS -C 1-HOUR TO REPORT TIME PLUS 11.99 HOURS, SKIP THE REPORT AS WE CAN'T -C DETERMINE ITS VALIDITY {THIS TEST IS NOT DONE FOR TAMDAR REPORTS -C BECAUSE THEY ARE RESENT MANY TIMES OVER AND THE RECEIPT TIME FOR -C VERY LATE (E.G., T-12 NDAS) RUNS MAY INCORRECTLY DISPLAY WHAT LOOKS -C LIKE A STRANGE RECEIPT TIME} - IF(ITIME.LT.100) ITIME = ITIME + 2400 - IETIME = ITIME - 100 - ILTIME = ITIME + 1199 - IF(IRCTME.LT.IETIME.OR.IRCTME.GT.ILTIME) THEN -C RECEIPT TIME IS OUTSIDE EXPECTED RANGE, BUT MAY BE AROUND 00Z SO ADD -C 2400 TO RECEIPT TIME AND TEST AGAIN - IRCTMN = IRCTME + 2400 - IF(IRCTMN.LT.IETIME.OR.IRCTMN.GT.ILTIME) THEN -C RECEIPT TIME IS STILL OUTSIDE EXPECTED RANGE, SKIP REPORT -CVVVVV%%%%% - PRINT *,'~~~~~ THE STRANGE RECEIPT TIME DIFF. HAS OCCURRED!!' -CAAAAA%%%%% - PRINT 9393, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),IRCTME,SPEC6(3:3) - 9393 FORMAT(/' ##########: SKIP RPTS WHERE OBS. & RCPT. TIME ARE INCON' - $,'SISTENT ',I5,2X,A8,2F8.2,F6.0,'; REC. TIME',I5,'; CAFB? ',A1) - KOUNT = KOUNT - 1 - GO TO 5 - END IF - END IF - END IF - AALT(KOUNT) = RDATA(IY) - ADIR(KOUNT) = RDATA(IY+3) - ASPD(KOUNT) = RDATA(IY+4) - ATMP(KOUNT) = RDATA(IY+1) -C FILL IN FCST VALUES FOR ALT, DIR, SPD & TMP - AALTF(KOUNT) = ALTF - ADIRF(KOUNT) = DIRF - ASPDF(KOUNT) = SPDF - ATMPF(KOUNT) = TMPF - ITEVNT(KOUNT) = 0 - IWEVNT(KOUNT) = 0 -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 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 (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 PREPBUFR 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 MAXIMUM LIMIT (12 DEG. C PRIOR TO -C ??/??/2005, 32 DEG. C AFTER THIS DATE). -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/TAMDAR REPORT WIND = 13 -C IN A TRACK WITH AN UNREASONABLE GROUND SPEED -C AND VECTOR WIND INCREMENT GREATER THAN 70 -C KNOTS. 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/TAMDAR REPORTS, THERE ARE AT LEAST 10 -C REPORTS WITH A VECTOR WIND INCREMENT GREATER -C THAN 50 KNOTS. WIND CONSIDERED BAD. -C 328 RPACKR ISOLATED ASDAR/AMDAR/TAMDAR REPORT WITH A TEMP = 1 -C TEMPERATURE AND/OR WIND THAT HAS PASSED ALL WIND = 1 -C CHECKS. TEMPERATURE AND/OR WIND CONSIDERED -C 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 330 RPACKR ISOLATED ASDAR/AMDAR/TAMDAR REPORT WITH A TEMP = 3 -C MISSING PHASE OF FLIGHT INDICATOR WIND = 3 -C (PROBABLY BANKING). TEMPERATURE AND/OR -C WIND CONSIDERED SUSPECT. -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 SDM HAS PURGED WIND (IN WHICH CASE -C PREVIOUS PREPDATA CODE HAS ALSO PURGED TEMP) -C (NOTE: NO LONGER SET TO 'P' IF SDM HAS PURGED TEMP BUT -C NOT WIND) -C ** NO LONGER!! : 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 (NOTE: ON29 MARKER " " CHANGED TO "-" HERE) -C BYTE 3 : +++ TRACK CHECK INDICATOR -C : WILL CONTAIN 'E' IF SUSPECTED TRACK CHECK ERROR -C : ELSE WILL BE '-' -C BYTE 4 : +++ FINAL WIND QUALITY MARKER (ON29 FORM) -C (NOTE: ON29 MARKER " " CHANGED TO "-" HERE) -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 BYTE 6 : +++ ASDAR/AMDAR/TAMDAR TEMPERATURE PRECISION -C : WILL CONTAIN '0' IF LOW PRECISION -C : WILL CONTAIN '1' IF HIGH PRECISION -C : ELSE WILL BE '-' IF ASDAR/AMDAR/TAMDAR T. PRECISION NOT -C REPORTED, OR IF NOT AN ASDAR/AMDAR/TAMDAR REPORT -C BYTE 7 : +++ ASDAR/AMDAR/TAMDAR/CARSWELL-TINKER INDICATOR -C : WILL CONTAIN 'Z' IF ASDAR/AMDAR/TAMDAR REPORT -C : ELSE WILL CONTAIN 'C' IF CARSWELL-TINKER REPORT -C : ELSE WILL BE '-' IF NONE OF THE ABOVE -C BYTE 8 : +++ ASDAR/AMDAR/TAMDAR 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 '-' IF NONE OF ABOVE OR AIREP/PIREP REPORT -C BYTE 9 : +++ CORRECTED WAYPOINT LOCATION INDICATOR -C : WILL CONTAIN 'C' IF LAT/LON CHANGED (CORRECTED) -C : ELSE WILL BE '-' -C BYTE 10 : +++ ASDAR/AMDAR/TAMDAR 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 (PROBABLY BANKING) -C : ELSE WILL CONTAIN '9' IF AIREP/PIREP REPORT -C BYTE 11 : +++ CURRENTLY NOT USED AND SET TO '-' -C BYTE 12 : +++ ISOLATED REPORT INDICATOR -C : WILL CONTAIN 'I' IF AN ISOLATED REPORT -C : ELSE WILL BE '-' -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 (' ' OR -C '-') -C '8' -- INITIAL VALUE -C -C - TAG(KOUNT)(2:4) = '---' - TAG(KOUNT)(6:9) = '----' - TAG(KOUNT)(11:11) = '-' - TAG(KOUNT)(10:10) = SPEC5(3:3) - - IF((MOD(KIX,10).EQ.1.OR.MOD(KIX,10).EQ.4.OR.MOD(KIX,10).EQ.5))THEN - -C AMDAR/ASDAR/TAMDAR - - 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 - -C TINKER (CARSWELL) - - TAG(KOUNT)(7:7) = 'C' - END IF - - TAG(KOUNT)(13:14) = '88' - TAG(KOUNT)(5:5) = 'N' - IF(QMARKI(4:4).GE.'Q'.AND.QMARKI(4:4).LE.'Z') - $ TAG(KOUNT)(5:5) = QMARKI(4:4) - TAG(KOUNT)(1:1) = QMARKI(4:4) - IF(QMARKI(1:1).EQ.'P') THEN - TAG(KOUNT)(1:1) = 'P' -C IF SDM PURGE FLAG ON WIND, WIND Q.M. IS 'P' -C (NOTE: IN THIS CASE PREVIOUS PREPOBS_PREPDATA PROGRAM HAS ALSO -C PURGED TEMP, SO ITS Q.M. WILL ALSO BE SET TO 'P' FURTHER DOWN) - IF(QMARKI(5:5).NE.'P') THEN !shouldn't happen (see NOTE above) - PRINT 9029, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT) - 9029 FORMAT(/' ##########: SDM PURGE FLAG ON WIND, WIND Q.M. IS "P".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - ELSE ! should ALWAYS happen (see NOTE above) - PRINT 90291, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT) -90291 FORMAT(/' ##########: SDM PURGE FLAG ON WIND & TEMP, Q.M.s "P".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - END IF -C SET POS. 12 OF TAG TO '@' TO MARK PURGE FLAG - TAG(KOUNT)(12:12) = '@' - TAG(KOUNT)(4:4) = 'P' - TAG(KOUNT)(14:14) = '1' - ELSE IF(QMARKI(1:1).EQ.'H') THEN -C IF SDM KEEP FLAG ON WIND, WIND Q.M. IS 'H' - PRINT 9027, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT) - 9027 FORMAT(/' ##########: SDM KEEP FLAG ON WIND, WIND Q.M. IS "H".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(4:4) = 'H' - TAG(KOUNT)(14:14) = '1' - END IF - IF(QMARKI(5:5).EQ.'P') THEN -C IF SDM PURGE FLAG ON TEMP, TEMP Q.M. IS 'P' -C (NOTE: IF ONLY SDM PURGE FLAG ON WIND, PREVIOUS PREPOBS_PREPDATA -C PROGRAM WILL ALSO SET TEMP Q.M. AS SDM PURGE) - IF(QMARKI(1:1).NE.'P') PRINT 90292, KOUNT,ACID(KOUNT), - $ ALAT(KOUNT),ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) -90292 FORMAT(/' ##########: SDM PURGE FLAG ON TEMP, TEMP Q.M. IS "P".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'P' - TAG(KOUNT)(13:13) = '1' - ELSE IF(QMARKI(5:5).EQ.'H') THEN -C IF SDM KEEP FLAG ON TEMP, TEMP Q.M. IS 'H' - PRINT 90271, KOUNT,ACID(KOUNT),ALAT(KOUNT),ALON(KOUNT), - $ TIME(KOUNT),TAG(KOUNT) -90271 FORMAT(/' ##########: SDM KEEP FLAG ON TEMP, TEMP Q.M. IS "H".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'H' - TAG(KOUNT)(13:13) = '1' - END IF - IF(TAG(KOUNT)(1:1).NE.'P') THEN - IF(ATMP(KOUNT).GE.XMSG) THEN -C IF TEMPERATURE OR WIND IS MISSING KEEP QUALITY MARKERS EQUAL TO '-' - IF(TAG(KOUNT)(13:13).GT.'2') TAG(KOUNT)(13:13) = '2' - ELSE IF(ATMPF(KOUNT).LT.XMSG) THEN -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) - IF((AALT(KOUNT).GT.609..AND.AALT(KOUNT).LT.1524.).AND. - $ (ABS(ATMP(KOUNT)-ATMPF(KOUNT)).GT.250.)) THEN - TAG(KOUNT)(12:12) = '@' -CVVVVV%%%%% - PRINT *,'~~~~~ HERE IS A RPT WITH INCORRECT? ALTITUDE!!' -CAAAAA%%%%% - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9902, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 9902 FORMAT(/' #EVENT 302: "0" DIGIT DROPPED FROM ALT.?, TEMP QM "F" ', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 302 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8902, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 8902 FORMAT(/' #EVENT 302: "0" DIGIT DROPPED FROM ALT.?, WIND QM "F" ', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(4:4) = 'F' - TAG(KOUNT)(14:14) = '3' - IWEVNT(KOUNT) = 302 - END IF - END IF - END IF - IF(ASPD(KOUNT).GE.XMSG.OR.ADIR(KOUNT).GE.XMSG) THEN - IF(TAG(KOUNT)(14:14).GT.'2') TAG(KOUNT)(14:14) = '2' - END IF - IF(TAG(KOUNT)(13:13).GT.'3'.AND.ATMP(KOUNT).GT.320.) THEN -C FLAG TEMPERATURES GREATER THAN MAXIMUM LIMIT (GROSS CLIMATOLOGICAL -C CHECK - LIMIT CHANGED FROM 12 TO 32 DEG. C ON ??/??/2005) - IF(EWRITE) PRINT 9004, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 9004 FORMAT(/' #EVENT 303: TEMPERATURE > 32.0 C, TEMP Q.M. SET TO "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 303 - END IF - IF(TAG(KOUNT)(14:14).GT.'3'.AND.ASPD(KOUNT).EQ.0..AND. - $ ADIR(KOUNT).NE.360.) THEN -C FLAG CALM WINDS THAT ARE NOT ASSIGNED A DIRECTION OF 360 DEGREES - IF(EWRITE) PRINT 9005, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 9005 FORMAT(/' #EVENT 304: CALM WIND NOT FROM 360, WIND Q.M. SET "F".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(4:4) = 'F' - TAG(KOUNT)(14:14) = '3' - IWEVNT(KOUNT) = 304 - END IF - IF(ACID(KOUNT).EQ.'XX999 ') THEN -C FLAG CARSWELL-TINKER CONVERTED PIREPS; SET POS. 12 OF TAG TO '@' TO -C MARK THEM - TAG(KOUNT)(12:12) = '@' - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9001, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 9001 FORMAT(/' #EVENT 301: CARSWELL-TINKER PIREP(XX999), TEMP QM "F" ', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 301 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8001, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 8001 FORMAT(/' #EVENT 301: CARSWELL-TINKER PIREP(XX999), WIND QM "F" ', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(4:4) = 'F' - TAG(KOUNT)(14:14) = '3' - IWEVNT(KOUNT) = 301 - END IF - ELSE IF(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 FLAG OTHER PIREPS IF INCR. MARKER 'S-Z' OR 'N'; SET POS. 12 OF TAG TO -C '@' TO MARK THEM - TAG(KOUNT)(12:12) = '@' - IF(TAG(KOUNT)(13:13).GT.'3') THEN - IF(EWRITE) PRINT 9006, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 9006 FORMAT(/' #EVENT 305: PIREP W/ LG OR N/A INCR., TEMP Q.M. IS "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(2:2) = 'F' - TAG(KOUNT)(13:13) = '3' - ITEVNT(KOUNT) = 305 - END IF - IF(TAG(KOUNT)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8006, KOUNT,ACID(KOUNT),ALAT(KOUNT), - $ ALON(KOUNT),TIME(KOUNT),TAG(KOUNT) - 8006 FORMAT(/' #EVENT 305: PIREP W/ LG OR N/A INCR., WIND Q.M. IS "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KOUNT)(4:4) = 'F' - TAG(KOUNT)(14:14) = '3' - IWEVNT(KOUNT) = 305 - END IF - END IF - END IF - 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,1X,2F8.2,I6,I7,3I6,3X,'"',A14,'"',I6,2I8, - $ I7,3I6) - END IF -C NOW GO BACK AND READ IN NEXT REPORT - GO TO 5 -C*********************************************************************** - 2 CONTINUE -C ALL MESSAGES READ IN -- FINISHED READING IN REPORTS - PRINT 812, KOUNT - 812 FORMAT(/' ALL MESSAGES READ IN PREPBUFR FILE -- KOUNT= ',I9) - NFILE = KOUNT - IF(KOUNT.EQ.0) GO TO 6000 -C*********************************************************************** -C SORT BY AIRCRAFT STATION ID -C*********************************************************************** - CALL IDSORT(NFILE,NASDAR,NEXCLD) - IF(IWRITE) THEN - PRINT 2177 - 2177 FORMAT(/' LISTING OF ORIGINAL DATA AFTER IDSORT----'/9X,'ACID', - $ 8X,'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 TRACK CHECK -C*********************************************************************** -C CALL TRACK CHECK WITH NASDAR, NEXCLD (ASDAR/AMDAR/TAMDAR ARE NEXT TO -C LAST IN SORTED ARRAY, REPORTS EXCLUDED FROM ALL CHECKS ARE LAST -C SORTED ARRAY) -C CALL TRACK CHECK WITH NFILE=KOUNT, RETURNS NEW KOUNT (NO DUPS) - 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 - 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 INITIALIZE SDM LOOKAT FILE FOR FLAGGED ISOLATED REPORTS -- UNIT 52 - WRITE(52,15) (IDATE(I),I=1,4) - 15 FORMAT(/' SDM AIRCRAFT QC CHECK FILE FOR ',I6,3I4) - WRITE(52,45) LATEST - 45 FORMAT(' LATEST A/C REPORT AT ',I4/) - WRITE(52,16) - 16 FORMAT(' ISOLATED REPORTS TOSSED (WIND QM=F), OR WITH LARGE ', - $ 'INCREMENTS (.GE. 50 KNOTS)'/ - $ ' (SUSPECT QM=Q, GOOD QM=A)'/ - $ ' (NOTE1: AMDAR/ASDAR/TAMDAR ARE NEVER FLAGGED AS BAD DUE ONLY ', - $ ' TO LARGE INCREMENTS)'/ - $ ' (NOTE2: DOES NOT INCLUDE REPORTS MARKED FOR EXCLUSION BY ', - $ 'THIS PROGRAM - THESE ARE'/ - $ ' NOT CONSIDERED CANDIDATES FOR RETENTION)'/ - $ ' (NOTE3: REPORTS WITH BAD TEMP QM BUT NON-BAD WIND QM ARE NOT', - $ ' LISTED HERE UNLESS'/ - $ ' THEY HAVE A LARGE INCREMENT (.GE. 50 KNOTS))'// - $ ' SDMEDIT CAN BE USED TO MARK THESE FOR RETENTION (KEEP FLAG) ', - $ 'IN LATER RUNS'//) - WRITE(52,17) - 17 FORMAT(/' AC',8X,'LAT LON UTC ALT TEMP WDIR ', - $ ' WSPD INCR SDM WND TMP'/' IDENT',30X,'(MB) (C)',8X, - $ '(KNTS) (KNTS) FLAG? QM QM'/' -------- ----- ------- ', - $ '----- ----- ----- ----- ----- ---- --- --- ---'/) -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 ON WIND AMD/OR TEMP -- -C UNIT 53 - WRITE(53,15) (IDATE(I),I=1,4) - WRITE(53,6) - 6 FORMAT(' ??? STACK, EVALUATE AND USE SDMEDIT -'/' STACKS WITH ', - $ 'AT LEAST ONE REPORT CONTAINING SDM KEEP FLAG ON WIND AND/OR ', - $ 'TEMP ALSO HERE') - WRITE(53,17) -C INITIALIZE FOR STACK DETERMINATION -C NOTE: THE FINAL SORT IS SET-UP S. T. AIREPS/PIREPS ARE FIRST, FOLLOWED -C BY ASDARS/AMDARS/TAMDARS, AND THEN AT THE END ALL EXLCUDED REPORTS -C -- ONLY THE NON-EXCLUDED AIREP/PIREP REPORTS ARE CHECKED FOR STACKS - K = 1 - INDX = 2 - NCUM = 2 - IFLEPT(1) = 1 - IFLEPT(KOUNT+1) = 1 - KDUP = NFILE - KOUNT - 94 CONTINUE -C FIND COLOCATED OBS- THRU ENTIRE FILE (TOLERANCE IS .55 DEG. LAT/LON) - IQ1 = NINT(ABS(ALAT(INDX)-ALAT(INDX-1)) * 100.) - IQ2 = NINT(ABS(ALON(INDX)-ALON(INDX-1)) * 100.) - IF(IQ1.LE.ITOL.AND.(IQ2.LE.ITOL.OR.IQ2.GE.36000-ITOL)) THEN -C THIS IS A STACK - IF(NCUM.GT.ISMX) THEN -C*********************************************************************** -C FATAL ERROR: THERE ARE MORE REPORTS IN A STACK THAN "ISMX" -- STOP 21 - PRINT 63, ISMX - 63 FORMAT(/' THERE ARE MORE THAN',I5,' AIRCRAFT REPORTS IN A STACK', - $ ' -- MUST INCREASE SIZE OF PARAMETER NAME "ISMX" - STOP 21'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(21) -C*********************************************************************** - END IF - IFLEPT(INDX) = NCUM - NCUM = NCUM + 1 - ELSE -C THIS IS NOT A STACK - IFLEPT(INDX) = 1 - NCUM = 2 - END IF - IF(INDX.LT.KOUNT-NASDAR-NEXCLD) THEN - INDX = INDX + 1 - GO TO 94 - END IF -C ALL ASDAR/AMDAR/TAMDAR AND EXCLUDED REPORTS ARE TREATED AS ISOLATED - IFLEPT(INDX+1:INDX+NASDAR+NEXCLD) = 1 -C ARRANGE STACK - INDX RUNS FROM 1 TO KOUNT WHILE COUNTER FOR -C ISTCPT RUNS FROM 1 TO NUM FOR EACH COLOCATED SET - NUM = 1 - JARRAY = 0 - CTAG = '--------------' - AAID = ' ' - DO INDX = 1,KOUNT - IF(IFLEPT(INDX).EQ.1.AND.IFLEPT(INDX+1).EQ.1) THEN -C----------------------------------------------------------------------- -C THIS IS AN ISOLATED OBSERVATION -C (NOTE: NO FLAGGING IS DONE FOR CALM WINDS WHEN OBS. IS ISOLATED) -C----------------------------------------------------------------------- - 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 IF LARGE VECTOR WIND INCREMENT (W - Z) AND NON-EXCLUDED AIREP/PIREP -C REPORT, CALL WAYPOINT TO SEE IF LOCATION NEEDS TO BE CHANGED - 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) -CVVVVV%%%%% - PRINT *,'~~~~~ WAYPT ERROR FROM CALL IN MAIN' -CAAAAA%%%%% -C SUBR. WAYPT HAS CHANGED LOCATION OF THIS REPORT AND HAS UPGRADED THE -C INCREMENT MARKER TO " " (SUSPECT) - 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 "-"'/) - END IF - END IF -C CALL RPACKR - CALL RPACKR(1,1,INDX) -C CALL FORSDM TO ALERT SDM TO FLAGGED ISOLATED REPORTS OR ISOLATED -C REPORTS WITH LARGE INCREMENTS (SKIP EXCLUDED REPORTS AT END OF THE -C LIST, BUT INCLUDE ASDARS/AMDARS/TAMDARS) - IF(INDX.LE.KOUNT-NEXCLD) CALL FORSDM(INDX) - ICNT1 = ICNT1 + 1 -C----------------------------------------------------------------------- - ELSE IF(IFLEPT(INDX).EQ.1.AND.IFLEPT(INDX+1).EQ.2) THEN -C CONTINUE, THERE ARE AT LEAST TWO - 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 JNDX SAVES THE STARTING POINT OF THE STAC - JNDX = INDX -C----------------------------------------------------------------------- - ELSE IF(IFLEPT(INDX).GT.1.AND.IFLEPT(INDX+1).GT.1) THEN -C CONTINUE, THERE ARE STILL MORE - 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 - ELSE IF(IFLEPT(INDX).GT.1.AND.IFLEPT(INDX+1).EQ.1) THEN -C THERE IT IS FINISHED --- -C----------------------------------------------------------------------- -C THIS IS A STACK OF 'NUM' OBSERVATIONS -C----------------------------------------------------------------------- - 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 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 - IK = 0 - KNUM = NUM - DO I = 1,NUM-1 - DO 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 - ENDDO - ENDDO - 1191 CONTINUE - IF(IK.GT.0) THEN - DO 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 - IF(EWRITE) PRINT 9003, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9003 FORMAT(/' #EVENT ###: STACK DUPLICATE, TEMP/WIND Q.M. SET TO "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') -C ASSIGN 'D' TO POS. 1 OF TAG TO INDICATE DUPLICATE (RPACKR WILL DELETE) - 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 CHKR THROWS ',2I5,2X,A8,',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,A8,',AALT=',F7.0,', TIME=', - $ F7.0,', DIR=',F5.0,', SPD=',F5.1,', LAT/LON=',2F7.2,' KNUM=',I3) - END IF - ENDDO - IF(KNUM.EQ.1) THEN -C IF ALL DUPL. BUT ONE ARE REMOVED, THIS REPORT NOW TREATED AS ISOLATED - TAG(JNDX+1)(12:12) = 'I' - CALL RPACKR(1,1,JNDX+1) - GO TO 19 - END IF - END IF -C COUNT CALMS - KNUM = 0 - DO KNDX = JNDX,JNDX+NUM-1 - IF(ASPD(KNDX).EQ.0.0) KNUM = KNUM + 1 - ENDDO - IF(KNUM.LE.3.AND.NUM.LE.6) THEN -C IF NUMBER OF CALMS IN STACK (KNUM) < 3 THEN FLAG WINDS - DO 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 - IF(EWRITE) PRINT 9007, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KOUNT),TIME(KNDX),TAG(KNDX) - 9007 FORMAT(/' #EVENT 306: # CALMS IN STACK < 3, WIND Q.M. SET TO "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(4:4) = 'F' - TAG(KNDX)(14:14) = '3' - IWEVNT(KNDX) = 306 - END IF - END IF - ISTCPT(K) = IFLEPT(KNDX) - ENDDO - END IF - LOALT = 0 - DO I = 1,NUM - KNDX = JNDX + I - 1 - IF(AALT(KNDX).LT.8400.) THEN - IFLEPT(KNDX) = -1 - ISTCPT(I) = -1 - LOALT = LOALT + 1 - END IF - ENDDO -C CALLS TO APPROPRIATE ROUTINES - 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 CALL RPACKR - CALL RPACKR(NUM,NTOTL,JNDX) -C DO CENSUS ON #S AT POINTS-BOOKEEPING - 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 -C--------------------------------------------------------------------- - END IF - 19 CONTINUE - ENDDO - 6000 CONTINUE -C----------------------------------------------------------------------- -C PACK Q.C'ED AND SUPEROBED (DOSPOB=T) OBSERVATIONS -C INTO PREPBUFR FILE -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(/5X,'@@@@@ 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) - 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',10X,'WEST', - $ 5X,'M C*10 DEG KTS',8X,14('-'),8X,'UTC',21X,'M C*10 DEG', - $ ' KTS'/) - KNT = 0 - DO 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,I5,2F7.2,2I6,2I5,2X,A1,1X,A1,2X,'"',A14,'"', - $ I4,2I6,2I5,I7,3I6) - 200 CONTINUE - ENDDO - IF(KNTOUT(3).GT.0) THEN - PRINT 9925 - 9925 FORMAT(//35X,'>>>>> LISTING OF NEW SUPEROB REPORTS IN AIRCFT ', - $ 'FILE <<<<<'//5X,'K STNID',5X,'TIME',6X,'LAT',6X,'LON ALT', - $ 7X,'TEMP DIR SPEED QUAL GESS: ALT',6X,'TEMP DIR ', - $ ' SPEED INCR'/18X,'UTC',15X,'WEST METERS DEG.C DEG. ', - $ ' KNOTS MARKS --> METERS DEG.C DEG. KNOTS -T--W-'/) - KNT = 0 - DO 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',F9.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 - ENDDO - END IF - END IF - 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) - PRINT 5012, KTYPS - 5012 FORMAT(/' #TYPE1A ',I2,' #TYPE1B ',I2,' #TYPE?? ',I2,' #TYPE1D ', - $ I2,' #TYPE2A ',I2,' #TYPE2B ',I2,' #TYPE3 ',I2,10X,I2,' TIME ', - $ 'TAGS',I2) - PRINT 5014, QCACMK - 5014 FORMAT(//' ORIGINAL DATA (WITHIN OUTPUT TIME WINDOW)'/14X, - $ 15(5X,A1)/) - PRINT 5331, NNQM - 5331 FORMAT(' TOTAL QM #S = ',15I6) - PRINT 5337, KISO - 5337 FORMAT(' ISOLA QM #S = ',15I6) - PRINT 5338, KNQM - 5338 FORMAT(' STACK QM #S = ',15I6) - PRINT 5011, KQM2F - 5011 FORMAT(' STACK WND QM=F',15I6/) - PRINT 5013, KSDM,KT - 5013 FORMAT(' STACK: NO. SDM (ONLY) PURGES',I5,'; NO. SDM KEEPS',I5, - $ '; NO. BAD TEMPS/NON-BAD WINDS',I5/10X,'(WIND AND/OR TEMP)'/) - END FILE 52 - REWIND 52 - END FILE 53 - REWIND 53 - PRINT 5015 - 5015 FORMAT(/49X,'************PROGRAM COMPLETED *********') - CALL W3TAGE('PREPOBS_PREPACQC') - STOP - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: TRKCHK COMPLETE TRACK CHECK FOR ALL FLIGHTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2007-10-17 -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 1993-01-05 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-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 1995-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 1995-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 1999-08-23 D.A. KEYSER -- ADDED HIGHER ORDERS IN CHARACTER SORTS -C TO HOPEFULLY ALWAYS GIVE SAME SORT ORDER REGARDLESS OF -C INPUT REPORT ORDER -C 2007-10-17 D. A. KEYSER -- CHECKS TO SEE IF PARAMETER "ITRKL" IS -C EXCEEDED IN A NUMBER OF TRACK CHECK TESTS, IF SO STOPS -C ABNORMALLY WITH CONDITION CODES 26-30 (DEPENDING ON WHAT -C CAUSES "ITRKL" TO BE EXCEEDED), BEFORE COULD RUN TO -C COMPLETION BUT CLOBBER MEMORY OR MAYBE SEG FAULT; -C INCREASED THE SIZE OF PARAMETER "ITRKL" FROM 20 TO 500 - -C TO PREVENT ARRAYS OVERFLOWS IN NEARLY EVERY PRODUCTION -C RUN; INCREASED SIZE OF ARRAY "IPTTRK" FROM 5 TO PARAMETER -C "ITRKL" (NOW 500) (THIS HOLDS POINTER TO REPORTS IN A -C TRACK WITH LARGE POSITION ERRORS), BEFORE THE VALUE OF 5 -C WAS OFTEN EXCEEDED AND MEMORY WAS UNKNOWINGLY BEING -C CLOBBERED; ANY REPORTS WITH ID "UNKNOWN" ARE NOT -C CONSIDERED FOR TRACK CHECKING (THIS WAS PLACED ON SOME -C REPORTS IN REANALYSIS WHEN NO ID WAS PRESENT - SINCE -C THESE ARE NOT NORMALLY PART OF THE SAME FLIGHT THEY -C CANNOT BE TRACK CHECKED); CHANGES TO TREAT TAMDAR AND -C CANADIAN AMDAR REPORTS THE SAME AS ASDAR/AMDAR REPORTS -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/TAMDAR 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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE TRKCHK(NFILE,NASDAR,NEXCLD) - PARAMETER (IRMX= 80000, ISMX= 8000) - PARAMETER (ISIZE= 16) -C PARAMETER NAME "ITMX" IN THIS SUBROUTINE (ONLY) SETS THE MAXIMUM -C NUMBER OF ACFT RPTS THAT CAN BE CHECKED IN A SINGLE TRACK - PARAMETER (ITMX= 8000) -C PARAMETER NAME "ITRKL" IN THIS SUBROUTINE (ONLY) SETS THE FOLLOWING: -C THE MAXIMUM NUMBER OF REPORTS IN THE POINTER SUMMARY FOR A TRACK -C THE MAXIMUM NUMBER OF REPORTS WITH ADJUSTABLE CONSTANTS FOR -C AIRCRAFT GROUND SPEED LIMITS IN A TRACK -C THE MAXIMUM NUMBER OF POINTERS FOR NON-ADJACENT REPORTS IN A -C TRACK -C THE MAXIMUM NUMBER OF DUPLICATE TYPES IN A TRACK -C THE MAXIMUM NUMBER OF REPORTS IN A TRACK WITH LARGE POSTION -C ERRORS - PARAMETER (ITRKL= 1000) - LOGICAL LOGLAT,LOGTME,LOGLT1,LOGWND,DUP,LOGTRK,LOGALT,NEW,LOGLON, - $ LOGLO,LOGTMP,LOGGT3,LOGHI,LPOS25,TRACE,LUTCEQ,LLATEQ,LLONEQ, - $ LVAREQ,EWRITE,IWRITE - CHARACTER*1 TOSLIM,CTG,CH1(9) - CHARACTER*8 ACID,SAAID(IRMX),AAID(IRMX),TYPE(ITRKL) - CHARACTER*14 TAG,CTAG(IRMX),STAG(IRMX) - CHARACTER*32 CARRAY(IRMX) - INTEGER IPTNAD(ITRKL),JPTNAD(ITRKL),IPTADJ(ITRKL),IPTTRK(ITRKL), - $ DTKNT,IARRAY(ISMX),INDR(IRMX),ICH1(9) - REAL AVESPD(ITMX),DELPOS(ITMX),DELLAT(ITMX),DELLON(ITMX) - COMMON/STWRIT/SWRITE,EWRITE,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) - DATA CH1 /'Q','R','S','T','U','V','W','X','Y'/ - DATA ICH1 / 5, 15, 25, 35, 45, 55, 65, 75, 85 / - KOUNT = NFILE - TRACE = .TRUE. - TRACE = .FALSE. - DG2RAD = (4.0 * ATAN(1.0))/180. -C TRANSFER ORIGINAL DATA TO TEMPORARY ARRAYS TO HOLD FOR RE-ARRANGING -C (ORIGINAL DATA HAS BEEN SORTED BY FLIGHT ID, WITH ASDARS/AMDARS/ -C TAMDARS LAST) - AAID(1:NFILE) = ACID(1:NFILE) - SAAID(1:NFILE) = AAID(1:NFILE) - JARRAY(1:NFILE,1) = NINT(ALAT(1:NFILE)*100.) - JARRAY(1:NFILE,2) = NINT(ALON(1:NFILE)*100.) - JARRAY(1:NFILE,3) = NINT(AALT(1:NFILE)) - JARRAY(1:NFILE,4) = NINT(TIME(1:NFILE)) - JARRAY(1:NFILE,5) = NINT(ATMP(1:NFILE)) - JARRAY(1:NFILE,6) = NINT(ADIR(1:NFILE)) - JARRAY(1:NFILE,7) = NINT(ASPD(1:NFILE)) - JARRAY(1:NFILE,8) = INTP(1:NFILE) - JARRAY(1:NFILE,9) = IRTM(1:NFILE) - JARRAY(1:NFILE,10) = KNTINI(1:NFILE) - JARRAY(1:NFILE,11) = ITEVNT(1:NFILE) - JARRAY(1:NFILE,12) = IWEVNT(1:NFILE) - JARRAY(1:NFILE,13) = NINT(AALTF(1:NFILE)) - JARRAY(1:NFILE,14) = NINT(ADIRF(1:NFILE)) - JARRAY(1:NFILE,15) = NINT(ASPDF(1:NFILE)) - JARRAY(1:NFILE,16) = NINT(ATMPF(1:NFILE)) - KARRAY(1:NFILE,:) = JARRAY(1:NFILE,:) - CTAG(1:NFILE) = TAG(1:NFILE) - STAG(1:NFILE) = CTAG(1:NFILE) - NAIREP = NFILE - NASDAR - NEXCLD - PRINT 501, KOUNT,NASDAR,NAIREP,NEXCLD - 501 FORMAT(1X,128('*')/43X,'AIRCRAFT TRACK CHECK SORT - NCEP ', - $ 'WASHINGTON'/128('*')//' FILE KOUNT=',I6,' # AMDAR/ASDAR/', - $ 'TAMDAR=',I6,' # AIREP/PIREP=',I6,' # EXCLUDED=',I6) -CCCCC PRINT 502 -CC502 FORMAT(' LISTING OF IDSORTED DATA ENTERING TRKCHK----'/9X,'ACID', -cvvvvv a -Cxxxx$ 7X,' LAT WLON UTC ALT TEMP WDIR WSPD',6X, -CCCCC$ 8X,' LAT WLON UTC ALT TEMP WDIR WSPD',6X, -caaaaa a -CCCCC$ ' TAGS ',13X,'I.TYPE RCPT. TIME KNTINI'/) -CCCCC DO J = 1,KOUNT -CCCCC SARRY1 = 99999. -CCCCC IF(JARRAY(J,1).LT.99999) SARRY1 = JARRAY(J,1) * 0.01 -CCCCC SARRY2 = 99999. -CCCCC IF(JARRAY(J,2).LT.99999) SARRY2 = JARRAY(J,2) * 0.01 -CCCCC PRINT 331, J,AAID(J),SARRY1,SARRY2,JARRAY(J,4),JARRAY(J,3), -CCCCC$ JARRAY(J,5),JARRAY(J,6),JARRAY(J,7),CTAG(J),JARRAY(J,8), -CCCCC$ JARRAY(J,9),JARRAY(J,10) -CC ENDDO - PRINT 574 - 574 FORMAT(/' ----------------------------------') -C*********************************************************************** -C DETERMINE TRACK FOR EACH ASDAR/AMDAR/TAMDAR FLIGHT ID -C*********************************************************************** - PRINT 2521 - 2521 FORMAT(' ====> ASDAR/AMDAR/TAMDAR REPORTS CURRENTLY NOT TRACK ', - $ 'CHECKED'/) - PRINT 574 - NTRK = 0 - ITRK = NAIREP + 1 - 65 CONTINUE - IF(ITRK.LT.NFILE-NEXCLD) THEN - JTRK = ITRK + NTRK + 1 - IBEG = ITRK - IF(AAID(ITRK).EQ.AAID(JTRK)) THEN -C FLIGHT ID'S MATCH - RECORD STARTING POINT AS IBEG - NTRK = NTRK + 1 - GO TO 65 - ELSE -C END OF TRACK, STORE LAST INDEX - IEND = JTRK - 1 - ITRK = IEND + 1 - IF(NTRK.NE.0) NTRK = NTRK + 1 - LTRK = NTRK - END IF - IF(TRACE) PRINT 8810, ITRK,JTRK,NTRK,IBEG,IEND - 8810 FORMAT(' TRKEND- ITRK,JTRK,NTRK,IBEG,IEND ',5I5) -C TO GET REASONABLE GROUND SPEED CHECKS TAKE EVERY OTHER REPORT - DO LREP = 1,2 - LBEG = IBEG + (LREP - 1) - DO 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 - QCOS = COS((JARRAY(L,1)+JARRAY(L+2,1))*0.005*DG2RAD) - QDELT = IABS(JARRAY(L,4)-JARRAY(L+2,4)) * 0.01 - 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 UNITS FOR POSTION DIFFERENCE- DEGREES - DELPOS(K) = SQRT(DELLAT(K)**2 + (DELLON(K)*QCOS)**2) - RDELT = 999. - IF(QDELT.GT.0.0) RDELT = 1./QDELT -C UNITS FOR APPARENT AVERAGE SPEED- KNOTS - AVESPD(K) = DELPOS(K) * RDELT * 65.3 -C LPOS25=T INDICATES UNREASONABLE GROUND SPEED FOR ASDAR/AMDAR/TAMDAR -C OBS. - 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), - $ DELPOS(K),AVESPD(K) - 534 FORMAT(' $$$$$ POSSIBLE ASDAR/AMDAR/TAMDAR ERROR: ',A8,6I7,I5, - $ ' "',A14,'"/ ',F7.1,F9.1) - IF(LOGTRK.AND.LPOS25.AND.CTAG(L)(14:14).GT.'3') THEN -CVVVVV%%%%% - PRINT *,'~~~~~ SEE BELOW: EVENT 307 ' -CAAAAA%%%%% - - IF(EWRITE) PRINT 9008, L,AAID(L),REAL(JARRAY(L,1))*.01, - $ REAL(JARRAY(L,2))*.01,REAL(JARRAY(L,4)),CTAG(L) - 9008 FORMAT(/' #EVENT 307: TRKCHK; ASDR QM X-Z & BAD G.SPD, WND QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 - END IF - END IF - 221 CONTINUE - ENDDO - ENDDO -C---------------------------------------------------------------------- - QSUM = 0.0 - IQNUM = 0 - QSUM1 = 0.0 - JQNUM = 0 - DO L = IBEG,IEND -C CALCULATE AVERAGE VECTOR INCREMENT FOR TRACK (QSUM) AMONGST THOSE OBS. -C WITH A SCALED INCREMENT CHARACTER Q-Z - IF(CTAG(L)(5:5).GE.'Q'.AND.CTAG(L)(5:5).LE.'Z') THEN - CTG = CTAG(L)(5:5) - SCALE = 95.0 - DO I=1,9 - IF(CTG.EQ.CH1(I)) THEN - SCALE = ICH1(I) - EXIT - END IF - ENDDO - IQNUM = IQNUM + 1 - QSUM = QSUM + SCALE - IF(CTAG(L)(5:5).GE.'V') THEN -C CALCULATE AVERAGE VECTOR INCREMENT FOR TRACK (QSUM1) AMONGST THOSE -C OBS. WITH SCALED INCREMENT > 50 KNOTS - JQNUM = JQNUM + 1 - QSUM1 = QSUM1 + SCALE - END IF - END IF - ENDDO - IF(IQNUM.GT.14) THEN - QSUM = QSUM/IQNUM -CVVVVV%%%%% - PRINT 5678, IBEG,IEND,IQNUM,QSUM+SIGN(.0005,QSUM) - 5678 FORMAT(' ~~~~~ FOR ASDAR/AMDAR/TAMDAR TRK BEG AT',I6,' AND ', - $ 'ENDING AT',I6,' THERE ARE',I4,' RPTS W/ INCR., MEAN IS',F7.1) -CAAAAA%%%%% - IF(JQNUM.GT.9) THEN - QSUM1 = QSUM1/JQNUM -CVVVVV%%%%% - PRINT 5679, JQNUM,QSUM1 - 5679 FORMAT(' ~~~~~ $$ A L S O FOR THIS ASDAR/AMDAR/TAMDAR TRK, ', - $ 'THERE ARE',I4,' RPTS W/ INCR. > 50 KNOTS, MEAN INCR. IS',F7.1) -CAAAAA%%%%% -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) - PRINT 574 -CVVVVV%%%%% - PRINT *,'~~~~~ SEE BELOW: LARGE TRACK INCR. IN ASDAR', - $ 'AMDAR/TAMDAR' -CAAAAA%%%%% - PRINT 520 - 520 FORMAT(' --> FOLLOWING TRACK HAS > 14 REPORTS WITH > 9 HAVING ', - $ 'WIND INCR. > 50 KTS, ALL WINDS FLAGGED!!'/) - DO L = IBEG,IEND - IF(CTAG(L)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9027, L,AAID(L),REAL(JARRAY(L,1)) - $ *.01,REAL(JARRAY(L,2))*.01,REAL(JARRAY(L,4)),CTAG(L) - 9027 FORMAT(/' #EVENT 327: TRKCHK; ASDR TRK>14,>9 INCR>50KT,WND QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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,'"') - ENDDO - PRINT 574 - END IF - END IF -C---------------------------------------------------------------------- - NTRK = 0 - GO TO 65 - END IF - PRINT 574 -C*********************************************************************** -C DETERMINE TRACK FOR EACH NON-EXCLUDED AIREP/PIREP FLIGHT ID -C*********************************************************************** - PRINT 2520 - 2520 FORMAT(' ====> BEGIN TRACK CHECKING OF AIREP/PIREP REPORTS'/) - PRINT 574 - NTRK = 0 - ITRK = 1 - 66 CONTINUE - IF(ITRK.LT.NAIREP) THEN - JTRK = ITRK + NTRK + 1 - IBEG = ITRK - IF(AAID(ITRK).EQ.AAID(JTRK)) THEN -C FLIGHT ID'S MATCH - RECORD STARTING POINT AS IBEG - NTRK = NTRK + 1 - GO TO 66 - ELSE -C END OF TRACK, STORE LAST INDEX - 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 - IF(TRACE) PRINT 8810,ITRK,JTRK,NTRK,IBEG,IEND -C INITITIALIZE VARIABLES - LOGTRK = .FALSE. - LOGTME = .FALSE. - LOGLT1 = .FALSE. - LPOS25 = .FALSE. - DUP = .FALSE. - TOSLIM = 'S' - NAPTS = 0 - NPTRS = 0 - NTYPS = 0 - NTRKP = 0 - TYPE = ' ' -C----------------------------------------------------------------------- -C CHECK PAIRS -- LTRK = 2 -C----------------------------------------------------------------------- - IF(LTRK.EQ.2) THEN - II = IBEG - IF(AAID(II)(4:4).EQ.' '.OR.AAID(II)(1:4).EQ.'AIRC'.OR. - $ AAID(II)(1:5).EQ.'COA16'.OR.AAID(II)(1:7).EQ.'UNKNOWN')THEN -C CERTAIN RPTS (E.G, 3 CHAR ID,"AIRCFT", "UNKNOWN") ARE NOT CONSIDERED -C FOR THE TRACK CHECK - PRINT 8866, ITRK,LTRK,IBEG,IEND,AAID(II) - 8866 FORMAT(' SKIP IN TRKCHK ',4I5,2X,' ACID ',A8) - NTRK = 0 - GO TO 66 - END IF - 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 UNITS FOR APPARENT AVERAGE SPEED- KNOTS - LOGTRK = (DELPOS(1).GT.15.0.AND.AVESPD(1).GT.770.) -C CALIBRATION CONSTANTS <2.0 DEGREES FOR SEPARATION ADJACENT REPORTS -C CALIBRATION CONSTANTS >25.0 DEGREES FOR SEPARATION ADJACENT REPORTS - IF(DELPOS(1).LE.2.0) THEN - LOGLT1 = .TRUE. - ELSE IF(DELPOS(1).GE.25.) THEN - LPOS25 = .TRUE. - CALL WAYPT(IBEG,IEND,NCHNGD) - IF(NCHNGD.GT.0) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ WAYPT(1) ERROR FOR PAIR IN TRACK CHECK' -CAAAAA%%%%% - 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. - END IF - END IF - END IF -C TIMES MATCH -CCCCC PRINT 223, IBEG,IEND,DELPOS(1),AVESPD(1),LOGTRK -CC223 FORMAT(' NTRK=2 DBG',2(I5,1X),2(1X,F8.1),1X,L1) - 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 TYPE IS DUPLICATE, PLACE 'D' IN POSITION 1 OF TAG - KTYPS(1) = KTYPS(1) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - 52 FORMAT(/' THERE ARE MORE THAN',I5,' DUPLICATE TYPES IN THIS ', - $ 'TRACK -- MUST INCREASE SIZE OF PARAMETER NAME "ITRKL" - STOP ', - $ '29'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 1A ' - DUP = .TRUE. - CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN - IF(EWRITE) PRINT 9009, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9009 FORMAT(/' #EVENT ###: TRKCHK; NTRK=2 TYPE 1A DUP, WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(1:1) = 'D' - CTAG(IWHICH)(13:13) = '0' - CTAG(IWHICH)(14:14) = '0' - END IF - PRINT 673, IBEG,IEND,CTAG(IBEG),CTAG(IEND) - 673 FORMAT(' NTRK=2 TYPE 1A DUP',2(I5,1X),1X,'"',A14,'"/"',A14,'"') -C TYPE IS NOT A STRICT DUPLICATE, PLACE 'F' IN POSITION 4 OF Q.M. WORD - ELSE IF(LOGLAT.AND.LOGLON) THEN - KTYPS(5) = KTYPS(5) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 2A ' - DUP = .TRUE. - CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9010, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9010 FORMAT(/' #EVENT 308: TRKCHK; NTRK=2 TYPE 2A DUP, WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 1B ' - DUP = .TRUE. - CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN - IF(EWRITE) PRINT 9011, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9011 FORMAT(/' #EVENT ###: TRKCHK; NTRK=2 TYPE 1B DUP, WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(1:1) = 'D' - CTAG(IWHICH)(13:13) = '0' - CTAG(IWHICH)(14:14) = '0' - END IF - END IF -C CHECK FOR DELPOS AND LOGTRK - IF(LPOS25.AND.LOGWND.AND.LOGALT.AND.(LOGTMP.OR.LOGTME))THEN - CALL WAYPT(IBEG,IEND,NCHNGD) - IF(NCHNGD.GT.0) THEN -CVVVVV%%%%% - PRINT *,'~~~~~ WAYPT(2) ERROR FOR PAIR IN TRACK CHECK' -CAAAAA%%%%% - PRINT *, 'WAYPOINT(2) HAS CHANGED REPORT LOCATION' - KTYPS(6) = KTYPS(6) + 1 -CSKIP NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - 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. - CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(NEW) THEN - KTYPS(7) = KTYPS(7) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 3 ' - IF(IWHICH.GT.0) THEN - IF(CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9012, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9012 FORMAT(/' #EVENT 309: TRKCHK; NTRK=2 TYPE 3 , WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 - IF(EWRITE) PRINT 9012, MAYBE,AAID(MAYBE), - $ REAL(JARRAY(MAYBE,1))*.01,REAL(JARRAY(MAYBE,2))*.01, - $ REAL(JARRAY(MAYBE,4)),CTAG(MAYBE) - 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. - CALL CHOOSE(II,II+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(NEW) THEN - KTYPS(7) = KTYPS(7) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 3 ' - IF(IWHICH.GT.0) THEN - IF(CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9012, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 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 - IF(EWRITE) PRINT 9012, MAYBE,AAID(MAYBE), - $ REAL(JARRAY(MAYBE,1))*.01,REAL(JARRAY(MAYBE,2))*.01, - $ REAL(JARRAY(MAYBE,4)),CTAG(MAYBE) - 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 ELSE LOOK AT SEQUENCE FOR LTRK GT 2 -C----------------------------------------------------------------------- - ELSE IF(LTRK.GT.2) THEN - LUTCEQ = .FALSE. - LLATEQ = .FALSE. - LLONEQ = .FALSE. - LVAREQ = .FALSE. - LOGTRK = .FALSE. - NCHNGD = 0 -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 - DTKNT = 0 - DO L = IBEG,IEND-1 - IF(AAID(L)(4:4).EQ.' '.OR.AAID(L)(1:4).EQ.'AIRC'.OR. - $ AAID(L)(1:5).EQ.'COA16'.OR.AAID(L)(1:7).EQ.'UNKNOWN')THEN -C CERTAIN RPTS (E.G, 3 CHAR ID,"AIRCFT", "UNKNOWN") ARE NOT CONSIDERED -C FOR THE TRACK CHECK - 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 - QCOS = COS((JARRAY(L,1)+JARRAY(L+1,1))*0.005 *DG2RAD) - QDELT = IABS(JARRAY(L,4)-JARRAY(L+1,4))*0.01 -C ADJUSTABLE CONSTANT FOR TIME DIFF BETWEEN SUCCESSIVE REPORTS = 2.5 HRS - 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 UNITS FOR POSTION DIFFERENCE- DEGREES - DELPOS(K) = SQRT(DELLAT(K)**2 + (DELLON(K)*QCOS)**2) - RDELT = 999. - IF(QDELT.GT.0.0) RDELT = 1./QDELT -C UNITS FOR APPARENT AVERAGE SPEED- KNOTS - 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. - ENDDO - 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 POSSIBLE TWO OR MORE FLIGHTS IN AIR DURING SIX-HOUR TIME BLOCK - IF(DTKNT.GT.1.OR.NCHNGD.GT.0) THEN - IF(NCHNGD.GT.0) - $ PRINT *, 'WAYPOINT(3) HAS CHANGED REPORT LOCATION' -CVVVVV%%%%% - IF(NCHNGD.GT.0) - $ PRINT *,'~~~~~ WAYPT(3) ERROR FOR .GT. 2 IN TRACK CHECK' -CAAAAA%%%%% - PRINT 4442, ITRK,JTRK,IBEG,IEND,DTKNT,NCHNGD - 4442 FORMAT(' ITRK',I5,' JTRK ',I5,' IBEG,IEND ',2I6, - $ ' DTKNT ',I3,' NCHNGD ',I2) - DO I = 1,LTRK - K = IBEG + I - 1 - IARRAY(I) = KARRAY(K,4) -CCCCC PRINT 387, LTRK,I,K,SAAID(K),IARRAY(I) -CC387 FORMAT(' DBG ',3I6,2X,'; ID=',A8,'; TIME=',I8) - ENDDO - IF(LTRK.GT.0) CALL INDEXF(LTRK,IARRAY,INDR) - DO J = 1,LTRK - K = IBEG - 1 + J - L = IBEG - 1 + INDR(J) - AAID(K) = SAAID(L) - CTAG(K) = STAG(L) - JARRAY(K,:) = KARRAY(L,:) -CCCCC PRINT 388, J,K,L,AAID(K),JARRAY(K,4) -CC388 FORMAT(' DBG J K L ',3I6,2X,'; ID=',A8,'; TIME=',I8) - ENDDO - DTKNT = 0 - DO L = IBEG,IEND-1 - K = L - IBEG + 1 - DELPOS(K) = 0.0 - DELLAT(K) = 0.0 - DELLON(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 -C ADJUSTABLE CONSTANT FOR TIME DIFF BETWEEN SUCCESSIVE REPORTS = 2.5 HRS - 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 UNITS FOR POSTION DIFFERENCE- DEGREES - DELPOS(K) = SQRT(DELLAT(K)**2 + (DELLON(K)*QCOS)**2) - RDELT = 999. - IF(QDELT.GT.0.0) RDELT = 1./QDELT -C UNITS FOR APPARENT AVERAGE SPEED- KNOTS - AVESPD(K) = DELPOS(K) * RDELT * 65.3 - IF(DELLON(K).GT.15..AND.AVESPD(K).GT.770.)LOGTRK=.TRUE. - ENDDO - DELPOS(LTRK) = -9999.9 - AVESPD(LTRK) = -9999.9 - END IF - TYPE = ' ' - JPTNAD = 0 - IPTNAD = 0 - IPTTRK = 0 -C FIND POINTERS FOR NON-ADJACENT REPORTS - IF(TRACE) PRINT 8888,LTRK,IBEG,IEND - 8888 FORMAT(' TRACE AT 211 ',3(1X,I6)) - DO L = IBEG,IEND-2 ! Formerly DO LOOP 211 - DO 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 - LVAREQ = .TRUE. - NPTRS = NPTRS + 1 - IF(NPTRS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE POINTERS FOR NON-ADJACENT REPORTS IN THIS -C TRACK THAN THE LIMIT "ITRKL" -- STOP 28 - PRINT 51, ITRKL - 51 FORMAT(/' THERE ARE MORE THAN',I5,' POINTERS FOR NON-ADJACENT ', - $ 'REPORTS IN THIS TRACK -- MUST INCREASE SIZE OF PARAMETER NAME ', - $ '"ITRKL" - STOP 28'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(28) -C....................................................................... - END IF - 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 - ENDDO - ENDDO - IF(NPTRS.EQ.1) THEN - I1 = IPTNAD(1) - I2 = JPTNAD(1) - DUP = .TRUE. - CALL CHOOSE(I1,I2,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN - IF(EWRITE) PRINT 9013, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9013 FORMAT(/' #EVENT ###: TRKCHK; NTRK>2 TYPE 1D DUP, WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(1:1) = 'D' - CTAG(IWHICH)(13:13) = '0' - CTAG(IWHICH)(14:14) = '0' - END IF - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - 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)) - IPTADJ = 0 - NPRNT = 0 -C BIG LOOP TO FIND BADDIES - IF(TRACE) PRINT 8890, LTRK,IBEG,IEND - 8890 FORMAT(' TRACE AT 216 ',3(1X,I6)) - DO L = IBEG,IEND-1 ! Formerly DO LOOP 216 - K = L - IBEG + 1 - LOGTRK = .FALSE. - TOSLIM = 'S' -C THIS IS A LIST OF NON-UNIQUE IDS - 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 ADJUSTABLE CONSTANTS FOR AIRCRAFT GROUND SPEED LIMITS - IF(AVESPD(K).GT.770.0.OR.AVESPD(K).LT.200.0) THEN - NAPTS = NAPTS + 1 - IF(NAPTS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE REPORTS WITH ADJUSTABLE CONSTANTS FOR -C AIRCRAFT GROUND SPEED LIMITS IN THIS TRACK THAN THE LIMIT "ITRKL" -- -C STOP 27 - PRINT 50, ITRKL - 50 FORMAT(/' THERE ARE MORE THAN',I5,' REPORTS WITH ADJUSTABLE ', - $ 'CONSTANTS FOR AIRCRAFT GROUND SPEED LIMITS IN THIS TRACK -- ', - $ 'MUST INCREASE SIZE OF PARAMETER NAME "ITRKL" - STOP 27'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(27) -C....................................................................... - END IF - 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 - IF(NAPTS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE REPORTS WITH ADJUSTABLE CONSTANTS FOR -C AIRCRAFT GROUND SPEED LIMITS IN THIS TRACK THAN THE LIMIT "ITRKL" -- -C STOP 27 - PRINT 50, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(27) -C....................................................................... - END IF - IPTADJ(NAPTS) = L - LOGTRK = .TRUE. - END IF - END IF -C START DECISION MAKING -C TUNING HERE- CHECK INCREMENT .GE. 'T' AS BAD - IF(LOGLT1.AND.LOGWND.AND.LOGEQ.GE.2) THEN -C CLASS 1 (SIMPLE) DUPLICATE, PLACE 'D' IN POSITION 1 OF TAG - DUP = .TRUE. - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN - IF(EWRITE) PRINT 9014, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9014 FORMAT(/' #EVENT ###: TRKCHK; NTRK>2 TYPE 1A DUP, WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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) - KTYPS(1) = KTYPS(1) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 1A ' - END IF - ELSE IF(LOGWND.AND.LOGALT.AND.LOGTMP.AND.LOGTME) THEN -C COME HERE IF NOT A STRICT DUPLICATE -- POSSIBLE POSITION ERROR - CTAG(L)(3:3) = 'E' - CTAG(L+1)(3:3) = 'E' - DUP = .TRUE. - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0') THEN - IF(EWRITE) PRINT 9015, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9015 FORMAT(/' #EVENT ###: TRKCHK; NTRK>2 TYPE 1B DUP, WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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) - KTYPS(2) = KTYPS(2) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 1B ' - END IF - ELSE IF(LOGTME.AND..NOT.LOGLT1.AND..NOT.LOGWND.AND. - $ .NOT.LOGTRK) THEN - DUP = .FALSE. - TOSLIM = 'V' - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(NTYPS+1.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - IF(IWHICH.GT.0) THEN - IF(CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9016, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9016 FORMAT(/' #EVENT 310: TRKCHK; NTRK>2 TYPE 3 , WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 310 - END IF - KTYPS(7) = KTYPS(7) + 1 - NTYPS = NTYPS + 1 - TYPE(NTYPS) = 'TYPE 3 ' - ELSE - KTYPS(9) = KTYPS(9) + 1 - NTYPS = NTYPS + 1 - TYPE(NTYPS) = 'TIME TAG' - END IF - 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. - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9017, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9017 FORMAT(/' #EVENT 311: TRKCHK; NTRK>2 TYPE 2B DUP, WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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) - KTYPS(6) = KTYPS(6) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - 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. - CALL CHOOSE(L,L+1,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9017, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 311 - END IF - IF(NEW) THEN - PRINT 723, IWHICH,MAYBE - KTYPS(6) = KTYPS(6) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 2B ' - END IF - ELSE IF(LOGLAT.AND.LOGLON.AND..NOT.LOGGT3) THEN - DUP = .TRUE. - 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 - IF(EWRITE) PRINT 9018, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9018 FORMAT(/' #EVENT 312: TRKCHK; NTRK>2 TYPE 2A DUP, WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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) - KTYPS(5) = KTYPS(5) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - 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 - 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 - IF(EWRITE) PRINT 9016, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 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 - IF(EWRITE) PRINT 9016, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - CTAG(IWHICH)(4:4) = 'F' - CTAG(IWHICH)(14:14) = '3' - JARRAY(IWHICH,12) = 310 - END IF - ELSE IF(NEW) THEN -CVVVVVASK PAUL -C ASK PAUL: PAUL CLAIMS THIS SHOULD BE 'F' NOT 'D' (LIKE ABOVE) -C DOUBLE CHECK WITH HIM: NOTE PREV. IF-THEN SETS WIND TO 'F' IF -C NEW AND TOSLIM = R (HERE NEW AND TOSSLIM .NE. R) -CAAAAAASK PAUL - PRINT 725, IWHICH,MAYBE - IF(MAYBE.GT.0) CTAG(MAYBE)(3:3) = 'E' - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'0')THEN - IF(EWRITE) PRINT 9019, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9019 FORMAT(/' #EVENT ###: TRKCHK; NTRK>2 TYPE 3 , WND QM SET "D"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 - KTYPS(7) = KTYPS(7) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 3 ' - END IF - ELSE - KTYPS(9) = KTYPS(9) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - 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 - ENDDO -C CHECK IF LAST REPORT IS BAD - 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 - IF(EWRITE) PRINT 9020, IEND,AAID(IEND),REAL(JARRAY(IEND,1))*.01, - $ REAL(JARRAY(IEND,2))*.01,REAL(JARRAY(IEND,4)),CTAG(IEND) - 9020 FORMAT(/' #EVENT 313: TRKCHK; NTRK>2 LAST IS BAD, WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - CTAG(IEND)(4:4) = 'F' - CTAG(IEND)(14:14) = '3' - JARRAY(IEND,12) = 313 - END IF - QSUM = 0.0 - IQNUM = 0 -C LOOP SETS POINTERS IF POSITION DIFFERENCES ARE TOO LARGE - DO L = IBEG,IEND - K = L - IBEG + 1 - IF(DELPOS(K).GT.25.0) THEN - IF(NTRKP+1.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE REPORTS IN THIS TRACK WITH LARGE POSTION -C ERRORS THAN THE LIMIT "ITRKL" -- STOP 30 - PRINT 53, ITRKL - 53 FORMAT(/' THERE ARE MORE THAN',I5,' REPORTS IN THIS TRACK WITH ', - $ 'LARGE POSITION ERRORS -- MUST INCREASE SIZE OF PARAMETER NAME ', - $ '"ITRKL" - STOP 30'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(30) -C....................................................................... - END IF - IF(L.LT.IEND) THEN - NTRKP = NTRKP + 1 - IPTTRK(NTRKP) = L - NTRKP = NTRKP + 1 - IF(NTRKP.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE REPORTS IN THIS TRACK WITH LARGE POSTION -C ERRORS THAN THE LIMIT "ITRKL" -- STOP 30 - PRINT 53, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(30) -C....................................................................... - END IF - IPTTRK(NTRKP) = L + 1 - ELSE - NTRKP = NTRKP + 1 - IPTTRK(NTRKP) = L - END IF - END IF -C CALCULATE AVERAGE VECTOR INCREMENT FOR TRACK (QSUM) AMONGST THOSE OBS. -C WITH A SCALED INCREMENT CHARACTER Q-Z - IF(CTAG(L)(5:5).GE.'Q'.AND.CTAG(L)(5:5).LE.'Z') THEN - CTG = CTAG(L)(5:5) - SCALE = 95.0 - DO I=1,9 - IF(CTG.EQ.CH1(I)) THEN - SCALE = ICH1(I) - EXIT - END IF - ENDDO - IQNUM = IQNUM + 1 - QSUM = QSUM + SCALE - END IF - ENDDO - IF(IQNUM.NE.0) THEN - QSUM = QSUM/IQNUM - ELSE - QSUM = 0.0 - END IF -C CHECK IF NTRKP INDICATES INTERIOR BAD - DO KK = 1,NTRKP-1 - DO JJ = KK+1,NTRKP - IF(IPTTRK(KK).EQ.IPTTRK(JJ)) THEN - I1 = IPTTRK(KK) - I2 = IPTTRK(JJ) - DUP = .TRUE. - CALL CHOOSE(I1,I2,TOSLIM,DUP,IWHICH,MAYBE,NEW) - IF(IWHICH.GT.0.AND.CTAG(IWHICH)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 9021, IWHICH,AAID(IWHICH), - $ REAL(JARRAY(IWHICH,1))*.01,REAL(JARRAY(IWHICH,2))*.01, - $ REAL(JARRAY(IWHICH,4)),CTAG(IWHICH) - 9021 FORMAT(/' #EVENT 314: TRKCHK; NTRK>2 TYPE 3 DUP , WND QM SET "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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) - KTYPS(7) = KTYPS(7) + 1 - NTYPS = NTYPS + 1 - IF(NTYPS.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE DUPLICATE TYPES IN THIS TRACK THAN THE -C LIMIT "ITRKL" -- STOP 29 - PRINT 52, ITRKL - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(29) -C....................................................................... - END IF - TYPE(NTYPS) = 'TYPE 3 ' - END IF - ENDDO - ENDDO - 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 KK = 1,LTRK - IF(KK.GT.ITRKL) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE REPORTS IN THE POINTER SUMMARY FOR THIS -C TRACK THAN THE LIMIT "ITRKL" -- STOP 26 - PRINT 49, ITRKL - 49 FORMAT(/' THERE ARE MORE THAN',I5,' REPORTS IN THE POINTER ', - $ 'SUMMARY FOR THIS TRACK -- MUST INCREASE SIZE OF PARAMETER NAME', - $ ' "ITRKL" - STOP 26'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(26) -C....................................................................... - END IF - PRINT 482,KK,IPTADJ(KK), IPTTRK(KK), IPTNAD(KK),JPTNAD(KK) - 482 FORMAT(' ',15X,I3,3X,4(I4,2X)) - ENDDO - PRINT 8891, LTRK,IBEG,IEND - 8891 FORMAT(' TRACE AT 215 ',3(1X,I6)) - END IF - DO 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), - $ DELPOS(K),AVESPD(K) - 334 FORMAT(' K=',I3,' L=',I5,2X,A8,6I7,I5,' "',A14,'"/ ', - $ F7.1,F13.1) - ENDDO - 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)) -CCCCC PRINT 5012, KTYPS -C5012 FORMAT(//,' #TYPE1A ',I2,' #TYPE1B ',I2,' #TYPE?? ',I2, -CCCCC$ ' #TYPE1D ',I2,' #TYPE2A ',I2,' #TYPE2B ',I2,' #TYPE3 ',I2, -CCCCC$ ' ',I2,'TIME TAGS',I2) - 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 GO BACK TO 66 TO START NEXT TRACK - GO TO 66 -C********************************************************************** - END IF - PRINT 574 -C RESORT FOR STACK DETERMINATION: -C 1ST ORDER - LATITUDE (SOUTH TO NORTH) -C 2ND ORDER - LONGITUDE (WEST, INCREASING) -C 3RD ORDER - TIME (INCREASING) -C 4TH ORDER - ALITITUDE (INCREASING) (THIS WAS ADDED 8/23/1999) -C SORT BY CONCATENATING THESE QUANITIIES INTO CHARACTER ARRAY -C (DO NOT INCLUDE ASDARS/AMDARS/TAMDARS AND EXCLUDED REPORTS IN THIS -C SORT) - DO 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) - WRITE(CARRAY(J)(15:20),'(I6.6)') JARRAY(J,3) - CARRAY(J)(21:32) = '000000000000' -CCCCC PRINT 788, J,AAID(J),CARRAY(J) -CC788 FORMAT(' DBG J ',I6,2X,'; ID=',A8,'; CARRAY=',A32) - ENDDO -C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE - IF(NAIREP.GT.0) CALL INDEXC(NAIREP,CARRAY,INDR) -C WRITE SORTED REPORTS INTO SAAID, KARRAY, AND STAG ARRAYS (REMAINING -C ASDAR/AMDAR/TAMDAR AND EXCLUDED REPORTS ALREADY IN THESE ARRAYS IN -C PROPER POSITION FROM STORE MADE AT BEGINNING OF SUBROUTINE) - DO I = 1,NAIREP - J = INDR(I) - SAAID(I) = AAID(J) - STAG(I) = CTAG(J) - KARRAY(I,:) = JARRAY(J,:) - ENDDO -CCCCC PRINT 562 -CC562 FORMAT(' LAT/LON ACID ',6X,' LAT LON ',4X,'UTC ALT ', -CCCCC$' TEMP WDIR WSPD ') -CCCCC DO J = 1,KOUNT -CCCCC KARRY1 = MIN0(KARRAY(J,1),99999) -CCCCC KARRY2 = MIN0(KARRAY(J,2),99999) -CCCCC PRINT 711, J,SAAID(J),KARRY1,KARRY2,KARRAY(J,4),KARRAY(J,3), -CCCCC$ KARRAY(J,5),KARRAY(J,6),KARRAY(J,7),STAG(J) -CC711 FORMAT(' ',I5,2X,A8,7I8,1X,'"',A14,'"') -CCCCC ENDDO -C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS AND ELIMINATE DUPS - IF(IWRITE) PRINT 557 - 557 FORMAT(/' FINAL LISTING OF SORTED DATA LEAVING TRKCHK----'/9X, - $ 'ACID',8X,'LAT WLON UTC ALT TEMP WDIR WSPD -----', - $ 'TAGS----- ITYPE RPTIME KNTINI GALT GTEMP GDIR GSPD'/) - M = 0 - DO 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,1X,2F8.2,I6,I7,3I6,3X,'"',A14,'"',I6,2I8, - $ I7,3I6) - 219 CONTINUE - ENDDO - NFILE = M - PRINT 681, NFILE - 681 FORMAT(1X,128('*')/47X,'OUT OF TRACK CHECK - NFILE =',I7/128('*')) - RETURN -C....................................................................... - 9999 CONTINUE -C FATAL ERROR: THERE ARE MORE RPTS IN TRACK THAN "ITMX" -- STOP 24 - PRINT 953, ITMX - 953 FORMAT(/' THERE ARE MORE THAN',I5,' REPORTS IN A SINGLE TRACK ', - $ '-- MUST INCREASE SIZE OF PARAMETER NAME "ITMX" - STOP 24'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(24) -C....................................................................... - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: WAYPT CORRECTS WAYPOINT LOCATIONS FOR ACFT RPTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-11-08 -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 1993-01-05 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-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 1995-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 1995-11-08 D. A. KEYSER -- INCREASED THE SIZE OF PARAMETER "LSIZE" -C FROM 26 TO 50 -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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE WAYPT(IBEG,IEND,NCHNGD) - PARAMETER (IRMX= 80000) - PARAMETER (ISIZE= 16) -C PARAMETER NAME "LSIZE" IN THIS SUBROUTINE REFERS TO THE MAXIMUM -C NUMBER OF LATITUDES AND LONGITUDES IN THE WAYPOINT CORRECTION FILE - PARAMETER (LSIZE= 50) - PARAMETER (LSIZ23= LSIZE-23) - LOGICAL WAYPIN,EWRITE - CHARACTER*80 BUFF1 - CHARACTER*8 AAID(IRMX) - CHARACTER*14 CTAG(IRMX),STAG(IRMX) - INTEGER OLDLAT(LSIZE),NEWLAT(LSIZE),OLDLON(LSIZE),NEWLON(LSIZE) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),RCPTST - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - SAVE - 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/ - NCHNGD = 0 - IF(ITKNT.EQ.0) THEN - IF(WAYPIN) THEN -C FIRST TIME IN, READ WAYPOINTS FROM EXTERNAL FILE IF WAYPIN=TRUE - 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" -- STOP 25 - PRINT 53, LSIZE,INUM - 53 FORMAT(/' THERE ARE MORE THAN THE',I5,' EXPECTED LAT/LON ', - $ 'CORRECTIONS IN THE WAYPOINT FILE'/5X,'-- MUST INCREASE SIZE OF', - $ ' PARAMETER NAME "LSIZE" TO AT LEAST',I5,' - STOP 25'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(25) -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 - DO L = IBEG,IEND - DO 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 SET TAG POSITION 9 TO 'C' TO INDICATE WAYPOINT CORRECTION - CTAG(L)(9:9) = 'C' -C UPDATE KARRAY AS WELL - WAYPOINT(3) SORTS BY TIME (SEE SUBR. TRKCHK) - KARRAY(L,1) = NEWLAT(J) - KARRAY(L,2) = NEWLON(J) -C UPDATE STAG AS WELL - WAYPOINT(3) SORTS BY TIME (SEE SUBR. TRKCHK) - STAG(L)(1:1) = '-' -C SET TAG POSITION 9 TO 'C' TO INDICATE WAYPOINT CORRECTION - STAG(L)(9:9) = 'C' -CVVVVV%%%%% - PRINT *,'~~~~~ WAYPT CORRECTION MADE (PRINT IN WAYPT)' -CAAAAA%%%%% - IF(EWRITE) PRINT 9002, L,AAID(L),REAL(JARRAY(L,1))*.01, - $ REAL(JARRAY(L,2))*.01,REAL(JARRAY(L,4)),CTAG(L) - 9002 FORMAT(/' #EVENT ###: WAYPT; WAYPT ERROR, LAT/LON CHANGED.......', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - PRINT 1000, IBEG,IEND,JARRAY(L,1),JARRAY(L,2) - 1000 FORMAT(' WAYPT ERR ',2(I5,1X),' NEW POS ',2I6) - END IF - ENDDO - ENDDO - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: CHOOSE CHOOSES WORST/DUPL. BETWEEN PAIR OF RPTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1994-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 1993-01-05 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1994-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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE CHOOSE(I,J,TOSLIM,DUP,IWHICH,MAYBE,NEW) - PARAMETER (IRMX= 80000) - PARAMETER (ISIZE= 16) - CHARACTER*1 TOSLIM - CHARACTER*8 AAID(IRMX) - CHARACTER*14 CTAG(IRMX),STAG(IRMX) - LOGICAL LIGS,LIGX,LJGS,LJGX,LIGJ,LJGI,DUP,NEW - COMMON/XXXXX/AAID,JARRAY(IRMX,ISIZE),CTAG,KARRAY(IRMX,ISIZE),STAG - NEW = .FALSE. - IWHICH = 0 - MAYBE = 0 -C IF DUPL. AND 2ND INCREMENT NOT CHECKED, SET 2ND INCREMENT TO THAT OF 1 - 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 - 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 - 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 - NEW = .TRUE. - 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 IF BOTH HAVE Q.M. OF 'Q' OR 'R' THEN RETAIN THEM BOTH - RETURN - END IF -C LIGJ = T IF 1ST WORSE THAN OR SAME AS 2ND; =F IF 1ST BETTER THAN 2ND - LIGJ = (CTAG(I)(5:5).GE.CTAG(J)(5:5)) -C LIGS = T IF 1ST BETWEEN S AND Z - LIGS = (CTAG(I)(5:5).GE.'S'.AND.CTAG(I)(5:5).LE.'Z') -C LIGX = T IF 1ST WORSE THAN OR SAME AS 'TOSLIM' - LIGX = (CTAG(I)(5:5).GE.TOSLIM.AND.CTAG(I)(5:5).LE.'Z') -C LJGS = T IF 2ND BETWEEN S AND Z - LJGS = (CTAG(J)(5:5).GE.'S'.AND.CTAG(J)(5:5).LE.'Z') -C LJGX = T IF 2ND WORSE THAN OR SAME AS 'TOSLIM' - LJGX = (CTAG(J)(5:5).GE.TOSLIM.AND.CTAG(J)(5:5).LE.'Z') - IF(LIGX.AND..NOT.LJGX) THEN -C 1ST WORSE THAN/SAME AS 'TOSLIM' & 2ND BETTER THAN 'TOSLIM': CHOOSE 1ST - IWHICH = I - ELSE IF(LJGX.AND..NOT.LIGX) THEN -C 2ND WORSE THAN/SAME AS 'TOSLIM' & 1ST BETTER THAN 'TOSLIM': CHOOSE 2ND - IWHICH = J - ELSE IF(LIGX.AND.LJGX) THEN -C BOTH WORSE THAN/SAME AS 'TOSLIM' .. CHECK CARSWELL-TINKER INDICATOR - IF(CTAG(I)(7:7).EQ.'C'.AND.CTAG(J)(7:7).NE.'C') THEN -C ...1ST IS CARSWELL-TINKER, CHOOSE 1ST - IWHICH = I - ELSE IF(CTAG(J)(7:7).EQ.'C'.AND.CTAG(I)(7:7).NE.'C') THEN -C ...2ND IS CARSWELL-TINKER, CHOOSE 2ND - IWHICH = J - ELSE IF(LIGJ) THEN -C ...BOTH EITHER ARE OR AREN'T CARSWELL-TINKER, CHOOSE 1ST IF WORSE -C THAN 2ND - IWHICH = I - ELSE -C ...BOTH EITHER ARE OR AREN'T CARSWELL-TINKER, CHOOSE 2ND IF WORSE -C THAN 1ST - IWHICH = J - END IF - ELSE IF(LIGS.AND..NOT.LJGS.AND.CTAG(J)(5:5).NE.'N') THEN -C 1ST BETWEEN S AND Z & 2ND IS Q OR R, CHOOSE 1ST MAYBE - MAYBE = I - ELSE IF(LJGS.AND..NOT.LIGS.AND.CTAG(I)(5:5).NE.'N') THEN -C 2ND BETWEEN S AND Z & 1ST IS Q OR R, CHOOSE 2ND MAYBE - MAYBE = J - ELSE IF(LIGS.AND.LJGS) THEN -C BOTH BETWEEN S AND Z .. CHECK CARSWELL-TINKER INDICATOR - IF(CTAG(I)(7:7).EQ.'C'.AND.CTAG(J)(7:7).NE.'C') THEN -C ...1ST IS CARSWELL-TINKER, CHOOSE 1ST MAYBE - MAYBE = I - ELSE IF(CTAG(J)(7:7).EQ.'C'.AND.CTAG(I)(7:7).NE.'C') THEN -C ...2ND IS CARSWELL-TINKER, CHOOSE 2ND MAYBE - MAYBE = J - ELSE IF(LIGJ) THEN -C ...BOTH EITHER ARE/AREN'T CARSWELL-TINKER, CHOOSE 1ST MAYBE IF WORSE -C THAN 2ND - MAYBE = I - ELSE -C ...BOTH EITHER ARE/AREN'T CARSWELL-TINKER, CHOOSE 2ND MAYBE IF WORSE -C THAN 1ST - 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 - NEW =.TRUE. -C LIGJ = T IF 1ST WORSE THAN 2ND; =F IF 1ST BETTER THAN OR SAME AS 2ND - LIGJ = (CTAG(I)(5:5).GT.CTAG(J)(5:5)) -C LJGI = T IF 2ND WORSE THAN 1ST; =F IF 2ND BETTER THAN OR SAME AS 1ST - LJGI = (CTAG(J)(5:5).GT.CTAG(I)(5:5)) - IF(CTAG(I)(5:5).EQ.CTAG(J)(5:5)) THEN -C BOTH HAVE SAME QUALITY .. CHECK CARSWELL-TINKER INDICATOR - IF(CTAG(J)(7:7).EQ.'C'.AND.CTAG(I)(7:7).NE.'C') THEN -C ...2ND IS CARSWELL-TINKER, CHOOSE 2ND - IWHICH = J - ELSE IF(CTAG(I)(7:7).EQ.'C'.AND.CTAG(J)(7:7).NE.'C') THEN -C ...1ST IS CARSWELL-TINKER, CHOOSE 1ST - IWHICH = I - ELSE -C ...BOTH EITHER ARE OR AREN'T CARSWELL-TINKER, CHOOSE 1ST - IWHICH = I - END IF - ELSE IF(LIGJ) THEN -C 1ST IS WORSE THAN 2ND, CHOOSE 1ST - IWHICH = I - ELSE IF(LJGI) THEN -C 2ND IS WORSE THAN 1ST, CHOOSE 2ND - 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: NP22 DATE: 1994-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 1989-04-01 P. JULIAN -- ORIGINAL AUTHOR -C 1993-01-05 P. JULIAN -- CHANGES TO UTILIZE SCALED OBS INCREMENTS -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE SHEAR(NUM,INDX) - PARAMETER (IRMX= 80000, ISMX= 8000) -C PRINT LOGICALS- PRNTA:PRINT ALL; PRNTT:PRINT TITLE; PRNTL: PRINT LINE - LOGICAL PRNTA,PRNTT,PRNTL - CHARACTER*1 CTG,CH1(9) - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER COUNT(ISMX),LOUNT(ISMX),CHKSUM(ISMX),KPOINT(ISMX), - $ GOUNT(ISMX),IARRAY(ISMX),INDR(ISMX),ICH1(9) - REAL TABLE(7,7),VPOINT(ISMX) - COMMON/CMPNTS/U(ISMX),V(ISMX),UF(ISMX),VF(ISMX) - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - 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 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/ - DATA CH1 /'Q','R','S','T','U','V','W','X','Y'/ - DATA ICH1 /10, 20, 30, 40, 50, 60, 70, 80, 90 / -C CALL STATS TO OBTAIN AVG. SPEED & VECTOR DIFFERENCE - CALL STATS(KNO,INDX,NUM,SBAR,VPOINT) - LOOP = 0 -C CALIBX IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK -CCCCC CALIBX = 0.30 SLIGHTLY MORE PERMISSIVE IS - CALIBX = 0.45 -C GOUNT IS INTEGER WEIGHTING FROM SCALED OBSERVED VECTOR INCREMENT - DO 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 SCALE IS BASED ON VALUE OF SCALED INCREMENT CHARACTER Q-Z - IF(TAG(KNDX)(5:5).GE.'Q'.AND.TAG(KNDX)(5:5).LE.'Z') THEN - CTG = TAG(KNDX)(5:5) - SCALE = 100.0 - DO I=1,9 - IF(CTG.EQ.CH1(I)) THEN - SCALE = ICH1(I) - EXIT - END IF - ENDDO - END IF -C NOTE: GOUNT WILL BE -1 FOR OBS. W/O SCALED VECTOR INCREMENT VALUE - GOUNT(K) = NINT((SCALE - 30) * 0.2) -C IF SUSPECTED TRACK CHECK ERROR ADD 2 TO GOUNT - IF(TAG(KNDX)(3:3).EQ.'E') GOUNT(K) = GOUNT(K) + 2 - 45 CONTINUE - ENDDO -C START OF ITERATION CHECKING AND TOSSING - 1010 CONTINUE - LOOP = LOOP + 1 -C COUNT IS INTEGER SUM OF QUALITY UNITS FOR OFF-LEVEL(SHEAR) CHECKS -C LOUNT IS SAME BUT FOR ON-LEVEL CHECKS - IARRAY(1:NUM) = NINT(VPOINT(1:NUM)*100.) - COUNT(1:NUM) = 0 - LOUNT(1:NUM) = 0 - CHKSUM(1:NUM) = -99 - DO K = 1,NUM - IF(KBAD(K).LE.0) GOUNT(K) = 0 - ENDDO -C EACH ITERATION MUST RESORT VECTOR DIFFERENCE AMONGST "GOOD" -C OBS. IN STACK - IF(NUM.GT.0) CALL INDEXF(NUM,IARRAY,KPOINT) - DIFF = 0.0 - IMAXK = 0 - IMAXJ = 0 - PRNTT =.TRUE. - PRNTA =.FALSE. - DO 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 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 ON-LEVEL CHECK -C CALIBX=0.45 IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK - CHEK = 9.0 + (TIMDIF * SBAR * CALIBX) - IF((QUAN-CHEK).GT.DIFF) THEN - DIFF = QUAN - CHEK -C IMAXJ AND IMAXK ARE THE TWO LEVELS EXCEEDING THE LIMITS - 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 OFF-LEVEL CHECK - IF(IALT.GT.5) GO TO 2 - CHEK = TABLE(IALT,ITIM) + (SBAR * 0.14) - IF((QUAN-CHEK).GT.DIFF) THEN - DIFF = QUAN - CHEK -C IMAXJ AND IMAXK ARE THE TWO LEVELS EXCEEDING THE LIMITS - 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+SIGN(.0005,CHEK) - 401 FORMAT(' ',2I4,3X,F8.0,F8.2,2X,F7.1,2X,F7.1) - 2 CONTINUE - ENDDO - END IF - ENDDO - 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 HOW MANY OBS. DO WE ACTUALLY HAVE TO EVALUATE (NUMT) ? -C (THERE MUST BE AT LEAST TWO) - NUMT = 0 - DO I = 1,NUM - IF(CHKSUM(I).GT.-99) NUMT = NUMT + 1 - ENDDO - ICHK1 = INDR(NUM) - ICHK2 = INDR(NUM-1) -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*********************************************************************** - IF(NUMT.GT.3) THEN -C----------------------------------------------------------------------- -C FOUR OR MORE OBSERVATIONS IN THE STACK CAN BE EVALUATED - 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 CALCULATE TOLERANCE LEVEL FOR CHECKING BADS- FUNCTION OF AVG. SPEED - DLIM = 2.5 - IF(SBAR.GT.70.) DLIM = DLIM + ((SBAR - 70.) * 0.02857) -C START LOGIC TREE CHECK - 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 -CVVVVV%%%%% - PRINT *,'~~~~~ DIFF .GT. 2.5 AMD ICDIF1.EQ.0' -CAAAAA%%%%% - 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 -CVVVVV%%%%% - PRINT *,'~~~~~ TOSSKEY=2 FOUND!!' -CAAAAA%%%%% - 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 -CVVVVV%%%%% - PRINT *,'~~~~~ TOSSKEY=3 FOUND!!' -CAAAAA%%%%% - 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 - 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: NP22 DATE: 1994-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 1993-01-05 P. JULIAN -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE LAPSE(NUM,INDX) - PARAMETER (IRMX= 80000, ISMX= 8000) - LOGICAL PRNTT - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER COUNT(ISMX),LOUNT(ISMX),CHKSUM(ISMX),INDR(ISMX) - REAL TABLE(7,7) - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - 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 LAPSE RATE CHECK (TABLE(IALT,ITIM),ITIM=1,6)/ DEG.C/KM / - 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 CALIBX IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK - CALIBX = 0.70 -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 - COUNT(1:NUM) = 0 - LOUNT(1:NUM) = 0 - CHKSUM(1:NUM) = -99 - DIFF = 0.0 - PRNTT = .TRUE. - DO 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 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 ON-LEVEL CHECK - QUAN = ABS(STMP(K)-STMP(J)) * 0.1 -C CALIBX=0.70 IS ADJUSTABLE CONSTANT FOR ON-LEVEL DIFFERENCE CHECK - 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 OFF-LEVEL CHECK - 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 LAPSE CHECK - 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 INVERSION CHECK - 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 - ENDDO - END IF - 1 CONTINUE - ENDDO - 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 I = 1,NUM - IF(CHKSUM(I).GT.-99) NUMT = NUMT + 1 - ENDDO - ICHK1 = INDR(NUM) - ICHK2 = INDR(NUM-1) - ICHK3 = INDR(NUM-2) - ICDIF2 = CHKSUM(ICHK2) - CHKSUM(ICHK3) - ICHK4 = 0 -C********************************************************************** -C LOGIC TREE FOR DECIDING WHATS WRONG - NO ITERATION HERE (ONCE ONLY) -C********************************************************************** - IF(NUMT.GT.3) THEN -C---------------------------------------------------------------------- -C FOUR OR MORE OBSERVATIONS IN THE STACK CAN BE EVALUATED - 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 - 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: NP22 DATE: 1995-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 1989-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1990-06-14 D. A. KEYSER -- CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES -C FOR STACKED OBS.; FIXED ERROR IN Q. MARK DESIGNATOR -C 1990-07-03 D. A. KEYSER -- SOME OMIT Q.M. INCORRECTLY CHANGED BACK -C TO 'N' OR 'C', FIXED -C 1993-01-05 P. JULIAN -- MINOR CHNAGES TO REFLECT USE OF SCALED INCRS -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-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 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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE AVEROB(NUM,INDX,LK) - PARAMETER (IRMX= 80000, ISMX= 8000) - LOGICAL EWRITE - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER SUPMRK(ISMX) - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - 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/STWRIT/SWRITE,EWRITE,IWRITE - DATA XMSG/99999./ - NUMGT = MAX0(NUMORG,NUM) - LK = NUMGT - NOOK = 0 - DO 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) - ENDDO - IF(NOOK.EQ.2) THEN - CALL NOEQ2(NUM,INDX,LK) - RETURN - END IF - SUPMRK = 65 - DO 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 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 - ENDDO - END IF - END IF - ENDDO - DO 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 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) - ENDDO - IF(KOUNT.GT.1) THEN -C THERE IS AT LEAST ONE OTHER REPORT AT THE SAME LEVEL - 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+SIGN(.0005,CTEMP),NINT(SHGT(LK)),NINT(STIM(LK)), - $ NINT(SDIRF(LK)),SSPDF(LK),CTMPF+SIGN(.0005,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 - ENDDO - IF(LK.GT.NUMGT) THEN - DO K = 1,NUM-1 - KNDX = INDX + K - 1 - DO KK = K+1,NUM - JNDX = INDX + KK - 1 - IF(SUPMRK(KK).EQ.SUPMRK(K)) THEN - IF(TAG(KNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9024, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9024 FORMAT(/' #EVENT 315: AVEROB; OMIT WIND(S-OB), WND QM SET TO "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(4:4) = 'O' - TAG(KNDX)(14:14) = '4' - IWEVNT(KNDX) = 315 - END IF - IF(TAG(JNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9024, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - TAG(JNDX)(4:4) = 'O' - TAG(JNDX)(14:14) = '4' - IWEVNT(JNDX) = 315 - END IF - IF(TAG(KNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9025, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9025 FORMAT(/' #EVENT 315: AVEROB; OMIT TEMP(S-OB), TMP QM SET TO "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(2:2) = 'O' - TAG(KNDX)(13:13) = '4' - ITEVNT(KNDX) = 315 - END IF - IF(TAG(JNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9025, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - TAG(JNDX)(2:2) = 'O' - TAG(JNDX)(13:13) = '4' - ITEVNT(JNDX) = 315 - END IF - END IF - ENDDO - ENDDO - 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 K = 1,NUMORG - KNDX = INDX + K - 1 - ISTCPT(K) = IFLEPT(KNDX) - ENDDO - END IF - NUM = NUMGT - NUMORG = 0 - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: FORSDM WRITES FLAGGED OR LARGE INCR. ISOL. RPTS -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-11-20 -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 ALSO WRITES ALL ISOLATED REPORTS WITH LARGE INCREMENTS, REGARDLESS -C OF QUALITY MARKER. THIS ALLOWS THE SDM TO USE SDMEDIT TO 'KEEP' -C ANY OF THESE REPORTS IN THE NEXT NETWORK RUN. AIREP/PIREP REPORTS -C WITHIN THE CONTINENTAL U.S. ARE EXCLUDED FROM THE WRITE IF IFLGUS=1 -C OR 2 AND KTACAR > 1. -C -C PROGRAM HISTORY LOG: -C 1993-01-05 P. JULIAN -- NEW SUBPROGRAM -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1998-02-17 D. A. KEYSER -- IMPROVED PRINT IN SDMACQC FILE IN UNIT 52 -C 2002-11-20 D. A. KEYSER -- SINCE HAVE REMOVED ASSUMPTION THAT AN SDM -C PURGE ON TEMP ONLY ALSO RESULTS IN AN SDM PURGE ON WIND -C AS WELL AS THE RELATIONSHIP BETWEEN AN SDM KEEP ON WIND -C VS. A KEEP ON TEMP (THEY ARE INDENDENDENT OF EACH OTHER), -C NOW TESTS BOTH BYTE 2 AND 4 OF TAG FOR "P" OR "H" RATHER -C THAN JUST BYTE 1 OF TAG {WHICH NOW CAN NEVER HAVE AN "H" -C AND WILL ONLY HAVE A "P" IF WIND (AND THUS ALSO TEMP VIA -C ACTIONS OF PREVIOUS PREPOBS_PREPACQC PROGRAM} IS PURGED} -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 AS WELL -C - AS THOSE WITH LARGE INCREMENTS) -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE FORSDM(INDX) - PARAMETER (IRMX= 80000) - CHARACTER*1 CTG,CLON,C1,CH1(9) - CHARACTER*8 ACID - CHARACTER*14 TAG - INTEGER ICH1(9) - COMMON/TSTACAR/KTACAR - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),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) - DATA CH1 /'Q','R','S','T','U','V','W','X','Y'/ - DATA ICH1 /10, 20, 30, 40, 50, 60, 70, 80, 90 / -C -C NOTE: ALL CONV'L AIREP/PIREP (NOT ASDAR/AMDAR/TAMDAR) RPTS OVER CONUS -C (DEFINED AS CONTINENTAL U.S, SO. ONTARIO AND THE GULF OF MEXICO NORTH -C OF 25 DEG. N LAT) WILL BE EXCLUDED FROM ALL NCEP ANALYSES IF: -C IFLGUS= 1 OR 2 & KTACAR>1. BASED ON THESE SWITCHES, THIS SUBR. MAY -C CHECK FOR OBS. OVER THIS REGION AND NOT WRITE ANY FLAGGED REPORTS TO -C 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(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 FLAGGED 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 VALUE OF SCALED INCREMENT CHARACTER Q-Z, IF INCREMENT NOT -C AVAIL. SCALE SET TO MSG - SCALE = 99999. - IF(TAG(INDX)(1:1).GE.'Q'.AND.TAG(INDX)(1:1).LE.'Z') THEN - CTG = TAG(INDX)(1:1) - SCALE = 100.0 - DO I=1,9 - IF(CTG.EQ.CH1(I)) THEN - SCALE = ICH1(I) - EXIT - END IF - ENDDO - 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 = '-' -ccccc IF(TAG(INDX)(1:1).EQ.'H'.OR.TAG(INDX)(1:1).EQ.'P') -ccccc$ C1 = TAG(INDX)(1:1) - IF(TAG(INDX)(4:4).EQ.'H'.OR.TAG(INDX)(2:2).EQ.'H' .OR. - $ TAG(INDX)(4:4).EQ.'P'.OR.TAG(INDX)(2:2).EQ.'P') - $ C1 = 'Y' - WRITE(52,25) ACID(INDX),ALAT(INDX),QLON,CLON,QTIME,PRALT, - $ QTEMP,ADIR(INDX),ASPD(INDX),SCALE,C1,TAG(INDX)(4:4), - $ TAG(INDX)(2:2) - 25 FORMAT(' ',A8,2F8.2,A1,3F7.0,F6.0,F7.1,F7.0,3(4X,A1)) - END IF - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: RPACKR PREPARES OBS. FOR PACKING -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2007-10-17 -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). -C -C PROGRAM HISTORY LOG: -C 1989-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1990-04-16 P. JULIAN -- MODIFIED TO PACK SUPEROBS ONE AT A -C TIME ON SINGLE LEVELS ONLY -C 1990-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 1990-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 1991-02-26 G. J. DIMEGO -- MADE INCREMENT TO-BE-ADDED 11 (SEE ABOVE) -C 1994-01-01 P. JULIAN -- CHANGES TO RE-DO ON29(REV) QUAL MARKS -C 1994-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 1995-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 1995-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 PREPBUFR -C FILE) IF THE SCALED VECTOR WIND INCREMENT IS LARGE -C (IN THE RANGE 'V' TO 'Z'), A SUPEROB IS NEVER STORED; -C ASDAR/AMDAR REPORTS NOW GET TEMPERATURE AND WIND Q. -C MARKS SET TO "SUSPECT" (AND ARE ASSIGNED THE NEW REASON -C CODE "330" FOR OUTPUT TO PREPBUFR FILE) IF THE -C PHASE OF FLIGHT INDICATOR IS MISSING (INDICATES A -C PROBABLE "BANKING" AIRCRAFT WITH SUSPECT DATA QUALITY) -C 2002-11-20 D. A. KEYSER -- SINCE THERE IS NO LONGER ANY RELATIONSHIP -C BETWEEN AN SDM KEEP ON WIND VS. A KEEP ON TEMP - THEY ARE -C INDENDENDENT OF EACH OTHER, FULL Q.C. IS NOW PERFORMED ON -C REPORTS WITH A KEEP FLAG ON EITHER, ALTHOUGH THE ORIGINAL -C KEEP FLAGS ARE STILL HONORED -C 2007-10-17 D. A. KEYSER -- CHANGES TO TREAT TAMDAR AND CANADIAN -C AMDAR REPORTS THE SAME AS ASDAR/AMDAR REPORTS -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 -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE RPACKR(NUM,NOBS,INDX) - PARAMETER (IRMX= 80000, ISMX= 8000) - PARAMETER (ISUP= 4000) - LOGICAL EWRITE - CHARACTER*4 SSMARK - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER IDATA(1608) - REAL ORIGTM(10),RDATA(1608) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),RCPTST - COMMON/OUTPUT/KNTOUT(5) - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - 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) - EQUIVALENCE (IDATA,RDATA) - N2DO = NOBS -C NSPOB IS NO. OF SUPEROBS FORMED FOR THE STACK (NSPOB IS LIMITED TO 5) - NSPOB = N2DO - NUM -C INVENTORY INCREMENTS - 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 I = 1,NUM - JNDX = INDX + I - 1 - IF(TAG(JNDX)(1:1).EQ.'D') THEN -C SKIP REPACKING OF ORIGINAL REPORT IF IT IS INDEED A DUPLICATE REPORT - 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 SKIP REPACKING OF ORIGINAL REPORT IF IT IS OUTSIDE REQ. TIME WINDOW - IF(TIME(JNDX).LT.TMINO.OR.TIME(JNDX).GT.TMAXO) THEN -C SET POS.1 OF TAG TO 'D' TO REMOVE FROM FINAL LISTING OF ORIG. REPORTS - TAG(JNDX)(1:1) = 'D' -CCCCC PRINT 9002, JNDX,ACID(JNDX),ALAT(JNDX),ALON(JNDX), -CCCCC$ TIME(JNDX),TAG(JNDX) -C9002 FORMAT(/' ##########: RPACKR; RPTS OUTSIDE TIME WINDOW SKIPPED..', -CCCCC$ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"'/) - KNTINI(JNDX) = 99999 - GO TO 1 - END IF -C NOW, MAKE FINAL ASSIGNMENT OF TEMPERATURE AND WIND Q. MARKS (IF APPL.) - IF(TAG(JNDX)(1:1).EQ.'P') THEN -C SDM WIND PURGE OBSERVATIONS HAVE ALREADY BEEN MARKED -C (NOTE: IF PURGE ON WIND, WILL ALSO BE PURGE ON TEMP FROM ACTION -C TAKEN BY PREVIOUS PREPOBS_PREPDATA PROGRAM) - ELSE IF(N2DO.EQ.1) THEN -C********************************************************************** -C ISOLATED OBSERVATIONS COME HERE -C********************************************************************** - IF(TAG(JNDX)(7:7).EQ.'Z') THEN -C---------------------------------------------------------------------- -C ASDARS/AMDARS/TAMDARS -C---------------------------------------------------------------------- - IF(TAG(JNDX)(13:13).GT.'5') THEN - IF(TAG(JNDX)(10:10).EQ.'7') THEN - IF(EWRITE) PRINT 9095, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9095 FORMAT(/' #EVENT 330: RPACKR; ISOLAT. ASDAR/AMDAR/TAMDAR ', - $ 'BANKING?, TMP QM. Q',I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'Q' - TAG(JNDX)(13:13) = '5' - ITEVNT(JNDX) = 330 - ELSE IF(TAG(JNDX)(13:13).GT.'6') THEN -C IF "GOOD" ASDAR/AMDAR/TAMDAR REPORT, TEMP Q.M. IS 'A' - IF(EWRITE) PRINT 9090, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9090 FORMAT(/' #EVENT 328: RPACKR; ISOLAT. "GOOD" ASDAR/AMDAR/TAMDAR,', - $ ' TEMP Q.M. A',I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'A' - TAG(JNDX)(13:13) = '6' - ITEVNT(JNDX) = 328 - END IF - END IF - IF(TAG(JNDX)(14:14).GT.'5') THEN - IF(TAG(JNDX)(10:10).EQ.'7') THEN - IF(EWRITE) PRINT 8095, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8095 FORMAT(/' #EVENT 330: RPACKR; ISOLAT. ASDAR/AMDAR/TAMDAR ', - $ 'BANKING?, WND QM. Q',I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'Q' - TAG(JNDX)(14:14) = '5' - IWEVNT(JNDX) = 330 - ELSE IF(TAG(JNDX)(14:14).GT.'6') THEN -C IF "GOOD" ASDAR/AMDAR/TAMDAR REPORT, WIND Q.M. IS 'A' - IF(EWRITE) PRINT 9091, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9091 FORMAT(/' #EVENT 328: RPACKR; ISOLAT. "GOOD" ASDAR/AMDAR/TAMDAR,', - $ ' WIND Q.M. A',I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'A' - TAG(JNDX)(14:14) = '6' - IWEVNT(JNDX) = 328 - END IF - END IF - ELSE -C---------------------------------------------------------------------- -C AIREPS/PIREPS -C---------------------------------------------------------------------- - IF(TAG(JNDX)(1:1).EQ.'Q'.OR.TAG(JNDX)(1:1).EQ.'R') THEN - IF(TAG(JNDX)(13:13).GT.'6') THEN -C IF "GOOD" REPORT W/ SMALL VECTOR WIND INCREMENT (Q-R) TEMP Q.M. IS 'A' - IF(EWRITE) PRINT 9030, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9030 FORMAT(/' #EVENT 317: RPACKR; ISOLAT. AIREP SMALL INCR. TMP QM A', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'A' - TAG(JNDX)(13:13) = '6' - ITEVNT(JNDX) = 317 - END IF - IF(TAG(JNDX)(14:14).GT.'6') THEN -C IF "GOOD" REPORT W/ SMALL VECTOR WIND INCREMENT (Q-R) WIND Q.M. IS 'A' - IF(EWRITE) PRINT 8030, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8030 FORMAT(/' #EVENT 317: RPACKR; ISOLAT. AIREP SMALL INCR. WND QM A', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'A' - TAG(JNDX)(14:14) = '6' - IWEVNT(JNDX) = 317 - END IF - ELSE IF(TAG(JNDX)(1:1).GE.'V'.AND.TAG(JNDX)(1:1).LE.'Z')THEN - IF(TAG(JNDX)(13:13).GT.'3') THEN -C IF LARGE VECTOR WIND INCREMENT (V - Z), TEMP Q.M. IS 'F' - IF(EWRITE) PRINT 9029, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9029 FORMAT(/' #EVENT 316: RPACKR; ISOLAT. AIREP LARGE INCR. TMP QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'F' - TAG(JNDX)(13:13) = '3' - ITEVNT(JNDX) = 316 - END IF - IF(TAG(JNDX)(14:14).GT.'3') THEN -C IF LARGE VECTOR WIND INCREMENT (V - Z), WIND Q.M. IS 'F' - IF(EWRITE) PRINT 8029, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8029 FORMAT(/' #EVENT 316: RPACKR; ISOLAT. AIREP LARGE INCR. WND QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 - IF(TAG(JNDX)(13:13).GT.'5') THEN -C IF "GOOD" REPORT WITH INTERMEDIATE VECTOR WIND INCREMENT (S - U) OR -C WAYPOINT LOCATION CHANGED ('-'), TEMP Q.M. IS 'Q' - IF(EWRITE) PRINT 9031, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9031 FORMAT(/' #EVENT 318: RPACKR; ISOLAT. AIREP SUSP. INCR. TMP QM Q', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'Q' - TAG(JNDX)(13:13) = '5' - ITEVNT(JNDX) = 318 - END IF - IF(TAG(JNDX)(14:14).GT.'5') THEN -C IF "GOOD" REPORT WITH INTERMEDIATE VECTOR WIND INCREMENT (S - U) OR -C WAYPOINT LOCATION CHANGED ('-'), WIND Q.M. IS 'Q' - IF(EWRITE) PRINT 8031, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8031 FORMAT(/' #EVENT 318: RPACKR; ISOLAT. AIREP SUSP. INCR. WND QM Q', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 IF REPORT WITH VECTOR WIND INCREMENT NOT CALCULATED ('C'), TEMP & -C WIND Q.M. IS '-' (INCLUDES ALL RPTS OUTSIDE +/- 3.33-HR WINDOW) - IF(TAG(JNDX)(13:13).GT.'7') THEN - IF(EWRITE) PRINT 9032, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9032 FORMAT(/' #EVENT ###: RPACKR; ISOLAT. AIREP INCR. N/A TMP QM " "', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(13:13) = '7' - END IF - IF(TAG(JNDX)(14:14).GT.'7') THEN - IF(EWRITE) PRINT 8032, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8032 FORMAT(/' #EVENT ###: RPACKR; ISOLAT. AIREP INCR. N/A WND QM " "', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(14:14) = '7' - END IF - ELSE - END IF -C---------------------------------------------------------------------- - 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 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) - IF(TAG(JNDX)(13:13).GT.'3') THEN -CVVVVV%%%%% - PRINT *,'~~~~~ NUM=2 & THIS OBS. HAS A LARGE INCR., FLAG TEMP' -CAAAAA%%%%% - IF(EWRITE) PRINT 9929, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9929 FORMAT(/' #EVENT 329: RPACKR; <3 STACKD AIREP LRG INCR. TMP QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'F' - TAG(JNDX)(13:13) = '3' - ITEVNT(JNDX) = 329 - END IF - IF(TAG(JNDX)(14:14).GT.'3') THEN -CVVVVV%%%%% - PRINT *,'~~~~~ NUM=2 & THIS OBS. HAS A LARGE INCR., FLAG WIND' -CAAAAA%%%%% - IF(EWRITE) PRINT 8929, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8929 FORMAT(/' #EVENT 329: RPACKR; <3 STACKD AIREP LRG INCR. WND QM F', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'F' - TAG(JNDX)(14:14) = '3' - IWEVNT(JNDX) = 329 - END IF -C WILL NOT STORE ANY SUPEROB REPORTS IN THIS CASE - 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 - IF(EWRITE) PRINT 9034, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9034 FORMAT(/' #EVENT 320: RPACKR; STACKED W/ GOOD WND, WIND Q.M. "A"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 - IF(EWRITE) PRINT 9035, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9035 FORMAT(/' #EVENT 320: RPACKR; STACKED W/ GOOD TMP, TEMP Q.M. "A"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'A' - TAG(JNDX)(13:13) = '6' - ITEVNT(JNDX) = 320 - END IF -C********************************************************************** - END IF - IF(TAG(JNDX)(4:4).EQ.'F'.AND.TAG(JNDX)(13:13).GT.'3') THEN -C IF WIND IS FLAGGED, THEN TEMPERATURE IS ALWAYS ALSO FLAGGED - IF(EWRITE) PRINT 9033, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9033 FORMAT(/' #EVENT 319: RPACKR; BAD WIND, TEMP Q.M. SET TO "F"....', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'F' - TAG(JNDX)(13:13) = '3' - ITEVNT(JNDX) = 319 - END IF - 1 CONTINUE - ENDDO - NPT = NUM - IF(NSPOB.GT.0) THEN -C####################################################################### -C####################################################################### -C S U P E R O B S -C####################################################################### -C####################################################################### - DO I = 1,NSPOB - NPT = NPT + 1 -C RE-STORE TIME IN WORD 4 - RDATA(4) = NINT(MOD(STIM(NPT),2400.)) - IF(RDATA(4).LT.0.0) THEN - RDATA(4) = RDATA(4) + 2400. - STIM(NPT) = STIM(NPT) + 2400. - END IF -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) - ORIGTM(I) = RDATA(4) - DO J = 1,I-1 - IF(ORIGTM(I).EQ.ORIGTM(J)) THEN - RDATA(4) = MOD(RDATA(4)+TIMINC,2400.) - STIM(NPT) = STIM(NPT) + TIMINC - END IF - ENDDO -C SKIP PACKING OF SUPEROB REPORT IF IT IS OUTSIDE REQ. TIME WINDOW - 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 - KNTOUT(3) = KNTOUT(3) + 1 - IF(KNTOUT(3).GT.ISUP) THEN -C....................................................................... -C FATAL ERROR: THERE ARE MORE SUPEROBED RPTS THAN "ISUP" -- STOP 23 - PRINT 53, ISUP - 53 FORMAT(/' THERE ARE MORE THAN',I5,' SUPEROBED REPORTS GENERATED', - $ ' -- MUST INCREASE SIZE OF PARAMETER NAME "ISUP" - STOP 23'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(23) -C....................................................................... - END IF - 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 - ENDDO -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: NP22 DATE: 2002-11-20 -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 PURGES ON WIND AND/OR TEMP. THE NUMBER OF BAD -C TEMPERATURES IS ALSO ACCOUNTED FOR HERE. -C -C PROGRAM HISTORY LOG: -C 1994-01-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 2002-11-20 D. A. KEYSER -- SINCE HAVE REMOVED ASSUMPTION THAT AN SDM -C PURGE ON TEMP ONLY ALSO RESULTS IN AN SDM PURGE ON WIND -C AS WELL AS THE RELATIONSHIP BETWEEN AN SDM KEEP ON WIND -C VS. A KEEP ON TEMP (THEY ARE INDENDENDENT OF EACH OTHER), -C NOW TESTS BOTH BYTE 2 AND 4 OF TAG FOR "P" OR "H" RATHER -C THAN JUST BYTE 1 OF TAG {WHICH NOW CAN NEVER HAVE AN "H" -C AND WILL ONLY HAVE A "P" IF WIND (AND THUS ALSO TEMP VIA -C ACTIONS OF PREVIOUS PREPOBS_PREPACQC PROGRAM} IS PURGED} -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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE ACOUNT(NUM,INDX) - PARAMETER (IRMX= 80000) - 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) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),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 M = 1,15 - IF(TAG(INDX)(1:1).EQ.QCACMK(M)) THEN - KISO(M) = KISO(M) + 1 - GO TO 618 - END IF - ENDDO - 618 CONTINUE - END IF - ELSE - DO K = INDX,INDX+NUM-1 - IF(TIME(K).GE.TMINO.AND.TIME(K).LE.TMAXO) THEN - DO 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 - ENDDO - 718 CONTINUE -ccccc IF(TAG(K)(1:1).EQ.'P') KSDM(1) = KSDM(1) + 1 - IF(TAG(K)(2:2).EQ.'P'.OR.TAG(K)(4:4).EQ.'P') - $ KSDM(1) = KSDM(1) + 1 -ccccc IF(TAG(K)(1:1).EQ.'H') KSDM(2) = KSDM(2) + 1 - IF(TAG(K)(2:2).EQ.'H'.OR.TAG(K)(4:4).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 - ENDDO - 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: NP22 DATE: 1999-08-23 -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 1993-01-05 P. JULIAN -- THIS IS A NEW SUBPROGRAM-ALL CODE WAS -C WRITTEN TO ENABLE LOCAL SORT PROGRAM TO BE USED. -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-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 1999-08-23 D.A. KEYSER -- ADDED HIGHER ORDERS IN CHARACTER SORTS -C TO HOPEFULLY ALWAYS GIVE SAME SORT ORDER REGARDLESS OF -C INPUT REPORT ORDER -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/AMDAR/TAMDAR 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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE IDSORT(NFILE,NASDAR,NEXCLD) - PARAMETER (IRMX= 80000) - PARAMETER (ISIZE= 16) - CHARACTER*8 ACID,AAID(IRMX) - CHARACTER*14 TAG,STAG(IRMX) - CHARACTER*32 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/ICHTP - NASDAR = 0 - NEXCLD = 0 -C FILL IN CARRAY FOR SORT ROUTINE - DO 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: -C '99999' IF CHARACTERS ARE EBCDIC, -C '~~~~~' IF CHARACTERS ARE ASCII) -C 1ST ORDER - "99999" or "~~~~~"//STATION ID -C 2ND ORDER - TIME (INCREASING) (THIS WAS ADDED 8/23/1999) -C 3RD ORDER - LONGITUDE (WEST, INCREASING) (THIS WAS ADDED 8/23/1999) -C 4TH ORDER - LATITUDE (SOUTH TO NORTH) (THIS WAS ADDED 8/23/1999) -C 5TH ORDER - ALTITUDE (INCREASING) (THIS WAS ADDED 8/23/1999) - NEXCLD = NEXCLD + 1 - CARRAY(J)(1:5) = '99999' - IF(ICHTP.EQ.0) CARRAY(J)(1:5) = '~~~~~' - CARRAY(J)( 6:12) = ACID(J)(1:7) - WRITE(CARRAY(J)(13:16),'(I4.4)') NINT(TIME(J)) - WRITE(CARRAY(J)(17:21),'(I5.5)') NINT(ALON(J)*100.) - WRITE(CARRAY(J)(22:26),'(I5.5)') NINT(ALAT(J)*100.) + 9000 - WRITE(CARRAY(J)(27:32),'(I6.6)') NINT(AALT(J)) -C RESET POS. 8 OF ID BACK TO '-' (LATER USED TO TAG ISOLATED REPORTS) - TAG(J)(12:12) = '-' - ELSE IF(TAG(J)(7:7).EQ.'Z') THEN -C ASDAR/AMDAR/TAMDAR RPTS ARE COUNTED AND WILL BE AFTER AIREPS IN SORT -C (DO THIS BY CHANGING CHARACTER STRING TO: -C '999' IF CHARACTERS ARE EBCDIC, -C '~~~' IF CHARACTERS ARE ASCII) -C 1ST ORDER - "999" or "~~~"//STATION ID -C 2ND ORDER - TIME (INCREASING) -C 3RD ORDER - LONGITUDE (WEST, INCREASING) (THIS WAS ADDED 8/23/1999) -C 4TH ORDER - LATITUDE (SOUTH TO NORTH) (THIS WAS ADDED 8/23/1999) -C 5TH ORDER - ALTITUDE (INCREASING) (THIS WAS ADDED 8/23/1999) - NASDAR = NASDAR + 1 - CARRAY(J)(1:3) = '999' - IF(ICHTP.EQ.0) CARRAY(J)(1:3) = '~~~' - CARRAY(J)(4:11) = ACID(J) - WRITE(CARRAY(J)(12:16),'(I5.5)') NINT(TIME(J)) - WRITE(CARRAY(J)(17:21),'(I5.5)') NINT(ALON(J)*100.) - WRITE(CARRAY(J)(22:26),'(I5.5)') NINT(ALAT(J)*100.) + 9000 - WRITE(CARRAY(J)(27:32),'(I6.6)') NINT(AALT(J)) - ELSE -C AIREPS WILL BE AT BEGINNING OF SORT -C 1ST ORDER - STATION ID -C 2ND ORDER - LONGITUDE (WEST, INCREASING) -C 3RD ORDER - TIME (INCREASING) -C 4TH ORDER - LATITUDE (SOUTH TO NORTH) (THIS WAS ADDED 8/23/1999) -C 5TH ORDER - ALTITUDE (INCREASING) (THIS WAS ADDED 8/23/1999) - 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)) - WRITE(CARRAY(J)(17:21),'(I5.5)') NINT(ALAT(J)*100.) + 9000 - WRITE(CARRAY(J)(22:27),'(I6.6)') NINT(AALT(J)) - CARRAY(J)(28:32) = '00000' - END IF -C REMOVED THIS FOR 6 JUL 1995 VERSION (WAS SPLITTING UP SOME TRACKS) -CCCCCCCCCDO K = 1,12 -CCCCCCCCC IF(CARRAY(J)(K:K).EQ.' ') CARRAY(J)(K:K) = '0' -CCCCCCCCCENDDO -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,A32) -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) - ENDDO -C CALL SORT ROUTINE- PUTS POINTERS INTO IPOINT ARRAY/DOES NOT REARRANGE - IF(NFILE.GT.0) CALL INDEXC(NFILE,CARRAY,INDR) - DO I = 1,NFILE - J = INDR(I) -C WRITE SORTED REPORTS BACK INTO ORIGINAL ARRAYS - 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) - ENDDO - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: PRELIM SUPERVISES QUALITY CONTROL -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2002-11-20 -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 1993-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 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 2002-11-20 D. A. KEYSER -- SINCE HAVE REMOVED THE RELATIONSHIP -C BETWEEN AN SDM KEEP ON WIND VS. A KEEP ON TEMP (THEY ARE -C INDENDENDENT OF EACH OTHER), NOW TESTS BOTH BYTE 2 AND 4 -C OF TAG FOR "H" RATHER THAN JUST BYTE 1 OF TAG (WHICH NOW -C CAN NEVER HAVE AN "H") -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 ON WIND -C - AND/OR TEMP) -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE PRELIM(NUM,INDX,LOALT,KNUM,STCLIM) - PARAMETER (IRMX= 80000, ISMX= 8000) - LOGICAL EWRITE - CHARACTER*1 CTG,CLON,C1,CH1(9) - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER ICH1(9) - REAL SCALE(ISMX) - COMMON/STWRIT/SWRITE,EWRITE,IWRITE - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - 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./ - DATA CH1 /'Q','R','S','T','U','V','W','X','Y'/ - DATA ICH1 / 5, 15, 25, 35, 45, 55, 65, 75, 85 / - 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)+SIGN(.0005,ALAT(INDX)), - $ ALON(INDX)+SIGN(.0005,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 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 - IF(EWRITE) PRINT 9036, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9036 FORMAT(/' #EVENT 321: PRELIM; WND FAILED SHEAR CHK, WND Q.M. "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'F' - TAG(JNDX)(14:14) = '3' - IWEVNT(JNDX) = 321 - END IF - KBAD(I) = I - END IF - ENDDO -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 - SCALE = XMSG - IFLAG = 0 - DO 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 - IF(EWRITE) PRINT 9037, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9037 FORMAT(/' #EVENT 322: PRELIM; TMP FAILED LAPSE CHK, TMP Q.M. "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - ITEVNT(JNDX) = 322 - ELSE - IF(EWRITE) PRINT 9028, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9028 FORMAT(/' #EVENT 319: PRELIM; WIND IS BAD, TEMP Q.M. SET TO "F".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 VALUE OF SCALED INCREMENT CHARACTER Q-Z - 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) - SCALE(I) = 95.0 - DO II=1,9 - IF(CTG.EQ.CH1(II)) THEN - SCALE(I) = ICH1(II) - EXIT - END IF - ENDDO - IQNUM = IQNUM + 1 - QSUM = QSUM + SCALE(I) - END IF -C IF ANY OBS. IN STACK HAS A KEEP FLAG (SDM) ON WIND AND/OR TEMP -C WILL ALWAYS FORCE THIS STACK TO GO TO SDMSTAC D-SET FOR SDM PERUSAL -C AND POSSIBLE DELETING OF THE STACK, REGARDLESS OF QSUM VALUE -ccccc IF(TAG(JNDX)(1:1).EQ.'H') IFLAG = 1 - IF(TAG(JNDX)(4:4).EQ.'H'.OR.TAG(JNDX)(2:2).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), -CCCCC$ CTEMP+SIGN(.0005,CTEMP),TIME(JNDX),KBAD(I),ISTCPT(I),TAG(JNDX), -CCCCC$ SCALE(I),IQNUM -C6003 FORMAT(' ',I3,1X,A8,F6.0,F6.1,1X,F7.0,F6.1,2X,F5.0,2I4,2X,'"', -CCCCC$ A14,'"',F4.1,1X,I3) - ENDDO - 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 ON WIND AND/OR TEMP, SEND PRINT TO -C SDM IN UNIT 53 - DO 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 = '-' -ccccccccccccIF(TAG(JNDX)(1:1).EQ.'H'.OR.TAG(JNDX)(1:1).EQ.'P') -ccccc$ C1 = TAG(JNDX)(1:1) - IF(TAG(JNDX)(4:4).EQ.'H'.OR.TAG(JNDX)(2:2).EQ.'H' .OR. - $ TAG(JNDX)(4:4).EQ.'P'.OR.TAG(JNDX)(2:2).EQ.'P') - $ C1 = 'Y' - WRITE(53,26) ACID(JNDX),ALAT(JNDX),QLON,CLON,QTIME,PRALT, - $ QTEMP,ADIR(JNDX),ASPD(JNDX),SCALE(I),C1,TAG(JNDX)(4:4), - $ TAG(JNDX)(2:2) - 26 FORMAT(' ',A8,2F8.2,A1,3F7.0,F6.0,F7.1,F7.0,3(4X,A1)) - ENDDO - 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: NP22 DATE: 1996-01-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 1989-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1990-03-29 P. JULIAN -- MODIFIED TO HONOR SDM/QCAIRCFT PURGE FOR -C STACKED OBSERVATIONS (OBS. INCRMENT CHECK) -C 1990-06-14 D. A. KEYSER -- CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES -C FOR STACKED OBS.; FIXED ERROR IN Q. MARK DESIGNATOR -C 1990-07-03 D. A. KEYSER -- ALT. CORRESP. TO PRESS. OF 300 & 200 MB -C FOR REGRESS. CALC. OF SUPEROBS OFF SLIGHTLY, FIXED -C 1990-09-18 D. A. KEYSER -- MINOR ERROR IN LOGIC CORRECTED, SOME ORIG. -C REPORTS WERE BEING GIVEN 'O' Q. MARK BY MISTAKE -C 1993-01-05 P. JULIAN -- SUBPROGRAM PRELIM CREATED FROM THE FIRST -C PORTION OF THE OLD VERSION -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-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 1995-04-26 D. A. KEYSER -- CORRECTED PROBLEM IN SUPEROBING GUESS -C (OCCASIONALLY OCCURRED) -C 1996-01-26 D. A. KEYSER -- CORRECTED DIVIDE-BY-ZERO POSSIBILITY IN -C THE CALCULATION OF MULTIPLE CORRELATIONS -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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE SUPROB(NUM,INDX,LK,LOALT,KNUM) - PARAMETER (IRMX= 80000, ISMX= 8000) - 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) - LOGICAL EWRITE - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - INTEGER IARRAY(ISMX),INDR(ISMX) - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - 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/STWRIT/SWRITE,EWRITE,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 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 - IF(EWRITE) PRINT 9038, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9038 FORMAT(/' #EVENT 315: SUPROB; S-LVL TMP SUPEROBED, TEMP Q.M. "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(2:2) = 'O' - TAG(KNDX)(13:13) = '4' - ITEVNT(KNDX) = 315 - END IF - IF(TAG(KNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9039, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9039 FORMAT(/' #EVENT 315: SUPROB; S-LVL WND SUPEROBED, WIND Q.M. "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(4:4) = 'O' - TAG(KNDX)(14:14) = '4' - IWEVNT(KNDX) = 315 - END IF - END IF - ENDDO - 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+SIGN(.0005,CTEMP), - $ NINT(SHGT(LK)),ISTCPT(LK),NT,NINT(SDIRF(LK)),SSPDF(LK), - $ CTMPF+SIGN(.0005,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 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 - ENDDO - 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 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 - ENDDO - 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 - DEN = 1. - (RAT * RAT) - IF(DEN.EQ.0.) DEN = 0.0001 - RUMULT = ((RUA*RUA+RUT*RUT-2.*RUA*RUT*RAT)/DEN) - IF(RUMULT.LE.0.0) RUMULT = .0001 - RUMULT = SQRT(RUMULT) - RVMULT = ((RVA*RVA+RVT*RVT-2.*RVA*RVT*RAT)/DEN) - 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 - IARRAY(1:NUM) = NINT(SSPD(1:NUM)*100.) - 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 - IARRAY(1:NUM) = NINT(STMP(1:NUM)*100.) - 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 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+SIGN(.0005,CTEMP),NINT(QDIRF(JA)),QSPDF(JA), - $ CTMPF+SIGN(.0005,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) - ENDDO - END IF - END IF -C ALL INTERPS HAVE BEEN TRIED, RESULT IS KOUNT - IF(KOUNT.GT.0) THEN - DO 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 - IF(EWRITE) PRINT 9040, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9040 FORMAT(/' #EVENT 315: SUPROB; M-LVL TMP SUPEROBED, TEMP Q.M. "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(2:2) = 'O' - TAG(KNDX)(13:13) = '4' - ITEVNT(KNDX) = 315 - END IF - IF(TAG(KNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9041, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9041 FORMAT(/' #EVENT 315: SUPROB; M-LVL WND SUPEROBED, WIND Q.M. "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 - IF(EWRITE) PRINT 9042, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9042 FORMAT(/' #EVENT 323: SUPROB; MUL-LVL TEMP BAD, TEMP Q.M. IS "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(2:2) = 'F' - TAG(KNDX)(13:13) = '3' - ITEVNT(KNDX) = 323 - END IF - IF(TAG(KNDX)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8042, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 8042 FORMAT(/' #EVENT 323: SUPROB; MUL-LVL WIND BAD, WIND Q.M. IS "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 - IF(EWRITE) PRINT 9043, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 9043 FORMAT(/' #EVENT ###: SUPROB; MUL-LO-LVL TEMP, TEMP Q.M. IS " "', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(13:13) = '7' - END IF - IF(TAG(KNDX)(14:14).GT.'7') THEN - IF(EWRITE) PRINT 8043, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - 8043 FORMAT(/' #EVENT ###: SUPROB; MUL-LO-LVL WIND, WIND Q.M. IS " "', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(KNDX)(14:14) = '7' - END IF - END IF - ENDDO - 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 - KFLAG = 0 - DO 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 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 - IF(EWRITE) PRINT 9044, JNDX,ACID(JNDX), - $ ALAT(KNDX),ALON(JNDX),TIME(JNDX),TAG(JNDX) - 9044 FORMAT(/' #EVENT 315: SUPROB; MUL-LO-LVL TMP SUPOBED, TMP QM "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(2:2) = 'O' - TAG(JNDX)(13:13) = '4' - ITEVNT(JNDX) = 315 - END IF - IF(TAG(JNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 8044, JNDX,ACID(JNDX), - $ ALAT(JNDX),ALON(JNDX),TIME(JNDX),TAG(JNDX) - 8044 FORMAT(/' #EVENT 315: SUPROB; MUL-LO-LVL WND SUPOBED, WND QM "O"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(JNDX)(4:4) = 'O' - TAG(JNDX)(14:14) = '4' - IWEVNT(JNDX) = 315 - END IF - IF(TAG(KNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9044, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - TAG(KNDX)(2:2) = 'O' - TAG(KNDX)(13:13) = '4' - ITEVNT(KNDX) = 315 - END IF - IF(TAG(KNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 8044, KNDX,ACID(KNDX), - $ ALAT(KNDX),ALON(KNDX),TIME(KNDX),TAG(KNDX) - TAG(KNDX)(4:4) = 'O' - TAG(KNDX)(14:14) = '4' - IWEVNT(KNDX) = 315 - END IF - END IF - ENDDO - 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+SIGN(.0005,CTEMP),NINT(SHGT(LK)),NINT(SDIRF(LK)),SSPDF(LK), - $ CTMPF+SIGN(.0005,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 - ENDDO - 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 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 - IF(EWRITE) PRINT 9038, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - TAG(JNDX)(2:2) = 'O' - TAG(JNDX)(13:13) = '4' - ITEVNT(JNDX) = 315 - END IF - IF(TAG(JNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9039, JNDX,ACID(JNDX),ALAT(JNDX), - $ ALON(JNDX),TIME(JNDX),TAG(JNDX) - TAG(JNDX)(4:4) = 'O' - TAG(JNDX)(14:14) = '4' - IWEVNT(JNDX) = 315 - END IF - END IF - ENDDO - 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 I = 1,NUM - KNDX = INDX + I - 1 - IF(ISTCPT(I).GT.0) THEN - IF(TAG(KNDX)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9038, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - TAG(KNDX)(2:2) = 'O' - TAG(KNDX)(13:13) = '4' - ITEVNT(KNDX) = 315 - END IF - IF(TAG(KNDX)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 9039, KNDX,ACID(KNDX),ALAT(KNDX), - $ ALON(KNDX),TIME(KNDX),TAG(KNDX) - TAG(KNDX)(4:4) = 'O' - TAG(KNDX)(14:14) = '4' - IWEVNT(KNDX) = 315 - END IF - END IF - ENDDO - 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+SIGN(.0005,CTEMP),NT,NINT(SDIRF(LK)), - $ SSPDF(LK),NINT(SHGTF(LK)),CTMPF+SIGN(.0005,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: NP22 DATE: 1995-03-27 -C -C ABSTRACT: CALCULATES SUPEROB FOR CASE OF TWO OBSERVATIONS ONLY. -C -C PROGRAM HISTORY LOG: -C 1989-04-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1990-03-29 P. JULIAN -- MODIFIED TO HONOR SDM/QCAIRCFT PURGE FOR -C STACKED OBSERVATIONS (OBS. INCRMENT CHECK) -C 1990-06-14 D. A. KEYSER -- CORRECTED TO HONOR ALL SDM/QCAIRCFT PURGES -C FOR STACKED OBS.; FIXED ERROR IN Q. MARK DESIGNATOR -C 1990-07-03 D. A. KEYSER -- ALT. CORRESP. TO PRESS. OF 300 & 200 MB -C FOR REGRESS. CALC. OF SUPEROBS OFF SLIGHTLY, FIXED -C 1990-09-18 D. A. KEYSER -- MINOR ERROR IN LOGIC CORRECTED, SOME ORIG. -C REPORTS WERE BEING GIVEN 'O' Q. MARK BY MISTAKE -C 1994-08-25 D. A. KEYSER -- STREAMLINED CODE, EXPANDED COMMENTS AND -C DOCBLOCKS, REVISED TO MAKE MACHINE INDEPENDENT -C 1995-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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE NOEQ2(NUM,INDX,LK) - PARAMETER (IRMX= 80000, ISMX= 8000) - LOGICAL L1L,L2L,EWRITE - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - 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/STWRIT/SWRITE,EWRITE,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 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 - ENDDO -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 - IF(EWRITE) PRINT 9047, I1,ACID(I1),ALAT(I1),ALON(I1), - $ TIME(I1),TAG(I1) - 9047 FORMAT(/' #EVENT 324: NOEQ2; VRY LRG INCR/?TRKCHK ERR,TMP QM "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(I1)(2:2) = 'F' - TAG(I1)(13:13) = '3' - ITEVNT(I1) = 324 - END IF - IF(TAG(I1)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8047, I1,ACID(I1),ALAT(I1),ALON(I1), - $ TIME(I1),TAG(I1) - 8047 FORMAT(/' #EVENT 324: NOEQ2; VRY LRG INCR/?TRKCHK ERR,WND QM "F"', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - 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 - IF(EWRITE) PRINT 9047, I2,ACID(I2),ALAT(I2),ALON(I2), - $ TIME(I2),TAG(I2) - TAG(I2)(2:2) = 'F' - TAG(I2)(13:13) = '3' - ITEVNT(I2) = 324 - END IF - IF(TAG(I2)(14:14).GT.'3') THEN - IF(EWRITE) PRINT 8047, I2,ACID(I2),ALAT(I2),ALON(I2), - $ TIME(I2),TAG(I2) - 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 - IF(EWRITE) PRINT 9048, I1,ACID(I1),ALAT(I1),ALON(I1), - $ TIME(I1),TAG(I1) - 9048 FORMAT(/' #EVENT 315: NOEQ2; USED TO MAKE SUPROB, TEMP Q.M. "O".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(I1)(2:2) = 'O' - TAG(I1)(13:13) = '4' - ITEVNT(I1) = 315 - END IF - IF(TAG(I1)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 8048, I1,ACID(I1),ALAT(I1),ALON(I1), - $ TIME(I1),TAG(I1) - 8048 FORMAT(/' #EVENT 315: NOEQ2; USED TO MAKE SUPROB, WIND Q.M. "O".', - $ I5,2X,A8,2F8.2,F6.0,2X,'"',A14,'"') - TAG(I1)(4:4) = 'O' - TAG(I1)(14:14) = '4' - IWEVNT(I1) = 315 - END IF - IF(TAG(I2)(13:13).GT.'4') THEN - IF(EWRITE) PRINT 9048, I2,ACID(I2),ALAT(I2),ALON(I2), - $ TIME(I2),TAG(I2) - TAG(I2)(2:2) = 'O' - TAG(I2)(13:13) = '4' - ITEVNT(I2) = 315 - END IF - IF(TAG(I2)(14:14).GT.'4') THEN - IF(EWRITE) PRINT 8048, I2,ACID(I2),ALAT(I2),ALON(I2), - $ TIME(I2),TAG(I2) - 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+SIGN(.0005,CTEMP),K1,K2,I1,I2,NINT(SDIRF(LK)),SSPDF(LK), - $ CTMPF+SIGN(.0005,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: NP22 DATE: 1994-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 1989-04-01 P. JULIAN -- ORIGINAL AUTHOR -C 1994-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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE STATS(KNO,INDX,NUM,SBAR,VPOINT) - PARAMETER (IRMX= 80000, ISMX= 8000) - DIMENSION SQQ(ISMX),DU(ISMX),DV(ISMX),VECT(ISMX),ALTNRM(ISMX), - $ UN(ISMX),VN(ISMX),UECT(ISMX),TIMNRM(ISMX),SSDN(ISMX),VPOINT(ISMX) - LOGICAL SWRITE - CHARACTER*8 ACID,SAID - CHARACTER*14 TAG - COMMON/SUMDAT/ISTCPT(ISMX),SAID(ISMX),SLAT(ISMX),SLON(ISMX), - $ SHGT(ISMX),STIM(ISMX),SSPD(ISMX),SDIR(ISMX),STMP(ISMX), - $ KBAD(ISMX),NUMORG,SSPDF(ISMX),SDIRF(ISMX),STMPF(ISMX),SHGTF(ISMX) - 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/STWRIT/SWRITE,EWRITE,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 - IBAD = 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 - 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 - UN = XMSG - DU = XMSG - VN = XMSG - DV = XMSG - SSDN = XMSG - UECT = -999. - VECT = -999. - ALTNRM = XMSG - TIMNRM = XMSG - DO 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 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 - ENDDO -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 - ENDDO - 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 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 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 - ENDDO - 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 - ENDDO - IF(KNUM.GT.KNO) THEN -C*********************************************************************** -C MORE THAN KNO OBSERVATIONS -C*********************************************************************** - SQQ = XMSG - VPOINT(1:NUM) = UECT(1:NUM) - DO I = 1,NUM - JNDX = INDX + I - 1 - IF(ISTCPT(I).LE.0) GO TO 117 - ALTNRM(I) = 0. -CVVVVV%%%%% - IF(SDALT.EQ.0.) PRINT *, '~~~~~ SDALT=0 IN STATS' -CAAAAA%%%%% - IF(SDALT.NE.0.) ALTNRM(I) = ABS((AALT(JNDX)-ABAR)/SDALT) - TIMNRM(I) = 0. -CVVVVV%%%%% - IF(SDT.EQ.0.) PRINT *, '~~~~~ SDT=0 IN STATS' -CAAAAA%%%%% - 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 - ENDDO - 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+SIGN(.0005,TBAR),SDT,ABAR,SDALT,SBAR, - $ SDS+SIGN(.0005,SDS),CTEMP+SIGN(.0005,CTEMP), - $ CTSD+SIGN(.0005,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*********************************************************************** - VPOINT(1:NUM) = VECT(1:NUM) - 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+SIGN(.0005,TBAR),SDT,ABAR,SDALT,SBAR, - $ SDS+SIGN(.0005,SDS),CTEMP+SIGN(.0005,CTEMP), - $ CTSD+SIGN(.0005,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 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+SIGN(.0005,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,'"') - ENDDO - ELSE - PRINT 6472 - 6472 FORMAT(7X,'DIR SPD U V DELU DELV D VECT ', - $ 'SSDN ALT TEMP TIME KBAD ISTCPT TAGS') - DO 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+SIGN(.0005,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,'"') - ENDDO - 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: NP22 DATE: 1994-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 1994-01-01 P. JULIAN (W/NMC00) -- ORIGINAL AUTHOR -C 1994-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: FORTRAN 90 -C MACHINE: IBM-SP -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: NP22 DATE: 1999-08-23 -C -C ABSTRACT: USES EFFICIENT SORT ALGORITHM TO PRODUCE INDEX SORT LIST -C FOR A 32-CHARACTER ARRAY. DOES NOT REARRANGE THE FILE. -C -C PROGRAM HISTORY LOG: -C 1993-06-05 R KISTLER --- FORTRAN VERSION OF C-PROGRAM -C 1993-07-15 P. JULIAN ---- MODIFIED TO SORT 12-CHARACTER ARRAY -C 1994-08-25 D. A. KEYSER - MODIFIED TO SORT 16-CHARACTER ARRAY -C 1995-05-30 D. A. KEYSER - TESTS FOR < 2 ELEMENTS IN SORT LIST, -C IF SO RETURNS WITHOUT SORTING (BUT FILLS INDX ARRAY) -C 1999-08-23 D. A. KEYSER - EXPANDED CHARACTER ARRAY FROM 16 TO 32 -C BYTES (ALLOWS HIGHER ORDERS TO BE INCLUDED IN SORT) -C -C USAGE: CALL INDEXC(N,CARRIN,INDX) -C INPUT ARGUMENT LIST: -C N - SIZE OF ARRAY TO BE SORTED -C CARRIN - 32-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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE INDEXC(N,CARRIN,INDX) - CHARACTER*32 CARRIN(N),CC - INTEGER INDX(N) - DO J = 1,N - INDX(J) = J - ENDDO -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: NP22 DATE: 1995-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 1993-06-05 R KISTLER -- FORTRAN VERSION OF C-PROGRAM -C 1995-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: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE INDEXF(N,IARRIN,INDX) - INTEGER INDX(N),IARRIN(N) - DO J = 1,N - INDX(J) = J - ENDDO -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 PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1994-08-25 -C -C ABSTRACT: READS THRU SUCCESSIVE BUFR MESSAGES UNTIL THE BUFR TABLE -C A ENTRY "AIRCFT" (CONVENTIONAL AIREP/PIREP AND ASDAR/AMDAR/TAMDAR -C AIRCRAFT REPORTS) IS FOUND IN A PREPBUFR FILE. RETURNS THE DATE -C OF THIS MESSAGE TO THE CALLING PROGRAM. -C -C PROGRAM HISTORY LOG: -C 1994-08-25 D. A. KEYSER -- ORIGINAL AUTHOR -C -C USAGE: CALL DBUFR(IDATEP) -C OUTPUT ARGUMENT LIST: -C IDATEP - DATE FROM FIRST TABLE A "AIRCFT" MESSAGE (YYMMDDHH) -C -C INPUT FILES: -C UNIT 14 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE DBUFR(IDATEP) - CHARACTER*8 SUBSET - COMMON/TSTACAR/KTACAR - CALL DATELEN(10) - CALL OPENBF(14,'IN',14) - 10 CONTINUE - CALL READMG(14,SUBSET,IDATEP,IRET) - IF(IRET.NE.0) GO TO 999 - IF(SUBSET.EQ.'AIRCAR ') KTACAR = KTACAR + 1 - IF(SUBSET.NE.'AIRCFT ') GO TO 10 -cppppp - print * ,' ' - print *, 'First AIRCFT message found ... ' - print *,'PREPBUFR File Sec. 1 message date (IDATEP) = ',IDATEP -cppppp - IF(IDATEP.LT.1000000000) THEN - -C If 2-digit year returned in IDATEP, must use "windowing" technique -C to create a 4-digit year - -C IMPORTANT: IF DATELEN(10) IS CALLED, THE DATE HERE SHOULD ALWAYS -C CONTAIN A 4-DIGIT YEAR, EVEN IF INPUT FILE IS NOT -C Y2K COMPLIANT (BUFRLIB DOES THE WINDOWING HERE) - - PRINT *, '##PREPACQC - THE FOLLOWING SHOULD NEVER HAPPEN!!!!!' - PRINT *, '##PREPACQC - 2-DIGIT YEAR IN IDATEP RETURNED FROM ', - $ 'READMG (IDATEP IS: ',IDATEP,') - USE WINDOWING TECHNIQUE ', - $ 'TO OBTAIN 4-DIGIT YEAR' - IF(IDATEP/1000000.GT.20) THEN - IDATEP = 1900000000 + IDATEP - ELSE - IDATEP = 2000000000 + IDATEP - ENDIF - PRINT *, '##PREPACQC - CORRECTED IDATEP WITH 4-DIGIT YEAR, ', - $ 'IDATEP NOW IS: ',IDATEP - ENDIF - RETURN - 999 CONTINUE -C PREPBUFR DATA SET CONTAINS NO "AIRCFT" TABLE A MSGS -- STOP 4 !!! - PRINT 14 - 14 FORMAT(/' PREPBUFR DATA SET CONTAINS NO "AIRCFT" TABLE A ', - $ 'MESSAGES - STOP 4'/) - CALL CLOSBF(14) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(4) - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: IBUFR DECODES ACFT OBS. FROM PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2008-07-30 -C -C ABSTRACT: DECODES A CONVENTIONAL AIREP/PIREP OR ASDAR/AMDAR/TAMDAR -C AIRCRAFT OBSERVATION FROM A TABLE A ENTRY "AIRCFT" MESSAGE IN A -C PREPBUFR FILE FOR EACH CALL. IF ALL SUBSETS HAVE BEEN DECODED IN -C A MESSAGE THE NEXT TABLE A ENTRY "AIRCFT" MESSAGE IN READ IN AND -C DECODED. A RETURN 1 OCCURS WHEN ALL TABLE A ENTRY "AIRCFT" MESSAGES -C HAVE 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 1994-08-25 D. A. KEYSER -- ORIGINAL AUTHOR -C 1995-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 1995-07-06 D. A. KEYSER -- FOR ASDAR/AMDAR: CHECKS "TSB" MNENOMIC -C FOR VALUE OF "2", IF SO MEANS REPORT HAS A MISSING -C PHASE OF FLIGHT INDICATOR AND STORES A "7" IN THE -C CHARACTER*1 VARIABLE LATER CHECKED BY MAIN PROGRAM -C 1996-10-18 D. A. KEYSER -- NOW CLOSES INPUT BUFR DATA SET AFTER ALL -C REPORTS HAVE BEEN READ IN BY SUBR. IBUFR, UPDATED BUFRLIB -C CAUSES PGM TO ABORT WITH CALL TO OPENBF IN SUBR. OBUFR -C W/O THIS FIX -C 2002-11-20 D. A. KEYSER -- EXPANDED CHARACTER QMARKI FROM 4 TO 5 -C BYTES, WHERE BYTE 5 HOLDS "P" OR "H" FOR TEMP SDM PURGE -C OR KEEP FLAG - BYTE 1 HOLDS "P" OR "H" EXCLUSIVELY FOR -C WIND SDM PURGE OR KEEP FLAGS, USED TO BE COMBINED FOR -C WIND AND TEMP, BUT REMOVED ASSUMPTION THAT AN SDM PURGE -C ON TEMP ONLY ALSO RESULTS IN AN SDM PURGE ON WIND, THERE -C IS ALSO NO LONGER ANY RELATIONSHIP BETWEEN AN SDM KEEP ON -C WIND VS. A KEEP ON TEMP - THEY ARE INDENDENDENT OF EACH -C OTHER -C 2008-07-30 D. A. KEYSER -- RECEIPT TIME TEST IS NO LONGER DONE FOR -C TAMDAR REPORTS (REGARDLESS OF SWITCH "RCPTST" BECAUSE -C TAMDAR REPORTS CAN BE RESENT MANY TIMES OVER AND THE -C RECEIPT TIME FOR VERY LATE (E.G., T-12 NDAS) RUNS MAY -C INCORRECTLY DISPLAY WHAT LOOKS LIKE A "STRANGE" RECEIPT -C TIME); IN RESPONSE TO CHANGE FROM SINGLE LEVEL TO -C DELAYED REPLICATION FOR "AIRCFT" REPORT LEVEL DATA NOW IN -C PREPBUFR FILE (IN PREPARATION FOR NRL AIRCRAFT QC PROGRAM -C WHICH WILL REPLACE THIS PROGRAM AND CAN GENERATE AIRCRAFT -C "PROFILES"), RECEIPT TIME (RCT) (WHICH IS NOW PART OF -C LEVEL DATA) IS NO LONGER RETRIEVED IN SAME CALL TO UFBINT -C AS REMAINING SINGLE-LEVEL HEADER DATA (TO AVOID BUFRLIB -C 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 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE IBUFR(ALTF,DIRF,SPDF,TMPF,*) - SAVE - CHARACTER*1 CIQMMK(10),CF,PF - CHARACTER*5 QMARKI - CHARACTER*8 SUBSET,IDENT - CHARACTER*40 HEADR,OBLVL,FCLVL - REAL(8) HDR6,OBS(8),HDR(9),FST_8(4),RCT - REAL ACAT(9),FST(4) - COMMON/CBUFR/IDENT,IRCTME,RDATA(1608),KIX,QMARKI,CF,PF - COMMON/STDATE/IDATE(5) - EQUIVALENCE (IDENT,HDR6),(IRPTYP,RDATA(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 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 - IF(IFLAG.EQ.1) GO TO 45 - RDATA = XMSG - 30 CONTINUE - CALL READSB(14,IRET) - IF(IRET.NE.0) THEN - 20 CONTINUE - CALL READMG(14,SUBSET,IDATEP,IRET) - IF(IRET.NE.0) THEN -C NON-ZERO IRET IN READMG MEANS ALL BUFR MESSAGES IN FILE HAVE BEEN READ -C FILE WILL BE CLOSED - PRINT 101 - 101 FORMAT(/5X,'===> PREPBUFR DATA SET IN UNIT 14 SUCCESSFULLY', - $ ' CLOSED FROM INITIAL READ OF AIRCFT OBS.') - CALL CLOSBF(14) - RETURN 1 - END IF - IF(SUBSET.NE.'AIRCFT ') GO TO 20 - GO TO 30 - END IF - CALL UFBINT(14,HDR,9,1,N1LEV,HEADR) - CALL UFBINT(14,OBS,8,1,NLEV ,OBLVL) - CALL UFBINT(14,FST_8,4,1,NLEV2,FCLVL); FST=FST_8 - 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 - IF(ILOOP.EQ.2) THEN -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) - IF(HDR(9).EQ.SQNL) GO TO 40 - ILOOP = 1 - IFLAG = 1 - RETURN - END IF - 45 CONTINUE -C CONSTRUCT OBSERVATION HEADER(ONLY DONE FOR 1ST DECODED REPORT "PIECE") - CF = '-' - PF = '-' - QMARKI = '---C-' -C RDATA(1) = MIN0(IMSG,NINT(HDR(1)*100.)) -C RDATA(2) = MIN0(IMSG,NINT(36000.-(HDR(2)*100.))) -C IRCTME = MIN0(IMSG,NINT(RCT*100.)) -C NDT = MIN0(IMSG,NINT(HDR(4)*100.)) - RDATA(1) = NINT(MIN(99999._8,HDR(1)*100.)) - RDATA(2) = NINT(MIN(99999._8,(36000.-(HDR(2)*100.)))) - IRCTME = NINT(MIN(99999._8,RCT*100.)) - NDT = NINT(MIN(99999._8,HDR(4)*100.)) - RDATA(4) = NDT + (IDATE(4) * 100) - RDATA(4) = MOD(NINT(RDATA(4)),2400) - IF(NINT(RDATA(4)).LT.0) RDATA(4) = NINT(2400. + RDATA(4)) - IF(NINT(HDR(5)).EQ.1) CF = 'C' - IF(NINT(HDR(5)).EQ.2) PF = '7' -C IRPTYP = MIN0(99,NINT(HDR(7))) - IRPTYP = NINT(MIN(99._8,HDR(7))) - HDR6 = HDR(6) - KIX = HDR(8) - 40 CONTINUE - IF(KI.EQ.2) THEN -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) - IF(MAX(FST_8(1),FST_8(2)).LT.XMSG) THEN - IF(MAX(OBS(7),OBS(8)).LT.XMSG.AND.(ABS(RDATA(4)- - $ REAL(IDATE(4)*100.)).LE.333..OR.(RDATA(4)- - $ REAL(IDATE(4)*100.)).GE.2067.)) THEN - VDIF = SQRT((FST_8(1)-OBS(7))**2+(FST_8(2)-OBS(8))**2)*1.9425 - QMARKI(4:4) = 'Z' - DO J = 1,9 - IF(VDIF.LT.ACAT(J)) THEN - QMARKI(4:4) = CIQMMK(J) - GO TO 175 - END IF - ENDDO - 175 CONTINUE - END IF -C CONSTRUCT FCST WIND DIR. (DEG) & SPD (KTS) FROM FCST WIND COMPONENTS - ISUNIT = 1 - CALL CMDDFF(ISUNIT,FST(1),FST(2),DIRF,SPDF) - DIRF = NINT(DIRF) - SPDF = NINT(SPDF) - END IF -C RDATA(43) HOLDS PRESSURE ALTITUDE (METERS) -C RDATA(43) = MIN0(IMSG,NINT(OBS(1))) - RDATA(43) = NINT(MIN(99999._8,OBS(1))) -C ALTF HOLDS FORECAST PRESSURE ALTITUDE (METERS) - IF(FST_8(4).LT.XMSG) ALTF = NINT(FST_8(4)) -C RDATA(46) HOLDS WIND DIRECTION (DEGREES) -C RDATA(46) = MIN0(IMSG,NINT(OBS(3))) - RDATA(46) = NINT(MIN(99999._8,OBS(3))) -C RDATA(46) HOLDS WIND SPEED (KNOTS) -C RDATA(47) = MIN0(IMSG,NINT(OBS(4))) - RDATA(47) = NINT(MIN(99999._8,OBS(4))) -C QMARKI(1:1) HOLDS SDM WIND PURGE FLAG (IF APPLICABLE) -- OR -- -C HOLDS SDM WIND KEEP FLAG (IF APPLICABLE) - IF(NINT(OBS(6)).EQ.14) THEN - QMARKI(1:1) = 'P' - ELSE IF(NINT(OBS(6)).EQ.0) THEN - QMARKI(1:1) = 'H' - END IF - ELSE -C CONSTRUCT MASS PART OF OBSERVATION FROM DECODED MASS REPORT "PIECE" -C -C RDATA(44) HOLDS TEMPERATURE (DEGREES CELSIUS X 10) -C RDATA(44) = MIN0(IMSG,NINT(OBS(2)*10.)) - RDATA(44) = NINT(MIN(99999._8,OBS(2)*10.)) -C TMPF HOLDS FORECAST TEMPERATURE (DEGREES CELSIUS X 10) - IF(FST_8(3).LT.XMSG) TMPF = NINT(FST_8(3) * 10.) -C QMARKI(5:5) HOLDS SDM TEMP PURGE FLAG (IF APPLICABLE) -- OR -- -C HOLDS SDM TEMP KEEP FLAG (IF APPLICABLE) -C (NOTE: IF ONLY SDM PURGE FLAG ON WIND, PREVIOUS PREPOBS_PREPDATA -C PROGRAM WILL ALSO SET TEMP Q.M. AS SDM PURGE) - IF(NINT(OBS(5)).EQ.14) THEN - QMARKI(5:5) = 'P' - ELSE IF(NINT(OBS(5)).EQ.0) THEN - QMARKI(5:5) = 'H' - END IF - END IF - IF(ILOOP.EQ.1) THEN -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) - SQNL = HDR(9) - ILOOP = 2 - GO TO 30 - END IF -C IF TWO "PIECES" HAVE BEEN DECODED IN THIS CALL, READY TO RETURN -C COMPLETE AIRCRAFT OBSERVATION TO CALLING PROGRAM - ILOOP = 1 - IFLAG = 0 - RETURN -C----------------------------------------------------------------------- - 999 CONTINUE -C THE NUMBER OF DECODED LEVELS IS NOT 1!! -- STOP 70 - PRINT 217 - 217 FORMAT(/' THE NUMBER OF DECODED LEVELS FOR A REPORT IS NOT 1 -- ', - $ 'STOP 70'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(70) -C----------------------------------------------------------------------- - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: OBUFR WRITES AIRCRAFT RPTS TO PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2008-07-30 -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 PREPBUFR -C FILE TO THE OUTPUT PREPBUFR 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 ON AN OBS THAT WAS NOT -C ORIGNALLY "BAD"). IF SO, PUSHES DOWN TEMPERATURE OR WIND STACKED -C EVENTS AND RECORDS THIS EVENT (REASON CODE) ALONG WITH THE NEW -C QUALITY MARKER PRIOR TO WRITING THE SUBSET TO THE OUTPUT PREPBUFR -C FILE. WILL ALSO UPDATE LAT/LON IF IT WAS CHANGED DUE TO A WAYPOINT -C ERROR (THIS IS NOT A STACKED EVENT, HOWEVER). -C -C PROGRAM HISTORY LOG: -C 1994-08-25 D. A. KEYSER -- ORIGINAL AUTHOR -C 1995-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 1995-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 2004-11-16 D. A. KEYSER -- NOW CALLS BUFRLIB ROUTINE "UFBQCD" TO GET -C PROGRAM CODE FOR THIS Q.C. STEP ("PREPACQC") RATHER THAN -C HARDWIRING IT TO 7 AS BEFORE -C 2008-07-30 D. A. KEYSER -- PRIOR TO WRITING OUT EVENT, TESTS ORIG. T -C & W QM'S - IF > 3, WILL NOT WRITE OUT EVENT (HONORS -C ORIGINAL T & W QM'S IF BAD), THIS NEEDED BECAUSE TAMDAR -C AND CANADIAN AMDAR CURRENTLY HAVE T & W QM=9 COMING IN -C (MISSING OBS ERROR) WHICH CODE WAS IGNORING (AND WRITING -C OUT EVENT WITH GOOD QM MOST OF THE TIME - THIS CAUSED -C OIQC TO USE THESE OBS IN ITS DECISION MAKING PROCESS - -C THESE OBS ARE CURRENTLY ONLY MONITORED BY GSI AND SHOULD -C NOT BE CONSIDERED BY OIQC) -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 - PREPBUFR FILE CONTAINING ALL DATA -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C UNIT 61 - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACFT QC) -C -C REMARKS: CALLED BY MAIN PROGRAM. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE OBUFR(KOUNT) - PARAMETER (IRMX= 80000) - PARAMETER (ISIZE= 16) - LOGICAL LTEST,DOSPOB - CHARACTER*1 CHRQM(6) - CHARACTER*8 LAST,ACID,AAID(IRMX),SUBSET,POSITN,HEADR - CHARACTER*14 TAG,STAG(IRMX) - CHARACTER*20 QM1LVL,QM2LVL - REAL(8) HDR(2),POS(2),QMS1(4),QMS2(5) - REAL RQM(6),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/OUTPUT/KNTOUT(5) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),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 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) - ENDDO -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 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) - ENDDO - CALL DATELEN(10) - CALL OPENBF(14,'IN',14) - PRINT 200 - 200 FORMAT(/5X,'+++> PREPBUFR 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,'+++> PREPBUFR 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,' <==') - -C GET THE "PROGRAM CODE" CORRESPONDING TO "PREPACQC" - CALL UFBQCD(14,'PREPACQC',PCODE) - - 10 CONTINUE - -C READ IN NEXT BUFR MESSAGE FROM INPUT FILE - CALL READMG(14,SUBSET,IDATEP,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,PCODE) - 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,'===> PREPBUFR DATA ' - $,'SET IN UNIT 14 SUCCESSFULLY CLOSED FROM FINAL READ OF ALL OBS') - CALL CLOSBF(61) - PRINT 9102 - 9102 FORMAT(/5X,'===> PREPBUFR 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,PCODE) - 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,IDATEP - 105 FORMAT(/' ===> NEXT MESSAGE IN OUTPUT PREPBUFR DATA SET IN ', - $ 'UNIT 61 HAS NEW TABLE A ENTRY OF "',A6,'" -- DATE IS',I11) - 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,IDATEP) - 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 IBNDA = 1,5 - IF(ALAT(KKK).LT.(PHIACF(IBNDA+1)-0.005)) GO TO 6701 - ENDDO - 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 -C (UNLESS ORIGINAL TEMP. QM IS "BAD", THEN DON'T WRITE OUT EVENT) - CALL UFBINT(14,QMS1,4,1,N1LEV,QM1LVL) - IF(QMS1(2).GT.3) THEN - IF(QMS1(2).LT.10) THEN - WRITE(TAG(KKK)(2:2),'(I1)') NINT(QMS1(2)) - ELSE IF(QMS1(2).EQ.10) THEN - TAG(KKK)(2:2) = 'a' - ELSE IF(QMS1(2).EQ.11) THEN - TAG(KKK)(2:2) = 'b' - ELSE IF(QMS1(2).EQ.12) THEN - TAG(KKK)(2:2) = 'c' - ELSE IF(QMS1(2).EQ.13) THEN - TAG(KKK)(2:2) = 'd' - ELSE IF(QMS1(2).EQ.14) THEN - TAG(KKK)(2:2) = 'e' - ELSE - TAG(KKK)(2:2) = 'f' - END IF - TAG(KKK)(13:13) = '8' - ITEVNT(KKK) = 0 - GO TO 2203 - END IF - 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) = PCODE - 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 I = 1,6 - IF(TAG(KKK)(2:2).EQ.CHRQM(I)) THEN - QMS1(2) = RQM(I) - GO TO 203 - END IF - ENDDO - 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) = PCODE - 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 -C (UNLESS ORIGINAL WIND QM IS "BAD", THEN DON'T WRITE OUT EVENT) - CALL UFBINT(14,QMS2,5,1,N1LEV,QM2LVL) - IF(QMS2(2).GT.3) THEN - IF(QMS2(2).LT.10) THEN - WRITE(TAG(KKK)(4:4),'(I1)') NINT(QMS2(2)) - ELSE IF(QMS2(2).EQ.10) THEN - TAG(KKK)(4:4) = 'a' - ELSE IF(QMS2(2).EQ.11) THEN - TAG(KKK)(4:4) = 'b' - ELSE IF(QMS2(2).EQ.12) THEN - TAG(KKK)(4:4) = 'c' - ELSE IF(QMS2(2).EQ.13) THEN - TAG(KKK)(4:4) = 'd' - ELSE IF(QMS2(2).EQ.14) THEN - TAG(KKK)(4:4) = 'e' - ELSE - TAG(KKK)(4:4) = 'f' - END IF - TAG(KKK)(14:14) = '8' - IWEVNT(KKK) = 0 - GO TO 2203 - END IF - 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) = PCODE - 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 I = 1,6 - IF(TAG(KKK)(4:4).EQ.CHRQM(I)) THEN - QMS2(2) = RQM(I) - GO TO 303 - END IF - ENDDO - 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) = PCODE - 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 - - 2203 CONTINUE - -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,F8.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!! -- STOP 70 - PRINT 217 - 217 FORMAT(/' THE NUMBER OF DECODED HEADER AND/OR OBS. LEVELS FOR', - $ ' A REPORT IS NOT 1 -- STOP 70'/) - CALL W3TAGE('PREPOBS_PREPACQC') - CALL ERREXIT(70) -C----------------------------------------------------------------------- - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C . . . . -C SUBPROGRAM: SBUFR WRITES SUPEROB RPTS TO PREPBUFR FILE -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 2004-11-16 -C -C ABSTRACT: ENCODES SUPEROB AIRCRAFT MASS AND WIND REPORTS INTO THE -C OUTPUT PREPBUFR 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 1994-08-25 D. A. KEYSER -- ORIGINAL AUTHOR -C 1995-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 2004-11-16 D. A. KEYSER -- ADDED INPUT ARGUMENT "PCODE" WHICH HOLDS -C PROGRAM CODE FOR THIS Q.C. STEP ("PREPACQC"), BEFORE IT -C WAS HARDWIRED TO 7 -C -C USAGE: CALL SBUFR(LTEST,COUNT,IRECOL,ISUBO,ISUBOT,PCODE) -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 PREPBUFR DATA SET -C ISUBO - CURRENT NUMBER OF SUBSETS THAT HAVE BEEN WRITTEN INTO -C - CURRENT RECORD (MESSAGE) IN PREPBUFR DATA SET -C ISUBOT - TOTAL NUMBER OF SUBSETS THAT HAVE BEEN WRITTEN INTO -C - PREPBUFR DATA SET PRIOR TO THE CURRENT RECORD -C PCODE - PROGRAM CODE CORRESPONDING TO THIS Q.C. STEP -C - ("PREPACQC") -C -C OUTPUT ARGUMENT LIST: -C ISUBOT - TOTAL NUMBER OF SUBSETS THAT HAVE BEEN WRITTEN INTO -C - PREPBUFR DATA SET PRIOR TO THE CURRENT RECORD -C -C OUTPUT FILES: -C UNIT 06 - PRINTOUT -C UNIT 61 - PREPBUFR FILE CONTAINING ALL DATA (NOW WITH ACFT QC -C - AND SUPEROBS) -C -C REMARKS: CALLED BY SUBROUTINE OBUFR. -C -C ATTRIBUTES: -C LANGUAGE: FORTRAN 90 -C MACHINE: IBM-SP -C -C$$$ - SUBROUTINE SBUFR(LTEST,COUNT,IRECOL,ISUBO,ISUBOT,PCODE) - PARAMETER (ISUP= 4000) - 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(8) HDR1,HDR(10),OBS(8),QMS(4),EVN(8),QFLG(5),FST_8(4) - REAL 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/STDATE/IDATE(5) - COMMON/INPT/DOSPOB,DOACRS,TMAXO,TMINO,TIMINC,WAYPIN,INIDST,IFLGUS, - $ JAMASS(6),JAWIND(6),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 PREPBUFR 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. MEXICO/SO', - $ '.ONTARIO WILL ALSO BE FLAGGED, NO. ACARS MSGS PREV=',I5,' <=='/) - 323 FORMAT(8X,'==> SUPEROBED REPORTS OVER U.S. MAINLAND/G. MEXICO/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) = PCODE - 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) = PCODE - 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) = PCODE - 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 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_8(4) = SSHGTF(I) -C DETERMINE LATITUDE BAND INDEX (IBNDA) - DO IBNDA = 1,5 - IF(HDR(3).LT.(PHIACF(IBNDA+1)-0.005)) GO TO 6701 - ENDDO - 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_8(3) = SSTMPF(I)/10. - IF(ABS(HDR(4)).LE.3.33) THEN - TDIF = ABS(FST_8(3)-OBS(2)) - SSMARK(I)(3:3) = 'Z' - DO J = 1,9 - IF(NINT(TDIF*10.).LT.LCAT(J)) THEN - SSMARK(I)(3:3) = CIQMMK(J) - GO TO 1175 - END IF - ENDDO - 1175 CONTINUE - END IF - END IF - QMS(3) = 1. - EVN(5) = PCODE - 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_8,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_8(1)=(-SSSPDF(I)* 0.5148) *SIN(SSDIRF(I)*0.017453293) - FST_8(2)=(-SSSPDF(I)* 0.5148) *COS(SSDIRF(I)*0.017453293) - IF(ABS(HDR(4)).LE.3.33) THEN - VDIF=SQRT((FST_8(1)-OBS(5))**2+(FST_8(2)-OBS(6))**2)*1.9425 - SSMARK(I)(4:4) = 'Z' - DO J = 1,9 - IF(VDIF.LT.ACAT(J)) THEN - SSMARK(I)(4:4) = CIQMMK(J) - GO TO 175 - END IF - ENDDO - 175 CONTINUE - END IF - END IF - QMS(2) = 1. - EVN(7) = PCODE - 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_8,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 - ENDDO - RETURN - END -C$$$ SUBPROGRAM DOCUMENTATION BLOCK -C -C SUBPROGRAM: CMDDFF CONVERTS WIND U/V COMPONENTS TO DIR/SPD -C PRGMMR: D. A. KEYSER ORG: NP22 DATE: 1995-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 1995-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: FORTRAN 90 -C MACHINE: IBM-SP -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 +c SYSTEM: - SYSTEM +c W3NCO: - ERREXIT W3TAGB W3TAGE W3MOVDAT MOVA2I W3FI04 +c W3EMC: - W3FC05 ORDERS +c BUFRLIB: - IREADMG IREADSB UFBINT UFBSEQ UFBEVN READNS IBFMS +c - COPYMG OPENMB UFBCPY WRITSB WRITLC CLOSMG DATELEN +c - OPENBF CLOSBF UFBQCD SETBMISS GETBMISS +c +c Exit states: +c Cond = 0 - successful run +c 4 - no aircraft reports of any type read in +c 23 - unexpected return code from readns; problems reading BUFR file +c 31 - indexing problem encountered when trying to match QC'd data in arrays to +c mass and wind pieces in original PREPBUFR file (subroutine +c output_acqc_noprof) +c 59 - nlvinprof is zero coming into subroutine sub2mem_mer (should never +c happen!) +c 61 - index "j is .le. 1 meaning "iord" array underflow (should never happen!) +c (subroutine sub2mem_mer) +c 69 - row number for input data matrix is outside range of 1-34 (subroutine +c tranQCflags) +c 79 - characters on this machine are not ASCII, conversion of quality flag to +c row number in subroutine tranQCflags cannot be made +c 98 - too many flights in input PREPBUFR file, must increase size of parameter +c "maxflt" (in some places code continues but in this case can't be sure +c continuing on w/o processing any more data would turn out ok) +calloc 99 - unable to allocate one or more array +c +c Remarks: +c Input Namelist switches (namelist &nrlacqcinput)): +c trad - time window radius in hours for outputting reports (if l_otw=T) +c (default=3.0) +c l_otw - logical: +c TRUE - eliminate reports outside the time window radius +c +/- trad when writing out reports +c +c FALSE - DO NOT eliminate reports outside the time window +c radius +/- trad when writing out reports +c (default=FALSE) +c l_nhonly - logical: +c TRUE - eliminate reports outside tropics & N. Hemisphere +c when writing out reports +c FALSE - DO NOT eliminate reports outside tropics & N. +c Hemisphere when writing out reports +c (default=FALSE) +c l_doprofiles - logical: +c TRUE - create merged raob lookalike QC'd profiles from +c aircraft ascents and descents (always) and output +c these as well as QC'd merged single(flight)-level +c aircraft reports not part of any profile (when +c l_prof1lvl=T) to a PREPBUFR-like file +c **CAUTION: Will make code take quite a bit longer +c to run! +c FALSE - SKIP creation of merged raob lookalike QC'd +c profiles from aircraft ascents and descents into +c PREPBUFR-like file +c (default=FALSE) +c l_allev_pf - logical: +c TRUE - process latest (likely NRLACQC) events plus all +c prior events into profiles PREPBUFR-like file +c **CAUTION: More complete option, but will make code +c take longer to run! +c FALSE - process ONLY latest (likely NRLACQC) events into +c profiles PREPBUFR-like file +c (Note 1: Hardwired to FALSE if l_doprofiles=FALSE) +c {Note 2: All pre-existing events plus latest (likely +c NRLACQC) events are always encoded into full +c PREPBUFR file} +c (default=FALSE) +c l_prof1lvl - logical: +c TRUE - encode merged single(flight)-level aircraft reports +c with NRLACQC events that are not part of any +c profile into PREPBUFR-like file, along with merged +c profiles from aircraft ascents and descents +c **CAUTION: Will make code take a bit longer to run! +c FALSE - DO NOT encode merged single(flight)-level aircraft +c reports with NRLACQC events that are not part of +c any profile into PREPBUFR-like file +c - only merged profiles from aircraft ascents and +c descents will be encoded into this file +c (Note: Applicable only when l_doprofiles=TRUE) +c (default=FALSE) +c l_mandlvl - logical: +c TRUE - interpolate obs data to mandatory levels in profile +c generation +c FALSE - DO NOT interpolate obs data to mandatory levels in +c profile generation +c (Note: Applicable only when l_doprofiles=TRUE) +c (default=TRUE) +c tsplines - logical: +c TRUE - use Jim Purser's tension-spline interpolation +c utility to generate aircraft vertical velocity rate +c in profile generation +c FALSE - use finite-difference method based on nearest +c neighboring pair of obs which are at least one +c minute apart to generate aircraft vertical velocity +c rate in profile generation +c (Note: Applicable only when l_doprofiles=TRUE) +c (default=TRUE) +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + program prepobs_prepacqc + + implicit none + +c ------------------------------ +c Parameter statements/constants +c ------------------------------ + integer inlun ! input unit number (for pre-prepacqc PREPBUFR file + ! containing all obs) + parameter (inlun = 11) + + integer extbl ! unit number for external table file (if used) + parameter (extbl = 12) + + integer outlun ! output unit number for post-PREPACQC PREPBUFR file + ! with added NRLACQC events + parameter (outlun=61) + + integer proflun ! output unit number for post-PREPACQC PREPBUFR-like + ! file containing merged profile reports (always) and + parameter (proflun=62) + + integer max_reps ! maximum number of input merged (mass + wind piece) + ! aircraft-type reports allowed + parameter (max_reps = 300000) + +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c replace above with this in event of future switch to dynamic memory allocation + +calloc integer max_reps ! original number of input merged (mass + wind piece) +calloc ! aircraft-type reports (obtained from first pass +calloc ! through input PREPBUFR file to get total for array +calloc ! allocation should = nrpts4QC_pre) +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + integer maxflt ! maximum number of flights allowed (inside NRL QC) + parameter (maxflt = 12500) + character*6 cmaxflt ! character form of maxflt + + integer imiss ! NRL integer missing value flag + parameter (imiss = 99999) + + real amiss ! NRL real missing value flag + parameter (amiss = -9999.) + + real*8 bmiss ! BUFR missing value + real*8 getbmiss ! Function to return current bmiss value from BUFRLIB + + real m2ft ! NRL conversion factor to convert m to ft + + parameter (m2ft = 3.28084) + +c ---------------------- +c Declaration statements +c ---------------------- + +c Indices/counters +c ---------------- + integer i,j ! loop indeces + + integer nrpts4QC_pre ! original number of input merged (mass + wind piece) + ! aircraft-type reports (read in from PREPBUFR file) + ! (after all is said and done, should equal nrpts4QC + + ! krej) + + integer nrpts4QC ! number of merged (mass + wind piece) reports going + ! through NRL QC code (initially equals nrpts4QC_pre, + ! then reduced as processing continues - ultimately + ! includes only "good" reports) + + integer krej ! number of merged (mass + wind piece) reports + ! ulimately rejected by NRL QC code + +c Observation variables required by the NRL aircraft QC routine +c ------------------------------------------------------------- + character*10 cdtg_an ! date-time group for analysis (YYYYMMDDCC) + + + character*11 c_qc(max_reps) ! character QC flags output from NRL QC code + ! 1st char - info about reject (if ob was rejected) + ! 2nd char - reason why time was rejected + ! 3rd char - reason why latitude was rejected + ! 4th char - reason why longitude was rejected + ! 5th char - reason why pressure/atitude was rejected + ! 6th char - readon why temperature was rejected + ! 7th char - reason why wind direction was rejected + ! 8th char - reason why wind speed was rejected + ! 9th char - reason why mixing ratio was rejected + ! 10th char - reason for blacklisting the aircraft + ! 11th char - info about flight phase + + character*25 csort(max_reps) ! variable (sort key) used for sorting data in NRL QC + ! code + + integer itype(max_reps) ! instrument (aircraft) type + real*8 alat(max_reps) ! latitude + +, alon(max_reps) ! longitude + real pres(max_reps) ! pressure + +, ht_ft(max_reps) ! altitude in feet + integer idt(max_reps) ! time in seconds to anal. time (- before, + after) + integer idp(max_reps) ! surface pressure change at ob location (not created + ! anywhere, set to missing) + integer ncep_qm_p(max_reps) ! NCEP PREPBUFR quality mark pressure (PQM) + +, ncep_rc_p(max_reps) ! NCEP PREPBUFR NRLACQC pressure event reason code(PRC) + +, ncep_qm_z(max_reps) ! NCEP PREPBUFR quality mark on altitude (ZQM) + +, ncep_rc_z(max_reps) ! NCEP PREPBUFR NRLACQC alt/hght event reason code(ZRC) + +, ncep_qm_t(max_reps) ! NCEP PREPBUFR quality mark on temperature (TQM) + +, ncep_rc_t(max_reps) ! NCEP PREPBUFR NRLACQC temperature evnt rea. code(TRC) + +, ncep_qm_q(max_reps) ! NCEP PREPBUFR quality mark on moisture (QQM) + +, ncep_rc_q(max_reps) ! NCEP PREPBUFR NRLACQC moisture reason code (QRC) + +, ncep_qm_w(max_reps) ! NCEP PREPBUFR quality mark on wind (WQM) + +, ncep_rc_w(max_reps) ! NCEP PREPBUFR NRLACQC wind event reason code (WRC) + +, ncep_rej(max_reps) ! NCEP PREPBUFR rejection indicator + + character*14 c_dtg(max_reps) ! full date-time group (yyyymmddhhmmss) + character*8 c_acftreg(max_reps) ! aircraft registration (tail) number (used in NRL QC + ! QC processing) + character*9 c_acftid(max_reps) ! aircraft flight number (used in NRL QC processing) + + real t_prcn(max_reps) ! temperature precision + +, ob_t(max_reps) ! temperature + +, ob_q(max_reps) ! moisture (specific humidity) + +, ob_dir(max_reps) ! wind direction + +, ob_spd(max_reps) ! wind speed + +, xiv_t(max_reps) ! temperature innovation/increment (ob-bg) + +, xiv_q(max_reps) ! specific humidity innovation/increment (ob-bg) + +, xiv_d(max_reps) ! wind direction innovation/increment (ob-bg) + +, xiv_s(max_reps) ! wind speed innovation/increment (ob-bg) + + integer ichk_t(max_reps) ! NRL QC flag for temperature ob + +, ichk_q(max_reps) ! NRL QC flag for specific humidity ob + +, ichk_d(max_reps) ! NRL QC flag for wind direction ob + +, ichk_s(max_reps) ! NRL QC flag for wind speed ob + +, nchk_t(max_reps) ! NCEP QC flag for temperature ob + +, nchk_q(max_reps) ! NCEP QC flag for specific humidity ob + +, nchk_d(max_reps) ! NCEP QC flag for wind direction ob + +, nchk_s(max_reps) ! NCEP QC flag for wind speed ob + +, phase(max_reps) ! phase of flight for aircraft + + logical l_minus9c(max_reps) ! true for MDCRS -9C temperatures + +c Pointers +c -------- + integer indx(max_reps) ! pointer index in NRL QC for good reports + +, in_bad(max_reps) ! pointer index in NRL QC for bad reports + +, isave(max_reps) ! second pointer index in NRL QC + +c ************************************************** +c All below are output from NRL acftobs_qc routine +c ************************************************** + +c Flight statistics +c ----------------- + character*8 creg_flt(maxflt) ! tail number for each flight + character*9 cid_flt(maxflt) ! flight id for each flight + +, cid_flt_old(maxflt) ! previous value of cid_flt + integer nobs_flt(maxflt) ! number of reports per flight + +, ntot_flt(maxflt) ! total number of reports per flight + +, ntot_flt_old(maxflt)! previous value of total num of reports per flt + +, nrej_flt(maxflt) ! number of reports rejected per flight + +, nrej_flt_old(maxflt)! previous value of num of reports rejected per flt + +, iobs_flt(maxflt) ! index for first report in each flight + +, kflight ! number of flights in dataset + logical l_newflt(maxflt) ! true if flight is new flight + +c Tail number statistics +c ---------------------- + character*8 creg_reg(maxflt) ! tail numbers + integer nobs_reg(maxflt,5) ! number of reports per tail number per type + +, ntot_reg(maxflt,5) ! total number of reports rejected per tail number + +, nrej_reg(maxflt,5) ! number of reports rejected per tail number + +, ntemp_reg(maxflt,5) ! number of reports with rejected temperature + +, nwind_reg(maxflt,5) ! number of reports with rejected wind + +, nwhol_reg(maxflt,5) ! number of reports with temperature in whole degrees + + character*10 creg_reg_tot(maxflt) ! master list of tail numbers + integer nobs_reg_tot(maxflt,5) ! number of reports per tail number + +, nwhol_reg_tot(maxflt,5) ! number of temperatures in whole degs/tail number + +, nrej_reg_tot(maxflt,5) ! number of reports rejected per tail number + +, ntemp_reg_tot(maxflt,5) ! number of temperatures rejected per tail number + +, nwind_reg_tot(maxflt,5) ! number of winds rejected per tail number + +, nrej_inv_tot(maxflt,5) ! number of reports rejected in subr. invalid + +, nrej_stk_tot(maxflt,5) ! number of reports rejected in subr. stkchek + +, nrej_grc_tot(maxflt,5) ! number of reports rejected in subr. grchek + +, nrej_pos_tot(maxflt,5) ! number of reports rejected in subr. poschek + +, nrej_ord_tot(maxflt,5) ! number of reports rejected in subr. ordchek + +, nrej_sus_tot(maxflt,5) ! number of reports rejected in suspect data check + + integer lead_t_tot(maxflt,11,2) ! distribution of temperature innovations + +, lead_d_tot(maxflt,11,2) ! distribution of wind direction innovations + +, lead_s_tot(maxflt,11,2) ! distribution of wind speed innovations + +, n_xiv_t(maxflt,2) ! number of temperature innovations + +, n_xiv_d(maxflt,2) ! number of wind direction innovations + +, n_xiv_s(maxflt,2) ! number of wind speed innovations + + real sum_xiv_t(maxflt,2) ! sum of temperature innovations + +, sum_xiv_d(maxflt,2) ! sum of wind direction innovations + +, sum_xiv_s(maxflt,2) ! sum of wind speed innovations + +, sumabs_xiv_t(maxflt,2) ! sum of absolute value of temperature innovations + +, sumabs_xiv_d(maxflt,2) ! sum of absolute value of wind dir. innovations + +, sumabs_xiv_s(maxflt,2) ! sum of absolute value of wind speed innovations + +c ************************************************** + +c Variables for sorting data by type, tail, flight, etc., including bad reports - will be +c used AFTER NRL QC code in the generation of profiles PREPBUFR-like profiles file +c --------------------------------------------------------------------------------------- + integer iob ! loop index + +, kidt ! idt + 100000 (converted to charcter c_idt and + ! added to csort_wbad sort key string) + +, iht_ft ! integer of ht_ft (converted to charcter c_ht_ft + ! and added to csort_wbad sort key string) + +, ilon ! integer of alon (converted to charcter c_lon + ! and added to csort_wbad sort key string) + +, ilat ! integer of alat (converted to charcter c_lat + ! and added to csort_wbad sort key string) + character*6 c_lon ! character form of ilon (added to csort_wbad + ! sort key string) + character*7 c_idt ! character form of kidt (added to csort_wbad + ! sort key string) + character*5 c_ht_ft ! character form of iht_ft (added to csort_wbad + ! sort key string) + +, c_lat ! character form of ilat (added to csort_wbad + ! sort key string) + character*4 c_type ! first 4 characters defining aircraft type + ! (added to csort_wbad sort key string) + character*1 c_qc11 ! value of 11th char in NRL c_qc string, + ! specifies whether report is part of an ascent, + ! descent, level leg, etc. (added to csort_wbad + ! sort key string) + character*16 c_insty_ob ! function - convers aircraft type to character + ! string ((added to csort_wbad sort key string) + character*40 csort_wbad(max_reps) ! variable (sort key) used to sort data after NRL + ! QC code - used in generation of profiles + ! PREPBUFR-like profiles file + integer indx_wbad(max_reps) ! sorted array index (specifies the order in + ! which reports should be written to the + ! PREPBUFR-like profiles file +c Namelist variables +c ------------------ + namelist /nrlacqcinput/ trad,l_otw,l_nhonly,l_doprofiles, + + l_allev_pf,l_prof1lvl,l_mandlvl,tsplines, + + l_ext_table,l_qmwrite + + real trad ! Time window radius for outputting reports (if l_otw=T) + logical l_otw ! T=eliminate reports outside the time window radius +/- trad + +, l_nhonly ! T=eliminate reports outside tropics & N. Hemisphere + +, l_doprofiles ! T=create merged raob lookalike QC'd profiles from aircraft + ! ascents and descents (always) and output these as well as + ! QC'd merged single(flight)-level aircraft reports not part + ! of any profile (when l_prof1lvl=T) to a PREPBUFR-like file + ! **CAUTION: Will make code take quite a bit longer to run! + ! F=skip creation of merged raob lookalike QC'd profiles from + ! aircraft ascents and descents into PREPBUFR-like file + +, l_allev_pf ! T=process latest (likely NRLACQC) events plus all prior + ! events into profiles PREPBUFR-like file + ! **CAUTION: More complete option, but will make code take + ! longer to run! + ! F=process ONLY latest (likely NRLACQC) events into profiles + ! PREPBUFR-like file + ! + ! Note 1: Hardwired to F if l_doprofiles=F + ! Note 2: All pre-existing events plus latest (likely NRLACQC) + ! events are always encoded into full PREPBUFR file) + +, l_prof1lvl ! T=encode merged single(flight)-level aircraft reports with + ! NRLACQC events that are not part of any profile into + ! PREPBUFR-like file, along with merged profiles from + ! aircraft ascents and descents + ! **CAUTION: Will make code take a bit longer to run! + ! F=do not encode merged single(flight)-level aircraft reports + ! with NRLACQC events that are not part of any profile into + ! PREPBUFR-like file - only merged profiles from aircraft + ! ascents and descents will be encoded into this file + ! Note : Applicable only when l_doprofiles=T + +, l_mandlvl ! T=interpolate to mandatory levels in profile generation + ! F=do not interpolate to mandatory levels in profile + ! generation + +, tsplines ! T=use tension-splines for aircraft vertical velocity + ! calculation + ! F=use finite-differencing for aircraft vertical velocity + ! calculation + ! Note : Applicable only when l_doprofiles=T + +, l_ext_table ! T=use external text table to define profile prepbufr format + ! F=take prepbufr format definition from input prepbufr file + +, l_qmwrite ! T=write NRL QMs in main prepbufr output file + ! F=omit NRL QMs from main prepbufr output file - use with old formats + +c Variables used to hold original aircraft data read from the input PREPBUFR file - necessary +c for carrying data through program so that it can be written to output profiles PREPBUFR- +c like file from memory instead of going back to input PREPBUFR file and re-reading that +c file before adding any QC events resulting from a decision made by the NRL QC routine (not +c applicable for case of single-level QC'd reports written back to full PREPBUFR file) +c -------------------------------------------------------------------------------------------- + integer mxnmev ! maximum number of events allowed in stack + parameter (mxnmev = 15) + + integer mxlv ! maximum number of report levels allowed in aircraft + ! profiles + parameter(mxlv = 255) + + + integer nevents(max_reps,6) ! array tracking number of events for variables for + ! each report: + ! 1 - number of pressure events + ! 2 - number of specific humidity events + ! 3 - number of temperature events + ! 4 - number of altitude events + ! 5 - number of wind (u/v) events + ! 6 - number of wind (direction/speed) events + integer nnestreps(4,max_reps) ! number of "nested replications" for TURB3SEQ, + ! PREWXSEQ, CLOUDSEQ, AFIC_SEQ + + real*8 pob_ev(max_reps,mxnmev) ! POB values for each report, including all events + +, pqm_ev(max_reps,mxnmev) ! PQM values for each report, including all events + +, ppc_ev(max_reps,mxnmev) ! PPC values for each report, including all events + +, prc_ev(max_reps,mxnmev) ! PRC values for each report, including all events + +, zob_ev(max_reps,mxnmev) ! ZOB values for each report, including all events + +, zqm_ev(max_reps,mxnmev) ! ZQM values for each report, including all events + +, zpc_ev(max_reps,mxnmev) ! ZPC values for each report, including all events + +, zrc_ev(max_reps,mxnmev) ! ZRC values for each report, including all events + +, tob_ev(max_reps,mxnmev) ! TOB values for each report, including all events + +, tqm_ev(max_reps,mxnmev) ! TQM values for each report, including all events + +, tpc_ev(max_reps,mxnmev) ! TPC values for each report, including all events + +, trc_ev(max_reps,mxnmev) ! TRC values for each report, including all events + +, qob_ev(max_reps,mxnmev) ! QOB values for each report, including all events + +, qqm_ev(max_reps,mxnmev) ! QQM values for each report, including all events + +, qpc_ev(max_reps,mxnmev) ! QPC values for each report, including all events + +, qrc_ev(max_reps,mxnmev) ! QRC values for each report, including all events + +, uob_ev(max_reps,mxnmev) ! UOB values for each report, including all events + +, vob_ev(max_reps,mxnmev) ! VOB values for each report, including all events + +, wqm_ev(max_reps,mxnmev) ! WQM values for each report, including all events + +, wpc_ev(max_reps,mxnmev) ! WPC values for each report, including all events + +, wrc_ev(max_reps,mxnmev) ! WRC values for each report, including all events + +, ddo_ev(max_reps,mxnmev) ! DDO values for each report, including all events + +, ffo_ev(max_reps,mxnmev) ! FFO values for each report, including all events + +, dfq_ev(max_reps,mxnmev) ! DFQ values for each report, including all events + +, dfp_ev(max_reps,mxnmev) ! DFP values for each report, including all events + +, dfr_ev(max_reps,mxnmev) ! DFR values for each report, including all events + + +, hdr(max_reps,15) ! SID XOB YOB DHR ELV TYP T29 TSB ITP SQN PROCN RPT + ! TCOR RSRD EXRSRD + +, acid(max_reps) ! ACID + +, rct(max_reps) ! RCT + + +, pbg(max_reps,3) ! POE PFC PFCMOD + +, zbg(max_reps,3) ! ZOE ZFC ZFCMOD + +, tbg(max_reps,3) ! TOE TFC TFCMOD + +, qbg(max_reps,3) ! QOE QFC QFCMOD + +, wbg(max_reps,5) ! WOE UFC VFC UFCMOD VFCMOD + + +, ppp(max_reps,3) ! PAN PCL PCS + +, zpp(max_reps,3) ! ZAN ZCL ZCS + +, tpp(max_reps,3) ! TAN TCL TCS + +, qpp(max_reps,3) ! QAN QCL QCS + +, wpp(max_reps,6) ! UAN VAN UCL VCL UCS VCS + + +, drinfo(max_reps,3) ! XOB YOB DHR + +, acft_seq(max_reps,2) ! PCAT POAF + + +, turb1seq(max_reps) ! TRBX + +, turb2seq(max_reps,4) ! TRBX10 TRBX21 TRBX32 TRBX43 + +, turb3seq(3,max_reps,5) ! DGOT HBOT HTOT + +, prewxseq(1,max_reps,5) ! PRWE + +, cloudseq(5,max_reps,5) ! VSSO CLAM CLTP HOCB HOCT + +, afic_seq(3,max_reps,5) ! AFIC HBOI HTOI + +, mstq(max_reps) ! MSTQ + +, cat(max_reps) ! CAT + +, rolf(max_reps) ! ROLF + + +, sqn(max_reps,2) ! SQN (1=SQN for mass, 2=SQN for wind) + +, procn(max_reps,2) ! PROCN (1=PROCN for mass, 2=PROCN for wind) + +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c add these in place of above declar. in event of future switch to dynamic memory allocation + +calloc character*11,allocatable :: c_qc(:) +calloc character*25,allocatable :: csort(:) +calloc integer,allocatable :: itype(:) +calloc real*8, allocatable :: alat(:) +calloc real*8, allocatable :: alon(:) +calloc real, allocatable :: pres(:) +calloc real, allocatable :: ht_ft(:) +calloc integer,allocatable :: idt(:) +calloc integer,allocatable :: idp(:) +calloc character*14,allocatable :: c_dtg(:) +calloc character*8, allocatable :: c_acftreg(:) +calloc character*9, allocatable :: c_acftid(:) +calloc real, allocatable :: t_prcn(:) +calloc real, allocatable :: ob_t(:) +calloc real, allocatable :: ob_q(:) +calloc real, allocatable :: ob_dir(:) +calloc real, allocatable :: ob_spd(:) +calloc real, allocatable :: xiv_t(:) +calloc real, allocatable :: xiv_q(:) +calloc real, allocatable :: xiv_d(:) +calloc real, allocatable :: xiv_s(:) +calloc integer,allocatable :: ichk_t(:) +calloc integer,allocatable :: ichk_q(:) +calloc integer,allocatable :: ichk_d(:) +calloc integer,allocatable :: ichk_s(:) +calloc integer,allocatable :: nchk_t(:) +calloc integer,allocatable :: nchk_q(:) +calloc integer,allocatable :: nchk_d(:) +calloc integer,allocatable :: nchk_s(:) +calloc integer,allocatable :: phase(:) +calloc logical,allocatable :: l_minus9c(:) +calloc integer,allocatable :: indx(:) +calloc integer,allocatable :: in_bad(:) +calloc integer,allocatable :: isave(:) +calloc character*40,allocatable :: csort_wbad(:) +calloc integer,allocatable :: indx_wbad(:) +calloc integer,allocatable :: nevents(:,:) +calloc integer,allocatable :: nnestreps(:,:) +calloc real*8,allocatable :: pob_ev(:,:) +calloc real*8,allocatable :: pqm_ev(:,:) +calloc real*8,allocatable :: ppc_ev(:,:) +calloc real*8,allocatable :: prc_ev(:,:) +calloc real*8,allocatable :: zob_ev(:,:) +calloc real*8,allocatable :: zqm_ev(:,:) +calloc real*8,allocatable :: zpc_ev(:,:) +calloc real*8,allocatable :: zrc_ev(:,:) +calloc real*8,allocatable :: tob_ev(:,:) +calloc real*8,allocatable :: tqm_ev(:,:) +calloc real*8,allocatable :: tpc_ev(:,:) +calloc real*8,allocatable :: trc_ev(:,:) +calloc real*8,allocatable :: qob_ev(:,:) +calloc real*8,allocatable :: qqm_ev(:,:) +calloc real*8,allocatable :: qpc_ev(:,:) +CAlloc real*8,allocatable :: qrc_ev(:,:) +calloc real*8,allocatable :: uob_ev(:,:) +calloc real*8,allocatable :: vob_ev(:,:) +calloc real*8,allocatable :: wqm_ev(:,:) +calloc real*8,allocatable :: wpc_ev(:,:) +calloc real*8,allocatable :: wrc_ev(:,:) +calloc real*8,allocatable :: ddo_ev(:,:) +calloc real*8,allocatable :: ffo_ev(:,:) +calloc real*8,allocatable :: dfq_ev(:,:) +calloc real*8,allocatable :: dfp_ev(:,:) +calloc real*8,allocatable :: dfr_ev(:,:) +calloc real*8,allocatable :: hdr(:,:) +calloc real*8,allocatable :: acid(:) +calloc real*8,allocatable :: rct(:) +calloc real*8,allocatable :: pbg(:,:) +calloc real*8,allocatable :: zbg(:,:) +calloc real*8,allocatable :: tbg(:,:) +calloc real*8,allocatable :: qbg(:,:) +calloc real*8,allocatable :: wbg(:,:) +calloc real*8,allocatable :: ppp(:,:) +calloc real*8,allocatable :: zpp(:,:) +calloc real*8,allocatable :: tpp(:,:) +calloc real*8,allocatable :: qpp(:,:) +calloc real*8,allocatable :: wpp(:,:) +calloc real*8,allocatable :: drinfo(:,:) +calloc real*8,allocatable :: acft_seq(:,:) +calloc real*8,allocatable :: turb1seq(:) +calloc real*8,allocatable :: turb2seq(:,:) +calloc real*8,allocatable :: turb3seq(:,:,:) +calloc real*8,allocatable :: prewxseq(:,:,:) +calloc real*8,allocatable :: cloudseq(:,:,:) +calloc real*8,allocatable :: afic_seq(:,:,:) +calloc real*8,allocatable :: mstq(:) +calloc real*8,allocatable :: cat(:) +calloc real*8,allocatable :: rolf(:) +calloc real*8,allocatable :: sqn(:,:) +calloc real*8,allocatable :: procn(:,:) + +c Variables for reading numeric data out of BUFR files via BUFRLIB +c ---------------------------------------------------------------- +calloc real*8 sqn_8 ! array holding BUFR subset sequence number from +calloc ! BUFRLIB call to input PREPBUFR file +calloc integer nlev ! number of report levels returned from BUFRLIB call +calloc Integer iret ! return code for call to BUFRLIB routine readns + +c Functions +c --------- +calloc integer ireadmg ! for reading messages +callo+, ireadsb ! for reading subsets + + +c Variables for BUFRLIB interface +c ------------------------------- +calloc character*8 mesgtype ! mesgtype of message +calloc integer mesgdate ! date time from BUFR message + +c Variables for determining whether consecutive reports are mass and wind pieces that belong +c together +c ------------------------------------------------------------------------------------------ +calloc logical l_match +calloc real sqn_current, sqn_next + +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +c Miscellaneous +c ------------- + real nrlacqc_pc ! PREPBUFR program code for the NRL PREPACQC step + + logical l_first_date ! true for first date (used inside NRL QC code) + data l_first_date /.true./ ! always initialize as T + + logical l_operational ! run program in operational mode if true + data l_operational /.true./ ! will get reset to F within acftobs_qc since + ! l_ncep=T; must be set to true here so that the + ! first l_operational=F section of the if block in + ! acftobs_qc.f will get skipped over + ! DAK: would code run faster if l_operational=F?, does it give + ! same answers I wonder ?? + logical l_pc ! true if running checkout at NRL (used inside NRL + ! QC code) + data l_pc /.false./ ! always set to F + logical l_last ! true if last time subroutine acftobs_qc is called + data l_last /.true./ ! DAK: I think this should be set to T + logical l_ncep ! run NRL QC code using NCEP preferences if true + data l_ncep /.true./ ! always set to T + +c Machine characteristics (obtained from W3FI04) +c ---------------------------------------------- + integer lwr ! machine word length in bytes (either 4 or 8) + +, ichtp ! machine charatcer type (either 0 for ASCII or 1 + ! for EBCDIC) + +, iendn ! machine Endian configuration (either 0 for Big- + ! Endian or 1 for Little-Endian) + +c ********************************************************************************** + +c Start program +c ------------- + call w3tagb('PREPOBS_PREPACQC',2016,344,1927,'NP22') + + write(*,*) + write(*,*) '************************************************' + write(*,*) 'Welcome to PREPOBS_PREPACQC, version 2016-12-09 ' + call system('date') + write(*,*) '************************************************' + write(*,*) + +C On WCOSS should always set BUFRLIB missing (BMISS) to 10E8 to avoid overflow when either an +C INTEGER*4 variable is set to BMISS or a REAL*8 (or REAL*4) variable that is missing is +C NINT'd +C ------------------------------------------------------------------------------------------- +ccccc call setbmiss(10E10_8) + call setbmiss(10E8_8) + bmiss = getbmiss() + print * + print *, 'BUFRLIB value for missing is: ',bmiss + print * + +c Initialize observation arrays +c ----------------------------- + c_qc = '-----------' + idp = imiss ! this is not created anywhere (even inside acftobs_qc) + +c Call W3FI04 to determine machine characteristics {word length (bytes), character type +c (ASCII or EBCDIC), and Endian-type (Big or Little)} +c ------------------------------------------------------------------------------------- + call w3fi04(iendn,ichtp,lwr) + print 2213, lwr, ichtp, iendn + 2213 format(/' ---> CALL TO W3FI04 RETURNS: LWR = ',I3,', ICHTP = ',i3, + + ', IENDN = ',I3/) + +c...................................................... + if(ichtp.ne.0) then + +C Characters on this machine are not ASCII!! -- stop 79 +c ----------------------------------------------------- + print 217 + 217 format(/5x,'++ CHARACTERS ON THIS MACHINE ARE NOT ASCII - STOP ', + + '79'/) + call w3tage('PREPOBS_PREPACQC') + call errexit(79) + endif +c...................................................... + +c Read in namelist nrlacqcinput, but set namelist defaults first +c -------------------------------------------------------------- + trad = 3.0 + l_otw = .false. + l_nhonly = .false. + l_doprofiles = .false. + l_allev_pf = .false. + l_prof1lvl = .false. + l_mandlvl = .true. + tsplines = .true. + l_ext_table = .false. + l_qmwrite = .true. + + read(5,nrlacqcinput,end=10) + 10 continue + write(6,nrlacqcinput) + + if(.not.l_doprofiles) l_allev_pf = .false. ! l_allev_pf always set to FALSE if profiles + ! are not being generated + + call datelen(10) + +c Open input PREPBUFR file (contains mass and wind reports for all data types, no NRLACQC +c events on reports in AIRCAR and AIRCFT message types) +c --------------------------------------------------------------------------------------- + call openbf(inlun,'IN',inlun) + print * + print'(" Opened input PREPBUFR file with all data, including ", + + "pre-NRLACQC aircraft data; unit number ",I0)', inlun + print * + +c Open output PREPBUFR file (will eventually be identical to input PREPBUFR file but with +c NRLACQC events on reports in AIRCAR and AIRCFT message types) +c --------------------------------------------------------------------------------------- + call openbf(outlun,'OUT',inlun) + print * + print'(" Opened output PREPBUFR file - will hold all data, ", + + "including post-NRLACQC aircraft data; unit number ",I0)', + + outlun + print * + + if(l_doprofiles) then + +c Open output PREPBUFR-like file (will eventually contain merged aircraft mass/wind data in +c AIRCAR and AIRCFT message types, including constructed profiles, with NRLACQC events on +c reports) +c ----------------------------------------------------------------------------------------- + if (l_ext_table) then + open(unit=extbl,form='formatted') + call openbf(proflun,'OUT',extbl) + close(extbl) + else + call openbf(proflun,'OUT',inlun) + end if + print * + print'(" Opened output PREPBUFR-like file - will hold only ", + + "post-NRLACQC merged aircraft profile data; unit ", + + "number ",I0)', proflun + print * + endif + +c Get the program code for NRLACQC +c -------------------------------- + if (.not. l_qmwrite ) then + nrlacqc_pc = 15 + else + call ufbqcd(outlun,'NRLACQC',nrlacqc_pc) + end if + + print * + print *, 'NRLACQC PROGRAM CODE IS: ', nrlacqc_pc + print * + +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c add this in event of future switch to dynamic memory allocation + +calloc CALL SYSTEM('date') +calloc max_reps = 0 +calloc l_match = .false. +calloc write(*,*) 'First time through just get count of number of ', +callo+ 'merged reports for dynamic array allocation' +calloc loop1: do while(ireadmg(inlun,mesgtype,mesgdate).eq.0) +calloc if((mesgtype.eq.'AIRCFT').or. +callo+ (mesgtype.eq.'AIRCAR')) then +calloc do while(ireadsb(inlun).eq.0) +c4051 continue +calloc l_match = .false. +calloc if(mesgtype.ne.'AIRCAR' .and. mesgtype.ne. 'AIRCFT') +callo+ cycle loop1 +c5051 continue +calloc max_reps = max_reps + 1 +calloc call ufbint(inlun,sqn_8,1,1,nlev,'SQN') +calloc sqn_current = sqn_8 +c6051 continue +calloc if(l_match) then +calloc call readns(inlun,mesgtype,mesgdate,iret) +calloc if(iret.eq.-1) then +calloc exit +calloc elseif(iret.eq.0) then +calloc go to 4051 +calloc else +calloc print *, 'Unexpected return code(iret=',iret, +callo+ ') from readns!' +calloc call w3tage('PREPOBS_PREPACQC') +calloc call errexit(23) ! Problems reading BUFR file +calloc endif +calloc endif +calloc call readns(inlun,mesgtype,mesgdate,iret) +calloc if(iret.eq.-1) then +calloc exit +calloc elseif(iret.eq.0) then +calloc if(mesgtype.ne.'AIRCAR' .and. mesgtype.ne. 'AIRCFT') +callo+ cycle loop1 +calloc call ufbint(inlun,sqn_8,1,1,nlev,'SQN') +calloc sqn_next = sqn_8 +calloc if(sqn_next.eq.sqn_current) then +calloc l_match = .true. +calloc go to 6051 +calloc else +calloc l_match = .false. +calloc go to 5051 +calloc endif +calloc else +calloc print *, 'Unexpected return code(iret=',iret, +callo+ ') from readns!' +calloc call w3tage('PREPOBS_PREPACQC') +calloc call errexit(23) ! Problems reading BUFR file +calloc endif +calloc enddo +calloc endif +calloc enddo loop1 +calloc write(*,*) +calloc write(*,*) 'TOTAL NUM OF RPTS IN FIRST READ THROUGH: ', +callo+ max_reps +calloc call closbf(inlun) +calloc call openbf(inlun,'IN',inlun) +calloc CALL SYSTEM('date') +calloc allocate(c_qc(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(csort(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(itype(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(alat(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(alon(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(pres(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ht_ft(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(idt(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(idp(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(c_dtg(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(c_acftreg(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(c_acftid(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(t_prcn(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ob_t(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ob_q(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ob_dir(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ob_spd(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(xiv_t(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(xiv_q(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(xiv_d(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(xiv_s(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ichk_t(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ichk_q(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ichk_d(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(ichk_s(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(nchk_t(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(nchk_q(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(nchk_d(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(nchk_s(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(phase(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(l_minus9c(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(indx(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(in_bad(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(isave(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(csort_wbad(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(indx_wbad(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(nevents(max_reps,6),stat=i);if(i.ne.0) go to 901 +calloc allocate(nnestreps(4,max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(pob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(pqm_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(ppc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(prc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(zob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(zqm_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(zpc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(zrc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(tob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(tqm_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(tpc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(trc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(qob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(qqm_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(qpc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(qrc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(uob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(vob_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(wqm_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(wpc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(wrc_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(ddo_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(ffo_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(dfq_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(dfp_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(dfr_ev(max_reps,mxnmev),stat=i);if(i.ne.0) go to 901 +calloc allocate(hdr(max_reps,15),stat=i);if(i.ne.0) go to 901 +calloc allocate(acid(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(rct(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(pbg(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(zbg(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(tbg(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(qbg(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(wbg(max_reps,5),stat=i);if(i.ne.0) go to 901 +calloc allocate(ppp(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(zpp(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(tpp(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(qpp(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(wpp(max_reps,6),stat=i);if(i.ne.0) go to 901 +calloc allocate(drinfo(max_reps,3),stat=i);if(i.ne.0) go to 901 +calloc allocate(acft_seq(max_reps,2),stat=i);if(i.ne.0) go to 901 +calloc allocate(turb1seq(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(turb2seq(max_reps,4),stat=i);if(i.ne.0) go to 901 +calloc allocate(turb3seq(3,max_reps,5),stat=i);if(i.ne.0) go to 901 +calloc allocate(prewxseq(1,max_reps,5),stat=i);if(i.ne.0) go to 901 +calloc allocate(cloudseq(5,max_reps,5),stat=i);if(i.ne.0) go to 901 +calloc allocate(afic_seq(3,max_reps,5),stat=i);if(i.ne.0) go to 901 +calloc allocate(mstq(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(cat(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(rolf(max_reps),stat=i);if(i.ne.0) go to 901 +calloc allocate(sqn(max_reps,2),stat=i);if(i.ne.0) go to 901 +calloc allocate(procn(max_reps,2),stat=i);if(i.ne.0) go to 901 +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +c Call input routine input_acqc to read the input PREPBUFR file, merge the mass and wind +c pieces, translate some values to NRL standards and store in memory (arrays) +c -------------------------------------------------------------------------------------- + write(*,*) + write(*,*) 'Calling input_acqc....' + write(*,*) + + call input_acqc(inlun,max_reps,mxnmev,bmiss,imiss,amiss,m2ft,mxlv, + + nrpts4QC_pre,cdtg_an,alat,alon,ht_ft,idt,c_dtg, + + itype,phase,t_prcn,c_acftreg,c_acftid, + + pres,ob_t,ob_q,ob_dir,ob_spd, + + ichk_t,ichk_q,ichk_d,ichk_s, + + nchk_t,nchk_q,nchk_d,nchk_s, + + xiv_t,xiv_q,xiv_d,xiv_s,l_minus9C,nevents, + + hdr,acid,rct,drinfo,acft_seq,turb1seq,turb2seq, + + turb3seq,prewxseq,cloudseq,afic_seq,mstq,cat,rolf, + + nnestreps,sqn,procn, + + pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, + + zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, + + tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, + + qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev,wbg,wpp, + + ddo_ev,ffo_ev,dfq_ev,dfp_ev,dfr_ev,l_allev_pf) + +c Close input PREPBUFR file +c ------------------------- + call closbf(inlun) + print * + print'(" Closed input PREPBUFR file with all data, including ", + + "pre-NRLACQC aircraft data; unit number ",I0)', inlun + print * + + write(*,*) + write(*,*) 'Back from input_acqc....' + write(*,'(" There are ",I0," merged reports for acftobs_qc (NRL ", + + "aircraft data QC routine).")') nrpts4QC_pre + write(*,*) + + if(nrpts4QC_pre.gt.0) then + +c Now that we are done reading in data from the input PREPBUFR file, need to call acftobs_qc +c (actual NRL aircraft QC code) +c ------------------------------------------------------------------------------------------ + write(*,*) 'Passing ',nrpts4QC_pre,'obs to acftobs_qc.f...' + write(*,*) + write(*,*) 'Calling acftobs_qc...' + +c NRPTS4QC_PRE is returned from input_acqc and represents the original number of "merged" +c reports (mass and wind pieces put together) read in from the PREPBUFR file - we need to +c save this value now as it will be used later (e.g., to correctly match the QC decisions +c made by acftobs_qc to the reports originally in the input PREPBUFR file) - we will set +c NRPTS4qc to NRPTS4QC_PRE at this point and then pass NRPTS4QC into acftobs_qc - the value +c for NRPTS4Qc gets reduced in the various subroutines in acftobs_qc as it only represents +c the number of "good" reports coming out of each subroutine +c------------------------------------------------------------------------------------------- + nrpts4QC = nrpts4QC_pre + + call acftobs_qc(max_reps,cdtg_an,nrpts4QC,krej,c_acftreg,c_acftid, + + itype,idt,idp,alon,alat,pres,ht_ft,ob_t,ob_q, + + ob_dir,ob_spd,t_prcn,xiv_t,xiv_q,xiv_d,xiv_s, + + ichk_t,ichk_q,ichk_d,ichk_s,nchk_t,nchk_q,nchk_d, + + nchk_s,indx,isave,in_bad,c_qc,csort,maxflt, + + kflight,creg_flt,cid_flt,cid_flt_old,l_newflt, + + nobs_flt,iobs_flt,ntot_flt,nrej_flt,ntot_flt_old, + + nrej_flt_old,creg_reg,nobs_reg,ntot_reg,nrej_reg, + + ntemp_reg,nwind_reg,nwhol_reg,creg_reg_tot, + + nobs_reg_tot,nwhol_reg_tot,nrej_reg_tot, + + ntemp_reg_tot,nwind_reg_tot,nrej_inv_tot, + + nrej_stk_tot,nrej_grc_tot,nrej_pos_tot, + + nrej_ord_tot,nrej_sus_tot,lead_t_tot,lead_d_tot, + + lead_s_tot,n_xiv_t,n_xiv_d,n_xiv_s,sum_xiv_t, + + sum_xiv_d,sum_xiv_s,sumabs_xiv_t,sumabs_xiv_d, + + sumabs_xiv_s,l_minus9c,l_last,l_first_date, + + l_operational,l_pc,l_ncep,*99) + + go to 34 + +c----------------------------------- + 99 continue ! return 1 out of subr. acftobs_qc comes here - keep going but post message + print 153, maxflt,maxflt + 153 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' AIRCRAFT ', + + '"FLIGHTS" IN INPUT FILE -- MUST INCREASE SIZE OF PARAMETER ', + +'NAME "MAXFLT" - WILL CONTINUE ON PROCESSING ONLY ',I6,' FLTS-0'/) + write(cmaxflt,'(i6)') maxflt + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmaxflt//' AIRCRAFT "FLIGHT" '// + + 'LIMIT EXCEEDED IN PREPOBS_PREPACQC, ONLY '// + + cmaxflt//' FLIGHTS PROCESSED-0"') +c----------------------------------- + + 34 continue + + write(*,'(" After running acftobs_qc, there are ",I0," good ", + + "reports, ",I0," bad reports (total rpts = ",I0,")")') + + nrpts4QC,krej,nrpts4QC_pre + write(*,*) + write(*,*) + +c Sort reports (including bad ones) into profiles (sort logic and sort key construction +c borrowed from acftobs_qc) (note this is done even if l_doprofiles = FALSE because it +c is used in the final listing of single-level aircraft reports) +c ------------------------------------------------------------------------------------- + +c Initialize sort key and sort index +c ---------------------------------- + do i=1,max_reps + csort_wbad(i) = 'zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz' + indx_wbad(i) = i + enddo + +c Form variable to sort / sort key +c -------------------------------- + write(*,'(" Sorting reports and creating sort index, including ", + + "reports marked as bad....")') + + do iob=1,nrpts4QC_pre + + kidt = idt(iob) + 100000 + if(kidt.ge.1000000) then + write(*,*) + write(*,*) '** WARNING: kidt too large (=',kidt,')' + write(*,*) + write (*,8073) iob,c_insty_ob(itype(iob)),c_acftreg(iob), + + c_acftid(iob),idt(iob),alat(iob),alon(iob), + + pres(iob),ht_ft(iob),t_prcn(iob),ob_t(iob), + + xiv_t(iob),ichk_t(iob),ob_q(iob),xiv_q(iob), + + ichk_q(iob),ob_dir(iob),xiv_d(iob),ichk_d(iob), + + ob_spd(iob),xiv_s(iob),ichk_s(iob),idp(iob) + 8073 format(i5,1x,a8,1x,a8,1x,a9,1x,i7,1x,2f11.5,1x,f8.1,1x,f7.0,1x, + + f5.2,4(2(1x,f8.2),1x,i5),1x,i4) + write(*,*) + kidt = 999999 + endif + write(c_idt,'(i6)') kidt + + if(ht_ft(iob).eq.amiss) then + c_ht_ft = '99999' + else + iht_ft = nint(ht_ft(iob)) + if(iht_ft.ge.100000) then + write(*,*) + write(*,*) '** WARNING: iht_ft too large (=',iht_ft,')' + write (*,8073) iob,c_insty_ob(itype(iob)),c_acftreg(iob), + + c_acftid(iob),idt(iob),alat(iob),alon(iob), + + pres(iob),ht_ft(iob),t_prcn(iob),ob_t(iob), + + xiv_t(iob),ichk_t(iob),ob_q(iob),xiv_q(iob), + + ichk_q(iob),ob_dir(iob),xiv_d(iob), + + ichk_d(iob),ob_spd(iob),xiv_s(iob), + + ichk_s(iob),idp(iob) + write(*,*) + iht_ft = 99999 + endif + +c Make descents look like ascents for sorting purposes (complication comes in when a descent +c has two obs with the same time, but different altitudes) +c +c *** -> Need to make sure to reverse order upon writing to output in output_acqc_prof for +c descents - profile levels need to be ordered by decreasing pressure (for example, +c 1st lvl = 1010 mb, 2nd lvl = 987 mb, 3rd lvl = 764 mb, etc.) +c ----------------------------------------------------------------------------------------- + if(c_qc(iob)(11:11).eq.'d' .or. c_qc(iob)(11:11).eq.'D') + + iht_ft = 50000 + (-1)*iht_ft + + if(iht_ft.ge.0) then + write(c_ht_ft,'(i5.5)') iht_ft + else + write(c_ht_ft,'(i5.4)') iht_ft + endif + endif + +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + if(alat(iob).eq.amiss) then + c_lat = '99999' + else + ilat = nint(alat(iob)*100.) + if(abs(ilat).ge.100000) then + write(*,*) + write(*,*) '** WARNING: ilat too large (=',ilat,')' + write (*,8073) iob,c_insty_ob(itype(iob)),c_acftreg(iob), + + c_acftid(iob),idt(iob),alat(iob),alon(iob), + + pres(iob),ht_ft(iob),t_prcn(iob),ob_t(iob), + + xiv_t(iob),ichk_t(iob),ob_q(iob),xiv_q(iob), + + ichk_q(iob),ob_dir(iob),xiv_d(iob), + + ichk_d(iob),ob_spd(iob),xiv_s(iob), + + ichk_s(iob),idp(iob) + write(*,*) + ilat = 99999 + endif + write(c_lat,'(i5)') ilat + endif + + if(alon(iob).eq.amiss) then + c_lon = '999999' + else + ilon = nint(alon(iob)*100.) + if(abs(ilon).ge.1000000) then + write(*,*) + write(*,*) '** WARNING: ilon too large (=',ilon,')' + write (*,8073) iob,c_insty_ob(itype(iob)),c_acftreg(iob), + + c_acftid(iob),idt(iob),alat(iob),alon(iob), + + pres(iob),ht_ft(iob),t_prcn(iob),ob_t(iob), + + xiv_t(iob),ichk_t(iob),ob_q(iob),xiv_q(iob), + + ichk_q(iob),ob_dir(iob),xiv_d(iob), + + ichk_d(iob),ob_spd(iob),xiv_s(iob), + + ichk_s(iob),idp(iob) + write(*,*) + ilon = 999999 + endif + write(c_lon,'(i6)') ilon + endif +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + + c_type = c_insty_ob(itype(iob)) + +c NRL sort key: +c ------------- +cc Option 1: not used +cc csort_wbad(iob) = c_idt(1:6) ! time +cc + //c_ht_ft(1:5) ! altitude +cc + //c_lat(1:5) ! latitude +cc + //c_lon(1:6) ! longitude +cc + //c_type(1:2) ! aircraft type + +cc Option 2: not used (tail number first) +cc csort_wbad(iob) = c_acftreg(iob)(1:7) ! tail number +cc + //c_acftid(iob)(1:7) ! flight number +cc + //c_idt(1:6) ! time +cc + //c_ht_ft(1:5) ! altitude +cc + //c_lat(1:5) ! latitude +cc + //c_type(1:2) ! aircraft type + +cc Option 3: not used (use type first to group AIRCFT and AIRCAR message types together) +cc csort_wbad(iob) = c_type(1:2) ! aircraft type +cc + //c_acftreg(iob)(1:7) ! tail number +cc + //c_acftid(iob)(1:7) ! flight number +cc + //c_idt(1:6) ! time +cc + //c_ht_ft(1:5) ! altitude +cc + //c_lat(1:5) ! latitude +cc + //c_lon(1:6) ! longitude + +c Option 4: not used +c Sort by altitude before time... want descents in order with an increasing vertical +c coordinate - but if you have two obs in a descent with the same time but different +c altitude, the altitudes will show up reversed -- use offset to get around this +c ----------------------------------------------------------------------------------- +c +c Option 5: USE THIS (sort by time then altitude that is adjusted for descents) +c ----------------------------------------------------------------------------- + if(c_qc(iob)(11:11).eq.'A') then ! change 'A' to 'a' + c_qc11 = 'a' + elseif(c_qc(iob)(11:11).eq.'D') then + c_qc11 = 'd' ! change 'D' to 'd' + else + c_qc11 = c_qc(iob)(11:11) + endif + +c Option 6: not used {sort by altitude first, then time... trust vertical coordinate more +c than position (many less bad marks in c_qc(5:5)'s vs c_qc(2:4))} +c --------------------------------------------------------------------------------------- + csort_wbad(iob) = c_type(1:2)//c_qc11 ! aircraft type + ascent/descent + + //c_acftreg(iob)(1:8) ! tail number + + //c_acftid(iob)(1:7) ! flight number +ccccc+ //c_ht_ft(1:5) +ccccc+ //c_idt(1:6) + + //c_idt(1:6) ! time + + //c_ht_ft(1:5) ! altitude +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + + //c_lat(1:5) ! latitude + + //c_lon(1:6) ! longitude +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + + enddo + +c Sort reports in file according to array csort_wbad +c -------------------------------------------------- + call indexc40(nrpts4QC_pre,csort_wbad,indx_wbad) + + if(l_doprofiles) then ! takes longer to run, because it outputs profiles in separate + ! PREPBUFR-like file + +c ---------------------------------------------------------------------------------- +c Translate NRL QC flags to NCEP events and add events to PREPBUFRlike profiles file +c ---------------------------------------------------------------------------------- + write(*,*) 'Calling output_acqc_prof....' + write(*,*) + + call output_acqc_prof(proflun,nrpts4QC_pre,max_reps,mxnmev,mxlv, + + bmiss,cdtg_an,alat,alon,ht_ft,idt,c_qc, + + trad,l_otw,l_nhonly,indx_wbad,c_acftreg, + + c_acftid,ob_t,nevents,hdr,acid,rct,drinfo, + + acft_seq,mstq,cat, + + pob_ev,pqm_ev,ppc_ev,prc_ev,pbg,ppp, + + zob_ev,zqm_ev,zpc_ev,zrc_ev,zbg,zpp, + + tob_ev,tqm_ev,tpc_ev,trc_ev,tbg,tpp, + + qob_ev,qqm_ev,qpc_ev,qrc_ev,qbg,qpp, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, + + wbg,wpp, + + ddo_ev,ffo_ev,dfq_ev,dfp_ev,dfr_ev, + + nrlacqc_pc,l_allev_pf,l_prof1lvl, + + l_mandlvl,tsplines, + + l_operational,lwr) + + write(*,*) + write(*,*) + write(*,*) 'Back from output_acqc_prof ....' + write(*,'(" PREPBUFR-like (profiles) file has been updated ", + + "with events representing the QC marks applied by ", + + "the NRLACQC routine acftobs_qc.")') + write(*,*) + write(*,*) + +c Close output PREPBUFR-like (profiles) file +c ------------------------------------------ + call closbf(proflun) ! closbf will take care of flushing last message + print * + print'(" Closed output PREPBUFR-like file - now holds post-", + + "NRLACQC merged aircraft profile data; unit number ", + + I0)', proflun + print * + endif + +c ---------------------------------------------------------------------- +c Always output single-level QC'd aircraft data in regular PREPBUFR file +C ---------------------------------------------------------------------- + +c Re-open input PREPBUFR file (contains mass and wind reports for all data types, no NRLACQC +c events on reports in AIRCAR and AIRCFT message types) +c ------------------------------------------------------------------------------------------ + call openbf(inlun,'IN',inlun) + print * + print'(" Again opened input PREPBUFR file with all data, ", + + "including pre-NRLACQC aircraft data; unit number ",I0)', + + inlun + print * + + +C Initialize some variables that will be set in output_acqc_noprof and used in printout +c ------------------------------------------------------------------------------------- + ncep_qm_p = 9999 + ncep_rc_p = 9999 + ncep_qm_z = 9999 + ncep_rc_z = 9999 + ncep_qm_t = 9999 + ncep_rc_t = 9999 + ncep_qm_q = 9999 + ncep_rc_q = 9999 + ncep_qm_w = 9999 + ncep_rc_w = 9999 + ncep_rej = 0 + +c Translate NRL QC flags to NCEP events and add events to aircraft reports in "AIRCAR" and +c "AIRCFT" message types in full PREPBUFR file (split mass and wind pieces) +c ---------------------------------------------------------------------------------------- + call output_acqc_noprof(inlun,outlun,nrpts4QC_pre,max_reps,bmiss, + + alat,alon,ht_ft,idt,c_qc,trad,l_otw, + + l_nhonly,l_qmwrite, + + ncep_qm_p,ncep_rc_p, + + ncep_qm_z,ncep_rc_z, + + ncep_qm_t,ncep_rc_t, + + ncep_qm_q,ncep_rc_q, + + ncep_qm_w,ncep_rc_w, + + ncep_rej,nrlacqc_pc) + + write(*,*) + write(*,*) + write(*,*) 'Back from output_acqc_noprof ....' + write(*,'(" PREPBUFR file has been updated with events ", + + "representing the QC marks applied by the NRL aircraft", + + " QC routine acftobs_qc")') + write(*,*) + write(*,*) + +c Close input PREPBUFR file +c ------------------------- + call closbf(inlun) + print * + print'(" Closed input PREPBUFR file with all data, including ", + + "pre-NRLACQC aircraft data; unit number ",I0)', inlun + print * + +c Close output PREPBUFR file +c -------------------------- + call closbf(outlun) ! closbf will take care of flushing last message + print * + print'(" Closed output PREPBUFR file - now holds all data, ", + + "including post-NRLACQC aircraft data; unit number ",I0)', + + outlun + print * + + if(.not.l_operational) then + +c Write merged reports and resulting NRL QC decisions (array c_qc) to an output file for +c later perusal +c -------------------------------------------------------------------------------------- + + open(51,file='merged.reports.post_acftobs_qc.sorted',form= + + 'formatted') + write(51,*) + write(51,'(" Final listing of all aircraft reports in PREPBUFR", + + " file after NRL QC (sorted according to array ", + + "csort_wbad)")') + if(nrpts4QC_pre.eq.max_reps) write(51,'(" (since max report ", + + "limit hit, only reports going through QC listed here)")') + write(51,'(" -------------------------------------------------", + + "--------------------------------------------------", + + "-------")') + write(51,*) + write(51,'(" TAMDAR reports here replace characters 1-3 of ", + + "manufactured flight # (''000'') with (''TAM'') in ", + + "order to create truncated tail # ''TAM'' for ", + + "NRLACQC sorting - the PREPBUFR file continues to ", + + "encode ''000'' in")') + write(51,'(" characters 1-3 of manufactured flight # for ", + + "TAMDAR (stored as both ''SID'' and ''ACID'')")') + + write(51,*) + write(51,'(" AIREP and PIREP reports report only a flight # ", + + "(manufactured for PIREPs) - a tail # for NRLACQC ", + + "sorting is created by truncating the flight # - ", + + "the PREPBUFR file will not encode these truncated ", + + "tail #''s")') + + write(51,*) + write(51,'(" All AMDAR reports except LATAM report only a tail", + + " # - this is stored as both flight # and tail # for", + + " NRLACQC sorting - the PREPBUFR file continues to ", + + "encode only tail # (stored in ''SID'')")') + write(51,*) + write(51,'(" AMDAR reports from LATAM report both a tail # and", + + " a flight # - these are used as reported for ", + + "NRLACQC sorting - the PREPBUFR file continues to ", + + "encode both tail # and flight # (as ''SID'' and ", + + "''ACID'',")') + write(51,*) 'resp.)' + write(51,*) + write(51,'(" MDCRS reports from ARINC report both a tail # and", + + " a flight # - these are used as reported for ", + + "NRLACQC sorting - the PREPBUFR file continues to ", + + "encode both tail # and flight # (as ''SID'' and ", + + "''ACID'',")') + write(51,*) 'resp.)' + + write(51,*) + write(51,3001) + 3001 format(173x,'! _PREPBUFR_QMs_!NRLACQC_REASON_CODE'/' index ', + + 'flight tail num itp ph lat lon ', + + 'time hght pres temp/chk spec_h/chk wspd/chk ', + + 'wdir/chk t-prec !__qc_flag__!_______________', + + 'csort_wbad_______________! Pq Zq Tq Qq Wq!Prc Zrc Trc ', + + 'Qrc Wrc'/'------ --------- -------- --- -- ', + + '-------- --------- ------ ----- ------ --------- ', + + '---------- --------- -------- ------ !-----------!', + + '----------------------------------------! -- -- -- ', + + '-- --!--- --- --- --- ---') + + do i=1,nrpts4QC_pre + j=indx_wbad(i) + + if(ncep_rej(j).eq.0) then + write(51,fmt=8001) j,c_acftid(j),c_acftreg(j),itype(j), + + phase(j),alat(j),alon(j),idt(j),nint(ht_ft(j)),pres(j), + + ob_t(j),ichk_t(j),ob_q(j),ichk_q(j),ob_spd(j),ichk_s(j), + + nint(ob_dir(j)),ichk_d(j),t_prcn(j),c_qc(j),csort_wbad(j), + + ncep_qm_p(j),ncep_qm_z(j),ncep_qm_t(j),ncep_qm_q(j), + + ncep_qm_w(j),ncep_rc_p(j),ncep_rc_z(j),ncep_rc_t(j), + + ncep_rc_q(j),ncep_rc_w(j) +c if(ncep_rc_p(j).ge.1000) write(51,fmt=9001) ncep_rc_p(j) +c9001 format(' PRC too large = ',i10) +c if(ncep_rc_z(j).ge.1000) write(51,fmt=9002) ncep_rc_z(j) +c9002 format(' ZRC too large = ',i10) +c if(ncep_rc_t(j).ge.1000) write(51,fmt=9003) ncep_rc_t(j) +c9003 format(' TRC too large = ',i10) +c if(ncep_rc_q(j).ge.1000) write(51,fmt=9004) ncep_rc_q(j) +c9004 format(' QRC too large = ',i10) +c if(ncep_rc_w(j).ge.1000) write(51,fmt=9005) ncep_rc_w(j) +c9005 format(' WRC too large = ',i10) + endif + enddo + + 8001 format(i6,1x,a9,1x,a8,i4,1x,i2,2f10.5,1x,i6,1x,i5,1x,f6.1,1x, + + f6.2,i3,1x,f7.2,i3,1x,f6.1,i3,2x,i4,i3,1x,f6.2,1x, + + '!',a11,'!',a40,'!',5(1x,i2.2),'!',i3.3,4(1x,i3.3)) + +c Close data listing file +c ----------------------- + close(51) + + endif + +c End program +c ----------- + + write(*,*) + write(*,*) '**************************' + write(*,*) 'PREPOBS_PREPACQC has ended' + call system('date') + write(*,*) '**************************' + write(*,*) + call w3tage('PREPOBS_PREPACQC') + + else ! nrpts4QC_pre.le.0 + +c Input PREPBUFR file contains NO aircraft data of any kind -- STOP 4 +c ------------------------------------------------------------------- + + WRITE(6,108) + 108 FORMAT(/' INPUT PREPBUFR FILE CONTAINS NO "AIRCAR" OR "AIRCFT" ', + $ 'MESSAGES WITH REPORTS - STOP 4'/) + CALL ERREXIT(4) + + endif ! nrpts4QC_pre.gt.0 + + stop + +cvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv +c add this event of future switch to dynamic memory allocation + +ca901 continue + +calloc print *, '#####PREPOBS_PREPACQC - UNABLE TO ALLOCATE ARRAYS' +calloc call w3tage('PREPOBS_PREPACQC') +calloc call errexit(99) +c^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + + end diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_landc b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_landc deleted file mode 100644 index 4b847c55..00000000 Binary files a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_landc and /dev/null differ diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_prepacqc.gdas.parm b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_prepacqc.gdas.parm new file mode 100755 index 00000000..0f9c2c68 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_prepacqc.gdas.parm @@ -0,0 +1,16 @@ + + &nrlacqcinput + trad = 3.0, + l_otw = .true., + l_nhonly = .false., + l_doprofiles = .true., + l_allev_pf = .false., + l_prof1lvl = .true., + l_mandlvl = .false., + tsplines = .true. + + / + + Cards for PREPACQC + Here: GDAS Runs + diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_prepacqc.merra.parm b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_prepacqc.merra.parm index 2413a7b4..27a61cdb 100755 --- a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_prepacqc.merra.parm +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_prepacqc.merra.parm @@ -6,6 +6,24 @@ FWRITE = .TRUE., SWRITE=.FALSE., IWRITE=.FALSE., EWRITE=.FALSE. / + + &nrlacqcinput + trad = 3.0, + l_otw = .true., + l_nhonly = .false., + l_doprofiles = .true., + l_allev_pf = .false., + l_prof1lvl = .true., + l_mandlvl = .false., + l_ext_table = .true., + l_qmwrite = .false., + tsplines = .true. + / + + Cards for PREPACQC + Here: GDAS Runs obsproc_global.v2.1.1 + modified for running with old GMAO files - l_ext_table and l_qmwrite + Cards for PREPACQC -- Version 17 February 1998 Here: GMAO/MERRA System -- Effective: 12Z 03/11/98 to present Updated: 11/05/97 -- IFLGUS=0 (was =1) -- AIREP/PIREP reports over diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_waypoints b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_waypoints deleted file mode 100644 index edcfcb4c..00000000 --- a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/prepobs_waypoints +++ /dev/null @@ -1,32 +0,0 @@ -CC THIS IS AN EDITABLE FILE GIVING THE INCORRECT WAYPOINTS AND -CC THEIR CORRECT LOCATIONS-READ IN WHEN LOGICAL WAYPIN IS .TRUE. - 27 -C DATA OLDLAT (degrees X 100, + is North, - is South) - 2017 3717 1067 3000 3383 4850 5683 4283 2617 3417 3783 4500 - 3417 3717 4033 3100 6217 -0583 -0950 -0667 0817 4017 2783 1683 - 1295 3850 1100 -C DATA NEWLAT (degrees X 100, + is North, - is South) - -2983 6000 3967 -2750 -2683 -2533 3504 3007 3648 3019 3845 -0511 - 4092 4056 -0813 -3123 3950 -0583 2431 1478 4195 0090 3746 5866 - 1295 5492 5263 -C DATA OLDLON (degrees WEST x 100) - 35333 11367 28567 8550 11650 11233 13550 7150 31267 9717 11300 7467 - 11783 9700 7845 8467 2050 19000 21300 7633 26117 11017 13050 7600 - 11423 8392 35738 -C DATA NEWLON (degrees WEST x 100) - 6200 4317 3167 5700 6050 4917 33384 32180 0422 0923 34367 3721 - 34562 34567 3488 5406 3117 16900 10450 9237 7183 7000 2405 17133 - 14423 18803 20410 -C CODE TO READ IN EDITABLE FILE FROM DISK -CC READ(23,230) BUFF1 80A -CC READ(23,230) BUFF1 80A -CC READ(23,231) NUM I5 -CC READ(23,230) BUFF1 80A -CC READ(23,232) OLDLAT(J) J=1,NUM 12I6 -CC READ(23,230) BUFF1 80A -CC READ(23,232) NEWLAT(J) J=1,NUM 12I6 -CC READ(23,230) BUFF1 80A -CC READ(23,232) OLDLON(J) J=1,NUM 12I6 -CC READ(23,230) BUFF1 80A -CC READ(23,232) NEWLON(J) J=1,NUM 12I6 -CC diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pspl.f90 b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pspl.f90 new file mode 100644 index 00000000..d02b6540 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/pspl.f90 @@ -0,0 +1,2088 @@ +! +! ****************************************** +! * MODULE pspl * +! * R. J. Purser, NOAA/NCEP/EMC, May 2014 * +! * jim.purser@noaa.gov * +! * * +! ****************************************** +! +! A collection of handy spline routines +! +! Last modified: +! Keyser (2014-12-12) - print written to unit 41 rather than stdout (for use in +! prepobs_prepacqc program - limits amount of stdout) +! +! DIRECT DEPENDENCIES: +! Modules: pietc, pkind, pmat2 +! Libraries: pmat +! +! +!============================================================================= +module pspl +!============================================================================= +use pkind, only: dp +use pietc, only: T,F,u0,o2,u1 ! True, False, 0., .5, 1. +implicit none +private +public:: expm,expmm,coshm,sinhm,coshmm,xcms,enbase_t, bnewton, & + fit_tspline,eval_tspline,int_tspline,eval_itspline, & + fit_uspline,eval_uspline,int_uspline,eval_iuspline, & + best_slalom,count_gates,set_gates,set_posts, & + count_routes,list_routes,next_route, & + slalom_tspline,slalom_uspline,convertd,convertd_back + +integer, parameter:: ihu=1025 ! "Huge" integer parameter +real(dp),parameter:: hu=huge(hu)/2 ! "Huge" real parameter +real(dp),parameter:: eps=epsilon(eps),heps=.01 ! Small parameters + +interface expm; module procedure expm; end interface +interface expmm; module procedure expmm; end interface +interface coshm; module procedure coshm; end interface +interface sinhm; module procedure sinhm; end interface +interface coshmm; module procedure coshmm; end interface +interface xcms; module procedure xcms; end interface +interface enbase_t; module procedure enbase_t; end interface +interface bnewton; module procedure tbnewton,ubnewton; end interface +interface fit_tspline; module procedure fit_gtspline,fit_tspline + end interface +interface eval_tspline + module procedure eval_tspline,eval_tsplined,eval_tsplinedd,eval_tsplineddd + end interface +interface int_tspline; module procedure int_tspline; end interface +interface eval_itspline; module procedure eval_itspline; end interface +interface fit_uspline; module procedure fit_guspline,fit_uspline + end interface +interface eval_uspline + module procedure eval_uspline,eval_usplined,eval_usplinedd,eval_usplineddd + end interface +interface int_uspline; module procedure int_uspline; end interface +interface eval_iuspline; module procedure eval_iuspline; end interface +interface best_slalom; module procedure best_tslalom,best_uslalom + end interface +interface count_gates; module procedure count_gates; end interface +interface set_gates; module procedure set_gates; end interface +interface set_posts; module procedure set_posts; end interface +interface count_routes; module procedure count_routes; end interface +interface list_routes; module procedure list_routes; end interface +interface next_route; module procedure next_route; end interface +interface slalom_tspline;module procedure slalom_tspline; end interface +interface slalom_uspline;module procedure slalom_uspline; end interface +interface convertd; module procedure convertd; end interface +interface convertd_back; module procedure convertd_back; end interface + +contains + +!============================================================================= +function expm(x) result(e)! [expm] +!============================================================================= +! exp(x)-1 (approximately x for small x) +! = I^(1)exp(x), where I^(p) is the integral iterated p times +real(dp),intent(in ):: x +real(dp) :: e +!----------------------------------------------------------------------------- +real(dp):: p +integer :: i +!============================================================================= +if(abs(x)>o2)then + e=exp(x)-u1 +else + p=x; e=p + do i=2,19; p=p*x/i; e=e+p; if(abs(p)<=abs(e*eps))return; enddo +endif +end function expm + +!============================================================================= +function expmm(x) result(e)! [expmm] +!============================================================================= +! exp(x)-1-x (approximately x^2/2 for small x) +! = I^(2)exp(x), where I^(p) is the integral iterated p times +real(dp),intent(in ):: x +real(dp) :: e +!----------------------------------------------------------------------------- +real(dp):: p +integer :: i +!============================================================================= +if(abs(x)>o2)then + e=exp(x)-u1-x +else + p=x*x*o2; e=p + do i=3,25; p=p*x/i; e=e+p; if(abs(p)<=abs(e*eps))return; enddo +endif +end function expmm + +!============================================================================= +function coshm(x) result(c)! [coshm] +!============================================================================= +! cosh(x)-1 (approximately x**2/2 for small x) +! =I^(2)cosh(x), where I^(p) is the integral iterated p times +real(dp),intent(in ):: x +real(dp) :: c +!----------------------------------------------------------------------------- +c=2*sinh(x*o2)**2 +end function coshm + +!============================================================================= +function sinhm(x) result(s)! [sinhm] +!============================================================================= +! sinh(x)-x (approximately x**3/6 for small x) +! =I^(3)cosh(x), where I^(p) is the integral iterated p times +real(dp),intent(in ):: x +real(dp) :: s +!----------------------------------------------------------------------------- +real(dp):: p,xx +integer :: i +!============================================================================= +if(abs(x)>o2)then + s=sinh(x)-x +else + p=x**3/6; s=p; xx=x*x + do i=5,19,2; p=p*xx/(i*(i-1)); s=s+p; if(abs(p)<=abs(s*eps))return; enddo +endif +end function sinhm + +!============================================================================= +function coshmm(x) result(c)! [coshmm] +!============================================================================= +! cosh(x)-1-x^2/2 (approximately x**4/24 for small x) +! =I^(4)cosh(x), where I^(p) is the integral iterated p times +real(dp),intent(in ):: x +real(dp) :: c +!----------------------------------------------------------------------------- +real(dp) :: xh +!============================================================================= +xh=x*o2 +c=sinhm(xh)*(2*sinh(xh)+x) +end function coshmm + +!============================================================================= +function xcms(x) result(e)! [xcms] +!============================================================================= +real(dp),intent(in ):: x +real(dp) :: e +!----------------------------------------------------------------------------- +real(dp):: p,xx +integer :: i,i2 +!============================================================================= +! x*coshm(x)-sinhm(x) (approximately x**3/3 for small x) +if(abs(x)>o2)then + e=x*coshm(x)-sinhm(x) +else + p=x**3/3; e=p; xx=x*x + do i=2,15 + i2=i*2; p=p*xx/(i2*(i2+1)); e=e+i*p; if(abs(p)<=abs(e*eps))return + enddo +endif +end function xcms + +!============================================================================== +function enbase_t(tspan,hspan)result(r)! [enbase_t] +!============================================================================== +! For a nondimensional time span, tspan, but a dimensional height +! span, hspan, return the baseline minimum possible tensioned spline +! energy integrated over the central span plus the two wings. +! If the hspan vanishes, return a nominal unit energy. +! The energy is quadratic in hspan, which can therefore be of either sign, +! but tspan must be strictly positive for a meaningful positive energy. +!============================================================================== +real(dp),intent(in ):: tspan,hspan +real(dp) :: r +!============================================================================= +if(tspangate)then + write(41,*) 'WARNING! In tbnewton; i,it,dt/gate = ',i,it,dt/gate + exit + endif + if(abs(dh)nit) + if(FF)then + write(41,'("In tbnewton; Newton iterations seem not to be")') + write(41,'("converging at i=",i3)'),i + write(41,'("tee,he,hac,heps,dhadt:",5(1x,e11.4))'),tee,he,hac,heps,dhadt + endif + te(i) = tee +enddo +end subroutine tbnewton + +!============================================================================= +subroutine ubnewton(nh,m,halfgate,hgts,hs,hgtp,p,q, te,dhdt,FF)! [bnewton] +!============================================================================= +! Like tbnewton, but for the case of untensioned (i.e., cubic) splines +!============================================================================= +integer, intent(in ):: nh,m +real(dp), intent(in ):: halfgate +integer, dimension(nh),intent(in ):: hgts +real(dp),dimension(nh),intent(in ):: hs +integer, dimension(m), intent(in ):: hgtp +real(dp),dimension(m) ,intent(in ):: p,q +real(dp),dimension(nh),intent(out):: dhdt, te +logical, intent(out):: FF +!----------------------------------------------------------------------------- +integer,parameter :: nit=12 +real(dp),dimension(m):: tr +real(dp) :: gate,tee,he,hac,dhadt,dh,dt +integer :: i,it +!============================================================================= +gate=2*halfgate +tr=hgtp*halfgate +do i=1,nh + tee=hgts(i)*halfgate + he=hs(i) +! Use Newton iterations to estimate the rescaled time, tee, at which the +! height is he + it = 1 + do while (it <= nit) + call eval_uspline(m,tr,p,q, tee,hac,dhadt) + if(it==1)dhdt(i)=dhadt + if(dhadt==u0)exit + dh=hac-he + dt=-dh/dhadt + if(abs(dt)>gate)then + write(41,*) 'WARNING! In ubnewton; i,it,dt/gate = ',i,it,dt/gate + exit + endif + if(abs(dh)nit) + if(FF)then + write(41,'("In ubnewton; Newton iterations seem not to be")') + write(41,'("converging at i=",i3)'),i + write(41,'("tee,he,hac,heps,dhadt:",5(1x,e11.4))'),tee,he,hac,heps,dhadt + endif + te(i) = tee +enddo +end subroutine ubnewton + +!============================================================================ +subroutine fit_gtspline(n,xs,ys,on,q,j,yac,en,FF)! [fit_tspline] +!============================================================================ +! Fit the gappy tensioned spline, where only those nodes flagged "on" +! are effective in the fitting procedure. Owing to the fact that, where +! constraints are not "on" the spline will generally depart from ys, the +! actual y (yac) is returned for all nodes, regardless of the partial +! duplication with the given ys. In other respects, this is just +! like fit_tspline. +!============================================================================ +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,ys +logical, dimension(n),intent(in ):: on +real(dp),dimension(n),intent(out):: q,j,yac +real(dp), intent(out):: en +logical, intent(out):: FF +!---------------------------------------------------------------------------- +real(dp),dimension(n):: xa,ya,qa,ja +integer :: i,k,m +!============================================================================ +m=0 +do i=1,n + if(on(i))then; m=m+1; xa(m)=xs(i); ya(m)=ys(i); endif +enddo +call fit_tspline(m,xa(1:m),ya(1:m),qa(1:m),ja(1:m),en,FF) +if(FF)then + write(41,*) 'In fit_gtspline; failure flag raised at call to fit_tspline' + return +endif +k=0 +do i=1,n + if(on(i))then + k=k+1 + q(i)=qa(k) + j(i)=ja(k) + yac(i)=ys(i) + else + call eval_tsplined(m,xa(1:m),ya(1:m),qa(1:m),xs(i), yac(i),q(i)) + j(i)=0 + endif +enddo +end subroutine fit_gtspline + +!============================================================================ +subroutine fit_tspline(n,xs,p,q,j,en,FF)! [fit_tspline] +!============================================================================ +! Solve for the coefficients, the 3rd-derivative jumps, and the energy, +! of the standardized tensioned spline passing through the n nodes at (xs,p). +! +! The value and successive derivatives on the immediate positive side of +! each node, xs(i), are to be found as p(i), q(i), r(i), s(i), with j(i) +! being the discontinuity of 3rd-derivative s between the negative and positive +! side of the node (value itself, and other derivatives, remaining continuous). +! In addition, p(0), q(0), r(0) and s(0) are the value and derivatives on the +! immediate negative side of xs(1). The spline solution minimizes elastic +! and tensional energy, en, defined as the integral dx of half the sum of the +! squared first and second derivatives over the whole line. Euler-Lagrange +! implies the solution is expressible in each segment between or beyond nodes: +! y(x') = p + q*x' + r*coshm(x') + s*sinhm(x') +! where x' = x-xs(i) is the local coordinate relative to the relevant node +! (the node at the left of the segent except that, implicitly, we take +! xs(0)===xs(1), and the two functions, coshm and sinhm, are defined: +! coshm(x) = cosh(x)-1 +! sinhm(x) = sinh(x)-x. +! The solution in segment 0, i.e., x< xs(1), must exponentially decay towards +! a constant as x--> -infinity, while that for segment n must likewise decay +! as x--> +infinity, in order that energy remains finite. Thus, q(0)=r(0)=s(0) +! and q(n)=-r(n)=s(n) always. Solutions in these infinite end segments are +! therefore expressible in terms only of p(0),q(0) for segment 0 and in terms +! only of p(n), q(n) for segment n and is linear in these coefficients. +! Between consecutive nodes (segments 0=xs(i)) then + FF=T + write(41,*) 'In fit_tspline; xs data must increase strictly monotonically' + return + end if +enddo +! Initialize tri-diagonal kernels for the energy definition: +qq=0 ! <- initialize symmetric tridiagonal, kernel for q^T*QQ*q + ! where "q" are the dp/dx at each node. +! The coefficients in the quadratic form defining the spline energy also +! include terms involving factors (p(ip)-p(i))*(q(i)+q(ip)) and +! (p(ip)-p(i))*(p(ip)-p(i)), but these can be dealt with using, respectively, +! the matrices cqp and cpp which are simply diagonal. It is the symmetries +! in the defiition of energy that allow this simplification. + +! Loop over the intervals bounded by consecutive nodes: +do i=1,n-1 + ip=i+1 + difp(i)=p(ip)-p(i) + x=(xs(ip)-xs(i))*o2 ! Halfwidth of interval + ch=cosh(x); sh=sinh(x) + xcmsx2=xcms(x)*2 +! egg relates to the odd-g-basis function's energy integral coefficient +! ehh relates to the even-g-basis function's energy integral coefficient + egg=x*sh/xcmsx2; ehh=ch/(2*sh) +! ccc is the coefficient of energy integral coupling g(i)*g(i) and g(ip)*g(ip) + ccc=egg+ehh + cpp(i)=ch/xcmsx2 ! Energy coefficient for difp(i)*difp(i)... + cqp(i)=-difp(i)*sh/xcmsx2 ! ..and for difp(i)*sumq(i) + qq(i,0)=qq(i,0)+ccc; qq(ip,-1)=qq(ip,-1)+egg-ehh; qq(ip,0)=qq(ip,0)+ccc +enddo +! Add the exterior energy contributions to qq at both ends: +qq(1,0)=qq(1,0)+1 +qq(n,0)=qq(n,0)+1 + +! Temporarily, q is made the vector of forcings in the tridiagonal linear +! system from which the final spline coefficients, q, are solved in place. +q(1:n-1)=-cqp; q(n)=0 +q(2:n)=q(2:n)-cqp + +! The following 2 lines solve the tridiagonal system for q: +call ldltb(n,1,qq) ! <- Decompose qq into factors, L*(1/D)*L^T, L=lower +call ltdlbv(n,1,qq,q) ! <- Back-substitute, thus solving for q +sumq=q(1:n-1)+q(2:n) ! <-pairwise sums of derivatives, q: + +! The minimizing energy can now be evaluated as a sum of only 2 terms: +en=o2*(dot_product(difp**2,cpp)+dot_product(sumq,cqp)) + +! Finally, evaluate the 3rd-derivative "jumps", j, at each node: +! Here, sb is the 3rd-derivative at the right end, sa that at the left end, +! of whichever interval is under consideration, but for interior intervals, +! sa = sap+q(i) and sb=sap+q(i+1). +sb=q(1) +do i=1,n-1 + ip=i+1 + x=o2*(xs(ip)-xs(i)) + xcmsx2=xcms(x)*2 + ch=cosh(x); sh=sinh(x) + sap=(sh*sumq(i)-ch*difp(i))/xcmsx2 + sa=sap+q(i) + j(i)=sa-sb + sb =sap+q(ip) +enddo +j(n)=q(n)-sb ! Final "sa" is just q(n) for the right exterior +end subroutine fit_tspline + +!============================================================================= +subroutine int_tspline(n,xs,p,q, m)! [int_tspline] +!============================================================================= +! Take the sets of n parameters p and q of the tensioned spline +! and return the values of its integral at the n-1 interval midpoints, and +! the value at the last node, assuming that the integral at the first node +! is set to zero. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp),dimension(n),intent(out):: m +!----------------------------------------------------------------------------- +real(dp):: a,b,c,d,e,t2,x,pa,pd,qa,qd,shx,chmx,shmx,chmmx,xcmsx +integer :: i,ip +!============================================================================= +! e is the running integral as we loop over successive nodes, so it starts out +! zero at the first node: +e=u0 +! Loop over intervals: +do i=1,n-1 + ip=i+1 + x=(xs(ip)-xs(i))*o2 !<- interval half-width + t2=x*x*o2 + shx =sinh (x) + chmx =coshm (x) + shmx =sinhm (x) + chmmx=coshmm(x) + xcmsx=xcms (x) + pa=(p(ip)+p(i))*o2 + pd=(p(ip)-p(i))*o2/x + qa=(q(ip)+q(i))*o2 + qd=(q(ip)-q(i))*o2/shx +! a,b,c,d are analogous to the Taylor coefficients of a cubic about the +! interval midpoint, but more precisely, c and d relate to basis functions +! coshm and sinhm (instead of x**2/2 and x**3/6 for the perfect cubic). + c=qd + a=pa-c*chmx + d=(qa-pd)*x/xcmsx + b=qa-d*chmx + m(i)=e+a*x -b*t2 +c*shmx -d*chmmx + e=e+2*(a*x+c*shmx) +enddo +m(n)=e +end subroutine int_tspline + +!============================================================================ +subroutine fit_guspline(n,xs,ys,on,q,j,yac,en,FF)! [fit_uspline] +!============================================================================ +! Fit the gappy untensioned spline, where only those nodes flagged "on" +! are effective in the fitting procedure. Owing to the fact that, where +! constraints are not "on" the spline will generally depart from ys, the +! actual y (yac) is returned for all nodes, regardless of the partial +! duplication with the given ys. In other respects, this is just +! like fit_tspline. +!============================================================================ +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,ys +logical, dimension(n),intent(in ):: on +real(dp),dimension(n),intent(out):: q,j,yac +real(dp), intent(out):: en +logical, intent(out):: FF +!---------------------------------------------------------------------------- +real(dp),dimension(n):: xa,ya,qa,ja +integer :: i,k,m +!============================================================================ +m=0 +do i=1,n + if(on(i))then; m=m+1; xa(m)=xs(i); ya(m)=ys(i); endif +enddo +call fit_uspline(m,xa(1:m),ya(1:m),qa(1:m),ja(1:m),en,FF) +if(FF)then + write(41,*) 'In fit_guspline; failure flag raised at call to fit_uspline' + return +endif +k=0 +do i=1,n + if(on(i))then + k=k+1 + q(i)=qa(k) + j(i)=ja(k) + yac(i)=ys(i) + else + call eval_usplined(m,xa(1:m),ya(1:m),qa(1:m),xs(i), yac(i),q(i)) + j(i)=0 + endif +enddo +end subroutine fit_guspline + +!============================================================================= +subroutine fit_uspline(n,xs,p,q,j,en,FF)! [fit_uspline] +!============================================================================= +! Solve for the coefficients, the 3rd-derivative jumps, and the energy, +! of the untensioned (cubic) spline passing through the n nodes at (xs,p). +! +! The algorithm follows the pattern given in fit_tspline, except that the +! hyperbolic functions are all replaced by their asymptotic (x--> 0) limiting +! forms. These limiting forms are as follows: +! cosh(x) --> 1 +! sinh(x) --> x +! coshm(x) --> x**2/2 +! sinhm(x) --> x**3/6 +! xcms(x) --> x**3/3 +!============================================================================= +use pietc, only: o3 +use pmat2, only: ldltb, ltdlbv +integer, intent(in ):: n +real(dp),dimension( n),intent(in ):: xs,p +real(dp),dimension( n),intent(out):: q,j +real(dp), intent(out):: en +logical, intent(out):: FF +!---------------------------------------------------------------------------- +integer :: i,ip +real(dp) :: x,x2,sa,sb,ccc,xcmsx2 +real(dp),dimension(n-1) :: difp,sumq,cpp,cqp +real(dp),dimension(n,-1:0):: qq ! <- Tridiagonal, stored as rows of nonupper +!============================================================================= +FF=F +if(n<1)stop 'In fit_uspline; size of data array must be positive' +if(n==1)then; q=0; j=0; en=0; return; endif +! apply a strict monotonicity check on the xs: +do i=2,n + if(xs(i-1)>=xs(i)) then + FF=T + write(41,*) 'In fit_uspline; xs data must increase strictly monotonically' + return + end if +enddo +! Initialize tri-diagonal kernels for the energy definition: +qq=0 ! <- initialize symmetric tridiagonal, kernel for q^T*QQ*q + ! where "q" are the dp/dx at each node. +! The coefficients in the quadratic form defining the spline energy also +! include terms involving factors (p(ip)-p(i))*(q(i)+q(ip)) and +! (p(ip)-p(i))*(p(ip)-p(i)), but these can be dealt with using, respectively, +! the matrices cqp and cpp which are simply diagonal. It is the symmetries +! in the defiition of energy that allow this simplification. + +! Loop over the intervals bounded by consecutive nodes: +do i=1,n-1 + ip=i+1 + difp(i)=p(ip)-p(i) + x2=xs(ip)-xs(i); x=o2*x2! Width, and halfwidth of interval + xcmsx2=o3*x**3*2 + +! ccc is the coefficient of energy integral coupling g(i)*g(i) and g(ip)*g(ip) + ccc=2/x + cpp(i)=u1/xcmsx2 ! Energy coefficient for difp(i)*difp(i)... + cqp(i)=-difp(i)*x/xcmsx2 ! ..and for difp(i)*sumq(i) + qq(i,0)=qq(i,0)+ccc; qq(ip,-1)=qq(ip,-1)+1/x; qq(ip,0)=qq(ip,0)+ccc +enddo +! There is NO exterior energy contributions to qq at both ends: + +! Temporarily, q is made the vector of forcings in the tridiagonal linear +! system from which the final spline coefficients, q, are solved in place. +q(1:n-1)=-cqp; q(n)=0 +q(2:n)=q(2:n)-cqp + +! The following 2 lines solve the tridiagonal system for q: +call ldltb(n,1,qq) ! <- Decompose qq into factors, L*(1/D)*L^T, L=lower +call ltdlbv(n,1,qq,q) ! <- Back-substitute, thus solving for q +sumq=q(1:n-1)+q(2:n) ! <-pairwise sums of derivatives, q: + +! The minimizing energy can now be evaluated as a sum of only 2 terms: +en=o2*(dot_product(difp**2,cpp)+dot_product(sumq,cqp)) + +! Finally, evaluate the 3rd-derivative "jumps", j, at each node: +! Here, sb and sa are the 3rd-derivatives in consecutive intervals +sb=0 +do i=1,n-1 + ip=i+1 + x=o2*(xs(ip)-xs(i)) + xcmsx2=o3*x**3*2 + sa=(x*sumq(i)-difp(i))/xcmsx2 + j(i)=sa-sb + sb =sa +enddo +j(n)=-sb ! Final "sa" is just 0 for the right exterior +end subroutine fit_uspline + +!============================================================================= +subroutine int_uspline(n,xs,p,q, m)! [int_uspline] +!============================================================================= +! Take the sets of n parameters p and q of the untensioned cubic spline +! and return the values of its integral at the n-1 interval midpoints, and +! the value at the last node, assuming that the integral at the first node +! is set to zero. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp),dimension(n),intent(out):: m +!----------------------------------------------------------------------------- +real(dp),parameter:: u3o2=3*o2 +real(dp):: a,b,c,d,e,t2,t3,t4,x,pa,pd,qa,qd +integer :: i,ip +!============================================================================= +! e is the running integral as we loop over successive nodes, so it starts out +! zero at the first node: +e=u0 +! Loop over intervals: +do i=1,n-1 + ip=i+1 + x=(xs(ip)-xs(i))*o2 !<- interval half-width + t2=x*x/2 + t3=t2*x/3 + t4=t3*x/4 + pa=(p(ip)+p(i))*o2 + pd=(p(ip)-p(i))*o2/x + qa=(q(ip)+q(i))*o2 + qd=(q(ip)-q(i))*o2/x +! a,b,c,d are the Taylor coefficients of the cubic about the interval midpoint: + c=qd + a=pa-c*t2 + d=(qa-pd)*u3o2/t2 + b=qa-d*t2 + m(i)=e+a*x-b*t2+c*t3-d*t4 + e=e+2*(a*x+c*t3) +enddo +m(n)=e +end subroutine int_uspline + +!============================================================================= +subroutine eval_tspline(n,xs,p,q, x,y)! [eval_tspline] +!============================================================================= +! Assuming the 1st derivatives, q, are correctly given at the n nodes, xs, +! of the standardized tensioned spline, where p are the nodal values, +! evaluate the spline function y at the location x. +! First find the nonvanishing interval in which x resides, then expand +! y using basis functions implied by the interval-end values of p and q +! using the interval midpoint as local origin when x is interior, or the +! single interval endpoint when it is exterior. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm +!============================================================================ +if(x<=xs(1))then; xr=x-xs(1); y=p(1)+q(1)*expm( xr); return; endif +if(x>=xs(n))then; xr=x-xs(n); y=p(n)-q(n)*expm(-xr); return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=sinh(xh); chh=cosh(xh) +sh =sinh(xr); ch=cosh(xr) +shm=sinhm(xr); chm=coshm(xr) +shhm=sinhm(xh); chhm=coshm(xh) +xcmsh=xcms(xh) +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +end subroutine eval_tspline + +!============================================================================= +subroutine eval_tsplined(n,xs,p,q, x,y,dydx)! [eval_tspline] +!============================================================================= +! Like eval_tspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm,& + qemxr +!============================================================================ +if(x<=xs(1))then + xr=x-xs(1); qemxr=q(1)*expm( xr); y=p(1)+qemxr; dydx=qemxr+q(1); return +endif +if(x>=xs(n))then + xr=x-xs(n); qemxr=q(n)*expm(-xr); y=p(n)-qemxr; dydx=qemxr+q(n); return +endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=sinh(xh); chh=cosh(xh) +sh =sinh(xr); ch=cosh(xr) +shm=sinhm(xr); chm=coshm(xr) +shhm=sinhm(xh); chhm=coshm(xh) +xcmsh=xcms(xh) +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx=qm+qdh*sh +qxh*(xh*chm-shhm) +end subroutine eval_tsplined + +!============================================================================= +subroutine eval_tsplinedd(n,xs,p,q, x,y,dydx,ddydxx)! [eval_tspline] +!============================================================================= +! Like eval_tspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx,ddydxx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm,& + qemxr +!============================================================================ +if(x<=xs(1))then + xr=x-xs(1); qemxr=q(1)*expm( xr); y=p(1)+qemxr; dydx=qemxr+q(1) + ddydxx=dydx; return +endif +if(x>=xs(n))then + xr=x-xs(n); qemxr=q(n)*expm(-xr); y=p(n)-qemxr; dydx=qemxr+q(n) + ddydxx=-dydx; return +endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=sinh(xh); chh=cosh(xh) +sh =sinh(xr); ch=cosh(xr) +shm=sinhm(xr); chm=coshm(xr) +shhm=sinhm(xh); chhm=coshm(xh) +xcmsh=xcms(xh) +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx=qm+qdh*sh +qxh*(xh*chm-shhm) +ddydxx=qdh*ch +qxh*xh*sh +end subroutine eval_tsplinedd + +!============================================================================= +subroutine eval_tsplineddd(n,xs,p,q, x,y,dydx,ddydxx,dddydxxx)! [eval_tspline] +!============================================================================= +! Like eval_tspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx,ddydxx,dddydxxx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm,& + qemxr +!============================================================================ +if(x<=xs(1))then + xr=x-xs(1); qemxr=q(1)*expm( xr); y=p(1)+qemxr; dydx=qemxr+q(1) + ddydxx=dydx; dddydxxx=dydx; return +endif +if(x>=xs(n))then + xr=x-xs(n); qemxr=q(n)*expm(-xr); y=p(n)-qemxr; dydx=qemxr+q(n) + ddydxx=-dydx; dddydxxx=dydx; return +endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=sinh(xh); chh=cosh(xh) +sh =sinh(xr); ch=cosh(xr) +shm=sinhm(xr); chm=coshm(xr) +shhm=sinhm(xh); chhm=coshm(xh) +xcmsh=xcms(xh) +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y =pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx = qm +qdh*sh + qxh*(xh*chm- shhm) +ddydxx = qdh*ch + qxh* xh*sh +dddydxxx= qdh*sh + qxh* xh*ch +end subroutine eval_tsplineddd + +!============================================================================= +subroutine eval_itspline(n,xs, p,q,m, x,y)! [eval_itspline] +!============================================================================= +! Evaluate the integrated tension spline at x, returning the value, y. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q,m +real(dp), intent(in ):: x +real(dp), intent(out):: y +!----------------------------------------------------------------------------- +real(dp):: a,b,c,d,t2,xh,shx,chmx,shmx,chmmx,xcmsx,xr,pa,pd,qa,qd +integer :: ia,ib +!============================================================================= +if(x<=xs(1))then; xr=x-xs(1); y= p(1)*xr+q(1)*expmm( xr); return; endif +if(x>=xs(n))then; xr=x-xs(n); y=m(n)+p(n)*xr+q(n)*expmm(-xr); return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +shx =sinh (xh) +chmx=coshm(xh) +xcmsx=xcms(xh) +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pa=(p(ib)+p(ia))*o2 +pd=(p(ib)-p(ia))*o2/xh +qa=(q(ib)+q(ia))*o2 +qd=(q(ib)-q(ia))*o2/shx +! a,b,c,d are analogous to the Taylor coefficients about the interval midpoint +c=qd +a=pa-c*chmx +d=(qa-pd)*xh/xcmsx +b=qa-d*chmx + +t2=xr**2/2 +shmx =sinhm (xr) +chmmx=coshmm(xr) +y=m(ia)+a*xr+b*t2+c*shmx+d*chmmx +end subroutine eval_itspline + +!============================================================================= +subroutine eval_uspline(n,xs,p,q, x,y)! [eval_uspline] +!============================================================================= +! Assuming the 1st derivatives, q, are correctly given at the n nodes, xs, +! of the standardized untensioned spline, where p are the nodal values, +! evaluate the (UNtensioned) spline function y at the location x. +! First find the nonvanishing interval in which x resides, then expand +! y using basis functions implied by the interval-end values of p and q +! using the interval midpoint as local origin when x is interior, or the +! single interval endpoint when it is exterior. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm +!============================================================================ +if(x<=xs(1))then; xr=x-xs(1); y=p(1)+q(1)*xr; return; endif +if(x>=xs(n))then; xr=x-xs(n); y=p(n)+q(n)*xr; return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=xh; chh=u1 +sh =xr; ch =u1 +shm =xr**3/6; chm =xr**2*o2 +shhm=xh**3/6; chhm=xh**2*o2 +xcmsh=xh**3/3 +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) + +end subroutine eval_uspline + +!============================================================================= +subroutine eval_usplined(n,xs,p,q, x,y,dydx)! [eval_uspline] +!============================================================================= +! Like eval_uspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm +!============================================================================ +if(x<=xs(1))then; xr=x-xs(1); y=p(1)+q(1)*xr; dydx=q(1); return; endif +if(x>=xs(n))then; xr=x-xs(n); y=p(n)+q(n)*xr; dydx=q(n); return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=xh; chh=u1 +sh =xr; ch =u1 +shm =xr**3/6; chm =xr**2*o2 +shhm=xh**3/6; chhm=xh**2*o2 +xcmsh=xh**3/3 +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx=qm+qdh*sh +qxh*(xh*chm-shhm) +end subroutine eval_usplined + +!============================================================================= +subroutine eval_usplinedd(n,xs,p,q, x,y,dydx,ddydxx)! [eval_uspline] +!============================================================================= +! Like eval_uspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx,ddydxx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm +!============================================================================ +if(x<=xs(1))then; xr=x-xs(1); y=p(1)+q(1)*xr; dydx=q(1); return; endif +if(x>=xs(n))then; xr=x-xs(n); y=p(n)+q(n)*xr; dydx=q(n); return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=xh; chh=u1 +sh =xr; ch =u1 +shm =xr**3/6; chm =xr**2*o2 +shhm=xh**3/6; chhm=xh**2*o2 +xcmsh=xh**3/3 +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx=qm+qdh*sh +qxh*(xh*chm-shhm) +ddydxx=qdh +qxh*xh*sh +end subroutine eval_usplinedd + +!============================================================================= +subroutine eval_usplineddd(n,xs,p,q, x,y,dydx,ddydxx,dddydxxx)! [eval_uspline] +!============================================================================= +! Like eval_uspline, but also return the derivative dy/dx +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q +real(dp), intent(in ):: x +real(dp), intent(out):: y,dydx,ddydxx,dddydxxx +!---------------------------------------------------------------------------- +integer :: ia,ib +real(dp):: xr,xh,pm,qm,qah,qbh,qxh,qdh,shh,chh,sh,ch,xcmsh,shm,chm,shhm,chhm +!============================================================================ +if(x<=xs(1))then; xr=x-xs(1); y=p(1)+q(1)*xr; dydx=q(1); return; endif +if(x>=xs(n))then; xr=x-xs(n); y=p(n)+q(n)*xr; dydx=q(n); return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +pm=(p(ia)+p(ib))*o2 ! average of end values +qm=(p(ib)-p(ia))/(xh*2) ! average gradient +qah=q(ia)*o2; qbh=q(ib)*o2 +qxh=qah+qbh-qm ! Half the total excess q at interval ends +qdh=qbh-qah ! Half the difference of q at interval ends +shh=xh; chh=u1 +sh =xr; ch =u1 +shm =xr**3/6; chm =xr**2*o2 +shhm=xh**3/6; chhm=xh**2*o2 +xcmsh=xh**3/3 +qdh=qdh/shh; qxh=qxh/xcmsh ! <- rescale qdh, qxh +y=pm+xr*qm +qdh*(chm-chhm) + qxh*(xh*shm-xr*shhm) +dydx=qm+qdh*sh +qxh*(xh*chm-shhm) +ddydxx=qdh +qxh*xh*sh +dddydxxx=qxh*xh +end subroutine eval_usplineddd + +!============================================================================= +subroutine eval_iuspline(n,xs, p,q,m, x,y)! [eval_iuspline] +!============================================================================= +! Evaluate the integrated untensioned spline at x, returning the value, y. +!============================================================================= +integer, intent(in ):: n +real(dp),dimension(n),intent(in ):: xs,p,q,m +real(dp), intent(in ):: x +real(dp), intent(out):: y +!----------------------------------------------------------------------------- +real(dp),parameter:: u3o2=3*o2 +real(dp):: a,b,c,d,t2,t3,t4,xh,xr,pa,pd,qa,qd +integer :: ia,ib +!============================================================================= +if(x<=xs(1))then; xr=x-xs(1); y=p(1)*xr+q(1)*xr**2/2; return; endif +if(x>=xs(n))then; xr=x-xs(n); y=m(n)+p(n)*xr+q(n)*xr**2/2; return; endif +do ib=2,n + if(xs(ib)<=xs(ib-1))cycle ! <- only consider intervals of positive width + if(xs(ib)>=x)exit ! <- exit once finite interval straddling x is found +enddo +ia=ib-1 +xh=(xs(ib)-xs(ia))*o2 ! <- halfwidth of interval +xr=x-xs(ia)-xh ! <- x relative to interval midpoint +t2=xh**2/2 +t3=t2*xh/3 +pa=(p(ib)+p(ia))*o2 +pd=(p(ib)-p(ia))*o2/xh +qa=(q(ib)+q(ia))*o2 +qd=(q(ib)-q(ia))*o2/xh +! a,b,c,d are the Taylor coefficients of the cubic about the interval midpoint: +c=qd +a=pa-c*t2 +d=(qa-pd)*u3o2/t2 +b=qa-d*t2 +t2=xr**2/2 +t3=t2*xr/3 +t4=t3*xr/4 +y=m(ia)+a*xr+b*t2+c*t3+d*t4 +end subroutine eval_iuspline + +!============================================================================== +subroutine best_tslalom(nh,mh,doru,hgts,hs,halfgate,bigT, & ! [best_slalom] + hgtp,hp,qbest,yabest,enbest,modebest,maxita,maxitb,maxit,maxrts,FF) +!============================================================================== +! Run through the different allowed routes between the slalom gates and +! select as the final solution the one whose spline has the smallest "energy". +!============================================================================== +integer, intent(in ):: nh,mh,doru +integer, dimension(nh), intent(in ):: hgts +real(dp),dimension(nh), intent(in ):: hs +real(dp), intent(in ):: halfgate,bigT +integer, dimension(mh*2),intent( out):: hgtp +real(dp),dimension(mh*2),intent( out):: hp +real(dp),dimension(mh*2),intent( out):: qbest +real(dp),dimension(mh*2),intent( out):: yabest +real(dp), intent( out):: enbest +integer,dimension(mh), intent( out):: modebest +integer, intent(inout):: maxita,maxitb,maxit,maxrts +logical, intent( out):: FF +!----------------------------------------------------------------------------- +integer, dimension(2,mh) :: hgtn +real(dp),dimension(mh*2) :: q,ya +real(dp),dimension(2,2,mh):: hn +real(dp) :: en,tspan,hspan,enbase,hgbigT +integer, dimension(mh) :: code,mode +integer, dimension(mh*2) :: bend +integer :: i,k,m,route_count,ita,ittot +logical, dimension(mh*2) :: off +logical :: flag,descending +!============================================================================== +m=mh*2 +call set_gates(nh,mh,doru,hgts,hs, hgtn,hn,code,FF) +! Examine gate posts of first and last slalom gate to determine whether +! profile is predominantly descending or ascending: +if (hn(1,2,1)>hn(1,1,mh))then; descending=T ! definitely descending +elseif(hn(2,2,1)4)call list_routes(mh,code) ! Only bother to list them when >4 +enbest=hu +flag=T +do k=1,ihu + call next_route(mh,code,mode,flag) + if(flag)then; flag=F; exit; endif + call set_posts(mh,mode,hgtn,hn,bend,hgtp,hp,off) + call slalom_tspline(m,bend,hgtp,hp,off,hgbigT, & + q,ya,en,ita,maxitb,ittot,FF); en=en/enbase + maxita=max(maxita,ita) + maxit =max(maxit,ittot) + if(FF)then + write(41,*) & + 'In best_tslalom; failure flag was raised in call to slalom_tspline' + return + endif + if(en4)call list_routes(mh,code)! Only bother to list them when >4 +enbest=hu +flag=T +do k=1,ihu + call next_route(mh,code,mode,flag) + if(flag)then; flag=F; exit; endif + call set_posts(mh,mode,hgtn,hn,bend,hgtp,hp,off) + call slalom_uspline(m,bend,hgtp,hp,off,halfgate, q,ya,en,ita,maxitb,ittot,FF) + maxita=max(maxita,ita) + maxit =max(maxit,ittot) + if(FF)then + write(41,*) & + 'In best_uslalom; failure flag was raised in call to slalom_uspline' + return + endif + if(en Option code(i) ; ==> Option Code(i) +!............................................................................ +! 0 0 0 +! 2 2 0 +! 3 0 1 +! 4 1 1 +! 5 2 1 +! 8 2 2 +!............................................................................. +! +! The first route code in a chain of gates, ie., code(1), is alway set +! to 0, so at the very least, two combinations of routes are always coded +! according as whether we choose to initialize the spline solution with +! descent through gate 1 or an ascent. If all the gates are temporally +! separated, then then final gate's route_code also has this 0 value +! signifying an indeterminate mode of passage. +! +! In the special case where mh=1 and the given hs data are not enough to +! decide whether this trajectory is descending or ascending, the tie-breaker +! code, doru ("down or up") forces the sense of the trajectory as follows: +! doru=1 ==> descending +! doru=2 ==> ascending +!============================================================================= +integer, intent(in ):: nh,mh,doru +integer, dimension(nh), intent(in ):: hgts +real(dp),dimension(nh), intent(in ):: hs +integer, dimension(2, mh),intent(out):: hgtn +real(dp),dimension(2,2,mh),intent(out):: hn +integer, dimension( mh),intent(out):: code +logical, intent(out):: FF +!----------------------------------------------------------------------------- +real(dp):: hp +integer :: i,im,i2,i2m,imh,n,atti,attim,codeim,hgtp +!============================================================================= +FF=F +n=nh*2 +hgtp=hgts(1)-1 ! <- default "time at present" in units of halfgate +imh=0 +do i=1,nh + i2=i*2 + i2m=i2-1 + hp=hs(i) + if(hgts(i)>hgtp)then +! A new nominal time of observation: + imh=imh+1 + hgtp=hgts(i) + hgtn(1,imh)=hgtp-1 + hgtn(2,imh)=hgtp+1 + hn(:,:,imh)=hp + elseif(hgts(i)=hn(1,1,i))then + atti=1 ! <-descending attitude at common time + code(i)=3 + if(attim==1.and.(codeim==0.or.codeim==3))code(im)=4 + else +! Overlapping, attitude at common time neither ascending nor descending, +! but sense of passage through gates must alternate (code=5). + code(i)=5 + if(hn(2,1,im)<=hn(1,2,i))then; hn(1,2,i) =hn(2,1,im) + else; hn(2,1,im)=hn(1,2,i) + endif + if(hn(2,2,im)<=hn(1,1,i))then; hn(2,2,im)=hn(1,1,i) + else; hn(1,1,i) =hn(2,2,im) + endif + endif + else +! Gates im and i separated by an intermission: + if(hn(2,2,im)<=hn(1,2,i))then + atti=2 ! <-ascending attitude at intermission + if(attim==2.and.(codeim==0.or.codeim==2))code(im)=8 + elseif(hn(2,1,im)>=hn(1,1,i))then + atti=1 ! <-descending attitude at intermission + if(attim==1.and.(codeim==0.or.codeim==3))code(im)=4 + endif + endif + attim=atti + codeim=code(i) +enddo +end subroutine set_gates + +!============================================================================= +subroutine set_posts(mh,mode,hgtn,hn, bend,hgtp,hp,off)! [set_posts] +!============================================================================= +! Given a set of mh double-gates (both descending and ascending types) and +! the array of actual passage modes (i.e., the actual route threading +! the sequence of gates), set the array of actual gateposts coordinates, +! hgtp and hp, and the corresponding set of signs, bend, by which these +! gatepost constraints, when activatived, must alter the principal +! changed derivative of the optimal spline taking the prescribed route. +! Also, flag (using logical array, "off") those gateposts that, for this +! particular route, are redundant owing to existence of duplication of +! consecutive pairs of (hgtp,hp) sometimes occurring when no intermission +! separates consecutive gates. All times are in integer units of halfgate. +!============================================================================= +integer, intent(in ):: mh +integer, dimension( mh),intent(in ):: mode +integer, dimension(2, mh),intent(in ):: hgtn +real(dp),dimension(2,2,mh),intent(in ):: hn +integer, dimension(mh*2), intent(out):: bend,hgtp +real(dp),dimension(mh*2), intent(out):: hp +logical, dimension(mh*2), intent(out):: off +!----------------------------------------------------------------------------- +real(dp):: hprev +integer :: i,i2,i2m,i2mm,im,modei,hgtprev +!============================================================================= +off=F +do i=1,mh + im=i-1 + modei=mode(i) + i2=i*2; i2m=i2-1; i2mm=i2-2 + hgtp(i2m)=hgtn(1,i) + hgtp(i2 )=hgtn(2,i) + hp(i2m)=hn(1,modei,i) + hp(i2 )=hn(2,modei,i) +! Check whether gatepost duplications exist, or one dominates another at same t: + if(i>1)then + if(hgtprev==hgtp(i2m))then + if(hprev==hp(i2m))off(i2m)=T + if(mode(im)==2.and.modei==1)then + if(hprev<=hp(i2m))then + off(i2mm)=T + else + off(i2m)=T + endif + elseif(mode(im)==1.and.modei==2)then + if(hprev<=hp(i2m))then + off(i2m)=T + else + off(i2mm)=T + endif + endif + endif + endif + bend(i2m)=modei*2-3 ! mode=1 ==> bend=-1; mode=2 ==> bend=+1 + bend(i2 )=-bend(i2m)! mode=1 ==> bend=+1; mode=2 ==> bend=-1 + hgtprev=hgtp(i2) + hprev =hp(i2) +enddo +end subroutine set_posts + +!============================================================================= +subroutine count_routes(n,code,count,FF)! [count_routes] +!============================================================================= +! Given the route code array, "code", list all the allowed combinations +! of passage modes (descending === 1; ascending === 2) through the sequence +! of slalom gates. +!============================================================================= +integer, intent(in ):: n +integer,dimension(n),intent(in ):: code +integer, intent(out):: count +logical, intent(out):: FF +!----------------------------------------------------------------------------- +integer,dimension(n):: mode +logical :: flag +!============================================================================ +FF=F +flag=T +do count=0,ihu; call next_route(n,code,mode,flag); if(flag)return; enddo +FF=(count>ihu) +if(FF) write(41,*) 'In count_routes; number of routes exceeds allowance = ',ihu +end subroutine count_routes + +!============================================================================= +subroutine list_routes(n,code)! [list_routes] +!============================================================================= +! Given the route code array, "code", list all the allowed combinations +! of passage modes (descending === 1; ascending === 2) through the sequence +! of slalom gates. +!============================================================================= +integer, intent(in ):: n +integer,dimension(n),intent(in ):: code +!----------------------------------------------------------------------------- +integer,dimension(n):: mode +integer :: i +logical :: flag +!============================================================================ +write(41,'("List all route combinations of ",i4," allowed passage modes")'),n +flag=T +do i=1,ihu + call next_route(n,code,mode,flag) + if(flag)then + write(41,'(" In list_routes; List of routes complete")'); flag=F; exit + endif + write(41,60)i,mode +enddo +if(i>ihu) write(41,'("This list is not necessarily complete")') +60 format(i5,3x,6(2x,5i2)) +end subroutine list_routes + +!============================================================================= +subroutine next_route(n,code,mode,flag)! [next_route] +!============================================================================= +! Given the combinatoric specification of sequentially-conditional +! allowable modes of passage through the n gates encoded in array +! codes, and generically given the present sequence, modes, (a series of +! 1's and 2's denoting respectively descents and ascents through the gates) +! return the next allowed combination defining the updated modes. If instead, +! the intent is to initialize the sequence of modes, input the flag to "true" +! and the first route (array of modes) will be returned (and the flag lowered +! to "false"). +! If there is no "next" route, the sequence having been already exhausted, +! the flag is raised to "true" on output and the route encoded in array, +! modes, is not meaningful. +! When, at gate i, the preceding gate's mode is "modeim" ( = modes(i-1)) +! and the present gate's given route code is code=codes(i), the options +! for choosing mode(i) are encoded in the options code, +! option = options(code, +!============================================================================= +integer, intent(in ):: n +integer,dimension(n),intent(in ):: code +integer,dimension(n),intent(inout):: mode +logical, intent(inout):: flag +!----------------------------------------------------------------------------- +integer,dimension(0:8,2):: options ! <- evaluates the trinary digit of code +integer,dimension(0:2) :: firstmode +integer :: i,im,j,modeim,modejm,option +data options/0,1,2,0,1,2,0,1,2, 0,0,0,1,1,1,2,2,2/ +data firstmode/1,1,2/ +!============================================================================= +modeim=1 ! <-arbitrarily set mode of previous gate passage to "descent" +if(flag)then +! Initialize the route sequence and reset the flag: + do i=1,n + option=options(code(i),modeim) + mode(i)=firstmode(option) + modeim=mode(i) + enddo + flag=F + return +endif + +! Use the present route (array of "mode" elements), and the route code, +! to find the next allowed route, or return with the flag raised when +! no more allowed routes are to be found: +do i=n,1,-1 + im=i-1 + if(i>1)then + modeim=mode(im) + else + modeim=1 + endif + option=options(code(i),modeim) + if(option>0.or.mode(i)==2)cycle + mode(i)=2 + modejm=mode(i) + do j=i+1,n + option=options(code(j),modejm) + mode(j)=firstmode(option) + modejm=mode(j) + enddo + return +enddo +flag=T +end subroutine next_route + +!============================================================================= +subroutine slalom_tspline(n,bend,hgxn,yn,off,bigX, &! [slalom_tspline] + q,ya,en,ita,maxitb,ittot,FF) +!============================================================================= +! Fit a tensioned spline, characteristic abscissa scale, bigX, between the +! "slalom gates" defined by successive pairs of abscissae, integer hgxn, and +! corresponding ordinate values, real yn. Even number n is the total number +! of inequality constraints, or twice the number of gates. There is no +! assumed conditional monotonicity for the gates, but the sense in which +! they are threaded is encoded in the array of signs (-1 or +1), "bend" +! which determines, when activated, the sense in which the gatepost constraint +! changes the principal non-continuous derivative (generally 3rd derivative) +! of the spline. Some gatepost inequality constraints are disabled, as flagged +! by logical array, "off", when two consecutive gateposts constraints are +! identical. +! Subject to the linear inequality constraints, we seek the tensioned +! spline with characteristic scale, bigX, whose energy is minimized. +! The energy of the tensioned spline in the infinitesimal segment [x,x+dx] +! is proportional to half*{ (dy/dx)**2 + (bigT**2)*(ddy/dxx)**2 }*dx. +! The problem is therefore of the type: minimize a quadratic functional +! subject to finitely many (n) linear inequality constraints. +! +! The problem is first standardized by rescaling hgxn (to real xs=xn/bigX) so +! that the characteristic scale becomes unity. We start with a feasible spline +! fitted (equality constraints) to as many of the constraints with distinct +! xs as we can. We "A" iterate from one such feasible, conditionally minimum- +! energy solution to another with a different set of equality constraints +! via an "B" iteration" as follows. The "A" solution generally may have +! constraints at the gateposts that are "pushing" when they should be +! "pulling" (specifically, the sign of the discontinuity in the spline's +! third derivative is the opposite of what it should be at that point). Take +! ALL such violations and, first, simply switch them "off". In general, this +! will cause the energy of the spline to fall significantly, but the resulting +! spline may no longer thread all the slalom gates, so we will have to ADD +! some constraints via what we call the "B-iteration" (whereupon the energy +! increases again, but not to point where it was when we released the +! constraints at this last A-iteration). In the spline's state space, the +! first of the new cycle of B-iterations back-tracks along the line-segment +! joining this new spline-state to the more constrained one we just departed, +! to the point on the spline-state-space segment where the solution becomes +! once again feasible. This involves adding just one more constraint where the +! spine just touches the inside of a slalom gatepost where it did not touch +! before. This new contact is made a new constraint, the spline state is +! recorded as the state reached at the 1st B-iteration, and a new spline +! solution is solved for. If, once again, the spline fails to thread the +! gateposts, then in the next B-iteration, we back-track once again along a +! line segment in spline-space, but this time towards the state at the previous +! B-iteration. Again, we add a new constraint (which adds energy, but still +! not so much that the energy exceeds that of the last A-iteration). We +! continue this process until we have added just enough new constraints to +! achieve a feasible (slalom-threading) spline. This cycle of B-iterations +! is thus complete and, in the generic case, the energy is still smaller +! than it was at the last A-iteration. But since the new configuration may +! be in violation of a new set of "jump-sign" violations, we must check +! whether another A-iteration is required -- and so on. The B-iterations +! are nested within the loop of A-iterations. To summarize: the A-iterations +! release the gatepost constraints where jump-sign violations occur and the +! energy between A-iterations decreases; the B-iterations activate new +! gatepost constraints to keep the spline between the gateposts, and the +! energy between B iterations increases. The process terminates when the +! jump-sign conditions are all satisfied in the generic case. However, we +! find that, in extremely rare and special cases of numerical coincidence, +! jump-sign condition is close enough to machine-zero to be ambiguous -- +! and this seems to occur at the very last stage of the A-iterations. To +! allow for this very rare occurrence, we now check that the energy between +! A-iterations really IS decreasing and, if it is ever found not to be, we +! terminate the iteration anyway. +! +! In general, when the constraint of the final solution is not active, the +! value y of the spline differs from the yn there; it is therefore convenient +! to output what the actual y value of the spline is, which we do in the +! array, ya ("y actual"). +!============================================================================= +integer, intent(in ):: n +integer, dimension(n), intent(in ):: bend,hgxn +real(dp),dimension(n), intent(in ):: yn +logical, dimension(n), intent(in ):: off +real(dp), intent(in ):: bigX +real(dp),dimension(n), intent( out):: q +real(dp),dimension(n), intent( out):: ya +real(dp), intent( out):: en +integer, intent( out):: ita,ittot +integer, intent(inout):: maxitb +logical, intent( out):: FF +!----------------------------------------------------------------------------- +integer,parameter :: nita=50,nitb=80 +real(dp),dimension(n) :: xs,jump,qt,yat +real(dp) :: sj,sjmin,ena +integer :: i,j,k,itb,hgxp +logical,dimension(n) :: on +!============================================================================= +FF=F +! For algebraic convenience, work in terms of rescaled times, xs, of +! the constraints whose given times, hgxn, are in integer units of halfgate +xs=hgxn/bigX + +! Initialize the "A" iteration by fitting a feasible spline to as many +! "gateposts" as is possible with distinct xs. A constraint i is signified +! to be activated when logical array element, on(i), is true: +hgxp=hgxn(1)-1 +do i=1,n + if(off(i))then; on(i)=F; cycle; endif + on(i)=(hgxn(i)>hgxp); if(on(i))hgxp=hgxn(i) +enddo +ittot=1 +call fit_gtspline(n,xs,yn,on,qt,jump,yat,en,FF)! <- Make the initial fit +ena=en +if(FF)then + write(41,*) 'In slalom_tspline; failure flag raised in call to fit_gtspline' + write(41,*) 'at initialization of A loop' + return +endif + +! loop over steps of iteration "A" to check for jump-sign violations +do ita=1,nita + q=qt ! Copy solution vector q of nodal 1st-derivatives + ya=yat ! Copy nodal intercepts + +! Determine whether there exists sign-violations in any active "jumps" +! of the 3rd derviative and, if so, inactivate (on==F) the constraints +! at those points. Also, count the number, j, of such violations. + j=0 + k=0 + sjmin=0 + do i=1,n + if(.not.on(i))cycle + sj=-bend(i)*jump(i) + if(sj<0)then + j=i + on(i)=F + else + k=k+1 ! <- new tally of constraints switched "on" + endif + enddo + if(j==0)exit !<-Proper conditions for a solution are met + if(k==0)on(j)=T ! <- must leave at least one constraint "on" + +! Begin a new "B" iteration that adds as many new constraints as needed +! to keep the new conditional minimum energy spline in the feasible region: + do itb=1,nitb + call fit_gtspline(n,xs,yn,on,qt,jump,yat,en,FF) + if(FF)then + write(41,*)& + 'In slalom_tspline; failure flag raised in call to fit_gtspline' + write(41,*) 'at B loop, iterations ita,itb = ',ita,itb + return + endif + ittot=ittot+1 ! Increment the running total of calls to fit_tspline + +! Determine whether this "solution" wanders outside any slalom gates at +! the unconstrained locations and identify and calibrate the worst violation. +! In this case, sjmin, ends up being the under-relaxation coefficient +! by which we need to multiply this new increment in order to just stay +! within the feasible region of spline space, and constraint j must be +! switched "on": + j=0 + sjmin=u1 + do i=1,n + if(on(i).or.off(i))cycle + sj=bend(i)*(yn(i)-yat(i)) + if(sj<0)then + sj=(yn(i)-ya(i))/(yat(i)-ya(i)) + if(sjnitb) then + FF=T + write(41,*) 'In slalom_tspline; exceeding the allocation of B iterations' + return + end if + q=qt + ya=yat + if(en>=ena)then + write(41,*) 'In slalom_tspline; energy failed to decrease' + exit + endif + ena=en +enddo ! ita loop +if(ita>nita)then + FF=T + write(41,*) 'In slalom_tspline; exceeding the allocation of A iterations' + return +endif +end subroutine slalom_tspline + +!============================================================================= +subroutine slalom_uspline(n,bend,hgxn,yn,off,halfgate,&! [slalom_uspline] + q, ya,en,ita,maxitb,ittot,FF) +!============================================================================= +! Like slalom_tspline, except this treats the special case where the spline +! is untensioned, and therefore the characteristic scale in x become infinite, +! and the spline becomes piecewise cubic instead of involving hyperbolic +! (or exponential) function. In other respects, the logic follows that of +! subroutine slalom_tsline. +!============================================================================= +integer, intent(in ):: n +integer, dimension(n), intent(in ):: bend,hgxn +real(dp),dimension(n), intent(in ):: yn +logical, dimension(n), intent(in ):: off +real(dp), intent(in ):: halfgate +real(dp),dimension(n), intent( out):: q +real(dp),dimension(n), intent( out):: ya +real(dp), intent( out):: en +integer, intent( out):: ita,ittot +integer, intent(inout):: maxitb +logical, intent( out):: FF +!----------------------------------------------------------------------------- +integer,parameter :: nita=50,nitb=80 +real(dp),dimension(n) :: xs,jump,qt,yat +real(dp) :: sj,sjmin,ena +integer :: i,j,k,itb,hgxp +logical,dimension(n) :: on +!============================================================================= +! Initialize the "A" iteration by fitting a feasible spline to as many +! "gateposts" as is possible with distinct xn. A constraint i is signified +! to be activated when logical array element, on(i), is true: +FF=F +xs=hgxn*halfgate +hgxp=hgxn(1)-1 +do i=1,n + if(off(i))then + on(i)=F + cycle + endif + on(i)=(hgxn(i)>hgxp) + if(on(i))hgxp=hgxn(i) +enddo +ittot=1 +call fit_guspline(n,xs,yn,on,qt,jump,yat,en,FF)! <- Make the initial fit +ena=en +if(FF)then + write(41,*) 'In slalom_uspline; failure flag raised in call to fit_guspline' + write(41,*) 'at initialization of A loop' + return +endif + +! loop over steps of iteration "A" to check for jump-sign violations +do ita=1,nita + q=qt ! Copy solution vector q of nodal 1st-derivatives + ya=yat ! Copy nodal intercepts + +! Determine whether there exists sign-violations in any active "jumps" +! of the 3rd derviative and, if so, inactivate (on==F) the constraints +! at those points. Also, count the number, j, of such violations. + j=0 + k=0 + sjmin=0 + do i=1,n + if(.not.on(i))cycle + sj=-bend(i)*jump(i) + if(sj<0)then + j=i + on(i)=F + else + k=k+1 ! <- new tally of constraints switched "on" + endif + enddo + if(j==0)exit !<-Proper conditions for a solution are met + if(k==0)on(j)=T ! <- must leave at least one constraint "on" + +! Begin a new "B" iteration that adds as many new constraints as needed +! to keep the new conditional minimum energy spline in the feasible region: + do itb=1,nitb + call fit_guspline(n,xs,yn,on,qt,jump,yat,en,FF) + if(FF)then + write(41,*)& + 'In slalom_uspline; failure flag raised in call to fit_guspline' + write(41,*) 'at B loop, iterations ita,itb = ',ita,itb + return + endif + ittot=ittot+1 ! Increment the running total of calls to fit_uspline + +! Determine whether this "solution" wanders outside any slalom gates at +! the unconstrained locations and identify and calibrate the worst violation. +! In this case, sjmin, ends up being the under-relaxation coefficient +! by which we need to multiply this new increment in order to just stay +! within the feasible region of spline space, and constraint j must be +! switched "on": + j=0 + sjmin=u1 + do i=1,n + if(on(i).or.off(i))cycle + sj=bend(i)*(yn(i)-yat(i)) + if(sj<0)then + sj=(yn(i)-ya(i))/(yat(i)-ya(i)) + if(sjnitb) then + FF=T + write(41,*) 'In slalom_uspline; exceeding the allocation of B iterations' + return + end if + q=qt + ya=yat + if(en>=ena)then + write(41,*) 'In slalom_uspline; energy failed to decrease' + exit + endif + ena=en +enddo +if(ita>nita)then + FF=T + write(41,*) 'In slalom_uspline; exceeding the allocation of A iterations' + return +endif +end subroutine slalom_uspline + +!============================================================================= +subroutine convertd(n,halfgate,tdata,hdata,phof,&! [convertd] + doru,idx,hgts,hs,descending,FF) +!============================================================================= +! tdata (in single precision real hours) is discretized into bins of size +! gate=2*halfgate (in units of seconds) and expressed as even integer units +! hgts of halfgate that correspond to the mid-time of each bin. (The two +! limits of each time-bin are odd integers in halfgate units.) +!============================================================================= +integer, intent(in ):: n +real(dp), intent(in ):: halfgate +real, dimension(n),intent(in ):: tdata,hdata +integer, dimension(n),intent(in ):: phof +integer, intent(out):: doru +integer, dimension(n),intent(out):: idx,hgts +real(dp),dimension(n),intent(out):: hs +logical, intent(out):: descending +logical, intent(out):: FF +!------------------------------------------------------------------------------ +integer,parameter:: hour=3600 ! 1 hour converted to S.I. units +integer :: i,j,ii,upsign,hgs +real(dp) :: s,gate +!============================================================================= +FF=F +if(size(hdata)/=n)stop 'In convertd; inconsistent dimensions of hdata' +if(size(tdata)/=n)stop 'In convertd; inconsistent dimensions of tdata' +if(size(hs)/=n)stop 'In convertd; inconsistent dimensions of hs' +if(size(hgts)/=n)stop 'In convertd; inconsistent dimensions of hgts' +hs=hdata +! convert to whole number of seconds rounded to the nearest gate=2*halfgate: +upsign=0 +gate=halfgate*2 +do i=1,n + hgts(i)=2*nint(tdata(i)*hour/gate)! + if(phof(i)==5)upsign=1 ! Ascending flight + if(phof(i)==6)upsign=-1 ! Descending flight +enddo +doru=0 +if (upsign>0) then + doru=2 +else + doru=1 +endif +if(n==1)return +if(hgts(1)>hgts(n))then ! Reverse the order: + do i=1,n/2 + j=n+1-i + hgs=hgts(i); hgts(i)=hgts(j); hgts(j)=hgs ! Swap integer hgts + s =hs(i) ; hs(i) =hs(j) ; hs(j) =s ! and swap real hs + enddo +endif +if(upsign==1)then + descending=F +elseif(upsign==-1)then + descending=T +else + descending=(hs(n) 80 characters +c 2014-12-09 Y. Zhu -- Modified the calculation of vertical velocity rate (stored in +c rate_accum) still using a finite-difference method, but now +c calculated for both ascents and descents using the nearest +c neighboring pair which are at least one minute apart (before, +c only only be calculated for descents) +c 2014-12-09 Y. Zhu -- Add new namelist switch "l_mandlvl" which, when F, will skip +c interpolation to mandatory levels +c 2014-12-09 J. Purser/Y. Zhu -- Add new namelist switch "tsplines" which, when T, will +c calculate vertical velocity rate (stored in rate_accum) using +c Jim Purser's tension-spline interpolation utility to get +c continuous gradient results in a profile and mitigate missing +c time information +c 2014-12-12 D. Keyser -- Printout from vertical velocity rate calculation information for +c QC'd merged aircraft reports written to profiles PREPBUFR-like +c file is written to unit 41 rather than stdout. +c 2015-04-17 Y. Zhu -- +c 1) This subroutine is more robust. If there is an error in the +c generation of vertical velocity rate in the tension-spline +c interpolation utility pspl (called in this subroutine), this +c subroutine (and thus the program itself) will no longer abort +c (with either c. code 62, 63 or 64 depending upon which routine +c inside pspl generated the error) but will instead revert to the +c finite difference method for calculating vertical velocity rate. +c 2) Previously, halfgate was set to be 30 for the data profiles that +c don't have second information in time, but a tighter value of 10 +c for the data profiles that do have second information in time. Now +c halfgate is relaxed to be 30 for the data profiles that do have +c complete time information. +c 2016-12-09 D. Keyser -- +c - Nomenclature change: replaced "MDCRS/ACARS" with just "MDCRS". +c - The format for a print statement containing latitude and longitude changed +c to print to 5 decimal places since some aircraft reports contain this +c precision. +c +c Usage: call sub2mem_mer(proflun,bmiss,mxlv,mxnmev,maxmandlvls, +c mandlvls,mesgtype,hdr2wrt, +c acid1,c_acftid1,c_acftreg1, +c rct_accum,drinfo_accum,acft_seq_accum, +c mstq_accum,cat_accum,elv_accum,rpt_accum, +c tcor_accum, +c pevn_accum,pbg_accum,ppp_accum, +c qevn_accum,qbg_accum,qpp_accum, +c tevn_accum,tbg_accum,tpp_accum, +c zevn_accum,zbg_accum,zpp_accum, +c wuvevn_accum,wuvbg_accum,wuvpp_accum, +c wdsevn_accum,mxe4prof,c_qc_accum, +c num_events_prof,lvlsinprof,nlvinprof, +c nrlacqc_pc,l_mandlvl,tsplines,l_operational,lwr) +c +c Input argument list: +c proflun - Unit number for the output post-PREPACQC PREPBUFR-like file containing +c merged profile reports (always) and single(flight)-level reports not +c part of any profile (when l_prof1lvl=T) with added NRLACQC events +c (aircraft data only) +c bmiss - BUFRLIB missing value (set in main program) +c mxlv - Maximum number of levels allowed in a report profile +c mxnmev - Maximum number of events allowed, per variable type +c maxmandlvls - Maxmum number of mandatory pressure levels to consider for aircraft +c profiles +c mandlvls - List of mandatory pressure levels to consider for aircraft profiles +c mesgtype - PREPBUFR message type (AIRCAR or AIRCFT) of the profile in question +c hdr2wrt - Array containing header information for the profile report +c acid1 - Aircraft flight number for the profile MDCRS report {this will be encoded +c into 'ACID' for MDCRS or AMDAR (LATAM only) reports in output PREPBUFR- +c like profiles file} +c c_acftreg - Aircraft tail number for the profile report as used in NRL QC processing +c (passed into this subroutine only for printing purposes) +c c_acftid - Aircraft flight number for the profile report as used in NRL QC +c processing (passed into this subroutine only for printing purposes) +c rct_accum - Array containing receipt time on all profile levels +c drinfo_accum - Array containing drift coordinates (lat, lon, time) on all profile +c levels +c acft_seq_accum - Array containing the temperature precision and flight phase on all +c profile levels +c mstq_accum - Array containing the moisture quality flag on all profile levels +c cat_accum - Array containing the PREPBUFR level categories on all profile levels +c elv_accum - Array containing elevation on all profile levels +c rpt_accum - Array containing reported observation time on all profile levels +c tcor_accum - Array containing time correction indicator on all profile levels +c pevn_accum - Array containing all pressure events (ob, qm, pc, rc) on all profile +c levels +c pbg_accum - Array containing pressure background information on all profile levels +c ppp_accum - Array containing pressure post-processing information on all profile +c levels +c qevn_accum - Array containing all moisture events (ob, qm, pc, rc) on all profile +c levels +c qbg_accum - Array containing moisture background information on all profile levels +c qpp_accum - Array containing moisture post-processing information on all profile +c levels +c tevn_accum - Array containing all temperature events (ob, qm, pc, rc) on all profile +c levels +c tbg_accum - Array containing temperature background information on all profile +c levels +c tpp_accum - Array containing temperature post-processing information on all profile +c levels +c zevn_accum - Array containing all altitude events (ob, qm, pc, rc) on all profile +c levels +c zbg_accum - Array containing altitude background information on all profile levels +c zpp_accum - Array containing altitude post-processing information on all profile +c levels +c wuvevn_accum - Array containing all wind (u/v) events (ob, qm, pc, rc) on all profile +c levels +c wuvbg_accum - Array containing wind (u/v) background information on all profile levels +c wuvpp_accum - Array containing wind (u/v) post-processing information on all profile +c levels +c wdsevn_accum - Array containing all wind (direction/speed) events (ob, qm, pc, rc) on +c all profile levels +c mxe4prof - Maximum number of events in a single-level merged report (i.e., the +c maximum amongst the number of pressure, moisture, temperature, altitude, +c u/v wind and dir/speed wind events) +c c_qc_accum - Array containing NQLACQC quality information 11-character strings on all +c profile levels +c lvlsinprof - Array containing a list of pressure levels that are present in the +c current profile +c nlvinprof - Number of levels in profile +c nrlacqc_pc - PREPBUFR program code for the NRLACQC step +c l_mandlvl - Logical whether to interpolate to mandatory levels in profile generation +c tsplines - Logical whether to use tension-splines for aircraft vertical velocity +c calculation +c l_operational- Run program in operational mode if true +c lwr - Machine word length in bytes (either 4 or 8) +c +c Output argument list: +c hdr2wrt - Array containing header information for the profile report (TYP undated, +c (also changed to highest/lowest pressure level for ascents/descents) +c num_events_prof - Total number of events on an ob, across all levels, across all +c reports (to this point), written into the PREPBUFR-like file (this value +c is the same for each ob type) +c lvlsinprof - Array containing a list of pressure levels that are present in the +c current profile (now possibly also contains mandatory levels) +c +c Output files: +c Unit proflun - PREPBUFR-like file containing merged (mass and wind) profile reports +c (always) and single(flight)-level reports not part of any profile (when +c l_prof1lvl=T) with NRLACQC events +c Unit 06 - Standard output print +c Unit 52 - Text file containing listing of all QC'd merged aircraft reports written +c to profiles PREPBUFR-like file +c +c Subprograms called: +c Unique: none +c Library: +c SYSTEM: SYSTEM +c BUFRLIB: UFBINT IBFMS +c W3NCO: W3TAGE ERREXIT +c W3EMC: ORDERS +c +c Exit States: +c Cond = 0 - successful run +c 59 - nlvinprof is zero coming into this subroutine (should never happen!) +c 61 - index "j is .le. 1 meaning "iord" array underflow (should never happen!) +c +c Remarks: Called by subroutine output_acqc_prof. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine sub2mem_mer(proflun,bmiss,mxlv,mxnmev,maxmandlvls, + + mandlvls,mesgtype,hdr2wrt, + + acid1,c_acftid1,c_acftreg1, + + rct_accum,drinfo_accum,acft_seq_accum, + + mstq_accum,cat_accum,elv_accum,rpt_accum, + + tcor_accum, + + pevn_accum,pbg_accum,ppp_accum, + + qevn_accum,qbg_accum,qpp_accum, + + tevn_accum,tbg_accum,tpp_accum, + + zevn_accum,zbg_accum,zpp_accum, + + wuvevn_accum,wuvbg_accum,wuvpp_accum, + + wdsevn_accum,mxe4prof,c_qc_accum, + + num_events_prof,lvlsinprof,nlvinprof, + + nrlacqc_pc,l_mandlvl,tsplines, + + l_operational,lwr) + + use pkind, only: dp + use pspl, only: bnewton,best_slalom,count_gates,convertd, + + convertd_back + implicit none + +c ------------------------------ +c Parameter statements/constants +c ------------------------------ + integer proflun ! output unit number for post-PREPACQC PREPBUFR-like + ! file containing merged profile reports (always) and + ! single(flight)-level reports not part of any + ! profile (when l_prof1lvl=T) with added NRLACQC + ! events + + real*8 bmiss ! BUFRLIB missing value (set in main program) + +c Variables used to write data to output PREPBUFR-like file in sorted order +c ------------------------------------------------------------------------- + integer mxlv ! maximum number of report levels allowed in aircraft + ! profiles + character*6 cmxlv ! character form of mxlv + + integer mxnmev ! maximum number of events allowed in stack + +, lvlsinprof(mxlv) ! array containing a list of pressure levels that are + ! present in the current profile (later changed to + ! add mandatory levels) + +, mxe4prof ! maximum number of events in a single-level merged + ! report (i.e., the maximum amongst the number of + ! pressure, moisture, temperature, altitude, u/v wind + ! and dir/speed wind events) + +, nlvinprof ! number of levels in a profile upon input + + real*8 hdr2wrt(15) ! header info for current profile (passed in) + +, drinfo_accum(3,mxlv) ! array used to accumulate drift info across profile + ! levels + +, acft_seq_accum(2,mxlv) ! array used to accumulate ACFT_SEQ (PCAT -temperature + ! precision, POAF - phase of flight) info across + ! profile levels + +, mstq_accum(1,mxlv) ! array used to accumulate moisture QC marks across + ! profile levels + +, cat_accum(1,mxlv) ! array used to accumulate level category markers + ! across profile levels + +, elv_accum(1,mxlv) ! array used to accumulate elevation across profile + ! levels + +, rpt_accum(1,mxlv) ! array used to accumulate reported obs time across + ! profile levels + +, tcor_accum(1,mxlv) ! array used to accumulate time correction factor + ! across profile levels + +, rct_accum(1,mxlv) ! array used to accumulate receipt time across profile + ! levels + + real*8 pevn_accum(4,mxlv,mxnmev)! array used to accumulate pressure data/events for a + ! single profile, across profile levels + +, pbg_accum(3,mxlv) ! array used to accumulate pressure background info + ! (POE, PFC, PFCMOD) for a single profile, across + ! profile levels + +, ppp_accum(3,mxlv) ! array used to accumulate pressure post-processing + ! info (PAN, PCL, PCS) for a single profile, across + ! profile levels + + real*8 qevn_accum(4,mxlv,mxnmev)! array used to accumulate moisture data/events for a + ! single profile, across profile levels + +, qbg_accum(3,mxlv) ! array used to accumulate moisture background info + ! (QOE, QFC, QFCMOD) for a single profile, across + ! profile levels + +, qpp_accum(3,mxlv) ! array used to accumulate moisture post-processing + ! info (QAN, QCL, QCS) for a single profile, across + ! profile levels + + real*8 tevn_accum(4,mxlv,mxnmev)! array used to accumulate temperature data/events + ! for a single profile, across profile levels + +, tbg_accum(3,mxlv) ! array used to accumulate temperature background + ! info (TOE, TFC, TFCMOD) for a single profile, + ! across profile levels + +, tpp_accum(3,mxlv) ! array used to accumulate temperature post- + ! processing info (TAN, TCL, TCS) for a single + ! profile, across profile levels + + real*8 zevn_accum(4,mxlv,mxnmev)! array used to accumulate altitude data/events for a + ! single profile, across profile levels + +, zbg_accum(3,mxlv) ! array used to accumulate altitude background info + ! (ZOE, ZFC, ZFCMOD) for a single profile, across + ! profile levels + +, zpp_accum(3,mxlv) ! array used to accumulate altitude post-processing + ! info (ZAN, ZCL, ZCS) for a single profile, across + ! profile levels + + real*8 wuvevn_accum(5,mxlv,mxnmev)! array used to accumulate wind data/events (u/v + ! components) for a single profile, across profile + ! levels + +, wuvbg_accum(5,mxlv) ! array used to accumulate wind background info (WOE, + ! UFC, VFC, UFCMOD, VFCMOD) for a single profile, + ! across profile levels + +, wuvpp_accum(6,mxlv) ! array used to accumulate wind post-processing info + ! (UAN, VAN, UCL, VCL, UCS, VCS) for a single + ! profile, across profile levels + + real*8 wdsevn_accum(5,mxlv,mxnmev)! array used to accumulate wind data/events + ! (direction/speed) for a single profile, across + ! profile levels + + character*11 c_qc_accum(mxlv) ! array used to accumulate NRLACQC quality information + ! on individual obs in a profile, across profile + ! levels + +c Logicals controlling processing (not read in from namelist in main program) +c --------------------------------------------------------------------------- + logical l_mandlvl ! T=interpolate to mandatory levels in profile + ! generation + ! F=do not interpolate to mandatory levels in profile + ! generation + logical tsplines ! T=use tension-splines for aircraft vertical velocity + ! calculation + ! F=use finite-differencing for aircraft vertical + ! velocity calculation + logical l_operational ! Run program in operational mode if true + +c Summary counters +c ---------------- + integer num_events_prof ! total number of events on an ob, across all levels, + ! across all reports, written in the PREPBUFR-like + ! (profiles) file (this value is the same for each + ! ob type) +c Mandatory levels settings +c ------------------------- + integer maxmandlvls ! maxmum number of mandatory pressure levels to + ! consider for aircraft profiles + +, mandlvls(maxmandlvls) ! list of mandatory pressure levels to consider for + ! aircraft profiles + +, nmandlvls ! number of mandatory levels interpolated for this + ! profile + +, nmNbtw ! number of mandatory levels between "bread of the + ! sandwich" reports + + character*8 mesgtype ! BUFR message type (e.g., 'AIRCFT ') + + real*8 acid1 ! aircraft flight number for the profile MDCRS or AMDAR + ! (LATAM only) report + +, acid_arr1 ! used with ufbint routine to encode aircraft flight + ! number (ACID) into MDCRS or AMDAR (LATAM only) + ! reports in output PREPBUFR-like file) + + character*9 c_acftid1 ! aircraft flight number (as processed by NRLACQC) + ! for the profile report (used for printing purposes + ! only) + + character*8 c_acftreg1 ! aircraft tail number (as processed by NRLACQC) + ! for the profile report (used for printing purposes + ! only) + + integer nlv2wrt_tot ! total number of levels to write in this profile, + ! including any interpolated mandatory levels + character*6 cnlv2wrt_tot ! character form of nlv2wrt_tot + + integer nlv2wrt ! number of levels in profile to write to output + character*6 cnlv2wrt ! character form of nlv2wrt + + integer nlvwrt ! number of levels written to output PREPBUFR-like + ! file + + real*8 pevns4(4,mxlv) ! array used with ufbint routine to encode pressure + ! events into output PREPBUFR-like file + +, qevns4(4,mxlv) ! array used with ufbint routine to encode moisture + ! events into output PREPBUFR-like file + +, tevns4(4,mxlv) ! array used with ufbint routine to encode temperature + ! events into output PREPBUFR-like file + +, zevns4(4,mxlv) ! array used with ufbint routine to encode altitude + ! events into output PREPBUFR-like file + +, wuvevns5(5,mxlv) ! array used with ufbint routine to encode wind (u/v + ! component) events into output PREPBUFR-like file + +, wdsevns5(5,mxlv) ! array used with ufbint routine to encode wind + ! (direction/speed) events into output PREPBUFR-like + ! file + +c For background/post-processing info +c ----------------------------------- + real*8 pbgarr3(3,mxlv) ! array used with ufbint routine to encode pressure + ! background info into output PREPBUFR-like file + +, qbgarr3(3,mxlv) ! array used with ufbint routine to encode moisture + ! background info into output PREPBUFR-like file + +, tbgarr3(3,mxlv) ! array used with ufbint routine to encode temperature + ! background info into output PREPBUFR-like file + +, zbgarr3(3,mxlv) ! array used with ufbint routine to encode altitude + ! background info into output PREPBUFR-like file + +, wuvbgarr5(5,mxlv) ! array used with ufbint routine to encode wind (u/v + ! component) background info into output PREPBUFR- + ! like file + +, ppparr3(3,mxlv) ! array used with ufbint routine to encode pressure + ! post-processing info into output PREPBUFR-like file + +, qpparr3(3,mxlv) ! array used with ufbint routine to encode moisture + ! post-processing info into output PREPBUFR-like file + +, tpparr3(3,mxlv) ! array used with ufbint routine to encode temperature + ! post-processing info into output PREPBUFR-like file + +, zpparr3(3,mxlv) ! array used with ufbint routine to encode altitude + ! post-processing info into output PREPBUFR-like file + +, wuvpparr6(6,mxlv) ! array used with ufbint routine to encode wind (u/v + ! component) info into output PREPBUFR-like file + +, drarr3(3,mxlv) ! array used with ufbint routine to encode drift info + ! into output PREPBUFR-like file + +, acft_seq_arr2(2,mxlv)! array used with ufbint routine to encode PCAT, POAF + ! into output PREPBUFR-like file + +, mstq_arr1(1,mxlv) ! array used with ufbint routine to encode moisture QC + ! flag into output PREPBUFR-like file + +, cat_arr1(1,mxlv) ! array used with ufbint routine to encode level + ! category info into output PREPBUFR-like file + +, rct_arr1(1,mxlv) ! array used with ufbint routine to encode level + ! receipt time info into output PREPBUFR-like file + +, ialr_arr1(1,mxlv) ! array used with ufbint routine to encode ascent/ + ! descent rate into output PREPBUFR-like file + +, turb_arr4(4,mxlv) ! array used with ufbint routine to encode turbulence + ! data into output PREPBUFR-like file + +C Arrays associated with sorting of data +c -------------------------------------- + integer iwork(mxlv) ! work array + +, iord(mxlv) ! array containing sorted index + +C Loop indices +c ------------ + integer i,j,k,l ! original (unsorted) indices + +, iii ! index + +, jj ! sorted (pressure low->high) index pointing to lvl j + +, jjp1 ! sorted index pointing to next level below jj + +, jjm1 ! sorted index pointing to previous level above jj + +, jjp2 ! sorted index pointing to next level below jjp1 + +, jjm2 ! sorted index pointing to previous level above jjm1 + +, jjmaxp ! sorted index pointing to level jj with max pressure + +, jjminp ! sorted index pointing to level jj with min pressure + +, jjpnmnbtw ! sorted index pointing to next level below jj that is + ! not a mandatory pressure level + +, jk ! index, + +, c1_jk ! index, + +, c2_jk ! index, + +, jkp ! index, + +, jkm ! index, + +, jjp ! index, + +, jjm ! index, + +, kk ! sorted (pressure low->high) index pointing to lvl k + +, jjpk ! sorted index pointing to level jj plus k + + real pul ! pressure ob at level "below" mandatory level (higher + ! pressure, lower altitude) + +, pll ! pressure ob at level "above" mandatory level (lower + ! pressure, higher altitude) + +, pqul ! pressure qm at level "below" mandatory level (higher + ! pressure, lower altitude) + +, pqll ! pressure qm at level "above" mandatory level (lower + ! pressure, higher altitude) + +, pml ! pressure ob at mandatory level + +, tul ! temperature ob at level "below" mandatory level + ! (higher pressure, lower altitude) + +, tll ! temperature ob at level "above" mandatory level + ! (lower pressure, higher altitude) + +, tqul ! temperature qm at level "below" mandatory level + ! (higher pressure, lower altitude) + +, tqll ! temperature qm at level "above" mandatory level + ! (lower pressure, higher altitude) + +, tml ! temperature ob at mandatory level + +, dt_dlnp ! change in temperature w.r.t. change in log-pressure + +, qul ! moisture ob at level "below" mandatory level (higher + ! pressure, lower altitude) + +, qll ! moisture ob at level "above" mandatory level (lower + ! pressure, higher altitude) + +, qqul ! moisture qm at level "below" mandatory level (higher + ! pressure, lower altitude) + +, qqll ! moisture qm at level "above" mandatory level (lower + ! pressure, higher altitude) + +, qml ! moisture ob at mandatory level + +, dq_dlnp ! change in moisture w.r.t. change in log-pressure + +, zul ! altitude ob at level "below" mandatory level (higher + ! pressure, lower altitude) + +, zll ! altitude ob at level "above" mandatory level (lower + ! pressure, higher altitude) + +, zqul ! altitude qm at level "below" mandatory level (higher + ! pressure, lower altitude) + +, zqll ! altitude qm at level "above" mandatory level (lower + ! pressure, higher altitude) + +, zml ! altitude ob at mandatory level + +, dz_dlnp ! change in altitude w.r.t. change in log-pressure + +, uul ! u-comp of wind ob at level "below" mandatory level + ! (higher pressure, lower altitude) + +, ull ! u-comp of wind ob at level "above" mandatory level + ! (lower pressure, higher altitude) + +, uml ! u-comp of wind ob at mandatory level + +, du_dlnp ! change in u-comp of wind w.r.t. change in + ! log-pressure + +, vul ! v-comp of wind ob at level "below" mandatory level + ! (higher pressure, lower altitude) + +, vll ! v-comp of wind ob at level "above" mandatory level + ! (lower pressure, higher altitude) + +, vml ! v-comp of wind ob at mandatory level + +, dv_dlnp ! change in v-comp of wind w.r.t. change in + ! log-pressure + +, uvqul ! u/v-comp of wind qm at level "below" mandatory level + ! (higher pressure, lower altitude) + +, uvqll ! u/v-comp of wind qm at level "above" mandatory level + ! (lower pressure, higher altitude) + + integer ibfms ! BUFRLIB function for testing for missing + + real*8 dtime_dlnp ! change in time w.r.t. change in log-pressure + + real dist_pul_pll ! horizontal distance traveled when going from point + ! at pll to pul + +, spd_pul_pll ! average speed while traveling from point at pll to + ! pul + +, dist2pml ! horizontal distance traveled when going from point + ! at pll to pml +! vvvv DAK-future change perhaps to account for incr. lat/lon precision + +, lat_pul ! latitude at data level "below" mandatory level + ! (higher pressure, lower altitude) + +, lon_pul ! longitude at data level "below" mandatory level + ! (higher pressure, lower altitude) + +, lat_pll ! latitude at data level "above" mandatory level + ! (lower pressure, higher altitude) + +, lon_pll ! longitude at data level "above" mandatory level + ! (lower pressure, higher altitude) +! ^^^^ DAK-future change perhaps to account for incr. lat/lon precision + +, radius_e ! radius of the earth in meters + +, deg2rad ! conversion factor for converting degrees -> radians + + parameter(radius_e = 6371229.) + parameter(deg2rad = 3.14159274/180.) + + real*8 delx ! change in longitude/nmNbtw + +, dely ! change in latitude/nmNbtw + +, dt ! delta time (sec) between two levels, used to + ! calculate instantaneous altitude (ascent/descent) + ! rate + +, dt_new ! delta time + +, rate_accum(mxlv) ! array of instantaneous altitude (ascent/descent) + ! rates on all levels of profile + +c Variables used in printing values for a particular report and level +c ------------------------------------------------------------------- + integer ihdr2wrt9 ! PREPBUFR instrument type ("ITP" from header) + +, iacft_seq_accum2 ! temperature precision, and phase of flight + +, idrinfo_accum3 ! drift information + +, izevn_accum1 ! altitude ob + +, iwdsevn_accum1 ! wind direction ob + +, ipevn_accum2 ! pressure quality mark + +, izevn_accum2 ! altitude quality mark + +, itevn_accum2 ! temperature quality mark + +, iqevn_accum2 ! moisture quality mark + +, iwuvevn_accum3 ! wind quality mark + +, ipevn_accum4 ! pressure reason code + +, izevn_accum4 ! altitude reason code + +, itevn_accum4 ! temperature reason code + +, iqevn_accum4 ! moisture code + +, iwuvevn_accum5 ! wind reason code + +, nevents_t ! number of events on temperature + +, nevents_q ! number of events on moisture + +, nevents_w ! number of events on wind + +, imstq_accum1 ! moisture qc flag + +, icat_accum1 ! PREPBUFR level category ("CAT") + +, ihdr2wrt6 ! PREPBUFR report type ("TYP" from header) + + real*8 wspd ! wind speed ob + +, q_sphum ! moisture (specific humidity) ob + +, hdr2wrt1 ! real form of PREPBUFR report id ("SID" from header) + +c Misc. +c ----- + real nrlacqc_pc ! PREPBUFR program code for the NRLACQC step + + integer lwr ! machine word length in bytes (either 4 or 8) + +c Variables related to tspline + integer, parameter:: nit=30 +! real(dp),parameter:: bigT=120.0,halfgate=30.0,heps=.01 + real(dp),parameter:: bigT=120.0,heps=.01 + integer nh,nh2,m,mh,maxita,maxitb,maxit,maxrts,doru + integer err_tspline + real(dp) enbest,timemin + real(dp) halfgate + integer, allocatable :: idx(:) + integer, allocatable :: modebest(:) + integer, allocatable :: pof(:) + integer, allocatable :: hgts(:) + integer, allocatable :: hgtp(:) + real, allocatable :: tdata(:),hdata(:),wdata(:) + real(dp), allocatable :: te(:),hs(:),dhdt(:) + real(dp), allocatable :: hp(:) + real(dp), allocatable :: qbest(:),habest(:) + logical descending,FF,nearsec + +c ---------------------------------------------------- + +c Start program +c ------------- +ccc print *, 'in sub2mem_mer for the next merged report' + + rate_accum = bmiss + + if(nlvinprof.eq.0) then + print * + print *, '### PROBLEM - into subr, sub2mem_mer with nlvinprof ', + + '= ',0 + print *, ' this should never happen!!' + print * + call w3tage('PREPOBS_PREPACQC') + call errexit(59) + endif + +c First sort pressures from lowest to highest, this will also determine the maximum and +c minimum pressure values in this profile +c ------------------------------------------------------------------------------------- + call orders(1,iwork,lvlsinprof,iord,nlvinprof,1,lwr,2) + +ccc print *, '.. there are originally ',nlvinprof,' p-levels in this', +ccc + ' report' + +c Interpolate z,t,q,u,v values to mandatory levels - include the levels of 1000, 850, 700, +c 500, 400, 300, 200, 150 and 100 mb in the acceptable mandatory levels for aircraft +c profiles (not many aircraft flying above 100 mb!) +c --------------------------------------------------------------------------------------- + nmandlvls = 0 + nlv2wrt_tot = nlvinprof + + if(l_mandlvl .and. nlvinprof.gt.1) then ! do interpolation only for profiles with + ! more than one report! + loop1: do i = 1,maxmandlvls ! maxmandlvls=9 - number of mandatory levels to check + do j = 1,nlvinprof ! levels will appear in increasing order via index + ! jj... first level might be 247 mb, second might be + ! 427 mb, etc. + jj = iord(j) + jjp1 = iord(j+1) + + if(j.lt.nlvinprof) then ! exclude last level in profile (one closest to the + ! ground) (use .lt. instead of .le. to do this); only + ! interpolate for mandatory levels sandwiched by + ! actual data + +c Below, jj points to level at a lower pressure/higher altitude and jjp1 points to the +c adjacent level at a higher pressure, lower altitude) +c ------------------------------------------------------------------------------------ + if(lvlsinprof(jj) .lt.mandlvls(i) .and. + + lvlsinprof(jjp1).gt.mandlvls(i)) then + + if(nlvinprof+nmandlvls+1.gt.mxlv) then +C....................................................................... +C There are more levels in profile than "mxlv" -- do not process any more levels +C ------------------------------------------------------------------------------ + print 53, mxlv,mxlv + 53 format(/' #####> WARNING: THERE ARE MORE THAN ',I6,' LEVELS IN ', + + 'THIS PROFILE -- WILL CONTINUE ON PROCESSING ONLY ',I6,' LEVELS', + + ' FOR THIS PROFILE'/) + write(cmxlv,'(i6)') mxlv + call system('[ -n "$jlogfile" ] && $DATA/postmsg'// + + ' "$jlogfile" "***WARNING:'//cmxlv//' AIRCRAFT '// + + 'PROFILE LEVEL LIMIT EXCEEDED IN '// + + 'PREPOBS_PREPACQC, ONLY '//cmxlv//' LEVELS '// + + 'PROCESSED"') + exit loop1 +C....................................................................... + endif + + nmandlvls = nmandlvls + 1 + +c Now calculate values on mandlvls(i) using values at lvlsinprof(j) (ll/lower level and (j+1) +c (ul/upper level) - USE REASON CODE 98 FOR INTERPOLATED MANDATORY LEVELS (use highest +c quality mark amongst lower and upper levels) +c ------------------------------------------------------------------------------------------- + pll = lvlsinprof(jj) ! pressure ob at level "above" mandatory level + pul = lvlsinprof(jjp1) ! pressure ob at level "below" mandatory level + pqll = pevn_accum(2,jj,1) ! pressure qm at level "above" mandatory level + pqul = pevn_accum(2,jjp1,1) ! pressure qm at level "below" mandatory level + pml = mandlvls(i) ! pressure at mandatory level + + lvlsinprof(nlvinprof+nmandlvls) = mandlvls(i) + pevn_accum(1,nlvinprof+nmandlvls,1) = pml/10. ! POB + pevn_accum(2,nlvinprof+nmandlvls,1) = max(pqll,pqul) ! PQM + pevn_accum(3,nlvinprof+nmandlvls,1) = nrlacqc_pc ! PPC + pevn_accum(4,nlvinprof+nmandlvls,1) = 98 ! PRC + + cat_accum(1,nlvinprof+nmandlvls) = 7 ! interpolated mand. levels get CAT = 7 + +c Temperature +c ----------- + if(ibfms(tevn_accum(1,jj,1)).eq.0 .and. + + ibfms(tevn_accum(1,jjp1,1)).eq.0 ) then ! temperature isn't missing + do iii = mxe4prof,1,-1 + if(ibfms(tevn_accum(1,jj,iii)).ne.0) then + nevents_t = iii + else + nevents_t = iii + exit + endif + enddo + tll = tevn_accum(1,jj,nevents_t) ! temp ob at lvl "above" mandatory level + tqll = tevn_accum(2,jj,nevents_t) ! temp qm at lvl "above" mandatory level + do iii = mxe4prof,1,-1 + if(ibfms(tevn_accum(1,jjp1,iii)).ne.0) then + nevents_t = iii + else + nevents_t = iii + exit + endif + enddo + tul = tevn_accum(1,jjp1,nevents_t) ! temp ob at lvl "below" mandatory level + tqul = tevn_accum(2,jjp1,nevents_t) ! temp qm at lvl "below" mandatory level +ccccc print *, 'pmd, pll, pul, tqll,tqul: ',pml, pll, pul, +ccccc+ tqll,tqul + + dt_dlnp = (tul - tll)/alog(pul/pll) + + tml = tll + (dt_dlnp * (alog(pml/pll))) + + tevn_accum(1,nlvinprof+nmandlvls,1) = tml ! TOB + tevn_accum(2,nlvinprof+nmandlvls,1) = max(tqll,tqul) ! TQM + tevn_accum(3,nlvinprof+nmandlvls,1) = nrlacqc_pc ! TPC + tevn_accum(4,nlvinprof+nmandlvls,1) = 98 ! TRC + + endif ! temps missing? + +c Moisture +c -------- + if(ibfms(qevn_accum(1,jj,1)).eq.0 .and. + + ibfms(qevn_accum(1,jjp1,1)).eq.0 ) then ! moisture isn't missing + do iii = mxe4prof,1,-1 + if(ibfms(qevn_accum(1,jj,iii)).ne.0) then + nevents_q = iii + else + nevents_q = iii + exit + endif + enddo + qll = qevn_accum(1,jj,nevents_q) ! q ob at level "above" mandatory level + qqll = qevn_accum(2,jj,nevents_q) ! q qm at level "above" mandatory level + do iii = mxe4prof,1,-1 + if(ibfms(qevn_accum(1,jjp1,iii)).ne.0) then + nevents_q = iii + else + nevents_q = iii + exit + endif + enddo + qul = qevn_accum(1,jjp1,nevents_q) ! q ob at level "below" mandatory level + qqul = qevn_accum(2,jjp1,nevents_q) ! q qm at level "below" mandatory level + + dq_dlnp = (qul - qll)/alog(pul/pll) + + qml = qll + (dq_dlnp * (alog(pml/pll))) + + qevn_accum(1,nlvinprof+nmandlvls,1) = qml ! QOB + qevn_accum(2,nlvinprof+nmandlvls,1) = max(qqll,qqul) ! QQM + qevn_accum(3,nlvinprof+nmandlvls,1) = nrlacqc_pc ! QPC + qevn_accum(4,nlvinprof+nmandlvls,1) = 98 ! QRC + + else ! if moisture missing, check to see if QFC is present for "bread" + ! levels; if so, interpolate QFC + if(ibfms(qbg_accum(2,jj)).eq.0 .and. + + ibfms(qbg_accum(2,jjp1)).eq.0 ) then ! QFC isn't missing for "bread" + ! levels + qll = qbg_accum(2,jj) ! QFC at ob level "above" mandatory level + qul = qbg_accum(2,jjp1) ! QFC at ob level "below" mandatory level + + dq_dlnp = (qul - qll)/alog(pul/pll) + + qml = qll + (dq_dlnp * (alog(pml/pll))) + + qbg_accum(2,nlvinprof+nmandlvls) = qml ! QFC + + endif ! is QFC present for "bread" levels when moisture missing? + endif ! moisture missing? + +c Altitude +c -------- + if(ibfms(zevn_accum(1,jj,1)).eq.0 .and. + + ibfms(zevn_accum(1,jjp1,1)).eq.0 ) then ! altitude isn't missing + zll = zevn_accum(1,jj,1) ! z ob at level "above" mandatory level + zul = zevn_accum(1,jjp1,1) ! z ob at level "below" mandatory level + zqll = zevn_accum(2,jj,1) ! z qm at level "above" mandatory level + zqul = zevn_accum(2,jjp1,1) ! z qm at level "below" mandatory level + + dz_dlnp = (zul - zll)/alog(pul/pll) + + zml = zll + (dz_dlnp * (alog(pml/pll))) + + zevn_accum(1,nlvinprof+nmandlvls,1) = zml ! ZOB + zevn_accum(2,nlvinprof+nmandlvls,1) = max(zqll,zqul) ! ZQM + zevn_accum(3,nlvinprof+nmandlvls,1) = nrlacqc_pc ! ZPC + zevn_accum(4,nlvinprof+nmandlvls,1) = 98 ! ZRC + + endif ! altitude missing? + +c u- and v- components of wind +c ---------------------------- + if(ibfms(wuvevn_accum(1,jj,1)).eq.0 .and. + + ibfms(wuvevn_accum(1,jjp1,1)).eq.0 .and. + + ibfms(wuvevn_accum(2,jj,1)).eq.0 .and. + + ibfms(wuvevn_accum(2,jjp1,1)).eq.0) then ! u and v aren't missing + do iii = mxe4prof,1,-1 + if(ibfms(wuvevn_accum(1,jj,iii)).ne.0 .or. + + ibfms(wuvevn_accum(2,jj,iii)).ne.0) then + nevents_w = iii + else + nevents_w = iii + exit + endif + enddo + ull = wuvevn_accum(1,jj,nevents_w) ! UOB ob at lvl "above" mandatory lvl + vll = wuvevn_accum(2,jj,nevents_w) ! VOB ob at lvl "above" mandatory lvl + uvqll = wuvevn_accum(3,jj,nevents_w) ! UOB/VOB qm at lvl "above" mandatory + ! lvl + do iii = mxe4prof,1,-1 + if(ibfms(wuvevn_accum(1,jjp1,iii)).ne.0 .or. + + ibfms(wuvevn_accum(2,jjp1,iii)).ne.0) then + nevents_w = iii + else + nevents_w = iii + exit + endif + enddo + uul = wuvevn_accum(1,jjp1,nevents_w) ! UOB ob at lvl "below" mandatory lvl + vul = wuvevn_accum(2,jjp1,nevents_w) ! VOB ob at lvl "below" mandatory lvl + uvqul = wuvevn_accum(3,jjp1,nevents_w) ! UOB/VOB qm at lvl "below" mandatory + ! lvl + + du_dlnp = (uul - ull)/alog(pul/pll) + dv_dlnp = (vul - vll)/alog(pul/pll) + + uml = ull + (du_dlnp * (alog(pml/pll))) + vml = vll + (dv_dlnp * (alog(pml/pll))) + + wuvevn_accum(1,nlvinprof+nmandlvls,1) = uml ! UOB + wuvevn_accum(2,nlvinprof+nmandlvls,1) = vml ! VOB + wuvevn_accum(3,nlvinprof+nmandlvls,1) = + + max(uvqll,uvqul) ! WQM + wuvevn_accum(4,nlvinprof+nmandlvls,1) = nrlacqc_pc ! WPC + wuvevn_accum(5,nlvinprof+nmandlvls,1) = 98 ! WRC + + endif ! wind missing? + + endif ! calc values for this mandatory level? + endif ! j.lt.nlvinprof + enddo ! j = 1,nlvinprof + enddo loop1 ! i = 1,maxmandlvls + + nlv2wrt_tot = nlvinprof + nmandlvls +ccc print'(" .. there are eventually ",I0," p-levels in this ", +ccc + "report (incl. mand. levels to which obs interp. to)")', +ccc + nlv2wrt_tot + +c Re-sort pressures (now with mandatory levels inclded) from lowest to highest +c ---------------------------------------------------------------------------- + call orders(1,iwork,lvlsinprof,iord,nlv2wrt_tot,1,lwr,2) + + end if ! l_mandlvl .and. nlvinprof.gt.1 + +c ----------------------------------------- +c Calculate vertical velocity rate_accum +c add ascent/descent rate here +c ----------------------------------------- + write(41,*) 'nlv2wrt_tot=', nlv2wrt_tot,'c_acftreg=',c_acftreg1 + err_tspline = 0 + + if ((nlv2wrt_tot.gt.1) .and. tsplines) then + nh = 0 + do j = 1,nlv2wrt_tot + jj = iord(j) + if (ibfms(drinfo_accum(3,jj)).eq.0) then + nh = nh + 1 +c write(41,*) 'j,ord,z,t=', j, jj,zevn_accum(1,jj,1), +c + drinfo_accum(3,jj) + end if + end do + nh2 = nh * 2 + + halfgate=30.0 +! nearsec=.false. +! do j = 1,nlv2wrt_tot +! jj = iord(j) +! if (ibfms(drinfo_accum(3,jj)).eq.0) then +! timemin=drinfo_accum(3,jj)*60.0 +! timemin=abs(timemin-nint(timemin)) +! if (timemin>=0.01 .and. timemin<=0.99) nearsec=.true. +! end if +! end do +! if (nearsec) halfgate=10.0 + write(41,*) 'halfgate=', halfgate + + allocate(idx(nh),pof(nh)) + allocate(tdata(nh),hdata(nh),wdata(nh)) + allocate(te(nh),hgts(nh),hs(nh),dhdt(nh)) + maxita = 0 + maxitb = 0 + maxrts = 0 + maxit = 0 + + nh = 0 + do j = 1,nlv2wrt_tot + jj = iord(j) + if (ibfms(drinfo_accum(3,jj)).eq.0) then + nh = nh + 1 + tdata(nh) = drinfo_accum(3,jj) ! hours + hdata(nh) = zevn_accum(1,jj,1) ! meters + pof(nh) = nint(acft_seq_accum(2,jj)) + write(41,*) 'tdata,hdata,pof=',nh,tdata(nh),hdata(nh), + + pof(nh) + end if + end do + +c arrange data with time increase + call convertd(nh,halfgate,tdata,hdata,pof, + + doru,idx,hgts,hs,descending,FF) +!!!!!!!! if (FF) call w3tage('PREPOBS_PREPACQC') +!!!!!!!! if (FF) call errexit(62) + if (FF) then +c Error generating vertical velocity rate in tension-spline interpolation utility pspl +c (coming out of subroutine convertd) - use finite difference method +c ------------------------------------------------------------------------------------ + print*,"WARNING: tspline err in utility pspl, coming out ", + + "of subr. convertd - use finite difference method" + write(41,*)"WARNING: tspline err in utility pspl, coming ", + + "out of subr. convertd - use finite difference ", + + "method" + err_tspline = 1 + go to 666 + end if + if (descending)then + write(41,'('' set descending'')') + else + write(41,'('' set ascending'')') + endif + + call count_gates(nh,hgts(1:nh),mh) + m = mh*2 + allocate(hgtp(m),hp(m),qbest(m),habest(m),modebest(mh)) + call best_slalom(nh,mh,doru,hgts,hs,halfgate,bigT,hgtp,hp, + + qbest,habest,enbest,modebest,maxita,maxitb,maxit,maxrts,FF) + write(41,*) 'maxita,maxitb,maxit,maxrts=',maxita,maxitb,maxit, + + maxrts +!!!!!!!! if (FF) call w3tage('PREPOBS_PREPACQC') +!!!!!!!! if (FF) call errexit(63) + if (FF) then +c Error generating vertical velocity rate in tension-spline interpolation utility pspl +c (coming out of subroutine best_slalom) - use finite difference method +c ------------------------------------------------------------------------------------ + print*,"WARNING: tspline err in utility pspl, coming out ", + + "of subr. best_slalom - use finite difference method" + write(41,*)"WARNING: tspline err in utility pspl, coming ", + + "out of subr. best_slalom - use finite ", + + "difference method" + err_tspline = 1 + go to 666 + end if + +c Use bounded Newton iterations to estimate the vertical velocity + call bnewton(nh,m,bigT,halfgate,hgts,hs,hgtp,habest, + + qbest,te(1:nh),dhdt(1:nh),FF) +!!!!!!!! if (FF) call w3tage('PREPOBS_PREPACQC') +!!!!!!!! if (FF) call errexit(64) + if (FF) then +c Error generating vertical velocity rate in tension-spline interpolation utility pspl +c (coming out of subroutine bnewton) - use finite difference method +c ------------------------------------------------------------------------------------ + print*,"WARNING: tspline err in utility pspl, coming out ", + + "of subr. bnewton - use finite difference method" + write(41,*)"WARNING: tspline err in utility pspl, coming ", + + "out of subr. bnewton - use finite difference ", + + "method" + err_tspline = 1 + go to 666 + end if + +c convert back data with time decrease for ascending + call convertd_back(nh,halfgate,wdata,tdata,dhdt,hgts,idx, + + descending) + do j = 1, nh + write(41,*) 'hgts,hs,dhdt,wdata=', j,hgts(j),hs(j),dhdt(j), + + wdata(j) + end do + +c Encode dhdt into PREPBUFR-like file as IALR + nh = 0 + do j = 1,nlv2wrt_tot + jj = iord(j) + if (ibfms(drinfo_accum(3,jj)).eq.0) then + nh = nh + 1 + rate_accum(jj) = wdata(nh) + write(41,*) 'j,z,rate=',j,zevn_accum(1,jj,1), + + rate_accum(jj) + end if + end do + + 666 continue + + if(allocated(idx)) deallocate(idx) + if(allocated(pof)) deallocate(pof) + if(allocated(tdata)) deallocate(tdata) + if(allocated(hdata)) deallocate(hdata) + if(allocated(wdata)) deallocate(wdata) + if(allocated(te)) deallocate(te) + if(allocated(hgts)) deallocate(hgts) + if(allocated(hs)) deallocate(hs) + if(allocated(dhdt)) deallocate(dhdt) + if(allocated(hgtp)) deallocate(hgtp) + if(allocated(hp)) deallocate(hp) + if(allocated(qbest)) deallocate(qbest) + if(allocated(habest)) deallocate(habest) + if(allocated(modebest)) deallocate(modebest) + end if ! nlv2wrt_tot.gt.1 .and. tsplines + + if (((nlv2wrt_tot.gt.1) .and. (.not.tsplines)) + + .or. err_tspline>0) then + do j = 1,nlv2wrt_tot + jj = iord(j) + write(41,*) 'j,ord,z,t,pof=', j, jj,zevn_accum(1,jj,1), + + drinfo_accum(3,jj),acft_seq_accum(1,jj),acft_seq_accum(2,jj) + end do + + do j = 1,nlv2wrt_tot + jj = iord(j) + + jkp = 0 + jkm = 0 + jjp1 = 0 + jjm1 = 0 + if (j .eq. nlv2wrt_tot) then + if (ibfms(drinfo_accum(3,jj)).eq.0) then + jjp1 = jj + jkp = j + end if + else + do jk = j+1,nlv2wrt_tot + jjp = iord(jk) + if (jjp > nlvinprof) cycle + if (ibfms(drinfo_accum(3,jjp)).eq.0) then + jjp1 = jjp + jkp = jk + exit + end if + end do + end if + + if (j .eq. 1 ) then + if (ibfms(drinfo_accum(3,jj)).eq.0) then + jjm1 = jj + jkm = j + end if + else + do jk = j-1,1,-1 + jjm = iord(jk) + if (jjm > nlvinprof) cycle ! use real obs only + if (ibfms(drinfo_accum(3,jjm)).eq.0) then + jjm1 = jjm + jkm = jk + exit + end if + end do + end if + + if ((jjp1 .ne. 0) .and. (jjm1 .ne. 0)) then + dt = (drinfo_accum(3,jjp1) - drinfo_accum(3,jjm1))*3600. ! seconds + + c1_jk = 0 + c2_jk = 0 + do while ((abs(dt)<60.) .and. ((jkp+c1_jk<=nlv2wrt_tot) + + .or. (jkm-c2_jk>=1))) + jjp2 = 0 + jjm2 = 0 + c1_jk = c1_jk+1 + c2_jk = c2_jk+1 + dt_new = dt + + do while (jkp+c1_jk<=nlv2wrt_tot + + .and. iord(jkp+c1_jk)>nlvinprof) + c1_jk = c1_jk+1 ! skip mandatory level + end do + if (jkp+c1_jk<=nlv2wrt_tot + + .and. iord(jkp+c1_jk)<=nlvinprof) then + jjp = iord(jkp+c1_jk) + if (ibfms(drinfo_accum(3,jjp)).eq.0) then + jjp2 = jjp + dt_new = (drinfo_accum(3,jjp2) + + - drinfo_accum(3,jjm1))*3600. + end if + end if + if (abs(dt_new) >= 60.) then + if (jjp2 .ne. 0) jjp1 = jjp2 + exit + end if + + do while (jkm-c2_jk>=1 .and. iord(jkm-c2_jk)>nlvinprof) + c2_jk = c2_jk+1 ! skip mandatory level + end do + if (jkm-c2_jk>=1 .and. iord(jkm-c2_jk)<=nlvinprof) then + jjm = iord(jkm-c2_jk) + if (ibfms(drinfo_accum(3,jjm)).eq.0) then + jjm2 = jjm + dt_new = (drinfo_accum(3,jjp1) + + - drinfo_accum(3,jjm2))*3600. + end if + end if + if (abs(dt_new) >= 60.) then + if (jjm2 .ne. 0) jjm1 = jjm2 + exit + end if + + if ((jjp2 .ne. 0) .and. (jjm2 .ne. 0)) then + dt_new = (drinfo_accum(3,jjp2) + + - drinfo_accum(3,jjm2))*3600. + if (abs(dt_new) >= 60.) then + if (jjp2 .ne. 0) jjp1 = jjp2 + if (jjm2 .ne. 0) jjm1 = jjm2 + exit + end if + end if + end do + dt = (drinfo_accum(3,jjp1) - drinfo_accum(3,jjm1))*3600. + +c write(41,*)' fj,ord1,z1,t1 = ',j,jjp1,zevn_accum(1,jjp1,1), +c + drinfo_accum(3,jjp1) +c write(41,*)' fj,ord2,z2,t2 = ',j,jjm1,zevn_accum(1,jjm1,1), +c + drinfo_accum(3,jjm1) + zul = zevn_accum(1,jjp1,1) ! meters + zll = zevn_accum(1,jjm1,1) ! meters + +c Need gross checks on ascent/descent rate here? + if(abs(dt) .gt. 0.) ! added to avoid divide by zero + + rate_accum(jj) = (zul - zll)/dt ! m/s + ! will be encoded into + ! PREPBUFR-like file as IALR + + write(41,*) ' fj,dt,rate_accum=',j,dt,rate_accum(jj) + write(41,*) '' + end if + end do + end if ! ((nlv2wrt_tot.gt.1) .and. (.not.tsplines)) .or. err_tspline>0 + +c Interpolate position and time to mandatory level (will be stored in XDR YDR HRDR) (need to +c have mandatory levels inserted into the profile before this step) +c ------------------------------------------------------------------------------------------ + if (l_mandlvl .and. nlvinprof.gt.1) then + +ccccccc print *, ' nlv2wrt_tot = ',nlv2wrt_tot + do j = 1,nlv2wrt_tot + jj = iord(j) +ccccccc print *, ' j,jj = ',j,jj + + nmNbtw = 0 ! reset 'number of mandatory levels in-between' counter +c------------------------------------------------------------------------------------------ +c------------------------------------------------------------------------------------------ +! (DAK: verified that logic below gives the correct answer - good news!) + if(ibfms(drinfo_accum(1,jj)).ne.0 .and. + + ibfms(drinfo_accum(2,jj)).ne.0 .and. + + ibfms(drinfo_accum(3,jj)).ne.0) then ! all obs in drift sequence missing likely + ! means this is a mandatory level for + ! which these obs must be filled via + ! interpolation + nmNbtw = 1 ! set 'number of mandatory levels in-between' counter to 1 +ccccc print *, 'here is a first mand. level - p = ',lvlsinprof(jj) + +c see if there is more than one mandatory level in a row for which we need to calculate XDR, +c YDR and HRDR values +c ------------------------------------------------------------------------------------------ + do k = j+1, nlv2wrt_tot +ccccccc print *, ' k = ',k + kk = iord(k) + if(ibfms(drinfo_accum(1,kk)).ne.0 .and. + + ibfms(drinfo_accum(2,kk)).ne.0 .and. + + ibfms(drinfo_accum(3,kk)).ne.0) then ! another mandatory levelw/ missing + ! XDR, YDR and HRDR + nmNbtw = nmNbtw + 1 ! increment 'number of mandatory levels in-between' + ! counter by 1 + +ccccc print *, 'here is ANOTHER adjacent MANDATORY LEVEL - ', +ccccc+ 'p =',lvlsinprof(kk) +ccccc print *, 'nmNbtw = ',nmNbtw + else + exit ! exit k loop + endif + enddo + +c At this point, nmNbtw is the number of mandatory levels in a row w/ missing XDR, YDR and +c HRDR - ow we need to determine the "bread" levels; in other words, levels with real, non- +c interpolated data, that sandwich the mandatory levels - below, jj points to the mandatory +c level, jjm1 points to the "bread" level with actual data at the lower pressure/higher +c altitude and jjpnmNbtw points to the "bread" level with actual data at a higher pressure/ +c lower altitude +c ------------------------------------------------------------------------------------------ + if(j.le.1) then +c DAK: Make sure j is > 1 here !! (not sure it can ever happen) + print * + print *, '### PROBLEM - j .le. 1 (= ',j,') in subr. ', + + 'sub2mem_mer, iord array underflow' + print *, ' this should never happen!!' + print * + call w3tage('PREPOBS_PREPACQC') + call errexit(61) + endif + jjm1 = iord(j-1) + jjpnmNbtw = iord(j+nmNbtw) + pll = lvlsinprof(jjm1) + pul = lvlsinprof(jjpnmNbtw) + +c Interpolate lat/lon/time to mandatory levels +c -------------------------------------------- + +c Determine dtime/dlnp, total horizontal distance covered between the two points, and average +c groundspeed of aircraft between the points +c ------------------------------------------------------------------------------------------- + dtime_dlnp = (drinfo_accum(3,jjpnmNbtw) - + + drinfo_accum(3,jjm1)) / alog(pul/pll) + +c Use Haversine formula to determine distance, given two lat/lons (the same formula is used +c in the acftobs_qc/gcirc_qc routine and more information is available at +c http://www.movable-type.co.uk/scripts/GIS-FAQ-5.1.html) +c ----------------------------------------------------------------------------------------- + lat_pul = drinfo_accum(2,jjpnmNbtw) + lon_pul = drinfo_accum(1,jjpnmNbtw) + lat_pll = drinfo_accum(2,jjm1) + lon_pll = drinfo_accum(1,jjm1) + + if(int(lon_pul*100.).eq.int(lon_pll*100.)) then + dist_pul_pll = radius_e * abs(lat_pul-lat_pll) * deg2rad + elseif(int(lat_pul*100.).eq.int(lat_pll*100.)) then + dist_pul_pll = 2.0*radius_e* + + asin(min(1.0,abs(cos(lat_pul*deg2rad)* + + sin((lon_pul-lon_pll)*0.5*deg2rad)))) + else + dist_pul_pll = 2.0*radius_e* + + asin(min(1.0,sqrt( + + (sin((lat_pul-lat_pll)*0.5*deg2rad))**2 + + + cos(lat_pul*deg2rad)* + + cos(lat_pll*deg2rad)* + + (sin((lon_pul-lon_pll)*0.5*deg2rad))**2 + + ) + + ) + + ) + endif + +c Check if times are equal, then interpolate lat/lon - assume aircraft is traveling at a +c constant speed between the locations where pul and pll are observed +c -------------------------------------------------------------------------------------- + if(int(drinfo_accum(3,jjpnmNbtw)*100000.).ne. + + int(drinfo_accum(3,jjm1)*100000.) .and. + + dist_pul_pll.ne.0.) then + + spd_pul_pll = dist_pul_pll / + + abs((drinfo_accum(3,jjpnmNbtw) - + + drinfo_accum(3,jjm1))*3600.) + + do k = 0,nmNbtw-1 +ccccccc print *, ' k 2 = ',k + jjpk = iord(j+k) + pml = lvlsinprof(jjpk) + +c time + drinfo_accum(3,jjpk) = drinfo_accum(3,jjm1) + + + dtime_dlnp*alog(pml/pll) + + dist2pml = spd_pul_pll * + + abs(drinfo_accum(3,jjpk)-drinfo_accum(3,jjm1))* + + 3600. ! sec/hour... drinfo_accum(3,x) values are in hours + +c latitude + drinfo_accum(2,jjpk) = drinfo_accum(2,jjm1) + + + dist2pml/dist_pul_pll* + + (drinfo_accum(2,jjpnmNbtw)-drinfo_accum(2,jjm1)) + +c longitude + drinfo_accum(1,jjpk) = drinfo_accum(1,jjm1) + + + dist2pml/dist_pul_pll* + + (drinfo_accum(1,jjpnmNbtw)-drinfo_accum(1,jjm1)) + + enddo + else ! times are equal; assume groundspeed varies linearly -- or, dist_pul_pll=0 + ! and lat/lons of pul and pll are either equal or very very close + +c Determine delx, y +c ----------------- + delx = (drinfo_accum(1,jjpnmNbtw) - + + drinfo_accum(1,jjm1))/(nmNbtw+1) + dely = (drinfo_accum(2,jjpnmNbtw) - + + drinfo_accum(2,jjm1))/(nmNbtw+1) + +c Store interpolated lat/lon/time values for the levels that need it +c ------------------------------------------------------------------ + do k = 0,nmNbtw-1 +ccccccc print *, ' k 3 = ',k + jjpk = iord(j+k) + pml = lvlsinprof(jjpk) + drinfo_accum(1,jjpk) = + + drinfo_accum(1,jjm1) + (k+1)*delx + drinfo_accum(2,jjpk) = + + drinfo_accum(2,jjm1) + (k+1)*dely + drinfo_accum(3,jjpk) = drinfo_accum(3,jjm1) + + + dtime_dlnp*alog(pml/pll) ! if times are equal, + ! dtime_dlnp =0, and then + ! time at pml = time at pll + +cc drinfo_accum(3,jj) = +cc + drinfo_accum(3,jjpnmNbtw) ! give pml the same time as pul and pll + + enddo + endif ! times of "bread" levels equal? + endif ! need to interpolate for mandatory level ? +! (DAK: verified that above below gives the correct answer - good news!) +c------------------------------------------------------------------------------------------ +c------------------------------------------------------------------------------------------ + enddo ! j = 1,nlv2wrt_tot + endif ! l_mandlvl .and. nlvinprof.gt.1 + +c Set TYP to reflect whether or not report is part of a profile, ascending or descending +c -------------------------------------------------------------------------------------- + jjmaxp = iord(nlv2wrt_tot) + jjminp = iord(1) + if(nlv2wrt_tot.eq.1) then + hdr2wrt(6) = 300 + mod(int(hdr2wrt(6)),100) ! TYP = 3xx for single level merged + ! (mass + wind) reports + elseif(nlv2wrt_tot.gt.1 .and. + + (c_qc_accum(jjmaxp)(11:11).eq.'a' .or. + + c_qc_accum(jjmaxp)(11:11).eq.'A')) then ! ascending profile (merged) + hdr2wrt(6) = 400 + mod(int(hdr2wrt(6)),100) ! TYP = 4xx for ascending profile + ! merged (mass + wind) reports + +c Make sure the header information for the ascent is the coordinates, etc, present at the +c "launch" level (highest pressure/lowest altitude) +c --------------------------------------------------------------------------------------- + hdr2wrt(2) = drinfo_accum(1,jjmaxp) + hdr2wrt(3) = drinfo_accum(2,jjmaxp) + hdr2wrt(4) = drinfo_accum(3,jjmaxp) + hdr2wrt(5) = elv_accum(1,jjmaxp) + hdr2wrt(12) = rpt_accum(1,jjmaxp) + hdr2wrt(13) = tcor_accum(1,jjmaxp) + + elseif(nlv2wrt_tot.gt.1 .and. + + (c_qc_accum(jjmaxp)(11:11).eq.'d' .or. + + c_qc_accum(jjmaxp)(11:11).eq.'D')) then ! descending profile (merged) + hdr2wrt(6) = 500 + mod(int(hdr2wrt(6)),100) ! TYP = 5xx for descending profile + ! merged (mass + wind) reports + +c Make sure the header information for the descent is the coordinates, etc., present at the +c "launch" level (lowest pressure/highest altitude) +c ----------------------------------------------------------------------------------------- + hdr2wrt(2) = drinfo_accum(1,jjminp) + hdr2wrt(3) = drinfo_accum(2,jjminp) + hdr2wrt(4) = drinfo_accum(3,jjminp) + hdr2wrt(5) = elv_accum(1,jjminp) + hdr2wrt(12) = rpt_accum(1,jjminp) + hdr2wrt(13) = tcor_accum(1,jjminp) + + endif +ccc print *, '.. the report type here is ',hdr2wrt(6) + +c Set SQN/PROCN to missing for profiles +c ------------------------------------- + hdr2wrt(10) = bmiss + hdr2wrt(11) = bmiss + +c Write header info/metadata +c -------------------------- + call ufbint(proflun,hdr2wrt,15,1,nlvwrt, + + 'SID XOB YOB DHR ELV TYP T29 TSB ITP SQN PROCN RPT TCOR '// + + 'RSRD EXPRSRD') + + acid_arr1 = acid1 + if(ibfms(acid1).eq.0) + + call ufbint(proflun,acid_arr1,1,1,nlvwrt,'ACID') ! store 'ACID' if present + ! {currently only in MDCRS or AMDAR + ! (LATAM only) reports} + + if(mesgtype.ne.'AIRCAR'.and. mesgtype.ne.'AIRCFT') then + print *, 'Non-compatible message type! (',mesgtype,')' + print *, 'Skipping this report; it will not be written to ', + + 'output.' + go to 9999 + endif + +ccc print *, 'FOR THIS REPORT: mxe4prof = ',mxe4prof + +c ------------------------------------- +c Process each event set, one at a time +c ------------------------------------- + do i = 1,mxe4prof ! maximum number of events in a single-level merged report (i.e., the + ! maximum amongst the number of pressure, moisture,temperature, + ! altitude, u/v wind and direction/speed wind events) +ccc print *, '.. bring in next event for writing out' +ccc print *, 'Next event is number ',i + +c Clear out arrays used with ufbint to store data in memory +c --------------------------------------------------------- + nlv2wrt = 0 + + pevns4 = bmiss + qevns4 = bmiss + tevns4 = bmiss + zevns4 = bmiss + wuvevns5 = bmiss + wdsevns5 = bmiss + + pbgarr3 = bmiss + qbgarr3 = bmiss + tbgarr3 = bmiss + zbgarr3 = bmiss + wuvbgarr5 = bmiss + + ppparr3 = bmiss + qpparr3 = bmiss + tpparr3 = bmiss + zpparr3 = bmiss + wuvpparr6 = bmiss + + drarr3 = bmiss + + acft_seq_arr2 = bmiss + + mstq_arr1 = bmiss + rct_arr1 = bmiss + cat_arr1 = bmiss + ialr_arr1 = bmiss + turb_arr4 = bmiss + +c Collapse stacks of events; keep levels where there is pressure data - do this in +c anticipation of "striping"/layering events onto data upon output - organize data across +c all levels for each "event set"/"layer" +c ---------------------------------------------------------------------------------------- + + do j = nlv2wrt_tot,1,-1 + + jj = iord(j) +ccc print *, 'j: ',j + + nlv2wrt = nlv2wrt + 1 ! nlv2wrt = number of pressure levels to be written out +ccc print *, 'nlv2wrt = ',nlv2wrt + + if(ibfms(pevn_accum(1,jj,i)).eq.0) then ! if POB is missing, don't process this + ! event + pevns4(1:4,nlv2wrt) = pevn_accum(1:4,jj,i) +ccc print *, 'POB PQM PPC PRC for this level and event:' +ccc print *, ' pevns4(1,',nlv2wrt,') = ',pevns4(1,nlv2wrt) +ccc print *, ' pevns4(2,',nlv2wrt,') = ',pevns4(2,nlv2wrt) +ccc print *, ' pevns4(3,',nlv2wrt,') = ',pevns4(3,nlv2wrt) +ccc print *, ' pevns4(4,',nlv2wrt,') = ',pevns4(4,nlv2wrt) +ccc else +ccc print *, 'POB missing, pevns4 is missing for this level ', +ccc + 'and event' + endif + + if(ibfms(qevn_accum(1,jj,i)).eq.0) then ! if QOB is missing, don't process this + ! event + qevns4(1:4,nlv2wrt) = qevn_accum(1:4,jj,i) +ccc print *, 'QOB QQM QPC QRC for this level and event:' +ccc print *, ' qevns4(1,',nlv2wrt,') = ',qevns4(1,nlv2wrt) +ccc print *, ' qevns4(2,',nlv2wrt,') = ',qevns4(2,nlv2wrt) +ccc print *, ' qevns4(3,',nlv2wrt,') = ',qevns4(3,nlv2wrt) +ccc print *, ' qevns4(4,',nlv2wrt,') = ',qevns4(4,nlv2wrt) +ccc else +ccc print *, 'QOB missing, qevns4 is missing for this ', +ccc + 'level and event' + endif + + if(ibfms(tevn_accum(1,jj,i)).eq.0) then ! if TOB is missing, don't process this + ! event + tevns4(1:4,nlv2wrt) = tevn_accum(1:4,jj,i) +ccc print *, 'TOB TQM TPC TRC for this level and event:' +ccc print *, ' tevns4(1,',nlv2wrt,') = ',tevns4(1,nlv2wrt) +ccc print *, ' tevns4(2,',nlv2wrt,') = ',tevns4(2,nlv2wrt) +ccc print *, ' tevns4(3,',nlv2wrt,') = ',tevns4(3,nlv2wrt) +ccc print *, ' tevns4(4,',nlv2wrt,') = ',tevns4(4,nlv2wrt) +ccc else +ccc print *, 'TOB missing, tevns4 is missing for this ', +ccc + 'level and event' + endif + + if(ibfms(zevn_accum(1,jj,i)).eq.0) then ! if ZOB is missing, don't process this + ! event + zevns4(1:4,nlv2wrt) = zevn_accum(1:4,jj,i) +ccc print *, 'ZOB ZQM ZPC ZRC for this level and event:' +ccc print *, ' zevns4(1,',nlv2wrt,') = ',zevns4(1,nlv2wrt) +ccc print *, ' zevns4(2,',nlv2wrt,') = ',zevns4(2,nlv2wrt) +ccc print *, ' zevns4(3,',nlv2wrt,') = ',zevns4(3,nlv2wrt) +ccc print *, ' zevns4(4,',nlv2wrt,') = ',zevns4(4,nlv2wrt) +ccc else +ccc print *, 'ZOB missing, zevns4 is missing for this level ', +ccc + 'and event' + endif + + if(ibfms(wuvevn_accum(1,jj,i)).eq.0 .and. ! if UOB or VOB are missing, don't + + ibfms(wuvevn_accum(2,jj,i)).eq.0) then ! process this event + wuvevns5(1:5,nlv2wrt) = wuvevn_accum(1:5,jj,i) +ccc print *, 'UOB VOB WQM WPC WRC for this level and event:' +ccc print *, ' wuvevns5(1,',nlv2wrt,') = ',wuvevns5(1,nlv2wrt) +ccc print *, ' wuvevns5(2,',nlv2wrt,') = ',wuvevns5(2,nlv2wrt) +ccc print *, ' wuvevns5(3,',nlv2wrt,') = ',wuvevns5(3,nlv2wrt) +ccc print *, ' wuvevns5(4,',nlv2wrt,') = ',wuvevns5(4,nlv2wrt) +ccc print *, ' wuvevns5(5,',nlv2wrt,') = ',wuvevns5(5,nlv2wrt) +ccc else +ccc print *, 'either UOB or VOB missing, wuvevns5 is missing ', +ccc + 'for this level and event' + endif + + wdsevns5(1:5,nlv2wrt) = wdsevn_accum(1:5,jj,i) +ccc print *, 'DDO FFO DFQ DFP DFR for this level and event:' +ccc print *, ' wdsevns5(1,',nlv2wrt,') = ',wdsevns5(1,nlv2wrt) +ccc print *, ' wdsevns5(2,',nlv2wrt,') = ',wdsevns5(2,nlv2wrt) +ccc print *, ' wdsevns5(3,',nlv2wrt,') = ',wdsevns5(3,nlv2wrt) +ccc print *, ' wdsevns5(4,',nlv2wrt,') = ',wdsevns5(4,nlv2wrt) +ccc print *, ' wdsevns5(5,',nlv2wrt,') = ',wdsevns5(5,nlv2wrt) + +c Collapse arrays of background, post-processing, drift, acft_seq info - need to accumulate +c background, etc., across all levels - only write out these values upon writing first +c "event"/"layer". These values occur only once per layer, there is no nested replication +c ----------------------------------------------------------------------------------------- + + if(i.eq.1) then + + pbgarr3(1:3,nlv2wrt) = pbg_accum(1:3,jj) +ccc print *, 'POE PFC PFCMOD for this level - NO event:' +ccc print *, ' pbgarr3(1,',nlv2wrt,') = ',pbgarr3(1,nlv2wrt) +ccc print *, ' pbgarr3(2,',nlv2wrt,') = ',pbgarr3(2,nlv2wrt) +ccc print *, ' pbgarr3(3,',nlv2wrt,') = ',pbgarr3(3,nlv2wrt) + qbgarr3(1:3,nlv2wrt) = qbg_accum(1:3,jj) +ccc print *, 'QOE QFC QFCMOD for this level - NO event:' +ccc print *, ' qbgarr3(1,',nlv2wrt,') = ',qbgarr3(1,nlv2wrt) +ccc print *, ' qbgarr3(2,',nlv2wrt,') = ',qbgarr3(2,nlv2wrt) +ccc print *, ' qbgarr3(3,',nlv2wrt,') = ',qbgarr3(3,nlv2wrt) + tbgarr3(1:3,nlv2wrt) = tbg_accum(1:3,jj) +ccc print *, 'TOE TFC TFCMOD for this level - NO event:' +ccc print *, ' tbgarr3(1,',nlv2wrt,') = ',tbgarr3(1,nlv2wrt) +ccc print *, ' tbgarr3(2,',nlv2wrt,') = ',tbgarr3(2,nlv2wrt) +ccc print *, ' tbgarr3(3,',nlv2wrt,') = ',tbgarr3(3,nlv2wrt) + zbgarr3(1:3,nlv2wrt) = zbg_accum(1:3,jj) +ccc print *, 'ZOE ZFC ZFCMOD for this level - NO event:' +ccc print *, ' zbgarr3(1,',nlv2wrt,') = ',zbgarr3(1,nlv2wrt) +ccc print *, ' zbgarr3(2,',nlv2wrt,') = ',zbgarr3(2,nlv2wrt) +ccc print *, ' zbgarr3(3,',nlv2wrt,') = ',zbgarr3(3,nlv2wrt) + wuvbgarr5(1:5,nlv2wrt) = wuvbg_accum(1:5,jj) +ccc print *, 'WOE UFC VFC UFCMOD VFCMOD for this level - NO event:' +ccc print *, ' wuvbgarr5(1,',nlv2wrt,') = ',wuvbgarr5(1,nlv2wrt) +ccc print *, ' wuvbgarr5(2,',nlv2wrt,') = ',wuvbgarr5(2,nlv2wrt) +ccc print *, ' wuvbgarr5(3,',nlv2wrt,') = ',wuvbgarr5(3,nlv2wrt) +ccc print *, ' wuvbgarr5(4,',nlv2wrt,') = ',wuvbgarr5(4,nlv2wrt) +ccc print *, ' wuvbgarr5(5,',nlv2wrt,') = ',wuvbgarr5(5,nlv2wrt) + + ppparr3(1:3,nlv2wrt) = ppp_accum(1:3,jj) +ccc print *, 'PAN PCL PCS for this level - NO event:' +ccc print *, ' ppparr3(1,',nlv2wrt,') = ',ppparr3(1,nlv2wrt) +ccc print *, ' ppparr3(2,',nlv2wrt,') = ',ppparr3(2,nlv2wrt) +ccc print *, ' ppparr3(3,',nlv2wrt,') = ',ppparr3(3,nlv2wrt) + qpparr3(1:3,nlv2wrt) = qpp_accum(1:3,jj) +ccc print *, 'QAN QCL QCS for this level - NO event:' +ccc print *, ' qpparr3(1,',nlv2wrt,') = ',qpparr3(1,nlv2wrt) +ccc print *, ' qpparr3(2,',nlv2wrt,') = ',qpparr3(2,nlv2wrt) +ccc print *, ' qpparr3(3,',nlv2wrt,') = ',qpparr3(3,nlv2wrt) + tpparr3(1:3,nlv2wrt) = tpp_accum(1:3,jj) +ccc print *, 'TAN TCL TCS for this level - NO event:' +ccc print *, ' tpparr3(1,',nlv2wrt,') = ',tpparr3(1,nlv2wrt) +ccc print *, ' tpparr3(2,',nlv2wrt,') = ',tpparr3(2,nlv2wrt) +ccc print *, ' tpparr3(3,',nlv2wrt,') = ',tpparr3(3,nlv2wrt) + zpparr3(1:3,nlv2wrt) = zpp_accum(1:3,jj) +ccc print *, 'ZAN ZCL ZCS for this level - NO event:' +ccc print *, ' zpparr3(1,',nlv2wrt,') = ',zpparr3(1,nlv2wrt) +ccc print *, ' zpparr3(2,',nlv2wrt,') = ',zpparr3(2,nlv2wrt) +ccc print *, ' zpparr3(3,',nlv2wrt,') = ',zpparr3(3,nlv2wrt) + wuvpparr6(1:6,nlv2wrt) = wuvpp_accum(1:6,jj) +ccc print *, 'UAN VAN UCL UCS VCL VCS for this level - NO event:' +ccc print *, ' wuvpparr6(1,',nlv2wrt,') = ',wuvpparr6(1,nlv2wrt) +ccc print *, ' wuvpparr6(2,',nlv2wrt,') = ',wuvpparr6(2,nlv2wrt) +ccc print *, ' wuvpparr6(3,',nlv2wrt,') = ',wuvpparr6(3,nlv2wrt) +ccc print *, ' wuvpparr6(4,',nlv2wrt,') = ',wuvpparr6(4,nlv2wrt) +ccc print *, ' wuvpparr6(5,',nlv2wrt,') = ',wuvpparr6(5,nlv2wrt) +ccc print *, ' wuvpparr6(6,',nlv2wrt,') = ',wuvpparr6(6,nlv2wrt) + + drarr3(1:3,nlv2wrt) = drinfo_accum(1:3,jj) +ccc print *, 'XDR YDR HRDR for this level - NO event:' +ccc print *, ' drarr3(1,',nlv2wrt,') = ',drarr3(1,nlv2wrt) +ccc print *, ' drarr3(2,',nlv2wrt,') = ',drarr3(2,nlv2wrt) +ccc print *, ' drarr3(3,',nlv2wrt,') = ',drarr3(3,nlv2wrt) + + acft_seq_arr2(1:2,nlv2wrt) = acft_seq_accum(1:2,jj) +ccc print *, 'PCAT POAF for this level - NO event:' +ccc print *, ' acft_seq_arr2(1,',nlv2wrt,') = ', +ccc + acft_seq_arr2(1,nlv2wrt) +ccc print *, ' acft_seq_arr2(2,',nlv2wrt,') = ', +ccc + acft_seq_arr2(2,nlv2wrt) + + mstq_arr1(1,nlv2wrt) = mstq_accum(1,jj) +ccc print *, 'MSTQ for this level - NO event:' +ccc print *, ' mstq_arr1(1,',nlv2wrt,') = ',mstq_arr1(1,nlv2wrt) + + rct_arr1(1,nlv2wrt) = rct_accum(1,jj) +ccc print *, 'RCT for this level - NO event:' +ccc print *, ' rct_arr1(1,',nlv2wrt,') = ',rct_arr1(1,nlv2wrt + + cat_arr1(1,nlv2wrt) = cat_accum(1,jj) +ccc print *, 'CAT for this level - NO event:' +ccc print *, ' cat_arr1(1,',nlv2wrt,') = ',cat_arr1(1,nlv2wrt) + + ialr_arr1(1,nlv2wrt) = rate_accum(jj) +ccc print *, 'IALR for this level - NO event:' +ccc print *, ' ialr_arr1(1,',nlv2wrt,') = ',ialr_arr1(1,nlv2wrt) + endif + + if(.not.l_operational) then ! this is currently invoked because l_operational + ! is hardwired to F for l_ncep=T + if(i.eq.mxe4prof) then + hdr2wrt1 = hdr2wrt(1) + if(ibfms(drinfo_accum(3,jj)).ne.0) then + idrinfo_accum3 = 9999999 + else + idrinfo_accum3 = nint(drinfo_accum(3,jj) * 3600.) + endif + if(ibfms(hdr2wrt(9)).ne.0) then + ihdr2wrt9 = 99999 + else + ihdr2wrt9 = nint(hdr2wrt(9)) + endif + if(ibfms(hdr2wrt(6)).ne.0) then + ihdr2wrt6 = 9999 + else + ihdr2wrt6 = nint(hdr2wrt(6)) + endif + if(ibfms(acft_seq_accum(2,jj)).ne.0) then + iacft_seq_accum2 = 99 + else + iacft_seq_accum2 = nint(acft_seq_accum(2,jj)) + endif + if(ibfms(mstq_accum(1,jj)).ne.0) then + imstq_accum1 = 9999 + else + imstq_accum1 = nint(mstq_accum(1,jj)) + endif + if(ibfms(cat_accum(1,jj)).ne.0) then + icat_accum1 = 9999 + else + icat_accum1 = nint(cat_accum(1,jj)) + endif + do iii = mxe4prof,1,-1 + if(ibfms(tevn_accum(1,jj,iii)).ne.0) then + nevents_t = iii + else + nevents_t = iii + exit + endif + enddo + if(ibfms(zevn_accum(1,jj,1)).ne.0) then + izevn_accum1 = 999999 + else + izevn_accum1 = nint(zevn_accum(1,jj,1)) + endif + if(ibfms(wdsevn_accum(1,jj,1)).ne.0) then + iwdsevn_accum1 = 99999 + else + iwdsevn_accum1 = nint(wdsevn_accum(1,jj,1)) + endif + do iii = mxe4prof,1,-1 + if(ibfms(wuvevn_accum(1,jj,iii)).ne.0 .or. + + ibfms(wuvevn_accum(2,jj,iii)).ne.0) then + if(iii.eq.1) wspd = bmiss + nevents_w = iii + else + wspd = sqrt(wuvevn_accum(1,jj,iii)**2 + + + wuvevn_accum(2,jj,iii)**2) + nevents_w = iii + exit + endif + enddo + do iii = mxe4prof,1,-1 + if(ibfms(qevn_accum(1,jj,iii)).ne.0) then + if(iii.eq.1) q_sphum = bmiss + nevents_q = iii + else + q_sphum = qevn_accum(1,jj,iii) * 0.001 + nevents_q = iii + exit + endif + enddo + if(ibfms(pevn_accum(2,jj,1)).ne.0) then + ipevn_accum2 = 999 + else + ipevn_accum2 = nint(pevn_accum(2,jj,1)) + endif + if(ibfms(zevn_accum(2,jj,1)).ne.0) then + izevn_accum2 = 999 + else + izevn_accum2 = nint(zevn_accum(2,jj,1)) + endif + if(ibfms(tevn_accum(2,jj,nevents_t)).ne.0) then + itevn_accum2 = 999 + else + itevn_accum2 = nint(tevn_accum(2,jj,nevents_t)) + endif + if(ibfms(qevn_accum(2,jj,nevents_q)).ne.0) then + iqevn_accum2 = 999 + else + iqevn_accum2 = nint(qevn_accum(2,jj,nevents_q)) + endif + if(ibfms(wuvevn_accum(3,jj,nevents_w)).ne.0) then + iwuvevn_accum3 = 999 + else + iwuvevn_accum3 = nint(wuvevn_accum(3,jj,nevents_w)) + endif + if(ibfms(pevn_accum(4,jj,1)).ne.0 .or. + + nint(pevn_accum(3,jj,1)).ne.nrlacqc_pc) then + ipevn_accum4 = 9999 + else + ipevn_accum4 = nint(pevn_accum(4,jj,1)) + endif + if(ibfms(zevn_accum(4,jj,1)).ne.0 .or. + + nint(zevn_accum(3,jj,1)).ne.nrlacqc_pc) then + izevn_accum4 = 9999 + else + izevn_accum4 = nint(zevn_accum(4,jj,1)) + endif + if(ibfms(tevn_accum(4,jj,nevents_t)).ne.0 .or. + + nint(tevn_accum(3,jj,nevents_t)).ne.nrlacqc_pc) then + itevn_accum4 = 9999 + else + itevn_accum4 = nint(tevn_accum(4,jj,nevents_t)) + endif + if(ibfms(qevn_accum(4,jj,nevents_q)).ne.0 .or. + + nint(qevn_accum(3,jj,nevents_q)).ne.nrlacqc_pc) then + iqevn_accum4 = 9999 + else + iqevn_accum4 = nint(qevn_accum(4,jj,nevents_q)) + endif + if(ibfms(wuvevn_accum(5,jj,nevents_w)).ne.0 .or. + + nint(wuvevn_accum(4,jj,nevents_w)).ne.nrlacqc_pc) then + iwuvevn_accum5 = 9999 + else + iwuvevn_accum5 = nint(wuvevn_accum(5,jj,nevents_w)) + endif + +ccccc write(52,fmt=7999) i +c7999 format('EVENT # ',i5) + write(52,fmt=8001) j,c_acftid1,c_acftreg1,ihdr2wrt9, + + iacft_seq_accum2,drinfo_accum(2,jj), + + drinfo_accum(1,jj),idrinfo_accum3,izevn_accum1, + + pevn_accum(1,jj,1),tevn_accum(1,jj,nevents_t)+273.16, + + nevents_t,q_sphum,nevents_q,wuvevn_accum(1,jj,nevents_w), + + wuvevn_accum(2,jj,nevents_w),nevents_w, + + acft_seq_accum(1,jj),c_qc_accum(jj),rct_accum(1,jj), + + imstq_accum1,icat_accum1,wspd,iwdsevn_accum1,ihdr2wrt6, + + ipevn_accum2,izevn_accum2,itevn_accum2,iqevn_accum2, + + iwuvevn_accum3,ipevn_accum4,izevn_accum4,itevn_accum4, + + iqevn_accum4,iwuvevn_accum5 + + 8001 format(i5,1x,a9,1x,a8,1x,i3,2x,i1,1x,2f10.5, 1x,i6,1x,i5,1x,f6.1, + + 1x,f6.2,i3,1x,f7.2,1x,i3,1x,f6.1,1x,f6.1,1x,i3,1x,f6.2,1x, + + '!',a11,'!',f5.2,1x,i3,2x,i2,1x,f6.1,1x,i4,2x,i3,9x,'!', + + 5(1x,i2.2),'!',i3.3,4(1x,i3.3)) + + endif ! i.eq.mxe4prof + endif ! .not.l_operational + enddo ! do j = nlv2wrt_tot,1,-1 +ccc print *, '.. will write out ',nlv2wrt,' p-levels for this ', +ccc + 'report' + +c Store pressure events across levels, z events, t, q, w, df events +c ----------------------------------------------------------------- + if(nlv2wrt.gt.0 .and. nlv2wrt.eq.nlv2wrt_tot) then ! should be equal; vertical coord. + ! is pressure + call ufbint(proflun,pevns4,4,nlv2wrt,nlvwrt,'POB PQM PPC PRC') +ccc print *, 'ufbint has stored POB PQM PPC PRC on all levels ', +ccc + 'for this event:' + + call ufbint(proflun,qevns4,4,nlv2wrt,nlvwrt,'QOB QQM QPC QRC') +ccc print *, 'ufbint has stored QOB QQM QPC QRC on all levels ', +ccc + 'for this event:' + + call ufbint(proflun,tevns4,4,nlv2wrt,nlvwrt,'TOB TQM TPC TRC') +ccc print *, 'ufbint has stored TOB TQM TPC TRC on all levels ', +ccc + 'for this event:' + + call ufbint(proflun,zevns4,4,nlv2wrt,nlvwrt,'ZOB ZQM ZPC ZRC') +ccc print *, 'ufbint has stored ZOB ZQM ZPC ZRC on all levels ', +ccc + 'for this event:' + + call ufbint(proflun,wuvevns5,5,nlv2wrt,nlvwrt, + + 'UOB VOB WQM WPC WRC') +ccc print *, 'ufbint has stored UOB VOB WQM WPC WRC on all ', +ccc + 'levels for this event:' + + call ufbint(proflun,wdsevns5,5,nlv2wrt,nlvwrt, + + 'DDO FFO DFQ DFP DFR') +ccc print *, 'ufbint has stored DDO FFO DFQ DFP DFR on all ', +ccc + 'levels for this event:' + +ccc print *, 'Finished writing p,q,t,u/v,s/d on all ',nlv2wrt, +ccc + ' levels for THIS event' + num_events_prof = num_events_prof + nlv2wrt +ccc print *, 'Finished writing p,q,t,u/v,s/d on all ',nlv2wrt, +ccc + ' levels for THIS event' +ccc print *, 'num_events_prof = ',num_events_prof + + if(i.eq.1) then ! store/write these only on first event application the following + ! values only occur once in the subset; there are no multiple + ! events to write out + +c ------------------------------------------------------------------------------------------- +c Store background and post processing info - each pressure level in the profile gets one set +c of each (not nested replication like with the events) +c ------------------------------------------------------------------------------------------- + +ccc print'(" write background and post-processing info - only ", +ccc + "for first ""event"" since there are no events for ", +ccc + "these")' + +c write background info + call ufbint(proflun,pbgarr3,3,nlv2wrt,nlvwrt, + + 'POE PFC PFCMOD') +ccc print *, 'ufbint has stored POE PFC PFCMOD on all levels -', +ccc + ' "event" ',i,' ONLY' + + call ufbint(proflun,qbgarr3,3,nlv2wrt,nlvwrt, + + 'QOE QFC QFCMOD') +ccc print *, 'ufbint has stored QOE QFC QFCMOD on all levels -', +ccc + ' "event" ',i,' ONLY' + + call ufbint(proflun,tbgarr3,3,nlv2wrt,nlvwrt, + + 'TOE TFC TFCMOD') +ccc print *, 'ufbint has stored TOE TFC TFCMOD on all levels -', +ccc + ' "event" ',i,' ONLY' + + call ufbint(proflun,zbgarr3,3,nlv2wrt,nlvwrt, + + 'ZOE ZFC ZFCMOD') +ccc print *, 'ufbint has stored ZOE ZFC ZFCMOD on all levels -', +ccc + ' "event" ',i,' ONLY' + + call ufbint(proflun,wuvbgarr5,5,nlv2wrt,nlvwrt, + + 'WOE UFC VFC UFCMOD VFCMOD') +ccc print *, 'ufbint has stored WOE UFC VFC UFCMOD VFCMOD on', +ccc + ' all levels - "event" ',i,' ONLY' + +c write post-processing info + call ufbint(proflun,ppparr3,3,nlv2wrt,nlvwrt,'PAN PCL PCS') +ccc print *, 'ufbint has stored PAN PCL PCS on all levels - ', +ccc + '"event" ',i,' ONLY' + + call ufbint(proflun,qpparr3,3,nlv2wrt,nlvwrt,'QAN QCL QCS') +ccc print *, 'ufbint has stored QAN QCL QCS on all levels - ', +ccc + '"event" ',i,' ONLY' + + call ufbint(proflun,tpparr3,3,nlv2wrt,nlvwrt,'TAN TCL TCS') +ccc print *, 'ufbint has stored TAN TCL TCS on all levels - ', +ccc + '"event" ',i,' ONLY' + + call ufbint(proflun,zpparr3,3,nlv2wrt,nlvwrt,'ZAN ZCL ZCS') +ccc print *, 'ufbint has stored ZAN ZCL ZCS on all levels - ', +ccc + '"event" ',i,' ONLY' + + call ufbint(proflun,wuvpparr6,6,nlv2wrt,nlvwrt, + + 'UAN VAN UCL UCS VCL VCS') +ccc print *, 'ufbint has stored UAN VAN UCL UCS VCL VCS on all', +ccc + ' levels - "event" ',i,' ONLY' + +c write out drift info + call ufbint(proflun,drarr3,3,nlv2wrt,nlvwrt,'XDR YDR HRDR') +ccc print *, 'ufbint has stored XDR YDR HRDR on all levels - ', +ccc + '"event" ',i,' ONLY' + +c write out acft_seq info + call ufbint(proflun,acft_seq_arr2,2,nlv2wrt,nlvwrt, + + 'PCAT POAF') +ccc print *, 'ufbint has stored PCAT POAF on all levels - ', +ccc + '"event" ',i,' ONLY' + +c There is no turbulence info carried forth into this subroutine right now, comment out +ccccc call ufbint(proflun,turb_arr4,4,nlv2wrt,nlvwrt, +ccccc+ 'TRBX10 TRBX21 TRBX32 TRBX43') +ccc print *, 'ufbint has stored TRBX10 TRBX21 TRBX32 TRBX43 on', +ccc + ' all levels - "event" ',i,' ONLY' + +c write out moisture QC flag + call ufbint(proflun,mstq_arr1,1,nlv2wrt,nlvwrt,'MSTQ') +ccc print *, 'ufbint has stored MSTQ on all levels - "event"', +ccc + ' ',i,' ONLY' + +c write out level receipt time + call ufbint(proflun,rct_arr1,1,nlv2wrt,nlvwrt,'RCT') +ccc print *, 'ufbint has stored RCT on all levels - "event" ',i, +ccc + ' ONLY' + +c write out level category + call ufbint(proflun,cat_arr1,1,nlv2wrt,nlvwrt,'CAT') +ccc print *, 'ufbint has stored CAT on all levels - "event" ',i, +ccc + ' ONLY' + +c write out the ascent/descent rate + call ufbint(proflun,ialr_arr1,1,nlv2wrt,nlvwrt,'IALR') +ccc print *, 'ufbint has stored IALR on all levels - "event" ', +ccc + i,' ONLY' + + endif ! i.eq.1/1st event? - only write background/pp info once + + else +C....................................................................... +C For some reason the total number of levels written out (nlv2wrt_tot) does not equal the +c number of pressure levels written out (nlv2wrt) for this profile report - problems!!! +c (go on to next profile) +c---------------------------------------------------------------------------------------- + print 54, nlv2wrt_tot,nlv2wrt + 54 format(/' #####> WARNING: THE TOTAL # OF LEVELS WRITTEN OUT ',I6, + + ' .NE. THE # OF PRESSURE LEVELS WRITTEN OUT ',I6,' FOR THIS ', + + 'PROFILE -- GO ON TO NEXT PROFILE'/) + write(cnlv2wrt_tot,'(i3)') nlv2wrt_tot + write(cnlv2wrt,'(i3)') nlv2wrt + call system('[ -n "$jlogfile" ] && $DATA/postmsg '// + + '"$jlogfile" "***WARNING: LEVEL MISMATCH FOR PREPACQC '// + + 'PROFILE: TOTAL WRITTEN '//cnlv2wrt_tot//' .ne. # PRESS '// + + 'LVLS WRITTEN '//cnlv2wrt//' - PROFILE SKIPPED"') + go to 9999 +C....................................................................... + endif + + enddo ! i = 1,mxnmev + + if(.not.l_operational) then + write(52,fmt=8002) + 8002 format(208('X')) + endif + + 9999 continue + +ccc print *, 'out of sub2mem_mer for this merged report' + + return + + end + diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/sub2mem_um.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/sub2mem_um.f new file mode 100644 index 00000000..3fa73075 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/sub2mem_um.f @@ -0,0 +1,649 @@ +c$$$ Subprogram Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Subprogram: sub2mem_um +c Programmer: D. Keyser Org: NP22 Date: 2012-05-08 +c +c Abstract: Adds new NRLACQC events for pressure, altitude, temperature, moisture and wind to +c the top of event stack in memory for a single merged aircraft report. This is +c accomplished via calls to subroutine tranQCflags to translate the QC information (for +c each variable) from NRL standards (c_qc_stg array) to their NCEP counterparts and to +c establish event reason codes for each variable. +c +c Program history log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c +c Usage: call sub2mem_um(c_qc_stg,max_reps,mxnmev,j,nevents, +c pob_ev,pqm_ev,ppc_ev,prc_ev, +c zob_ev,zqm_ev,zpc_ev,zrc_ev, +c tob_ev,tqm_ev,tpc_ev,trc_ev, +c qob_ev,qqm_ev,qpc_ev,qrc_ev, +c uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, +c nrlacqc_pc,l_allev_pf) +c +c Input argument list: +c c_qc_stg - NRLACQC quality information (11 character string) +c max_reps - Maximum number of reports accepted by acftobs_qc +c mxnmev - Maximum number of events allowed, per variable type +c j - Report number index +c nevents - Array tracking number of events for variables for each report +c pob_ev - Pressure event obs +c pqm_ev - Pressure event quality marks +c ppc_ev - Pressure event program codes +c prc_ev - Pressure event reason codes +c zob_ev - Altitude event obs +c zqm_ev - Altitude event quality marks +c zpc_ev - Altitude event program codes +c zrc_ev - Altitude event reason codes +c tob_ev - Temperature event obs +c tqm_ev - Temperature event quality marks +c tpc_ev - Temperature event program codes +c trc_ev - Temperature event reason codes +c qob_ev - Moisture event obs +c qqm_ev - Moisture event quality marks +c qpc_ev - Moisture event program codes +c qrc_ev - Moisture event reason codes +c uob_ev - Wind/u-comp event obs +c vob_ev - Wind/v-comp event obs +c wqm_ev - Wind event quality marks +c wpc_ev - Wind event program codes +c wrc_ev - Wind event reason codes +c nrlacqc_pc - PREPBUFR program code for the NRLACQC step +c l_allev_pf - Logical whether to process latest (likely NRLACQC) event plus all prior +c events (TRUE) or only latest event (FALSE) into profiles PREPBUFR-like +c file +c +c Output argument list: +c nevents - Array tracking number of events for variables for each report +c pob_ev - Pressure event obs +c ppc_ev - Pressure event program codes +c prc_ev - Pressure event reason codes +c zob_ev - Altitude event obs +c zqm_ev - Altitude event quality marks +c zpc_ev - Altitude event program codes +c zrc_ev - Altitude event reason codes +c tob_ev - Temperature event obs +c tqm_ev - Temperature event quality marks +c tpc_ev - Temperature event program codes +c trc_ev - Temperature event reason codes +c qob_ev - Moisture event obs +c qqm_ev - Moisture event quality marks +c qpc_ev - Moisture event program codes +c qrc_ev - Moisture event reason codes +c uob_ev - Wind/u-comp event obs +c vob_ev - Wind/v-comp event obs +c wqm_ev - Wind event quality marks +c wpc_ev - Wind event program codes +c wrc_ev - Wind event reason codes +c +c Output files: +c Unit 06 - Standard output print +c +c Subprograms called: +c Unique: TRANQCFLAGS +c Library: +c BUFRLIB: IBFMS +c +c Exit States: +c Cond = 0 - successful run +c +c Remarks: Called by subroutine output_acqc_prof. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine sub2mem_um(c_qc_stg,max_reps,mxnmev,j,nevents, + + pob_ev,pqm_ev,ppc_ev,prc_ev, + + zob_ev,zqm_ev,zpc_ev,zrc_ev, + + tob_ev,tqm_ev,tpc_ev,trc_ev, + + qob_ev,qqm_ev,qpc_ev,qrc_ev, + + uob_ev,vob_ev,wqm_ev,wpc_ev,wrc_ev, + + nrlacqc_pc,l_allev_pf) + + implicit none + +c ---------------------- +c Declaration statements +c ---------------------- + +c Indices/counters +c ---------------- + integer j ! report number index + + character*11 c_qc_stg ! character QC flags output from NRL QC code + ! 1st char - info about reject (if ob was rejected) + ! 2nd char - reason why time was rejected + ! 3rd char - reason why latitude was rejected + ! 4th char - reason why longitude was rejected + ! 5th char - reason why pressure/atitude was rejected + ! 6th char - readon why temperature was rejected + ! 7th char - reason why wind direction was rejected + ! 8th char - reason why wind speed was rejected + ! 9th char - reason why mixing ratio was rejected + ! 10th char - reason for blacklisting the aircraft + ! 11th char - info about flight phase + +c Variables for updating input reports with QC results/events from NRLACQC +c ------------------------------------------------------------------------ + logical l_badrpt_p ! T = pressure/altitude is bad per NRLACQC info (c_qc_stg) + +, l_badrpt_z ! T = pressure/altitude is bad per NRLACQC info (c_qc_stg) + +, l_badrpt_t ! T = temperature is bad per NRLACQC info (c_qc_stg) + +, l_badrpt_q ! T = moisture is bad per NRLACQC info (c_qc_stg) + +, l_badrpt_w ! T = wind is bad per NRLACQC info (c_qc_stg) + + logical l_duprpt ! T = report is marked as a duplicate per NRLACQC info + ! (c_qc_stg(1:1)=D/d) + + real*8 pob_topstk ! event POB at top of stack before adding any events + ! containing info from NRLACQC + +, zob_topstk ! event ZOB at top of stack before adding any events + ! containing info from NRLACQC + +, tob_topstk ! event TOB at top of stack before adding any events + ! containing info from NRLACQC + +, qob_topstk ! event QOB at top of stack before adding any events + ! containing info from NRLACQC + +, uob_topstk ! event UOB at top of stack before adding any events + ! containing info from NRLACQC + +, vob_topstk ! event VOB at top of stack before adding any events + ! containing info from NRLACQC + + integer ipqm_topstk ! event PQM at top of stack before adding any events + ! containing info from NRLACQC + +, izqm_topstk ! event ZQM at top of stack before adding any events + ! containing info from NRLACQC + +, itqm_topstk ! event TQM at top of stack before adding any events + ! containing info from NRLACQC + +, iqqm_topstk ! event QQM at top of stack before adding any events + ! containing info from NRLACQC + +, iwqm_topstk ! event WQM at top of stack before adding any events + ! containing info from NRLACQC + + integer ipqm_nrlacqc ! value for pressure q.m. (PQM) returned from tranQCflags + +, iprc_nrlacqc ! value for pressure r.c. (PRC) returned from tranQCflags + +, izqm_nrlacqc ! value for altitude q.m. (ZQM) returned from tranQCflags + +, izrc_nrlacqc ! value for altitude r.c. (ZRC) returned from tranQCflags + +, itqm_nrlacqc ! value for temperature q.m. (TQM) returned from tranQCflags + +, itrc_nrlacqc ! value for temperature r.c. (TRC) returned from tranQCflags + +, iqqm_nrlacqc ! value for moisture q.m. (QQM) returned from tranQCflags + +, iqrc_nrlacqc ! value for moisture r.c. (QRC) returned from tranQCflags + +, iwqm_nrlacqc ! value for wind q.m. (WQM) returned from tranQCflags + +, iwrc_nrlacqc ! value for wind r.c. (WRC) returned from tranQCflags + +c Variables used to hold original aircraft data read from input PREPBUFR file - necessary for +c carrying data through program so that it can be later written to output PREPBUFR-like +c profiles file from memory instead of going back to input PREPBUFR file and re-reading that +c file before adding any NRLACQC events +c ------------------------------------------------------------------------------------------- + integer nevents(max_reps,6) ! array tracking number of events for variables for each + ! report: + ! 1 - number of pressure events + ! 2 - number of moisture events + ! 3 - number of temperature events + ! 4 - number of altitude events + ! 5 - number of wind (u/v) events + ! 6 - number of wind (direction/speed) events + + real*8 pob_ev(max_reps,mxnmev) ! POB values for each report, including all events + +, pqm_ev(max_reps,mxnmev) ! PQM values for each report, including all events + +, ppc_ev(max_reps,mxnmev) ! PPC values for each report, including all events + +, prc_ev(max_reps,mxnmev) ! PRC values for each report, including all events + +, zob_ev(max_reps,mxnmev) ! ZOB values for each report, including all events + +, zqm_ev(max_reps,mxnmev) ! ZQM values for each report, including all events + +, zpc_ev(max_reps,mxnmev) ! ZPC values for each report, including all events + +, zrc_ev(max_reps,mxnmev) ! ZRC values for each report, including all events + +, tob_ev(max_reps,mxnmev) ! TOB values for each report, including all events + +, tqm_ev(max_reps,mxnmev) ! TQM values for each report, including all events + +, tpc_ev(max_reps,mxnmev) ! TPC values for each report, including all events + +, trc_ev(max_reps,mxnmev) ! TRC values for each report, including all events + +, qob_ev(max_reps,mxnmev) ! QOB values for each report, including all events + +, qqm_ev(max_reps,mxnmev) ! QQM values for each report, including all events + +, qpc_ev(max_reps,mxnmev) ! QPC values for each report, including all events + +, qrc_ev(max_reps,mxnmev) ! QRC values for each report, including all events + +, uob_ev(max_reps,mxnmev) ! UOB values for each report, including all events + +, vob_ev(max_reps,mxnmev) ! VOB values for each report, including all events + +, wqm_ev(max_reps,mxnmev) ! WQM values for each report, including all events + +, wpc_ev(max_reps,mxnmev) ! WPC values for each report, including all events + +, wrc_ev(max_reps,mxnmev) ! WRC values for each report, including all events + + integer mxnmev,max_reps + +c Misc. +c ----- + real nrlacqc_pc ! PREPBUFR program code for the NRLACQC step + + integer ibfms ! BUFRLIB function for testing for missing + + logical l_skip ! skip (TRUE) or execute (FALSE) block of code + +c Logicals controlling processing (read in from namelist in main program) +c ----------------------------------------------------------------------- + logical l_allev_pf ! T=process latest (likely NRLACQC) events plus all prior + ! events into profiles PREPBUFR-like file + ! **CAUTION: More complete option, but will make code take + ! longer to run!!! + ! F=process ONLY latest (likely NRLACQC) events into profiles + ! PREPBUFR-like file (here means input latest events will + ! likely be written over by NRLACQC events) + ! Note : All pre-existing events plus latest (likely NRLACQC) + ! events are always encoded into full PREPBUFR file) + + +c ******************************************************************* + +c Initialize variables +c -------------------- + + ipqm_topstk = 9999 + izqm_topstk = 9999 + itqm_topstk = 9999 + iqqm_topstk = 9999 + iwqm_topstk = 9999 + +c Start subroutine +c ---------------- + +c --------------------------------------------------------------- +c Translate NRLACQC flags to NCEP events and add events to memory +c --------------------------------------------------------------- + +c Also, first initialize the "bad report", "suspect report", and "duplicate report" flags as +c false - these flags will be set to true if the NRLACQC quality information (array +c c_qc_stg) indicates that the report or any part of it is bad, suspect or a duplicate +c ------------------------------------------------------------------------------------------ + l_badrpt_p = .false. + l_badrpt_z = .false. + l_badrpt_t = .false. + l_badrpt_q = .false. + l_badrpt_w = .false. + + l_duprpt = .false. + +c Pressure +c -------- + +c Get pressure OB and QM at top of stack coming in (from memory) and store in pob_topstk and +c ipqm_topstk, translate NRLACQC quality flags in c_qc_stg to NCEP standards for pressure +c and store in ipqc_nrlacqc, also store reason code in iprc_nrlacqc +c ------------------------------------------------------------------------------------------ + pob_topstk = pob_ev(j,nevents(j,1)) + if(ibfms(pqm_ev(j,nevents(j,1))).eq.0) then + if(nint(pqm_ev(j,nevents(j,1))).ge.0.and. + + nint(pqm_ev(j,nevents(j,1))).le.15) then +c PQM for event at top of stack (prior to adding any NRLACQC events) + ipqm_topstk = nint(pqm_ev(j,nevents(j,1))) + endif + endif + + call tranQCflags(c_qc_stg,'p',ipqm_nrlacqc,iprc_nrlacqc, + + l_badrpt_p,l_duprpt) + +c if PQM = 2 and PRC = 099, returned from tranQCflags, then can't translate! + if(ipqm_nrlacqc.eq.2 .and. iprc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc_stg flag on pressure/altitude:', + + c_qc_stg(5:5) + print * + endif + +c Altitude +c -------- + +c Get altitude OB and QM at top of stack coming in (from memory) and store in zob_topstk and +c izqm_topstk, translate NRLACQC quality flags in c_qc_stg to NCEP standards for altitude +c and store in izqc_nrlacqc, also store reason code in izrc_nrlacqc +c +c Use same quality marks for altitude as were used for pressure - NRLACQC has one flag for +c both (c_qc_stg(5:5)) +c ------------------------------------------------------------------------------------------ + zob_topstk = zob_ev(j,nevents(j,4)) + if(ibfms(zqm_ev(j,nevents(j,4))).eq.0) then + if(nint(zqm_ev(j,nevents(j,4))).ge.0.and. + + nint(zqm_ev(j,nevents(j,4))).le.15) then +c ZQM for event at top of stack (prior to adding any NRLACQC events) + izqm_topstk = nint(zqm_ev(j,nevents(j,4))) + endif + endif + + call tranQCflags(c_qc_stg,'z',izqm_nrlacqc,izrc_nrlacqc, + + l_badrpt_z,l_duprpt) + +c if ZQM = 2 and ZRC = 099 returned from tranQCflags, then can't translate! + if(izqm_nrlacqc.eq.2 .and. izrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc_stg flag on pressure/altitude:', + + c_qc_stg(5:5) + print * + endif + +c Temperature +c ----------- + +c Get temperature OB and QM at top of stack coming in (from memory) and store in tob_topstk +c and itqm_topstk, translate NRLACQC quality flags in c_qc_stg to NCEP standards for +c temperature and store in itqc_nrlacqc, also store reason code in itrc_nrlacqc +c ----------------------------------------------------------------------------------------- + tob_topstk = tob_ev(j,nevents(j,3)) + if(ibfms(tqm_ev(j,nevents(j,3))).eq.0) then + if(nint(tqm_ev(j,nevents(j,3))).ge.0.and. + + nint(tqm_ev(j,nevents(j,3))).le.15) then +c TQM for event at top of stack (prior to adding any NRLACQC events) + itqm_topstk = nint(tqm_ev(j,nevents(j,3))) + endif + endif + + call tranQCflags(c_qc_stg,'t',itqm_nrlacqc,itrc_nrlacqc, + + l_badrpt_t,l_duprpt) + +c if TQM = 2 and TRC = 099 returned from tranQCflags, then can't translate! + if(itqm_nrlacqc.eq.2 .and. itrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc_stg flag on temperature:', + + c_qc_stg(6:6) + print * + endif + +c Moisture +c -------- + +c Get moisture OB and QM at top of stack coming in (from memory) and store in qob_topstk and +c iqqm_topstk, translate NRLACQC quality flags in c_qc_stg to NCEP standards for moisture +c and store in iqqc_nrlacqc, also store reason code in iqrc_nrlacqc +c ------------------------------------------------------------------------------------------ + qob_topstk = qob_ev(j,nevents(j,2)) + if(ibfms(qqm_ev(j,nevents(j,2))).eq.0) then + if(nint(qqm_ev(j,nevents(j,2))).ge.0.and. + + nint(qqm_ev(j,nevents(j,2))).le.15) then +c QQM for event at top of stack (prior to adding any NRLACQC events) + iqqm_topstk = nint(qqm_ev(j,nevents(j,2))) + endif + endif + + call tranQCflags(c_qc_stg,'q',iqqm_nrlacqc,iqrc_nrlacqc, + + l_badrpt_q,l_duprpt) + +c if QQM = 2 and QRC = 099 returned from tranQCflags, then can't translate! + if(iqqm_nrlacqc.eq.2 .and. iqrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc_stg flag on moisture:', + + c_qc_stg(9:9) + print * + endif + +c Wind +c ---- + +c Get wind OB (u- and v-) and QM at top of stack coming in (from memory) and store in +c uob_topstk, vob_topstk, and iwqm_topstk, translate NRLACQC quality flags in c_qc_stg to +c NCEP standards for wind and store in iwqc_nrlacqc, also store reason code in iwrc_nrlacqc +c ------------------------------------------------------------------------------------------ + uob_topstk = uob_ev(j,nevents(j,5)) + vob_topstk = vob_ev(j,nevents(j,5)) + if(ibfms(wqm_ev(j,nevents(j,5))).eq.0) then + if(nint(wqm_ev(j,nevents(j,5))).ge.0.and. + + nint(wqm_ev(j,nevents(j,5))).le.15) then +c WQM for event at top of stack (prior to adding any NRLACQC events) + iwqm_topstk = nint(wqm_ev(j,nevents(j,5))) + endif + endif + + call tranQCflags(c_qc_stg,'w',iwqm_nrlacqc,iwrc_nrlacqc, + + l_badrpt_w,l_duprpt) + +c if WQM = 2 and WRC = 099 returned from tranQCflags, then can't translate! + if(iwqm_nrlacqc.eq.2 .and. iwrc_nrlacqc.eq.099) then + print * + print *, 'Unknown c_qc_stg flag on wind:', + + c_qc_stg(7:7),'/',c_qc_stg(8:8) + print * + endif + +c If entire report is to be rejected, put reject flags (QM=13) on pressure, altitude, +c temperature, moisture, and wind +c ----------------------------------------------------------------------------------- + if(l_badrpt_p .or. l_badrpt_z .or. + + l_badrpt_t .or. l_badrpt_q .or. l_badrpt_w) then + ipqm_nrlacqc = 13 ! PQM + ! PRC already encoded into iprc_nrlacqc in subr. tranQCflags + + izqm_nrlacqc = 13 ! ZQM + ! ZRC already encoded into izrc_nrlacqc in subr. tranQCflags + + itqm_nrlacqc = 13 ! TQM + ! TRC already encoded into itrc_nrlacqc in subr. tranQCflags + + iqqm_nrlacqc = 13 ! QQM + ! QRC already encoded into iqrc_nrlacqc in subr. tranQCflags + + iwqm_nrlacqc = 13 ! WQM + ! WRC already encoded into iwrc_nrlacqc in subr. tranQCflags + + endif ! l_badrpt_[p,z,t,q,w] + +c If report is marked as a duplicate (c_qc_stg(1:1) = d or D), then mark the entire report +c with a bad NCEP quality mark (=13) +c ---------------------------------------------------------------------------------------- + if(l_duprpt) then + ipqm_nrlacqc = 13 ! PQM + ! PRC already encoded into iprc_nrlacqc in subr. tranQCflags + + izqm_nrlacqc = 13 ! ZQM + ! ZRC already encoded into izrc_nrlacqc in subr. tranQCflags + + itqm_nrlacqc = 13 ! TQM + ! TRC already encoded into itrc_nrlacqc in subr. tranQCflags + + iqqm_nrlacqc = 13 ! QQM + ! QRC already encoded into iqrc_nrlacqc in subr. tranQCflags + + iwqm_nrlacqc = 13 ! WQM + ! WRC already encoded into iwrc_nrlacqc in subr. tranQCflags + + endif ! l_duprpt + +c Update pressure, altitude, temperature, moisture and wind stacks with new event in memory +c when there has been a qualty mark change by NRLACQC (don't need to write out an event if +c quality mark has not been changed by this program) +c +c EXCEPTION: Retain (honor) the incoming quality mark at the top of the stack (i.e., do not +c write event) when: +c +c (1) The incoming quality mark at the top of the stack is 0 (keep flag) +c (2) The incoming quality mark at the top of the stack is between 4 and 15 (bad) - +c except when NRLACQC itself generates a BAD quality mark (translated to NCEP +c value of 13), allows reason code to denote why action taken by NRLACQC to mark +c obs as bad +c (3) The incoming quality mark at the top of the stack is not between 0 and 15 +c (i.e.,missing) +c (4) The incoming quality mark at the top of the stack is 3 (suspect) and the NRLACQC +c generates a GOOD or NEUTRAL or SUSPECT quality mark (translated to NCEP values of +c 1, 2 and 3 resp.) {in other words, unless an ob previously marked as suspect was +c marked bad by NRLACQC, don't change a suspect quality mark assigned by a PREPBUFR +c processing step prior to the NRLACQC step} +c (5) The quality mark translated to its NCEP value is 2 (neutral) and the reason code +c is returned from tranQCflags is 099 - this indicates that the NRLACQC quality +c flags in c_qc_stg pertaining to this ob are unknown to transQCflags (the routine +c tranQCflags may need to be updated to account for the c_qc_stg flags that is +c coming out of the NRLACQC QC routine for this ob - this would probably only +c happen if NRL provides an updated/upgraded acftobs_qc module to NCEP) +c (6) The NCEP equivalent of the NRLACQC is the same as the incoming quality mark of +c the stack - if there is no change in the quality mark, then do not add a new +c event and leave the event at the top of the event stack as is with TWO +c exceptions: +c a) NRLACQC itself generates a GOOD quality mark (translated to NCEP value of +c 1) +c b) NRLACQC itself generates a BAD quality mark (translated to NCEP value of +c 13) (see 2 above for more on this) +c ------------------------------------------------------------------------------------------- + +c Pressure +c -------- + + l_skip = .true. ! SKIP LOGIC TO WRITE PRESSURE EVENTS - there is no need to do so since + ! pressure is a vertical coordinate and it is not analyzed, in + ! addition, adding pressure events complicates reason code logic + + if(.not.l_skip) then + +c .... if here, include logic to write pressure events + if(ipqm_topstk.eq.0 .or. + + (ipqm_topstk.ge.4 .and. ipqm_topstk.le.15) .or. ! ob has already been marked bad + ! by NCEP codes + + ipqm_topstk.eq.9999 .or. + + (ipqm_topstk.eq.3.and.ipqm_nrlacqc.le.3) .or. + + (ipqm_nrlacqc.eq.2.and.iprc_nrlacqc.eq.099) .or. + + (ipqm_topstk.eq.ipqm_nrlacqc.and.ipqm_nrlacqc.ne.1) + + ) then ! no event needed; leave PQM as is + + ipqm_nrlacqc = ipqm_topstk + + else ! NRL QC produced an event; add this event to top of stack in memory + if(l_allev_pf) nevents(j,1) = nevents(j,1) + 1 ! add new event (do not write over + ! event currently at top of stack + ! since l_allev_pf=TRUE) + pob_ev(j,nevents(j,1)) = pob_topstk + pqm_ev(j,nevents(j,1)) = ipqm_nrlacqc + ppc_ev(j,nevents(j,1)) = nrlacqc_pc + prc_ev(j,nevents(j,1)) = iprc_nrlacqc + + endif + + else + +c .... if here, SKIP logic to write pressure events + ipqm_nrlacqc = ipqm_topstk + + endif + +c Altitude +c -------- + + l_skip = .true. ! SKIP LOGIC TO WRITE ALTITUDE EVENTS - there is no need to do so since + ! altitude is a vertical coordinate and it is not analyzed, in + ! addition, adding altitude events complicates reason code logic + + if(.not.l_skip) then + +c .... if here, include logic to write altitude events + if(izqm_topstk.eq.0 .or. + + (izqm_topstk.ge.4 .and. izqm_topstk.le.15) .or. ! ob has already been marked bad + ! by NCEP codes + + izqm_topstk.eq.9999 .or. + + (izqm_topstk.eq.3.and.izqm_nrlacqc.le.3) .or. + + (izqm_nrlacqc.eq.2.and.izrc_nrlacqc.eq.099) .or. + + (izqm_topstk.eq.izqm_nrlacqc.and.izqm_nrlacqc.ne.1) + + ) then ! no event needed; leave ZQM as is + izqm_nrlacqc = izqm_topstk + + else ! NRL QC produced an event; add this event to top of stack in memory + if(l_allev_pf) nevents(j,4) = nevents(j,4) + 1 ! add new event (do not write over + ! event currently at top of stack + ! since l_allev_pf=TRUE) + zob_ev(j,nevents(j,4)) = zob_topstk + zqm_ev(j,nevents(j,4)) = izqm_nrlacqc + zpc_ev(j,nevents(j,4)) = nrlacqc_pc + zrc_ev(j,nevents(j,4)) = izrc_nrlacqc + + endif + + else + +c .... if here, SKIP logic to write altitude events + izqm_nrlacqc = izqm_topstk + + endif + +c Temperature +c ----------- + +c Obs/Events + if((itqm_topstk.eq.0 .or. + + (itqm_topstk.ge.4 .and. itqm_topstk.le.15) .or. ! ob has already been marked bad by + ! NCEP codes + + itqm_topstk.eq.9999 .or. + + (itqm_topstk.eq.3.and.itqm_nrlacqc.le.3) .or. + + (itqm_nrlacqc.eq.2.and.itrc_nrlacqc.eq.099) .or. + + (itqm_topstk.eq.itqm_nrlacqc.and.itqm_nrlacqc.ne.1) + + ) .and. (itqm_nrlacqc.ne.13.or. + + itqm_topstk.eq.9999)) then ! no event needed; leave TQM as is + itqm_nrlacqc = itqm_topstk + + else ! NRL QC produced an event; add this event to top of stack in memory + if(l_allev_pf) nevents(j,3) = nevents(j,3) + 1 ! add new event (do not write over + ! event currently at top of stack + ! since l_allev_pf=TRUE) + if(int(itrc_nrlacqc/100).eq.9 .and. + + itqm_nrlacqc.eq.13) itqm_nrlacqc = 14 ! if temperature marked bad here due to it + ! being on reject list, reset TQM to 14 + tob_ev(j,nevents(j,3)) = tob_topstk + tqm_ev(j,nevents(j,3)) = itqm_nrlacqc + tpc_ev(j,nevents(j,3)) = nrlacqc_pc + trc_ev(j,nevents(j,3)) = itrc_nrlacqc + + endif + +c Moisture +c -------- + +c Obs/Events + if((iqqm_topstk.eq.0 .or. + + (iqqm_topstk.ge.4 .and. iqqm_topstk.le.15) .or. ! ob has already been marked bad by + ! NCEP codes + + iqqm_topstk.eq.9999 .or. + + (iqqm_topstk.eq.3 .and. iqqm_nrlacqc.le.3) .or. + + (iqqm_nrlacqc.eq.2.and.iqrc_nrlacqc.eq.099) .or. + + (iqqm_topstk.eq.iqqm_nrlacqc.and.iqqm_nrlacqc.ne.1) + + ) .and. (iqqm_nrlacqc.ne.13.or. + + iqqm_topstk.eq.9999)) then ! no event needed; leave QQM as is + iqqm_nrlacqc = iqqm_topstk + + else ! NRL QC produced a new event; add this event to top of stack in memory + if(l_allev_pf) nevents(j,2) = nevents(j,2) + 1 ! add new event (do not write over + ! event currently at top of stack + ! since l_allev_pf=TRUE) + if(int(iqrc_nrlacqc/100).eq.9 .and. + + iqqm_nrlacqc.eq.13) iqqm_nrlacqc = 14 ! if moisture marked bad here due to + ! temperature being on reject list, reset + ! QQM to 14 + qob_ev(j,nevents(j,2)) = qob_topstk + qqm_ev(j,nevents(j,2)) = iqqm_nrlacqc + qpc_ev(j,nevents(j,2)) = nrlacqc_pc + qrc_ev(j,nevents(j,2)) = iqrc_nrlacqc + + endif + +c Wind +c ---- + +c Obs/Events + if((iwqm_topstk.eq.0 .or. + + (iwqm_topstk.ge.4 .and. iwqm_topstk.le.15) .or. ! ob has already been marked bad by + ! NCEP codes + + iwqm_topstk.eq.9999 .or. + + (iwqm_topstk.eq.3 .and. iwqm_nrlacqc.le.3) .or. + + (iwqm_nrlacqc.eq.2.and.iwrc_nrlacqc.eq.099) .or. + + (iwqm_topstk.eq.iwqm_nrlacqc.and.iwqm_nrlacqc.ne.1) + + ) .and. (iwqm_nrlacqc.ne.13.or. + + iwqm_topstk.eq.9999)) then ! no event needed; leave WQM as is + iwqm_nrlacqc = iwqm_topstk + + else ! NRL QC produced a new event; add this event to top of stack in memory + if(l_allev_pf) nevents(j,5) = nevents(j,5) + 1 ! add new event (do not write over + ! event currently at top of stack + ! since l_allev_pf=TRUE) + if(int(iwrc_nrlacqc/100).eq.9 .and. + + iwqm_nrlacqc.eq.13) iwqm_nrlacqc = 14 ! if wind marked bad here due to it being + ! on reject list, reset WQM to 14 + uob_ev(j,nevents(j,5)) = uob_topstk + vob_ev(j,nevents(j,5)) = vob_topstk + wqm_ev(j,nevents(j,5)) = iwqm_nrlacqc + wpc_ev(j,nevents(j,5)) = nrlacqc_pc + wrc_ev(j,nevents(j,5)) = iwrc_nrlacqc + + endif + + return + + end diff --git a/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/tranQCflags.f b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/tranQCflags.f new file mode 100644 index 00000000..7b3e2dd6 --- /dev/null +++ b/src/Applications/NCEP_Paqc/prepobs_prepacqc.fd/tranQCflags.f @@ -0,0 +1,813 @@ +c$$$ Subprogram Documentation Block +c BEST VIEWED WITH 94-CHARACTER WIDTH WINDOW +c +c Subprogram: tranQCflags +c Programmer: D. Keyser Org: NP22 Date: 2012-05-08 +c +c Abstract: Translates quality information from NRL standards to equivalent NCEP PREPBUFR +c quality marks. Also generates the NCEP PREPBUFR reason codes based on the NRL quality +c information. This is read in for one observation at a time for each report (e.g., +c pressure reads it, then altitude, then temperature, then moisture, then wind). +c +c Program History Log: +c 2010-11-15 S. Bender -- Original Author +c 2012-05-08 D. Keyser -- Prepared for operational implementation +c +c Usage: call tranQCflags(NRLQCstg,type,NCEPqm,NCEPrc,l_badrpt,l_duprpt) +c +c Input argument list: +c NRLQCstg - NRLACQC quality information (11 char. string) for this complete report +c type - Type of variable being considered in this call (e.g., 'p', 'z', 't', +c 'q', 'w') +c +c Output argument list: +c NCEPqm - Equivalent NCEP PREPBUFR quality mark for this variable +c NCEPrc - Generated NCEP PREPBUFR reason code for this variable +c l_badrpt - Logical indicating if the entire report should be marked as "bad" +c l_duprpt - Logical indicating if the entire report should be marked as a duplicate +c +c Output files: +c Unit 06 - Standard output print +c +c Subprograms called: +c Library: +c W3NCO: ERREXIT W3TAGE MOVA2I +c +c Exit States: +c Cond = 0 - successful run +c 69 - row number for input data matrix is outside range of 1-34 +c +c Remarks: Called by subroutines output_acqc_noprof and sub2mem_um. +c +c Attributes: +c Language: FORTRAN 90 +c Machine: NCEP WCOSS +c +c$$$ + subroutine tranQCflags(NRLQCstg,type,NCEPqm,NCEPrc,l_badrpt, + + l_duprpt) + + implicit none + + character*11 NRLQCstg + character*1 type + + logical l_badrpt,l_duprpt + + integer iii(45:118) ! the "row number" (RN) corresponding to the single + ! character NRLACQC quality flag pulled out of + ! NRLQCstg, this is the second dimension of table + ! w2d + +, mova2i + + integer cp ! character position in c_qc string (1-11), this + ! value minus 1 is the first dimension of table w2d + +, RN ! row number in w2d/action data table/numerical + ! equivalent of character value (example: a=1, + ! F=10), this is obtained via integer conversion of + ! the single ASCII character NRLACQC quality flag + ! pulled out of NRLQCstg, obtained from iii + + character*2 w2d(0:10,34) +c 0 = overall report +c |--- 1 = time +c |--- |--- 2 = latitude +c |--- |--- |--- 3 = longitude +c |--- |--- |--- |--- 4 = pressure/altitude +c |--- |--- |--- |--- |--- 5 = temperature +c |--- |--- |--- |--- |--- |--- 6 = wind direction +c |--- |--- |--- |--- |--- |--- |--- 7 = wind speed +c |--- |--- |--- |--- |--- |--- |--- |--- 8 = moisture +c |--- |--- |--- |--- |--- |--- |--- |--- |--- 9 = reject (black) list +c |--- |--- |--- |--- |--- |--- |--- |--- |--- |--- 10 = flight phase +c |--- |--- |--- |--- |--- |--- |--- |--- |--- |--- |--- +c i: 0:10 (cp-1) --------------> + data w2d/'ND','ND','ND','ND','ND','ND','ND','ND','ND','ND','IO', ! a j:1-34 (RN) 1 | + + 'RR','ND','ND','ND','ND','ND','ND','RW','ND','ND','IO', ! A 2 | + + 'RR','RR','RR','RR','RR','RR','RW','RW','RM','ND','ND', ! B 3 | + + 'ND','ND','ND','ND','ND','RT','ND','ND','ND','ND','ND', ! b 4 V + + 'ND','ND','ND','ND','ND','ND','ND','ND','ND','IO','ND', ! C 5 + + 'DR','ND','ND','ND','ND','ND','ND','ND','ND','ND','IO', ! D 6 + + 'DR','ND','ND','ND','ND','ND','ND','ND','ND','ND','IO', ! d 7 + + 'RR','ND','ND','ND','ND','RT','RW','RW','ND','ND','ND', ! E 8 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! e 9 + + 'ND','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! F 10 + + 'ND','RR','RR','RR','RR','RT','RW','RW','ND','ND','ND', ! I 11 + + 'ND','ND','ND','ND','RR','ND','ND','ND','ND','ND','IO', ! i 12 + + 'ND','RR','RR','RR','RR','CW','CT','CT','RM','ND','ND', ! K 13 + + 'ND','ND','ND','ND','ND','ND','ND','ND','ND','ND','IO', ! L 14 + + 'ND','RR','RR','RR','RR','CW','CT','CT','RM','IO','IO', ! M 15 + + 'NU','NU','NU','NU','ND','NU','ND','ND','NU','ND','IO', ! N 16 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','RR','ND', ! O 17 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! P 18 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! p 19 + + 'ND','IO','IO','IO','IO','IO','ND','ND','ND','ND','ND', ! R 20 + + 'RR','ND','ND','ND','IO','ND','ND','ND','ND','ND','ND', ! r 21 + + 'RR','RR','RR','RR','RR','ND','ND','SW','SM','ND','ND', ! S 22 + + 'RR','ND','ND','ND','ND','ND','SW','SW','ND','ND','ND', ! s 23 + + 'ND','ND','ND','ND','ND','ND','ND','ND','ND','RT','ND', ! T 24 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! t 25 + + 'ND','ND','ND','ND','ND','ND','ND','ND','ND','ND','IO', ! U 26 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! V 27 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! v 28 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','RW','ND', ! W 29 + + 'RR','ND','ND','ND','ND','ND','ND','ND','ND','ND','ND', ! X 30 + + 'GR','IO','IO','IO','GV','GT','GW','GW','GM','IO','ND', ! . 31 + + 'NU','ND','ND','ND','NU','NU','NU','NU','NU','ND','ND', ! - 32 + + 'IO','ND','ND','ND','ND','ND','ND','ND','SM','ND','ND', ! 2 33 + + 'ND','ND','ND','ND','ND','ND','ND','ND','SM','ND','ND' ! 3 34 + + / + +c 'CT' -- check temperature -> reject wind, or will reject report if temperature also bad +c 'CW' -- check wind -> reject temperature, or will reject report if wind also bad +c 'DR' -- duplicate report +c 'GM' -- good moisture +c 'GR' -- good report +c 'GT' -- good temperature` +c 'GV' -- good pressure/altitude +c 'GW' -- good wind +c 'IO' -- inconclusive (?) +c 'ND' -- not defined +c 'NU' -- neutral report (not checked) +c 'RM' -- reject moisture +c 'RR' -- reject entire report +c 'RT' -- reject temperature +c 'RW' -- reject wind +c 'SM' -- suspect moisture +c 'SW' -- suspect wind +c 'XX' -- initialized value (not yet set) + + character*2 action ! action value to be passed back to the calling + ! routine (RR,DR,GR,RT,RM,RW,SW,NU,ND,IO) + +, bl_action ! reject (black) list action (c_qc(10:10)) + +, pres_action ! pressure/altitude action (c_qc(5:5)) + +, temp_action ! temperature action (c_qc(6:6)) + +, moist_action ! moisture action (c_qc(9:9)) + +, wdir_action ! wind direction action (c_qc(7:7)) + +, wspd_action ! wind speed action (c_qc(8:8)) + +, lat_action ! latitude action (c_qc(3:3)) + +, lon_action ! longitude action (c_qc(4:4)) + +, time_action ! time action (c_qc(2:2)) + +, overall_action ! action per c_qc(1:1) + + integer NCEPqm ! value of NCEP quality mark to be passed back to + ! calling routine + +, NCEPrc ! value of NCEP reason code to be passed back to + ! calling routine + +, NCEPrc_t ! intermediate value for temperature quality mark + +, NCEPrc_q ! intermediate value for moisture quality mark + +, NCEPrc_w ! intermediate value for wind quality mark + + +c Misc. +c ----- + +c decimal --> 45 46 50 51 +c character --> '-' '.' '2' '3' + data iii / 32, 31, 0, 0, 0, 33, 34, 0, 0, 0, 0, 0, 0, + +c decimal --> 65 66 67 68 69 70 +c character --> 'A' 'B' 'C' 'D' 'E' 'F' + + 0, 0, 0, 0, 0, 0, 0, 2, 3, 5, 6, 8, 10, + +c decimal --> 73 75 76 77 78 79 80 82 83 +c character --> 'I' 'K' 'L' 'M' 'N' 'O' 'P' 'R' 'S' + + 0, 0, 11, 0, 13, 14, 15, 16, 17, 18, 0, 20, 22, + +c decimal --> 84 85 86 87 88 +c character --> 'T' 'U' 'V' 'W' 'X' + + 24, 26, 27, 29, 30, 0, 0, 0, 0, 0, 0, 0, 0, + +c decimal --> 97 98 100 101 105 +c character --> 'a' 'b' 'd' 'e' 'i' + + 1, 4, 0, 7, 9, 0, 0, 0, 12, 0, 0, 0, 0, + +c decimal --> 112 114 115 116 118 +c character --> 'p' 'r' 's' 't' 'v' + + 0, 0, 19, 0, 21, 23, 25, 0, 28 / + +c ----------------------------------------------------------- + +c Initialize variables +c -------------------- + l_badrpt = .false. + l_duprpt = .false. + + bl_action = 'XX' + pres_action = 'XX' + temp_action = 'XX' + moist_action = 'XX' + wdir_action = 'XX' + wspd_action = 'XX' + lat_action = 'XX' + lon_action = 'XX' + time_action = 'XX' + overall_action = 'XX' + action = 'XX' + + NCEPqm = 99999 + NCEPrc = 99999 + NCEPrc_t = 99999 + NCEPrc_q = 99999 + NCEPrc_w = 99999 +c ----------------------------------------------------------- + +C ************************************************************************* +c FIRST CHECK FOR UNILATERAL REJECT REPORT - APPLIES TO ALL VARIABLES +C ************************************************************************* + +c --------------------------------------------------------------------- +c First sub-check is on OVERALL REPORT (first character of c_qc string) +c --------------------------------------------------------------------- + cp = 1 + +c iii represents the "row number" corresponding to the single ASCII character NRLACQC +c quality flag NRLQCstg(cp:cp) and is the second dimension of table w2d (Note: this comment +c is not repeated for each instance where iii is obtained below) +c ------------------------------------------------------------------------------------------- + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU', 'GR', 'DR' + overall_action = action + if(action.eq.'RR' .or. action.eq.'DR') then + NCEPrc = (cp-1)*100 + RN ! RC range 001-034 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c ------------------------------------------------------------------------ +C If we make it to here ... +c Second sub-check is on PRESSURE/ALTITUDE (fifth character of c_qc string) +c ------------------------------------------------------------------------- + cp = 5 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU', 'GV' + pres_action = action + if(action.eq.'RR') then + NCEPrc = (cp-1)*100 + RN ! RC range 401-434 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c ------------------------------------------------------------------ +C If we make it to here ... +c Third sub-check is on TEMPERATURE (sixth character of c_qc string) +c ------------------------------------------------------------------ + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU', 'RT', 'GT', 'CW' + temp_action = action + if(temp_action.eq.'RT') then +c If temperature action is reject temperature ('RT'), change reject (black) list value in +c tenth character of c_qc string from 'O' (reject entire report) to 'W' (reject wind only) - +c this prevents eighth sub-check below from masking QM (13) & RC associated with this code's +c reject of temperature {instead it would receive reject (black) list QM (14) and RC} + if(NRLQCstg(10:10).eq.'O') NRLQCstg(10:10) = 'W' + endif + if(action.eq.'RR') then + NCEPrc = (cp-1)*100 + RN ! RC range 501-534 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c ------------------------------------------------------------- +C If we make it to here ... +c Fourth sub-check is on TIME (second character of c_qc string) +c ------------------------------------------------------------- + cp = 2 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU' + time_action = action + if(action.eq.'RR') then + NCEPrc = (cp-1)*100 + RN ! RC range 101-134 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c --------------------------------------------------------------- +C If we make it to here ... +c Fifth sub-check is on LATITUDE (third character of c_qc string) +c --------------------------------------------------------------- + cp = 3 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU' + lat_action = action + if(action.eq.'RR') then + NCEPrc = (cp-1)*100 + RN ! RC range 201-234 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c ----------------------------------------------------------------- +C If we make it to here ... +c Sixth sub-check is on LONGITUDE (fourth character of c_qc string) +c ----------------------------------------------------------------- + cp = 4 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'NU' + lon_action = action + if(action.eq.'RR') then + NCEPrc = (cp-1)*100 + RN ! RC range 301-334 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +c ------------------------------------------------------------------------------------------- +C If we make it to here ... +c Seventh sub-check is on TEMPERATURE/WIND COMBINATION (sixth thru tenth char of c_qc string) +c ------------------------------------------------------------------------------------------- +c We already know temperature action (from sixth character of c_qc string) from above +c {temp_action, either 'ND', 'IO', 'NU', 'RT', 'GT', 'CW' ('RR' already considered)} + +c Obtain wind direction action from seventh character of c_qc string (wdir_action) + cp = 7 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + wdir_action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RW', 'SW', 'GW', 'CT' + ! (Note: 'RR' not a choice here) + if(wdir_action.eq.'RW') then +c If wind direction action is reject wind ('RW'), change reject (black) list value in tenth +c character of c_qc string from 'O' (reject entire report) to 'T' (reject temperature only) +c - this prevents eighth sub-check below from masking QM (13) & RC associated with this +c code's reject of wind {instead it would receive reject (black) list QM (14) & RC} + if(NRLQCstg(10:10).eq.'O') NRLQCstg(10:10) = 'T' + endif + +c Obtain wind speed action from eighth character of c_qc string (wspd_action) + cp = 8 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + wspd_action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RW', 'SW', 'GW', 'CT' + ! (Note: 'RR' not a choice here) + if(wspd_action.eq.'RW') then +c If wind speed action is reject wind ('RW'), change reject (black) list value in tenth +c character of c_qc string from 'O' (reject entire report) to 'T' (reject temperature only) +c - this prevents eighth sub-check below from masking QM (13) & RC associated with this +c code's reject of wind {instead it would receive reject (black) list QM (14) and RC} + if(NRLQCstg(10:10).eq.'O') NRLQCstg(10:10) = 'T' + endif + +c Obtain moisture action from ninth character of c_qc string (wspd_action) + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + moist_action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RM', 'SM', 'GM' + ! (Note: 'RR' not a choice here) + +c Obtain reject (black) list action from tenth character of c_qc string (bl_action) + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + bl_action = w2d(cp-1,RN) ! either 'ND', 'RR', 'IO', 'RT', 'RW' + +c If temperature action is to check wind ('CW'), then a "bad" wind will result in the entire +c report being rejected + if(temp_action.eq.'CW') then + action = 'RR' + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 501-534 +c .... first check wind direction to see if it is "bad" + if(wdir_action.eq.'CT'.or.wdir_action.eq.'RW') then + cp = 7 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 601-634 +c ........ a bad wind direction rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + elseif(wspd_action.eq.'CT'.or.wspd_action.eq.'RW') then +c .... next check wind speed to see if it is "bad" + cp = 8 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 701-734 +c ........ a bad wind speed rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + elseif(bl_action.eq.'RW' ) then +c .... finally check reject (black) list to see if wind (direction/speed) is rejected ("bad") +c (Note: bl_action = 'RR' will be considered separately in eighth sub-check below) + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 901-934 +c ........ wind on reject (black) list rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + else +c .... even though temperature action is to check wind ('CW'), wind is not "bad", so +c temperature (and wind and moisture if they are present) will be tested later as a +c single variable unless eighth sub-check below yields a reject entire report + action = 'XX' ! reset action back to initialized value + NCEPrc_t = 99999 ! reset temperature reason code back to initialized value + endif + else +c Temperature action is something other than check wind ('CW') {or, for that matter, reject +c report ('RR')}, so temperature (and wind and moisture if present) will be tested later as +c a single variable unless eighth sub-check below yields a reject entire report + temp_action = temp_action ! dummy statement to allow else branch here + endif + +c If wind direction action is to check temperature ('CT'), then a "bad" temperature will +c result in the entire report being rejected + if(wdir_action.eq.'CT') then + action = 'RR' + cp = 7 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 601-634 +c .... first check temperature to see if it is "bad" + if(temp_action.eq.'CW'.or.temp_action.eq.'RT') then + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 501-534 +c ........ a bad temperature rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + elseif(bl_action.eq.'RT' ) then +c .... finally check reject (black) list to see if temperature is rejected ("bad") +c (Note: bl_action = 'RR' will be considered separately in eighth sub-check below) + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 901-934 +c ........ temperature on reject (black) list rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + else +c .... even though wind direction action is to check temperature ('CT'), temperature is not +c "bad", so wind (and temperature and moisture if present) will be tested later as a +c single variable unless either wind speed check (action 'CT' checking against "bad" +c temperature) just below yields a reject entire report, or eighth sub-check below +c yields a reject entire report + action = 'XX' ! reset action back to initialized value + NCEPrc_w = 99999 ! reset wind reason code back to initialized value + endif + else +c Wind direction action is something other than check temperature ('CT') {or, for that +c matter, reject report ('RR')}, so wind (and temperature and moisture if present) will be +c tested later as a single variable unless either wind speed check (action 'CT' checking +c against "bad" temperature) just below yields a reject entire report, or eighth sub-check +c below yields a reject entire report + wdir_action = wdir_action ! dummy statement to allow else branch here + endif + +c If wind speed action is to check temperature ('CT'), then a "bad" temperature will result +c in the entire report being rejected + if(wspd_action.eq.'CT') then + action = 'RR' + cp = 8 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 701-734 +c .... first check temperature to see if it is "bad" + if(temp_action.eq.'CW'.or.temp_action.eq.'RT') then + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 501-534 +c ........ a bad temperature rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + elseif(bl_action.eq.'RT' ) then +c .... finally check reject (black) list to see if temperature is rejected ("bad") +c (Note: bl_action = 'RR' will be considered separately in eighth sub-check below) + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 901-934 +c ........ temperature on reject (black) list rejects entire report +c ........ set RC for moisture to moisture action if moisture rejected, otherwise set it to +c RC for temperature + if(moist_action.eq.'RM') then + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + else + NCEPrc_q = NCEPrc_t ! moisture RC range 501-534 + endif + go to 2000 ! reject entire report here means we don't need to do anymore testing + else +c .... even though wind speed action is to check temperature ('CT'), temperature is not"bad", +c so wind (and temperature and moisture if present) will be tested later as a single +c variable unless eighth sub-check below yields a reject entire report + action = 'XX' ! reset action back to initialized value + NCEPrc_w = 99999 ! reset wind reason code back to initialized value + endif + else +c Wind speed action is something other than check temperature ('CT') {or, for that matter, +c reject report ('RR')}, so wind (and temperature and moisture if present) will be tested +c later as a single variable unless eighth sub-check below yields a reject entire report + wspd_action = wspd_action ! dummy statement to allow else branch here + endif + +c --------------------------------------------------------------------------- +C If we make it to here ... +c Eighth sub-check is on REJECT (BLACK) LIST (tenth character of c_qc string) +c --------------------------------------------------------------------------- +c We already know reject (black) list action (from tenth character of c_qc string) from above +c {bl_action, either 'ND', 'RR', 'IO', 'RT', 'RW'} + action = bl_action + if(action.eq.'RR') then + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + NCEPrc = (cp-1)*100 + RN ! RC range 901-934 + go to 2000 ! reject entire report here means we don't need to do anymore testing + endif + +C ************************************************************************* +C If we make it to here ... +c NEXT CHECK SINGLE VARIABLES +C ************************************************************************* + + if(type.eq.'p' .or. type.eq.'z') then ! check 5 +c ***************** +c PRESSURE/ALTITUDE +c ***************** + cp = 5 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'IO', 'NU', 'GV' ('RR' already considered) + NCEPrc = (cp-1)*100 + RN ! pressure/altitude RC range 401-434 + pres_action = action + + elseif(type.eq.'t') then ! check 6, 10 +c *********** +c TEMPERATURE +c *********** + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'IO', 'NU', 'RT', 'GT', 'CW' + ! ('RR' already considered) + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 501-534 + +c A temperature action of check wind ('CW') is treated as a reject temperature ('RT') - test +c for unilateral reject of entire report above has already tested cases where temperature +c action of 'CW' is combined with a "bad" wind (resulting in a reject of the entire report), +c so we know here that wind is not bad and only temperature should be rejected +c ------------------------------------------------------------------------------------------- + if(action.eq.'CW') action = 'RT' + +c Check reject (black) list flag to see if temperature should be rejected {but ONLY if +c temperature action is not already set to reject temperature ('RT')} +c ------------------------------------------------------------------------------------ + if(action.ne.'RT') then + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + bl_action = w2d(cp-1,RN) ! either 'ND', 'IO', 'RT', 'RW' ('RR' already considered) + if(bl_action.eq.'RT') then + action = 'RT' ! reject temperature + NCEPrc_t = (cp-1)*100 + RN ! temperature RC range 901-934 + endif + endif + + elseif(type.eq.'q') then ! check 9 +c ******** +c MOISTURE +c ******** + cp = 9 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RM', 'SM', 'GM' + ! (Note: 'RR' not a choice here) + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 801-834 + moist_action = action + + if(action.ne.'RM') then + +c A reject of temperature forces a reject of moisture (if moisture not already rejected) +c -------------------------------------------------------------------------------------- + cp = 6 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + temp_action = w2d(cp-1,RN) ! either 'ND', 'IO', 'NU', 'RT', 'GT', 'CW' + ! ('RR' already considered) + if(temp_action.eq.'RT') then + action = 'RM' + NCEPrc_q = (cp-1)*100 + RN ! moisture RC range 501-534 + endif + endif + + elseif(type.eq.'w') then ! check 7, 8, 10 +c **** +c WIND +c **** + +c First, check Wind direction action +c ---------------------------------- + cp = 7 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + wdir_action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RW', 'SW', 'GW', 'CT' + ! (Note: 'RR' not a choice here) + NCEPrc_w = (cp-1)*100 + RN ! initially set overall wind RC to reflect wind direction + ! status, wind RC range 601-634 {this may be overwritten later + ! by wind speed status if it is inferior to wind direction + ! status (quality-wise)}) + + action = wdir_action ! initially set overall wind action to wind direction + ! action {this may be overwritten later by wind speed action + ! if it is inferior to wind direction action (quality-wise)} + +c A wind direction action of check temperature ('CT') is treated as a reject wind ('RW') - +c test for unilateral reject of entire report above has already tested cases where wind +c direction action of 'CT' is combined with a "bad" temperature (resulting in a reject of +c the entire report), so we know here that temperature is not bad and only wind should be +c rejected +c ---------------------------------------------------------------------------------------- + if(wdir_action.eq.'CT') wdir_action = 'RW' + + if(wdir_action.eq.'RW') then + +c If wind direction action is reject wind ('RW') then set overall wind action to 'RW' - no +c need to examine wind speed action in this case +c ---------------------------------------------------------------------------------------- + action = 'RW' + else + +c Otherwise, check wind speed action to see if it is inferior to wind direction action +C (quality-wise) +c ------------------------------------------------------------------------------------ + + cp = 8 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + wspd_action = w2d(cp-1,RN) ! either 'ND', 'NU', 'RW', 'SW', 'GW', 'CT' + ! (Note: 'RR' not a choice here) + +c A wind speed action of check temperature ('CT') is treated as a reject wind ('RW') - test +c for unilateral reject of entire report above has already tested cases where wind speed +c action of 'CT' is combined with a "bad" temperature (resulting in a reject of the entire +c report), so we know here that temperature is not bad and only wind should be rejected +c ----------------------------------------------------------------------------------------- + if(wspd_action.eq.'CT') wspd_action = 'RW' + + if(wspd_action.eq.'RW') then + +c For cases when wind direction action is not 'RW' but wind speed action is 'RW', use wind +c speed's RC as overall wind RC value since it is inferior to wind direction action +C (quality-wise) +c ---------------------------------------------------------------------------------------- + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 701-734 + action = 'RW' + elseif (wdir_action.eq.'SW') then + +c For cases when wind direction action is suspect wind ('SW') and wind speed action is not +c 'RW', set overall wind action to 'SW' and use wind direction's RC as overall wind RC value +c since it is inferior to wind speed action (quality-wise) +c ------------------------------------------------------------------------------------------- + action = 'SW' + elseif (wspd_action.eq.'SW') then + +c For cases when wind direction action is neither 'RW' nor 'SW' but wind speed action is +c 'SW', set overall wind action to 'SW' and use wind speed's RC as overall wind RC value +c since it is inferior to wind direction action (quality-wise) +c --------------------------------------------------------------------------------------- + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 701-734 + action = 'SW' + endif + endif + +c Check reject (black) list flag to see if wind should be rejected {but ONLY if overall wind +c action is not already set to reject wind ('RW')} +c ------------------------------------------------------------------------------------------ + if(action.ne.'RW') then + cp = 10 + RN = iii(mova2i(NRLQCstg(cp:cp))) + if(RN.lt.0 .or. RN.gt.34) go to 999 + bl_action = w2d(cp-1,RN) ! either 'ND', 'IO', 'RT', 'RW' ('RR' already considered) + if(bl_action.eq.'RW') then + action = 'RW' ! reject wind + NCEPrc_w = (cp-1)*100 + RN ! wind RC range 901-934 + endif + endif + + endif + +C ************************************************************************* + + 2000 continue + +c ------------------------------------------- +c Translate actions into NCEP QUALITY MARKERS +c ------------------------------------------- + if(action.eq.'RR') then + l_badrpt = .true. + + elseif(action.eq.'DR') then + l_duprpt = .true. + + elseif(action.eq.'GV'.or.action.eq.'GT' .or. + + action.eq.'GM'.or.action.eq.'GW') then + NCEPqm = 1 ! good (RC already set) + + elseif(action.eq.'NU') then + NCEPqm = 2 ! neutral/not checked (RC already set) + + elseif(action.eq.'ND') then ! not defined + NCEPqm = 2 ! QM -> neutral + NCEPrc = 099 ! RC -> 099 - override any RCs already set + + print *, 'type: ',type + print *, 'overall_action: ',overall_action + print *, 'time_action: ',time_action + print *, 'lat/lon_action: ',lat_action,'/',lon_action + print *, 'pres_action: ',pres_action + print *, 'temp_action: ',temp_action + print *, 'moist_action: ',moist_action + print *, 'wdir_action: ',wdir_action + print *, 'wspd_action: ',wspd_action + print *, 'bl_action: ',bl_action + print *, 'c_qc: "',NRLQCstg,'"' + + elseif(action.eq.'RT'.or.action.eq.'RM'.or.action.eq.'RW') then + NCEPqm = 13 ! QM -> bad (RC already set) + + elseif(action.eq.'SM'.or.action.eq.'SW') then + NCEPqm = 3 ! QM -> suspect (RC already set) + + else + cp = 99 ! this is just a dummy statement + ! leave QM as is (IO,GR) + endif + +c ------------------------------------------------------------- +c Set QM, RC info into arrays to be returned to calling routine +c ------------------------------------------------------------- + if(type.eq.'t' .and. NCEPrc_t.ne.99999) then + NCEPrc = NCEPrc_t + elseif(type.eq.'q' .and. NCEPrc_q.ne.99999) then + NCEPrc = NCEPrc_q + elseif(type.eq.'w' .and. NCEPrc_w.ne.99999) then + NCEPrc = NCEPrc_w + endif + + return + + 999 continue + + write(*,*) '*** Warning! RN is out of range 1-34, here = ',RN + call w3tage('PREPOBS_PREPACQC') + call errexit(69) + + end