SUBROUTINE CORBC5(KFILDO,IP14,IP20,CCALL,DATA,XP,YP,XPL,YPL,LTAG, 1 QUALST,VRAD,LNDSEA,ELEV,LAPFG, 2 XLAPSE,ULAPSE,NSTA,NBASTA,LAPUDB, 3 TELL,TELH,ATEL,BTEL, 4 ILS,LNDWAT,WTWTL,WTLTW,WTAUG,LTAGPT, 5 IALGOR,ELCORR,IBKPN,BK,ELCORU,IFCOR,ICUB, 6 RWATO,RWATI,IVRAD,IALOC,ADIST,AELEV,ND13, 7 P,CORR,COUNT,NCOUNT,NWIND,NX,NY,MESH,MESHL, 8 U,V,WNDWT,WNDGRD, 9 TELEV,SEALND,NXE,NYE,XPE,YPE,MESHE,ORIENT, A HGTTHA,HGTTHB,NAREA, B LP,NPASS,NTYP,R,IOPT,JDATE,TITLE,N4P,MGUESS, C ISTOP,IER) C C JUNE 2004 GLAHN MOS-2000 C DERIVED FROM CORBCD C OCTOBER 2004 GLAHN QUALST( ) INSERTED IN CALL AND USED C IN CORRECTIONS C OCTOBER 2004 GLAHN INSERTED VARIABLES FOR FOR TERRAIN C OCTOBER 2004 GLAHN ADDED NELEV( ) TO CALL C OCTOBER 2004 GLAHN CHANGED NELEV( ) TO ELEV( ); INSERTED C ELEVATION CHECKS; REMOVED EMESH C OCTOBER 2004 GLAHN TOOK CARE OF DX = 0 AT 2254 C OCTOBER 2004 GLAHN MODIFIED FOR LAT/LON VICE POLE C OCTOBER 2004 GLAHN ADDED LNDSEA( ), LNDWAT( , ), ILS C NOVEMBER 2004 GLAHN MODIFIED COMPUTATION OF IXE AND JYE C NOVEMBER 2004 GLAHN ADDED IFIRST AND IER=0 AT BEGINNING; C CHANGED FLOAT(MESHE) TO 1 FOR DXLINE C DECEMBER 2004 GLAHN ADDED ELCORR( ), XLAPSE( , , ), C AA( , , , ), IBASE, IDIMTB, IDIM, C IBASE( ), ND1, ND13, ND14, ND15 AND C REMOVED IDIM IN CALL; IMPLEMENTED C HEIGHT THRESHOLDING C DECEMBER 2004 GLAHN IMPLEMENTED ELCORR AND LNDWAT C DECEMBER 2004 GLAHN INSERTED CHECK ON HGTTHB GE 20000 C DECEMBER 2004 GLAHN INSERTED SEALND(IX,JY).EQ.0. TEST228 C ABOVE DO 2282 LOOP C JANUARY 2005 GLAHN SUBSTITUTED ITRPSL FOR ITRP TO GET C ANALYSIS VALUE C JANUARY 2005 GLAHN CHANGED TEST ON IER AFTER ITRPSL CALL C JANUARY 2005 GLAHN TESTED FOR P(IX,JY)=9999 AT DO 237 C JANUARY 2005 GLAHN INSERTED IER=0 AT ISTOP=ISTOP+1 C JANUARY 2005 GLAHN ALLOWED TYPE 3 CORRECTION FOR WATER C POINT EVEN WHEN R GE 3 AND NCOUNT = 1 C FEBRUARY 2005 GLAHN MODIFIED ABOVE TO APPLY TO ONLY PASS 1 C FEBRUARY 2005 GLAHN ADDED LNDWAT = 2 FEATURE C FEBRUARY 2005 GLAHN ADDED R*50% FOR LP=1 AND LNDSEA( )=0 C FEBRUARY 2005 GLAHN COMMENTS; REMOVED SOME CHECKOUT PRINT C MARCH 2005 GLAHN BYPASSED CORRECTION LOOP WHEN IER FROM C ITRPSL = 196; REMOVED /D ON 222 PRINT C MARCH 2005 GLAHN ADDED NOSTM, TRSTL( ), TRSTU( ), C IDST( ), IDPARS( ) TO CALL C APRIL 2005 GLAHN CORRECTED COUNT( , ) TO NCOUNT( , ) FOR C TYPE 2 CORRECTION BETWEEN 241 AND 242 C APRIL 2005 GLAHN CHANGED R FOR WATER POINTS FROM 1.5 TO C 2. TIMES THE SPECIFIED R FOR PASS 1 C APRIL 2005 GLAHN REMOVED RESTRICTION OF LP = 1 TO GO TO C DOUBLE THE RADIUS FOR WATER POINTS C MAY 2005 GLAHN ELIMINATED STRATIFICATION FEATURE; C ADDED LAPSE CALCULATION ON THE FLY C MAY 2005 GLAHN CHANGED WAY LAPSE APPLIED C JUNE 2005 GLAHN BYPASSED ITRPSL UNLESS ELCORR = 0 OR C HGTTHB LT TOP C JUNE 2005 GLAHN CHANGED R*2 TO R*3 FOR WATER POINTS C JUNE 2005 GLAHN CHANGED R*3 TO R*3.2 FOR WATER POINTS C AUGUST 2005 GLAHN MODIFIED COMMENT ABOUT TYPE 2 C CORRECTION WHEN NCOUNT = 1: /D PRINT C AUGUST 2005 GLAHN MODIFIED USE OF LNDSEA( ) C AUGUST 2005 GLAHN MODIFIED CORRECTION WHEN XLAPSE = 0 C AUGUST 2005 GLAHN MODIFIED TO CALL ITRPSL BELOW 228 C SEPTEMBER 2005 GLAHN ADDED ELCUT AND ANOTHER CONDITION FOR C COMPUTING BB; CHANGED LOCATION OF C IF(QUALST(K).EQ.0.) GO TO 240; C MODIFIED FOR ELCORR NE 1; ELCUT=100 C ON 9/26/05 8:05 AM; BACK TO 0 9:45 C SEPTEMBER 2005 GLAHN ADDED BRKSQ; REMOVED SKIP OF ITRPSL C FOR CERTAIN CONDITIONS C SEPTEMBER 2005 GLAHN ADDED IUSEIW C OCTOBER 2005 GLAHN CHANGED BRKSQ FROM 25 TO 9 C OCTOBER 2005 GLAHN CHANGED R*3.2 TO R*3.5 FOR WATER C POINTS C OCTOBER 2005 GLAHN CHANGED BRKSQ FROM 9 TO 0 C OCTOBER 2005 GLAHN ADDED IBKPN AND BK( ) C NOVEMBER 2005 GLAHN ADDED LIMITX C NOVEMBER 2005 GLAHN MODIFIED ALGORITHM; ADDED LIMITX TO C CALL C JANUARY 2006 GLAHN REMOVED LIMITX C JANUARY 2006 GLAHN CORRECTED ALGORITHM; PULLED ELD= C JANUARY 2006 GLAHN ADDED ELCORU C JANUARY 2006 GLAHN MODIFIED ELEVATION ALGORITHM TO WEIGHT C CORRECTION BY DISTANCE C JANUARY 2006 GLAHN ADDED IALGOR, WT CALCULATED EARLIER C MARCH 2006 GLAHN ADDED IP14 AND ISTOP( ) TO CALL AND TO C CALL TO ITRPSL; ADDED N4P C APRIL 2006 GLAHN MADE NTYP = 3, R GE 3, NCOUNT = 1, C TYPE 3 FOR OCEAN APPLY TO INLAND WATER C JUNE 2006 GLAHN ADDED IBKPN = 99 CAPABILITY C JUNE 2006 GLAHN CORRECTED W TO WHT WHEN IBKPN = 0 BELOW C 228 C DECEMBER 2006 GLAHN ADDED MGUESS TO CALL; USE IN CORRECTION C MARCH 2007 GLAHN ADDED ILS=1 AS A REQUIREMENT TO USE C R*3.5 OVER WATER ABOVE 205 C JUNE 2007 GLAHN ADDED IBKPN = -2 AND +2 CAPABILITY C JUNE 2007 GLAHN ADDED RWATO AND RWATI C JUNE 2007 GLAHN REARRANGED CALL C JUNE 2007 GLAHN CORRECTED CHECK ON IBKPN AT 200 C AUGUST 2007 GLAHN ADDED VRAD(ND1), IVRAD C AUGUST 2007 GLAHN PUT SECTION 224 T0 227 INTO TRDIF; C ADDED RFACT( , ) C AUGUST 2007 GLAHN MODIFIED TO USE ONLY PASS 1 FOR OCEAN C AND INLAND WATER POINTS AT DO 240 C SEPTEMBER 2007 GLAHN ADDED CALLS TO ACTUAL BELOW 110, AND C ABOVE 222; MODIFIED COMPUTATION OF C RM999, RP001, RSQ TO INCLUDE RMESH C SEPTEMBER 2007 GLAHN REMOVED PASS 1 MOD; INSERTED TEST C TO NOT REDUCE WATER RADII C OCTOBER 2007 GLAHN ADDED USE OF VRAD( ) BASED ON IVRAD C NOVEMBER 2007 GLAHN ADDED ORIENT TO CALL AND TO HELP C CONTROL TYPE WHEN NCOUNT = 1 C DECEMBER 2007 GLAHN ADDED ISTOP(6) CAPABILITY C FEBRUARY 2008 GLAHN ADDED NAREA; COMMENTS C MARCH 2008 GLAHN SUBSTITUTED ITRPSX FOR ITRPSL C MARCH 2008 GLAHN DIFFERENTED ALASKA FOR OCEAN; C LIMITED LAST PASS CORRECTION C MARCH 2008 GLAHN ADDED IBKPN, ELCORR, ELCORU TO CALL C TO ITRPSX C MARCH 2008 GLAHN ADDED COMMA TO FORMAT 2045 FOR IBM C MAY 2008 GLAHN ADDED LNDWAT = 2,3 CAPABILITY; C ELIMINATED IUSEIW C JULY 2008 GLAHN MODIFIED IALGOR = 3 ALGORITHM C SEPTEMBER 2008 GLAHN ADDED CHECKS ON LNDWAT EARLY IN C DO 240 LOOP C OCTOBER 2008 GLAHN REMOVED VESTIGES OF RFACT( , ); C REMOVED NDIM; R**2. MADE R**2 IN TWO C PLACES C OCTOBER 2008 GLAHN ADDED WTWTL, WTLTW; ADDED CHECK FOR C EFFICIENCY IF(MESH.EQ.MESHE) TWICE C MAY 2009 GLAHN USED NTYP=2 FOR PASS 4 FOR NCOUNT = 2 C JULY 2009 GLAHN CORRECTED SETTING OF WTLW BELOW C DO 237; ELIMINATED EARLY BYPASS C CHECKS AFTER DO 240 C SEPTEMBER 2009 GLAHN ADDED USE OF RWATO WTIH NAREA = 3 C AFTER 199; CHANGED IF(ELEDIF.GT.0.) C TO IF(ELEDIF.LT.0.) WHEN IBKPN = +2 C JANUARY 2010 GLAHN ADDED PREX4 AND LTAGPT( ) TO CALL C AND THEIR USE; PUT IN CHECKS FOR C DIVISION BY COUNT( , ) = 0 C MARCH 2010 GLAHN RAISED CHECK ON LNDWAT OUT OF LOOP; C CHECK TO BYPASS CORRECTIONS FOR AN C AUGMENTATION STATION WHEN PREX4 =0; C PUT WEIGHT WTA IN COUNT VICE WT C MARCH 2010 GLAHN CHANGED PREX4 TO WTAUG C ENERGIZED "IF(IAUG.EQ.1.AND.LTAGPT(K). C NE.0.AND.WTAUG.LT..001)GO TO 240" C JULY 2010 FAN/GLAHN INSERTED OPEN MP STATEMENTS IN C 3 PLACES; SPELL CHECK, COMMENTS C JULY 2010 GLAHN COPIED FROM YUN VERSION (7/19/10) C JULY 2010 GLAHN CORRECTED NOUNT TO NCOUNT(IX,JY) IN C TWO PLACES C OCTOBER 2010 GLAHN COMMENTS C JULY 2011 GLAHN MOVED IF LOOP OUT OF DO 240 LOOP C JULY 2011 GLAHN OPEN MP LOOP AT DO 240 VICE DO 238 C NOVEMBER 2011 GLAHN CHECK ON COUNT( , ) MOVED ABOVE 243 C DECEMBER 2011 GLAHN INCREASED I4 TO I5 FOR K IN 222 C MAY 2012 HUANG MOVED OPEN MP LOOP FROM 240 BACK TO C DO 238 BECAUSE OPEN MP LOOP AT 240 C CAUSES RACE CONDITION AND DOES NOT C PRODUCE IDENTICAL OUTPUT BETWEEN C DIFFERENT RUNS. C OCTOBER 2013 GLAHN CHANGED WTLW FOR INLAND WATER/LAND C POINT AFFECTING INLAND WATER AND LAND C JANUARY 2014 GLAHN ADDED NPASS TO CALL; CHANGED C LP.GE.4 TO LP.GE.NPASS IN TWO PLACES C AND REMOVED TWO REDUNDANT CHECKS C BELOW 2425 C JANUARY 2014 GLAHN CHANGED LP.GE.NPASS TO GE.NPASS+1 C (NEGATES THIS OPTION) C JANUARY 2014 GLAHN DIVISOR FOR NCOUNT( , ) = 2 TO C (NCOUNT( , )+COUNT( , )/2. C JANUARY 2014 GLAHN CHECK FOR NCOUNT( ,)/COUNT( , )>5 C LIMITED TO ALASKA C JUNE 2014 GLAHN ADDED 2ND INTERPOLATION WHEN C LNDSEA( ) = 6 AND AVERAGED C JUNE 2014 GLAHN ELIMINATED TID, C OMP_GET_NUM_THREADS,NTHREADS, AND C OMP_GET_THREAD_NUM C JULY 2014 GLAHN INTERPOLATION FOR TYPE 6 DONE TWICE C AND ONE CLOSEST TO DATUM USED. C DECEMBER 2014 GLAHN ADDED W3TAB PER JUDY IN ONE PLACE C DECEMBER 2014 GLAHN CORRECTED ERROR NAREA VICE NREA C BELOW 2425 C MAY 2015 GLAHN MODIFIED TO GIVE LESS WEIGHT IN C ANALYSIS TO STATIONS WITH C QUALST( ) < 1; ADDED IFULL( , ) C JUNE 2015 GLAHN ADDED ULAPSE( ), TELL, TELH, ATEL, C BTEL, FSTGS C JULY 2015 GLAHN ADDED IFCOR C JULY 2015 GLAHN ADDED ICUB C JULY 2015 GLAHN REMOVED ICUB=R**3 C OCTOBER 2015 GLAHN REMOVED ABS IN C "IF(ABS(ELEDIF).LT.TELL)THEN" C DECEMBER 2015 GLAHN ADDED DISTCU TO PARALLEL !$OMP C JANUARY 2016 GLAHN BYPASSED CUBIC DISTCU WITH ICUB C SEPTEMBER 2016 GLAHN ADDED THREE MORE CHECKS BELOW 2430 C ON COUNT(IX,JY)=0 BEFORE DIVIDING C DECEMBER 2018 GLAHN LTAGPT( ) = 4 IMPLEMENTED; C "LTAGPT(K).EQ.4" ADDED TO TEST JUST C AFTER DO 240 C APRIL 2019 GLAHN ADDED IF(NAREA.EQ.2.AND.LP.EQ.NPASS) C TO ACCOMMODATE EXACT FIT FOR ALASKA C LAST PASS; INSERTED MAX( ) TWO C PLACES TO KEEP WT NON-NEGATIVE C APRIL 2019 GLAHN INSERTED ELSEIF(LNDSEA(K).EQ.3)THEN C UNDER ELSEIF(LNDWAT.EQ.3)THEN C APRIL 2019 GLAHN EXCEPTION MADE FOR ALASKA BELOW 2425 C APRIL 2019 GLAHN CORRECTED COMMENT ABOUT NP C MAY 2019 GLAHN USED IBKPN = 0 IN ITRPSX ON LAST PASS C MAY 2019 GLAHN ADDED NBASTA TO CALL, DIAGNOSTIC 222 C JULY 2024 SHAFER ADDED CHECK ON VARIABLE DISTSQ TO C PREVENT POSSIBLE DIVISION BY ZERO C IN LATER CALCULATIONS. C C PURPOSE C TO DO THE CORRECTIONS FOR BCD5 IN U405A. THE QUALITY C VALUES IN QUALST( ) ARE APPLIED DIRECTLY TO THE CORRECTIONS C AS FRACTIONS OF THE FULL CORRECTION. THE WIND CORRECTIONS C USED IN SEA LEVEL PRESSURE (ONLY) ARE NOT AFFECTED. C OTHERWISE, WEIGHTS FOR WINDS WOULD HAVE TO BE ACCESSED C IN A CALLING ROUTINE AND CARRIED IN. THIS HAS THE EFFECT C THAT QUALITY OF WIND OBS DOES NOT VARY BY STATION FOR C SLP ANALYSIS. THE QUALITY OF WIND OBS DOES APPLY IN C WIND ANALYSIS IN BCDW5. ENTERED ONCE PER PASS. C C WHEN THE FIRST GUESS IS 9999 (MISSING) IT IS LEFT AND C CORRECTIONS NOT MADE. C C A BUNCH OF TESTS ON COUNT( , ) NE 0. INSERTED JANUARY 1, C 2010. EVIDENTLY HAD NOT CAUSED A PROBLEM. WITH THE C MODIFICATION OF WT TO ACCOUNT FOR FRACTION OF AUGMENTED C DATA, IT COULD BE ZERO IF THE FRACTION WAS SET TO ZERO. C NORMALLY THIS WOULD NOT BE DONE AND WOULD PROBABLY BE C AN ERROR. C C WHEN AUGMENTATION STATIONS ARE USED WITH A LESSER WEIGHT, C AND THAT WEIGHT IS ZERO, OR WHEN THE QUALITY WEIGHT OF C A STATION IS ZERO, THE CORRECTIONS TO GRIDPOINTS FOR C THAT STATION SHOULD NOT BE DONE. THE WEIGHTING AND C COUNTING BEING DONE MAY NOT BE A TRUE WEIGHTING, BUT IS C CLOSE. IT IS EXACT FOR WEIGHTS OF ZERO AND ONE, AND IS C REASONABLY CLOSE FOR OTHER WEIGHTS. THE SAME IS TRUE C FOR QUALITY WEIGHTS. C C WHEN A COMPUTED LAPSE IS USED, IT HAS TO BE USED ON C THE FIRST PASS SO THAT A GRIDPOINT AFFECTED ONLY ON C THE FIRST PASS WILL HAVE A LAPSE APPLIED. ON C SUBSEQUENT PASSES, THE LAPSE USED FOR A PARTICULAR C STATION HAS TO BE REMOVED (AS WELL AS IT CAN BE) BEFORE C APPLYING IT ON THE CURRENT PASS, OR IT WILL BE APPLIED C MULTIPLE TIMES AND BE EXCESSIVE. C C THE MODS MADE MAY 15, 2015 TO MAKE A TYPE 2 CORRECTION C VICE TYPE 3 WHEN THERE IS NO BASE VALUE AFFECTING C THE GRIDPOINT AND THE CORRECTION IS NEGATIVE IS FOR C WIND SPEED. IT IS ASSUMED THERE IS NO VARIABLE EXCEPT C MESONET WINDS THAT HAVE A REDUCED WEIGHT. C C THE ABOVE WAS MODIFIED BY USE OF IFCOR SO THE CORRECTION C SWITCH DOES NOT DEPEND ON A REDUCED WEIGHT, WHICH MIGHT C BE THE CASE WITH MESONET TEMP FOR MOS. IFCOR IS READ C AS PART OF NTYPE IN U405A.CN. C C THE ICUB FEATURE WAS ADDED TO SWITCH TO A DIFFERENT C WEIGHTING ALGORITHM. C C WHEN LTAGPT(K) = 4, INDICATING BOGUS FROM SUBROUTINE C BOGUSG, CONSTANT RADII (FROM U405A.CN) ARE NOT USED C AFTER SWITCH (IVRAD NOW = 0). THIS IS TO KEEP RADII C OVER OCEAN AT VARIABLE SET VALUES NEAR 1. C C OPEN MP ISTOP MAY BE CONFLICTED, BUT WILL ONLY RESULT IN BEING C INCREMENTED LESS THAN IT SHOULD. THIS IS NOT C DAMAGING, EXCEPT IN DIAGNOSTICS. IT WOULD BE C VERY UNUSUAL FOR THIS TO HAPPEN. C IER IS DECLARED PRIVATE, BECAUSE IT COULD AFFECT C PROGRAM FLOW IF CONFLICTED. C IFIRST COULD BE CONFLICTED, BUT IT WOULD BE EXTREMELY C RARE AND WOULD ONLY AFFECT A DIAGNOSTIC. C C FATAL ERRORS, IER: C NONE. C C DATA SET USE C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) C IP14 - UNIT NUMBER FOR LISTING COMPUTED LAPSE C RATES AND PROBLEMS WITH LAPSE RATES. (OUTPUT) C IP20 - UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS, DATA VALUES, LTAGS, UNSMOOTHED C ANALYSIS (INTERPOLATED) VALUES, AND DIFFERENCES C BETWEEN THE DATA AND THE UNSMOOTHED ANALYSIS C VALUES FOR ONLY THE SUBSETTED AREA FOR C GRIDPRINTING. IF IOPT(1) = 0, MEANING THERE C IS NO SUBSETTED AREA, IP20 IS NOT ACTIVATED. C (OUTPUT) C C VARIABLES C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) C IP14 = UNIT NUMBER FOR LISTING COMPUTED LAPSE C RATES AND PROBLEMS WITH LAPSE RATES. (INPUT) C IP20 = UNIT NUMBER FOR LISTING OF STATIONS, THEIR C X/Y POSITIONS, DATA VALUES, LTAGS, UNSMOOTHED C ANALYSIS (INTERPOLATED) VALUES, AND DIFFERENCES C BETWEEN THE DATA AND THE UNSMOOTHED ANALYSIS C VALUES FOR ONLY THE SUBSETTED AREA FOR C GRIDPRINTING. IF IOPT(1) = 0, MEANING THERE C IS NO SUBSETTED AREA, IP20 IS NOT ACTIVATED. C (OUTPUT) C CCALL(J) = STATION CALL LETTERS (J=1,NSTA). (CHARACTER*8) C (INPUT) C DATA(J) = DATA TO ANALYZE (J=1,NSTA). (INPUT) C XP(K) = THE X POSITION FOR STATION K (K=1,NSTA) ON C THE ANALYSIS GRID AREA AT THE CURRENT GRID MESH C LENGTH XMESH. (INPUT/OUTPUT) C YP(K) = THE Y POSITION FOR STATION K (K=1,NSTA) ON C THE ANALYSIS GRID AREA AT THE CURRENT GRID MESH C LENGTH XMESH. (INPUT/OUTPUT) C XPL(K) = THE X POSITION FOR STATION K (K=1,NSTA) ON C THE ANALYSIS GRID AREA AT THE MESH LENGTH C MESHB. (INPUT) C YPL(K) = THE Y POSITION FOR STATION K (K=1,NSTA) ON C THE ANALYSIS GRID AREA AT THE MESH LENGTH C MESHB. (INPUT) C LTAG(K) = DENOTES USE OF DATA CORRESPONDING TO CCALL(K). C +4 = TOSSED IN A PREVIOUS OBS RUN AND C MAINTAINED DOWNSTREAM. C +2 = NOT USED FOR ANY PURPOSE. FLTAG SETS C A VALUE +2 WHEN THE STATION LOCATION C IS MISSING. C +1 = PERMANENTLY DISCARDED FOR THE VARIABLE C BEING ANALYZED. INCLUDES DATA FAR C OUTSIDE THE GRID, AS DEFINED BY RMAX C 0 = USE ON CURRENT PASS THROUGH DATA IN BCD. C -1 = ON RETURN FROM BCD, THE DATUM WAS NOT C USED ON THE LAST PASS. C -3 = ACCEPT THIS STATION ON EVERY PASS IN BCD. C (NOT IMPLEMENTED IN U405A). C (INPUT/OUTPUT) C QUALST(K) = THE QUALITY WEIGHTS TO APPLY FOR THIS VARIABLE C (K=1,KSTA). (INPUT) C LAPFG = 0 COMPUTE LAPSE FROM DATA C 1 COMPUTE LAPSE FROM FIRST GUESS. C 2 COMPUTE LAPSE FROM UPPER AIR DATA. C 3 COMPUTE LAPSE FROM SURFACE AND UPPER AIR DATA. C 4 USE LAPSE FROM PREVIOUS VARIABLE (E.G., TOTAL C WIND FROM WIND SPEED) C 5 A COMBINATION OF 0 AND 3 ABOVE. C NOTE IT IS COMBINED WITH LAPUDB IN READING. C (INTERNAL) C XLAPSE(K) = CALCULATED LAPSE RATE IN UNITS OF THE VARIABLE C BEING ANALYZED PER M (K=1,KSTA). THIS IS THE C LAPSE TO USE, UNLESS LAPFG = 5, IN WHICH CASE C THIS IS COMPUTED FROM SURFACE DATA AND ULAPSE( ) C IS CALCULATED FROM SURFACE AND UA DATA, AND C THEY ARE TO BE COMBINED DEPENDING ON DISTANCE C IN ELEVATION BETWEEN THE STATION AND THE C GRIDPOINT BEING CORRECTED. (INPUT). C ULAPSE(K) = LAPSE CALCULATED FROM SFC AND UA DATA (K=1,NSTA). C (INPUT) C LAPUDB = 0 ANY LAPSE WILL BE USED BOTH UP AND DOWN C 1 LAPSE WILL BE USED ONLY IN AN UPWARD MANNER C 2 LAPSE WILL BE USED ONLY IN A DOWNWARD MANNER C THIS WAS ADDED TO KEEP WIND SPEED FROM BEING C VERY LOW IN VALLEYS. (INPUT) C TELL = LOWER THRESHOLD FOR WT TO BE USED WITH XLAPSE C IN CORBC5. WHEN ELELAP IS LT TELL, XLAPSE IS C USED. CALCULATED IN CLAPSE. (INPUT) C TELH = HIGHER THRESHOLD FOR WT. WHEN ELEDIF IS GT C TELH, ULAPSE IS USED. (SEE TELL ABOVE) C (INPUT) C ATEL = CONSTANT FOR THE LINE. WHEN ELEDIF IS BETWEEN C TELL AND TELH, LINEAR INTERPOLATION IS USED. C (SEE TELL ABOVE) (INPUT) C BTEL = COEFFICIENT FOR THE LINE. (SEE ABOVE) (INPUT) C VRAD(K) = RADII OF INFLUENCE USED AS OVERRIDE TO U405.CN C CONTROL FILE FOR THIS PASS (K=1,NSTA). (INPUT) C LNDSEA(K) = LAND/SEA INFLUENCE FLAG FOR EACH STATION C (K=1,ND1). C 0 = WILL BE USED FOR ONLY OCEAN WATER (=0) C GRIDPOINTS. C 3 = WILL BE USED FOR ONLY INLAND WATER (=3) C GRIDPOINTS. C 6 = WILL BE USED FOR BOTH INLAND WATER (=3) C AND LAND (=9) GRIDPOINTS. C 9 = WILL BE USED FOR ONLY LAND (=9) GRIDPOINTS. C (INPUT) C ELEV(K) = ELEVATIONS OF STATIONS IN METERS (K=1,NSTA). C NSTA = NUMBER OF STATIONS FOR WHICH DATA ARE AVAILABLE. C (INPUT) C ILS = FLAG FOR HOW THE SEA/LAND CORRECTIONS ARE C GOING TO BE MADE: C 1 = LAND/WATER TREATED SEPARATELY; C 0 = OTHERWISE. THIS OPERATES IN TANDEM WITH C LNDWAT( , ), BUT ILS CAN OVERRIDE FOR EASY CHANGE. C (INPUT) C LNDWAT = FLAG FOR THIS PASS AND FIRST GUESS OPTION TO C DETERMINE HOW THE SEA/LAND CORRECTIONS WILL BE C MADE. C 0 = THE WTWTL AND WTLTW ARE NOT USED, LAND POINTS C AFFECT LAND, OCEAN POINTS AFFECT OCEAN, C INLAND WATER AFFECTS INLAND WATER, AND A C POINT DESIGNATED AS BOTH INLAND WATER AND C LAND AFFECTS. BOTH. ILS = 1 AND LNDWAT = 0 C WILL PRODUCE THE SAME RESULT AS ILS = 1, C LNDWAT = 1 AND WTLTW AND WTWTL = 0. C WILL BE USED FOR ALL POINTS. C 1 = USE THE DIFFERENCE FEATURE. SEE LNDSEA( ). C 2 = OCEAN POINTS WILL NOT BE CHANGED. C 3 = NEITHER OCEAN NOR INLAND WATER POINTS WILL C BE CHANGED. C (INPUT) C WTWTL = WEIGHTING FACTOR TO USE FOR OCEAN OR INLAND WATER C POINTS OVER LAND WHEN ILS = 1. OCEAN POINTS C NEVER AFFECT INLAND WATER. (INPUT) C WTLTW = WEIGHTING FACTOR TO USE FOR LAND POINTS OVER C OCEAN AND INLAND WATER WHEN ILS = 1. (INPUT) C WTAUG = THE FRACTION OF THE AUGMENTED DATA TO USE C IN THE ANALYSIS (WITH AUGMT3 ONLY). WHEN THIS C IS 1., NO DISTINCTION IS MADE IN THE DATA; C WHEN WTAUG = 0., ONLY THE BASE (REAL) DATA C ARE USED. WTAUG INITIALIZED TO 1. IN U405A, C SO NORMALLY IT IS 1. (INPUT) C LTAGPT(K) = FOR STATION K (K=1NSTA), C 1 = AUGMENTED DATA (FIRST PASS) C 2 = AUGMENTED DATA (2ND PASS) C 3 = BOGUS DATA FROM SUBROUTINE BOGUS C 4 = MODEL FORECAST, BOGUS FROM SUBROUTINE BOGUSG C 0 = EVERYTHING ELSE C (INPUT) C IALGOR(J) = TYPE OF CORRECTION ALGORITHM TO APPLY FOR THIS C PASS. C 1 = NORMAL TERRAIN C 2 = DISTANCE WEIGHTED TERRAIN C 3 = NON LINEAR CORRECTION C (INPUT) C ELCORR = FRACTION OF THE ELEVATION CORRECTION TO C APPLY FOR THIS PASS. (INPUT) C IBKPN = FLAG TO INDICATE WHETHER TO APPLY BK( , ) TO C POSITIVE OR NEGATIVE LAPSE RATES: C 0 = DON'T OPERATE BK( , ) (ALL LAPSES USED), C +1 = APPLY TO POSITIVE LAPSES (POSITIVE IS ODD C FOR TEMPERATURE), C +2 = APPLY TO POSITIVE LAPSES, BUT DON'T USE C LAPSE AT ALL WHEN ELEDIF LT 0 (THEY ONLY C OPERATE UPWARD), C -1 = APPLY TO NEGATIVE LAPSES (NEGATIVE IS ODD C FOR SNOW), AND C -2 = APPLY TO NEGATIVE LAPSES, BUT DON'T USE C LAPSE AT ALL WHEN ELEDIF LT 0 (THEY ONLY C OPERATE UPWARD). C 99 = DON'T COMPUTE OR USE LAPSE RATES. C (LAPSE RATES WILL ALSO NOT BE USED WHEN KFILLP C IS NOT PROVIDED AND WHEN ELCORR( ) FOR ALL C PASSES = 0.) C (INPUT) C BK = THE MAXIMUM RADII IN GRIDPOINTS FOR WHICH C THE LAPSE RATES INDICATED BY IBKPN ARE USED. C (INTERNAL) C ELCORU = FRACTION OF THE ELEVATION CORRECTION TO C APPLY FOR THIS PASS FOR THE "UNUSUAL" LAPSE RATE C (THE ONE WITH THE SIGN SPECIFIED IN IBKPN. C (INPUT) C RWATO = FACTOR BY WHICH TO INCREASE THE RADIUS FOR C OCEAN WATER POINTS FOR THIS PASS WHEN IVRAD = 0. C (INPUT) C RWATI = FACTOR BY WHICH TO INCREASE THE RADIUS FOR C INLAND WATER POINTS FOR THIS PASS WHEN IVRAD = 0. C (INPUT) C IVRAD = CONTROLS HOW VRAD( ) AND THE RADII R( , ) C ARE USED. (INPUT) C 0 = USE R( ) NORMALLY FROM U405A.CN FILE. C 1 = USE VRAD( ) OVERRIDE. C IALOC = LOCATIONS IN CCALL( ) OF THE PAIRED STATIONS C (J=1,ND13), NOALOC(K) VALUES FOR EACH STATION K C (K=1,LSTA). NOT ACTUALLY USED. C ADIST(J) = DISTANCES OF BASE STATION OF THE PAIRED STATIONS C (J=1,ND13), NOALOC(K) VALUES FOR EACH STATION K. C AELEV(J) = ELEVATION DIFFERENCES OF BASE STATION OF THE C PAIRED STATIONS (J=1,ND13), NOALOC(K) VALUES C FOR EACH STATION K. C ND13 = MAXIMUM TOTAL PAIRS OF STATIONS. DIMENSION OF C IALOC( ), ADIST( ), AND AELEV( ). C P(IX,JY) = FIELD HOLDING FIRST GUESS AND ANALYSIS C (IX=1,NX) (JY=1,NY). (INPUT/OUTPUT) C CORR(IX,JY) = CORRECTION FOR GRIDPOINT IX,JY C (IX=1,NX) (JY=1,NY). (INTERNAL) C COUNT(IX,JY) = SUM OF WEIGHTS FOR GRIDPOINT IX,JY WHEN TYPE 3 C CORRECTION BEING MADE (IX=1,NX) (JY=1,NY). C (INTERNAL) C NCOUNT(IX,JY) = COUNT OF STATIONS CORRECTING GRIDPOINT IX,JY C (IX=1,NX) (JY=1,NY), NOT COUNTING WIND C CORRECTIONS. (INTERNAL) C NWIND(IX,JY) = COUNT OF STATIONS CORRECTING GRIDPOINT IX,JY C (IX=1,NX) (JY=1,NY) WITH WINDS. (INTERNAL) C NX = NUMBER OF GRIDPOINTS IN THE XI (LEFT TO RIGHT) C DIRECTION. (INPUT) C NY = NUMBER OF GRIDPOINTS IN THE YJ (BOTTOM TO TOP) C DIRECTION. (INPUT) C MESH = THE NOMINAL MESH LENGTH OF THE CURRENT GRID. C (INPUT) C MESHL = NOMINAL MESH LENGTH OF QUALITY CONTROL C (SUBSETTED) GRID FOR CONTINUOUS VARIABLES. C (INPUT) C U(K) = THE FACTOR TO USE IN CONVERTING U-WINDS C TO CHANGE IN MB PER MESH LENGTH (K=1,NSTA). C U(K) HAS BEEN SET TO 9999 FOR OBS C TOSSED BY U405B AS WELL AS WIND SPEEDS LT C WNDTHR. (INPUT) C V(K) = SAME AS U(K) EXCEPT FOR V-WINDS. (INPUT) C WNDWT = WEIGHT TO APPLY TO WIND OBS CORRECTIONS C RELATIVE TO PRESSURE CORRECTIONS FOR THIS PASS. C THIS WILL BE ZERO FOR ALL EXCEPT PRESSURE C ANALYSIS. (INPUT) C WNDGRD = PARAMETER FOR CONVERTING WIND SPEED TO SLP C GRADIENTS. (INPUT) C IFCOR = FLAG FOR CORRECTIONS: C 0 = IFULL( , ) IS NOT USED IN CORRECTIONS, C 1 = IFULL( , ) USED FOR + OR - CORRECTIONS, C 2 = IFULL( , ) USED TO EMPHASIZE HIGH WINDS. C THIS IS FOR WHEN MESONET OR OTHER DATA WITH C LESS RELIABILITY THAN METAR ARE TO NOT CARRY C AS MUCH WEIGHT. (INPUT) C ICUB = = 0, USE WT=(R**2-DIST**2)/(R**2+DIST**2) C = 1, USE WT=[(R**3-DIST**3)/(R**3-DIST**3)]**2 C (INPUT) C TELEV(IX,JY) = THE TERRAIN ELEVATION FROM THE MOS-2000 EXTERNAL C RANDOM ACCESS FILE IN METERS (IX=1,NXE) C (JY=1,NYE). (INPUT) C SEALND(J) = THE LAND/SEA MASK (J=1,NXE*NYE) AT NOMINAL C MESHLENGTH MESHE. C 0 = OCEAN WATER GRIDPOINTS; C 3 = INLAND WATER GRIDPOINTS. C 9 = LAND GRIDPOINTS. C (INPUT) C NXE = X-EXTENT OF TELEV( , ) AND SEALND( , ) AT MESH C LENGTH MESHE. (INPUT) C NYE = Y-EXTENT OF TELEV( , ) AND SEALND( , ) AT MESH C LENGTH MESHE. (INPUT) C XPE(K) = THE X POSITION FOR STATION K (K=1,NSTA) ON C THE ELEVATION AND SEA/LAND MASK GRIDS AT THE C GRID MESH LENGTH MESHE. (INPUT) C YPE(K) = THE Y POSITION FOR STATION K (K=1,NSTA) ON C THE ELEVATION AND SEA/LAND MASK GRIDS AT THE C GRID MESH LENGTH MESHE. (INPUT) C MESHE = THE NOMINAL MESH LENGTH OF THE TERRAIN GRID. C IT IS MANDATORY THE GRID AVAILABLE IS OF THIS C MESH SIZE AND COVER THE SAME AREA SPECIFIED C BY NXL BY NYL, EVEN IF MESHE IS NOT EQUAL C TO MESHB. (INPUT) C HGTTHA = ELEVATION DIFFERENCE IN M BETWEEN A STATION C AND A GRIDPOINT WHICH MUST NOT BE EXCEEDED C FOR THE STATION TO INFLUENCE THE GRIDPOINT. C (INPUT) C HGTTHB = ELEVATION DIFFERENCE IN M BETWEEN A STATION C AND ANY (INTERPOLATED) POINT ON THE ELEVATION C GRID BETWEEN THE STATION AND THE GRIDPOINT C WHICH MUST NOT BE EXCEEDED FOR THE STATION C TO INFLUENCE THE GRIDPOINT. (INPUT) C NAREA = THE AREA OVER WHICH THE ANALYSIS IS MADE: C 1 = CONUS, C 2 = ALASKA, C 3 = HAWAII, C 4 = PUERTO RICO. C LP = PASS NUMBER. (INPUT) C NPASS = NUMBER OF PASSES TO PERFORM FOR VARIABLE. C (INPUT) C NTYP = TYPE OF CORRECTION FOR THIS PASS LP. C 0 MEANS SKIP THIS PASS C 1 MEANS W = 1 C 2 MEANS W = (R**2 - D**2)/(R**2 + D**2) C 3 MEANS SAME AS 2 EXCEPT SUM OF WEIGHTS IN C DENOMINATOR. (INPUT) C R = RADIUS OF INFLUENCE FOR THIS PASS LP IN GRID C UNITS. THE MESH LENGTH MESH WILL REFER TO C THAT. NOTE THAT THE ACTUAL DISTANCE C DEPENDS ON MESH. THIS IS THE VALUE IN THE C U405A.CN FILE, NOT THE VARIABLE RADIUS, IF C THAT IS USED. (INPUT) C IOPT(J) = SUBSETTING VALUES USED IN GRIDPRINTING (J=1,8). C WHEN IOPT(1) = 0, SUBSETTING IS NOT DONE, C STATISTICS ARE NOT CALCULATED, AND IP20 IS NOT C USED. IOPT( ) IS IN RELATION TO THE SUBSETTED C AREA MESH LENGTH MESHL. (INPUT) C JDATE(J) = NDATE PARSED INTO ITS 4 COMPONENTS: C J=1 IS YYYY C J=2 IS MM C J=3 IS DD C J=4 IS HH C (INPUT) C TITLE = 40-CHARACTER TITLE FOR VARIABLE. (CHARACTER*40) C (INPUT) C N4P = 4 INDICATES THE SURROUNDING 4 POINTS WILL BE C CHECKED WHEN TRYING TO FIND A GRIDPOINT OF C THE SAME TYPE AS THE DATUM AND INTERPOLATION C CAN'T BE DONE. CURRENTLY, THIS IS ALWAYS C DONE (DOES NOT REQUIRE N4P=4). C 12 SAME AS ABOVE, EXCEPT 12 ADDITIONAL POINTS C WILL BE CHECKED WHEN NONE OF THE 4 POINTS C ARE OF THE CORRECT TYPE. C N4P IS OPERATIVE ONLY WHEN THE SURROUNDING C 4 POINTS ARE OF MIXED TYPE. (INPUT) C MGUESS = THE TYPE OF FIRST GUESS ACTUALLY USED. C 1 = CONSTANT. C 2 = PRIMARY GRID (E.G., A MOS FORECAST). C 3 = ALTERNATE GRID. C 4 = AVERAGE OF OBSERVATIONS. C (INPUT) C ISTOP(J) = ISTOP(1)--IS INCREMENTED BY 1 EACH TIME AN ERROR C OCCURS. C ISTOP(2)--IS INCREMENTED WHEN THERE ARE C FEW DATA (200) FOR AN ANALYSIS. C ISTOP(3)--IS INCREMENTED WHEN A DATA RECORD C COULD NOT BE FOUND. C ISTOP(4)--IS INCREMENTED WHEN A LAPSE RATE COULD C NOT BE COMPUTED OR HAS TOO FEW CASES C TO BE USED. C ISTOP(5)--IS INCREMENTED WHEN NO NON-MISSING C GRIDPOINT AROUND THE DATA POINT IS C OF THE SAME TYPE. C ISTOP(6)--IS INCREMENTED WHEN THERE IS A PROBLEM C WITH MAKING BOGUS STATIONS. C (INPUT/OUTPUT) C IER = ERROR RETURN. C 0 = GOOD RETURN. C 777 = FATAL ERROR. C (OUTPUT) C RSQ = RADIUS OF INFLUENCE SQUARED FOR THE PASS C BEING DONE. (INTERNAL) C JB, JE, LB, LE = LOOP LIMITS FOR DETERMINING GRID POINT C CORRECTION FOR A DATUM. (INTERNAL) C DISTSQ = DISTANCE (IN GRID UNITS) SQUARED BETWEEN A C STATION AND A GRID POINT = DIST**2. (INTERNAL) C WT = WEIGHT FOR CORRECTIONS FOR BASE STATIONS AND C COUNTS. (INTERNAL) C WTA = WEIGHT FOR NON BASE STATIONS( , ). (INTERNAL) C ELEDIF = GRIDPOINT ELEVATION - STATION ELEVATION IN M. C (INTERNAL) C RM999R = HELPS DETERMINE THE NORMAL BEGINNING SEARCH C LIMIT. (INTERNAL) C RP001R = HELPS DETERMINE THE NORMAL ENDING SEARCH C LIMIT. (INTERNAL) C RM999P = SAME AS RM999R, EXCEPT EXTENDS THE LIMIT R BY C 50 PERCENT. USED FOR PASS 1 FOR WATER STATION C POINTS. (INTERNAL) C RM001P = SAME AS RM001R, EXCEPT EXTENDS THE LIMIT R BY C 50 PERCENT. USED FOR PASS 1 FOR WATER STATION C POINTS. (INTERNAL) C TOP = VALUE WHICH ESSENTIALLY DISABLES THE MAX C ELEVATION CHECKS HGTTHA AND HGTTHB. (INTERNAL) C RSQP = INCREASES THE RADIUS OF INFLUENCE R BY SOME C FACTOR FOR WATER POINTS. CURRENTLY, THIS IS C R*3.5 TO ACCOMMODATE ONLY ONE DEW POINT IN THE C PACIFIC ALONG THE NORTH COAST. (INTERNAL) C RMESH = RATIO OF MESH TO MESHE. (INTERNAL) C ELCUT = THE ELEVATION DIFFERENCE IN M BETWEEN THE C STATION AND GRIDPOINT BELOW WHICH THE ELEVATION C CORRECTION IS NOT USED. (INTERNAL) C BRKSQ = THE DISTANCE SQUARED IN GRID LENGTHS AT WHICH A C WEIGHTED "UNUSUAL"HEIGHT GRADIENT GOES TO ZERO C (THIS IS FOR TEMPERATURE AND DEW POINT--WILL C HAVE TO BE PART OF CONTROL FILE U405AXXXXXX.CN. C (INTERNAL) C WTLW = FINAL WEIGHTING FACTOR DERIVED FROM THE WTLTW C AND WTWTL. (INTERNAL) C F = FACTOR BY WHICH CORRECTION IS APPLIED TO POINTS C ADJACENT TO MINIMUM. THIS IS COMPUTED IN C WNDCOR AND IS USED ONLY IN SEA LEVEL PRESSURE C ANALYSIS. (INTERNAL) C IFULL(IX,JY) = INCREMENTED BY 1 WHEN THE CORRECTION IS A BASE C VALUE (IX=1,NX) (JY=1,NY). THE RATIO C IFULL(IX,JY)/NCOUNT(IX,JY) IS THE PROPORTION OF C BASE VALUES CONTRIBUTING TO THE CORRECTION. C A BASE STATION IS INDICATED BY IQUAL( ) = 1. C (THIS WAS ADDED FOR WIND SPEED WHERE THERE ARE C ABOUT 5 TIMES AS MANY MESONET SITES AS METAR, C AND THEY HAVE A WEIGHT OF 0.212.) (INTERNAL) C TLAPSE = THE COMBINED LAPSE FOR STATION K AS A C COMBINATION OF XLAPSE(K) AND ULAPSE(K). C (INTERNAL) C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES CALLED C ITRPSX, WNDCOR, ACTUAL, TERDIF, TIMPR C CHARACTER*8 CCALL(NSTA),CK CHARACTER*40 TITLE C DIMENSION XP(NSTA),YP(NSTA),XPL(NSTA),YPL(NSTA), 1 DATA(NSTA),LTAG(NSTA),U(NSTA),V(NSTA), 2 QUALST(NSTA),XLAPSE(NSTA),VRAD(NSTA), 3 LNDSEA(NSTA),ELEV(NSTA),XPE(NSTA),YPE(NSTA), 4 LTAGPT(NSTA),ULAPSE(NSTA) DIMENSION P(NX,NY),CORR(NX,NY),COUNT(NX,NY),NCOUNT(NX,NY), 1 NWIND(NX,NY) DIMENSION IFULL(NX,NY) C IFULL( , ) IS AN AUTOMATIC ARRAY. DIMENSION TELEV(NXE,NYE),SEALND(NXE,NYE) DIMENSION IALOC(ND13),ADIST(ND13),AELEV(ND13) DIMENSION IOPT(8),JDATE(4),ISTOP(6) C DATA TOP/20000./ DATA ELCUT/0./ C CALL TIMPR(KFILDO,KFILDO,'START CORBC5 ') C IER=0 IFIRST=0 D WRITE(KFILDO,100)NSTA D100 FORMAT(/' IN CORBC5 AT 100--NSTA',I10) C CCC WRITE(KFILDO,101)(K,IVRAD,CCALL(K),DATA(K),LTAG(K),LTAGPT(K), CCC 1 QUALST(K),K=1,NSTA) CCC 101 FORMAT(' AT 101(K,IVRAD,CCALL(K),DATA(K),LTAG(K),LTAGPT(K),', CCC 1 'QUALST(K),K=1,NSTA)',I6,I2,1X,A8,F8.2,2I6,F15.3) C****************************************************************** CCCC WRITE(KFILDO,1080)(K,CCALL(K),RWATO,VRAD(K),K=568,570) CCCC 1080 FORMAT(/' AT 1080--(K,CCALL(K),RWATO,VRAD(K)K=568,570)',/ CCCC 1 (I8,2X,A8,2F10.3)) C****************************************************************** C C SAFETY CHECK ON LNDWAT. C IF(LNDWAT.LT.0.OR.LNDWAT.GT.3)THEN WRITE(KFILDO,110)LNDWAT 110 FORMAT(/' ****LNDWAT =',I4,' NOT EQUAL TO 0, 1, 2, OR 3.', 1 ' FATAL ERROR AT 110 IN CORBC5.') IER=777 GO TO 500 ENDIF C IF(MESH.EQ.MESHE)THEN RMESH=1. C RMESH IS THE RATIO OF THE MESH LENGTH OF THE ANALYSIS GRID C TO THE TERRAIN GRID. ELSE C MESH AND MESHE MAY NOT BE DIFFERENT BY AN EXACT C FACTOR OF 2 FOR SMALL GRIDLENGTHS. CALL ACTUAL C TO GET VALUES THAT CAN BE USED TO COMPUTE RATIO. C SINCE MESH USUALLY EQUALS MESHE, THESE CALLS C WILL BE RARE. C NPROJ=5 C SINCE THE 3RD ARGUMENT WILL NOT BE USED, C THE PROJECTION WILL NOT MATTER. USE OF 5 C IS ARBITRARY; IT COULD BE 3, 5, OR 7. C CALL ACTUAL(KFILDO,MESH,TRASH,BMESH,NPROJ,IER) C IF(IER.NE.0)THEN C ACTUAL WILL HAVE PRODUCED A DIAGNOSTIC. ISTOP(1)=ISTOP(1)+1 IER=777 GO TO 500 ENDIF CALL ACTUAL(KFILDO,MESHE,TRASH,EMESH,NPROJ,IER) C IF(IER.NE.0)THEN C ACTUAL WILL HAVE PRODUCED A DIAGNOSTIC. ISTOP(1)=ISTOP(1)+1 IER=777 GO TO 500 ENDIF C RMESH=BMESH/EMESH C RMESH IS THE RATIO OF THE MESH LENGTH OF THE ANALYSIS GRID C TO THE TERRAIN GRID. ENDIF C C INITIALIZE ARRAYS. C C***D WRITE(KFILDO,115)(K,CCALL(K),XP(K),YP(K),XPE(K),YPE(K),K=1,NSTA) C***D115 FORMAT(/' POSITIONS OF STATIONS ON CURRENT GRID AND ON TERRAIN',/ C***D 1 (' ',I6,2X,A8,2X,4F10.4)) C DO 199 JY=1,NY DO 198 IX=1,NX CORR(IX,JY)=0. COUNT(IX,JY)=0. NCOUNT(IX,JY)=0 NWIND(IX,JY)=0 IFULL(IX,JY)=0 198 CONTINUE 199 CONTINUE C C THE VALUES BELOW DEPEND ON R. IF THE RADIUS VARIES BY C STATION, THEY ARE SET WITHIN THE STATION LOOP BELOW. C IF(IVRAD.EQ.0)THEN RSQR=R**2 RM999R=R-.999 RP001R=R+.001 RM99WO=RWATO*R-.999 RM99WI=RWATI*R-.999 RP00WO=RWATO*R+.001 RP00WI=RWATI*R+.001 RSQRWO=(RWATO*R)**2 RSQRWI=(RWATI*R)**2 RCUBWO=(RWATO*R)**3 RCUBWI=(RWATI*R)**3 ENDIF C C********************* C ADDED FOR HAWAII 9/12/09. MAY BE APPROPRIATE FOR PUERTO RICO C AND GUAM. C IF(NAREA.EQ.3)THEN RSQRWO=(RWATO*R)**2 RCUBWO=(RWATO*R)**3 ENDIF C C********************* C C CHECK FOR LEGITIMATE VALUE OF IBKPN = 0, +1, +2, -1, -2, OR 99. C IF(IBKPN.LT.-2.OR.IBKPN.GT.+2)THEN C IF(IBKPN.NE.99)THEN WRITE(KFILDO,200)IBKPN 200 FORMAT(/' *****IBKPN =',I3,' NOT ONE OF LEGITIMATE VALUES', 1 ' 0, +1, +2, -1, -2, OR 99. SET IT TO 0, WHICH', 2 ' DOES NOT RESTRICT USE OF LAPSE RATE.', 3 ' PROCEEDING.') ISTOP(1)=ISTOP(1)+1 IBKPN=0 ENDIF C ENDIF C BRKSQ=BK*BK C BRKSQ IS THE SQUARE OF BK TO USE IN WEIGHT. BRKCU=BK**3 C BRKCU IS THE CUBE OF BK TO USE IN WEIGHT WHEN ICUB = 1. C IF(IP20.NE.0.AND.IOPT(1).NE.0)THEN C THIS IS THE TITLE FOR THE LISTING AT STATEMENT 222. C IP20 IS FOR THE SUBSETTED AREA. IF IOPT(1) = 0, C THERE IS NO SUBSETTED AREA. CCC WRITE(IP20,202)(JDATE(J),J=1,4),LP,TITLE(1:16),MESH CCC 202 FORMAT(/' FOR DATE',I6,3I3.2,' STATIONS AFFECTING THE', CCC 1 ' SUBSETTED AREA FOR PASS NO.',I2,' FOR ',A16, CCC 2 ' AT NOMINAL MESH LENGTH =',I4/ CCC 3 ' THE ANALYSIS VALUES ARE INTERPOLATED FROM', CCC 4 ' THE UNSMOOTHED GRID. LOCATIONS ARE WITH', CCC 5 ' REFERENCE TO THE SUBSETTED AREA.'/ CCC 6 ' STATIONS WITH MISSING DATA ARE NOT LISTED.'/ CCC 7 ' NO. STATION RANGE OF IX RANGE OF JY', CCC 8 ' XPOS YPOS DATA VALUE ANALYSIS VALUE DIFF') C C IOPT( ) IS IN REGARD TO THE ANALYSIS GRID AT MESH LENGTH C MESH. THAT IS THE WAY THE GRIDPRINT WILL OCCUR. SET C LBL, ETC. TO AGREE FOR PRINTING. FOR OPERATIONS, IP20 C WOULD BE 0 AND THIS WOULD BE BYPASSED. C IF(MESH.EQ.MESHL)THEN RATIO=1. ELSE C MESH AND MESHL MAY NOT BE DIFFERENT BY AN EXACT C FACTOR OF 2 FOR SMALL GRIDLENGTHS. CALL ACTUAL C TO GET VALUES THAT CAN BE USED TO COMPUTE RATIO. C SINCE MESH USUALLY EQUALS MESHL, THESE CALLS C WILL BE RARE. NPROJ=5 C SINCE THE 3RD ARGUMENT WILL NOT BE USED, C THE PROJECTION WILL NOT MATTER. USE OF 5 C IS ARBITRARY; IT COULD BE 3, 5, OR 7. C CALL ACTUAL(KFILDO,MESH,TRASH,BMESH,NPROJ,IER) C IF(IER.NE.0)THEN C ACTUAL WILL HAVE PRODUCED A DIAGNOSTIC. ISTOP(1)=ISTOP(1)+1 IER=777 GO TO 500 ENDIF CALL ACTUAL(KFILDO,MESHL,TRASH,ELMESH,NPROJ,IER) C IF(IER.NE.0)THEN C ACTUAL WILL HAVE PRODUCED A DIAGNOSTIC. ISTOP(1)=ISTOP(1)+1 IER=777 GO TO 500 ENDIF C RATIO=BMESH/ELMESH ENDIF C ENDIF C D CALL TIMPR(KFILDO,KFILDO,'START NSTA LOOP 1 ') C C FOR EVERY STATION, FIND THE GRIDPOINTS TO CORRECT, AND C CORRECT THEM. C DO 240 K=1,NSTA C C IF THE RADIUS VARIES BY STATION, THEN VALUES NEED TO BE C SET HERE. IF NOT, THEY WERE SET ABOVE. C C**************************************************************** CCCC IF(K.GT.567.AND.K.LT.571)THEN CCCC WRITE(KFILDO,8762)K,CCALL(K),IVRAD,NAREA,LTAGPT(K), CCCC 1 LTAG(K),QUALST(K),WTAUG,NSTA CCCC 8762 FORMAT(' AT 8762--K,CCALL(K),IVRAD,NAREA,LTAGPT(K),', CCCC 1 'LTAG(K),QUALST(K),WTAUG,NSTA', CCCC 2 I10,2X,A8,4I6,2F8.2,I10) CCCC ENDIF C********************************* IF(IVRAD.EQ.1.OR.(NAREA.EQ.2.AND.LTAGPT(K).EQ.4))THEN C RDVRHL ASSURES EVERY STATION K HAS A RADIUS. IF IT C DIDN'T EXIST ON THE INCOMING RADII FILE, THE GENERIC C ONE FOR THE PASS IS USED. C NOTE THAT RWATO AND RWATI ARE NOT USED. C LTAGPT(K) = 4 INDICATES THE VARIABLE RADII ARE NOT C TO BE CHANGED (OCEAN GRIDPOINTS). CONTROL COMES C HERE IF VARIABLE RADII ARE BEING USED OR IF THIS IS C ALASKA AND THE STATION IS BOGUS CREATED BY BOGUSG C AND LTAAGPT( ) = 4. IN THIS LATTER CASE, VRAD( , ) C HAS NON-ZERO VALUES ONLY FOR THE BOGUSG STATIONS C (WATER AND SIBERIA). RSQR=VRAD(K)**2 RM999R=VRAD(K)-.999 RP001R=VRAD(K)+.001 RM99WO=VRAD(K)-.999 RM99WI=VRAD(K)-.999 RP00WO=VRAD(K)+.001 RP00WI=VRAD(K)+.001 RSQRWO=VRAD(K)**2 C****************************************************************** CCCC IF(K.GT.567.AND.K.LT.571)THEN CCCC WRITE(KFILDO,2025)K,CCALL(K),RWATO,VRAD(K),RSQRWO CCCC 2025 FORMAT(/' AT 2025--K,CCALL(K),RWATO,,VRAD(K)RSQRWO', CCCC 1 I8,2X,A8,3F10.3) CCCC ENDIF C****************************************************************** RSQRWI=VRAD(K)**2 C IF(ICUB.EQ.1)THEN RCUB=VRAD(K)**3 RCUBWO=VRAD(K)**3 RCUBWI=VRAD(K)**3 ENDIF ENDIF C C*****************************************TEST CCC IF(CCALL(K).EQ.'WPKS2 ')THEN CCC WRITE(KFILDO,203)CCALL(K) CCC 203 FORMAT(/' OMITTING STATION ',A8) CCC GO TO 240 CCC ENDIF C*****************************************TEST C CCCC IF(CCALL(K).EQ.'KFHR ')THEN CCCC WRITE(KFILDO,204)K,LNDSEA(K),CCALL(K),QUALST(K), CCCC 1 ELEV(K),XP(K),YP(K),IAUG,LTAGPT(K),WTAUG,DATA(K) CCCC 204 FORMAT(/' IN CORBC5 AT 204--K,LNDSEA(K),CCALL(K),QUALST(K),', CCCC 1 'ELEV(K),XP(K),YP(K),IAUG,LTAGPT(K),WTAUG,DATA(K)',/, CCCC 2 I6,I2,2X,A8,F3.0,3F8.1,2I5,F10.5,F10.3) CCCC ENDIF C CCCCCCC IF(LP.GT.1.AND.LNDSEA(K).LE.3)GO TO 240 C ABOVE PULLED 9/17/07 AT 4:45 A.M. C THE ABOVE CHECK WAS ADDED 8/15/07 FOR ALASKA. C C IF(QUALST(K).EQ.0.)GO TO 240 C IF(LTAGPT(K).NE.0.AND.WTAUG.LT..00001)GO TO 240 C WHEN AUGMENTATION IS DONE WITH AUGMT3, THE AUGMENTATION DATA C CAN HAVE A LESSER WEIGHT = WTAUG. WHEN THIS IS ZERO, THE C CORRECTIONS CAN BE BYPASSED. NORMALLY, IT IS 1. C C SET THE BEGINNING AND ENDING SEARCH LIMITS. THEY ARE C DIFFERENT FOR OCEAN WATER AND INLAND WATER POINTS. C IF(ILS.NE.0)THEN C WHEN THE DISTINCTION IS BEING MADE BETWEEN LAND C AND WATER, THE RADIUS IS ADJUSTED FOR WATER POINTS. C IF(LNDSEA(K).GE.6)THEN C THIS IS FOR ANY POINT THAT CAN BE USED FOR LAND, C WHICH INCLUDES THE POINTS THAT CAN BE USED FOR BOTH C INLAND WATER AND LAND. THIS SHOULD HAPPEN MOST OFTEN. RM999=RM999R RP001=RP001R RSQ=RSQR RCU=RCUB ELSEIF(LNDSEA(K).EQ.0)THEN C THIS IS FOR OCEAN WATER, THE NEXT MOST FREQUENT. RM999=RM99WO RP001=RP00WO RSQ=RSQRWO RCU=RCUBWO ELSEIF(LNDSEA(K).EQ.3)THEN C THIS IS FOR INLAND WATER. RM999=RM99WI RP001=RP00WI RSQ=RSQRWI RCU=RCUBWI ELSE WRITE(KFILDO,2045)LNDSEA(K),CCALL(K) 2045 FORMAT(/,' ****INCORRECT LNDSEA( ) VALUE =',I4, 1 ' FOR STATION ',A8,'. ABORT THIS STATION') ISTOP(1)=ISTOP(1)+1 GO TO 240 ENDIF ELSE C USE THE NORMAL RADIUS UNLESS THE DISTINCTION IS C BEING MADE BETWEEN LAND AND WATER. RM999=RM999R RP001=RP001R RSQ=RSQR RCU=RCUB ENDIF C C IF THE RADIUS IS NEAR ZERO, NO CORRECTION WILL BE MADE C FOR THIS STATION. C C**************************************************** CCCC IF(K.GT.567.AND.K.LT.571)THEN CCCC WRITE(KFILDO,8766)RSQ CCCC 8766 FORMAT('AT 8766--RSQ',F10.3) CCCC ENDIF C**************************************************** IF(RSQ.LT..1)GO TO 240 C (TEST INSERTED 10/4/08) C C******************************************** CK='XXXX ' IF(CCALL(K).EQ.CK)THEN WRITE(KFILDO,2048)CCALL(K),ILS,LNDSEA(K),LP,IVRAD,VRAD(K), 1 RM999,RP001,RSQ,IAUG,WTAUG 2048 FORMAT(/,' AT 2048--CCALL(K),ILS,LNDSEA(K),LP,IVRAD,VRAD(K),', 1 'RM999,RP001,RSQ,IAUG,WTAUG',/, 2 A8,4I3,4F10.3,I3,F6.3) ENDIF C******************************************** C CCC WRITE(KFILDO,2047)LP,K,CCALL(K),LTAG(K),IVRAD,RM999,RP001,RSQ CCC 2047 FORMAT(/' AT 2046--LP,K,CCALL(K),LTAG(K),IVRAD,RM999,RP001,RSQ', CCC 1 I4,I6,2X,A8,2I5,3F8.2) C**************************************************************** CCCC IF(K.GT.567.AND.K.LT.571)THEN CCCC WRITE(KFILDO,8763)K,CCALL(K) CCCC 8763 FORMAT(' AT 8763--K,CCALL(K)',I10,2X,A8) CCCC ENDIF C********************************* IF(LTAG(K).EQ.0)GO TO 205 IF(LTAG(K).NE.-3)GO TO 240 C C ESTABLISH THE CIRCUMSCRIBED SQUARE AROUND THE CIRCLE OF C RADIUS R, WITHIN WHICH CORRECTIONS ARE TO BE MADE AT C GRIDPOINTS. C 205 LB=XP(K)-RM999 IF(LB.GT.0)GO TO 206 LB=1 GO TO 208 C 206 IF(LB.GT.NX)GO TO 240 208 LE=XP(K)+RP001 IF(LE.LE.0)GO TO 240 IF(LE.GT.NX)LE=NX JB=YP(K)-RM999 IF(JB.GT.0)GO TO 218 JB=1 GO TO 220 C 218 IF(JB.GT.NY)GO TO 240 220 JE=YP(K)+RP001 IF(JE.LE.0)GO TO 240 IF(JE.GT.NY)JE=NY C C FIND INTERPOLATED VALUE OR NEAREST NEIGHBOR VALUE IN C ITRPSX ACCORDING TO THE LAND/WATER TYPE LNDSEA(K). C LAPSE IS USED EXCEPT ON THE LAST PASS. IBKPNX IS USED C ONLY IN ITRPSX. C CCCC IF(LP.EQ.NPASS)THEN CCCC IBKPNX=0 CCCC ELSE CCCC IBKPNX=IBKPN CCCC ENDIF C CALL ITRPSX(KFILDO,IP14,P,NX,NY, 1 CCALL(K),DATA(K),XLAPSE(K),ELEV(K),XP(K),YP(K), 2 LNDSEA(K),SEALND,TELEV,NXE,NYE, 3 IBKPNX,ELCORR,ELCORU, 4 MESH,MESHE,N4P,BB,ISTOP,IERX) C VALUE INTERPOLATED FROM CURRENT ANALYSIS OR FIRST C GUESS TO LOCATION OF STATION IS NOW IN BB. THIS CAN BE C MISSING BECAUSE AN INTERPOLATED VALUE FOR A LAND (WATER) C STATION IS ONLY TAKEN FROM LAND (WATER) STATIONS, AND IT IS C POSSIBLE NONE EXIST. ALSO, THE FIRST GUESS ANALYSIS AREA C MAY NOT FILL GRID. C CCCC IF(K.GT.322543)THEN CCCC CALL TIMPR(KFILDO,KFILDO,'AT 221 IN CORBC5 ') CCCC WRITE(KFILDO,221)K,CCALL(K),XP(K),YP(K),LNDSEA(K),BB CCCC 221 FORMAT(/' AT 210 IN CORBC5--K,CCALL(K),XP(K),YP(K),', CCCC 1 'LNDSEA(K),BB',I10,2X,A8,2F10.1,I4,F10.1) CCCC STOP 221 CCCC ENDIF C IF(IERX.EQ.196) GO TO 240 C IERX = 196 IS NOT COUNTED AS AN ERROR. IT MEANS BB = 9999. C BECAUSE OF MISSING POINTS OR NON-MATCHING LAND/WATER C DESIGNATION BETWEEN STATIONS AND LAND/WATER MASK. C IERX = 195 IS COUNTED AS AN ERROR BELOW. C IF(LNDSEA(K).EQ.6)THEN CALL ITRPSX(KFILDO,IP14,P,NX,NY, 1 CCALL(K),DATA(K),XLAPSE(K),ELEV(K),XP(K),YP(K), 2 9,SEALND,TELEV,NXE,NYE, 3 IBKPNX,ELCORR,ELCORU, 4 MESH,MESHE,N4P,BBLAND,ISTOP,IERX) C ITRPSX TAKES THE CLOSEST LAKE POINT WHEN LNDSEA( )=6. C THIS DOES NOT WORK WELL FOR LAND, SO FIND THE CLOSEST C LAND POINT AND USE THE ONE WITH THE VALUES CLOSEST TO C THE CURRENT ANALYSIS SO THE EFFECT IS MINIMIZED. C (A BETTER ALTERNATIVE WOULD PROBABLY BE TO DUPLICATE C THE POINT, AND USE ONE FOR WATER AND ONE FOR LAND.) C CCCC IF(CCALL(K).EQ.'CBOGUS3 '.OR. CCCC 1 CCALL(K).EQ.'CWAJ '.OR. CCCC 2 CCALL(K).EQ.'CBOGUS4 '.OR. CCCC 3 CCALL(K).EQ.'MRHO1 ')THEN CCCC WRITE(KFILDO,2215)CCALL(K),DATA(K),BB,BBLAND CCCC 2215 FORMAT(/' AT 2215 IN CORBC5--CCALL(K),DATA(K),BB,BBLAND', CCCC 1 5X,A8,3F8.2) CCCC ENDIF C IF(BBLAND.LT.9998.5)THEN C IF(ABS(DATA(K)-BB).GT.ABS(DATA(K)-BBLAND))THEN BB=BBLAND C THIS USES THE INTERPOLATED VALUE CLOSEST TO THE C STATION VALUE, SO THE EFFECT WILL BE A MINIMUM. ENDIF C ELSE BB=9999. GO TO 240 ENDIF C ENDIF C C WRITE TO IP20 WHEN DESIRED. THIS IS FOR THE SUBSETTED AREA. C WHEN IOPT(1) = 0, THERE IS NO SUBSETTED AREA. C IF(IP20.NE.0.AND.IOPT(1).NE.0)THEN LBL=NINT((LB-1)*RATIO)+1 JBL=NINT((JB-1)*RATIO)+1 LEL=NINT((LE-1)*RATIO)+1 JEL=NINT((JE-1)*RATIO)+1 C IF(LBL.LE.IOPT(3).AND. 1 JBL.LE.IOPT(5).AND. 2 LEL.GE.IOPT(2).AND. 3 JEL.GE.IOPT(4).AND. 4 K.LE.NBASTA)THEN C DON'T PRINT WATER AND SIBERIA WHEN NSTA GT NBASTA. DIF=BB-DATA(K) WRITE(IP20,222)K,CCALL(K),LBL,LEL,JBL,JEL,XPL(K),YPL(K), 1 DATA(K),BB,DIF,QUALST(K) 222 FORMAT(' ',I5,3X,A8,I8,I5,I9,I5,F9.2,F7.2,F12.2,F13.2, 1 F10.2,F6.3) C XPL( ) AND YPL( ) ARE THE STATION LOCATIONS WITH C RESPECT TO THE FULL ANALYSIS GRID AT MESH LENGTH C MESHL. LBL, ETC., HAVE BEEN SET TO AGREE. ENDIF C ENDIF C IF(IERX.NE.0)THEN ISTOP(1)=ISTOP(1)+1 IERX=0 GO TO 240 C THIS STATION VALUE CANNOT BE USED BECAUSE A CORRECTION C CANNOT BE OBTAINED. ERRORS OTHER THAN 196 ARE TAKEN C CARE OF HERE. ENDIF C C COMPUTE CORRECTIONS AT GRIDPOINTS. C CCC WRITE(KFILDO,2220)K,CCALL(K),JB,JE,LB,LE CCC 2220 FORMAT(/' AT 2220 IN CORBC5--K,CCALL(K),JB,JE,LB,LE',I5,2X,A8,4I6) C**************************************************************** CCCC IF(K.GT.567.AND.K.LT.571)THEN CCCC WRITE(KFILDO,8764)K,CCALL(K),CCALL(K) CCCC 8764 FORMAT(' AT 8764--K,CCALL(K)',I10,2X,A8,I10) CCCC ENDIF C********************************* C !$OMP PARALLEL DO !$OMP& PRIVATE(JY,JYE,DISTSQ,DISTCU,IX,IXE,ELEDIF,BBPLUS,TLAPSE, !$OMP& W,WT,WHT,WTA,WTLW,IWINDX,IWINDY,F,IER) CCCCCCCCCCC!$OMP& SCHEDULE(DYNAMIC) THIS TOOK TOO LONG. MAY BE DUE C TO MANY WATER GRIDPOINTS. C C ALL PRIVATE VARIABLES ARE INITIALIZED WITHIN THE LOOP AND C DO NOT NEED A VALUE COMING IN. IER FROM CORBC5 FROM WITHIN C THE OPEN MP LOOP IS NOT NEEDED IN THE CALLING PROGRAM. C C******************************************** CCCC IF(K.GT.567.AND.K.LT.571)THEN CCCC WRITE(KFILDO,8761)K,CCALL(K),JB,JE,LB,LE CCCC 8761 FORMAT(' AT 8761--K,CCALL(K),JB,JE,LB,LE',I10,2X,A8,4I8) CCCC ENDIF C******************************************** DO 238 JY=JB,JE C IF(MESH.EQ.MESHE)THEN JYE=JY ELSE JYE=NINT((JY-1)*RMESH)+1 C JYE IS THE JY POSITION ON THE TERRAIN GRID. ENDIF C DO 237 IX=LB,LE IF(P(IX,JY).EQ.9999.)GO TO 237 C WHEN FIRST GUESS IS NOT A CONSTANT, IT MAY CONTAIN MISSING C VALUES. IN THAT CASE, MAKE NO CORRECTION. DISTSQ=(IX-XP(K))**2+(JY-YP(K))**2 C C BELOW CHECK ADDED JULY 2024 TO ADDRESS POSSIBLE DIVISION C BY ZERO IN LATER CALCULATIONS IF(DISTSQ.EQ.0.) DISTSQ=.00001 C C CCCC IF(CCALL(K).EQ.'PAPN ')THEN CCCC IF(IX.EQ.1279.AND.JY.EQ.423)THEN CCCC WRITE(KFILDO,2222)K,CCALL(K),IX,XP(K),JY,YP(K),DISTSQ,RSQ CCCC 2222 FORMAT(' AT 2222--K,CCALL(K),IX,XP(K),JY,YP(K),DISTSQ,RSQ', CCCC 1 I6,2X,A8,I8,F8.2,I8,3F8.2) CCCC ENDIF C CCCC ENDIF C IF(DISTSQ.GT.RSQ)GO TO 237 C THIS OBSERVATION IS IN THE DISTANCE RANGE TO AFFECT C THE GRIDPOINT. C C***************************************************** C CCCC IF(CCALL(K).EQ.'PAPN ')THEN C CCCC IF(IX.EQ.830.AND.JY.EQ.463)THEN CCCC WRITE(KFILDO,2222)K,CCALL(K),IX,XP(K),JY,YP(K),DISTSQ,RSQ CCCC 2222 FORMAT(' AT 2222--K,CCALL(K),IX,XP(K),JY,YP(K),DISTSQ,RSQ', CCCC 1 I6,2X,A8,I8,F8.2,I8,3F8.2) CCCC ENDIF C CCCC ENDIF C C**************************************************** IF(ICUB.EQ.1)THEN DISTCU=ABS((IX-XP(K))**3)+ABS((JY-YP(K))**3) C THE CUBE CAN BE NEGATIVE. THIS IS ONLY COMPUTED WHEN NEEDED. ENDIF C IF(MESH.EQ.MESHE)THEN IXE=IX ELSE IXE=NINT((IX-1)*RMESH)+1 C IXE IS THE IX POSITION ON THE TERRAIN GRID. ENDIF C CCCCD WRITE(KFILDO,2223)LNDSEA(K),IX,JY,RMESH,IXE,JYE,SEALND(IXE,JYE) CCCCD2223 FORMAT(' AT 2223--LNDSEA(K),IX,JY,RMESH,IXE,JYE,SEALND(IXE,JYE)', CCCCD 1 3I6,F6.3,2I6,F5.2) C IF(ILS.EQ.1)THEN C THIS OPTION IS TO BE EXERCISED, SO SOME CORRECTIONS C ARE BYPASSED. CHECKS AT THE BEGINNING OF DO 240 LOOP C WILL ACTUALLY BYPASS THESE CHECKS. THEY ARE LEFT HERE C FOR SAFETY. WHEN ILS = 0, LNDWAT HAS NO EFFECT. C WHEN ILS = 1, LNDWAT IS IN EFFECT. C IF(LNDWAT.EQ.2.AND.SEALND(IXE,JYE).EQ.0.)GO TO 237 C OCEAN WILL NOT BE CHANGED. C IF(LNDWAT.EQ.3.AND.SEALND(IXE,JYE).LE.3.)GO TO 237 C OCEAN AND INLAND WATER WILL NOT BE CHANGED. C C APPLY DATA VALUES OVER WATER OR LAND AS INDICATED BY C LNDSEA( ), WTLTW, AND WTWTL. THE CHECKS BELOW ACCOUNT C FOR THE TWO CHECKS ABOVE, WHICH ARE THERE FOR QUICK C BYPASSES. C C THE CODE BELOW SETS THE LAND/WATER WEIGHT WTLW TO C 0., 1., WTLTW, OR WTWTL DEPENDING ON THE TYPE OF POINT C (STATION) AND TYPE OF GRIDPOINT. WHENEVER THE WEIGHT C IS ZERO, ALL FURTHER PROCESSING FOR THIS GRIDPOINT C IS BYPASSED. C IF(LNDWAT.EQ.1)THEN C IF(LNDSEA(K).EQ.0)THEN C THIS IS AN OCEAN POINT. C IF(SEALND(IXE,JYE).EQ.0.)THEN WTLW=1. C OCEAN POINT AFFECTING OCEAN. ELSEIF(SEALND(IXE,JYE).EQ.3.)THEN WTLW=0. C OCEAN DOES NOT AFFECT INLAND WATER. GO TO 237 ELSE WTLW=WTWTL C OCEAN POINT AFFECTING LAND. IF(WTLW.EQ.0.)GO TO 237 ENDIF C ELSEIF(LNDSEA(K).EQ.3)THEN C THIS IS AN INLAND WATER POINT. C IF(SEALND(IXE,JYE).EQ.3.)THEN WTLW=1. C INLAND WATER POINT AFFECTING INLAND WATER. ELSEIF(SEALND(IXE,JYE).EQ.0.)THEN WTLW=0. C INLAND WATER POINT DOES NOT AFFECT OCEAN. GO TO 237 ELSE WTLW=WTWTL C INLAND WATER POINT AFFECTING LAND. IF(WTLW.EQ.0.)GO TO 237 ENDIF C ELSEIF(LNDSEA(K).EQ.6)THEN C THIS IS AN INLAND WATER AND LAND POINT. C IF(SEALND(IXE,JYE).EQ.0.)THEN WTLW=WTLTW C INLAND WATER/LAND POINT AFFECTING OCEAN. IF(WTLW.EQ.0.)GO TO 237 ELSEIF(SEALND(IXE,JYE).EQ.9.)THEN C A STATION CANNOT EFFECTIVELY REFLECT BOTH LAND C AND WATER. THE WEIGHTS ARE INTENTIONALLY SET C 0.1, NOT 1.0. WTLW=.1 ELSE WTLW=.1 C INLAND WATER/LAND POINT AFFECTING INLAND WATER. C IF BOTH THESE LAST TWO WEIGHTS ARE EQUAL, THE C IF TEST COULD BE ELIMINATED. THIS ARRANGEMENT C GIVES THE FLEXIBILITY OF EASILY CHANGING THE C WEIGHTS INDIVIDUALLY. ENDIF C ELSE C THIS IS A LAND POINT. C IF(SEALND(IXE,JYE).LE.3.)THEN WTLW=WTLTW C LAND POINT AFFECTING OCEAN AND INLAND WATER. IF(WTLW.EQ.0.)GO TO 237 ELSE WTLW=1. C LAND POINT AFFECTING LAND. ENDIF C ENDIF C ELSEIF(LNDWAT.EQ.2)THEN C IF(LNDSEA(K).EQ.0)THEN C THIS IS AN OCEAN POINT. C IF(SEALND(IXE,JYE).EQ.0.)THEN WTLW=0. C OCEAN POINT IS LEFT INTACT. GO TO 237 ELSEIF(SEALND(IXE,JYE).EQ.3.)THEN WTLW=0. C OCEAN DOES NOT AFFECT INLAND WATER. GO TO 237 ELSE WTLW=WTWTL C OCEAN POINT AFFECTING LAND. IF(WTLW.EQ.0.)GO TO 237 ENDIF C ELSEIF(LNDSEA(K).EQ.3)THEN C THIS IS AN INLAND WATER POINT. C IF(SEALND(IXE,JYE).EQ.3.)THEN WTLW=1. C INLAND WATER POINT AFFECTING INLAND WATER. ELSEIF(SEALND(IXE,JYE).EQ.0.)THEN WTLW=0. C OCEAN POINT IS LEFT INTACT. GO TO 237 ELSE WTLW=WTWTL C INLAND WATER POINT AFFECTING LAND. IF(WTLW.EQ.0.)GO TO 237 ENDIF C ELSEIF(LNDSEA(K).EQ.6)THEN C THIS IS AN INLAND WATER AND LAND POINT. C IF(SEALND(IXE,JYE).EQ.0.)THEN WTLW=0. C OCEAN POINT IS LEFT INTACT. GO TO 237 ELSE WTLW=1. C INLAND WATER POINT AFFECTING LAND AND INLAND WATER. ENDIF C ELSE C THIS IS A LAND POINT. C IF(SEALND(IXE,JYE).EQ.0.)THEN WTLW=0. C OCEAN POINT IS LEFT INTACT. GO TO 237 ELSEIF(SEALND(IXE,JYE).EQ.3)THEN WTLW=WTLTW C LAND POINT AFFECTING INLAND WATER. IF(WTLW.EQ.0.)GO TO 237 ELSE WTLW=1. C LAND POINT AFFECTING LAND. ENDIF C ENDIF C ELSEIF(LNDWAT.EQ.3)THEN C IF(LNDSEA(K).EQ.0)THEN C THIS IS AN OCEAN POINT. C IF(SEALND(IXE,JYE).LE.3.)THEN WTLW=0. C OCEAN AND INLAND WATER POINTS LEFT INTACT. GO TO 237 ELSE WTLW=WTWTL C OCEAN OR INLAND WATER POINT AFFECTING LAND. IF(WTLW.EQ.0.)GO TO 237 ENDIF C ****************INSERTED 4/7/19***************** C ELSEIF(LNDSEA(K).EQ.3)THEN C THIS IS AN INLAND WATER POINT. C IF(SEALND(IXE,JYE).LE.3)THEN WTLW=0 C INLAND WATER AND OCEAN LEFT INTACT. ELSE WTLW=WTWTL C INLAND WATER POINT AFFECTING LAND. IF(WTLW.EQ.0)GO TO 237 ENDIF C C ****************INSERTED 4/7/19***************** C ELSEIF(LNDSEA(K).EQ.6)THEN C THIS IS AN INLAND WATER AND LAND POINT. C IF(SEALND(IXE,JYE).LE.3.)THEN WTLW=0. C INLAND WATER AND OCEAN LEFT INTACT. GO TO 237 ELSE WTLW=1. C INLAND WATER POINT AFFECTING LAND. ENDIF C ELSE C THIS IS A LAND POINT. C IF(SEALND(IXE,JYE).LE.3.)THEN WTLW=0. C INLAND WATER AND OCEAN POINTS LEFT INTACT. GO TO 237 ELSE WTLW=1. C LAND POINT AFFECTING LAND. ENDIF C ENDIF C ELSEIF(LNDWAT.EQ.0)THEN C IF(LNDSEA(K).EQ.0)THEN C IF(SEALND(IXE,JYE).EQ.0.)THEN WTLW=1. C OCEAN POINT AFFECTING OCEAN. ELSE WTLW=0. C OCEAN POINT NOT AFFECTING INLAND WATER OR LAND. GO TO 237 ENDIF C ELSEIF(LNDSEA(K).EQ.3)THEN C IF(SEALND(IXE,JYE).EQ.3.)THEN WTLW=1. C INLAND WATER POINT AFFECTING INLAND WATER. ELSE WTLW=0. C INLAND WATER NOT AFFECTING OCEAN OR LAND. GO TO 237 ENDIF C ELSEIF(LNDSEA(K).EQ.6)THEN C IF(SEALND(IXE,JYE).EQ.0.)THEN WTLW=0. C INLAND WATER OR LAND POINT NOT AFFECTING OCEAN. GO TO 237 ELSE WTLW=1. C INLAND WATER OR LAND AFFECTING INLAND WATER/LAND. C ENDIF C ELSE C IF(SEALND(IXE,JYE).LE.3.)THEN WTLW=0. C LAND POINT NOT AFFECTING INLAND WATER OR OCEAN. GO TO 237 ELSE WTLW=1. C LAND POINT AFFECTING LAND. ENDIF C ENDIF C ENDIF C ELSE WTLW=1. C ILS = 0 INDICATES NO DISTINCTION BETWEEN POINTS. C ENDIF C CCCC IF(CCALL(K).EQ.'MRHO1 ')THEN CCCC WRITE(KFILDO,2225)CCALL(K),LNDSEA(K),SEALND(IXE,JYE), CCCC 1 ILS,WTLW CCCC 2225 FORMAT(' AT 2225 IN CORBC5--CCALL(K),LNDSEA(K),', CCCC 1 'SEALND(IXE,JYE),ILS,WTLW ',A8,I3,F5.0,I4,F6.0) CCCC ENDIF CC CCCD IF(IFIRST.EQ.0) CCCD 1 WRITE(KFILDO,223) CCCD223 FORMAT(/' QUAD IX JY IXE JYE K STATION XPE(K) YPE(K)', CCCD 1 ' RMESH B DXLINE X Y ELEV(K) TELEV(IXE,JYE)', CCCD 2 ' BB BE') C THE ABOVE FORMAT IS TO HEAD THE VALUES IN FORMAT 227. CCC IFIRST=1 C C DETERMINE WHETHER THE HEIGHT DIFFERENCE BETWEEN THE STATION C AND THE GRIDPOINT IS ACCEPTABLE. C CCCD WRITE(KFILDO,2235)K,CCALL(K),XPE(K),YPE(K),ELEV(K), CCCD 1 IXE,JYE,TELEV(IXE,JYE),SEALND(IXE,JYE),HGTTHA CCCD2235 FORMAT(/,' AT 2235--K,CCALL(K),XPE(K),YPE(K),ELEV(K),', CCCD 1 'IXE,JYE,TELEV(,),SEALND(,),HGTTHA', CCCD 2 I5,1X,A8,3F6.1,2I4,F8.1,F4.0,F8.1) C ELEDIF=TELEV(IXE,JYE)-ELEV(K) IF(ABS(ELEDIF).GT.HGTTHA)GO TO 237 C THE DIFFERENCE BETWEEN THE STATION ELEVATION AND THE C GRIDPOINT ELEVATION EXCEEDS THE HGTTHA THRESHOLD. C C WHEN HGTTHB IS GE TOP, DON'T GO THROUGH THE CHECKING C FOR HEIGHT DIFFERENCE EXCEEDED, BECAUSE HGTTHB IS VERY C LARGE. C IF(HGTTHB.LT.TOP)THEN C CALL TERDIF(KFILDO,IXE,JYE,XPE(K),YPE(K), 1 TELEV,NXE,NYE,ELEV(K),HGTTHB,IER) IF(IER.EQ.777)GO TO 237 C IER RETURN FROM TERDIF INDICATES TERRAIN DIFFERENCE C KEEPS STATION CORRECTION FROM BEING MADE FOR THIS C GRIDPOINT. OTHERWISE, FALL THROUGH PERMITS CORRECTION. C (NOT EXERCISED AS OF 8/3/07) ENDIF C C SET TLAPSE, THE LAPSE TO BE USED FOR THIS STATION. WHEN C LAPFGS = 5, IT IS CALCULATED AS A LINEAR COMBINATION OF C XLAPSE( ) AND ULAPSE( ), DEPENDING ON TELL AND TELLH. C OTHERWISE, TLAPSE = XLAPSE( ). C IF(LAPFG.EQ.5)THEN C IF(ELEDIF.LT.TELL)THEN TLAPSE=XLAPSE(K) ELSEIF(ELEDIF.GT.TELH)THEN TLAPSE=ULAPSE(K) ELSE TLAPSE=(ATEL+BTEL*ELEDIF)*ULAPSE(K)+ 1 (1.-ATEL-BTEL*ELEDIF)*XLAPSE(K) ENDIF C ELSE TLAPSE=XLAPSE(K) ENDIF C CCCC IF(CCALL(K).EQ.'KRAP ')THEN CCCC WRITE(KFILDO,2237)CCALL(K),TELL,TELH,ATEL,BTEL,XLAPSE(K), CCCC 1 ULAPSE(K),TLAPSE,ELEDIF CCCC 2237 FORMAT(' AT 2237 IN CORBC5--CCALL(K),TELL, TELH, ATEL ,BTEL,', CCCC 1 ' XLAPSE(K), ULAPSE(K), TLAPSE, ELEDIF'/ CCCC 2 17X,A8,7F10.4,F10.1) CCCC ENDIF C C COMES HERE WHEN THE ELEVATION CRITERION DOES NOT C KEEP THE CORRECTION FROM BEING MADE. GO AHEAD AND C MAKE THE CORRECTION. C NCOUNT(IX,JY)=NCOUNT(IX,JY)+1 C C SWITCH ON XLAPSE CORRECTION. NOTE THAT WATER POINTS C ARE TREATED LIKE LAND POINTS BELOW, EXCEPT THAT XLAPSE( ) C IS ZERO FOR WATER POINTS, SO THIS MAKES A BASIC DIFFERENCE C IN THE WAY WATER POINTS ARE TREATED. THE BBPLUS=BB C IS THE "STANDARD" WAY THE BCD (CRESSMAN) ANALYSIS WORKS C WITHOUT AN ELEVATION (LAPSE RATE) CORRECTION. IT HAS C ALREADY BEEN DETERMINED THAT QUALST(K) NE 0. C IF(ELCORR.EQ.0..OR.TLAPSE.EQ.0..OR.ABS(ELEDIF).LT.ELCUT.OR. 1 IBKPN.EQ.99.OR.(ELEDIF.GT.0..AND.LAPUDB.EQ.2).OR. 2 (ELEDIF.LT.0..AND.LAPUDB.EQ.1))THEN C C THIS IS THE ORIGINAL FORMULATION AND FITS THE DATA C BETTER WHEN XLAPSE IS OF NO USE. BB HAS BEEN INSURED C TO BE A LEGITIMATE VALUE IN CALL TO ITRPSX AND THE C TRANSFER TO 240 WHEN IER NE 0. THIS IS ALSO THE PATH C FOR WATER POINTS. THE TESTS ON LAPUDB ADDED 1/25/14. C BBPLUS=BB C IF(ICUB.EQ.0)THEN WT=MAX((RSQ-DISTSQ)/(RSQ+DISTSQ),0.) ELSE WT=MAX(((RCU-DISTCU)/(RCU+DISTCU))**2,0.) C INSERTED MAX( ) IN STATEMENTS ABOVE 4/1/19. ENDIF C ELSE C IF(IBKPN.EQ.0)THEN C IBKPN = 0 MEANS THE LAPSE RATES ARE NOT RESTRICTED C FOR ANY XLAPSE( ), POSITIVE OR NEGATIVE, SO USE C THE WEIGHT ELCORR. WHT=ELCORR C ELSEIF(IBKPN.EQ.+1)THEN C IBKPN = +1 MEANS THE POSITIVE LAPSE RATES ARE C UNUSUAL AND RESTRICTED. C IF(TLAPSE.GT.0.)THEN C IF(ICUB.EQ.0)THEN W=MAX(0.,(BRKSQ-DISTSQ)/(BRKSQ+DISTSQ)) C W IS THE WEIGHT FOR THE UNUSUAL HEIGHT GRADIENT. ELSE W=MAX(0.,((BRKCU-DISTCU)/(BRKCU+DISTCU)))**2 ENDIF C WHT=W*ELCORU CCC WRITE(KFILDO,2240)CCALL(K),IBKPN,TLAPSE, CCC 1 BRKSQ,DISTSQ,W,ELCORU,WHT CCC 2240 FORMAT(/, 'AT 2240--CCALL(K),IBKPN,TLAPSE,', CCC 1 'BRKSQ,DISTSQ,W,ELCORU,WHT ',A8,I3,6F9.3) ELSE WHT=ELCORR ENDIF C ELSEIF(IBKPN.EQ.+2)THEN C IBKPN = +2 MEANS THE POSITIVE LAPSE RATES ARE C UNUSUAL AND RESTRICTED. C IF(TLAPSE.GT.0.)THEN C IF(ICUB.EQ.0)THEN W=MAX(0.,(BRKSQ-DISTSQ)/(BRKSQ+DISTSQ)) C W IS THE WEIGHT FOR THE UNUSUAL HEIGHT GRADIENT. ELSE W=MAX(0.,((BRKCU-DISTCU)/(BRKCU+DISTCU)))**2 ENDIF C WHT=W*ELCORU ELSE IF(ELEDIF.LT.0.)THEN C NEGATIVE LAPSE RATES ARE ONLY ALLOWED TO C OPERATE UPWARD. WHEN ELEDIF LT 0, STATION IS C HIGHER THAN GRIDPOINT. (USED FOR BIG ISLAND C IN HAWAII.) WHT=0. ELSE WHT=ELCORR ENDIF C ENDIF C ELSEIF(IBKPN.EQ.-1)THEN C IBKPN = -1, SO NEGATIVE LAPSE RATES ARE UNUSUAL AND C RESTRICTED. C IF(TLAPSE.LT.0.)THEN C IF(ICUB.EQ.0)THEN W=MAX(0.,(BRKSQ-DISTSQ)/(BRKSQ+DISTSQ)) C W IS THE WEIGHT FOR THE UNUSUAL HEIGHT GRADIENT. ELSE W=MAX(0.,((BRKCU-DISTCU)/(BRKCU+DISTCU)))**2 ENDIF C WHT=W*ELCORU ELSE WHT=ELCORR ENDIF C ELSEIF(IBKPN.EQ.-2)THEN C IBKPN = -2, SO NEGATIVE LAPSE RATES ARE UNUSUAL AND C RESTRICTED, AND POSITIVE LAPSE RATES ARE ONLY C ALLOWED TO OPERATE UPWARD. C IF(TLAPSE.LT.0.)THEN C IF(ICUB.EQ.0)THEN W=MAX(0.,(BRKSQ-DISTSQ)/(BRKSQ+DISTSQ)) C W IS THE WEIGHT FOR THE UNUSUAL HEIGHT GRADIENT. ELSE W=MAX(0.,((BRKCU-DISTCU)/(BRKCU+DISTCU)))**2 ENDIF C WHT=W*ELCORU ELSE IF(ELEDIF.LT.0.)THEN C POSITIVE LAPSE RATES ARE ONLY ALLOWED TO C OPERATE UPWARD. WHEN ELEDIF LT 0, STATION IS C HIGHER THAN GRIDPOINT. (THIS IS TO KEEP LAKES C FROM BECOMING DRY FOR QPF.) WHT=0. ELSE WHT=ELCORR ENDIF C ENDIF C ENDIF C C SINCE ALMOST ALWAYS THE CORRECTION IS TYPE 2 OR 3, WT C WILL BE NEEDED. C IF(ICUB.EQ.0)THEN WT=MAX((RSQ-DISTSQ)/(RSQ+DISTSQ),0.) ELSE WT=MAX(((RCU-DISTCU)/(RCU+DISTCU))**2,0.) C INSERTED MAX( ) IN STATEMENTS ABOVE 4/1/19. C CCCC IF(IX.EQ.968.AND.JY.EQ.551.AND.LP.EQ.1)THEN CCCC WRITE(KFILDO,2278)LP,CCALL(K),WT,RCU,DISTCU CCCC 2278 FORMAT('AT 2278--LP,CCALL(K),WT,RCU,DISTCU ',/, CCCC 1 I4,2X,A8,3F20.4) CCCC ENDIF C ENDIF C C C******************************************************** CCCC IF(CCALL(K).EQ.'PADU ')THEN CCCC WRITE(KFILDO,2279)K,CCALL(K),ELCORR,TLAPSE,ELEDIF, CCCC 1 IBKPN,ELCORR,ELCORU,WHT,WT,IX,JY,SEALND(IXE,JYE), CCCC 2 BB,IALGOR CCCC2279 FORMAT(' AT 2279--K,CCALL(K),ELCORR,,TLAPSE,ELEDIF,', CCCC 1 'IBKPN,ELCORR,ELCORU,WHT,WT,IX,JY,', CCCC 2 'SEALND(IXE,JYE),BB,IALGOR',/, CCCC 3 I6,2X,A8,3F8.3,I3,4F8.2,2I5,F4.1,F7.3,I6) CCCC ENDIF C********************************************************* C IF(WHT.EQ.0.)THEN BBPLUS=BB ELSE C IF(IALGOR.EQ.1)THEN BBPLUS=BB+WHT*(P(IX,JY)-BB-TLAPSE*ELEDIF) C NOTE THAT ELCORR OR ELCORU IS EMBODIED IN WHT. C THIS FORMULATION 5/31/05. C THE SIGN ACCOMMODATES THE -BBPLUS. C WATER POINTS WILL HAVE XLAPSE( ) = 0 AND NOT BE C IN THIS LOOP. C ELSEIF(IALGOR.EQ.2)THEN BBPLUS=BB+WHT*(1.-WT)*(P(IX,JY)-BB-TLAPSE*ELEDIF) C NOTE THAT ELCORR OR ELCORU IS EMBODIED IN WHT. C THIS FORMULATION WITH WT 1/8/06. C THE SIGN ACCOMMODATES THE -BBPLUS. C WATER POINTS WILL HAVE XLAPSE( ) = 0 AND NOT BE C IN THIS LOOP. C ELSEIF(IALGOR.EQ.3)THEN C IF(ELEDIF.LE.1200.)THEN BBPLUS=BB+WHT*(P(IX,JY)-BB-TLAPSE*ELEDIF) C THIS IS THE SAME AS ALGORITHM 1 WHEN ELEDIF LE 1200. ELSE BBPLUS=BB+WHT*(P(IX,JY)-BB- 1 TLAPSE*(1200.+(ELEDIF-1200.)*0.)) CCC 1 TLAPSE*(1000.+(ELEDIF-1000.)**.1)) C THE 750 AND .8 ARE ARBITRARY AND CAN BE MODIFIED. ENDIF C ELSE WRITE(KFILDO,2280)IALGOR 2280 FORMAT(/,' ****IALGOR =',I3,' INCORRECT.', 1 ' STOP AT 2280 IN CORBC5.') CALL W3TAGE('CORBC5') STOP 2280 ENDIF C ENDIF C ENDIF C C********************************************************************** C THE BELOW CAN MONITOR THE FIT TO PARTICULAR STATIONS. C CCCC IF(CCALL(K).EQ.'PAMD ')THEN CCCC CHANGE=DATA(K)-BBPLUS CCCC WRITE(KFILDO,2281)CCALL(K),DATA(K),IX,JY,P(IX,JY), CCCC 1 TLAPSE,ELEDIF,BBPLUS,ELCORR,CHANGE, CCCC 2 RSQ CCCC 2281 FORMAT(' AT 2281--CCALL(K),DATA(K),IX, JY, P(IX,JY),', CCCC 1 'TLAPSE,ELEDIF, BBPLUS, ELCORR, CHANGE', CCCC 2 ' RSQ',/, CCCC 3 10X,A8,F6.2,2I6,6F10.3,F13.1) CCCC ENDIF C********************************************************************** C CCC IF(LNDSEA(K).NE.100)THEN CCC WRITE(KFILDO,2282)K,LNDSEA(K),IX,JY,P(IX,JY),BB,W,WHT, CCC 1 TLAPSE,ELEDIF,ELCORR,DATA(K),QUALST(K),BBPLUS CCC 2282 FORMAT(' AT 2282--K,LNDSEA(K),,IX,JY,P(IX,JY),BB,W,WHT,', CCC 1 'TLAPSE,ELEDIF,ELCORR,DATA(K),QUALST(K),BBPLUS)' CCC 2 ,/,4I5,10F10.2) CCC ENDIF C C THIS IS WHERE THE ADJUSTMENTS ARE MADE TO THE GRIDPOINTS C AND ACCUMULATED. WHEN THERE ARE AUGMENTED DATA, IN C ADDITION TO THE BASIC (REAL) DATA, THE AUGMENTED DATA CAN C BE WEIGHTED LESS. THIS IS DONE BY USING WTA FOR CORRECTIONS C VICE WT. C IF(LTAGPT(K).NE.0)THEN C WTAUG IS THE WEIGHT TO USE FOR AUGMENTED STATIONS C FOR THE CORRECTIONS WHEN AUGMT3 IS USED. WHEN AUGMT2 IS C USED, THE WEIGHTS COME THROUGH QUEST( ) AND NOT WTAUG; C IN THIS CASE, WTAUG = 1. AND WTA = WT. WT IS NOT C MODIFIED FOR BASE DATA. WTA=WT*WTAUG C WTA IS USED FOR CORRECTIONS AND FOR COUNT( , ). ELSE WTA=WT ENDIF C**************************************************************** CCCC IF(K.GT.567.AND.K.LT.571)THEN CCCC WRITE(KFILDO,8765)K,CCALL(K),CCALL(K) CCCC 8765 FORMAT(' AT 8765--K,CCALL(K)',I10,2X,A8,I10) CCCC ENDIF C**************************************************************** IF(NTYP.EQ.1)THEN C THIS IS TYPE 1 CORRECTION. CORR(IX,JY)=CORR(IX,JY)+WTLW*(DATA(K)-BBPLUS)*QUALST(K) C NOTE THIS HAS BEEN BYPASSED WHEN WTLW OR QUALST(K) = 0. ELSEIF(NTYP.EQ.2)THEN C THIS IS TYPE 2 CORRECTION. WT ALREADY COMPUTED. C CCC IF(IX.EQ.1250.AND.JY.EQ.100)THEN CCC PRINT=WT*(DATA(K)-BBPLUS)*QUALST(K) CCC WRITE(KFILDO,2282)K,CCALL(K),ELEV(K),DATA(K), CCC 1 TLAPSE,TELEV(IXE,JYE),ELCORR,WT,BBPLUS, CCC 2 IX,JY,P(IX,JY),PRINT,CORR(IX,JY),COUNT(IX,JY) CCC 2282 FORMAT('AT 2282-K,CCALL(K),ELEV(K),DATA(K),', CCC 1 'TLAPSE,TELEV(IXE,JYE),ELCORR,WT,BBPLUS,', CCC 2 ' IX, JY,P(IX,JY),PRINT,CORR(IX,JY),', CCC 3 'COUNT(IX,JY)',/, CCC 4 3X,I6,2X,A8,F6.1,F8.4,F8.2,F12.2,F10.2,F6.2,F7.2,I7, CCC 5 I6,F8.2,F7.2,2F10.2) CCC ENDIF C CORR(IX,JY)=CORR(IX,JY)+WTLW*WTA*(DATA(K)-BBPLUS)*QUALST(K) C NOTE THIS HAS BEEN BYPASSED WHEN WTLW, WTA, OR QUALST( ) = 0. ELSE C C THIS IS TYPE 3 CORRECTION. WT ALREADY COMPUTED. C C************************************************************************* C IX = 951 AND JY = 958 IS MIDDLETON ISLAND CCCC IF(IX.EQ.951.AND.JY.EQ.528)THEN C IX = 939 AND JY = 278 IS WATER POINT 46060 NEAR CORDOVA C IF(IX.EQ.939.AND.JY.EQ.278)THEN C C IX = 1168 AND JY = 161 IS WATER POINT 46084 NEAR JUNEAU C IF(IX.EQ.1168.AND.JY.EQ.161)THEN C C IX = 1117 AND JY = 214 IS WATER POINT 46083 c IF(IX.EQ.1117.AND.JY.EQ.214)THEN C C IX = 1061 AND JY = 232 IS HALF WAY BETWEEN 46082 AND 46083 C C IX = 958.58 AND JY = 629.81 IS BARTER ISLAND. TAKE A POINT C INLAND C IX = 958 AND JY = 625 IS BARTER ISLAND C C IX = 474 AND JY = 220 IS ST. PAUL ISLAND C C IX = 725 AND JY = 210 IS OCEAN JUST WEST AND NORTH OF PAII. C THIS SHOWED ONLY CORRECTION BY 46072 WITH WT = .31 ON C PASS 1 AND .02 ON PASS 2 AT R = 560 AND 414 C IX = 857 AND JY = 555 IS PAKP IN BROOKS RANGE C BELOW IS FOR PAKP IN BROOKS RANGE C IX =585 AND.JY EQ.311)FOR NUNIVAK ISLAND. C IX = 306 AND JY = 673 FOR NEAR DEATH VALLEY C IX = 508.AND.JY.EQ.75) FOR PADU IN ALEUTIANS. C IX = 951.AND.JY.EQ.527) FOR MIDDLETON ISLAND C CCCC IF(IX.EQ.781.AND.JY.EQ.660)THEN C ABOVE IS CLOSEST LAND POINT TO PAGM. CCCC WTOTAL=WTLW*WTA*QUALST(K) CCCC PRINT=WTOTAL*(DATA(K)-BBPLUS) C NOTE THAT IF WTOTAL AND PRINT ARE ACTIVATED AND C NOT MADE PRIVATE, CORBC5 SLOWS DOWN ON NCEP'S C SUPERCOMPUTER, BUT NOT ON FLASH. C CHANGED WT TO WTA 5/6/10 C ADDED WTLW 10/15/08 C CCCC WRITE(KFILDO,2283)K,CCALL(K),ELEV(K),DATA(K), CCCC 1 TLAPSE,TELEV(IXE,JYE),ELCORR,WTOTAL,BBPLUS, CCCC 2 IX,JY,P(IX,JY),PRINT,CORR(IX,JY),COUNT(IX,JY), CCCC 3 NCOUNT(IX,JY),WTAUG,WTLW,SEALND(IXE,JYE) 2283 FORMAT(/'AT 2283-K,CCALL(K),ELEV(K),DATA(K),', 1 'TLAPSE,TELEV(IXE,JYE),ELCORR, WT,BBPLUS,', 2 ' IX, JY,P(IX,JY),PRINT,CORR(IX,JY),', 3 'COUNT(IX,JY),NCOUNT(IX,JY),WTAUG,WTLW,', 4 'SEALND(IXE,JYE),VRAD(K)',/, 5 3X,I6,2X,A8,F6.1,F8.4,F8.4,F12.2,F10.2,F6.3,F7.3,I7, 6 I6,F8.2,F7.3,2F10.3,I12,F11.1,F6.1,F5.1,F15.2) CCCC ENDIF C CORR(IX,JY)=CORR(IX,JY)+WTLW*WTA*(DATA(K)-BBPLUS)*QUALST(K) COUNT(IX,JY)=COUNT(IX,JY)+WTLW*WTA*QUALST(K) C NOTE THAT THESE ABOVE ARE BYPASSED WHEN WTLW, WTA, OR C QUALST(K) = 0. ALSO NOTE WTA IS IN BOTH CORR( , ) AND C COUNT( , ). PUTTING WTA IN COUNT VICE WT WAS MADE 3/13/10. C IF(QUALST(K).GT..995)THEN IFULL(IX,JY)=IFULL(IX,JY)+1 C IFULL( , ) ESSENTIALLY COUNTS THE NUMBER OF BASE STATIONS, C THOSE THAT HAVE FULL WEIGHT. THE RATIO IFULL(IX,JY)/ C NCOUNT(IX,JY) IS THE PROPORTION OF THE CORRECTIONS THAT C ARE BASE STATIONS. THE CORRECTIONS THAT MIGHT BE MADE C BELOW WHEN USING WIND AS GRADIENTS IN SLP ANALYSIS ARE C ADDITIONAL CORRECTIONS, AND IFULL( , ) SHOULD NOT BE C INCREMENTED THERE. ENDIF C CCCC IF(IX.EQ.781.AND.JY.EQ.660)THEN C ABOVE IS CLOSEST LAND POINT TO PAGM. CCCC WRITE(KFILDO,2283)K,CCALL(K),ELEV(K),DATA(K), CCCC 1 TLAPSE,TELEV(IXE,JYE),ELCORR,WTOTAL,BBPLUS, CCCC 2 IX,JY,P(IX,JY),PRINT,CORR(IX,JY),COUNT(IX,JY), CCCC 3 NCOUNT(IX,JY),WTAUG,WTLW,SEALND(IXE,JYE),VRAD(K) CCCC ENDIF C CCCC IF(IX.EQ.1509.AND.JY.EQ.859)THEN C THIS POINT IS SOUTH OF LAKE ERIE NEAR MRHO1. C FOR PRINTING, WHT IS UNDEFINED WHEN IBKPN = 99. C CCCC IF(CCALL(K).EQ.'MRHO1 '.AND.SEALND(IXE,JYE).EQ.9)THEN CCCC WRITE(KFILDO,2284)P(IX,JY),CORR(IX,JY),COUNT(IX,JY), CCCC 1 WT,WHT,BB,BBPLUS,NCOUNT(IX,JY),IX,JY,LP, CCCC 2 SEALND(IXE,JYE),CCALL(K),ELEDIF,TLAPSE CCCC 2284 FORMAT(' AT 2284--P(IX,JY),CORR(IX,JY),COUNT(IX,JY),', CCCC 1 'WT,WHT,BB,BBPLUS,NCOUNT(IX,JY),IX,JY,LP,', CCCC 2 'SEALND(IXE,JYE),CCALL(K),ELEDIF,TLAPSE' CCCC 3 ,/,7F10.3,4I5,F5.1,2X,A8,2F10.3) CCCC ENDIF C ENDIF IF(WNDWT.EQ.0.)GO TO 237 IF(WNDGRD.EQ.0.)GO TO 237 IF(U(K).EQ.9999.)GO TO 237 IF(P(IX,JY).GT.1013.)GO TO 237 C ALL OF THE ABOVE CONDITIONS MUST BE MET FOR A C WIND CORRECTION TO BE MADE. OTHER CONDITIONS C ARE SPECIFIED IN SUBROUTINE WNDCOR. C C POSSIBLY MAKE A CORRECTION FOR THE WIND. WIND C COUNTS ARE KEPT SEPARATE IN NWIND( , ). C CALL WNDCOR(KFILDO,P,IX,JY,NX,NY,MESH,IWINDX,IWINDY,F) IF(IWINDX.EQ.0.AND.IWINDY.EQ.0)GO TO 237 C NO WIND CORRECTION IS TO BE DONE. C NWIND(IX,JY)=NWIND(IX,JY)+1 C C*** WRITE(KFILDO,229)IWINDX,IWINDY,K,CCALL(K),WNDWT,DATA(K), C*** 1 IX,JY,XP(K),YP(K),U(K),V(K) C*** 229 FORMAT(' CORBC5--IWINDX,IWINDY,K,CCALL(K),WNDWT,DATA(K),', C*** 1 'IX,JY,XP(K),JY(K),V(K),U(K)',2I2,I5,2X,A8,2F7.1, C*** 2 2I4,2F8.1,2F10.3) IF(NTYP.EQ.1)THEN CORR(IX,JY)=CORR(IX,JY)+WNDWT*(DATA(K)+(IX-XP(K))*V(K)+ 1 (JY-YP(K))*U(K)-P(IX,JY)) ELSEIF(NTYP.EQ.2)THEN CORR(IX,JY)=CORR(IX,JY)+WNDWT*WTA*(DATA(K)+(IX-XP(K))*V(K)+ 1 (JY-YP(K))*U(K)-P(IX,JY)) ELSE CORR(IX,JY)=CORR(IX,JY)+WNDWT*WTA*(DATA(K)+(IX-XP(K))*V(K)+ 1 (JY-YP(K))*U(K)-P(IX,JY)) C WT CALCULATED ABOVE. COUNT(IX,JY)=COUNT(IX,JY)+WNDWT*WTA ENDIF C IF(F.EQ.0.)GO TO 237 C IF(IWINDX.EQ.1)THEN C A WIND CORRECTION IS TO BE MADE TO SOME ADJACENT POINTS. C NOTE THAT THIS CANNOT BE DONE WHEN RUNNING OPENMP BECAUSE C SPECIFIC LOCATIONS CAN BE MODIFIED IN MORE THAN ONE C THREAD. C WRITE(KFILDO,2295) 2295 FORMAT(/' ****IWINDX AND IWINDY CANNOT BE USED WHEN', 1 ' RUNNING WITH OPENMP.') GO TO 237 C C CORRECT ADJACENT POINTS IN X DIRECTION. C IF(IX-1.LE.0)GO TO 230 C NWIND(IX-1,JY)=NWIND(IX-1,JY)+1 C IF(NTYP.EQ.1)THEN CORR(IX-1,JY)=CORR(IX-1,JY)+ 1 WNDWT*F*(DATA(K)+(IX-1-XP(K))*V(K)+ 2 (JY-YP(K))*U(K)-P(IX-1,JY)) ELSEIF(NTYP.EQ.2)THEN CORR(IX-1,JY)=CORR(IX-1,JY)+ 1 WNDWT*WTA*F*(DATA(K)+(IX-1-XP(K))*V(K)+ 2 (JY-YP(K))*U(K)-P(IX-1,JY)) ELSE CORR(IX-1,JY)=CORR(IX-1,JY)+ 1 WNDWT*WTA*F*(DATA(K)+(IX-1-XP(K))*V(K)+ 2 (JY-YP(K))*U(K)-P(IX-1,JY)) COUNT(IX-1,JY)=COUNT(IX-1,JY)+WNDWT*WTA*F ENDIF C 230 IF(IX+1.GE.NX)GO TO 231 C NWIND(IX+1,JY)=NWIND(IX+1,JY)+1 C IF(NTYP.EQ.1)THEN CORR(IX+1,JY)=CORR(IX+1,JY)+ 1 WNDWT*F*(DATA(K)+(IX+1-XP(K))*V(K)+ 2 (JY-YP(K))*U(K)-P(IX+1,JY)) ELSEIF(NTYP.EQ.2)THEN CORR(IX+1,JY)=CORR(IX+1,JY)+ 1 WNDWT*WTA*F*(DATA(K)+(IX+1-XP(K))*V(K)+ 2 (JY-YP(K))*U(K)-P(IX+1,JY)) ELSE CORR(IX+1,JY)=CORR(IX+1,JY)+ 1 WNDWT*WTA*F*(DATA(K)+(IX+1-XP(K))*V(K)+ 2 (JY-YP(K))*U(K)-P(IX+1,JY)) COUNT(IX+1,JY)=COUNT(IX+1,JY)+WNDWT*WTA*F ENDIF C ENDIF C 231 IF(IWINDY.EQ.1)THEN C A WIND CORRECTION IS TO BE MADE TO SOME ADJACENT POINTS. C NOTE THAT THIS CANNOT BE DONE WHEN RUNNING OPENMP BECAUSE C SPECIFIC LOCATIONS CAN BE MODIFIED IN MORE THAN ONE C THREAD. WRITE(KFILDO,2295) GO TO 237 C C CORRECT ADJACENT POINTS IN Y DIRECTION. C IF(JY-1.LE.0)GO TO 232 C NWIND(IX,JY-1)=NWIND(IX,JY-1)+1 C IF(NTYP.EQ.1)THEN CORR(IX,JY-1)=CORR(IX,JY-1)+ 1 WNDWT*F*(DATA(K)+(IX-XP(K))*V(K)+ 2 (JY-1-YP(K))*U(K)-P(IX,JY-1)) ELSEIF(NTYP.EQ.2)THEN CORR(IX,JY-1)=CORR(IX,JY-1)+ 1 WNDWT*WTA*F*(DATA(K)+(IX-XP(K))*V(K)+ 2 (JY-1-YP(K))*U(K)-P(IX,JY-1)) ELSE CORR(IX,JY-1)=CORR(IX,JY-1)+ 1 WNDWT*WTA*F*(DATA(K)+(IX-XP(K))*V(K)+ 2 (JY-1-YP(K))*U(K)-P(IX,JY-1)) COUNT(IX,JY-1)=COUNT(IX,JY-1)+WNDWT*WTA*F ENDIF C 232 IF(JY+1.GE.NY)GO TO 237 C NWIND(IX,JY+1)=NWIND(IX,JY+1)+1 C IF(NTYP.EQ.1)THEN CORR(IX,JY+1)=CORR(IX,JY+1)+ 1 WNDWT*F*(DATA(K)+(IX-XP(K))*V(K)+ 2 (JY+1-YP(K))*U(K)-P(IX,JY+1)) ELSEIF(NTYP.EQ.2)THEN CORR(IX,JY+1)=CORR(IX,JY+1)+ 1 WNDWT*WTA*F*(DATA(K)+(IX-XP(K))*V(K)+ 2 (JY+1-YP(K))*U(K)-P(IX,JY+1)) ELSE CORR(IX,JY+1)=CORR(IX,JY+1)+ 1 WNDWT*WTA*F*(DATA(K)+(IX-XP(K))*V(K)+ 2 (JY+1-YP(K))*U(K)-P(IX,JY+1)) COUNT(IX,JY+1)=COUNT(IX,JY+1)+WNDWT*WTA*F ENDIF C ENDIF C IF(IX.EQ.951.AND.JY.EQ.527)THEN C ABOVE IS MIDDLETON ISLAND. WRITE(KFILDO,235)CCALL(K),LNDSEA(K),TLAPSE, 1 NTYP,ILS,WTLW,WT, 2 IX,JY,SEALND(IX,JY),CORR(IX,JY), 3 NCOUNT(IX,JY),COUNT(IX,JY) 235 FORMAT(' CCALL(K),LNDSEA(K),TLAPSE,', 1 'NTYP,ILS,WTLW,WT,', 2 'IX,JY,SEALND(IX,JY),CORR(IX,JY),', 3 'NCOUNT(IX,JY),COUNT(IX,JY)',/, 4 1X,A8,I3,F7.3,2I3,2F6.2,2I5,2F6.2,I4,F6.2) ENDIF C 237 CONTINUE 238 CONTINUE C !$OMP END PARALLEL DO C C***************************************************************** CCCC DO 239 JY=399,342,-1 CCCC WRITE(KFILDO,2390)(TELEV(IX,JY),IX=500,520) CCCC WRITE(KFILDO,2391)(SEALND(IX,JY),IX=500,520) CCCC 2390 FORMAT(/21F6.0) CCCC 2391 FORMAT(21F6.0) CCCC 239 CONTINUE C CCCC STOP 239 C****************************************************************** C 240 CONTINUE C C************************************************** C IF(LP.EQ.1.AND.NAREA.EQ.2)THEN C THIS OPERATES ONLY FOR ALASKA ON PASS 1. IT PRINTS C WATER POINTS NOT SET BY BOGUS5. C DO 2402 K=1,1000 C IF(LNDSEA(K).LE.3.AND.LTAGPT(K).NE.4.AND.DATA(K).LT.9998.5)THEN WRITE(KFILDO,2401)CCALL(K),XP(K),YP(K),DATA(K) 2401 FORMAT(' ****WATER STATION, NOT GRIDPOINT BOGUS--', 1 'CCALL(K),XP(K),YP(K),DATA(K) ',A8,3F10.4) ENDIF C 2402 CONTINUE C ENDIF C C************************************************** C D CALL TIMPR(KFILDO,KFILDO,'END CORBC5 LOOP 1 ') C C NOW CORRECT GRIDPOINT VALUES. THE WIND COUNTS HAVE C BEEN KEEP SEPARATELY IN NWIND( , ). EVEN THOUGH THERE C HAS TO BE A PRESSURE OB TO MAKE A WIND CORRECTION, A C WIND CORRECTION CAN BE MADE TO MORE THAN ONE POINT, C SO NWIND( , ) CAN EXCEED NCOUNT( , ). C C WITHOUT WINDS, A TYPE 3 CORRECTION CAN BE MADE FOR ANY C NCOUNT( , ) PROVIDED R GE 3. C C FOR R LT 3, FOR WINDS AND PRESSURE GE 990 MB, A TYPE 3 C CORRECTION CAN BE MADE FOR NCOUNT( , ) GE 2; C THIS ALLOWS UP TO 2 WIND CORRECTIONS. C C FOR R LT 3, FOR WINDS AND PRESSURE LT 990 MB, A TYPE 3 C CORRECTION CAN BE MADE FOR NCOUNT( , ) GT 3; C THIS ALLOWS UP TO 3 WIND CORRECTIONS, OR C FOR NCOUNT( , ) GE 2 AND NWIND( , ) = 0. THIS LOW C PRESSURE TEST IS TO KEEP 1 OR 2 WINDS FROM EXERTING C TOO MUCH INFLUENCE IN HURRICANE CASES. C !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(IX,JY) C THIS LOOP IN OPEN MP SEEMS TO SAVE NO TIME. EACH C GRIDPOINT IS DEALT WITH ONLY ONCE AT MOST, SO NO C SAVINGS. C DO 245 JY=1,NY DO 244 IX=1,NX C ************************************************************** C CCCC IF((IX.EQ.536.AND.JY.EQ.751.OR. CCCC 1 IX.EQ.537.AND.JY.EQ.751.OR. CCCC 2 IX.EQ.537.AND.JY.EQ.752).AND.LP.GE.5)THEN CCCC WRITE(KFILDO,2404)IX,JY,LP,IFCOR,IFULL(IX,JY),NTPY, CCCC 1 P(IX,JY),CORR(IX,JY),NCOUNT(IX,JY), CCCC 2 COUNT(IX,JY) CCCC 2404 FORMAT(/'AT 2404--IX, JY, LP, IFCOR, IFULL(IX,JY), NTPY,', CCCC 1 'P(IX,JY), CORR(IX,JY), NCOUNT(IX,JY),COUNT(IX,JY)',/, CCCC 2 6I5,2F10.3,I5,F10.3) CCCC ENDIF C ************************************************************** C IF(NCOUNT(IX,JY).EQ.0.OR.COUNT(IX,JY).EQ.0.)GO TO 244 C NO CORRECTION MADE IF NO DATA TO AFFECT IT. C CHECK ON COUNT( , ) ADDED 9/26/16. C IF(NTYP.LT.3)THEN C C THIS OPTION IS RARELY USED. C **************************************************** C *** NTYP = 1,2 *** C *** R = ANYTHING *** C *** NCOUNT = ANYTHING *** C *** WINDWT = ANYTHING *** C **************************************************** C C**************************************************************** C P(IX,JY)=P(IX,JY)+CORR(IX,JY)/(NCOUNT(IX,JY)+NWIND(IX,JY)) C ABOVE CORRECTION FOR TYPES 1 AND 2. C CCCD IF(IX.EQ.474.AND.JY.EQ.500)THEN CCCD WRITE(KFILDO,2406)IX,JY,P(IX,JY),CORR(IX,JY), CCCD 1 NCOUNT(IX,JY),NWIND(IX,JY) CCCD2406 FORMAT(/' AT 2406--IX,JY,P(IX,JY),CORR(IX,JY),', CCCD 1 'NCOUNT(IX,JY),NWIND(IX,JY)',2I5,2F8.2,2I5) CCCD ENDIF C ELSEIF(R.GE.3.AND.ILS.EQ.1)THEN C NOTE THAT THIS TEST USES R WITH NO OPTION FOR USING VRAD( ). C R AND VRAD( ) IN U155 WILL ALMOST ALWAYS BE > 3, SO THIS C OPTION WILL ALMOST ALWAYS BE USED WHEN A WATER/LAND C DISTINCTION IS TO BE MADE. AN R OR VRAD( ) < 3 C WOULD NOT MAKE SENSE WITH SMALL GRID SPACING. THIS WAS C ORIGINALLY WRITTEN FOR A GRID SPACING OF 80 KM, DOWN TO C MAYBE 10 KM. THE TEST ON ILS WAS ADDED 6/9/09 WHEN IT C WAS DISCOVERED THERE WAS A WATER LAND DISTINCTION EVEN C THOUGH ILS INDICATED OTHERWISE. THE CHANGE, THEN, WITH C ILS = 0 IS ALWAYS TYPE 3 WHEN NTYP = 3, NO MATTER THE C OTHER VARIABLES SUCH AS NCOUNT. C C NOTE BELOW WHEN COUNT( , ) = 0, THE DIVISION IS NOT MADE C AND P( , ) IS NOT CHANGED. THIS IS WHAT IS DESIRED. C COUNT( , ) SHOULD NOT NORMALLY = 0. C C************************************************************************* C THIS PORTION IS FOR ONLY ONE POINT FOR CORRECTION. C NCOUNT.EQ.1 AND WHEN ILS = 1 FOR WATER/LAND DISTINCTION. C************************************************************************* C IF(NCOUNT(IX,JY).EQ.1)THEN C CCCD IF(P(IX,JY).LT.1013.)THEN CCCD WRITE(KFILDO,241)P(IX,JY),IX,JY, CCCD 1 NCOUNT(IX,JY),NWIND(IX,JY) CCCD241 FORMAT(' TYPE 2 CORRECTION AT 241--', CCCD 1 'P(IX,JY),IX,JY,NCOUNT(IX,JY),NWIND(IX,JY) ', CCCD 2 F7.1,4I6) CCCD ENDIF C IF(LP.EQ.1.AND.SEALND(IX,JY).LE.3.)THEN C ABOVE TEST CHANGED FROM EQ 0 TO LE 3 ON 4/4/06 C C **************************************************** C *** LP = PASS NUMBER = 1 C *** NTYP = 3 *** C *** R GE 3 AND ILS = 1 *** C *** NCOUNT = 1 *** C *** WINDWT = ANYTHING *** C *** GRIDPOINT = WATER *** C **************************************************** C IF(COUNT(IX,JY).NE.0.)THEN P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) C THIS NEEDS TO BE REGULATED FOR BERING SEA. NOT SURE C YET WHAT IS BEST. D ELSE D WRITE(KFILDO,2414)IX,JY D2414 FORMAT('. ****GRIDPOINT IX,JY =',2I7,' HAS NO', D 1 ' CORRECTION. PROCEEDING.') ENDIF C C CHANGED NCOUNT( , ) TO COUNT( , ) 10/20/07 11:22 A.M. C CHANGED COUNT( , ) TO NCOUNT( , ) 10/20/07 9:47 A.M. C CHANGED NCOUNT( , ) TO COUNT( , ) 10/15/07 6:22 A.M. C***********CHANGED COUNT( , ) TO NCOUNT( , ) 10/12/07 6:00 A.M. C ABOVE CORRECTION IS TYPE 3. THIS ALLOWS A SINGLE C BUOY OR POINT ON THE COAST TO SPREAD TO THE FULL C RADIUS FOR THE FIRST PASS. (NOT TRUE WITH NCOUNT) C CCCCC ELSEIF(LP.GT.1.AND.SEALND(IX,JY).LE.3.)THEN CCCCC GO TO 244 C************TEST INSERTED 10/13/07 AT 1:51 P.M. C************ELIMINATED 10/20/07 8:34 A.M. C THIS LIMITS WATER CHANGES TO PASS 1. C ELSEIF(LP.EQ.1.AND.(MGUESS.EQ.1.OR.MGUESS.EQ.4))THEN C C **************************************************** C *** LP = PASS NUMBER = 1 C *** MGUESS = 1 OR 4 C *** NTYP = 3 *** C *** R GE 3 *** C *** NCOUNT = 1 *** C *** WINDWT = ANYTHING *** C *** GRIDPOINT = WATER OR LAND *** C **************************************************** C IF(COUNT(IX,JY).NE.0.)THEN P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) C ABOVE CORRECTION IS TYPE 3. THIS ALLOWS A SINGLE C POINT TO SPREAD TO THE FULL RADIUS FOR THE FIRST C PASS WHEN A CONSTANT OR AVERAGE IS USED AS FIRST C GUESS. INCLUDES SHEMYA CORRECTION. D ELSE D WRITE(KFILDO,2414)IX,JY ENDIF ELSE C C **************************************************** C *** LP = PASS NUMBER = 1 *** C *** LAND *** C *** FG = 2 OR 3 *** C *** LP = PASS NUMBER > 1 *** C *** NTYP = 3 FOR ALASKA (NAREA = 2) *** C *** NTYP = 2 FOR CONUS, HAWAII, PR (NAREA NE 2) *** C *** R GE 3 *** C *** NCOUNT = 1 *** C *** WINDWT = ANYTHING *** C *** GRIDPOINT = WATER *** C **************************************************** C IF(NAREA.EQ.2.AND.LP.EQ.1)THEN C NOTE: TEST ABOVE FOR LP.EQ.1 MADE 3/4/08 IF(COUNT(IX,JY).NE.0.)THEN P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) C THIS MUST BE TYPE 3 FOR SHEMYA TO BE CORRECTED BY ADAK C OR ATKA. D ELSE D WRITE(KFILDO,2414)IX,JY ENDIF C ELSEIF(NAREA.EQ.2.AND.LP.EQ.NPASS)THEN C NOTE: ABOVE WAS ADDED 4/1/19 FOR EXACT FIT FOR ALASKA C ON LAST PASS. VARIABE RADIUIS HAS BEEN ADJUSTED BY C DDRAD2. MAY BE IMPLEMENTED FOR OTHER AREAS LATER. IF(COUNT(IX,JY).NE.0.)THEN P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) ENDIF ELSE P(IX,JY)=P(IX,JY)+CORR(IX,JY)/NCOUNT(IX,JY) C THIS IS TYPE TWO FOR LAND AND ONLY ONE STATION. ENDIF C C IF THIS IS NOT PRESSURE, NWIND( , ) = 0. C ENDIF C C************************************************************************* C THIS PORTION IS FOR MORE THAN ONE POINT FOR CORRECTION. C NCOUNT > 1. C************************************************************************* C ELSE C CCCD IF(P(IX,JY).LT.1013.)THEN CCCD WRITE(KFILDO,242)P(IX,JY),IX,JY, CCCD 1 NCOUNT(IX,JY),NWIND(IX,JY) CCCD242 FORMAT(' TYPE 3 CORRECTION--', CCCD 1 'P(IX,JY),IX,JY,NCOUNT(IX,JY),NWIND(IX,JY) ', CCCD 2 F7.1,4I6) CCCD ENDIF C C **************************************************** C *** NTYP = 3 *** C *** R GE 3 *** C *** NCOUNT > 1 *** C *** WINDWT = ANYTHING *** C **************************************************** C C THIS MAKES A WATER FOR PASS 1 = TYPE 3, BUT FOR C OTHER PASSES TYPE 2. THIS IS FOR ALASKA, BUT MAY C WORK FOR CONUS. C IF(SEALND(IX,JY).LE.3)THEN C IF(LP.EQ.1)THEN c IF(COUNT(IX,JY).NE.0.)THEN P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) D ELSE D WRITE(KFILDO,2414)IX,JY ENDIF C ELSEIF(NAREA.EQ.2)THEN C THIS DIFFERENTIATION BETWEEN ALASKA AND CONUS C INSERTED 3_7_08. IT WAS PROBABLY THIS WAY FOR CONUS C ORIGINALLY BUT MODIFIED FOR ALASKA. P(IX,JY)=P(IX,JY)+CORR(IX,JY)/NCOUNT(IX,JY) ELSE IF(COUNT(IX,JY).NE.0.)THEN C CCCC IF(IX.EQ.1172.AND.JY.EQ.2145)THEN CCCCC ABOVE IS NEAR BGRUT--BADGER ISLAND CCCC IF(IX.EQ.794.AND.JY.EQ.969)THEN CCCCC ABOVE IS NEAR WPKS2 IN THE BLACK HILLS CCCC WRITE(KFILDO,2424)IX,JY,P(IX,JY),CORR(IX,JY), CCCC 1 COUNT(IX,JY) CCCC 2424 FORMAT(/' AT 2456 IN CORBC5--IX,JY,P(IX,JY),', CCCC 1 'CORR(IX,JY),COUNT(IX,JY)',2I6,3F10.3) CCCC ENDIF C IF(IFCOR.EQ.0)THEN C THIS IS THE USUAL SITUATION. P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) ELSEIF(IFCOR.EQ.1)THEN C IF(IFULL(IX,JY).EQ.0)THEN C NO FULL WT STATIONS CONTIRBUTING, SO MAKE C LESS CORRECTION. P(IX,JY)=P(IX,JY)+CORR(IX,JY)/NCOUNT(IX,JY) ELSE P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) ENDIF C ELSE C THIS IS FOR IFCOR = 2. IF(IFULL(IX,JY).EQ.0.AND.CORR(IX,JY).LT.0.)THEN C THIS IS FOR LESS THAN FULL CORRECTION C FOR WIND SPEED/GUSTS WHEN CORRECTION IS C NEGATIVE. P(IX,JY)=P(IX,JY)+CORR(IX,JY)/NCOUNT(IX,JY) ELSE P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) ENDIF C ENDIF C ENDIF C ENDIF C ELSE C C**************************************************************** CCC IF(IX.EQ.474.AND.JY.EQ.500)THEN CCC WRITE(KFILDO,2425)IX,JY,P(IX,JY),CORR(IX,JY), CCC 1 NCOUNT(IX,JY),NWIND(IX,JY),COUNT(IX,JY) CCC 2425 FORMAT(/' AT 2425--IX,JY,P(IX,JY),CORR(IX,JY),', CCC 1 'NCOUNT(IX,JY),NWIND(IX,JY),COUNT(IX,JY)', CCC 2 2I5,2F8.2,2I5,F8.2) CCC ENDIF C**************************************************************** C IF(COUNT(IX,JY).NE.0.)THEN C IF(LP.GE.NPASS.AND.NAREA.EQ.2.AND. 1 NCOUNT(IX,JY)/COUNT(IX,JY).GT.5.)THEN C C THE CORRECTION NREA TO NAREA MADE 12/14/14; IT C HAD BEEN INTRODUCED BEFORE THE 6/20/14 VERSION. C THE ERROR PROBABLY CAUSED NO PROBLEM WHEN NOT C RUNNING FOR ALASKA BECAUSE NREA WOULD NOT C LIKELY = 2. C C THIS LIMITS THE CORRECTION ON THE LAST PASS C WHEN ALL THE STATIONS ARE NEAR THE EDGE OF THE C R RADIUS CIRCLE. (MIDDLETON ISLAND CORRECTION) C FOR OBS WIND SPEED, WHEN MANY WINDS WERE MESONET C WITH LOW WEIGHTS, THIS WAS BEING INVOKED OFTEN. C (CHANGED GE 4 TO GE NPASS 1/5/14) C (CHANGED GE NPASS TO GE NPASS+1 1/9/14; NEGATES) C (CHANGED BACK TO NPASS AND ADDED NAREA.EQ.2; C CHECK WAS PUT IN FOR ALASKA, SO LIMIT TO THERE.) P(IX,JY)=P(IX,JY)+CORR(IX,JY)/NCOUNT(IX,JY) C ELSE C IF(IFCOR.EQ.0)THEN C THIS IS THE USUAL SITUATION. C IF(LP.EQ.NPASS.AND.NCOUNT(IX,JY).EQ.2.AND. 1 NAREA.NE.2)THEN C THIS MODIFIES CORRECTION WHEN C LP GE NPASS AND NCOUNT = 2 (NCOUNT = 1 TAKEN C CARE OF ABOVE). (THIS GOVERNOR ADDED 5/16/09 C TRYING TO REMOVE REFLECTION SPOTS.) (THE C ALASKA EXCEPTION ADDED 4/23/19. WITH SPOTRM C THIS IS PROBABLY NOT NEEDED. C P(IX,JY)=P(IX,JY)+CORR(IX,JY)/ 1 ((NCOUNT(IX,JY)+COUNT(IX,JY))/2.) ELSE P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) C COUNT( , ) NE 0 CHECKED ABOVE. ENDIF C ELSEIF(IFCOR.EQ.1)THEN C IF(IFULL(IX,JY).EQ.0)THEN C NO FULL WT STATIONS CONTIRBUTING, SO MAKE C LESS CORRECTION. P(IX,JY)=P(IX,JY)+CORR(IX,JY)/NCOUNT(IX,JY) ELSE C IF(LP.EQ.NPASS.AND.NCOUNT(IX,JY).EQ.2)THEN C THIS MODIFIES CORRECTION WHEN C LP GE NPASS AND NCOUNT = 2 (NCOUNT = 1 TAKEN C CARE OF ABOVE). (THIS GOVERNOR ADDED 5/16/09 C TRYING TO REMOVE REFLECTION SPOTS.) C P(IX,JY)=P(IX,JY)+CORR(IX,JY)/ 1 ((NCOUNT(IX,JY)+COUNT(IX,JY))/2.) ELSE P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) C COUNT( , ) NE 0 CHECKED ABOVE. ENDIF C ENDIF C ELSE C THIS IS FOR IFCOR = 2. IF(IFULL(IX,JY).EQ.0.AND.CORR(IX,JY).LT.0.)THEN C THIS IS FOR LESS THAN FULL CORRECTION C FOR WIND SPEED/GUSTS WHEN CORRECTION IS C NEGATIVE. P(IX,JY)=P(IX,JY)+CORR(IX,JY)/NCOUNT(IX,JY) ELSE C IF(LP.EQ.NPASS.AND.NCOUNT(IX,JY).EQ.2)THEN C THIS MODIFIES CORRECTION WHEN C LP GE NPASS AND NCOUNT = 2 (NCOUNT = 1 TAKEN C CARE OF ABOVE). (THIS GOVERNOR ADDED 5/16/09 C TRYING TO REMOVE REFLECTION SPOTS.) C (CHANGED GE 4 TO GE NPASS 1/4/14) C (CHANGED GE.NPASS TO GE.NAPSS-1 6/20/14) C (CHANGED GE NAPSS-1 TO GE NAPSS 6/26/14) C P(IX,JY)=P(IX,JY)+CORR(IX,JY)/ 1 ((NCOUNT(IX,JY)+COUNT(IX,JY))/2.) ELSE P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) C COUNT( , ) NE 0 CHECKED ABOVE. ENDIF C ENDIF C ENDIF C ENDIF C ENDIF C**************************************************************** CCC IF(IX.EQ.474.AND.JY.EQ.500)THEN CCC WRITE(KFILDO,2426)IX,JY,P(IX,JY),CORR(IX,JY), CCC 1 NCOUNT(IX,JY),NWIND(IX,JY),COUNT(IX,JY) CCC 2426 FORMAT(/' AT 2426--IX,JY,P(IX,JY),CORR(IX,JY),', CCC 1 'NCOUNT(IX,JY),NWIND(IX,JY),COUNT(IX,JY)', CCC 2 2I5,2F8.2,2I5,F8.2) CCC ENDIF C**************************************************************** C ENDIF C ENDIF C ELSEIF(WNDWT.NE.0)THEN C THIS IS ONLY FOR SEA LEVEL PRESSURE ANALYSIS WITH WIND. C WRITE(KFILDO,9995)WNDWT,COUNT(IX,JY) 9995 FORMAT(' AT 9995--WNDWT,COUNT( , )--',2F10.3) C IF(COUNT(IX,JY).NE.0.)THEN C IF(NCOUNT(IX,JY).GT.NWIND(IX,JY).AND. 1 ABS(CORR(IX,JY)/COUNT(IX,JY)).LE.5.)THEN C D IF(NWIND(IX,JY).GT.0)THEN D IF(IX.EQ.474.AND.JY.EQ.500) D 1 WRITE(KFILDO,243)P(IX,JY),IX,JY, D 2 NCOUNT(IX,JY),NWIND(IX,JY) D243 FORMAT(' TYPE 3 CORRECTION WITH WIND--', D 1 'P(IX,JY),IX,JY,NCOUNT(IX,JY),NWIND(IX,JY) ', D 2 F7.1,4I6) D ENDIF C C **************************************************** C *** NTYP = 3 *** C *** R < 3 *** C *** NCOUNT = ANYTHING *** C *** WINDWT > 0 *** C *** SPECIAL WIND CHECK MET *** C **************************************************** C P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) C ABOVE CORRECTION IS TYPE 3. C D IF(NWIND(IX,JY).GT.0)THEN D IF(IX.EQ.474.AND.JY.EQ.500) D 1 WRITE(KFILDO,243)P(IX,JY),IX,JY, D 2 NCOUNT(IX,JY),NWIND(IX,JY) D ENDIF C ELSE P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) C ABOVE CORRECTION IS TYPE 3. ENDIF C ELSE C D IF(NWIND(IX,JY).GT.0)THEN D WRITE(KFILDO,2430)P(IX,JY),IX,JY, D 1 NCOUNT(IX,JY),NWIND(IX,JY) D2430 FORMAT(' TYPE 2 CORRECTION WITH WIND--', D 1 'P(IX,JY),IX,JY,NCOUNT(IX,JY),NWIND(IX,JY) ', D 2 F7.1,4I6) D ENDIF C C **************************************************** C *** NTYP = 3 *** C *** R < 3 *** C *** NCOUNT = ANYTHING *** C *** WINDWT > 0 *** C *** SPECIAL WIND CHECK NOT MET *** C **************************************************** C P(IX,JY)=P(IX,JY)+CORR(IX,JY)/ 1 (NCOUNT(IX,JY)+NWIND(IX,JY)) C ABOVE CORRECTION FOR TYPE 2. C D IF(NWIND(IX,JY).GT.0)THEN D WRITE(KFILDO,2430)P(IX,JY),IX,JY, D 1 NCOUNT(IX,JY),NWIND(IX,JY) D ENDIF C ENDIF C ELSE C **************************************************** C *** NTYP = 3 *** C *** R < 3 OR ILS = 0 *** C *** NCOUNT = ANYTHING *** C *** WNDWT = 0 *** C **************************************************** C IF(IFCOR.EQ.0)THEN C THIS IS THE USUAL SITUATION. C IF(COUNT(IX,JY).NE.0.)THEN P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) ENDIF C ELSEIF(IFCOR.EQ.1)THEN C IF(IFULL(IX,JY).EQ.0)THEN C NO FULL WT STATIONS CONTIRBUTING, SO MAKE C LESS CORRECTION. P(IX,JY)=P(IX,JY)+CORR(IX,JY)/NCOUNT(IX,JY) ELSE C IF(COUNT(IX,JY).NE.0.)THEN P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) ENDIF C ENDIF C ELSE C THIS IS FOR IFCOR = 2. C IF(IFULL(IX,JY).EQ.0.AND.CORR(IX,JY).LT.0.)THEN C THIS IS FOR LESS THAN FULL CORRECTION C FOR WIND SPEED/GUSTS WHEN CORRECTION IS C NEGATIVE. P(IX,JY)=P(IX,JY)+CORR(IX,JY)/NCOUNT(IX,JY) ELSE C IF(COUNT(IX,JY).NE.0.)THEN P(IX,JY)=P(IX,JY)+CORR(IX,JY)/COUNT(IX,JY) ENDIF C ENDIF C ENDIF C C ENDIF C CCC IF(JY.EQ.1556)THEN CCC WRITE(KFILDO,2439) CCC 1 NTYP,ILS, CCC 2 IX,JY,SEALND(IX,JY),CORR(IX,JY), CCC 3 NCOUNT(IX,JY),COUNT(IX,JY),P(IX,JY) CCC 2439 FORMAT(' ', CCC 1 'NTYP,ILS, ', CCC 2 'IX,JY,SEALND(IX,JY),CORR(IX,JY),', CCC 3 'NCOUNT(IX,JY),COUNT(IX,JY),P(IX,JY)',/, CCC 4 19X,2I3,12X,2I5,2F6.2,I4,2F6.2) CCC ENDIF C 244 CONTINUE 245 CONTINUE C !$OMP END PARALLEL DO C C****************************************************************** CCCC WRITE(KFILDO,2450)NAPSS,(IX,P(IX,653),IX=620,676) CCCC 2450 FORMAT(/' AT 2450 IN CORBC5, PASS =',I4,' PAMO CROSSCECTION', CCCC 1 ' (IX,P(IX,653),IX=620,676)'/(5(I12,F8.2))) C****************************************************************** C IER=0 C IER WILL BE UNDEFINED COMING OUT OF OPEN MP LOOP. SET C TO ZERO TO INDICATE A GOOD RETURN. C CALL TIMPR(KFILDO,KFILDO,'END CORBC5 ') C 500 RETURN END