SUBROUTINE LAPSE(KFILDO,KFILLP,IP14,CCALL,NAME,LNDSEA,ELEV,
1 NOPAR,LOCPAR,XDATA,XLAPSE,MPAIRS,
2 LTAGPT,NSTA,ND1,
3 NXL,NYL,XPL,YPL,R,XP,YP,
4 ELCORR,NPASS,WTRUNL,NORUNS,LEVELS,
5 IALOC,ADIST,AELEV,ND13,EXCLUD,NAREA,
6 SEALND,TELEV,NXE,NYE,MESHE,P,NX,NY,MESH,
7 ID,IBKPN,LPNO,LAPFG,MGUESS,N4P,ISTOP,IER)
C
C MAY 2005 GLAHN MDL MOS-2000
C MAY 2005 GLAHN ADDED IP14 FOR COMPUTED LAPSE RATES
C ADDED ELEV( ) TO CALL
C MAY 2005 GLAHN CHANGED COMPUTATION OF LAPSE
C JUNE 2005 GLAHN MODS TO OUTPUT PRINT
C JUNE 2005 GLAHN ADDED PRINT OF ACTUAL PAIRS USED
C JUNE 2005 GLAHN MODIFIED TO WRITE LAPSE RATES ONLY
C ONCE
C JULY 2005 GLAHN MODIFIED DIAGNOSTIC PRINT
C AUGUST 2005 GLAHN MODIFIED PRINT AT 210
C AUGUST 2005 GLAHN MODIFIED USE OF LNDSEA( )
C AUGUST 2005 GLAHN INSERTED IF(IALOC(J).EQ.999999)
C TEST IN DO 195 LOOP
C SEPTEMBER 2005 GLAHN REVISED DIAGNOSTICS
C OCTOBER 2005 GLAHN ADDED KFILLP TO CALL AND WHEN = 0,
C SET XLAPSE( ) = 0
C OCTOBER 2005 GLAHN ADDED NBOTH
C OCTOBER 2005 GLAHN ADDED ELCORR( ) AND NPASS TO CALL
C MARCH 2006 GLAHN ADDED MPAIRS( ) TO CALL
C APRIL 2006 GLAHN ADDED NORUNS WTRUNL( ); INCREASED
C XDATA(NSTA) TO XDATA(ND1,6)
C APRIL 2006 GLAHN ADDED SUMLPS, SQLPS, NTOTAL, AVGLPS,
C SDLPS
C APRIL 2006 GLAHN MADE SUMLPS, SQLPS, AVGLPS, AND SDLPS
C REAL*8
C APRIL 2006 GLAHN CHECKED IP14 NE 0 BEFORE WRITING
C JUNE 2006 GLAHN ADDED IBKPN TO CALL
C SEPTEMBER 2006 GLAHN ADDED LPNO TO CALL AND ITS CAPABILITY;
C ADDED KZERO, KMINUS, KPLUS
C NOVEMBER 2006 GLAHN CHANGED ELSEIF(NOPAR(K).EQ.9999) TO
C ELSEIF(NOPAR(K).EQ.999999) ABOVE 123;
C CHANGED IF(NOPAR((K)).EQ.9999)THEN
C TO IF(NOPAR((K)).EQ.999999) AT DO 215;
C ADDED XLAPSE(K)=0. BELOW 1985
C NOVEMBER 2006 GLAHN MODIFIED TO ACCOMMODATE LAPSE FROM
C FIRST GUESS.
C NOVEMBER 2006 GLAHN CHANGED ELSEIF(NOPAR(K).EQ.999999) TO
C ELSEIF(NOPAR(K).EQ.9999) ABOVE 123;
C CHANGED IF(NOPAR((K)).EQ.999999)THEN
C TO IF(NOPAR((K)).EQ.9999) AT DO 215
C DECEMBER 2006 GLAHN ADDED HMINUS, HPLUS; MOVED PRINT
C SECTION BELOW DO 195; SET XLAPSE( )
C = 0. BELOW 117; ADDED NINT TO CHECK ON
C 9999 2 PLACES BELOW DO 194
C FEBRUARY 2007 GLAHN CHECK ON IBKPN AND KFILLP AT 103
C MAY 2007 GLAHN CORRECTED WRITE TO FORMAT 1985
C JUNE 2007 GLAHN MODIFIED FOR PROBABILITY LEVELS
C JULY 2007 GLAHN CORRECTED HMIMUS TO HMINUS IN WRITE
C SEPTEMBER 2007 GLAHN ADDED DIAGNOSTIC D1170
C NOVEMBER 2007 GLAHN REMOVED COMMENT ABOUT MGUESS NOT BEING
C KNOWN ABOVE DO 110 LOOP; SPELLING
C DECEMBER 2007 GLAHN ADDED ISTOP(6) CAPABILITY; SPELL CHECK
C JANUARY 2008 COSGROVE CHANGED FORMAT 207 BECAUSE
C IT WAS 73 CHARACTERS. FOR IBM COMPILE.
C AUGUST 2008 GLAHN CHECKED FOR LAPFG = 0 OR 1; COMMENTS
C SEPTEMBER 2008 GLAHN CHANGED ELSEIF(LAPFG.EQ.2)THEN TO
C ELSEIF(LAPFG.EQ.1)THEN
C NOVEMBER 2009 GLAHN ADDED LLMT TO CALL
C APRIL 2010 GLAHN CHANGED PRINTING TO IP14 FROM FIRST TO
C FIRST AND SECOND ENTRIES
C MARCH 2011 GLAHN ELIMINATED LLMT AND ADDED ID( ) TO
C CALL, COMMENTS, MINOR CHANGE TO 205
C MARCH 2011 GLAHN ADDED EXCLUD TO CALL
C MARCH 2011 GLAHN MOVED SETTING LLMT UP BEFORE LLMTTS;
C REINSTATED DATA STATEMENT FOR LPNO
C AUGUST 2011 GLAHN /D ON STATEMENT 100
C MAY 2015 GLAHN CHANGED MAX LAPSE FOR CIG FROM 3.28
C TO .0328; ADDED ILAP
C JUNE 2015 GLAHN ADDED LAPFG = 5 CAPABILITY
C MAY 2018 GLAHN CHANGED 7280000 (OBS CIG) AND 7281000
C (OBS VIS) TO 708000 AND 7081000 IN
C TESTS TO SET MAX/MIN LAPSE; ADDED
C DIAGNOSTICS FOR HI/LO LAPSE; ADDED
C DIAGNOSTICS FOR INCONSISTENT SETTINGS
C AND RETURNED IER = 777 TO TRIGGER A
C MAJOR ERROR.
C MAY 2018 GLAHN SET ILAP = 1 FOR LAMP VCST VIS PROBS
C DECEMBER 2018 GLAHN INSERTED TEST ON 22808000 AT 196
C ADDED LTAGPT( ) TO CALL
C APRIL 2019 GLAHN ADDED (ID(1)/100).EQ.2280602 TO LIMIT
C LAPSE FOR ALASKA CIG PROB BELOW 999
C
C PURPOSE
C TO COMPUTE A LAPSE RATE FOR EACH STATION OF THE VARIABLE
C BEING ANALYZED. EACH STATION HAS A LIST OF STATIONS, EACH
C OF WHICH IT USES AS A PAIR IN COMPUTING THE LAPSE RATE
C IN UNITS OF THE VARIABLE BEING ANALYZED PER METER.
C THE LISTS OF STATIONS HAVE BEEN COMPUTED BY U174.
C THE LAPSE RATES ARE COMPUTED BY SUMMING THE VARIABLE
C DIFFERENCES (BASE - PAIR) AND THE ELEVATION
C DIFFERENCES (TOP - BOTTOM = ABSOLUTE VALUE OF DIFFERENCE),
C AND DIVIDING. THE ELEVATION DIFFERENCES ARE IN AELEV( ).
C NOTE THIS IS NOT COMPUTING EACH LAPSE RATE AND AVERAGING;
C IF THAT WERE TO BE DONE, AN AVERAGE WEIGHTED BY THE
C INDIVIDUAL DISTANCES WOULD BE APPROPRIATE. OF THE LIST
C OF PAIRS, ONLY LPNO*NORUNS ARE USED.
C
C LAPSE COMPUTATION IS: SUM OF ELEMENT VALUE OF THE
C STATION AT THE HIGHEST ELEVATION MINUS ITS LOWER PAIR
C DIVIDED BY THE SUM OF THE HIGHER HEIGHT OF THE TWO
C MINUS THE LOWER HEIGHT (THIS LATTER IS JUST THE
C ABSOLUTE VALUE OF THE DIFFERENCE).
C
C ADIST( ) IS NOT USED. PROBABLY CAN'T AFFORD TO LET ONE
C PAIR AFFECT THE LAPSE TOO MUCH.
C
C XDATA( ,L,J) CAN HOLD UP TO 5 SETS OF VALUES, EACH FROM
C A DIFFERENT MODEL RUN (VERIFYING AT THE SAME TIME)
C (L=2,6) AND UP TO J PROBABILITY LEVELS.
C EACH VALUE IS USED IN COMPUTING THE LAPSE.
C A VALUE COULD BE MISSING FOR ONE RUN AND NOT ANOTHER.
C ALL CYCLES AND PROBABILITY LEVELS ARE USED IN COMPUTING
C THE LAPSE TO PUT INTO XDATA( ,1,1) FOR ANALYSIS.
C
C WTRUNL( ) IS NOT CURRENTLY USED IN COMPUTING THE LAPSE
C RATE. THIS IS FOR EFFICIENCY. IF ONLY ONE RUN IS USED,
C OR THE WEIGHTS ARE ALL THE SAME, USING THE WTRUN( )
C WOULDN'T MATTER. IT WOULD BE EASY TO IMPLEMENT.
C
C THE SMALLEST LAPSE ALLOWED IS HMINUS, AND THE LARGEST
C IS HPLUS. THESE WERE UNIVERSALLY SET TO -.1 AND +.1
C PRIOR TO MARCH 2011 AND PERTAINED PRIMARILY TO
C TEMPERATURE. THEY CAN NOW BE SET BASED ON THE INPUT
C ID( ) WHICH SEEMED NECESSARY FOR CEILING HEIGHT BECAUSE
C THE DATA POINTS WITHIN A REGION OVER WHICH THE LAPSE
C IS COMPUTED MAY VARY A LOT AND BE OUTSIDE THE .1 RANGE.
C ALSO WITH THIS CHANGE, LLMT IS SET INTERNALLY RATHER
C THAN BEING IN U405 FOR INPUT.
C
c IF A PARTICULAR VALUE CANNOT BE USED IN THE LAPSE
C CALCULATIONS (E.G., 130 FOR UNLIMITED CEILING), THE
C VALUE COMES IN AS EXCLUD.
C
C DATA SET USE
C KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT)
C IP14 - UNIT NUMBER FOR WRITING COMPUTED LAPSE RATES.
C (OUTPUT)
C
C VARIABLES
C KFILDO = UNIT NUMBER OF OUTPUT (PRINT) FILE. (INPUT)
C KFILLP = UNIT NUMBER FOR READING STATION PAIRS.
C WHEN = 0, XLAPSE( ) SET = 0. (INPUT)
C IP14 = UNIT NUMBER FOR WRITING COMPUTED LAPSE
C RATES WHEN NON ZERO. (INPUT)
C CCALL(K) = 8-CHARACTER STATION CALL LETTERS (K=1,NSTA).
C (CHARACTER*8) (INPUT)
C NAME(K) = 20-CHARACTER STATION NAME (K=1,NSTA).
C (CHARACTER*20) (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) = ELEVATION OF STATIONS (K=1,NSTA). (INPUT)
C NOPAR(K) = NUMBER OF PAIRS FOR STATION K (K=1,NSTA).
C (INPUT)
C LOCPAR(K) = WHERE IN IALOC( ), ADIST( ), AND AELEV( ) THE
C DATA FOR STATION CCALL(K) STARTS (K=1,NSTA).
C LOCPAR(K) POINTS TO THE LOCATION IN IALOC( )
C WHERE THE PAIRS FOR STATION K STARTS. EACH
C OF THE CONTIGUOUS VALUES IN IALOC( ) POINTS
C TO A PAIR LOCATION IN CCALL( ) AND
C XDATA( , , ). (INPUT)
C XDATA(K,J,L) = HOLDS THE DATA TO ANALYZE (K=1,NSTA)
C (J=1,NORUNS) (L=1,LEVELS).
C DATA ARE READ INTO COLUMNS J=2,NORUNS. (INPUT)
C XLAPSE(K) = CALCULATED LAPSE RATE IN UNITS OF THE VARIABLE
C BEING ANALYZED PER M. (K=1,KSTA). THIS IS
C NEVER 9999, BUT RATHER 0 WHEN THERE IS NO
C LAPSE RATE CALCULATED. (OUTPUT)
C MPAIRS(K) = THE ACTUAL NUMBER OF PAIRS USED IN THE
C CALCULATION (K=1,NSTA). IT CAN TAKE THE
C FOLLOWING VALUES:
C 1) 5555 FOR SOME PAIRS BUT LT 4,
C 2) 7777 STATION IS OUTSIDE ANALYSIS BY R (NOTE
C THIS MAY BE A LARGER AREA THAN ACTUALLY
C USED,
C 3) A LEGITIMATE NUMBER OF PAIRS USED IN THE
C CALCULATION, OR
C 4) 9999 FOR OTHER SITUATIONS (NO PAIR LIST, OB
C MISSING, OR NO USABLE PAIRS). (OUTPUT)
C LTAGPT(K) = FOR STATION K (K=1NSTA),
C 1 = AUGMENTED DATA (FIRST PASS)
C 2 = AUGMENTED DATA (2ND OR LATER PASS)
C 3 = BOGUS DATA FROM BOGUS
c 4 = BOGUS DATA FROM BOGUSG
C 0 = EVERYTHING ELSE
C (INPUT)
C NSTA = NUMBER OF STATIONS OR LOCATIONS BEING DEALT
C WITH. (INPUT)
C ND1 = MAXIMUM NUMBER OF STATIONS THAT CAN BE DEALT
C WITH. (INPUT)
C NXL = THE SIZE OF THE PRIMARY GRID FOR THIS RUN
C IN THE X DIRECTION IN MESHB UNITS. (INPUT)
C NYL = THE SIZE OF THE PRIMARY GRID FOR THIS RUN
C IN THE Y DIRECTION IN MESHB UNITS. (INPUT)
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 R = THE RADIUS OF INFLUENCE FOR THE FIRST GUESS
C OPTION USED FOR THE 1ST PASS MODIFIED BY
C THE CORRESPONDING RSTAR. (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 MESH. (INPUT)
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 MESH. (INPUT)
C ELCORR(J) = FRACTION OF THE ELEVATION CORRECTION TO
C APPLY FOR EACH PASS (J=1,NPASS) FOR THE DESIRED
C FIRST GUESS OPTION. (INPUT)
C NPASS = THE NUMBER OF PASSES FOR THIS ANALYSIS.
C UP TO 6 ARE ACCOMMODATED. (INPUT)
C WTRUNL(J) = THE WEIGHTS TO USE FOR THE RUN TIMES IN
C NHRRUM(J) FOR THE LAPSE RATES (J=1,NORUNS).
C (NOT CURRENTLY IMPLEMENTED; THE LAPSE IS BASED
C ON EQUALLY WEIGHTED DATA.) (INPUT)
C NORUNS = NUMBER OF RUNS OR CYCLES TO INCLUDE IN AN
C ANALYSIS, ALL VERIFYING AT THE SAME TIME,
C MAXIMUM OF 5. (INPUT)
C LEVELS = THE NUMBER OF PROBABILITY LEVELS TO ANALYZE.
C (INPUT)
C IALOC(J) = LOCATIONS IN CCALL( , ) OF THE PAIRED STATIONS
C (J=1,NOPAR(K)) VALUES FOR EACH STATION K
C (K=1,LSTA). (INPUT)
C ADIST(J) = DISTANCES OF BASE STATION OF THE PAIRED STATIONS
C (J=1,NOPAR(K)) VALUES FOR EACH STATION K.
C NOTE: NOT USED IN THE COMPUTATION, BUT COULD
C BE USED WITH A WEIGHTING FACTOR TO GIVE CLOSE
C PAIRS MORE WEIGHT. (INPUT)
C AELEV(J) = ARITHMETIC DIFFERENCES ELEVATION OF BASE
C STATION AND OF THE PAIRED STATIONS
C (J=1NOPAR(K)) VALUES FOR EACH STATION K IN
C METERS. (INPUT)
C ND13 = MAXIMUM TOTAL PAIRS OF STATIONS. DIMENSION OF
C ADIST( ), AND AELEV( ). (INPUT)
C EXCLUD = VALUE OF XDATA( , , ) TO NOT USE IN
C CALCULATIONS. PUT IN FOR CEILING HEIGHT OF
C 130 = UNLIMITED. THIS IS 9999 WHEN NOT TO BE
C USED. WHEN NOT 9999, IT IS READ IN WITH
C SUBROUTINE SETCIG (AND MAYBE OTHERS). (INPUT)
C SEALND(J) = THE LAND/SEA MASK (J=1,NXE*NYE).
C 0 = OCEAN WATER GRIDPOINTS;
C 3 = INLAND WATER GRIDPOINTS.
C 9 = LAND GRIDPOINTS.
C (INPUT)
C TELEV(J) = THE TERRAIN ELEVATION FROM THE MOS-2000 EXTERNAL
C RANDOM ACCESS FILE (J=1,NXE*NYE). (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 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 P(IX,JY) = FIELD HOLDING FIRST GUESS (IX=1,NX) (JY=1,NY).
C (INPUT)
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 MESH = THE NOMINAL MESH LENGTH OF THE CURRENT GRID.
C (INPUT)
C ID(J) = THE ID OF THE ANALYSIS BEING DONE (J=1,4).
C (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), AND
C -1 = APPLY TO NEGATIVE LAPSES (NEGATIVE IS ODD
C FOR SNOW).
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 LPNO = THE MAXIMUM NUMBER OF DATA POINTS TO USE IN
C COMPUTING THE LAPSE. NOTE THAT THERE CAN BE
C LPNO*NORUNS ACTUAL VALUES TO SUM. THE ACTUAL
C NUMBER CAN BE LPNO*NORUNS+NORUNS WHEN
C NORUNS > 1. THIS IS READ IN U405A.CN FILE.
C UNLIMITED NUMBER OF POINTS IS INDICATED WHEN
C LPNO = 99, AND IS THEN SET TO A LARGE NUMBR.
C (INPUT)
C LAPFG = 0 COMPUTE LAPSE FROM DATA
C 1 COMPUTE LAPSE FROM FIRST GUESS.
C 2 COMPUTE LAPSE FROM UPPER AIR DATA (IN LAPSUA).
C 3 COMPUTE LAPSE FROM UPPER AIR DATA AND
C SURFACE DATA (IN LAPSUA).
C 4 USE LAPFG FROM SOME PREVIOUS VARIABLE.
C 5 A COMBINATION OF 0 AND 3 ABOVE.
C (INPUT)
C MGUESS = THE TYPE OF FIRST GUESS ACTUALLY USED (SEE
C (IGUESS( )). SET IN FSTGS5. (INPUT)
C (NOT ACTUALLY USED.)
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 DATUM AND
C THE SURROUNDING 4 POINTS ARE OF MIXED TYPE.
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. IT IS INCREMENTED ONLY IF
C THERE ARE NO DATA TO COMPUTE A LAPSE
C RATE OR IF THE LAPSE RATE IS OUTSIDE
C THE RANGE PLUS OR MINUS 0.1 AND IS
C SET TO ZERO
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 = STATUS RETURN.
C 777 = ROUTINE ENTERED WITH LAPFG NE 0, 1. OR 5.
C 0 = GOOD RETURN.
C NOPAIR = THE NUMBER OF STATIONS WITH NO PAIRS LIST THAT
C ARE NOT WATER POINTS. (INTERNAL)
C NUMPR = THE NUMBER OF STATIONS WITH A LIST. (INTERNAL)
C NODATA = THE NUMBER OF STATIONS WITH A PAIRS LIST
C BUT NO USABLE DATA. (INTERNAL)
C NUMGOD = THE NUMBER OF LAPSE RATES ACTUALLY COMPUTED
C AND CAN BE USED. (INTERNAL)
C NUMLES = THE NUMBER OF STATIONS WITH A LIST THAT
C HAVE LESS THAN 10 DATA POINTS. (INTERNAL)
C NOCEAN = THE NUMBER OF OCEAN WATER POINTS. (INTERNAL)
C NINWAT = THE NUMBER OF INLAND WATER POINTS. (INTERNAL)
C NBOTH = THE NUMBER OF POINTS THAT ARE BOTH INLAND
C WATER AND LAND. (INTERNAL)
C NRESET = THE NUMBER OF COMPUTED LAPSE RATES DEEMED OUT
C OF REASONABLE RANGE AND SET TO ZERO.
C (INTERNAL)
C NOUTS = THE NUMBER OF DATA POINTS OUTSIDE THE
C ANALYSIS AREA. (INTERNAL)
C XAXLAP = THE MAXIMUM COMPUTED LAPSE RATE. (INTERNAL)
C XINLAP = THE MINIMUM COMPUTED LAPSE RATE. (INTERNAL)
C SUMLPS = SUM OF ALL THE LAPSE RATES. (REAL*8)
C (INTERNAL)
C SQLPS = SQUARE OF ALL THE LAPSE RATES. (REAL*8)
C (INTERNAL)
C NTOTAL = SUM OF ALL THE DIFFERENCES USED IN COMPUTING
C THE LAPSE RATES. (INTERNAL)
C AVGLPS = AVERAGE OF THE COMPUTED LAPSE RATES. (REAL*8)
C (INTERNAL)
C SDLPS = STANDARD DEVIATION OF THE COMPUTED LAPSE
C RATES. (REAL*8) (INTERNAL)
C IPRINT = 0 INDICATES A SPACE IS TO BE PRINTED;
C 1 OTHERWISE. (INTERNAL)
C KMINUS = NUMBER OF MINUS LAPSE RATES. (INTERNAL)
C KZERO = NUMBER OF ZERO LAPSE RATES. (INTERNAL)
C KPLUS = NUMBER OF PLUS LAPSE RATES. (INTERNAL)
C LLMT = THE MINIMUM NUMBER OF PAIRS TO USE IN COMPUTING
C A LAPSE. A DIAGNOSTIC IS WRITTEN WHEN NUMBER
C OF PAIRS USED IS LT LLMT*NORUNS, AND
C XLAPSE( ) SET TO ZERO. (INTERNAL)
C MLMT = DIAGNOSTIC IS WRITTEN WHEN NUMBER OF PAIRS
C USED IS LT LLMT*NORUNS. SET TO 10 IN DATA
C STATEMENT.
C HMINUS = THE LARGEST MINUS LAPSE RATE TOLERATED.
C IF EXCEEDED, XLAPSE( ) SET TO 0. (INTERNAL)
C HPLUS = THE LARGEST PLUS LAPSE RATE TOLERATED.
C IF EXCEEDED, XLAPSE( ) SET TO 0. (INTERNAL)
C ILAP = 0 WHEN XLAPSE( ) IS SET TO ZERO WHEN LIMITS
C ARE EXCEEDED,
C 1 WHEN XLAPSE( ) IS SET TO THE LIMIT WHEN
C LIMITS EXCEEDED. (INTERNAL)
C 1 2 3 4 5 6 7 X
C NONSYSTEM SUBROUTINES USED
C NONE
C
CHARACTER*8 CCALL(ND1)
CHARACTER*20 NAME(ND1)
C
REAL*8 SUMLPS,SQLPS,AVGLPS,SDLPS
C
DIMENSION ID(4)
DIMENSION LNDSEA(NSTA),ELEV(NSTA),NOPAR(NSTA),LOCPAR(NSTA),
1 XLAPSE(NSTA),XP(NSTA),YP(NSTA),XPL(NSTA),YPL(NSTA),
2 MPAIRS(NSTA),LTAGPT(NSTA)
DIMENSION XDATA(ND1,NORUNS+1,LEVELS)
DIMENSION TELEV(NXE,NYE),SEALND(NXE,NYE)
DIMENSION IALOC(ND13),ADIST(ND13),AELEV(ND13)
DIMENSION ELCORR(6),ISTOP(6),WTRUNL(5)
C
DATA IFIRST/0/
DATA MLMT/10/
C
CALL TIMPR(KFILDO,KFILDO,'START LAPSE ')
IER=0
C
C************************
CCCC DO 99 K=1,NSTA
CCCC WRITE(KFILDO,98)CCALL(K),(XDATA(K,2,L),L=1,LEVELS)
CCCC 98 FORMAT(' IN LAPSE AT 98--CCALL(K),(XDATA(K,2,L),L=1,LEVELS)',
CCCC 1 2X,A8,2X,10F10.3)
CCCC 99 CONTINUE
CCCC WRITE(KFILDO,998)ID
CCCC 998 FORMAT(/' IN FSTGS,ID(1) =',I12)
C***********************
C
C SET LLMT, HMINUS, AND HPLUS ACCORDING TO VARIABLE ID( ).
C
IF((ID(1)/100).EQ.7280000.OR.(ID(1)/100).EQ.2280800)THEN
C THE ABOVE IS FOR CEILING HEIGHT, OBS OR LAMP FORECASTS.
LLMT=4
C FOR A STRATUS DECK INTERSECTING A MOUNTAIN, THE CHANGE
C IN HEIGHT WOULD BE 3.28 FT/M. THIS SHOULD BE .0328 HDS FT
C PER M. CHANGED 5/4/15.
HMINUS=-.0328
HPLUS=+.0328
WRITE(KFILDO,999)HMINUS,HPLUS
999 FORMAT(/' SETTING LIMITS FOR LAPSE ',2F10.5)
ILAP=1
ELSEIF((ID(1)/100).EQ.2280702)THEN
C THE ABOVE IS FOR LAMP CEILING PROBABILITY FORECASTS.
C MODIFIED FROM DEFAULT BELOW 5/3/15. DEATH VALLEY WAS
C GETTING FOG WITH NOTHING CLOSE TO INDICATE IT.
LLMT=4
HMINUS=-.0001
HPLUS=+.0001
WRITE(KFILDO,999)HMINUS,HPLUS
ILAP=1
ELSEIF((ID(1)/100).EQ.2280602)THEN
C THE ABOVE IS FOR LAMP CEILING PROBABILITY FORECASTS.
C FOR ALASKA. THIS GIVES A MAXIMUM OF 10 PERCENT CHANGE
C PER 1000 FT. (4/9/19)
LLMT=4
HMINUS=-.01
HPLUS=+.01
WRITE(KFILDO,999)HMINUS,HPLUS
ILAP=1
ELSEIF((ID(1)/100).EQ.7081000.OR.(ID(1)/100).EQ.2281600)THEN
C THE ABOVE IS FOR VISIBILITY, OBS OR LAMP FORECASTS.
C MODIFIED FROM DEFAULT BELOW 5/2/15. DEATH VALLEY WAS
C GETTING FOR WITH NOTHING CLOSE TO INDICATE IT.
LLMT=4
HMINUS=-.001
HPLUS=+.001
WRITE(KFILDO,999)HMINUS,HPLUS
ILAP=1
ELSEIF((ID(1)/100).EQ.2281302)THEN
C THE ABOVE IS FOR LAMP VISIBILITY PROBABILITY FORECASTS.
C MODIFIED FROM DEFAULT BELOW 5/3/15. DEATH VALLEY WAS
C GETTING NON ZERO PROB WITH NOTHING CLOSE TO INDICATE IT.
LLMT=4
HMINUS=-.00005
HPLUS=+.00007
WRITE(KFILDO,999)HMINUS,HPLUS
ILAP=1
ELSE
C THESE ARE DEFAULT, AND WERE USED PRIOR TO MARCH 2011
C CHANGE. FOR TEMPERATURE, THE ADIABATIC CHANGE IS
C .0176 DEG F/M, MUCH LESS THAN ALLOWED.
LLMT=4
HMINUS=-.1
HPLUS=+.1
WRITE(KFILDO,999)HMINUS,HPLUS
ILAP=0
ENDIF
C
KZERO=0
KMINUS=0
KPLUS=0
LLMTTS=LLMT*NORUNS
MLMTTS=MLMT*NORUNS
LPNOTS=LPNO*NORUNS
C LLMTTS, MLMTTS, AND LPNOTS INCORPORATE NORUNS FOR TESTING.
C
D WRITE(KFILDO,100)NORUNS,LLMT,HMINUS,HPLUS,EXCLUD
D100 FORMAT(/' AT 100 IN LAPSE--NORUNS,LLMT,HMINUS,HPLUS,EXCLUD',
D 1 2I4,3F12.5)
C
D DO 103 K=1,NSTA
D WRITE(KFILDO,101)K,EXCLUD,LNDSEA(K),NOPAR(K),
D 1 (XDATA(K,L,1),L=2,NORUNS+1)
D101 FORMAT(/,' AT 101 IN LAPSE (K,EXCLUD,LNDSEA(K),NOPAR(K),',
D 1 '(XDATA(K,L,1),L=2,NORUNS+1)',/,
D 2 (I7,F6.1,I2,I8,6F8.0))
D103 CONTINUE
C
C CHECK CORRESPONDENCE OF IBKPN AND KIFLLP. IF IBKPN
C NE 99, IT INDICATES XAPSE( ) IS TO BE CALCULATED.
C THEREFORE, KFILLP SHOULD NOT BE ZERO.
C
IF(IBKPN.NE.99.AND.KFILLP.EQ.0)THEN
WRITE(KFILDO,104)IBKPN
104 FORMAT(/' ****IBKPN =',I4,' NOT EQUAL 99, BUT NO KFILLP',
1 ' PAIRS FILE PROVIDED. LAPSE COULD NOT BE ',
2 ' CALCULATED. PROCEEDING.')
C
DO 1040 K=1,NSTA
XLAPSE(K)=0.
1040 CONTINUE
C
ISTOP(1)=ISTOP(1)+1
IER=777
C THIS WILL COUNT AS A MAJOR ERROR.
GO TO 250
ENDIF
C
C IF THE UNIT NUMBER ON WHICH TO READ THE PAIRS LIST IS
C ZERO, SET THE XLAPSE( ) = 0.
C
IF(KFILLP.EQ.0.OR.IBKPN.EQ.99)THEN
C ALTHOUGH THE TEST IS MADE, LAPSE WILL PROBABLY
C NOT BE CALLED WHEN IBPKN - 99.
C
DO 105 K=1,NSTA
XLAPSE(K)=0.
105 CONTINUE
C
WRITE(KFILDO,106)
106 FORMAT(/' ****INCONSISTENCY. LAPSE SET = 0. ',
1 'KFILLP = 0 OR IBPKN = 99, BUT LAPFG',
2 'INDICATES TO COMPUTE IT. COUNT AS ISTOP(1)',
3 'ERROR.')
ISTOP(1)=ISTOP(1)+1
IER=777
C THIS WILL COUNT AS A MAJOR ERROR.
GO TO 250
ENDIF
C
C IF ALL THE ELCORR( ) ARE ZERO, THEN THE ELEVATION
C CORRECTION IS NOT TO BE USED, SO SET XLAPSE( ) = 0.
C
DO 110 J=1,NPASS
C
D WRITE(KFILDO,109)ELCORR(J)
D109 FORMAT(' AT 109 IN LAPSE--ELCORR(J)',F10.2)
C
IF(ELCORR(J).GT.0.)GO TO 112
110 CONTINUE
C
C DROP THROUGH HERE MEANS THE LAPSE RATE IS NOT TO BE USED.
C
DO 111 K=1,NSTA
XLAPSE(K)=0.
111 CONTINUE
C
WRITE(KFILDO,1110)
1110 FORMAT(/' ****INCONSISTENCY. LAPSE SET = 0. ',
1 'ALL ELCORR( ) = 0, BUT LAPFG INDICATES TO COMPUTE',
2 ' IT. COUNT AS ISTOP(1) ERROR.')
ISTOP(1)=ISTOP(1)+1
IER=777
C THIS WILL COUNT AS A MAJOR ERROR.
C
GO TO 250
C
112 IPRINT=0
NOPAIR=0
C NOPAIR COUNTS THE NUMBER OF STATIONS WITH NO PAIRS LIST
C THAT ARE NOT WATER POINTS.
NUMPR=0
C NUMPR COUNTS THE NUMBER OF STATIONS WITH A LIST.
NODATA=0
C NODATA COUNTS THE NUMBER OF STATIONS WITH A PAIRS LIST
C BUT NO USABLE DATA.
NUMGOD=0
C NUMGOD COUNTS THE NUMBER OF LAPSE RATES ACTUALLY COMPUTED.
NUMLES=0
C NUMLES COUNTS THE NUMBER OF STATIONS WITH A LIST THAT
C HAVE LESS THAN 10 DATA POINTS.
NOCEAN=0
C NOCEAN COUNTS THE NUMBER OF OCEAN WATER POINTS.
NINWAT=0
C NINWAT COUNTS THE NUMBER OF INLAND WATER (ONLY) POINTS.
NBOTH=0
C NBOTH COUNTS THE NUMBER OF INLAND WATER POINTS AND
C LAND COMBINED.
NRESET=0
C NRESET COUNTS THE NUMBER OF COMPUTED LAPSE RATES
C DEEMED OUT OF REASONABLE RANGE AND SET TO ZERO.
NOUTS=0
C NOUTS COUNTS THE NUMBER OF DATA POINTS OUTSIDE THE
C ANALYSIS AREA.
XAXLAP=-9.
C XAXLAP IS THE MAXIMUM COMPUTED LAPSE RATE. MORE DIGITS
C WON'T PRINT AT 205.
XINLAP=+9.
C XINLAP IS THE MINIMUM COMPUTED LAPSE RATE. MORE DIGITS
C WON'T PRINT AT 205.
SUMLPS=0.
C SUMLPS IS THE SUM OF ALL THE LAPSE RATES.
AVGLPS=9.
C AVGLPS IS THE AVERAGE OF THE LAPSE RATES. MORE DIGITS
C WON'T PRINT AT 205.
SDLPS=9.
C SDLPS IS THE STANDARD DEVIATION OF THE LAPSE RATES.
C MORE DIGITS WON'T PRINT AT 205.
SQLPS=0.
C SQLPS IS THE SQUARE OF ALL THE LAPSE RATES.
NTOTAL=0
C NTOTAL IS THE TOTAL NUMBER OF DIFFERENCES USED IN
C COMPUTING LAPSE RATES.
C
DO 200 K=1,NSTA
C
C*** WRITE(KFILDO,115)K,CCALL(K),NAME(K),XPL(K),YPL(K),R
C*** 115 FORMAT(' AT 115--K,CCALL(K),NAME(K),XPL(K),YPL(K),R',
C*** 1 I6,2X,A8,2X,A20,3F8.2)
C
C INITIALIZE MPAIRS( ).
C
MPAIRS(K)=0
C
IF((XPL(K).LT.1.-R).OR.
1 (YPL(K).LT.1.-R).OR.
2 (XPL(K).GT.NXL+R).OR.
3 (YPL(K).GT.NYL+R))THEN
C ANY STATION OUTSIDE POSSIBLE USE IN ANALYSIS IS NOT
C CONSIDERED.
D WRITE(KFILDO,117)CCALL(K),NAME(K)
D117 FORMAT(' STATION ',A8,2X,A20,' OUTSIDE AREA OF USE IN',
D 1 ' ANALYSIS.')
D WRITE(KFILDO,1170)XPL(K),YPL(K),NXL,NYL,R
D1170 FORMAT(' XPL(K),YPL(K),NXL,NYL,R--',2F10.2,2I6,F10.2)
NOUTS=NOUTS+1
MPAIRS(K)=7777
XLAPSE(K)=0.
GO TO 200
ENDIF
C
SUMV=0.
SUME=0.
NUM=0
C
D WRITE(KFILDO,118)K,LNDSEA(K),NOPAR(K),XDATA(K,2,1),XDATA(K,3,1)
D118 FORMAT(' AT 118 IN LAPSE--K,LNDSEA(K),NOPAR(K),',
D 1 'XDATA(K,2,1),XDATA(K,3,1)',3I8,2F10.2)
C
IF(LNDSEA(K).EQ.0)THEN
NOCEAN=NOCEAN+1
XLAPSE(K)=0.
MPAIRS(K)=9999
GO TO 200
ELSEIF(LNDSEA(K).EQ.3)THEN
NINWAT=NINWAT+1
XLAPSE(K)=0.
MPAIRS(K)=9999
GO TO 200
ELSEIF(LNDSEA(K).EQ.6)THEN
NBOTH=NBOTH+1
XLAPSE(K)=0.
MPAIRS(K)=9999
GO TO 200
ELSEIF(NAREA.EQ.2.AND.LTAGPT(K).NE.0)THEN
C THIS CUTS OUT THE BOGUS AND AUGMENTED FOR ALASKA
C WHICH OCCURS OVER SIBERIA (LAND) AS WELL AS OCEAN.
XLAPSE(K)=0.
MPAIRS(K)=9999
GO TO 200
ELSEIF(NOPAR(K).EQ.9999)THEN
C THE ABOVE TEST WAS CHANGED FROM 999999 TO 9999 12/2/06
C U174 WRITES 9999, NOT 999999.
C THERE IS NO PAIR LIST. THERE IS ALWAYS A POINTER IN
C LOCPAR(K) INTO IALOC( ) AND NOPAR( ), BUT THE VALUE
C IN NOPAR( ) MAY INDICATE A MISSING LIST.
NOPAIR=NOPAIR+1
XLAPSE(K)=0.
MPAIRS(K)=9999
D WRITE(KFILDO,120)K,XLAPSE(K),XAXLAP,XINLAP,
D 1 SUMLPS,SQLPS,NTOTAL
D120 FORMAT(/' AT 120 IN LAPSE--K,XLAPSE(K),XAXLAP,XINLAP,',
D 1 'SUMLPS,SQLPS,NTOTAL',I6,5F10.1,I6)
GO TO 200
ELSE
NUMPR=NUMPR+1
ENDIF
C
C CHECK FOR MISSING DATA. AT LEAST ONE RUN MUST HAVE DATA
C FOR ONE PROBABILITY LEVEL.
C
DO 123 J=1,LEVELS
C
DO 122 L=2,NORUNS+1
C
IF(XDATA(K,L,J).NE.9999.)THEN
GO TO 125
ENDIF
C
122 CONTINUE
C
123 CONTINUE
C FALL THROUGH MEANS ALL NORUNS FOR ALL LEVELS HAVE
C MISSING DATA.
C
D WRITE(KFILDO,124)CCALL(K),NAME(K)
D124 FORMAT(/,' STATION ',A8,2X,A20,' HAS A MISSING',
D 1 ' OBSERVATION. A LAPSE RATE IS NOT NEEDED.')
XLAPSE(K)=0.
C XLAPSE(K) SET = 0 FOR SAFETY.
MPAIRS(K)=9999
NODATA=NODATA+1
GO TO 200
C
125 CONTINUE
C
DO 1950 J=1,LEVELS
C
DO 195 JJ=LOCPAR(K),LOCPAR(K)+NOPAR(K)-1
C
D WRITE(KFILDO,1255)K,JJ,LOCPAR(K),NOPAR(K)
D1255 FORMAT(/' AT 1255 IN LAPSE--K,JJ,LOCPAR(K),NOPAR(K)',4I10)
C
DO 194 L=2,NORUNS+1
C
D WRITE(KFILDO,126)K,CCALL(K)
D126 FORMAT(/' IN LAPSE--K,CCALL(K)',I6,2X,A8)
C
C*****************************************************************
C THE BELOW CAN BE ACTIVATED ALONG WITH FORMAT 135 TO
C CHECK ON PARTICULAR STATIONS.
C
CCC IF(CCALL(K).EQ.'KDRA '.OR.
CCC 1 CCALL(K).EQ.'KINS ')THEN
CCC WRITE(KFILDO,127)
CCC 127 FORMAT(/' K CALL(K) NAME(K)',
CCC 1 ' XDATA(K,L,J) XPL(K) YPL(K),',
CCC 2 ' ELEV(K) NOPAR(K)',/,
CCC 3 ' JJ CCALL(IALOC(JJ)) NAME(IALOC(JJ))',
CCC 4 ' XDATA(IALOC(JJ),L,J) XPL(IALOC(JJ)) YPL(IALOC(JJ))',
CCC 5 ' ELEV(IALOC(JJ)), AELEV(JJ) ADIST(JJ)',
CCC 6 ' NUM SUMV SUME')
CCC ENDIF
C*****************************************************************
C
D WRITE(KFILDO,128)K,JJ,L,CCALL(K),XDATA(K,L,J),IALOC(JJ)
D128 FORMAT(' AT 128 IN LAPSE--K,JJ,J,L,CCALL(K),XDATA(K,L,J),',
D 1 'IALOC(JJ)',3I7,2X,A8,F10.2,I7)
C
IF(NINT(XDATA(K,L,J)).EQ.9999)GO TO 194
C THIS HAS TO BE CHECKED HERE EVEN THOUGH CHECKED ABOVE
C BECAUSE ANY ONE OF THE RUNS L WILL LET CONTROL PASS HERE.
IF(NINT(XDATA(K,L,J)).EQ.NINT(EXCLUD))GO TO 194
C THIS WAS PUT IN FOR CEILING HEIGHT TO EXCLUDE UNLIMITED.
C
IF(IALOC(JJ).EQ.999999)GO TO 195
C IALOC( ) IS SET TO 999999 WHEN THE DATA CAN'T BE USED.
C A VALUE OF 999999 IS PROBABLY OUTSIDE THE XDATA( , , ) ARRAY.
C
IF(LAPFG.EQ.0.OR.LAPFG.EQ.5)THEN
C
C THIS IS THE LOOP TO COMPUTE LAPSE RATES FROM
C STATION DATA. WHEN LAPFG = 5, IT WILL BE COMBINED WITH
C LAPSE COMPUTED AS A COMBINATION OF SURFACE AND UA DATA.
IF(XDATA(IALOC(JJ),L,J).NE.9999..AND.
1 LNDSEA(IALOC(JJ)).NE.0.AND.
2 LNDSEA(IALOC(JJ)).NE.3.AND.
3 NINT(XDATA(IALOC(JJ),L,J)).NE.NINT(EXCLUD))THEN
C WHILE THE LISTS SHOULD NOT INCLUDE WATER STATIONS,
C DESIGNATIONS MAY BE CHANGED THAT RENDER THE LIST
C OUT OF COORDINATION WITH U155. THE ABOVE KEEPS
C A WATER STATION (OF TYPE 0 OR 3) FROM BEING USED IN
C THE CALCULATION. THE EXCLUD WAS ADDED FOR UNLIMITED
C CEILING HEIGHT.
NUM=NUM+1
C NOTE THAT NUM COUNTS ONE FOR EACH RUN.
C
C THE SUMMATION OF THE ELEMENT VALUE IS THE ONE WITH
C THE HIGHEST ELEVATION MINUS THE OTHER.
C
IF(ELEV(IALOC(JJ)).GE.ELEV(K))THEN
SUMV=SUMV+(XDATA(IALOC(JJ),L,J)-XDATA(K,L,J))
ELSE
SUMV=SUMV+(XDATA(K,L,J)-XDATA(IALOC(JJ),L,J))
ENDIF
SUME=SUME+ABS(AELEV(JJ))
C AELEV( ) IS THE ARITHMETIC DIFFERENCE OF THE HEIGHT
C OF THE PAIRED STATION MINUS THE BASE STATION IN
C METERS. THE ABSOLUTE VALUE IS THE SAME AS THE
C HEIGHT OF THE UPPER STATION MINUS THE HEIGHT OF
C THE LOWER STATION. EVERY STATION IN THE DICTIONARY
C HAS AN ELEVATION.
C
D WRITE(KFILDO,134)K,ELEV(K),ELEV(IALOC(JJ)),SUMV,SUME
D134 FORMAT(/,' AT 134 IN LAPSE--K,ELEV(K),ELEV(IALOC(JJ)),',
D 1 'SUMV,SUME',I6,4F10.2)
ENDIF
C
C*****************************************************************
C THE BELOW CAN BE ACTIVATED ALONG WITH FORMAT 127 TO
C CHECK ON PARTICULAR STATIONS.
C
CCC IF(CCALL(K).EQ.'KDRA '.OR.
CCC 1 CCALL(K).EQ.'KINS ')THEN
CCC WRITE(KFILDO,135)K,CCALL(K),NAME(K),
CCC 1 XDATA(K,L,J),XPL(K),YPL(K),
CCC 2 ELEV(K),NOPAR(K),
CCC 3 CCALL(IALOC(JJ)),NAME(IALOC(JJ)),
CCC 4 XDATA(IALOC(JJ),L,J),XPL(IALOC(JJ)),YPL(IALOC(JJ)),
CCC 5 ELEV(IALOC(JJ)),AELEV(JJ),ADIST(JJ),
CCC 6 NUM,SUMV,SUME
CCC 135 FORMAT(/,I5,1X,A8,1X,A20,
CCC 1 F10.1,F14.1,F15.1,
CCC 2 F15.1,I14,/,
CCC 3 6X,A8,1X,A20,3X,
CCC 4 F7.1,F14.1,F15.1,
CCC 5 F15.1,F14.1,F10.1,I5,F7.0,F7.0)
CCC ENDIF
C*****************************************************************
C
ELSEIF(LAPFG.EQ.1)THEN
C
C THIS IS THE LOOP TO COMPUTE LAPSE RATES FROM
C THE FIRST GUESS AND EITHER THE STATION ELEVATIONS
C OR THE GRIDDED TERRAIN.
C
IF(XDATA(IALOC(JJ),L,J).NE.9999..AND.
1 LNDSEA(IALOC(JJ)).NE.0.AND.
2 LNDSEA(IALOC(JJ)).NE.3)THEN
C WHILE THE LISTS SHOULD NOT INCLUDE WATER STATIONS,
C DESIGNATIONS MAY BE CHANGED THAT RENDER THE LIST
C OUT OF COORDINATION WITH U155. THE ABOVE KEEPS
C A WATER STATION (OF TYPE 0 OR 3) FROM BEING USED IN
C THE CALCULATION.
C
CALL ITRPSL(KFILDO,IP14,P,NX,NY,CCALL(K),XP(K),YP(K),
1 LNDSEA(K),SEALND,NXE,NYE,
2 MESH,MESHE,N4P,BB,ISTOP,IER)
C VALUE INTERPOLATED FROM FIRST GUESS TO STATION LOCATION
C IS NOW IN BB. THIS CAN BE MISSING BECAUSE AN
C INTERPOLATED VALUE FOR A LAND (WATER) STATION IS ONLY
C TAKEN FROM LAND (WATER) STATIONS, AND IT IS POSSIBLE NONE
C EXIST. ALSO, THE FIRST GUESS ANALYSIS AREA MAY NOT FILL
C GRID. IN THIS CASE, IER NE 0.
C
IF(IER.NE.0)GO TO 195
C IER NE 0 IS NOT COUNTED AS AN ERROR HERE.
C
CALL ITRPSL(KFILDO,IP14,P,NX,NY,CCALL(K),XP(K),YP(K),
1 LNDSEA(K),SEALND,NXE,NYE,
2 MESH,MESHE,N4P,BB1,ISTOP,IER)
C VALUE INTERPOLATED FROM FIRST GUESS TO STATION PAIR
C LOCATION IS NOW IN BB1. THIS CAN BE MISSING.
C
IF(IER.NE.0)GO TO 195
C IER NE 0 IS NOT COUNTED AS AN ERROR HERE.
C
IF(LAPFG.EQ.1)THEN
C THE ELEVATION DIFFERENCE IS TO BE TAKEN FROM THE
C STATION VALUES. AELEV( ) IS COMPUTED IN A
C PREPROCESSOR.
NUM=NUM+1
C NOTE THAT NUM COUNTS ONE FOR EACH RUN.
C
SUME=SUME+ABS(AELEV(JJ))
C AELEV( ) IS THE ARITHMETIC DIFFERENCE OF THE HEIGHT
C OF THE PAIRED STATION MINUS THE BASE STATION IN
C METERS. THE ABSOLUTE VALUE IS THE SAME AS THE
C HEIGHT OF THE UPPER STATION MINUS THE HEIGHT OF
C THE LOWER STATION.
C
ELSE
CALL ITRPSL(KFILDO,IP14,TELEV,NXE,NYE,CCALL(K),
1 XP(K),YP(K),LNDSEA(K),SEALND,NXE,NYE,
2 MESH,MESHE,N4P,EE,ISTOP,IER)
C VALUE INTERPOLATED FROM FIRST GUESS TO STATION LOCATION
C IS NOW IN BB. THIS CAN BE MISSING BECAUSE AN
C
IF(IER.NE.0)GO TO 195
C IER NE 0 IS NOT COUNTED AS AN ERROR HERE.
C
CALL ITRPSL(KFILDO,IP14,TELEV,NXE,NYE,CCALL(K),
1 XP(K),YP(K),LNDSEA(K),SEALND,NXE,NYE,
2 MESH,MESHE,N4P,EE1,ISTOP,IER)
C VALUE INTERPOLATED FROM FIRST GUESS TO STATION PAIR
C LOCATION IS NOW IN BB1. THIS CAN BE MISSING.
C
IF(IER.NE.0)GO TO 195
C IER NE 0 IS NOT COUNTED AS AN ERROR HERE.
NUM=NUM+1
C NOTE THAT NUM COUNTS ONE FOR EACH RUN.
C
SUME=SUME+ABS(EE1-EE)
C EE1-EE IS THE ARITHMETIC DIFFERENCE OF THE HEIGHT
C OF THE PAIRED STATION MINUS THE BASE STATION IN
C METERS.
C
IF(BB1.GE.BB)THEN
SUMV=SUMV+BB1-BB
ELSE
SUMV=SUMV+BB-BB1
ENDIF
C
ENDIF
C
C*****************************************************************
C THE BELOW CAN BE ACTIVATED ALONG WITH FORMAT 127 TO
C CHECK ON PARTICULAR STATIONS.
C
C IF(CCALL(K).EQ.'ZKMEI ')THEN
C WRITE(KFILDO,145)K,CCALL(K),NAME(K),
C 1 XDATA(K,L,J),XPL(K),YPL(K),
C 2 ELEV(K),NOPAR(K),
C 3 CCALL(IALOC(JJ)),NAME(IALOC(JJ)),
C 4 XDATA(IALOC(JJ),L,J),XPL(IALOC(JJ)),YPL(IALOC(JJ)),
C 5 ELEV(IALOC(JJ)),AELEV(JJ),ADIST(JJ),
C 6 NUM,SUMV,SUME
C145 FORMAT(/,I5,1X,A8,1X,A20,
C 1 F10.1,F14.1,F15.1,
C 2 F15.1,I14,/,
C 3 6X,A8,1X,A20,3X,
C 4 F7.1,F14.1,F15.1,
C 5 F15.1,F14.1,F10.1,I5,F7.0,F7.0)
C ENDIF
C*****************************************************************
C
ENDIF
C
ELSE
WRITE(KFILDO,192)
192 FORMAT(/,' LAPFG NOT EQUAL TO ZERO, 1, OR 5 IN LAPSE.',
1 ' LAPSE CANNOT BE COMPUTED. COUNT AS FATAL.')
ISTOP(1)=ISTOP(1)+1
IER=777
C
C SET XLAPSE( ) = 0. FOR SAFETY.
C
DO 193 KKK=1,NSTA
XLAPSE(KKK)=0.
193 CONTINUE
C
GO TO 250
ENDIF
C
194 CONTINUE
C
IF(NUM.GE.LPNOTS)THEN
D WRITE(KFILDO,1945)LPNOTS,CCALL(K),NAME(K),NORUNS
D1945 FORMAT(/' THE MAXIMUM NUMBER OF PAIRS OF VALUES =',I6,
D 1 ' HAS BEEN REACHED FOR STATION ',A8,1X,A20,
D 2 ' FOR',I3,' CYCLES.')
GO TO 1955
C THE DESIRED NUMBER OF PAIRS HAS BEEN REACHED.
ENDIF
C
195 CONTINUE
C
1950 CONTINUE
C
1955 IF(NUM.EQ.0)THEN
XLAPSE(K)=0.
IF(MPAIRS(K).EQ.0)MPAIRS(K)=9999
C MPAIRS( ) COULD HAVE BEEN SET TO 7777.
NODATA=NODATA+1
C
IF(ID(1)/100.EQ.7080000.OR.ID(1)/100.EQ.2280800)THEN
CCCC IF(IP14.NE.0)WRITE(IP14,196)CCALL(K),NAME(K)
CCCC 196 FORMAT(/,' ****NO DATA FOR COMPUTING LAPSE FOR STATION ',
CCCC 1 A8,2X,A20,'. ZERO IS USED.',
CCCC 2 ' MAY BE DUE TO UNLIMITED CEILING.')
C************ABOVE TOO MUCH PRINT*********
IPRINT=0
ISTOP(4)=ISTOP(4)+1
ELSE
C
IF(IP14.NE.0)WRITE(IP14,1961)CCALL(K),NAME(K)
1961 FORMAT(/,' ****NO DATA FOR COMPUTING LAPSE FOR STATION ',
1 A8,2X,A20,'. ZERO IS USED.')
IPRINT=0
ISTOP(4)=ISTOP(4)+1
GO TO 200
ENDIF
C
ELSEIF(NUM.LT.LLMTTS)THEN
C
IF(IPRINT.EQ.0)THEN
IF(IP14.NE.0)WRITE(IP14,1965)
1965 FORMAT(' ')
ENDIF
C
IF(IP14.NE.0)WRITE(IP14,197)CCALL(K),NAME(K),LLMTTS,NUM
197 FORMAT(' #### STATION ',A8,2X,A20,' HAS LESS THAN',I4,' =',I4,
1 ' DATA LOCATIONS ON WHICH TO COMPUTE A LAPSE.',
2 ' ZERO IS USED.')
C NOTE THAT THERE CAN BE LLMT*NORUNS ACTUAL VALUES.
IPRINT=1
XLAPSE(K)=0.
MPAIRS(K)=5555
C
ELSE
XLAPSE(K)=SUMV/SUME
C NOTE THAT SUME CANNOT BE ZERO BECAUSE IT IS THE SUM OF
C ABSOLUTE VALUES, EACH OF WHICH MUST BE GREATER THAN
C A SPECIFIED AMOUNT.
NUMGOD=NUMGOD+1
MPAIRS(K)=NUM
D WRITE(KFILDO,1975)NUMGOD,SUMV,SUME,XLAPSE(K)
D1975 FORMAT(' AT 1975 IN LAPSE--NUMGOD,SUMV,SUME,XLAPSE(K)',I5,
D 1 3F15.4)
C
IF(NUM.LT.MLMTTS)THEN
NUMLES=NUMLES+1
C
IF(IPRINT.EQ.0)THEN
IF(IP14.NE.0)WRITE(IP14,198)CCALL(K),NAME(K),MLMTTS,NUM
198 FORMAT(/,' #### STATION ',A8,2X,A20,' HAS LESS THAN',I4,
1 ' =',I4,
2 ' DATA VALUES ON WHICH TO COMPUTE A LAPSE.',
3 ' CONTINUING.')
C NOTE THAT THERE CAN BE MLMT*NORUNS ACTUAL VALUES.
IPRINT=1
ELSE
IF(IP14.NE.0)WRITE(IP14,1980)CCALL(K),NAME(K),MLMTTS,NUM
1980 FORMAT(' #### STATION ',A8,2X,A20,' HAS LESS THAN',I4,
1 ' =',I4,
2 ' DATA VALUES ON WHICH TO COMPUTE A LAPSE.',
3 ' CONTINUING.')
C NOTE THAT THERE CAN BE MLMT*NORUNS ACTUAL VALUES.
ENDIF
C
ENDIF
C
C CHECK RANGE OF LAPSE RATES IN XLAPSE( ) FOR ACCEPTABLE
C VALUES. HMINUS AND HPLUS HAVE BEEN SET IN DATA STATEMENTS
C ASSUMING THE NORMAL LAPSE RATE IS NEGATIVE. TO BE CORRECT,
C THE VARIABLE IBKPN IN U405 MUST BE USED.
C
IF(XLAPSE(K).LT.0.)THEN
C
IF(XLAPSE(K).LT.HMINUS)THEN
XSAVE=XLAPSE(K)
C
IF(ILAP.EQ.0)THEN
XLAPSE(K)=0.
ELSE
XLAPSE(K)=HMINUS
ENDIF
C
IF(IP14.NE.0)WRITE(IP14,1985)CCALL(K),NAME(K),XSAVE,
1 HMINUS,HPLUS,XLAPSE(K)
1985 FORMAT(/,' ****STATION ',A8,2X,A20,' XLAPSE = ',F7.4,
1 ' OUTSIDE RANGE',F8.5,' TO',F8.5,'. SET TO',
2 F7.4)
IPRINT=0
ISTOP(4)=ISTOP(4)+1
NRESET=NRESET+1
ENDIF
C
ELSEIF(XLAPSE(K).GT.0.)THEN
C
IF(XLAPSE(K).GT.HPLUS)THEN
XSAVE=XLAPSE(K)
C
IF(ILAP.EQ.0)THEN
XLAPSE(K)=0.
ELSE
XLAPSE(K)=HPLUS
ENDIF
C
IF(IP14.NE.0)WRITE(IP14,1985)CCALL(K),NAME(K),XSAVE,
1 HMINUS,HPLUS,XLAPSE(K)
IPRINT=0
ISTOP(4)=ISTOP(4)+1
NRESET=NRESET+1
ENDIF
C
ENDIF
C
C COMPUTE NUMBER OF ZERO, MINUS, AND PLUS LAPSE RATES.
C
IF(XLAPSE(K).LT.0.)THEN
KMINUS=KMINUS+1
ELSEIF(XLAPSE(K).GT.0.)THEN
KPLUS=KPLUS+1
ELSE
KZERO=KZERO+1
ENDIF
C
C COMPUTE RANGE OF LAPSE RATES.
C
IF(XLAPSE(K).GT.XAXLAP)XAXLAP=XLAPSE(K)
IF(XLAPSE(K).LT.XINLAP)XINLAP=XLAPSE(K)
C CHECK THIS WAY TO MAKE SURE BOTH ARE FOUND.
C
C COMPUTE THE TOTALS AND SQUARES.
C
SUMLPS=SUMLPS+XLAPSE(K)
SQLPS=SQLPS+XLAPSE(K)*XLAPSE(K)
NTOTAL=NTOTAL+MPAIRS(K)
ENDIF
C
200 CONTINUE
C
C COMPUTE THE AVERAGE LAPSE AND STANDARD DEVIATION
C WHEN THERE ARE SOME GOOD POINTS. OTHERWISE, LEAVE
C AT THE INITIALIZATION VALUE.
C
IF(NUMGOD.NE.0)THEN
AVGLPS=SUMLPS/NUMGOD
SDLPS=SQRT((SQLPS/NUMGOD)-AVGLPS*AVGLPS)
ELSE
KZERO=NSTA
C IF THERE ARE NO GOOD POINTS, THEN ALL XLAPSE( ) = 0.
ENDIF
C
WRITE(KFILDO,205)NOPAIR,NOCEAN,NINWAT,NBOTH,NUMPR,NODATA,
1 NUMGOD,NUMLES,NRESET,NOUTS,NTOTAL,
2 XAXLAP,XINLAP,AVGLPS,SDLPS,
3 KMINUS,KZERO,KPLUS
205 FORMAT(/,' ',I6,' = NUMBER OF POINTS WITHOUT A PAIRS',
X ' LIST THAT ARE NOT OCEAN OR INLAND WATER',
X ' POINTS.',/,
1 I7,' = NUMBER OF POINTS WITH A XLAPSE',
X ' RATE = 0 THAT ARE OCEAN POINTS.',/,
2 I7,' = NUMBER OF POINTS WITH A XLAPSE',
X ' RATE = 0 THAT ARE INLAND WATER POINTS.',/,
3 I7,' = NUMBER OF POINTS WITH A XLAPSE RATE = 0',
X ' THAT ARE BOTH INLAND WATER AND LAND.',/,
4 I7,' = NUMBER OF POINTS WITH A PAIRS LIST.',/,
5 I7,' = NUMBER OF POINTS WITH 0 DATA POINTS',
X ' OR HAVE MISSING OBS, LAPSE = 0 USED',/,
6 I7,' = NUMBER OF POINTS WITH GE 3 DATA POINTS',
X ', LAPSE IS COMPUTED; OTHERWISE, LAPSE ',
X ' SET TO ZERO'/,
7 I7,' = NUMBER OF POINTS WITH GE 3 AND LE 10',
X ' DATA POINTS',/,
8 I7,' = NUMBER OF COMPUTED LAPSE RATES OUTSIDE',
X ' RANGE HMINUS AND HPLUS SET IN LAPSE AND',
X ' SET TO ZERO',/,
9 I7,' = NUMBER OF DATA POINTS OUTSIDE ANALYSIS',
X ' AREA',/,
A I7,' = NUMBER OF PAIRS USED IN COMPUTING',
X ' LAPSE RATES',/,
B F7.4,' = MAXIMUM LAPSE RATE COMPUTED',/,
C F7.4,' = MINIMUM LAPSE RATE COMPUTED',/,
D F7.4,' = AVERAGE LAPSE RATE COMPUTED',/,
E F7.4,' = STANDARD DEVIATION OF LAPSE RATES',
F ' COMPUTED',/,
G I7,' = NUMBER OF MINUS LAPSE RATES',/,
H I7,' = NUMBER OF ZERO LAPSE RATES (COMPUTED)',/,
I I7,' = NUMBER OF PLUS LAPSE RATES',/,/,
X ' NOTE: ALL COMPUTATIONS AND COUNTS PERTAIN',
X ' ONLY TO STATIONS WITHIN THE RADIUS OF',
X ' INFLUENCE MODIFIED BY RSTAR FOR PASS 1 ON',
X ' OPTION 1.')
C
IF(IP14.NE.0.AND.IFIRST.LE.1)THEN
IFIRST=IFIRST+1
C FOR TESTING, WRITE THESE ONLY TWICE. THIS WILL BE FOR
C THE FIRST AND SECOND VARIABLES.
WRITE(IP14,207)
207 FORMAT(/,' LISTING OF COMPUTED LAPSE RATE WHEN NON-ZERO.',
1 ' THERE IS A LINE FOR EACH MODEL RUN',/,/,
2 ' STATION NO. CALL LETTERS AND NAME NO. PAIRS',
3 ' NO. PAIRS USED DATA VALUE LAPSE',
4 ' (PER METER)',/,
5 54X,'9999=NO USABLE PAIRS',/,
6 54X,'7777=STATION OUTSIDE R',/,
7 54X,'5555=LT 4, SET = 0',/,
8 54X,'XX=ACTUAL PAIRS USED')
C
DO 215 K=1,NSTA
C
IF(NOPAR((K)).NE.9999)THEN
C
IF(LTAGPT(K).NE.4)THEN
CCCCCC IF(NAREA.NE.2.AND.LTAGPT(K).NE.4)THEN REPLACED 4/11/19
C
DO 213 J=1,LEVELS
C
DO 212 L=2,NORUNS+1
C
IF(XDATA(K,L,J).NE.9999.)THEN
IF(IP14.NE.0)WRITE(IP14,210)K,L,J,CCALL(K),NAME(K),
1 NOPAR(K),MPAIRS(K),XDATA(K,L,J),XLAPSE(K)
210 FORMAT(' ',I5,2I3,2X,A8,2X,A20,I8,I14,F21.3,F13.6)
ENDIF
C
212 CONTINUE
C
213 CONTINUE
C
ENDIF
C
ENDIF
C
215 CONTINUE
C
ENDIF
C
C*******************************************************
C FOR TEST
C
C*** DO 220 K=1,NSTA
C*** IF(XLAPSE(K).GT.0.)XLAPSE(K)=0.
C*** 220 CONTINUE
C
C*******************************************************
CALL TIMPR(KFILDO,KFILDO,'END LAPSE ')
250 RETURN
END