SUBROUTINE KEYLST(KFILDO,IP8,CCALL,CCALLD,IALOC,
1 NOPAR,LOCPAR,NSTA,LSTA,MSTA,ISTOP,IER)
C
C MAY 2005 GLAHN MDL MOS-2000
C NOVEMBER 2006 GLAHN CHECK FOR LSTA, NSTA, OR LSTA = 0;
C CHANGED DIMENSIONS OF NOPART( ) AND
C LOCPART( ), & FULLY INITIALIZED; ADDED
C IF(IALOC(J).EQ.9999)IALOC(J)=999999
C BELOW DO 160
C JULY 2008 GLAHN MISSING VALUE OF NOPAR( ) RETURNED
C AS 9999 VICE 999999
C JUNE 2014 GLAHH INSERTED CALL TO W3TAGE BEFORE STOP
C NOVEMBER 2014 GLAHN REVISED W3TAG PER JUDY
C
C PURPOSE
C
C TO CHANGE THE LINKS IN IALOC( ) FROM REFERENCE TO THE
C LSTA INPUT LIST TO THE NSTA ANALYSIS LIST. ALSO ORDER
C NOPAR( ) AND LOCPAR( ) ACCORDING TO THE NSTA LIST
C RATHER THAN THE LSTA LIST.
C
C DATA SET USE
C KFILDO - UNIT NUMBER OF OUTPUT (PRINT) FILE. (OUTPUT)
C IP(J) - UNIT NUMBERS FOR OPTIONAL OUTPUT (J=1,25)
C (SEE IP( ) UNDER "VARIABLES" BELOW.) (OUTPUT)
C
C VARIABLES
C KFILDO = UNIT NUMBER OF OUTPUT (PRINT) FILE. (INPUT)
C IP8 = THE POSITION IN THE NSTA LIST OF THE PAIRS
C OF STATIONS IN THE LSTA LIST IS IS
C WRITTEN WHEN IP8 NE 0. (INPUT)
C CCALL(K) = 8-CHARACTER STATION CALL LETTERS (K=1,NSTA).
C NOTE THAT THE SUBSTITUTE STATIONS IN CCALL( , )
C IN THE CALLING PROGRAM ARE NOT USED.
C (CHARACTER*8) (INPUT)
C CCALLD(L) = THE CALL LETTERS IN THE PAIRS LIST READ FROM
C THE INPUT IN RDPRS (L=1,LSTA). (INPUT)
C (CHARACTER*8)
C IALOC(J) = THE LOCATIONS OF THE PAIRS FOR EACH STATION
C K IN THE LSTA LIST (INPUT) AND THE NSTA LIST
C (OUTPUT) (J=1,MSTA). (INPUT/OUTPUT)
C NOPAR(K) = THE NUMBER OF PAIRS FOR STATION K IN THE
C LSTA LIST (INPUT) AND THE NSTA LIST (OUTPUT),
C (K=1,NSTA ON OUTPUT) (INPUT/OUTPUT)
C LOCPAR(K) = THE LOCATION IN IALOC( ) OF THE STATION K
C IN THE LSTA LIST (INPUT) AND THE NSTA LIST
C (OUTPUT) (K=1,NSTA ON OUTPUT) WHERE THE PAIRS
C LISTS START. (INPUT/OUTPUT)
C NSTA = THE NUMBER OF STATIONS IN THE CCALL( ) LIST.
C (INPUT)
C LSTA = THE NUMBER OF STATIONS IN THE CCALLD( ) LIST.
C (INPUT)
C MSTA = THE NUMBER OF VALUES IN THE IALOC( ) LIST.
C (INPUT)
C ISTOP = INCREMENTED BY ONE WHEN AN ERROR OCCURS. NOT
C ACTUALLY USED. (INPUT-OUTPUT)
C IER = STATUS RETURN.
C 0 = GOOD RETURN.
C (OUTPUT)
C KEY(L) = INTERNAL CORRESPONDENCE BETWEEN EACH STATION
C IN LSTA LIST AND NSTA LIST (L=1,LSTA).
C (AUTOMATIC) (INTERNAL)
C NOPART(L) = WORK ARRAY (L=1,MAX(LSTA,NSTA)).
C (AUTOMATIC) (INTERNAL)
C LOCPART(L) = WORK ARRAY (L=1,MAX(LSTA,NSTA)).
C (AUTOMATIC) (INTERNAL)
C 1 2 3 4 5 6 7 X
C
C NONSYSTEM SUBROUTINES USED
C NONE
C
CHARACTER*8 CCALL(NSTA)
CHARACTER*8 CCALLD(LSTA)
C
DIMENSION LOCPAR(NSTA),NOPAR(NSTA)
DIMENSION IALOC(MSTA)
DIMENSION KEY(LSTA),NOPART(NSTA),LOCPART(NSTA)
C KEY( ), NOPART( ) AND LOCPART( ) ARE AUTOMATIC ARRAYS.
C
IER=0
C
D WRITE(KFILDO,099)NSTA,LSTA,MSTA
D099 FORMAT(/' AT 099 IN KEYLST--NSTA,LSTA,MSTA',3I8)
IF(NSTA.LE.0.OR.LSTA.LE.0.OR.MSTA.LE.0)THEN
WRITE(KFILDO,100)NSTA,LSTA,MSTA
100 FORMAT(/,' NSTA, LSTA OR MSTA IS ZERO.',3I10,/,
1 ' STOP IN KEYLST AT 100.')
CALL W3TAGE('KEYLST')
STOP 100
ENDIF
C
ISTART=1
IEND=NSTA
MATCH=0
C MATCH COUNTS THE NUMBER OF MATCHES.
D WRITE(KFILDO,101)(J,IALOC(J),J=1,MSTA)
D101 FORMAT(/' IN KEYLST--(J,IALOC(J),J=1,MSTA)',/,5(I10,I7))
C
IPRINT=0
C IPRINT CONTROLS SPACING OF PRINT.
C
D WRITE(KFILDO,104)NSTA,(CCALL(K),K=1,NSTA)
D104 FORMAT(/,' LIST OF ',I6,' STATIONS IN CCALL( )',/,(10(2X,A8)))
D WRITE(KFILDO,105)LSTA,(CCALLD(K),K=1,LSTA)
D105 FORMAT(/,' LIST OF ',I6,' STATIONS IN CCALLD( )',/,(10(2X,A8)))
C
C INITIALIZE KEY( ), NOPART( ), AND LOCPART( )
C
DO 119 L=1,LSTA
KEY(L)=999999
119 CONTINUE
C
DO 120 L=1,NSTA
NOPART(L)=999999
LOCPART(L)=999999
120 CONTINUE
C
DO 140 L=1,LSTA
C
D WRITE(KFILDO,121)LSTA,ISTART,IEND
D121 FORMAT(/' AT 121 IN KEYLST--LSTA,ISTART,IEND',3I6)
C
122 DO 135 K=ISTART,IEND
C
IF(CCALLD(L).EQ.CCALL(K))THEN
C
C FORM THE KEY( ) LIST. EACH ENTRY IS AT THE LSTA
C LIST LOCATION, THE NUMBER BEING THE LOCATION IN
C THE NSTA LIST.
C
KEY(L)=K
C
C FORM A TEMPORARY LIST OF THE LOCATIONS IN THE MSTA
C LIST IN THE ORDER OF THE NSTA LIST FROM THE LSTA LIST.
C
LOCPART(K)=LOCPAR(L)
NOPART(K)=NOPAR(L)
ISTART=K
C ISTART IS SET TO K RATHER THAN K+1 TO ALLEVIATE
C POSSIBLE REFERENCING AN ELEMENT OUTSIDE ARRAY BOUNDS.
IEND=NSTA
MATCH=MATCH+1
GO TO 140
ENDIF
C
135 CONTINUE
C
C NO MATCH. SEARCH FIRST PART OF THE LIST IF IT HASN'T
C BEEN DONE.
C
IF(ISTART.NE.1)THEN
IEND=ISTART-1
ISTART=1
GO TO 122
ELSE
C
C A MATCH DOES NOT EXIST. THIS MEANS A STATION IN
C THE INCOMING LSTA LIST IS NOT IN THE U155 NSTA LIST.
C
KEY(L)=999999
C
C RESTART IN THE L LIST WHERE IT WAS PREVIOUSLY.
C
IEND=NSTA
C
IF(IP8.NE.0)THEN
C
IF(IPRINT.EQ.0)THEN
WRITE(IP8,137)
137 FORMAT(' ')
IPRINT=1
ENDIF
C
WRITE(IP8,138)CCALLD(L)
138 FORMAT(' ****STATION ',A8,' NOT FOUND IN NSTA CCALL( )',
1 ' LIST IN KEYLST. MAY BE NORMAL; NOT COUNTED',
2 ' AS AN ISTOP ERROR.')
ENDIF
C
ENDIF
C
140 CONTINUE
C
IF(MATCH.EQ.0)THEN
WRITE(KFILDO,144)
144 FORMAT(/' ****NO PAIR MATCHES FOUND. LAPSE RATES WILL ALL',
1 ' BE ZERO. PROCEEDING.')
ISTOP=ISTOP+1
ELSE
WRITE(KFILDO,145)MATCH
145 FORMAT(/,' ',I6,' MATCHES FOUND')
ENDIF
C
IF(IP8.NE.0)THEN
WRITE(IP8,150)(L,CCALL(L),KEY(L),L=1,LSTA)
150 FORMAT(/,'THE POSITION IN THE NSTA LIST OF THE',
1 ' STATION IN THE LSTA LIST',/,
1 (5(3X,I7,1X,A8,I7)))
ENDIF
C
C NOW REPLACE THE LOCATIONS IN IALOC( ) PERTAINING TO THE
C LSTA LIST WITH THOSE PERTAINING TO THE NSTA LIST.
C
DO 160 J=1,MSTA
IF(IALOC(J).EQ.9999)IALOC(J)=999999
C WHEN THErE WAS NO LIST OUT OF U174, IALOC( ) WILL BE 9999.
C
IF(IALOC(J).NE.999999)THEN
C IF IALOC( ) = 999999, LEAVE IT. IT PERTAINS TO A
C STATION IN THE LSTA LIST, BUT WILL PERTAIN TO THE
C SAME STATION IN THE NSTA LIST.
C
D WRITE(KFILDO,155)J,IALOC(J),KEY(IALOC(J))
D155 FORMAT(/' AT 155 IN KEYLST--J,IALOC(J),KEY(IALOC(J))',
D 1 3I10)
IF(KEY(IALOC(J)).EQ.999999)THEN
C THIS MEANS THERE IS NO MATCH FOR THE STATION
C IN IALOC( ), SO SIT TO MISSING = 999999.
IALOC(J)=999999
ELSE
IALOC(J)=KEY(IALOC(J))
ENDIF
C
D WRITE(KFILDO,158)J,IALOC(J)
D158 FORMAT(' AT 158 IN KEYLST--J,IALOC(J)',2I8)
ENDIF
C
160 CONTINUE
C
C MOVE THE TEMPORARY LISTS NOPART( ) AND LOCPART( ) TO
C NOPAR( ) AND LOCPAR( ). AFTER THAT, THE LOCATIONS IN
C THE MSTA LIST IN IALOC( ), ADIST( ), AELEV( ) ARE IN
C THE ORDER OF THE NSTA LIST.
C
DO 170 K=1,NSTA
LOCPAR(K)=LOCPART(K)
NOPAR(K)=NOPART(K)
IF(NOPAR(K).EQ.999999)NOPAR(K)=9999
C THE ABOVE STATEMENT INSERTED 7/15/08.
C THIS WAS NECESSARY WHEN USING A LAMP U174 PAIRS LIST WITH
C A LARGER (MOS) LIST OF STATIONS FOR ANALYSIS
C THIS VALUE OF 9999 VS 999999 HAS BEEN A SOURCE OF CONFUSION.
C IT IS WRITTEN BY U174 AS 9999, BUT AT ONE TIME WAS 999999.
170 CONTINUE
C
D WRITE(KFILDO,175)(K,CCALL(K),
D 1 LOCPAR(K),NOPAR(K),K=1,NSTA)
D175 FORMAT(/' AT 175 IN KEYLST--(K,CCALL(K),',
D 1 'LOCPAR(K),NOPAR(K),K=1,NSTA)',/,
D 2 2(I12,2X,A8,2I8))
RETURN
C
END