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