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 AT SOME POINTISABLED
C MAY 2019 GLAHN ADDED NBASTA TO CALL, DIAGNOSTIC 222
C FEBRUARY 2020 GLAHN CORRECTED ERROR: IBKPN USED IN CALL
C TO ITRPSX VICE IBKPNX
C FEBRUARY 2020 GLAHN ADDED TO MAKE EXACT FIT ON LAST PASS
C FEBRUARY 2020 GLAHN CHANGED "IF(IVRAD.EQ.1" TO
C "IF(IVRAD.GE.1" BELOW DO 240 LOOP
C MARCH 2020 GLAHN CHANGED DIAGNOSTIC 8765; CHECK ON
C COUNT(IX,JY) MADE DEPENDENT ON NRYP
C AT 2504
C MARCH 2020 GLAHN ADDED DIAGNOSTIC AND STOP AT 2280
C OCTOBER 2002 GHIRARDELLI MODIFIED FORMAT 100 FOR CORRECT
C TYPE
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 = 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 2 = SAME AS 1 EXCEPT ON LAST PASS ALSO MAKES
C TYPE 3 CORRECTION FOR ONLY ONE STATION
C WHEN DDRAD2 HAS BEEN CALLED.
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
WRITE(KFILDO,100)NSTA,NBASTA,IVRAD,IALGOR,ELCORR
C 1 2 3 4 5 6 7 X
C 100 FORMAT(/' IN CORBC5 AT 100--NSTA,NBASTA,IVRAD,IALGOR,ELCORR',5I10)
100 FORMAT(/' IN CORBC5 AT 100--NSTA,NBASTA,IVRAD,IALGOR,ELCORR',4I10,
1 F8.2)
C
CCCC WRITE(KFILDO,101)(K,IVRAD,CCALL(K),DATA(K),LTAG(K),LTAGPT(K),
CCCC 1 QUALST(K),K=1,NSTA)
CCCC 101 FORMAT(' AT 101(K,IVRAD,CCALL(K),DATA(K),LTAG(K),LTAGPT(K),',
CCCC 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.GE.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. DISABLED LAST PASS OPTION.
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 IBKPN,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 IBKPN,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
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(IX.EQ.1220.AND.JY.EQ.450)THEN
CCCC WRITE(KFILDO,8765)K,CCALL(K),IX,JY,NTYP,WTLW,CORR(IX,JY),
CCCC 1 NCOUNT(IX,JY),COUNT(IX,JY),DATA(K),BBPLUS,
CCCC 2 QUALST(K)
CCCC 8765 FORMAT(/' AT 8765--K,CCALL(K),IX,JY,NTYP,WTLW,CORR(IX,JY),',
CCCC 1 'NCOUNT(IX,JY),COUNT(IX,JY),DATA(K),BBPLUS,QUALST(K)',
CCCC 2 /,I5,2X,A8,3I5,2F8.2,I4,4F8.2)
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.1220.AND.JY.EQ.1269)THEN
C ABOVE IS CWCF.
WTOTAL=WTLW*WTA*QUALST(K)
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),VRAD(K)
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.1220.AND.JY.EQ.1269)THEN
C ABOVE IS CWCF.
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.475.AND.JY.EQ.503.)THEN
CCCC WRITE(KFILDO,2404)IX,JY,LP,IFCOR,IFULL(IX,JY),NTYP,
CCCC 1 P(IX,JY),CORR(IX,JY),NCOUNT(IX,JY),
CCCC 2 COUNT(IX,JY),R,ILS,SEALND(IX,JY)
CCCC 2404 FORMAT(/'AT 2404--IX, JY, LP, IFCOR, IFULL(IX,JY), NTYP,',
CCCC 1 'P(IX,JY), CORR(IX,JY), NCOUNT(IX,JY),COUNT(IX,JY)',
CCCC 2 'R,ILS,SEALND(IX,JY)',/,
CCCC 3 6I5,2F10.3,I5,F10.3,F6.2,I3,F4.0)
CCCC ENDIF
C
**************************************************************
C
IF(NTYP.EQ.3.AND.(NCOUNT(IX,JY).EQ.0.OR.COUNT(IX,JY).EQ.0.))THEN
GO TO 244
ELSEIF(NCOUNT(IX,JY).EQ.0)THEN
GO TO 244
ENDIF
C NO CORRECTION MADE IF NO DATA TO AFFECT IT.
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
D IF(IX.EQ.474.AND.JY.EQ.500)THEN
D WRITE(KFILDO,2406)IX,JY,P(IX,JY),CORR(IX,JY),
D 1 NCOUNT(IX,JY),NWIND(IX,JY)
D2406 FORMAT(/' AT 2406--IX,JY,P(IX,JY),CORR(IX,JY),',
D 1 'NCOUNT(IX,JY),NWIND(IX,JY)',2I5,2F8.2,2I5)
D 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
C
ELSEIF(LP.EQ.NPASS.AND.IVRAD.EQ.2)THEN
C NOTE: ABOVE WAS ADDED 2/18/20 FOR EXACT FIT FOR
C ON LAST PASS. VARIABE RADIUS HAS BEEN ADJUSTED BY
C DDRAD2. MAY BE IMPLEMENTED FOR OTHER AREAS LATER.
C MADE CONTINGENT ON DDRAD2 (IVRAD=2) SO IT WILL NOT
C AFFECT OTHER ANALYSES.
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