SUBROUTINE AVGLAP(KFILDO,KFILZO,FLZERO,NAREA,
1 ID,IDPARS,JD,
2 CCALL,NAME,XDATA,LNDSEA,XLAPSE,NSTA,ND1,
3 L3264B,ISTOP,IER)
C
C JULY 2009 GLAHN TDL MOS-2000
C ADAPTED FROM STSNOZ
C SEPTEMBER 2009 GAW MODIFIED OPEN STATEMENT FOR OPERATIONS
C MARCH 2012 J. WAGNER CHANGED EKDMOS DD'S FROM 76 TO 61
C JUNE 2014 GLAHN SET IER = 777 AFTER IERX, REMOVED
C STOP, AND RETURNED
C JULY 2014 HUANG MODIFIED FOR IMPLEMENTATION
C
C PURPOSE
C TO AVERAGE THE LAPSE RATES FROM SURROUNDING STATIONS
C WITH ITS OWN. DEVELOPED FOR SNOW IN ALASKA. THIS MAY
C ALSO WORK FOR QPF OR OTHER VARIABLES.
C
C THE U179A FILE IS ALWAYS READ THE FIRST TIME THIS ROUTINE
C IS ENTERED FOR A RUN. THE STATION LIST ON IT IS
C COORDINATED WITH THE ONE BEING USED IN U155. BOTH THE
C FILE NAME AND THE ID IN THE FIRST RECORD ARE SAVED.
C ON SUBSEQUENT ENTIRES, THE FIRST RECORD IS READ, AND IF
C THE FILE AND ID ARE THE SAME, IT NEED NOT BE READ.
C
C HAVING BEEN ADAPTED FROM THE AUGMENTING ROUTINE AUGMT1
C VIA STSNOZ, SOME OF THE TERMINOLOGY WAS LEFT THAT WAY.
C
C THE DATA COMING IN IS AFTER THE SCALING AND AVERAGING
C OVER CYCLES IF THAT IS BEING DONE.
C
C DATA SET USE
C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT)
C KFILZO - THE UNIT NUMBER FOR THE FILE HOLDING THE
C AUXILIARY DATA. (INPUT)
C
C VARIABLES
C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT)
C KFILZO = THE UNIT NUMBER FOR THE FILE HOLDING THE
C AUXILIARY DATA. (INPUT)
C FLZERO = THE FILE NAME OF THE AUXILIARY DATA.
C (CHARACTER*60) (INPUT)
C NAREA = THE AREA OVER WHICH THE ANALYSIS IS MADE:
C 1 = CONUS,
C 2 = ALASKA,
C 3 = HAWAII,
C 4 = PUERTO RICO.
C NOT CURRENTLY USED, BUT MIGHT BE NEEDED.
C ID(J) = 4-WORD ID OF VARIABLE TO PROVIDE FIRST GUESS FOR
C (J=1,4). (INPUT)
C IDPARS(J) = THE PARSED, INDIVIDUAL COMPONENTS OF THE
C VARIABLE ID'S CORRESPONDING TO ID( ,N)
C (J=1,15), (N=1,ND4).
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 (INPUT)
C JD(J) = THE BASIC INTEGER VARIABLE ID'S (J=1,4)
C (N=1,ND4).
C THIS IS THE SAME AS ID(J,N), EXCEPT THAT THE
C PORTIONS PERTAINING TO PROCESSING ARE OMITTED:
C B = IDPARS(3, ),
C T = IDPARS(8,),
C I = IDPARS(13, ),
C S = IDPARS(14, ),
C G = IDPARS(15, ), AND
C THRESH( ).
C NOT ACTUALLY USED. (INPUT)
C CCALL(K) = CALL LETTERS OF STATIONS BEING DEALT WITH.
C (CHARACTER*8) (INPUT)
C NAME(K) = NAMES OF STATIONS (K=1,NSTA). (CHARACTER*20)
C (INPUT)
C XDATA(K) = DATA VALUES ON INPUT; AUGMENTED VALUES
C ON OUTPUT (K=1,NSTA). (INPUT/OUTPUT)
C LNDSEA(K) = LAND/SEA INFLUENCE FLAG FOR EACH STATION
C (K=1,NSTA).
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 NOT CURRENTLY USED, BUT MIGHT BE NEEDED.
C (INPUT)
C XLAPSE(K) = CALCULATED LAPSE RATE IN UNITS OF THE VARIABLE
C BEING ANALYZED PER M. (K=1,KSTA). (INPUT)
C ND1 = FIRST DIMENSION OF XDATA( ) AND DIMENSION
C OF FD1( ). (INPUT)
C NSTA = NUMBER OF STATIONS BEING USED; THE NUMBER
C OF VALUES IN XDATA( ). (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 WHENEVER AN ERROR
C OCCURS AND THE PROGRAM PROCEEDS. ISTOP IS
C INCREMENTED WHEN THE FIRST CHOICE OF FIRST
C GUESS IS NOT AVAILABLE (I.E., MGUESS NE
C IGUESS(1)). ISTOP(3) IS INCREMENTED BY 1
C WHEN A DATA RECORD COULD NOT BE FOUND.
C (INPUT/OUTPUT)
C ISTOP(J) = ISTOP(1) IS INCREMENTED BY 1 EACH TIME AN ERROR
C OCCURS.
C ISTOP(2) IS INCREMENTED WHEN LESS THAN
C 200 STATIONS ARE AVAILABLE FOR AN
C ANALYSIS.
C ISTOP(3) IS INCREMENTED WHEN A DATA RECORD
C CANNOT BE FOUND.
C (INPUT/OUTPUT)
C IER = ERROR CODE.
C 0 = GOOD RETURN.
C 103 = COULD NOT IDENTIFY ID IN INTERNAL TABLE.
C 777 = NO FIRST GUESS AVAILABLE. FATAL ERROR.
C OTHER VALUES FROM CALLED ROUTNES. EVERY
C ERROR IS FATAL FOR THIS ELEMENT.
C (OUTPUT)
C NSLAB = SLAB OF THE GRID CHARACTERISTICS. RETURNED
C BY GFETCH. USED FOR CHECKING FOR EQUAL
C CHARACTERISTICS OF GRIDS READ. (INTERNAL)
C ITABLE(J,L) = HOLDS THE 4-WORD IDS (J=1,4) OF THE NCAT
C VARIABLES TO WHICH THIS ROUTINE APPLIES
C AND THE DATA TO ACCESS (L=1,NCAT). (INTERNAL)
C TRATIO = THE FRACTION OF THE WAY BETWEEN 3-HOURLY GRIDS
C TO GET THE PROJECTION NEEDED, WHEN TIME
C INTERPOLATION IS NEEDED. WILL BE 0, 1/3, OR
C 2/3. (INTERNAL)
C JDATE = THE DATE TIME TO LOOK FOR MOS DATA. (INTERNAL)
C JTAU1 = THE FIRST PROJECTION AUXILIARY DATA ARE NEEDED.
C (INTERNAL)
C JTAU2 = THE SECOND PROJECTION AUXILIARY DATA ARE NEEDED.
C (INTERNAL)
C MAXSTA = THE MAXIMUM NUMBER OF NEIGHBORS (AUGMENTING
C STATIONS) PROVIDED ON THE FILE WITH UNIT NUMBER
C KFILZO. (INTERNAL)
C LIST(K) = THE LOCATION IN THE STATION LIST (K=1,NSTA) OF
C THE SAME STATION IN THE AUGMENTING LIST.
C (INTERNAL)
C LISTD(KK) = THIS LOCATION IN THE CCALLD( ) LIST OF THE
C STATION IN THE CCALL( ) LIST (K=1,NSTA).
C (INTERNAL)
C TEMP(K) = TEMPORARY ARRAY FOR AUGMENTING XLAPSE( ).
C (INTERNAL)
C CCALLD(M) = THE AUGMENTING STATION CALL LETTERS (M=1,MSTA).
C (INTERNAL)
C NOALOC(M) = THE NUMBER OF AUGMENTING STATIONS FOR STATION M
C (M=1,MSTA). (INTERNAL)
C IALOC(M,L) = THE POSITIONS OF THE AUGMENTING STATIONS
C (L=1,MAXSTA) IN THE AUGMENTING LIST (M=1,MSTA).
C (INTERNAL)
C RDIST(M,L) = THE DISTANCES OF THE OF THE AUGMENTING STATIONS
C (L=1,MAXSTA) IN THE AUGMENTING LIST FROM THE
C STATION BEING AUGMENTED. (M=1,MSTA). (INTERNAL)
C MSTA = THE NUMBER OF STATIONS THAT HAVE A LIST.
C (INTERNAL)
C IFIRST = CONTROLS PRINTING AND SPACING OF DIAGNOSTICS AT
C 194, 195, 196. (INTERNAL)
C JFIRST = CONTROLS PRINTING AND SPACING OF DIAGNOSTICS AT
C 2185, ETC. (INTERNAL)
C 1 2 3 4 5 6 7 X
C
C NONSYSTEM SUBROUTINES USED
C GFETCH, TIMPR
C
PARAMETER (IDCAT=2)
C
CHARACTER*4 STATE
CHARACTER*8 CCALL(ND1),CCALLD,TRASH
CHARACTER*20 NAME(ND1)
CHARACTER*60 FLZERO,FILEID,SAVFL,SAVID
C
DIMENSION ID(4),IDPARS(15),JD(4)
DIMENSION XDATA(ND1),LNDSEA(ND1),XLAPSE(ND1)
DIMENSION ISTOP(3),ITABLE(4,IDCAT),LD(4)
C
ALLOCATABLE CCALLD(:),NOALOC(:),IALOC(:,:),RDIST(:,:),LIST(:),
1 LISTD(:),TEMP(:)
C
DATA SAVFL/' '/,
1 SAVID/' '/
SAVE SAVFL,SAVID
SAVE CCALLD,NOALOC,IALOC,RDIST,LIST,LISTD
SAVE IALL
C
DATA ITABLE/228470000,0,0,0,
1 223270000,0,0,0/
C THE ABOVE ACCOMMODATES FOR GMOS SNOW AMOUNT AND 6-H QPF.
C
D CALL TIMPR(KFILDO,KFILDO,'START AVGLAP ')
C
IER=0
IFIRST=0
JFIRST=0
C
C DETERMINE WHETHER VARIABLE IS IN THE LIST.
C THE TAU IS NOT IN THE TABLE TO MAKE IT GENERIC, BUT
C IS IN ID(3).
C
DO 105 L=1,IDCAT
D WRITE(KFILDO,103)(ITABLE(J,L),J=1,4)
D103 FORMAT(/' AT 103 IN AVGLAP--(ITABLE(J,M),J=1,4)',4I11)
C
IF(ID(1)/100.EQ.ITABLE(1,L)/100.AND.
1 (ID(3)/1000).EQ.(ITABLE(3,L)/1000).AND.
2 ID(4).EQ.ITABLE(4,L))THEN
GO TO 111
C THIS DEFINES L. NOTE THAT ID(2) IS NOT CHECKED HERE.
C IT MAY BE THAT EKDMOS WILL BE CONSIDERED WITH THE
C MEAN DESIGNATION IN ID(2).
ENDIF
C
105 CONTINUE
C
C DROP THROUGH HERE MEANS THE ID WAS NOT FOUND.
C
ISTOP(1)=ISTOP(1)+1
IER=103
WRITE(KFILDO,110)(ID(J),J=1,4),IER
110 FORMAT(/,' ****VARIABLE ',I9.9,I10.9,I10.9,I4.3,' NOT',
1 ' ACCOMMODATED IN SUBROUTINE AVGLAP. IER =',I3,/,
2 ' MODIFICATIO OF ZEROS NOT DONE. PROCEEDING.')
GO TO 900
C
C MAKE SURE THIS IS EITHER A MEAN OR PROBABILITY FORECAST
C WHEN EKDMOS.
C
111 IF(IDPARS(4).EQ.61)THEN
C
IF((IDPARS(6)-(IDPARS(6)/1000)*1000).EQ.0)THEN
IER=103
WRITE(KFILDO,1110)(ID(J),J=1,4),IER
1110 FORMAT(/' ****LLLL DOES NOT INDICATE EITHER A MEAN OR',
1 ' PROBABILITY FORECAST FOR EKDMOS VARIABLE ',
2 I9.9,I10.9,I10.9,I4.3,/,
3 ' IER =',I5,'. ABORT AVGLAP.',
4 ' PROCEEDING.')
GO TO 900
ENDIF
C
ENDIF
C
C OPEN THE FILE AND READ THE PAIRS LIST. THE FIRST RECORD
C IS AN IDENTIFICATION. READ IT IN ASCII AND RETAIN IT.
C IF THE FILE NAME AND THE ID MATCH, THE DATA DO NOT
C HAVE TO BE READ AND MATCHED WITH THE CURRENT LIST.
C
125 STATE='130 '
COPS OPEN(UNIT=KFILZO,FILE=FLZERO,STATUS='OLD',
OPEN(UNIT=KFILZO,STATUS='OLD',
1 IOSTAT=IOS,ERR=126)
C IF THE FILE IS ALREADY OPEN THIS IS A NOP.
GO TO 129
C
126 WRITE(KFILDO,127)FLZERO,KFILZO
127 FORMAT(/' ****U179A PAIRS FILE ',A60,' ON UNIT NO.',I4,
1 ' COULD NOT BE OPENED.'/' SETTING ZEROS NOT DONE.')
ISTOP(1)=ISTOP(1)+1
GO TO 900
C
129 WRITE(KFILDO,130)KFILZO,FLZERO
130 FORMAT(/,' OPENING PAIRS FILE ON UNIT NO.',I3,
1 ' FILE = ',A60)
REWIND KFILZO
C FILE MAY HAVE ALREADY BEEN OPENED AND READ. THEREFORE,
C REWIND.
STATE='132 '
READ(KFILZO,132,ERR=900)FILEID
132 FORMAT(A60)
C
IF(FILEID.EQ.SAVID.AND.FLZERO.EQ.SAVFL)THEN
C THE FILE FOR AUXILIARY FORECASTS IS THE SAME AS USED
C PREVIOUSLY.
C FLZERO IS THE FILE NAME; FILEID IS THE FILE
C IDENTIFICATION PUT THERE BY U179A.
WRITE(KFILDO,135)
135 FORMAT(' THE FILE FOR AUXILIARY FORECASTS IN AVGLAP',
1 ' IS THE SAME AS USED BEFORE.',
2 ' IT DOES NOT HAVE TO BE READ.')
GO TO 201
C THE TWO LISTS OF STATIONS ARE THE SAME, SO ALL
C ARRAYS ARE THE SAME, EXCEPT TEMP( ) TO HOLD THE
C DATA NEEDS TO BE INITIALIZED.
ELSE
SAVID(1:60)=FILEID(1:60)
SAVFL(1:60)=FLZERO(1:60)
WRITE(KFILDO,137)FILEID
137 FORMAT(' IDENTIFICATION ON THIS FILE IS: ',A60)
C
C READ THE NUMBER OF STATIONS AND MAXIMUM PAIRS.
C
STATE='138 '
READ(KFILZO,138,ERR=900)MSTA,MAXSTA
138 FORMAT(2I6)
WRITE(KFILDO,139)MAXSTA,MSTA,FLZERO
139 FORMAT(' UP TO',I3,' STATIONS IN EACH LIST FOR ',
1 I7,' STATIONS READ FROM FILE ',A60)
C
C IF THIS IS A DIFFERENT FILE, LIKELY MSTA OR MAXSTA
C WILL BE DIFFERENT. DEALLOCATE AND REALLOCATE.
C IT WON'T HURT IF THEY HAVE HAVEN'T BEEN ALLOCATED.
C
DEALLOCATE(CCALLD,NOALOC,IALOC,RDIST,LIST,LISTD,TEMP,
1 STAT=IOS)
IALL=MAX(NSTA,MSTA)
C NOTE THAT MSTA CAN BE LARGER OR SMALLER THAN NSTA.
ALLOCATE(CCALLD(IALL),NOALOC(IALL),IALOC(IALL,MAXSTA),
1 RDIST(IALL,MAXSTA),LIST(IALL),LISTD(IALL),
2 TEMP(IALL),STAT=IOS)
C
IF(IOS.EQ.1)THEN
WRITE(KFILDO,140)
140 FORMAT(/' ****ALLOCATION OF ARRAYS FAILED IN AVGLAP AT',
1 ' 120. ARRAY ALREADY ALLOCATED.')
ISTOP(1)=ISTOP(1)+1
IER=777
GO TO 900
C
ELSEIF(IOS.EQ.2)THEN
WRITE(KFILDO,141)
141 FORMAT(/' ****ALLOCATION OF ARRAYS FAILED IN AVGLAP AT',
1 ' 121. ARRAY NOT ALLOCATED.')
ISTOP(1)=ISTOP(1)+1
IER=777
GO TO 900
ENDIF
C
C INITIALIZE LIST( ) AND LISTD( ).
C
DO 145 K=1,IALL
LIST(K)=999999
LISTD(K)=999999
145 CONTINUE
C
C READ THE PAIRS.
C
DO 160 KK=1,MSTA
STATE='150 '
READ(KFILZO,150,IOSTAT=IOS,ERR=910)CCALLD(KK),NOALOC(KK)
150 FORMAT(A8,I8)
C
CCC WRITE(KFILDO,151)KK,MSTA,CCALLD(KK),NOALOC(KK)
CCC 151 FORMAT(' AT 151--KK,MSTA,CCALLD(KK),NOALOC(KK)',2I6,2X,A8,I6)
C
IF(NOALOC(KK).EQ.9999)GO TO 160
C NOALOC( ) = 9999 SIGNIFIES THERE IS NO LIST TO READ.
C IALOC( , ) AND RDIST( ,) WILL BE UNDEFINED.
C
IF(NOALOC(KK).GT.MAXSTA)THEN
WRITE(KFILDO,152)KK,NOALOC(KK),MAXSTA
152 FORMAT(/' ****NALOC(KK) =',I8,' GT MAXSTA =',I4,
1 ' FOR STATION NO. KK =',I6,' IN AVGLAP AT 152.',/,
2 ' FATAL ERROR.')
ISTOP(1)=ISTOP(1)+1
IER=777
GO TO 900
ENDIF
C
STATE='155 '
READ(KFILZO,155,IOSTAT=IOS,ERR=910)(IALOC(KK,J),RDIST(KK,J),
1 J=1,NOALOC(KK))
155 FORMAT(10(I6,F10.2))
C
DO 1558 J=1,NOALOC(KK)
C
IF(IALOC(KK,J).GT.MSTA)THEN
WRITE(KFILDO,1555)IALOC(KK,J),MSTA,CCALLD(KK)
1555 FORMAT(/,' ****LOCATION IN IALOC(KK,J) =',I9,
1 ' GREATER THAN SIZE OF LIST =',I6,
2 ' FOR STATION ',A8,/,
3 ' FATAL ERROR.')
ISTOP(1)=ISTOP(1)+1
IER=777
GO TO 900
ENDIF
C
1558 CONTINUE
C
CCC WRITE(KFILDO,156)KK,(IALOC(KK,J),RDIST(KK,J),J=1,NOALOC(KK))
CCC 156 FORMAT(' AT 156 IN AVGLAP--KK,(IALOC(KK,J),RDIST(KK,J),',
CCC 1 'J=1,NOALOC(KK))',I6,/,(I6,F10.2))
160 CONTINUE
C
C READ THE TERMINATOR.
C
STATE='162 '
READ(KFILZO,150,IOSTAT=IOS,ERR=910)TRASH
C
IF(TRASH.NE.'999999 ')THEN
WRITE(KFILDO,165)TRASH
165 FORMAT(' ****DID NOT FIND TERMINATOR ON FILE IN AVGLAP.',
1 ' FOUND INSTEAD ',A8,/,
2 ' COUNT AS FATAL ERROR.')
ISTOP(1)=ISTOP(1)+1
IER=777
GO TO 900
ENDIF
C
ENDIF
C
WRITE(KFILDO,167)NSTA,MSTA
167 FORMAT(/' THERE ARE',I6,' STATIONS BEING ANALYZED, AND',I6,
1 ' STATIONS FOR AUGMENTATION. SOME MAY HAVE MISSING',
2 ' DATA.')
C
C FIND THE LINKS FROM THE AUXILIARY MSTA LIST TO THE
C PRIMARY NSTA LIST.
C
ISTART=1
IEND=MSTA
C
DO 200 K=1,NSTA
C
C FIND THE STATION IN CCALL(K) IN THE CCALLD(KK) LIST.
C THEY OUGHT TO BOTH BE AT LEAST APPROXIMATELY IN ORDER,
C AND STORE THE ORDER IN LIST( ).
C
170 DO 190 KK=ISTART,IEND
C
IF(CCALLD(KK).EQ.CCALL(K))THEN
LIST(K)=KK
LISTD(KK)=K
ISTART=KK
C ISTART SET TO KK RATHER THAN KK+1 TO KEEP FROM INDEXING
C PAST END OF ARRAY WHEN ISTART = IEND.
IEND=MSTA
CCCD WRITE(KFILDO,175)K,KK,CCALL(K),LIST(K),ISTART,IEND
CCCD175 FORMAT(' AT 175--K,KK,CCALL(K),LIST(K),ISTART,IEND',
CCCD 1 2I6,2X,A8,3I6)
GO TO 200
ENDIF
C
190 CONTINUE
C
IF(ISTART.NE.1)THEN
IEND=ISTART
ISTART=1
GO TO 170
ENDIF
C
C DROP THROUGH HERE MEANS AUXILIARY STATION NOT FOUND.
C
IF(IFIRST.EQ.0)THEN
WRITE(KFILDO,194)
194 FORMAT(' ')
IFIRST=IFIRST+1
ISTOP(1)=ISTOP(1)+1
ENDIF
C
IF(IFIRST.LE.3)THEN
WRITE(KFILDO,195)CCALL(K),NAME(K)
195 FORMAT(' ****STATION ',A8,A20,' NOT FOUND IN AUXILIARY LIST.',
1 ' PROCEEDING.')
IFIRST=IFIRST+1
ENDIF
C
IF(IFIRST.EQ.4)THEN
WRITE(KFILDO,196)
196 FORMAT(' THIS DIAGNOSTIC WILL NOT PRINT AGAIN.',
1 ' COUNTED AS ONE ISTOP ERROR.')
IFIRST=IFIRST+1
ENDIF
C
LIST(K)=999999
ISTART=1
IEND=MSTA
IFIRST=IFIRST+1
C IF STATION NOT FOUND, RESTART THE PROCESS FROM THE TOP.
C THIS SHOULD BE UNUSUAL.
C
200 CONTINUE
C
IF(IFIRST.NE.0)THEN
WRITE(KFILDO,2001)IFIRST
2001 FORMAT(' THERE WERE',I6,' ERRORS OF THIS TYPE.')
ENDIF
C
D DO 2005 K=1,MIN(IALL,ND1)
C IALL COULD EXCEED ND1.
D WRITE(KFILDO,2000)K,CCALL(K),LIST(K),LISTD(K),XLAPSE(K)
D2000 FORMAT(' AT 2000--K,CCALL(K),LIST(K),LISTD(K),XLAPSE(K),',
D 1 I6,2X,A8,2I8,F8.4)
D2005 CONTINUE
C
C AVERAGE THE XLAPSE VALUES WTIH NEIGHBORING STATIONS.
C
201 DO 220 K=1,NSTA
TEMP(K)=9999.
C
IF(LIST(K).NE.999999)THEN
C LIST(K) IS THE LOCATION OF THE SAME STATION IN THE
C PAIRS LIST.
C
D WRITE(KFILDO,2015)K,LIST(K),LISTD(K),NOALOC(LIST(K)),
D 1 IALOC(LIST(K),1)
D2015 FORMAT(/' AT 2015--K,LIST(K),LISTD(K),NOALOC(LIST(K)),',
D 1 'IALOC(LIST(K),1)',5I10)
C
IF(NOALOC(LIST(K)).NE.9999)THEN
C
D IF(LISTD(K).NE.999999)THEN
C
C LOC AND THE FOLLOWING IF STATEMENT ONLY FOR
C DIAGNOSTIC PRINTING.
C
D LOC=LISTD(IALOC(LIST(K),1))
C NOTE THE 1.
C
D IF(LOC.NE.999999)THEN
D WRITE(KFILDO,2017)K,LIST(K),LISTD(K),
D 1 IALOC(LIST(K),1),LOC
D2017 FORMAT(/' AT 2017--K,LIST(K),LISTD(K),',
D 1 'IALOC(LIST(K),1),LOC',6I10)
C
D WRITE(KFILDO,202)K,CCALL(K),LIST(K),NOALOC(LIST(K)),
D 1 XLAPSE(K),XLAPSE(LOC)
D202 FORMAT(/,' AT 202--K,CCALL(K),LIST(K),',
D 1 'NOALOC(LIST(K)),',
D 2 'XLAPSE(K),XLAPSE(LOC)',/,
D 3 I7,2X,A8,I8,I3,2F8.4)
D ENDIF
C
D ENDIF
C
IF(XDATA(K).LE..0.OR.XDATA(K).GT.9998.)THEN
C THIS MEANS THE DATA VALUE IS EITHER ZERO OR
C MISSING, SO DON'T CHANGE THE XLAPSE( ) VALUE.
TEMP(K)=XLAPSE(K)
C
D WRITE(KFILDO,2018)K,CCALL(K),NAME(K),XLAPSE(K),TEMP(K)
D2018 FORMAT(' AT 2018--K,CCALL(K),NAME(K),XLAPSE(K),TEMP(K)',
D 1 I6,2X,A8,2X,A20,2F10.4)
GO TO 220
ENDIF
C
C DATA VALUE IS POSITIVE AND NOT MISSING. COMPUTE THE
C AVERAGE.
C
SUM=MAX(XLAPSE(K),0.)
C DO NOT SUM NEGATIVE VALUES.
KOUNT=1
C THE STATION ITSELF WILL NOT BE IN THE LIST, SO INCLUDE
C IT HERE.
C
DO 205 M=1,NOALOC(LIST(K))
IF(IALOC(LIST(K),M).GT.IALL)GO TO 205
C
LOC=LISTD(IALOC(LIST(K),M))
C
IF(LOC.EQ.999999)THEN
C
D WRITE(KFILDO,2021)
D2021 FORMAT('STATION IN PAIRS LIST IS NOT A',
D 1 ' STATION BEING ANALYZED, SO CANNOT BE USED IN',
D 2 ' SETTING ZERO VALUES IN AVGLAP.')
C
D WRITE(KFILDO,2022)K,M,LIST(K),LISTD(K),
D 1 IALOC(LIST(K),M),LOC
D2022 FORMAT(' AT 2022--K,M,LIST(K),LISTD(K),',
D 1 'IALOC(LIST(K),M),LOC',6I9)
GO TO 205
ENDIF
C
IF(CCALL(K).EQ.'PAKP ')THEN
WRITE(KFILDO,2025)K,LIST(K),CCALL(K),CCALLD(LIST(K)),
1 XLAPSE(LOC),IALOC(LIST(K),M),
2 CCALL(IALOC(LIST(K),M)),NAME(IALOC(LIST(K),M)),
3 SUM,KOUNT
2025 FORMAT(/' AT 2025--K,LIST(K),CCALL(K),CCALLD(LIST(K)),',
1 'XLAPSE(LOC),IALOC(LIST(K),M)',
2 'CCALL(IALOC(LIST(K),M)),NAME(IALOC(LIST(K),M))',
3 'SUM,KOUNT',
3 /,10X,2I5,2X,2A8,F10.1,I10,2X,A8,2X,A20,F7.4,I3)
ENDIF
C
IF(XDATA(LOC).LT.9998..AND.XDATA(LOC).GT..0)THEN
C THIS REQUIRES THE PAIR TO BE POSITIVE AND NON-MISSING.
SUM=SUM+MAX(XLAPSE(LOC),0.)
C DO NOT SUM NEGATIVE VALUES.
KOUNT=KOUNT+1
C
WRITE(KFILDO,2027)K,XLAPSE(LOC),SUM,KOUNT
2027 FORMAT(' AT 2027 IN AVGLAP--K,XLAPSE(LOC),SUM,KOUNT',
1 I6,2F10.4,I4)
C
IF(KOUNT.GE.5)GO TO 2050
C LIMIT AVERAGING TO 4 STATIONS. THE STATION LIST IS
C ORDERED, SO THE 4 CLOSEST ONES WITH DATA WILL BE USED.
ENDIF
C
205 CONTINUE
C
2050 IF(KOUNT.GT.1)THEN
C BECAUSE THE STATION ITSELF IS ICLUDED, KOUNT WILL
C NEVER BE ZERO. DO NOT ACCEPT A LAPSE OF ONLY
C THE STATION ITSELF.
TEMP(K)=MAX(SUM/KOUNT,0.)
C TEMP(K) NOW IS THE AVERAGE OF THE XLAPSE( ) VALUES
C OF THE STATION ITSELF AND THE 4 NEAREST NEIGHBORS
C WITH DATA,BUT ONLY IF POSITIVE.
C
D WRITE(KFILDO,2051)K,CCALL(K),NAME(K),XLAPSE(K),TEMP(K)
D2051 FORMAT(' AT 2051--K,CCALL(K),NAME(K),XLAPSE(K),TEMP(K)',
D 1 I6,2X,A8,2X,A20,2F10.2)
C
ELSE
TEMP(K)=0.
C THIS IS A SAFETY, AND WILL NOT HAPPEN.
C
D WRITE(KFILDO,2052)K,CCALL(K),NAME(K),XLAPSE(K),TEMP(K)
D2052 FORMAT(' AT 2052--K,CCALL(K),NAME(K),XLAPSE(K),TEMP(K)',
D 1 I6,2X,A8,2X,A20,2F10.2)
ENDIF
C
ELSE
TEMP(K)=XLAPSE(K)
C
D WRITE(KFILDO,2053)K,CCALL(K),NAME(K),XLAPSE(K),TEMP(K)
D2053 FORMAT(' AT 2053--K,CCALL(K),NAME(K),XLAPSE(K),TEMP(K)',
D 1 I6,2X,A8,2X,A20,2F10.4)
C
ENDIF
C
ELSE
TEMP(K)=XLAPSE(K)
C
D WRITE(KFILDO,2054)K,CCALL(K),NAME(K),XLAPSE(K),TEMP(K)
D2054 FORMAT(' AT 2054--K,CCALL(K),NAME(K),XLAPSE(K),TEMP(K)',
D 1 I6,2X,A8,2X,A20,2F10.4)
C
IF(JFIRST.EQ.0)THEN
WRITE(KFILDO,2185)
2185 FORMAT(' ')
ISTOP(1)=ISTOP(1)+1
ENDIF
C
IF(JFIRST.LE.1)THEN
WRITE(KFILDO,219)K,LIST(K),CCALL(K),NAME(K)
219 FORMAT(' ****STATION IN ANALYSIS LIST NOT IN PAIRS',
1 ' LIST. K,LIST(K),CCALL(K) ARE',I6,I10,2X,A8,A20)
JFIRST=JFIRST+1
ENDIF
C
IF(JFIRST.EQ.2)THEN
WRITE(KFILDO,2190)
2190 FORMAT(' THIS DIAGNOSTIC WILL NOT PRINT AGAIN FOR',
1 ' THIS ZERO MODIFICATION. COUNTED AS ONE ISTOP',
2 ' ERROR.')
JFIRST=JFIRST+1
ENDIF
C
IF(JFIRST.GT.2)THEN
JFIRST=JFIRST+1
ENDIF
C
ENDIF
C
220 CONTINUE
C
IF(JFIRST.NE.0)THEN
WRITE(KFILDO,221)JFIRST
221 FORMAT(/' THERE WERE',I6,' CASES IN WHICH A STATION IN',
1 ' THE ANALYSIS LIST WAS NOT IN PAIRS LIST.',
2 ' LOOK AT HOW U179A WAS RUN.')
ENDIF
C
C REPLACE XLAPSE( ) WITH THE AUGMENTED DATA IN TEMP( ).
C
DO 222 K=1,NSTA
XLAPSE(K)=TEMP(K)
222 CONTINUE
C
WRITE(KFILDO,225)(K,CCALL(K),XLAPSE(K),K=1,NSTA)
C NOTE THAT THESE VALUES ARE NOT SCALED--JUST WHAT IS
C BEING ANALYZED. SCALING COULD BE DONE HERE OR IN A
C FOLLOWING ROUTINE.
225 FORMAT(/,' IN AVGLAP AT 225',/,(I6,2X,A8,F10.4))
C
D CALL TIMPR(KFILDO,KFILDO,'END AVGLAP ')
C
900 RETURN
C ERROR STOP BELOW IS FOR ERRORS OF CONTROL INFORMATION INPUT.
910 CALL IERX(KFILDO,KFILDO,IOS,'AVGLAP',STATE)
ISTOP(1)=ISTOP(1)+1
IER=777
GO TO 900
END