SUBROUTINE LAPSUA(KFILDO,KFIL10,IP14,ID,IDPARS,NCEPNO, 1 CCALL,NAME,LNDSEA, 2 DIR,NGRIDC,ND11,LAPFG,FL174, 3 XDATA,XLAPSE,ELEVLO,ELEVHI,ELEV,NSTA,ND1, 4 ALATL,ALONL,XPL,YPL,NXL,NYL,BMESH, 5 NORUNS,LEVELS,MGUESS,IBACKN,IBACKL, 6 LSTORE,ND9,LITEMS,NDATE,JHR, 7 IS0,IS1,IS2,IS4,ND7, 8 IPACK,IWORK,DATA,ND5, 9 CORE,ND10,NBLOCK,NFETCH,MISTOT,NSLAB, A NPROJ,ORIENT,XLAT,L3264B,ISTOP,IER) C C OCTOBER 2007 GLAHN MDL MOS-2000 C OCTOBER 2007 GLAHN MODIFIED ALGORITHM C OCTOBER 2007 GLAHN CHANGED IF(L.EQ.1) TO IF(L.LE.4) C ABOVE DO 135 C DECEMBER 2007 GLAHN ADDED ISTOP(6) CAPABILITY C DECEMBER 2007 GLAHN ADDED RETURN STATEMENT; UPDATED C ITABLE( , ); REMOVED 200 FOR C INTERPOLATION IN 4TH WORD OF UA ID C FEBRUARY 2008 GLAHN COMMENTS C MARCH 2008 GLAHN REMOVED COMPUTATION DOWNWARD C MARCH 2008 GLAHN ADDED BACKUP CYCLES, IGUESS AND C MGUESS TO CALL C MAY 2008 GLAHN EXPANDED TO WIND U, V, AND SPEED C MAY 2008 GLAHN REMOVED IGUESS( ) C MAY 2008 GLAHN COMMENTS; IF TEST BEFORE 220/221; C ADDED WIND GUSTS; ADDED XSAVE( ), C IDSAV( ) C AUGUST 2008 GLAHN MODIFIED TO USE ARCHIVE UA GRIDS C SEPTEMBER 2008 GLAHN NDATSV MADE A SAVE VARIABLE; C CORRECTED IDPARS(12) TO IDPARS(4) C IN TESTS ABOVE 109; MODIFIED C FORMAT 125, ADDED FORMAT 1624; C ADDED LAPFG C SEPTEMBER 2008 GLAHN DIAGNOSTIC PRINT MADE MORE SPECIFIC C WHEN LAPSE IS REUSED C SEPTEMBER 2008 GLAHN PURPOSE MODIFIED TO INCLUDE LAPFG C OCTOBER 2008 GLAHN CHANGED IS2(4) AND IS2(5) TO IS2(3) C AND IS2(4), RESPECTIVELY C OCTOBER 2008 GLAHN REINSERTED THE TEST FOR ISG=200 C NEEDED FOR SOME TEST DATA. C OCTOBER 2008 COSGROVE ADDED COMMAS FOR IBM COMPILE C NOVEMBER 2008 GLAHN ADDED CHECKING FOR PAST 6-H FORECAST C FOR MAX TEMP PROBLEM AT 198 HR; C INCREMENTED ISTOP(1) TWICE C NOVEMBER 2008 GLAHN SET IER=0 BELOW 1090 AND 110 C NOVEMBER 2008 GLAHN SEVERAL CHANGES RELATED TO USING C PREVIOUS CALCULATED LAPSE AND UA C DATA; ADDED FL174 C DECEMBER 2008 GLAHN MODIFIED FORMAT 1275 C MARCH 2008 GLAHN OMITTED CHECK ON 2ND WORD AT 105 C AUGUST 2009 GLAHN ADDED DO 100 LOOP C AUGUST 2009 GLAHN ADDED PRINT TO IP14 WHEN LAPFG = 2 C AUGUST 2009 GLAHN CHANGED ISTOP=ISTOP+1 TO C ISTOP(1)=ISTOP(1)+1 IN ONE PLACE C AUGUST 2009 GLAHN MODIFIED TEST ON ELEVHI( ) AND ELEV( ) C TO INTEGER C SEPTEMBER 2009 GLAHN REVISED THE LAPSE CALCULATIONS A BIT C JULY 2010 GLAHN ADDED NCEPNO TO CALL; USED NCEPNO AS C DD FOR UA DATA VICE IDPARS(4) C SEPTEMBER 2010 GLAHN MODIFIED FOR ONLY 6 UP LEVELS FOR C EKDMOS VICE 12 FOR MOS C SEPTEMBER 2010 GLAHN MODIFIED FORMATS 102, 1010, 1575, C 131; TEST IN ELEVHI ABOVE 154; COMMENT C MARCH 2012 GLAHN ADDED IDS; ADDED DIMENSION TO C ITABLE( , ) C SEPTEMBER 2013 GLAHN ADDED IDS FOR OBS & LAMP, TEMP & WIND C SEPTEMBER 2013 GLAHN CHANGED IBACKN TO APPLY TO MGUESS 1 C AND 4 AS WELL AS 2; COMMENTS C DECEMBER 2013 GLAHN REVISION TO USE WIND SPEED DIRECTLY C FROM INPUT RATHER THAN COMPUTE IT C DECEMBER 2013 GLAHN REPLACED +20000 TO ID(1) FOR 10-M WIND C WITH +1000 C DECEMBER 2013 GLAHN ADDED TIME INTERPOLATION BETWEEN TWO C 3-H PROJECTIONS OF UA DATA C DECEMBER 2013 GLAHN MODIFIED IDS FOR ACCESSING UA WINDS C DECEMBER 2013 GLAHN SWITCHED TO EARTH ORIENTED U AND V C JANUARY 2014 GLAHN ADDED USING PREVIOUS LAPSE FOR TOTAL C WIND FOR OBS AND LAMP WITH LAPFG = 4 C CAPABILITY C JANUARY 2014 GLAHN CORRECTED TIME INTERPOLATION; OTHER C MINOR CHANGES C MARCH 2014 GLAHN ADDED TWO MORE LEVELS FOR DETERMINING C HHIGH TO GET LAPSE, WHEN NECESSARY C MARCH 2014 GLAHN MODIFIED TO ACCOMMODATE ANY NDATE; C CHANGED NSTA TO NWORDS IN LOOPS C DO 133 AND DO 146 C MAY 2014 GLAHN DIMENSIONED NCEPNO(3); UPPER AIR C DATA ACCESSED BY NCEPNO(3) C JUNE 2014 GLAHN INSERTED IER=103 AFTER 109; C INSERTED IER = 777 AFTER 1091; C INSERTED IER = 777 TWICE AFTER 1093 C MAY 2015 GLAHN STATEMENT XLAPSE(K)=0 CHANGED BELOW C 200 TO XLAPSE(K)=HPLUS C JUNE 2015 GLAHN ADDED FSTGS = 5 CAPABILITY C NOVEMBER 2015 GLAHN/IM CHANGED ID FOR OBS AND LAMP DP IN C ITABLE( , , ) C DECEMBER 2015 GLAHN CHANGED ID FOR MOS DP IN ITABLE( , , ) C JANUARY 2015 GLAHN GFS MOS MAX AND MIN USE TEMP UA FOR C LAPSE, NOW OFFSET BY 6 H C FEBRUARY 2016 GLAHN SET TO ACCOMMODATE MOS GUST C C PURPOSE C TO COMPUTE A LAPSE RATE FOR EACH STATION OF THE VARIABLE C BEING ANALYZED FROM UPPER AIR AND POSSIBLY SURFACE DATA. C AVERAGE OF RUNS (CYCLES) IS USED FOR SURFACE DATA, BUT C ONLY THE ON-TIME CYCLE OF UPPER AIR DATA AND ONE LEVEL. C LEVEL IS USED FOR PROBABILITY LEVELS AND WILL NEED C SPECIAL TREATMENT. C C THE LAPSE CAN BE COMPUTED IN ONE OF TWO WAYS DEPENDING C ON THE VALUE OF LAPFG, OR A PREVIOUS LAPSE USED: C C LAPFG = 2. C THE LAPSE IS COMPUTED FROM THE FIRST LEVEL ABOVE THE C STATION ELEVATION ELEV( ) TO THE FIRST LEVEL ABOVE THE C HIGHEST GRIDPOINT TO CORRECT WITH THIS STATION C ELEVHI( ). HOWEVER, IF THIS LEVEL IS ABOVE THE 2ND C UPPER LEVEL, THE LEVEL BELOW IS USED. THIS MAKES THE C LAPSE COMPUTED OVER A RANGE OF ELEVATIONS ENCOMPASSING C THE STATION ELEVATION. IT DOES NOT USE THE DATA TO C ANALYZE. THIS MAY NOT WORK WELL IN INTENSE INVERSIONS. C C NOTE THAT THIS COMPUTES A GRADIENT BASED ON ONLY UPPER C AIR DATA, BUT APPLIES IT TO THE SURFACE OBSERVATION. C THE RESULTING VALUE (E.G. TEMPERATURE) AT HIGH C ELEVATIONS SHOULD NOT BE GREATLY DIFFERENT FROM THE C UPPER AIR VALUE AT THAT ELEVATION. FOR WIND U AND V, C THE INFLUENCE OF TERRAIN (FRICTION) ON THE SURFACE C WIND WILL BE FELT FOR SOME ELEVATIONS ABOVE A BASE C STATION, BUT EVENTUALLY, AT HIGH ELEVATIONS, BE NOT FAR C DIFFERENT FROM THE UPPER AIR COMPONENTS, AND THEREFORE C A COMPUTED DIRECTION. C C LAPFG = 3 OR 5. C THE LAPSE IS COMPUTED FROM THE STATION VALUE AT ITS C ELEVATION TO THE FIRST LEVEL ABOVE THE HIGHEST C GRIDPOINT TO CORRECT WITH THIS STATION ELEVHI( ). C BECAUSE THE ELEVATION CORRECTION IS TO BE APPLIED C TO THE SURFACE VALUE, IT SEEMS LAPFG = 3 SHOULD BE C BETTER THAN LAPFG = 2. C C THE NOMINAL LIMITS OF XLAPSE(K) WERE SET HPLUS = +.1 C AND HMINUS = -.1 WHEN THE LAPSE WAS COMPUTED FROM THE C SURFACE DATA ONLY IN LAPSE AND APPLIED TO ALL C VARIABLES. FOR WIND, .1 MPH PER METER EQUATES C APPROXIMATELY TO 30 MPH PER 1000 FT, WHICH IS NOT C UNREASONABLE, BUT COULD BE EXCEEDED. LAPSE RATES MAY C BE CALCULATED ON THE HIGH SIDE BECAUSE (1) MESONET C SURFACE WINDS MAY BE LOW, AND (2) THE UPPER AIR C WINDS ARE FREE AIR, NOT SURFACE. WHEN THE LAPSE WAS C BEING CALCULATED FROM ONLY SURFACE DATA, A LARGE C LAPSE MIGHT HAVE JUST BEEN AN ERROR, AND THE C LARGE VALUE WAS SET TO ZERO. WITH THIS CALCULATION, C USING UA DATA, THE POSSIBILITY OF CALCULATION ERORR C IS LESS, AND LARGE VALUES ARE SET TO HPLUS VICE C ZERO. BECAUSE THE UA VALUE IS NEAR THE ELEVATION C OF THE HIGHEST ELEVATION TO BE AFFECTED BY THE C DATA VALLUE, THE CORRECTIONS TO HIGH ELEVATIONS C SHOULD NOT BE EXCESSIVE, BUT CLOSELY MATCH THE UA C VALUE AT THAT ELEVATION. C C LAPFG = 4. C THIS IS FOR TOTAL WIND TO USE A LAPSE COMPUTED FOR C WIND SPEED. IT IS IMPLEMENTED FOR OBS AND LAMP. C C THE INTERPOLATION IS TO ALL STATIONS IN THE NSTA LIST, C NOT JUST THE ONES WITH DATA TO ANALYZE. THIS COULD BE C TRIMMED TO ONLY INTERPOLATE FOR NON-MISSING AND C NON-WATER POINTS WITH SOME EXTRA CODING. FOR ALASKA, C THIS IS NOT WORTH THE EFFORT, AND LAPSUA IS NOT C CURRENTLY USED FOR THE CONUS WHERE THE STATION LIST C IS LONG, EXCEPT FOR OBS/LAMP WIND. C C THERE CANNOT BE AN EXACT MATCH OF UA TEMPERATURE DATA C WITH MAX AND MIN, BECAUSE THEY COVER A PERIOD. THE C UA TAU USED IS THE SAME AS THE MAX OR MIN ANALYSIS. C C WHEN A MATCH OF TAU FOR UA DATA IS NOT FOUND, IBACKN C OR IBACKL IS USED TO LOOK FOR PRIOR DATES THAT VERIFY C AT THE SAME TIME. IF ONE CANNOT BE FOUND, THEN A TAU C 6-H PREVIOUS FOR THE SAME DATE IS TRIED. THIS IS C PRIMARILY FOR MAX TEMP. IBACKN AND IBACKL ARE C DETERMINED FROM LAPFG (WHICH SEE). C C THE UA DATA ARE PROVIDED AS GRIDDED. WHILE NOT C DIRECTLY OUTPUT BY NCEP, WIND SPEED HAS BEEN ALREADY C CALCULATED FROM U AND V. THIS MAY BE DIRECTLY FROM C THE GFS ARCHIVE, OR MAY HAVE BEEN CALCULATED FOR C LAMP. IT IS ASSUMED PROJECTIONS ARE EVERY 3 HOURS. C C TIME INTERPOLATION WAS NOT NECESSARY FOR ALASKA BECAUSE C THE ANALYSES WERE NO OFTENER THAN EVERY 3 HOURS, FOR C WHICH UA DATA WERE AVAILABLE. FOR THE 1-H LAMP ANALYSES, C INTERPOLATION OR SLIGHTLY OFF-TIME UA DATA WERE NEEDED. C C NOTE: CURRENTLY ACCOMMODATES TEMPERATURE (CONVERSION OF C UNITS AT DO 135) AND WIND (CONVERSION OF UNITS C AT DO 136). THE ORDER OF THE VARIABLES IN C ITABLE( , , ) IS IMPORTANT. C C THE IDS IN ITABLE( , , ) WILL HAVE TO BE CHECKED C OR ADDED TO WHEN DEALING WITH ANOTHER VARIABLE OR C MODEL (E.G., OBS, LAMP, ECMWFMOS). C C BY 4/6/12, THE ORIGINAL VERSION HAD ONLY BEEN C USED FOR ALASKA, THE NEW VERSION WAS CHECKED C WITH ALASKA WIND WITH IDENTICAL RESULTS. IDS C WERE UP TO DATE AS OF THIS 4/6/12. C C DATA SET USE C KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT) C KFIL10 - UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT/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 KFIL10 = UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT) C IP14 = UNIT NUMBER FOR WRITING COMPUTED LAPSE C RATES. (INPUT) C ID(J) = ID OF VARIABLE BEING ANALYZED (J=1,4). C (INPUT) C IDPARS(J) = THE PARSED, INDIVIDUAL COMPONENTS OF THE C ID'S CORRESPONDING TO ID( ) C (J=1,15). (INPUT) C J=1--CCC (CLASS OF VARIABLE), C J=2--FFF (SUBCLASS OF VARIABLE), C J=3--B (BINARY INDICATOR), C J=4--DD (DATA SOURCE, MODEL NUMBER), C J=5--V (VERTICAL APPLICATION), C J=6--LBLBLBLB (BOTTOM OF LAYER, 0 IF ONLY C 1 LAYER), C J=7--LTLTLTLT (TOP OF LAYER), C J=8--T (TRANSFORMATION), C J=9--RR (RUN TIME OFFSET, ALWAYS + AND BACK C IN TIME), C J=10--OT (TIME APPLICATION), C J=11--OH (TIME PERIOD IN HOURS), C J=12--TAU (PROJECTION IN HOURS), C J=13--I (INTERPOLATION TYPE), C J=14--S (SMOOTHING INDICATOR), AND C J=15--G (GRID INDICATOR). C NCEPNO(J) = ORIGINALLY DESIGNED A SINGLE NCEP MODEL NUMBER C FOR THE RUN WHEN ONLY ONE GRIDDED DD WAS C EXPECTED. TO PROVIDE FOR UP TO 3 GRIDS THAT C MIGHT BE NEEDED IN MERGING LAMP AND HRRR OR RAP, C IT HAS BEEN DIMENSIONED NCEPNO(J) (J=1,3). C ONE VALUE IS READ IN, AND PARSED INTO THREE C VARIABLES IN INT155. VARIABLE READ AS XXYYZZ C AND PARSED INTO NCEPNO(1)=XX, NCEPNO(2)=YY, C AND NCEPNO(3)=ZZ. NCEPNO(3) IS FOR UA DATA C FOR LAPSE. (OUTPUT) 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 DIR(K,J,M) = THE IX (J=1) AND JY (J=2) POSITIONS ON THE GRID C FOR THE COMBINATION OF GRID CHARACTERISTICS M C (M=1,NGRID) AND STATION K (K=1,NSTA) IN C NGRIDC( ,M). (INPUT) C NGRIDC(L,M) = HOLDS THE GRID CHARACTERISTICS (L=1,6) FOR EACH GRID C COMBINATION (M=1,NGRID). C L=1--MAP PROJECTION NUMBER (3=LAMBERT, 5=POLAR C STEREOGRAPHIC). C L=2--GRID LENGTH IN METERS, C L=3--LATITUDE AT WHICH GRID LENGTH IS CORRECT, C L=4--GRID ORIENTATION IN DEGREES, AND C L=5--LATITUDE OF LL CORNER IN DEGREES, C L=6--LONGITUDE OF LL CORNER IN DEGREES C (INPUT) C ND11 = MAXIMUM NUMBER OF GRID COMBINATIONS THAT CAN BE C DEALT WITH ON THIS RUN. LAST DIMENSION OF C NGRIDC( , ). (INPUT) C LAPFG = 0 COMPUTE LAPSE FROM DATA (NOT IN LAPSUA). C 1 COMPUTE LAPSE FROM FIRST GUESS (NOT IN LAPSUA). 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 FL174 = THE FILE NAME OF THE FILE PREPARED BY U174. C (CHARACTER*60) (INPUT) C XDATA(K,J,L) = HOLDS THE DATA TO ANALYZE (K=1,NSTA) C (J=2,NORUNS) (L=1,LEVELS). C THE DATA FOR THE FIRST CYCLE, IF THERE IS C MORE THAN ONE, IS IN COLUMN 2. PROBABILITY C LEVELS ARE IN THE 3RD DIMENSION. C DATA ARE READ INTO COLUMNS J=2,NORUNS. THE C DATA TO ANALYZE ARE PUT INTO COLUMN J=1. C (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 ELEVLO(K) = THE LOW ELEVATION ASSOCIATED WITH STATION C CCALL(K) (K=1,NSTA). NOTE THAT MISSING C VALUES ARE 999999, NOT 9999. ALSO, 888888 C CAN OCCUR. VALUES COME FROM U178. (INPUT) C ELEVHI(K) = THE HIGH ELEVATION ASSOCIATED WITH STATION C CCALL(K) (K=1,NSTA). THE HIGHEST GRIDPOINT C ELEVATION TO BE AFFECTED BY THIS STATION K. C NOTE THAT MISSING VALUES ARE -999999, NOT C 9999. ALSO, -888888 CAN OCCUR. THESE VALUES C COME FROM U178. (INPUT) C ELEV(K) = ELEVATION OF STATIONS (K=1,NSTA). (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 ALATL = NORTH LATITUDE OF LOWER LEFT CORNER POINT C OF A GRID OF THE SIZE NXL, NYL. TRUNCATED C TO TEN THOUSANDTHS OF DEGREES. NOTE THAT THE C MOS-2000 ARCHIVE IS ONLY TO THOUSANDTHS OF C DEGREES. (INPUT) C ALONL = WEST LONGITUDE OF LOWER LEFT CORNER POINT C OF A GRID OF THE SIZE NXL, NYL. TRUNCATED C TO TEN THOUSANDTHS OF DEGREES. NOTE THAT THE C MOS-2000 ARCHIVE IS ONLY TO THOUSANDTHS OF C DEGREES. (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 NXL = NUMBER OF GRIDPOINTS IN THE XI (LEFT TO RIGHT) C DIRECTION. (INPUT) C NYL = NUMBER OF GRIDPOINTS IN THE YJ (BOTTOM TO TOP) C DIRECTION. (INPUT) C BMESH = MESH LENGTH OF THE CURRENT GRID. (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 MGUESS = THE TYPE OF FIRST GUESS ACTUALLY USED (SEE C (IGUESS( )). SET IN FSTGS5. C 1 = CONSTANT. C 2 = FIRST GUESS GRID. C 3 = ALTERNATE FIRST GUESS GRID. C 4 = AVERAGE OF OBSERVATIONS. C (INPUT) C IBACKN = NUMBER OF 6-H CYCLES TO LOOK BACK FOR FIRST C GUESS WHEN MGUESS = 1,2, OR 4. IBACKN = 1 C MEANS CURRENT (MOST RECENT) CYCLE PLUS THE ONE C 6 HOURS BEFORE). NORMALLY, THIS IS 0 FOR C DEVELOPMENT; MAY BE OTHERWISE FOR OPERATIONS. C (INPUT) C IBACKL = NUMBER OF 6-H CYCLES TO LOOK BACK FOR FIRST C GUESS WHEN MGUESS = 3. IBACKL = 1 MEANS C CURRENT (MOST RECENT) CYCLE PLUS THE ONE C 6 HOURS BEFORE). NORMALLY, THIS IS 0 FOR C DEVELOPMENT; MAY BE OTHERWISE FOR OPERATIONS. C (INPUT) C LSTORE(L,J) = THE ARRAY HOLDING INFORMATION ABOUT THE DATA C STORED (L=1,12) (J=1,LITEMS). (INPUT) C ND9 = MAXIMUM NUMBER OF FIELDS STORED IN LSTORE( , ). C SECOND DIMENSION OF LSTORE( , ). (INPUT) C LITEMS = THE NUMBER OF ITEMS J IN LSTORE(L,J). C (INPUT) C NDATE = THE DATE/TIME OF THE RUN. (INPUT) C JHR = THE HOUR IN NDATE. (INPUT) C IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,4). C IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,21+). C IS2(J) = MOS-2000 GRIB SECTION 2 ID'S (J=1,12). C IS4(J) = MOS-2000 GRIB SECTION 4 ID'S (J=1,4). C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND IS4( ). C (INPUT) C IPACK(J) = WORK ARRAY FOR GFETCH (J=1,ND5). (INTERNAL) C IWORK(J) = WORK ARRAY FOR GFETCH (J=1,ND5). (INTERNAL) C DATA(J) = WORK ARRAY FOR GFETCH (J=1,ND5). (INTERNAL) C ND5 = DIMENSION OF IPACK( ), WORK( ), AND DATA( ). C (INPUT) C CORE(J) = SPACE ALLOCATED FOR SAVING PACKED GRIDPOINT C FIELDS (J=1,ND10). WHEN THIS SPACE IS C EXHAUSTED, SCRATCH DISK WILL BE USED. THIS IS C THE SPACE USED FOR THE MOS-2000 INTERNAL RANDOM C ACCESS SYSTEM. (INPUT) C ND10 = THE MEMORY IN WORDS ALLOCATED TO THE SAVING OF C DATA CORE( ). WHEN THIS SPACE IS EXHAUSTED, C SCRATCH DISK WILL BE USED. (INPUT) C NBLOCK = BLOCK SIZE IN WORDS OF INTERNAL MOS-2000 DISK C STORAGE. (INPUT) C NFETCH = INCREMENTED EACH TIME DATA ARE FETCHED BY C GFETCH. IT IS A RUNNING COUNT FROM THE C BEGINNING OF THE PROGRAM. THIS COUNT C IS MAINTAINED IN CASE THE USER NEEDS IT C (DIAGNOSTICS, ETC.). (OUTPUT) C MISTOT = RUNNING TOTAL OF RETRIEVED GRIDS WITH ONE OR C MORE MISSING VALUES. (INPUT/OUTPUT) C NSLAB = SLAB OF THE GRID CHARACTERISTICS. RETURNED C BY GFETCH. USED FOR CHECKING FOR EQUAL C CHARACTERISTICS OF GRIDS READ. (INTERNAL) C NPROJ = NUMBER OF MAP PROJECTION TO WHICH THIS GRID C APPLIES. C 3 = LAMBERT. C 5 = POLAR STEREOGRAPHIC. C 7 = MERCATOR. C (INPUT) C ORIENT = ORIENTATION OF GRID IN WEST LONGITUDE. (INPUT) C XLAT = NORTH LATITUDE AT WHICH GRIDLENGTH IS SPECIFIED C IN DEGREES. (INPUT) C L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING C USED (EITHER 32 OR 64). (INPUT) C ISTOP(J) = ISTOP(1)--IS INCREMENTED BY 1 EACH TIME AN ERROR C OCCURS. C ISTOP(3)--IS INCREMENTED WHEN A DATA RECORD C COULD NOT BE FOUND. C (INPUT/OUTPUT) C IER = STATUS RETURN. C 0 = GOOD RETURN. C 103 = VARIABLE NOT ACCOMMODATED, EITHER C CCCFFF OR DD. C 777 = FATAL ERROR. C (OUTPUT) C NRESET = THE NUMBER OF COMPUTED LAPSE RATES DEEMED OUT C OF REASONABLE RANGE AND SET TO ZERO. C (INTERNAL) C XAXLAP = THE MAXIMUM COMPUTED LAPSE RATE. (INTERNAL) C XINLAP = THE MINIMUM COMPUTED LAPSE RATE. (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 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 ITABLE(J,M,N) = CORRESPONDENCE TABLE BETWEEN ANALYSIS ID AND C THE DATA TO ACCESS; C J=1--CCCFFFB00 OF THE VARIABLE BEING ANALYZED C J=2--2ND ID WORD OF THE VARIABLE BEING ANALYZED C J=3--CCCFFF000 OF THE UPPER AIR FIELD TO ACCESS C FOR THE VARIABLE BEING ANALYZED. C (M=1,NDIM) (N=1,MDIM) (SEE DATA STATEMENT C BELOW FOR EXPLANATION.) (INTERNAL) C NDIM = THE NUMBER OF VARIABLES FOR WHICH THE LAPSE C CAN BE CALCULATED. SET BY PARAMETER. C (INTERNAL) C JDIM = NUMBER OF LEVELS OF DATA NEEDED. DETERMINED C BY WHETHER THE ENTRY IS MOS, EKDMOS, OR ECMWF. C (INTERNAL) C LDIM = MAXIMUM OF LDIM LEVELS OF UP DATA PROVIDED. C SET BY PARAMETER. (INTERNAL) C JTABLE(M,L) = THE LEVELS OF UPPER AIR DATA THAT CAN C BE ACCESSED FOR COMPUTING THE LAPSE RATE C (M=1,LDIM) FOR GFS AND ETA, (L=1) AND C EKDMOS AND ECMWF (L=2). (INTERNAL) C AVXDAT(K) = THE AVERAGE OF THE CYCLES IN XDATA(K,M,1), C (K=1,NSTA), M=2,LEVELS+1). (AUTOMATIC) C (INTERNAL) C JDATE = DATE UA DATA ARE NEEDED. MUST BE ON EVEN C 6-H CYCLES. UPDATED IN CASE OF BACKUP CYCLES. C (INTERNAL) C VDATA(K,J) = THE DATA VALUES OF THE VARIABLE FOR WHICH C THE LAPSE IS BEING COMPUTED FOR EACH C STATION (K=1,NSTA), EACH VERTICAL LEVEL C (J=1,LDIM). (INTERNAL) (ALLOCATED) (SAVED) C IDVSAV = THE ID OF THE DATA IN VDATA( , ), THE C THIRD WORD IN ITABLE( , , ). (INTERNAL) C (SAVED) C HDATA(K,J) = THE HEIGHTS OF THE VARIABLE FOR WHICH C THE LAPSE IS BEING COMPUTED CORRESPONDING TO C VDATA(K,J) (K=1,NSTA) (J=1,LDIM). (INTERNAL) C (ALLOCATED) (SAVED) C XSAVE(K) = SAVED LAPSE RATES IN XLAPSE( ) IN CASE THEY C CAN BE REUSED. (INTERNAL) (ALLOCATED) C (SAVED) C IFIRST = CONTROLS PRINTING TO IP14. (INTERNAL) C JFIRST = CONTROLS ALLOCATION AND PRINTING. (INTERNAL) C (SAVED) C IDSAV = THE ID INFORMATION ASSOCIATED WITH THE DATA IN C VDATA( , ). (INTERNAL) (SAVED) C NDATSV = THE DATE ASSOCIATED WITH THE DATA IN C VDATA( , ). (INTERNAL) (SAVED) C NTAUSV = THE PROJECTION ASSOCIATED WITH THE DATA IN C VDATA( , ). (INTERNAL) (SAVED) C IDPS12 = SAVES IDPARS(12). UPPER AIR DATA ARE NOT C AVAILABLE IN OUR ARCHIVE (WHAT'S USED FOR LAPSE C COMPUTATION) AT 198 HOURS, SO THE LAPSE FOR C MAX TEMP AT 198 HOURS CAN'T BE CALCULATED. C AN UPPER AIR FORECAST FOR 192 HOURS IS TRIED C FOR THE SAME DATE. (IT MAY BE THERE IS NO C LONGER A NEED FOR THIS--1/22/14.) (INTERNAL) C LAPSV = SAVES THE TYPE OF LAPSE RATE SAVED IN XSAVE( ). C WHEN IT IS 2, THE LAPSE WAS CALCULATED FROM C ONLY UPPER AIR DATA AND COULD BE REUSED. WHEN C IT IS 3, IT CANNOT BE USED BECAUSE SURFACE DATA C OF THE VARIABLE BEING ANALYZED IS USED. IF C THE SAVED LAPSE( ) IS MISSING (=0), C LAPSV = 9999. (INTERNAL) (SAVED) C SV174 = THE FILE NAME OF THE FILE PREPARED BY U174 USED C FOR THE LAPSE SAVED IN XDAVE( ). C (CHARACTER*60) (INTERNAL) (SAVED) C DATA1(K) = WORK ARRAY (K=1,ND5). (INTERNAL) (AUTOMATIC) C 1 2 3 4 5 6 7 X C NONSYSTEM SUBROUTINES USED C INTRPX, TIMPR, UPDAT, GFETCH C PARAMETER (NDIM=9) PARAMETER (MDIM=8) PARAMETER (LDIM=12) C CHARACTER*8 CCALL(ND1) CHARACTER*20 NAME(ND1) CHARACTER*60 FL174,SV174 C DIMENSION ID(4),IDPARS(15) DIMENSION LNDSEA(NSTA),ELEV(NSTA), 1 XLAPSE(NSTA),XPL(NSTA),YPL(NSTA), 2 ELEVHI(NSTA),ELEVLO(NSTA) DIMENSION AVXDAT(NSTA) C AVXDAT( ) IS AN AUTOMATIC ARRAY. DIMENSION XDATA(ND1,NORUNS+1,LEVELS) DIMENSION DIR(ND1,2,ND11),NGRIDC(6,ND11) DIMENSION IPACK(ND5),IWORK(ND5),DATA(ND5) DIMENSION DATA1(ND5) C DATA1( ) IS AN AUTOMATIC ARRAY. DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION LSTORE(12,ND9) DIMENSION CORE(ND10) DIMENSION ISTOP(6),LD(4) DIMENSION ITABLE(3,NDIM,MDIM) DIMENSION JTABLE(LDIM,2),IDTYP(MDIM) DIMENSION NCEPNO(3) C ALLOCATABLE VDATA(:,:),HDATA(:,:),XSAVE(:) SAVE VDATA,HDATA,XSAVE,JFIRST,IDSAV,NTAUSV,NDATSV,LAPSV,IDVSAV C DATA IFIRST/0/ DATA JFIRST/0/ DATA HMINUS/-.1/, 1 HPLUS/+.1/ DATA IDSAV /0/, 1 NDATSV/0/, 2 NTAUSV/0/, 3 IDVSAV/0/ DATA SV174/' '/ C C THE DD'S OF THE 8 TYPES OF DATA HANDLED IN ORDER: C OBS, LAMP, GMOS, EKDMOS, NAMMOS, ECMWFMOS, COMBINED MOS, C OPEN SLOT. THESE ARE THE MDIM TIERS IN ITABLE( , ,MDIM) C DATA IDTYP/85,05,08,61,07,01,00,00/ C C THE FIRST DIMENSION OF ITABLE( , , ) CONTAINS THE FIRST C AND SECOND IDS OF THE VARIABLE ANALYZED AND THE FIRST WORD C OF THE UA DATA TO ACCESS FOR THAT VARIABLE. THE SECOND C DIMENSION IS THE VARIABLE, OF WHICH THERE ARE CURRENTLY C NINE. THE THIRD DIMENSION IS FOR THE TYPE OF DATA, OF C WHICH THERE ARE SEVEN PROVIDED: OBS, LAMP, GMOS, EKDMOS, C NAM MOS, COMBINED MOS (E.G., ECMWF WTIH GMOS), AND AN C EXPANSION SLOT. C C THE BELOW ARE IN ORDER (SECOND DIMENSION): C HOURLY TEMPERATURE UA TEMPERATURE IS USED C HOURLY DEW POINT UA TEMPERATURE IS USED FOR DEW POINT C MAX TEMPERATURE UA TEMPERATURE IS USED FOR MAX TEMP C MIN TEMPERATURE, UA TEMPERATURE IS USED FOR MIN TEMP C APPARENT TEMPERATURE UA TEMPERATURE IS USED FOR APP TEMP C WIND SPEED UA SPEED IS USED FOR TOTAL WIND C U-WIND UA U-WIND IS USED C V-WIND UA V-WIND IS USED C WIND GUST (ACTUALLY, TOTAL WIND) LAPSE SAME AS FOR SPEED C C THE FIRST TIER IS OBS. C DATA ITABLE/722030000,000000000,002000000, 2 723130000,000000000,003100000, !CHANGED UA FOR DP TO DP NOVEMBER 3 000000000,000000000,002000000, 4 000000000,000000000,002000000, 5 000000000,000000000,000000000, 6 724330000,000000000,004210000, 7 724020000,000000000,004000000, 8 724120000,000000000,004100000, 9 724390000,000000000,004210000, C C THE SECOND TIER IS LAMP. C 1 222030000,000000000,002000000, 2 223030000,000000000,003100000, !CHANGED UA FOR DP TO DP NOVEMBER 3 000000000,000000000,002000000, 4 000000000,000000000,002000000, 5 000000000,000000000,000000000, 6 224335000,000000000,004210000, 7 224020000,000000000,004000000, 8 224120000,000000000,004100000, 9 224390000,000000000,004210000, C C THE THIRD TIER IS GFS MOS. C 1 222020000,000000000,002000000, 2 223020000,000000000,003100000, !CHANGED UA FOR DP TO DP 12/9/15 3 222120000,000000000,002000000, 4 222220000,000000000,002000000, !CHANGED UA FOR MIN TEMP TO TEMP 1/19/16 5 000000000,000000000,000000000, 6 224360000,000000000,004210000, 7 224060000,000000000,004000000, 8 224160000,000000000,004100000, 9 224385000,000000000,004210000, C C THE FOURTH TIER IS EKDMOS. C 1 222020000,000000000,002000000, 2 223020000,000000000,002000000, 3 222120000,000000000,002000000, 4 222220000,000000000,002000000, 5 222060000,000000000,002000000, 6 224360000,000000000,004210000, 7 224060000,000000000,004000000, 8 224160000,000000000,004100000, 9 224390000,000000000,004210000, C C THE FIFTH TIER IS NAM MOS. C 1 222020000,000000000,002000000, 2 223020000,000000000,002000000, 3 222120000,000000000,002000000, 4 222220000,000000000,002000000, 5 000000000,000000000,000000000, 6 224360000,000000000,004210000, 7 224060000,000000000,004000000, 8 224160000,000000000,004100000, 9 224390000,000000000,004210000, C C THE SIXTH TIER IS ECMWF MOS. C 1 222020000,000000000,002000000, 2 223020000,000000000,002000000, 3 222120000,000000000,002000000, 4 222220000,000000000,002000000, 5 000000000,000000000,000000000, 6 224360000,000000000,004210000, 7 224060000,000000000,004000000, 8 224160000,000000000,004100000, 9 224390000,000000000,004210000, C C THE SEVENTH TIER IS COMBINED MOS. C 1 222020000,000000000,002000000, 2 223020000,000000000,002000000, 3 222120000,000000000,002000000, 4 222220000,000000000,002000000, 5 000000000,000000000,000000000, 6 224360000,000000000,004210000, 7 224060000,000000000,004000000, 8 224160000,000000000,004100000, 9 224390000,000000000,004210000, C C THE EIGHTH TIER IS AN EXPANSION SLOT. C IF USED, THE USES OF L MUST BE DEFINED BELOW. C 1 000000000,000000000,000000000, 2 000000000,000000000,000000000, 3 000000000,000000000,000000000, 4 000000000,000000000,000000000, 5 000000000,000000000,000000000, 6 000000000,000000000,000000000, 7 000000000,000000000,000000000, 8 000000000,000000000,000000000, 9 000000000,000000000,000000000/ C C********************************************************************* C NOTE THAT THE UNITS CONVERSIONS ARE KEYED TO THE ORDER ABOVE C AT DO 135 AND DO 136. OTHER DECISIONS ARE ALSO BASED ON C ORDER. MAKE ADDITIONS AT END. C********************************************************************* C C THESE ARE THE LEVELS OF UPPER AIR DATA AVAILABLE TO BE C ACCESSED FOR THE DIFFERENT TYPES OF DATA. 12 LEVELS ARE C TO BE USED, EXCEPT FOR EKDMOS AND ECMWF. IF A LEVEL CANNOT C BE FOUND, PROCESSING CAN PROCEED WITHOUT IT. THE "2" FOR C THE FIRST LEVEL IS FOR TEMP AND DEWPOINT; FOR WIND, THE C VALUE IS "10". C DATA JTABLE/ 1 2,1000,975,950,925,900,850,800,750,700,600,500, 2 2,1000, 925, 850, 700, 500,0,0,0,0,0,0/ C CALL TIMPR(KFILDO,KFILDO,'START LAPSUA ') IER=0 C C SET XLAPSE( ) = 0. IN CASE IT CAN'T BE COMPUTED. C DO 100 K=1,NSTA XLAPSE(K)=0. 100 CONTINUE C IDPS12=IDPARS(12) C THIS IS FOR RECYCLING TO USE UPPER AIR DATA FOR A PROJECTION C 6-H EARLIER PRIMARILY FOR THE 198-H MAX TEMP PROBLEM. C C DETERMINE WHETHER THIS IS GFS MOS OR GEFS EKDMOS. C IF(IDPARS(4).EQ.85.OR. 1 IDPARS(4).EQ.05.OR. 2 IDPARS(4).EQ.08.OR. 3 IDPARS(4).EQ.07)THEN JDIM=12 C THIS IS GFS MOS, LAMP, OR OBS. ELSEIF(IDPARS(4).EQ.76)THEN JDIM=6 C THIS IS GEFS EKDMOS. ELSE WRITE(KFILDO,101)IDPARS(4) 101 FORMAT(/' ****IDPARS(4) =',I3,' NOT AN EXPECTED VALUE', 1 ' IN LAPSUA AT 101. RETURN WITH IER = 777.') IER=777 GO TO 250 ENDIF C D WRITE(KFILDO,102)NDATE,ND5,ND7,ND10,ND9,ND1,NSTA,IDPARS(12), D 1 NPROJ,ORIENT,XLAT,BMESH,L3264B D102 FORMAT(/,' AT 102 IN LAPSUA--', D 1 'NDATE,ND5,ND7,ND10,ND9,ND1,NSTA,IDPARS(12,', D 2 'NPROJ,ORIENT,XLAT,BMESH,L3264B',/, D 3 I12,8I8,2F10.4,F10.6,I4) C CCCD WRITE(KFILDO,1010)(K,CCALL(K),NAME(K),ELEV(K), CCCD 1 ELEVHI(K),ELEVLO(K),XPL(K),YPL(K),LNDSEA(K), CCCD 2 K=1,NSTA) CCCD1010 FORMAT(/' AT 1010--K,CCALL(K),NAME(K),ELEV(K),', CCCD 1 'ELEVHI(K),ELEVLO(K),XPL(K),YPL(K),LNDSEA(K)',/, CCCD 2 (I6,2X,A8,2X,A20,5F11.2,I5)) C C ALLOCATE ARRAYS. THIS SHOULD BE DONE ONLY ONCE, AND SAVED. C IF(JFIRST.EQ.0)THEN ALLOCATE (VDATA(NSTA,LDIM),HDATA(NSTA,LDIM),XSAVE(NSTA), 1 STAT=IOS) C IF(IOS.EQ.1)THEN C IF(JFIRST.EQ.0)THEN WRITE(KFILDO,103) 103 FORMAT(/' ****ALLOCATION OF XSAVE( ), VDATA( , ) OR', 1 ' HDATA( , ) FAILED IN LAPSUA AT 103.', 2 ' ARRAY ALREADY ALLOCATED.') C IT IS EXPECTED THE ARRAYS WILL ALREADY BE ALLOCATED C EXCEPT ON FIRST ENTRY. ISTOP(1)=ISTOP(1)+1 IER=777 GO TO 250 ENDIF C ELSEIF(IOS.EQ.2)THEN WRITE(KFILDO,104) 104 FORMAT(/' ****ALLOCATION OF XSAVE( ), VDATA( , ) OR', 1 ' HDATA( , ) FAILED IN LAPSUA AT 104.', 2 ' ARRAY NOT ALLOCATED.') ISTOP(1)=ISTOP(1)+1 IER=777 GO TO 250 ENDIF C JFIRST=1 C JFIRST = 1 SIGNIFIES ALLOCATION HAS BEEN SUCCESSFUL. C IT SHOULD NOT BE DONE AGAIN ON THIS RUN. ENDIF C C DETERMINE WHETHER THIS MODEL IS ACCOMMODATED. IF SO, C N IS SET. C DO 1045 N=1,NDIM IF(IDPARS(4).EQ.IDTYP(N))GO TO 1047 1045 CONTINUE C C DROP THROUGH HERE MEANS THE DD WAS NOT FOUND. ABORT. C WRITE(KFILDO,1046)IDPARS(4),(IDTYP(N),N=1,NDIM) 1046 FORMAT(/' *****DD OF VARIABLE NOT FOUND IN LAPSUA SO ABORT.', 1 ' LIST SEARCHED:',20I4) IER=103 GO TO 250 C C DETERMINE WHETHER THIS VARIABLE IS ACCOMMODATED. C 1047 DO 105 L=1,NDIM C IF(ID(1)/100.EQ.ITABLE(1,L,N)/100)GO TO 108 C THIS DEFINES L. THE DD IS NOT CHECKED. C ID(2) IS NOT CHECKED BECAUSE OF EKDMOS. C 105 CONTINUE C C DROP THROUGH HERE MEANS THE ID WAS NOT FOUND. C ISTOP(1)=ISTOP(1)+1 IER=103 WRITE(KFILDO,107)(ID(J),J=1,4),IER 107 FORMAT(/' ****VARIABLE ',I9.9,I10.9,I10.9,I4.3,' NOT', 1 ' ACCOMMODATED IN SUBROUTINE LAPSUA. IER =',I3) GO TO 250 C 108 CONTINUE C D WRITE(KFILDO,1085)NDATE,NDATSV,ID(1),IDSAV, D 1 IDPARS(12),NTAUSV,IDVSAV,LAPSV D1085 FORMAT(/' AT 1085--NDATE,NDATSV,', D 1 'ID(1),IDSAV,IDPARS(12),NTAUSV,IDVSAV,LAPSV'/, D 2 (8I12)) C C TAKE CARE OF LAPFG = 4. TOTAL WIND USES LAPSE FROM SPEED, C BUT SEQUENCE IS SEPARATED BY U AND V, SO NORMAL REUSE C SEQUENCE WON'T WORK. C IF(LAPFG.EQ.4)THEN C IF(L.EQ.9)THEN C THIS IS TOTAL WIND. C IF(N.EQ.1)THEN C THIS IS OBS. LD(1)=704330000+IDTYP(N) LD(2)=980000 LD(3)=0 LD(4)=0 ELSEIF(N.EQ.2)THEN C THIS IS LAMP. LD(1)=204325000+IDTYP(N) LD(2)=980000 LD(3)=IDPARS(12) LD(4)=0 ELSEIF(N.EQ.3)THEN C THIS IS GFS MOS. LD(1)=204335000+IDTYP(N) LD(2)=980000 LD(3)=IDPARS(12) LD(4)=0 ELSE WRITE(KFILDO,109)(ID(J),J=1,4) 109 FORMAT(/' ****VARIABLE ',3I11.9,I11.3, 1 ' NOT ACCOMMODATED IN LAPSUA WITH LAPFG = 4.') IER=103 ISTOP(1)=ISTOP(1)+1 GO TO 250 ENDIF C CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,XLAPSE,NSTA, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) C IF(IER.NE.0)THEN ISTOP(1)=ISTOP(1)+1 ISTOP(3)=ISTOP(3)+1 WRITE(KFILDO,1091) 1091 FORMAT(/' ****CANNOT READ DESIRED XLAPSE( ) RECORD IN', 1 ' LAPSUA AT 1091.', 2 ' CANNOT USE XLAPSE( ) FROM PREVIOUS ANALYSIS.') GO TO 250 ENDIF C IF(NWORDS.NE.NSTA)THEN ISTOP(1)=ISTOP(1)+1 WRITE(KFILDO,1093) 1093 FORMAT(/' ****NUMBER OF WORDS RETURNED FROM GFETCH NOT', 1 ' CONSISTENT EQUAL TO NSTA IN LAPSUA AT 1093.', 2 ' CANNOT USE XLAPSE( ) FROM PREVIOUS ANALYSIS.') IER=777 GO TO 250 ENDIF C CCCC WRITE(KFILDO,1094)(LD(LLL),LLL=1,4),(IS2(LLL),LLL=2,9),NSLAB CCCC 1094 FORMAT(/' IN LAPSUA AT 1094--(LD(LLL),LLL=1,4),(IS2(LLL),', CCCC 1 'LLL=2,9),NSLAB',/4I10,9I10) C GO TO 250 C READING OF LAPSE( ) WAS SUCCESSFUL, SO RETURN. ELSE WRITE(KFILDO,109)(ID(J),J=1,4) IER=777 ISTOP(1)=ISTOP(1)+1 GO TO 250 ENDIF C ENDIF C C DETERMINE WHETHER THE SAVED LAPSE IN XSAVE( ) CAN BE REUSED. C IF(LAPFG.EQ.LAPSV.AND.FL174.EQ.SV174)THEN C ONLY WHEN THE TYPE OF LAPSE NEEDED AND SAVED ARE THE SAME C CAN THE SAVED LAPSE IN XSAVE( ) POSSIBLY BE USED. ALSO C THE U174 FILES BETTER BE THE SAME, OR DIFFERENT STATIONS C MAY BE INVOLVED. THE SEQUENCES OF IDS (T, TD AND C S, U, V, D, G) ARE MAINTAINED TO SUPPORT CONSISTENCY C OF THROWOUT AND OF NECESSARY REUSE OF LAPSE. FOR C INSTANCE, TD NEEDS TO USE TEMP LAPSE, AND NOT COMPUTE C IT USING SURFACE DP DATA. C C THE TEST BELOW REQUIRES THE SAME DATE AND TAU, AND THE C SAME UPPER AIR DATA. THE SAME UA DATA ONLY APPLIES C TO THE TEMPERATURE SUITE, WHERE THE LAPSE FOR C TEMPERATURE IS APPLED TO MAX, MIN, DEW POINT, AND C APPARENT TEMPERATURE. C IF(NDATSV.EQ.NDATE.AND. 1 NTAUSV.EQ.IDPARS(12).AND. 2 IDVSAV.EQ.ITABLE(3,L,N)+IDPARS(4))THEN C DO 110 K=1,NSTA XLAPSE(K)=XSAVE(K) 110 CONTINUE C WRITE(KFILDO,112)(ID(JJ),JJ=1,4) 112 FORMAT(/' SAVED LAPSE BEING USED FOR VARIABLE ', 1 I9.9,I10.9,I10.9,I4.3) GO TO 250 C ENDIF C ENDIF C THE LAPSE NEEDED IS NOT OF TYPE LAPFT = 2 OR THE LAPSE SAVED IN C XSAVE( ) WAS NOT OF THE TYPE 2. SO, COMPUTE IT. C KZERO=0 KMINUS=0 KPLUS=0 C NRESET=0 C NRESET COUNTS THE NUMBER OF COMPUTED LAPSE RATES C DEEMED OUT OF REASONABLE RANGE AND SET TO ZERO. XAXLAP=0. C XAXLAP IS THE MAXIMUM POSITIVE COMPUTED LAPSE RATE. XINLAP=0. C XINLAP IS THE MINIMUM NEGATIVE COMPUTED LAPSE RATE. C C CYCLE OVER IBACKN CYCLES IF PRIMARY FIRST GUESS, A CONSTANT, C OR AVERAGE OF DATA IS USED, OR IBACKL IS USED IF THE C SECONDARY IS USED. C IF(MGUESS.EQ.3)THEN IBACK=IBACKL ELSE IBACK=IBACKN ENDIF C DO 230 KCYCLE=0,IBACK C IBACK CAN EQUAL 0. C C READ UPPER AIR DATA AND COMPUTE VALUE OF ELEMENT AND, C IF NEEDED, ITS HEIGHT AT EACH STATION. THE ELEVATIONS FOR C WHICH DATA ARE AVAILABLE ARE IN JTABLE EXCEPT FOR LEVEL 1. C THE PROJECTIONS ARE AVAILABLE EVERY 3 HOURS ON THE ARCHIVE. C DO TIME INTERPOLATION IF NECESSARY. C DO 150 J=1,JDIM C C LOOP OVER VERTICAL LEVELS C C READ THE ELEMENT VALUES FOR EACH LEVEL. C FORM THE ELEMENT ID IN LD( ). C LD(1)=ITABLE(3,L,N)+NCEPNO(3) C C READ THE HEIGHTS ONLY IF NECESSARY. THIS ASSUMES THAT IF C ANY ANALYSIS HAS BEEN MADE FOR THIS PROJECTION, THE HEIGHTS C EXIST. C D WRITE(KFILDO,1285)NDATSV,NTAUSV,IDVSAV,(ID(JJ),JJ=1,3), D 1 ITABLE(3,L,N),NDATE,IDPARS(12) D1285 FORMAT(/' AT 1285--NDATSV,NTAUSV,IDVSAV,(ID(JJ),JJ=1,3)', D 2 'ITABLE(3,L,N),NDATE,IDPARS(12)',/, D 3 (9I12)) C D WRITE(KFILDO,1286)IDVSAV,L,ITABLE(3,L,N) D1286 FORMAT(/' AT 1286--IDVSAV,L,ITABLE(3,L,N)',3I12) C IF(N.NE.3.OR.(L.NE.3.AND.L.NE.4))THEN C THIS IS GFS MOS MAX OR MIN, AND THE TEST ON PROJECTION C IDPARS(12) IS NOT CORRECT FOR OFFSETS THAT MAX AND MIN C HAVE. ADDED 1/20/16 C IF(NDATSV.EQ.NDATE.AND. 1 NTAUSV.EQ.IDPARS(12))THEN C IF(IDVSAV.EQ.ITABLE(3,L,N))THEN C IF(J.GT.1)GO TO 151 C LOOP HAS BEEN EXECUTED ONCE WITH DIAGNOSTICS. IF c DATA ARE AVAILABLE, HEIGHTS ARE ALSO. EXIT LOOP. C WRITE(KFILDO,129)(ID(JJJ),JJJ=1,4) 129 FORMAT(/' UPPER AIR DATA ALREADY EXIST WHEN', 1 ' PROCESSING ',4I11) GO TO 1362 ENDIF C ENDIF C ENDIF C C THE LOWEST LEVEL OF TEMPERATURE AND WIND HAVE THE HEIGHT C IN METERS IN THE 2ND WORD AND A DIFFERENT FFF. THE OTHER C LEVELS HAVE THE HEIGHT IN MB GIVEN IN JTABLE( ) AND THE C CCCFFFB IN ITABLE(3, , ). ONLY FOR THE 1ST LEVEL IS THE C CCCFFFB AND 2ND WORD DIFFERENT FOR DIFFERENT WEATHER C ELEMENTS. C IF(J.EQ.1)THEN C THIS IS THE FIRST LEVEL. C IF(L.LE.5)THEN LD(1)=LD(1)+1000 C THE 2-M TEMPERATURE HAS A FFF = 001. LD(2)=2 ELSEIF(L.EQ.6.OR.L.EQ.9)THEN LD(1)=LD(1)+1000 C THE 10-M WIND SPEED HAS FFF = 211 LD(2)=10 ELSE LD(1)=LD(1)+11000 C THE 10-M U AND V WIND HAS FFF = 011 AND 111, C RESPECTIVELY. LD(2)=10 ENDIF C ELSE C IF(L.EQ.7.OR.L.EQ.8)THEN LD(1)=LD(1)+10000 C THE PRESSURE LEVEL U AND V WIND HAS FFF = 010 AND 110, C RESPECTIVELY. THE WIND SPEED, WIND GUST, AND TEMPERATURE C SUITE HAVE THE ITABLE(3,L, ) VALUES. ENDIF C C ADD THE PRESSURE LEVEL. C IF(JDIM.EQ.12)THEN LD(2)=JTABLE(J,1) C THIS IS FOR GFS MOS, LAMP. OR OBS. ELSE LD(2)=JTABLE(J,2) C THIS IS FOR GEFS EKDMOS AND ECMWF. ENDIF C ENDIF C IF(IDPARS(12)+KCYCLE*6.LT.0)GO TO 230 C WHEN THIS LOOP IS REPEATED (AFTER EXITING ONCE), C IDPARS(12) MAY = NEGATIVE. C INC6=MOD(JHR,6) C INC6 IS THE NUMBER OF HOURS FROM THE START HOUR C TO GO BACK FOR A 6-H HR UA RUN TIME. INC3=MOD(JHR+IDPARS(12),3) C INC3 IS THE NUMBER OF HOURS FROM THE PROJECTION C TO GO FORWARD TO GET ANOTHER VALUE FOR TIME INTERPOLATION. C A ZERO INDICATES INTERPOLATION IS NOT NEEDED. CALL UPDAT(NDATE,-KCYCLE*6-INC6,JDATE) C JDATE IS THE 6-H UA RUN TIME. LD(3)=IDPARS(12)+KCYCLE*6+INC6 C LD(3) IS THE PROJECTION NEEDED FROM JDATE. LD(3)=LD(3)-MOD(LD(3),3) C LD(3) IS THE PROJECTION BEFORE OR ON THE ONE NEEDED C OCCURRING ON 3-H PROJECTION INTERVALS. C IF(N.EQ.3.AND.(L.EQ.3.OR.L.EQ.4))THEN LD(3)=LD(3)-6 C THIS IS GFS MOS MAX OR MIN. OFFSET THE TEMP FOR LAPSE C BY 6 HR. THIS IS IN AGREEMENT WITH THE DMO FG. (THIS C MAY NOT WORK FOR OTHER THAN CONUS.) ENDIF C LD(4)=ID(4) C CCCC WRITE(KFILDO,1295)(LD(JJJ),JJJ=1,4),NDATE,INC3 CCCC 1295 FORMAT(' AT 1295 IN LAPSUA--(LD(JJJ),JJJ=1,4),NDATE,INC3', CCCC 1 3(2X,I10.9),2X,I10.3,I14,I4) C CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DATA,ND5, 2 NWORDS,NPACK,JDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 C CCCC WRITE(KFILDO,1296)ND5,NWORDS,NSLAB,(IS2(JJJ),JJJ=1,9) CCCC 1296 FORMAT(/' AT 1296 IN LAPSUA--ND5,NWORDS,NSLAB,', CCCC 1 '(IS2(JJJ),JJJ=1,9)',/,12I11) C IF(IER.NE.0)THEN ISTOP(3)=ISTOP(3)+1 IER=0 C IER IS SET = 0 SO IT WON'T BE NON ZERO ON RETURN. GO TO 220 ENDIF C C THIS GRID MAY NOT HAVE THE SAME CHARACTERISTICS AS C THE ANALYSIS GRID, BUT THEY ARE CONTAINED IN C NGRIDC( ,NSLAB). CHECK TO MAKE SURE THE DEFINITION C IN IS2( ) MATCHES NGRIDC( ,NSLAB). THIS IS A SAFETY. C IF(NGRIDC(1,NSLAB).NE.IS2(2).OR. 1 NGRIDC(2,NSLAB).NE.IS2(8).OR. 2 NGRIDC(3,NSLAB).NE.IS2(9).OR. 3 NGRIDC(4,NSLAB).NE.IS2(7).OR. 4 NGRIDC(5,NSLAB).NE.IS2(5).OR. 5 NGRIDC(6,NSLAB).NE.IS2(6))THEN WRITE(KFILDO,130)NSLAB,NGRIDC(1,NSLAB),IS2(2), 1 NGRIDC(2,NSLAB),IS2(8), 2 NGRIDC(3,NSLAB),IS2(9), 3 NGRIDC(4,NSLAB),IS2(7), 4 NGRIDC(5,NSLAB),IS2(5), 5 NGRIDC(6,NSLAB),IS2(6) 130 FORMAT(/,' ****GRID CHARACTERISTICS IN NGRIDC( , ) DO NOT', 1 ' MATCH THOSE IN IS2( ) FOR NSLAB = ',I3,'.',/, 2 'NGRIDC(1,NSLAB) =',I8,' IS2(2) =',I8, 3 'NGRIDC(2,NSLAB) =',I8,' IS2(8) =',I8, 4 'NGRIDC(3,NSLAB) =',I8,' IS2(9) =',I8, 5 'NGRIDC(4,NSLAB) =',I8,' IS2(7) =',I8, 6 'NGRIDC(5,NSLAB) =',I8,' IS2(5) =',I8, 7 'NGRIDC(6,NSLAB) =',I8,' IS2(6) =',I8) ISTOP(3)=ISTOP(3)+1 GO TO 220 ELSE C CCCC WRITE(KFILDO,1304)(LD(LLL),LLL=1,4),(IS2(LLL),LLL=2,9),NSLAB CCCC 1304 FORMAT(/' IN LAPSUA AT 1304--(LD(LLL),LLL=1,4),(IS2(LLL),', CCCC 1 'LLL=2,9),NSLAB',/4I10,9I10) D WRITE(KFILDO,1305)NSLAB,J D1305 FORMAT(' GRID RETRIEVED IN LAPSUA WITH NSLAB =',I3, D 1 ' FOR LEVEL =',I3) ENDIF C C IS TIME INTERPOLATION NECESSARY? C CCCC WRITE(KFILDO,1306)NDATE,JDATE,LD(3),IDPARS(12),IDPS12 CCCC 1306 FORMAT(' AT 1306 IN LAPSUA--NDATE,JDATE,LD(3),', CCCC 1 'IDPARS(12),IDPS12',2I13,3I6) C IF(INC3.EQ.0)GO TO 134 C ON TRANSFER, THE DATA NEEDED ARE IN DATA( ). LD(3)=LD(3)+3 C INCREASE THE PROJECTION BY 3 HOURS. CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DATA1,ND5, 2 NWORDS,NPACK,JDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 C IF(IER.NE.0)THEN ISTOP(3)=ISTOP(3)+1 IER=0 C IER IS SET = 0 SO IT WON'T BE NON ZERO ON RETURN. GO TO 220 ENDIF C C THIS GRID MAY NOT HAVE THE SAME CHARACTERISTICS AS C THE ANALYSIS GRID, BUT THEY ARE CONTAINED IN C NGRIDC( ,NSLAB). CHECK TO MAKE SURE THE DEFINITION C IN IS2( ) MATCHES NGRIDC( ,NSLAB). THIS IS A SAFETY. C IF(NGRIDC(1,NSLAB).NE.IS2(2).OR. 1 NGRIDC(2,NSLAB).NE.IS2(8).OR. 2 NGRIDC(3,NSLAB).NE.IS2(9).OR. 3 NGRIDC(4,NSLAB).NE.IS2(7).OR. 4 NGRIDC(5,NSLAB).NE.IS2(5).OR. 5 NGRIDC(6,NSLAB).NE.IS2(6))THEN WRITE(KFILDO,131)NSLAB,NGRIDC(1,NSLAB),IS2(2), 1 NGRIDC(2,NSLAB),IS2(8), 2 NGRIDC(3,NSLAB),IS2(9), 3 NGRIDC(4,NSLAB),IS2(7), 4 NGRIDC(5,NSLAB),IS2(5), 5 NGRIDC(6,NSLAB),IS2(6) 131 FORMAT(/,' ****GRID CHARACTERISTICS IN NGRIDC( , ) DO NOT', 1 ' MATCH THOSE IN IS2( ) FOR NSLAB = ',I3,'.',/, 2 'NGRIDC(1,NSLAB) =',I8,' IS2(2) =',I8, 3 'NGRIDC(2,NSLAB) =',I8,' IS2(8) =',I8, 4 'NGRIDC(3,NSLAB) =',I8,' IS2(9) =',I8, 5 'NGRIDC(4,NSLAB) =',I8,' IS2(7) =',I8, 6 'NGRIDC(5,NSLAB) =',I8,' IS2(5) =',I8, 7 'NGRIDC(6,NSLAB) =',I8,' IS2(6) =',I8) ISTOP(3)=ISTOP(3)+1 GO TO 220 ELSE C CCCC WRITE(KFILDO,1314)(LD(LLL),LLL=1,4),(IS2(LLL),LLL=2,9),NSLAB CCCC 1314 FORMAT(/' IN LAPSUA AT 1314--(LD(LLL),LLL=1,4),(IS2(LLL),', CCCC 1 'LLL=2,9),NSLAB',/4I10,9I10) C D WRITE(KFILDO,1315)NSLAB,J D1315 FORMAT(' GRID RETRIEVED IN LAPSUA WITH NSLAB =',I3, D 1 ' FOR LEVEL =',I3) ENDIF C C TIME INTERPOLATE. THIS IS GRIDDED DATA. THE GRID C IS NWORDS IN SIZE AS RETURNED FROM GFETCH. C R=INC3/3. C R IS THE FRACTION OF THE WAY FROM THE FIRST UA PROJECTION C TO THE ONE NEEDED. LD(3) AT THIS POINT IS THE SECOND C UA PROJECTION. C DO 133 K=1,NWORDS C IF(NINT(DATA(K)).EQ.9999.OR.NINT(DATA1(K)).EQ.9999)THEN DATA(K)=9999. ELSE DATA(K)=R*(DATA1(K)-DATA(K))+DATA(K) ENDIF C 133 CONTINUE C C INTERPOLATE TO EACH STATION. C 134 CALL INTRPX(KFILDO,DATA,IS2(3),IS2(4), 1 DIR(1,1,NSLAB),ND1,NSTA,VDATA(1,J)) C NOTE THAT INTERPOLATION IS TO ALL STATIONS, NOT JUST THE C ONES WITH DATA TO ANALYZE. THE CHARACTERISTS OF THE GRID C READ IS FURNISHED, NOT NECESSARILY THE ANALYSIS GRID. C C CONVERT UNITS AS APPROPRIATE. C IF(L.LE.5)THEN C NOTE THAT L DEPENDS ON THE ORDER OF VARIABLES IN C ITABLE( , , ). THE FIRST 5 ARE TEMPERATURE. C C BELOW FOR KELVIN TO FAHRENHEIT. C CCCC WRITE(KFILDO,1345)J,L CCCC 1345 FORMAT(/' IN LAPSUA AT 1345, CONVERTING K TO F.', CCCC 1 'J,L',2I4) C DO 135 K=1,NSTA IF(NINT(VDATA(K,J)).EQ.9999)GO TO 135 VDATA(K,J) =(VDATA(K,J)-273.15)*1.8+32. 135 CONTINUE C ELSEIF(L.LE.9)THEN C CCCC WRITE(KFILDO,1355)J,L CCCC 1355 FORMAT(/' IN LAPSUA AT 1355, CONVERTING M/S TO KT.', CCCC 1 'J,L',2I4) C C BELOW FOR M/S TO KTS FOR WIND. C DO 136 K=1,NSTA IF(NINT(VDATA(K,J)).EQ.9999)GO TO 136 VDATA(K,J) =(VDATA(K,J))*1.9424 C CONVERSION CONSTANT TAKEN FROM MPSKTS. 136 CONTINUE C ENDIF C C READ THE HEIGHTS IF NECESSARY. THIS ASSUMES THAT IF C ANY ANALYSIS HAS BEEN MADE FOR THIS PROJECTION, THE HEIGHTS C EXIST. C 1362 IF(N.NE.3.OR.(L.NE.3.AND.L.NE.4))THEN C THIS IS GFS MOS MAX OR MIN, AND THE TEST ON PROJECTION C IDPARS(12) IS NOT CORRECT FOR OFFSETS THAT MAX AND MIN C HAVE. ADDED 1/20/16 C IF(NDATSV.EQ.NDATE.AND. 1 NTAUSV.EQ.IDPARS(12))THEN IF(J.EQ.1)WRITE(KFILDO,1365)(ID(JJJ),JJJ=1,4) 1365 FORMAT(/' UPPER AIR HEIGHTS ALREADY EXIST WHEN', 1 ' PROCESSING ',4I11) GO TO 150 ENDIF C ENDIF C IF(J.EQ.1)THEN C IF(L.LE.5)THEN C THE FIRST TEMPERATURE LEVEL IS A CONSTANT 2 M. C DO 137 K=1,NSTA HDATA(K,J)=2. 137 CONTINUE C ELSE C THE FIRST WIND LEVEL IS A CONSTANT 10 M. C DO 138 K=1,NSTA HDATA(K,J)=10. 138 CONTINUE C ENDIF C GO TO 150 C ENDIF C LD(1)=001000000+NCEPNO(3) LD(3)=IDPARS(12)+KCYCLE*6+INC6 C LD(3) IS THE PROJECTION NEEDED FROM JDATE. C IF INTERPOLATION WERE NECESSARY, LD(3) WOULD HAVE CHANGED. LD(3)=LD(3)-MOD(LD(3),3) C LD(3) IS THE PROJECTION BEFORE OR ON THE ONE NEEDED C OCCURRING ON 3-H PROJECTION INTERVALS. C IF(N.EQ.3.AND.(L.EQ.3.OR.L.EQ.4))THEN LD(3)=LD(3)-6 C THIS IS GFS MOS MAX OR MIN. OFFSET THE TEMP FOR LAPSE C BY 6 HR. THIS IS IN AGREEMENT WITH THE DMO FG. (THIS C MAY NOT WORK FOR OTHER THAN CONUS.) ENDIF C CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DATA,ND5, 2 NWORDS,NPACK,JDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 C C IF THIS GRID COULD NOT BE OBTAINED OR THE GRID CHARACTERISTICS C WERE NOT WHAT WAS EXPECTED, COUNT IT AS A GRID THAT COULD C NOT BE OBTAINED BY INCREMENTING ISTOP(3). C IF(IER.NE.0)THEN ISTOP(3)=ISTOP(3)+1 IER=0 C IER IS SET = 0 SO IT WON'T BE NON ZERO ON RETURN. GO TO 220 ENDIF C C THIS GRID MAY NOT HAVE THE SAME CHARACTERISTICS AS C THE ANALYSIS GRID, BUT THEY ARE CONTAINED IN C NGRIDC( ,NSLAB). CHECK TO MAKE SURE THE DEFINITION C IN IS2( ) MATCHES NGRIDC( ,NSLAB). C IF(NGRIDC(1,NSLAB).NE.IS2(2).OR. 1 NGRIDC(2,NSLAB).NE.IS2(8).OR. 2 NGRIDC(3,NSLAB).NE.IS2(9).OR. 3 NGRIDC(4,NSLAB).NE.IS2(7).OR. 4 NGRIDC(5,NSLAB).NE.IS2(5).OR. 5 NGRIDC(6,NSLAB).NE.IS2(6))THEN WRITE(KFILDO,140)NSLAB,NGRIDC(1,NSLAB),IS2(2), 1 NGRIDC(2,NSLAB),IS2(8), 2 NGRIDC(3,NSLAB),IS2(9), 3 NGRIDC(4,NSLAB),IS2(7), 4 NGRIDC(5,NSLAB),IS2(5), 5 NGRIDC(6,NSLAB),IS2(6) 140 FORMAT(/,' ****GRID CHARACTERISTICS IN NGRIDC( , ) DO NOT', 1 ' MATCH THOSE IN IS2( ) FOR NSLAB = ',I3,'.',/, 2 'NGRIDC(1,NSLAB) =',I8,' IS2(2) =',I8, 3 'NGRIDC(2,NSLAB) =',I8,' IS2(8) =',I8, 4 'NGRIDC(3,NSLAB) =',I8,' IS2(9) =',I8, 5 'NGRIDC(4,NSLAB) =',I8,' IS2(7) =',I8, 6 'NGRIDC(5,NSLAB) =',I8,' IS2(5) =',I8, 7 'NGRIDC(6,NSLAB) =',I8,' IS2(6) =',I8) ISTOP(3)=ISTOP(3)+1 GO TO 220 ELSE C CCCC WRITE(KFILDO,1414)(LD(LLL),LLL=1,4),(IS2(LLL),LLL=2,9),NSLAB CCCC 1414 FORMAT(/' IN LAPSUA AT 1414--(LD(LLL),LLL=1,4),(IS2(LLL),', CCCC 1 'LLL=2,9),NSLAB',/4I10,9I10) D WRITE(KFILDO,142)NSLAB D142 FORMAT(' GRID RETRIEVED IN LAPSUA WITH NSLAB =',I3) ENDIF C C IS TIME INTERPOLATION NECESSARY? C IF(INC3.EQ.0)GO TO 148 C ON TRANSFER, THE DATA NEEDED ARE IN DATA( ). LD(3)=LD(3)+3 C INCREASE THE PROJECTION BY 3 HOURS. CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,DATA1,ND5, 2 NWORDS,NPACK,JDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) IF(MISSP.NE.0)MISTOT=MISTOT+1 C IF(IER.NE.0)THEN ISTOP(3)=ISTOP(3)+1 IER=0 C IER IS SET = 0 SO IT WON'T BE NON ZERO ON RETURN. GO TO 220 ENDIF C C THIS GRID MAY NOT HAVE THE SAME CHARACTERISTICS AS C THE ANALYSIS GRID, BUT THEY ARE CONTAINED IN C NGRIDC( ,NSLAB). CHECK TO MAKE SURE THE DEFINITION C IN IS2( ) MATCHES NGRIDC( ,NSLAB). THIS IS A SAFETY. C IF(NGRIDC(1,NSLAB).NE.IS2(2).OR. 1 NGRIDC(2,NSLAB).NE.IS2(8).OR. 2 NGRIDC(3,NSLAB).NE.IS2(9).OR. 3 NGRIDC(4,NSLAB).NE.IS2(7).OR. 4 NGRIDC(5,NSLAB).NE.IS2(5).OR. 5 NGRIDC(6,NSLAB).NE.IS2(6))THEN WRITE(KFILDO,143)NSLAB,NGRIDC(1,NSLAB),IS2(2), 1 NGRIDC(2,NSLAB),IS2(8), 2 NGRIDC(3,NSLAB),IS2(9), 3 NGRIDC(4,NSLAB),IS2(7), 4 NGRIDC(5,NSLAB),IS2(5), 5 NGRIDC(6,NSLAB),IS2(6) 143 FORMAT(/,' ****GRID CHARACTERISTICS IN NGRIDC( , ) DO NOT', 1 ' MATCH THOSE IN IS2( ) FOR NSLAB = ',I3,'.',/, 2 'NGRIDC(1,NSLAB) =',I8,' IS2(2) =',I8, 3 'NGRIDC(2,NSLAB) =',I8,' IS2(8) =',I8, 4 'NGRIDC(3,NSLAB) =',I8,' IS2(9) =',I8, 5 'NGRIDC(4,NSLAB) =',I8,' IS2(7) =',I8, 6 'NGRIDC(5,NSLAB) =',I8,' IS2(5) =',I8, 7 'NGRIDC(6,NSLAB) =',I8,' IS2(6) =',I8) ISTOP(3)=ISTOP(3)+1 GO TO 220 ELSE C CCCC WRITE(KFILDO,1434)(LD(LLL),LLL=1,4),(IS2(LLL),LLL=2,9),NSLAB CCCC 1434 FORMAT(/' IN LAPSUA AT 1434--(LD(LLL),LLL=1,4),(IS2(LLL),', CCCC 1 'LLL=2,9),NSLAB',/4I10,9I10) D WRITE(KFILDO,144)NSLAB,J D144 FORMAT(' GRID RETRIEVED IN LAPSUA WITH NSLAB =',I3, D 1 ' FOR LEVEL =',I3) ENDIF C C TIME INTERPOLATE. C R=INC3/3. C R IS THE FRACTION OF THE WAY FROM THE FIRST UA PROJECTION C TO THE ONE NEEDED. LD(3) AT THIS POINT IS THE SECOND C UA PROJECTION. C DO 146 K=1,NWORDS C IF(NINT(DATA(K)).EQ.9999.OR.NINT(DATA1(K)).EQ.9999)THEN DATA(K)=9999. ELSE DATA(K)=R*(DATA1(K)-DATA(K))+DATA(K) ENDIF C 146 CONTINUE C C INTERPOLATE TO EACH STATION. C 148 CALL INTRPX(KFILDO,DATA,IS2(3),IS2(4), 1 DIR(1,1,NSLAB),ND1,NSTA,HDATA(1,J)) C NOTE THAT INTERPOLATION IS TO ALL STATIONS, NOT JUST THE C ONES WITH DATA TO ANALYZE. THE CHARACTERISTS OF THE GRID C READ IS FURNISHED, NOT NECESSARILY THE ANALYSIS GRID. C CCCD WRITE(KFILDO,143)(LD(N),N=1,4), CCCD 1 (N,CCALL(N),VDATA(N,J),HDATA(N,J),N=1,NSTA) CCCD143 FORMAT(/,' DATA AND HEIGHTS FOR STATIONS FOR VARIABLE ', CCCD 1 I12.9,I10.9,I9.8,I4.3,/,(' ',I4,2X,A8,2F8.1)) 150 CONTINUE C C AT THIS POINT, WE HAVE THE HEIGHTS IN HDATA( , ) AND C VARIABLE VALUES IN VDATA( , ) FOR EACH STATION. ALL C HEIGHTS ARE IN METERS. NO USE OF GRIDS BELOW THIS C POINT. SAVE THE GRID CHARACTERISTICS. C 151 IDVSAV=ITABLE(3,L,N)+IDPARS(4) C IDVSAV INDICATES THE DATA IN VDATA( , ). C ICOUNT=0 C ICOUNT IS USED TO LIMIT PRINT. C DO 200 K=1,NSTA C C FIND SUM OF DATA IN XDATA(K, ,1). THIS IS GETTING THE C AVERAGE OF SURFACE DATA WHEN MORE THAN ONE CYCLE C IS USED, OR IF NOT, JUST SETTING AVXDAT( ) = THE ONE C VALUE. U450A HAS NOT YET AVERAGED THE VALUES. C IF LAPFG = 2, THE AVERAGE IS NOT NEEDED, BUT IS COMPUTED C ANYWAY. AVXDAT( ) IS PRINTED IN VARIOUS PLACES WITH C DIAGNOSTIC D. C IF(NORUNS.GT.1)THEN AVXDAT(K)=0. NC=0 C DO 1525 M=1,NORUNS C IF(XDATA(K,M+1,1).LT.9998.9)THEN AVXDAT(K)=AVXDAT(K)+XDATA(K,M+1,1) NC=NC+1 ENDIF C 1525 CONTINUE C C FIND AVERAGE. WHEN NC = 1, AVXDAT IS THE VALUE. C IF(NC.GT.0)THEN AVXDAT(K)=AVXDAT(K)/NC C THERE IS AN OCCASIONAL DIVISION BY 1 WHEN THERE C IS ONLY ONE VALUE, BUT SAVES A CHECK FOR NC = 1. ELSE AVXDAT(K)=9999. ENDIF C ELSE AVXDAT(K)=XDATA(K,2,1) ENDIF C C SET LAPSE FOR WATER POINTS = 9999. FOR NOW. C IF(LNDSEA(K).LT.6)THEN C THERE ARE NO TYPE 6 IN ALASKA, AND NOT MANY IN THE CONUS. C IT IS PROBABLY BETTER TO USE THEM WITH A COMPUTED C LAPSE, RATHER THAN EVENTUALLY SETTING THE LAPZE =0. C CCCD WRITE(KFILDO,153)K,CCALL(K) CCCD153 FORMAT(/' AT 153, WATER STATION--K,CCALL',I4,2X,A8) C XLAPSE(K)=9999. C THIS WILL LATER BE SET TO 0. GO TO 200 ENDIF C C CHECK FOR MISSING DATA. WHEN FOUND SET LAPSE = 9999. FOR NOW. C IF(ELEVHI(K).GT.9998.OR. 1 NINT(ELEV(K)).EQ.9999.OR. C NOTE THAT THE ELEVATIONS WILL NOT EXCEED 9999 METERS. 2 VDATA(K,1).GT.9998..OR. 3 (AVXDAT(K).GT.9998..AND.(LAPFG.EQ.3.OR.LAPFG.EQ.5)))THEN C THE LAPSE CANNOT BE COMPUTED WHEN AVXDAT( ) IS MISSING C AND LAPFG = 3. HOWEVER, WHEN LAPFG = 2, AVXDAT( ) IS NOT C USED AND NEEDS TO BE COMPUTED AND SAVED. FOR INSTANCE, C IF THE LAPSE COMPUTED IN TEMP IS USED IN MAX TEMP, ALL C STATIONS WITH MAX DATA NEED A LAPSE, NOT JUST THE ONES C WITH TEMP DATA. XLAPSE(K)=9999. C THIS WILL LATER BE SET TO 0. C CCCD WRITE(KFILDO,154)K,CCALL(K),ELEVHI(K),ELEV(K),VDATA(K,1), CCCD 1 HDATA(K,1),AVXDAT(K) CCCD154 FORMAT(/,' AT 154 IN LAPSUA--K,CCALL(K),ELEVHI(K),ELEV(K)', CCCD 1 'VDATA(K,1),HDATA(K,1),AVXDAT(K)', CCCD 2 I8,2X,A8,F7.0,F7.1,F7.1,F7.1,F6.0) C GO TO 200 ENDIF C C THE LAPSE IS COMPUTED FROM ONLY UA DATA ABOVE THE STATION C WHEN LAPFG = 2, BUT FROM THE STATION UP TO THE FIRST C LEVEL ABOVE THE STATION WHEN LAPFG = 3. C HLOW=9999. HHIGH=9999. C IF(LAPFG.EQ.2)THEN C DO 156 J=1,JDIM C CCCC IF(CCALL(K).EQ.'ACRAW ')THEN CCCC WRITE(KFILDO,155)K,CCALL(K),NAME(K),J,HDATA(K,J),ELEV(K), CCCC 1 VDATA(K,J),AVXDAT(K) CCCC 155 FORMAT(/' AT 155 IN LAPSUA--K,CCALL(K),NAME(K),J,', CCCC 1 'HDATA(K,J),ELEV(K),VDATA(K,J),AVXDAT(K)',/, CCCC 2 I5,2X,A8,2X,A20,I3,4F8.1) CCCC ENDIF C C FIND THE LOWEST UA LEVEL ABOVE THE STATION ELEVATION. C IF(HDATA(K,J).GT.ELEV(K))THEN C IF(J.GT.2)THEN C UNLESS THE ELEVATIONS ARE QUITE LOW, THE LAPSE C WILL BE COMPUTED OVER A RANGE OF ELEVATIONS THAT C INCLUDES THE STATION. HLOW=HDATA(K,J-1) VLOW=VDATA(K,J-1) JLOW=J-1 GO TO 157 ELSE HLOW=HDATA(K,J) VLOW=VDATA(K,J) JLOW=J GO TO 157 ENDIF C ENDIF C 156 CONTINUE C ELSE C HLOW AND VLOW ARE NOT USED WHEN LAPFG = 3. SET JLOW C FOR LOOP BELOW. JLOW=0 GO TO 157 C ENDIF C WRITE(KFILDO,1569) 1569 FORMAT(/,' ****ERROR IN LAPSUA AT 1569.', 1 ' XLAPSE( ) SET TO ZERO.') XLAPSE(K)=9999. C THIS WILL LATER BE SET TO ZERO. ISTOP(1)=ISTOP(1)+1 GO TO 200 C C NOW FIND THE UPPER LEVEL TO CALCULATE THE LAPSE RATE. C START ONE LEVEL ABOVE THE LOWEST LEVEL J. C 157 DO 158 J=JLOW+1,JDIM C IF BY CHANCE JLOW+1 EXCEEDS JDIM, LOOP WILL NOT EXECUTE. C CCCC IF(CCALL(K).EQ.'ACRAW ')THEN CCCC WRITE(KFILDO,1575)K,CCALL(K),NAME(K),J,HDATA(K,J),ELEV(K), CCCC 1 VDATA(K,J),AVXDAT(K),ELEVHI(K) CCCC 1575 FORMAT(/' AT 1575 IN LAPSUA--K,CCALL(K),NAME(K), J,', CCCC 1 ' HDATA(K,J),', CCCC 2 'ELEV(K),VDATA(K,J),AVXDAT(K),ELEVHI(K)' CCCC 3 ,/,16X,I5,2X,A8,2X,A8,I3,5F10.1) CCCC ENDIF C IF(HDATA(K,J).GT.ELEVHI(K))THEN HHIGH=HDATA(K,J) VHIGH=VDATA(K,J) GO TO 162 ENDIF C 158 CONTINUE C C THE TOP LEVEL (500 MB) HAS BEEN REACHED AND ELEVHI(K) C HAS NOT BEEN EXCEEDED. USE THE 500 MB LEVEL. HHIGH=HDATA(K,JDIM) VHIGH=VDATA(K,JDIM) C C COMPUTE LAPSE. C 162 IF(LAPFG.EQ.2)THEN C IF(NINT(HHIGH).EQ.9999.OR.NINT(HLOW).EQ.9999)THEN WRITE(KFILDO,1620)CCALL(K),NAME(K) 1620 FORMAT(/,' ****LAPSE COULD NOT BE COMPUTED FOR STATION ', 1 A8,2X,A20,' AT 1620 IN LAPSUA. SET IT TO ZERO.') XLAPSE(K)=0. ELSE C IF(HHIGH-HLOW.GT.130.)THEN C DON'T COMPUTE OVER A SMALL RANGE OF HEIGHTS. THE C 130 AGREES WITH WHAT IS USED FOR COMPUTING THE LAPSE C WITH STATION DATA IN U174. XLAPSE(K)=(VHIGH-VLOW)/(HHIGH-HLOW) ELSE XLAPSE(K)=0. ENDIF C ENDIF C ELSEIF(LAPFG.EQ.3.OR.LAPFG.EQ.5)THEN C IF(NINT(HHIGH).EQ.9999.OR.NINT(ELEV(K)).EQ.9999)THEN WRITE(KFILDO,1620)CCALL(K),NAME(K) XLAPSE(K)=0. ELSE C IF(HHIGH-ELEV(K).GT.130.)THEN C DON'T COMPUTE OVER A SMALL RANGE OF HEIGHTS. THE C 130 AGREES WITH WHAT IS USED FOR COMPUTING THE LAPSE C WITH STATION DATA IN U174. AVXDAT(K) HAS BEEN CHECKED C FOR NON MISSING ABOVE. XLAPSE(K)=(VHIGH-AVXDAT(K))/(HHIGH-ELEV(K)) IPRINT=0 C CCCC IF(CCALL(K).EQ.'ACRAW ')THEN CCCC WRITE(KFILDO,9161)K,CCALL(K),J,ELEVHI(K),ELEVLO(K), CCCC 1 HHIGH,VHIGH,XLAPSE(K) CCCC 9160 FORMAT(' AT 9161--', CCCC 1 'K,CCALL(K),J,ELEVHI(K),ELEVLO(K),', CCCC 2 'HHIGH,VHIGH,XLAPSE(K)', CCCC 3 I8,2X,A8,I3,4F8.1,F9.3) CCCC ENDIF C ELSEIF(J.GT.1)THEN C IF THE 130 M CONDITION IS NOT MET, TRY THE LEVEL C BELOW. IPRINT=1 ICOUNT=ICOUNT+1 IF(ICOUNT.GT.500)IPRINT=0 HHIGH=HDATA(K,J-1) VHIGH=VDATA(K,J-1) C IF(HHIGH.GT.ELEVLO(K).AND.ELEV(K)-HHIGH.GT.130.)THEN C DON'T USE A VALUE THAT MAY BE BELOW GROUND. XLAPSE(K)=(VHIGH-AVXDAT(K))/(HHIGH-ELEV(K)) C CCCC IF(CCALL(K).EQ.'ACRAW ')THEN CCCC WRITE(KFILDO,9161)K,CCALL(K),J,ELEVHI(K),ELEVLO(K), CCCC 1 HHIGH,VHIGH,XLAPSE(K) CCCC 9161 FORMAT(' AT 9161, LEVEL BELOW--', CCCC 1 'K,CCALL(K),J,ELEVHI(K),ELEVLO(K),', CCCC 2 'HHIGH,VHIGH,XLAPSE(K)', CCCC 3 I8,2X,A8,I3,4F8.1,F9.3) CCCC ENDIF C IF(XLAPSE(K).LT.0.)THEN C BECAUSE AVXDAT( ) IS A MEASURED WIND AT THE C SURFACE AND VHIGH IS AN UA WIND, MANY OF C THESE VALUES MAY BE UNREALISTICALLY NEGATIVE. C DO NOT ALLOW IT HERE. TRY THE LEVEL ABOVE J. IF(J.LT.JDIM)THEN HHIGH=HDATA(K,J+1) VHIGH=VDATA(K,J+1) C IF(HHIGH-ELEV(K).GT.130.)THEN XLAPSE(K)=(VHIGH-AVXDAT(K))/(HHIGH-ELEV(K)) C CCCC IF(CCALL(K).EQ.'ACRAW ')THEN CCCC WRITE(KFILDO,9162)K,CCALL(K),J,ELEVHI(K), CCCC 1 ELEVLO(K),HHIGH,VHIGH,XLAPSE(K) CCCC 9162 FORMAT(' AT 9162, LEVEL ABOVE--', CCCC 1 'K,CCALL(K),J,ELEVHI(K),', CCCC 2 'ELEVLO(K),HHIGH,VHIGH,XLAPSE(K)', CCCC 3 I8,2X,A8,I3,4F8.1,F9.3) CCCC ENDIF C ELSE XLAPSE(K)=0. ENDIF C ELSE XLAPSE(K)=0. ENDIF C ENDIF C ELSEIF(J.LT.JDIM)THEN HHIGH=HDATA(K,J+1) VHIGH=VDATA(K,J+1) C IF(HHIGH-ELEV(K).GT.130.)THEN XLAPSE(K)=(VHIGH-AVXDAT(K))/(HHIGH-ELEV(K)) C CCCC IF(CCALL(K).EQ.'ACRAW ')THEN CCCC WRITE(KFILDO,9163)K,CCALL(K),J,ELEVHI(K), CCCC 1 ELEVLO(K),HHIGH,VHIGH,XLAPSE(K) CCCC 9163 FORMAT(' AT 9163, LEVEL ABOVE--', CCCC 1 'K,CCALL(K),J,ELEVHI(K),ELEVLO(K),', CCCC 2 'HHIGH,VHIGH,XLAPSE(K)', CCCC 3 I8,2X,A8,I3,4F8.1,F9.3) CCCC ENDIF C ELSE XLAPSE(K)=0. ENDIF C ELSE XLAPSE(K)=0. ENDIF C ELSE XLAPSE(K)=0. IPRINT=1 ENDIF C CCCC IF(IPRINT.EQ.1)THEN CCCC WRITE(KFILDO,9876)K,CCALL(K),J,LNDSEA(K),HHIGH, CCCC 1 ELEV(K),ELEVHI(K),ELEVLO(K),HDATA(K,J),VDATA(K,J), CCCC 2 VHIGH,AVXDAT(K),XLAPSE(K),ICOUNT CCCC 9876 FORMAT(' AT 9876--K,CCALL(K),J,LNDSEA(K),HHIGH,', CCCC 1 'ELEV(K),ELEVHI(K),ELEVLO(K),HDATA(K,J),', CCCC 2 'VDATA(K,J),VHIGH,AVXDAT(K),XLAPSE(K),ICOUNT',//, CCCC 3 4x,I6,1X,A8,2I3,8F8.1,F6.4,I10) CCCC ENDIF C ENDIF C ELSE WRITE(KFILDO,1622)LAPFG 1622 FORMAT(/' ****LAPSUA ENTERED WITH LAPFG NE 2, 3,OR 5.', 1 ' LAPSE CANNOT BE COMPUTED. COUNT AS FATAL.') ISTOP(1)=ISTOP(1)+1 IER=777 C C SET XLAPSE( ) = 0. FOR SAFETY AND LAPSV TO INDICATE C NOTHING REUSABLE IS SAVED. C DO 1623 KKK=1,NSTA XLAPSE(KKK)=0. 1623 CONTINUE C LAPSV=9999 GO TO 250 ENDIF C CCCC IF(CCALL(K).EQ.'ACRAW ')THEN CCCC WRITE(KFILDO,1624)K,CCALL(K),AVXDAT(K),ELEV(K),XLAPSE(K), CCCC 1 (VDATA(K,J),J=1,JDIM), CCCC 2 (HDATA(K,J),J=1,JDIM) CCCC 1624 FORMAT(/' AT 1624--K,CCALL(K),AVXDAT(K),ELEV(K),XLAPSE(K)', CCCC 1 '(VDATA(K,J),J=1,JDIM),', CCCC 2 '(HDATA(K,J),J=1,JDIM)',/, CCCC 3 I6,2X,A8,2F8.1,F10.7/,(12F9.2)) CCCCC FORMAT ABOVE SET FOR JDIM = 12. CCCC ENDIF C CCCC WRITE(KFILDO,1625)K,CCALL(K),AVXDAT(K),ELEV(K), CCCC 1 ELEVLO(K),ELEVHI(K), CCCC 2 VHIGH,VLOW,HHIGH,HLOW,XLAPSE(K) CCCC 1625 FORMAT(' AT 1625--K,CCALL(K),AVXDAT(K),ELEV(K),', CCCC 1 'ELEVLO(K),ELEVHI(K),', CCCC 2 'VHIGH,VLOW,HHIGH,HLOW,XLAPSE(K)',/, CCCC 3 I11,2X,A8,F7.1,F9.1,F11.0,F6.0,4F7.1,F8.4) C 200 CONTINUE C C CHECK FOR REASONABLENESS OF LAPSE RATES AND COUNT NEGATIVES, C POSITIVES, AND ZEROS. C DO 204 K=1,NSTA C IF(XLAPSE(K).NE.9999.)THEN C IF(XLAPSE(K).LT.0.)THEN KMINUS=KMINUS+1 C IF(XLAPSE(K).LT.HMINUS)THEN NRESET=NRESET+1 XLAPSE(K)=0. ELSEIF(XLAPSE(K).LT.XINLAP)THEN XINLAP=XLAPSE(K) ENDIF C ELSEIF(XLAPSE(K).GT.0.)THEN KPLUS=KPLUS+1 C IF(XLAPSE(K).GT.HPLUS)THEN NRESET=NRESET+1 CCCCCCCCCC XLAPSE(K)=0. XLAPSE(K)=HPLUS C CHANGED FROM XLAPSE(K)=0 MAY 15, 2015. ELSEIF(XLAPSE(K).GT.XAXLAP)THEN XAXLAP=XLAPSE(K) ENDIF C ELSE KZERO=KZERO+1 ENDIF C ELSE XLAPSE(K)=0. C THE 9999'S ARE SET TO ZERO. ENDIF C CCCC WRITE(KFILDO,203)K,CCALL(K),XLAPSE(K),NRESET,KMINUS,KPLUS,KZERO, CCCC 1 XINLAP,XAXLAP,NSTA CCCC 203 FORMAT(' AT 203--K,CCALL(K),XLAPSE(K),NRESET,KMINUS,KPLUS,KZERO,', CCCC 1 'XINLAP,XAXLAP,NSTA',/,I5,2X,A8,F12.4,4I6,2F12.4,I6) C 204 CONTINUE C WRITE(KFILDO,205)NRESET,HMINUS,HPLUS,HPLUS, 1 XAXLAP,XINLAP, 2 KMINUS,KZERO,KPLUS 205 FORMAT(/, I7,' = NUMBER OF COMPUTED LAPSE RATES OUTSIDE', 1 ' RANGE',F6.3,' AND,',F5.3,'; POSITIVES SET', 2 ' TO',F5.3,' AND NEGATIVES SET TO 0',/, 3 F7.4,' = MAXIMUM POSITIVE LAPSE RATE COMPUTED',/, 4 F7.4,' = MINIMUM NEGATIVE LAPSE RATE COMPUTED',/, 5 I7,' = NUMBER OF MINUS LAPSE RATES',/, 6 I7,' = NUMBER OF ZERO LAPSE RATES (COMPUTED)',/, 7 I7,' = NUMBER OF PLUS LAPSE RATES') C IF(IP14.NE.0.AND.IFIRST.EQ.0.AND. 1 (LAPFG.EQ.2.OR.LAPFG.EQ.3.OR.LAPFG.EQ.5))THEN IFIRST=1 C FOR TESTING, WRITE THESE ONLY ONCE. THIS WILL BE FOR C THE FIRST VARIABLE. WRITE(IP14,207) 207 FORMAT(/,' LISTING OF COMPUTED LAPSE RATE.', 1 ' MISSING STATIONS ARE NOT LISTED'/,/, 2 ' STATION NO. CALL LETTERS AND NAME', 3 ' DATA VALUE LAPSE (PER METER)',/) DO 210 K=1,NSTA C IF(AVXDAT(K).NE.9999.)THEN WRITE(IP14,209)K,CCALL(K),NAME(K),AVXDAT(K),XLAPSE(K) 209 FORMAT(' ',I6,8X,A8,2X,A20,F10.2,F8.3) ENDIF C 210 CONTINUE C ENDIF C C SAVE LAPSE RATES FOR POSSIBLE REUSE. LAPSV INDICATES THE C TYPE OF LAPSE SAVED. C DO 215 K=1,NSTA XSAVE(K)=XLAPSE(K) 215 CONTINUE C C THIS IS THE ONLY GOOD COMPLETION FOR READING VALUES. C SET SAVE VALUES. C LAPSV=LAPFG IDSAV=ID(1) NDATSV=NDATE NTAUSV=IDPARS(12) SV174=FL174 C D WRITE(KFILDO,217)IDSAV,NDATSV,NTAUSV D217 FORMAT(/' LAPSUA AT 217--IDSAV,NDATSV,NTAUSV', D 1 I2,1X,3I10,3I11,3I3) C GO TO 250 C 220 IF(KCYCLE.LT.IBACK)THEN C WRITE(KFILDO,221)(LD(M1),M1=1,4),JDATE 221 FORMAT(/,' UPPER AIR DATA FOR ',3I10.9,I10.3,' FOR JDATE',I12, 1 ' NOT AVAILABLE. TRY A PREVIOUS CYCLE.') ENDIF C 230 CONTINUE C C DROP THROUGH HERE MEANS DATA WERE NOT RETRIEVED. TRY A C FORECAST FOR 6-H EARLIER PROJECTION. IT WILL DO THIS ONLY C ONCE. THIS IS FOR RECYCLING TO USE UPPER AIR DATA FOR C A PROJECTION 6-H EARLIER PRIMARILY FOR THE 198-H MAX TEMP C PROBLEM. C IF(IDPS12.EQ.IDPARS(12))THEN IDPARS(12)=IDPARS(12)-6 WRITE(KFILDO,242)(ID(M1),M1=1,4) 242 FORMAT(/,' THE UPPER AIR DATA FOR VARIABLE ', 1 I9.9,I10.9,I10.9,I4.3,' NOT AVAILABLE. TRY A', 2 ' FORECAST FOR 6-H EARLIER PROJECTION.') GO TO 108 ENDIF C WRITE(KFILDO,245)(ID(M1),M1=1,4),NDATE 245 FORMAT(/,' ****COULD NOT FIND UPPER DATA TO USE FOR VARIABLE', 1 ' ID =',3I10.9,I10.3,' FOR DATE =',I12,' IN LAPSUA.',/, 2 ' FATAL ERROR.') ISTOP(1)=ISTOP(1)+1 IER=777 C 250 IDPARS(12)=IDPS12 C ALWAYS RESTORES IDPARS(12) IN CASE IT WAS CHANGED. CALL TIMPR(KFILDO,KFILDO,'END LAPSUA ') RETURN C END