C @(#)redsubs.for 17.1.1.1 (ESO-DMD) 01/25/02 17:17:17 C=========================================================================== C Copyright (C) 1995 European Southern Observatory (ESO) C C This program is free software; you can redistribute it and/or C modify it under the terms of the GNU General Public License as C published by the Free Software Foundation; either version 2 of C the License, or (at your option) any later version. C C This program is distributed in the hope that it will be useful, C but WITHOUT ANY WARRANTY; without even the implied warranty of C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the C GNU General Public License for more details. C C You should have received a copy of the GNU General Public C License along with this program; if not, write to the Free C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, C MA 02139, USA. C C Correspondence concerning ESO-MIDAS should be addressed as follows: C Internet e-mail: midas@eso.org C Postal address: European Southern Observatory C Data Management Division C Karl-Schwarzschild-Strasse 2 C D 85748 Garching bei Muenchen C GERMANY C=========================================================================== C SUBROUTINE STDNAME(C32, NUMBER) C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT (c) European Southern Observatory 1992 C.IDENT redsubs.for C.MODULE C.AUTHOR Andrew T. Young C.KEYWORD C.LANGUAGE FORTRAN 77 C.PURPOSE some subroutines used by REDUCE C.COMMENTS C.VERSION 4.5 C.RETURNS C.ENVIRONMENT C. C----------------------------------------------------------------------------- C C C splits input string C32 into NUMBER star names in std. format, C stored in STAR5 in /STDNAM/. C C CAUTION: assumes ASCII collating sequence!! C C method: input string is split into tokens in token(ntok), C which begins in nbgn(ntok) and ends in nend(ntok) C of the input string. The (possibly modified) token C has length len(ntok), and if recognized has type C ntype(ntok), or zero if not recognized. C C IMPLICIT NONE INTEGER NUMBER, NBGN, NEND, NTYPE, LEN, NWORDS, NITEM, NEXT, N, 1 NBIN, K, NTOK, NTOKENS, JUMP, LAST, M, KOL, NEW, NERR C CHARACTER*80 CARD C INCLUDE 'MID_REL_INCL:mstars.inc' C PARAMETER (MSTARS=1650) C common for name matching: INTEGER MSTARK PARAMETER (MSTARK=2*MSTARS) CHARACTER*20 STDNAMES(MSTARK), STAR5(5) COMMON /STDNAM/ STDNAMES,STAR5 C CHARACTER C32*32, STDNAM*32, STR*20, TOKEN(12)*20 DIMENSION NBGN(12),NEND(12),NTYPE(12),LEN(12) C INTEGER NTYPES(3*6*24+3) INTEGER NT1(6*24),NT2(6*24),NT3(6*24+3) CC EQUIVALENCE (NTYPES,NT1),(NTYPES(6*24+1),NT2) compiler warnings... CC EQUIVALENCE (NTYPES(2*6*24+1),NT3) C CHARACTER*3 WORD(6*3*24+3),NAME CHARACTER*3 C3P1(3*24),C3P2(3*24),C3P3(3*24) CHARACTER*3 C3P4(3*24),C3P5(3*24+2),C3P6(3*24+1) EQUIVALENCE (WORD,C3P1),(WORD(3*24+1),C3P2) EQUIVALENCE (WORD(2*3*24+1),C3P3),(WORD(3*3*24+1),C3P4) EQUIVALENCE (WORD(4*3*24+1),C3P5),(WORD(5*3*24+3),C3P6) C CHARACTER*7 STDWD(6*3*24+3),STD1(3*12),STD2(3*12),STD3(3*12) CHARACTER*7 STD4(3*12),STD5(3*12),STD6(3*12) CHARACTER*7 STD7(3*12),STD8(3*12),STD9(3*12+2) CHARACTER*7 STD10(3*12),STD11(3*12),STD12(3*12+1) EQUIVALENCE (STDWD,STD1),(STDWD(3*12+1),STD2) EQUIVALENCE (STDWD(2*3*12+1),STD3),(STDWD(3*3*12+1),STD4) EQUIVALENCE (STDWD(4*3*12+1),STD5),(STDWD(5*3*12+1),STD6) EQUIVALENCE (STDWD(6*3*12+1),STD7),(STDWD(7*3*12+1),STD8) EQUIVALENCE (STDWD(8*3*12+1),STD9),(STDWD(9*3*12+3),STD10) EQUIVALENCE (STDWD(10*3*12+3),STD11),(STDWD(11*3*12+3),STD12) C C The following entries *** MUST *** be ordered C according to the collating sequence! C DATA C3P1/ 1'1U ','2U ','3C ','3U ','4U ','ADS','AGK','ALP','AND', 2'ANT','APS','APU','AQL','AQR','AQU','ARA','ARI','AUR', 3'AUS','Alp','And','Ant','Aps','Apu','Aql','Aqr','Aqu', 4'Ara','Ari','Aur','Aus','BD ','BD+','BD-','BER','BET', 5'BOO','BOR','BS ','BS1','BS2','BS3','BS4','BS5','BS6', 6'BS7','BS8','BS9','BSD','Ber','Bet','Boo','Bor','CAE', 7'CAM','CAN','CAP','CAR','CAS','CD ','CD+','CD-','CEN', 8'CEP','CET','CHA','CHI','CIR','CMA','CMI','CMa','CMi'/ DATA C3P2/ 1'CNC','COD','COL','COM','COR','CPD','CRA','CRB','CRT', 2'CRU','CRV','CVN','CVn','CYG','Cae','Cam','Can','Cap', 3'Car','Cas','Cen','Cep','Cet','Cha','Chi','Cir','Cnc', 4'CoD','Col','Com','Cor','CrA','CrB','Crt','Cru','Crv', 5'Cyg','DEL','DOR','DRA','Del','Dor','Dra','EPS','EQU', 6'ERI','ETA','Eps','Equ','Eri','Eta','FEI','FK5','FOR', 7'For','GAM','GC ','GEM','GRU','GSC','Gam','Gem','Grb', 8'Gro','Gru','Grw','HD ','HDE','HER','HOR','HR ','HYA'/ DATA C3P3/ 1'HYD','HYI','Her','Hor','Hya','Hyd','Hyi','IC ','IND', 2'IOT','IRC','Ind','Iot','KAP','Kap','LAC','LAM','LEO', 3'LEP','LIB','LMC','LMI','LMi','LS ','LUP','LYN','LYR', 4'Lac','Lal','Lam','Leo','Lep','Lib','LkH','Lup','Lyn', 5'Lyr','M ','MAJ','MEN','MIC','MIN','MON','MU ','MUS', 6'Maj','Mel','Men','Mic','Min','Mon','Mu ','Mus','N ', 7'NGC','NLT','NOR','NOV','NU ','Nor','Nov','Nu ','OCT', 8'OME','OMI','OPH','ORI','Oct','Ome','Omi','Oph','Ori'/ DATA C3P4/ 1'PAL','PAV','PEG','PER','PHE','PHI','PI ','PIC','PIS', 2'PK ','PPM','PSA','PSC','PSI','PUP','PYX','Pal','Pav', 3'Peg','Per','Phe','Phi','Pi ','Pic','Pis','PsA','Psc', 4'Psi','Pup','Pyx','QSO','RET','RHO','Ret','Rho','SAG', 5'SAO','SCL','SCO','SCT','SCU','SER','SEX','SGE','SGR', 6'SIG','SMC','SN ','Sag','Scl','Sco','Sct','Scu','Ser', 7'Sex','Sge','Sgr','Sig','TAU','TEL','THE','TRA','TRI', 8'TUC','Tau','Tel','The','TrA','Tri','Tuc','UGC','UMA'/ DATA C3P5/ 1'UMI','UMa','UMi','UPS','URS','Ups','Urs','VEL','VEN', X'VIR','VOL', 2'VUL','Vel','Ven','Vir','Vol','Vul','XI ','Xi ','ZET', 3'Zet','alp','and','ant','aps','apu','aql','aqr','aqu', 4'ara','ari','aur','aus','ber','bet','boo','bor','cae', 5'cam','can','cap','car','cas','cen','cep','cet','cha', 6'chi','cir','cma','cmi','cnc','col','com','cor','cra', 7'crb','crt','cru','crv','cvn','cyg','del','dor','dra', 8'eps','equ','eri','eta','for','gam','gem','gru','gsc'/ DATA C3P6/ 1'her','hor','hya','hyd','hyi','ind','iot','kap','lac', 2'lam','leo','lep','lib','lmi','lup','lyn','lyr','maj', 3'men','mic','min','mon','mu ','mus','nor','nu ','oct', 4'ome','omi','oph','ori','pav','peg','per','phe','phi', 5'pi ','pic','pis','psa','psc','psi','pup','pyx','ret', 6'rho','sag','scl','sco','sct','scu','ser','sex','sge', 7'sgr','sig','tau','tel','the','tra','tri','tuc','uma', 8'umi','ups','urs','vel','ven','vir', 9'vol','vul','xi ','zet'/ C C Here are the 7-character std. spellings for Greek & constellations: C DATA STD1/ 1'1U ','2U ','3C ','3U ','4U ','ADS','AGK','Alpha','And', 2'Ant','Aps','Apu','Aql','Aqr','Aqu','Ara','Ari','Aur', 3'AUS','Alpha','And','Ant','Aps','Apu','Aql','Aqr','Aqu', 4'Ara','Ari','Aur','Aus','BD ','BD+','BD-','BER','Beta'/ DATA STD2/ 5'Boo','BOR','BS ','BS1','BS2','BS3','BS4','BS5','BS6', 6'BS7','BS8','BS9','BSD','Ber','Bet','Boo','Bor','Cae', 7'Cam','CAN','Cap','Car','Cas','CD ','CD+','CD-','Cen', 8'Cep','Cet','Cha','Chi','Cir','CMa','CMi','CMa','CMi'/ DATA STD3/ 1'Cnc','COD','Col','Com','Cor','CPD','Cra','CrB','Crt', 2'Cru','Crv','CVn','CVn','Cyg','Cae','Cam','Can','Cap', 3'Car','Cas','Cen','Cep','Cet','Cha','Chi','Cir','Cnc', 4'CoD','Col','Com','Cor','CrA','CrB','Crt','Cru','Crv'/ DATA STD4/ 5'Cyg','DEL','Dor','Dra','Del','Dor','Dra','Epsilon','Equ', 6'Eri','Eta','Epsilon','Equ','Eri','Eta','FEI','FK5','For', 7'For','Gamma','GC ','Gem','Gru','GSC','Gam','Gem','Grb', 8'Gro','Gru','Grw','HD ','HDE','Her','Hor','HR ','Hya'/ DATA STD5/ 1'Hyd','Hyi','Her','Hor','Hya','Hyd','Hyi','IC ','Ind', 2'Iota','IRC','Ind','Iot','Kappa','Kappa','Lac','Lambda','Leo', 3'Lep','Lib','LMC','LMi','LMi','LS ','Lup','Lyn','Lyr', 4'Lac','Lal','Lam','Leo','Lep','Lib','LkH','Lup','Lyn'/ DATA STD6/ 5'Lyr','M ','MAJ','Men','Mic','MIN','Mon','Mu ','Mus', 6'Maj','Mel','Men','Mic','Min','Mon','Mu ','Mus','Nova', 7'NGC','NLT','Nor','Nova','Nu ','Nor','Nova','Nu ','Oct', 8'Omega','Omicron','Oph','Ori','Oct','Ome','Omi','Oph','Ori'/ DATA STD7/ 1'Pal','Pav','Peg','Per','Phe','Phi','Pi ','Pic','Pis', 2'PK ','PPM','PsA','Psc','Psi','Pup','Pyx','Pal','Pav', 3'Peg','Per','Phe','Phi','Pi ','Pic','Pis','PsA','Psc', 4'Psi','Pup','Pyx','QSO','Ret','Rho','Ret','Rho','Sag'/ DATA STD8/ 5'SAO','Scl','Sco','Sct','SCU','Ser','Sex','Sge','Sgr', 6'Sigma','SMC','SN ','Sag','Scl','Sco','Sct','Scu','Ser', 7'Sex','Sge','Sgr','Sig','Tau','Tel','Theta','TrA','Tri', 8'Tuc','Tau','Tel','The','TrA','Tri','Tuc','UGC','UMa'/ DATA STD9/ 1'UMi','UMa','UMi','UPS','URS','Upsilon','Urs','Vel','VEN', X'Vir', 2'Vol','Vul','Vel','Ven','Vir','Vol','Vul','Xi ','Xi ','Zeta', 3'Zeta','Alpha','And','Ant','Aps','apu','Aql','Aqr','Aqu', 4'Ara','Ari','Aur','aus','ber','Beta','Boo','bor','Cae'/ DATA STD10/ 5'Cam','can','Cap','Car','Cas','Cen','Cep','Cet','Cha', 6'Chi','Cir','CMa','CMi','Cnc','Col','Com','cor','Cra', 7'CrB','Crt','Cru','Crv','CVn','Cyg','del','Dor','Dra', 8'Epsilon','Equ','Eri','Eta','For','Gamma','Gem','Gru','GSC'/ DATA STD11/ 1'Her','Hor','Hya','Hyd','Hyi','Ind','Iota','Kappa','Lac', 2'Lambda','Leo','Lep','Lib','LMi','Lup','Lyn','Lyr','maj', 3'Men','Mic','min','Mon','Mu ','Mus','Nor','Nu ','Oct', 4'Omega','Omicron','Oph','Ori','Pav','Peg','Per','Phe','Phi'/ DATA STD12/ 5'Pi ','Pic','pis','PsA','Psc','Psi','Pup','Pyx','Ret', 6'Rho','sag','Scl','Sco','Sct','scu','Ser','Sex','Sge', 7'Sgr','Sigma','Tau','Tel','Theta','TrA','Tri','Tuc','UMa', 8'UMi','Upsilon','urs','Vel','ven','Vir','Vol','Vul','Xi ','Zeta'/ C C The type numbers here correspond to the keys above. C C Key codes: C C 1 = Greek letter C 2 = Constellation name C 3 = AGK, Grw, other zone cats. C 4 = BD (or CD) C 5 = BD+ or BD- C 6 = CoD or COD C 7 = BS C 8 = BS1 to BS9... C 9 = Aust. C 10 = Borealis C 11 = CPD C 12 = Tau (unresolved on 1st pass). C 13 = NGC, IC, ... (composite objects) C 14 = Nova C 15 = ordinary catalogs C 16 = LS C 17 = PK C 18 = C 19 = C 20 = C 21 = AQU 26 = HYD 31 = TAU C 22 = CAN 27 = LEO 32 = TRI C 23 = COR 28 = PIS 33 = URS C 24 = CRA 29 = SAG 34 = C 25 = DEL 30 = SCU C C 35 = MAJ C 36 = MIN C 37 = BER C 38 = VEN C DATA NT1/ C C '1U ','2U ','3C ','3U ','4U ','ADS','AGK','ALP','AND', C 'ANT','APS','APU','AQL','AQR','AQU','ARA','ARI','AUR', 115,15,15,15,15,15, 3, 1, 2, 2, 2, 2, 2, 2,21, 2, 2, 2, C C 'AUS','Alp','And','Ant','Aps','Apu','Aql','Aqr','Aqu', C 'Ara','Ari','Aur','Aus','BD ','BD+','BD-','BER','BET', 2 9, 1, 2, 2, 2, 2, 2, 2,21, 2, 2, 2, 9, 4, 5, 5,37, 1, C C 'BOO','BOR','BS ','BS1','BS2','BS3','BS4','BS5','BS6', C 'BS7','BS8','BS9','BSD','Ber','Bet','Boo','Bor','CAE', 3 2,10, 7, 8, 8, 8, 8, 8, 8, 8, 8, 8, 2,37, 1, 2,10, 2, C C 'CAM','CAN','CAP','CAR','CAS','CD ','CD+','CD-','CEN', C 'CEP','CET','CHA','CHI','CIR','CMA','CMI','CMa','CMi'/ 4 2,22, 2, 2, 2, 4, 5, 5, 2, 2, 2, 2, 1, 2, 2, 2, 2, 2, C C 'CNC','COD','COL','COM','COR','CPD','CRA','CRB','CRT', C 'CRU','CRV','CVN','CVn','CYG','Cae','Cam','Can','Cap', 5 2, 6, 2, 2,23,11,24, 2, 2, 2, 2, 2, 2, 2, 2, 2,22, 2, C C 'Car','Cas','Cen','Cep','Cet','Cha','Chi','Cir','Cnc', C 'CoD','Col','Com','Cor','CrA','CrB','Crt','Cru','Crv', 6 2, 2, 2, 2, 2, 2, 1, 2, 2, 6, 2, 2,23, 2, 2, 2, 2, 2, C C 'Cyg','DEL','DOR','DRA','Del','Dor','Dra','EPS','EQU', C 'ERI','ETA','Eps','Equ','Eri','Eta','FEI','FK5','FOR', 7 2,25, 2, 2,25, 2, 2, 1, 2, 2, 1, 1, 2, 2, 1, 2, 2, 2, C C 'For','GAM','GC ','GEM','GRU','GSC','Gam','Gem','Grb', C 'Gro','Gru','Grw','HD ','HDE','HER','HOR','HR ','HYA'/ 8 2, 1, 2, 2, 2, 2, 1, 2,15,15, 2, 3,15,15, 2, 2,15, 2/ C DATA NT2/ C C 'HYD','HYI','Her','Hor','Hya','Hyd','Hyi','IC ','IND', C 'IOT','IRC','Ind','Iot','KAP','Kap','LAC','LAM','LEO', 126, 2, 2, 2, 2,26, 2,13, 2, 1,15, 2, 1, 1, 1, 2, 1,27, C C 'LEP','LIB','LMC','LMI','LMi','LS ','LUP','LYN','LYR', C 'Lac','Lal','Lam','Leo','Lep','Lib','LkH','Lup','Lyn', 2 2, 2,13, 2, 2,16, 2, 2, 2, 2, 2, 1,27, 2, 2,15, 2, 2, C C 'Lyr','M ','MAJ','MEN','MIC','MIN','MON','MU ','MUS', C 'Maj','Mel','Men','Mic','Min','Mon','Mu ','Mus','N ', 3 2,13,35, 2, 2,36, 2, 1, 2,35, 2, 2, 2,36, 2, 1, 2,14, C C 'NGC','NLT','NOR','NOV','NU ','Nor','Nov','Nu ','OCT', C 'OME','OMI','OPH','ORI','Oct','Ome','Omi','Oph','Ori'/ 413,15, 2,14, 1, 2,14, 1, 2, 1, 1, 2, 2, 2, 1, 1, 2, 2, C C 'PAL','PAV','PEG','PER','PHE','PHI','PI ','PIC','PIS', C 'PK ','PPM','PSA','PSC','PSI','PUP','PYX','Pal','Pav', 513, 2, 2, 2, 2, 1, 1, 2,28,17,15, 2, 2, 1, 2, 2,13, 2, C C 'Peg','Per','Phe','Phi','Pi ','Pic','Pis','PsA','Psc', C 'Psi','Pup','Pyx','QSO','RET','RHO','Ret','Rho','SAG', 6 2, 2, 2, 1, 1, 2,28, 2, 2, 1, 2, 2,15, 2, 1, 2, 1,29, C C 'SAO','SCL','SCO','SCT','SCU','SER','SEX','SGE','SGR', C 'SIG','SMC','SN ','Sag','Scl','Sco','Sct','Scu','Ser', 715, 2, 2, 2,30, 2, 2, 2, 2, 1,13,15,29, 2, 2, 2,30, 2, C C 'Sex','Sge','Sgr','Sig','TAU','TEL','THE','TRA','TRI', C 'TUC','Tau','Tel','The','TrA','Tri','Tuc','UGC','UMA'/ 8 2, 2, 2, 1,31, 2, 1, 2,32, 2,31, 2, 1, 2,32, 2,13, 2/ C DATA NT3/ C C 'UMI','UMa','UMi','UPS','URS','Ups','Urs','VEL','VEN', C 'VIR', C 'VOL','VUL','Vel','Ven','Vir','Vol','Vul','XI ','Xi ','ZET', 1 2, 2, 2, 1,33, 1,33, 2,38, 2, 2, 2, 2,38, 2, 2, 2, 1, 1, 1, C C 'Zet','alp','and','ant','aps','apu','aql','aqr','aqu', C 'ara','ari','aur','aus','ber','bet','boo','bor','cae', 2 1, 1, 2, 2, 2, 2, 2, 2,21, 2, 2, 2, 9,37, 1, 2,10, 2, C C 'cam','can','cap','car','cas','cen','cep','cet','cha', C 'chi','cir','cma','cmi','cnc','col','com','cor','cra', 3 2,22, 2, 2, 2, 2, 2, 2, 2, 1, 2, 2, 2, 2, 2, 2,23,24, C C 'crb','crt','cru','crv','cvn','cyg','del','dor','dra', C 'eps','equ','eri','eta','for','gam','gem','gru','gsc'/ 4 2, 2, 2, 2, 2, 2,25, 2, 2, 1, 2, 2, 1, 2, 1, 2, 2, 2, C C 'her','hor','hya','hyd','hyi','ind','iot','kap','lac', C 'lam','leo','lep','lib','lmi','lup','lyn','lyr','maj', 5 2, 2, 2,26, 2, 2, 1, 1, 2, 1,27, 2, 2, 2, 2, 2, 2,35, C C 'men','mic','min','mon','mu ','mus','nor','nu ','oct', C 'ome','omi','oph','ori','pav','peg','per','phe','phi', 6 2, 2,36, 2, 1, 2, 2, 1, 2, 1, 1, 2, 2, 2, 2, 2, 2, 1, C C 'pi ','pic','pis','psa','psc','psi','pup','pyx','ret', C 'rho','sag','scl','sco','sct','scu','ser','sex','sge', 7 1, 2,28, 2, 2, 1, 2, 2, 2, 1,29, 2, 2, 2,30, 2, 2, 2, C C 'sgr','sig','tau','tel','the','tra','tri','tuc','uma', C 'umi','ups','urs','vel','ven','vir','vol','vul','xi ','zet'/ 8 2, 1,31, 2, 1, 2,32, 2, 2, 2, 1,33, 2,38, 2, 2, 2, 1, 1/ C DATA TOKEN/12*' '/ C C ****************** BEGIN EXECUTION ****************** C M=6*24 NWORDS=3*M+3 NITEM=0 C C initialize array NTYPES C DO 99123, N=1,M NTYPES(N) = NT1(N) NTYPES(N+M) = NT2(N) NTYPES(N+M+M) = NT3(N) 99123 CONTINUE NTYPES(NWORDS-2) = NT3(M+1) NTYPES(NWORDS-1) = NT3(M+2) NTYPES(NWORDS) = NT3(M+3) C C the loop above replaces the original EQUIVALENCE statements: C EQUIVALENCE (NTYPES,NT1),(NTYPES(6*24+1),NT2) C EQUIVALENCE (NTYPES(2*6*24+1),NT3) C which gave problems with the Fortran compiler of VAX/VMS C K. Banse 980310 C C Tokenize name: C 2 NEXT=INDEX(C32,' ') C IF (NEXT.EQ.1) THEN C skip leading blanks. DO 12 NEXT=2,32 IF(C32(NEXT:NEXT).NE.' ')GO TO 13 12 CONTINUE C name was blank. NEXT=32 13 CONTINUE NBGN(1)=NEXT NEND(1)=INDEX(C32(NBGN(1):),' ')+NEXT-2 IF (NEND(1).EQ.NEXT-2) NEND(1)=32 LEN(1)=NEND(1)-NBGN(1)+1 ELSE C usual case. NBGN(1)=1 NEND(1)=NEXT-1 LEN(1)=NEND(1) END IF C C CALL TV('Tokens are:') NAME=C32(NBGN(1):NEND(1)) N=NBIN(NAME(:3),WORD,NWORDS) C IF (N.GT.0) THEN NTYPE(1)=NTYPES(N) C set len(ntok) to length of std.string if ntype < 3: IF (NTYPE(1).LT.3) THEN DO 14 K=7,1,-1 IF (STDWD(N)(K:K).NE.' ') GO TO 15 14 CONTINUE 15 CONTINUE LEN(1)=K TOKEN(1)(:LEN(1))=STDWD(N) ELSE LEN(1)=NEND(1)-NBGN(1)+1 TOKEN(1)(:LEN(1))=C32(NBGN(1):NEND(1)) END IF C PRINT*,'Found ',WORD(N), NTYPES(N),' ',TOKEN(1) ELSE NTYPE(1)=0 LEN(1)=NEND(1)-NBGN(1)+1 TOKEN(1)(:LEN(1))=C32(NBGN(1):NEND(1)) C PRINT*,NAME//': Not in list.' END IF C CALL TVN(TOKEN(1)) C DO 20 NTOK=2,12 C look for next token: DO 16 K=NEND(NTOK-1)+2,32 IF (C32(K:K).NE.' ') THEN NBGN(NTOK)=K GO TO 17 END IF 16 CONTINUE NTOKENS=NTOK-1 GO TO 21 C 17 CONTINUE NEND(NTOK)=INDEX(C32(NBGN(NTOK):),' ') IF (NEND(NTOK).EQ.0) NEND(NTOK)=34-NBGN(NTOK) NEND(NTOK)=NEND(NTOK)+NBGN(NTOK)-2 LEN(NTOK)=NEND(NTOK)-NBGN(NTOK)+1 C C PRINT*,'Token ',NTOK,' is "',C32(NBGN(NTOK):NEND(NTOK))//'"' C N=NBIN(C32(NBGN(NTOK):NBGN(NTOK)+2),WORD,NWORDS) IF (N.GT.0) THEN C listed keyword. NTYPE(NTOK)=NTYPES(N) IF (NTYPE(NTOK).LT.3) THEN C Greek letter or constellation. DO 18 K=7,1,-1 IF (STDWD(N)(K:K).NE.' ') GO TO 19 18 CONTINUE 19 CONTINUE LEN(NTOK)=K TOKEN(NTOK)(:LEN(NTOK))=STDWD(N) ELSE C Constellation or catalog. TOKEN(NTOK)(:LEN(NTOK))=C32(NBGN(NTOK):NEND(NTOK)) END IF C PRINT*,'Found ',WORD(N), NTYPES(N),' ',STDWD(N) ELSE C not a listed keyword. NTYPE(NTOK)=0 TOKEN(NTOK)(:LEN(NTOK))=C32(NBGN(NTOK):NEND(NTOK)) C PRINT*,C32(NBGN(NTOK):NEND(NTOK))//': Not in list.' END IF C C CALL TVN(TOKEN(NTOK)) 20 CONTINUE C C End of reading loop. C 21 CONTINUE C C Start of fixup loop. C DO 60 NTOK=1,NTOKENS C Fix up ambiguous names. JUMP=NTYPE(NTOK)-20 GO TO (31,32,33,34,35,36,37,38,39,40,41,42,43),JUMP C GO TO 60 C C AQU: Aquarius or Aquila? 31 CONTINUE IF (TOKEN(NTOK)(5:5).EQ.'r' .OR. TOKEN(NTOK)(5:5).EQ.'R')THEN TOKEN(NTOK)(:3)='Aqr' GO TO 50 ELSE IF (TOKEN(NTOK)(5:5).EQ.'l' .OR. TOKEN(NTOK)(5:5).EQ.'L')THEN TOKEN(NTOK)(:3)='Aql' GO TO 50 END IF GO TO 60 C C CAN: Cancer or Canis M. or Canes Ven.? 32 CONTINUE IF (TOKEN(NTOK)(4:4).EQ.'i' .OR. TOKEN(NTOK)(4:4).EQ.'I') THEN C Canis. IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.35) THEN TOKEN(NTOK)(:3)='CMa' GO TO 45 ELSE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.36) THEN TOKEN(NTOK)(:3)='CMi' GO TO 45 END IF ELSE IF (TOKEN(NTOK)(4:4).EQ.'e' .OR. TOKEN(NTOK)(4:4).EQ.'E' .OR. 1 TOKEN(NTOK)(4:4).EQ.'u' .OR. TOKEN(NTOK)(4:4).EQ.'U' .OR. 2 TOKEN(NTOK)(4:4).EQ.'.' .OR. LEN(NTOK).EQ.3) THEN C Canes or Canum. IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.38) THEN TOKEN(NTOK)(:3)='CVn' GO TO 45 END IF ELSE IF (TOKEN(NTOK)(4:4).EQ.'c' .OR. TOKEN(NTOK)(4:4).EQ.'C')THEN C Cacer or Cancri. TOKEN(NTOK)(:3)='Cnc' GO TO 50 END IF GO TO 60 C C COR: Corona or Corvus? 33 CONTINUE IF (TOKEN(NTOK)(4:4).EQ.'o' .OR. TOKEN(NTOK)(4:4).EQ.'O' .OR. 1 TOKEN(NTOK)(4:4).EQ.'.' .OR. LEN(NTOK).EQ.3) THEN C Corona. IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.9) THEN TOKEN(NTOK)(:3)='CrA' GO TO 45 ELSE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.10) THEN TOKEN(NTOK)(:3)='CrB' GO TO 45 END IF ELSE IF (TOKEN(NTOK)(4:4).EQ.'v' .OR. TOKEN(NTOK)(4:4).EQ.'V')THEN TOKEN(NTOK)(:3)='Crv' GO TO 50 END IF GO TO 60 C C CRA: Crater or CrA? 34 CONTINUE IF (LEN(NTOK).EQ.3) THEN C CrA. TOKEN(NTOK)(:3)='CrA' GO TO 50 ELSE IF (TOKEN(NTOK)(4:4).EQ.'t' .OR. TOKEN(NTOK)(4:4).EQ.'T')THEN TOKEN(NTOK)(:3)='Crt' GO TO 50 END IF GO TO 60 C C DEL: Delta or Delphinus? 35 CONTINUE IF (TOKEN(NTOK)(4:4).EQ.'t' .OR. TOKEN(NTOK)(4:4).EQ.'T')THEN TOKEN(NTOK)(:5)='Delta' LEN(NTOK)=5 NTYPE(NTOK)=1 GO TO 60 ELSE IF (TOKEN(NTOK)(4:4).EQ.'p' .OR. TOKEN(NTOK)(4:4).EQ.'P' .OR. 1 NTOK.EQ.NTOKENS .OR. 2 (NTOKENS.GT.NTOK .AND. TOKEN(NTOK+1)(:1).EQ.'=') .OR. 3 (NTOK.GT.1 .AND. NTYPE(NTOK-1).EQ.1) )THEN TOKEN(NTOK)(:3)='Del' GO TO 50 END IF GO TO 60 C C HYD: Hydrus or Hydra? 36 CONTINUE IF (TOKEN(NTOK)(5:5).EQ.'a' .OR. TOKEN(NTOK)(5:5).EQ.'A')THEN TOKEN(NTOK)(:3)='Hya' GO TO 50 ELSE IF (TOKEN(NTOK)(5:5).EQ.'i' .OR. TOKEN(NTOK)(5:5).EQ.'I' .OR. 1 TOKEN(NTOK)(5:5).EQ.'u' .OR. TOKEN(NTOK)(5:5).EQ.'U')THEN TOKEN(NTOK)(:3)='Hyi' GO TO 50 END IF GO TO 60 C C LEO: or Leo Minor? 37 CONTINUE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.36) THEN TOKEN(NTOK)(:3)='LMi' GO TO 45 ELSE IF (LEN(NTOK).EQ.3 .OR. LEN(NTOK).EQ.6) THEN TOKEN(NTOK)(:3)='Leo' GO TO 50 END IF GO TO 60 C C PIS: Pisces or PsA? 38 CONTINUE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.9) THEN C Austrinus. TOKEN(NTOK)(:3)='PsA' GO TO 45 ELSE IF (TOKEN(NTOK)(5:5).EQ.'i' .OR. TOKEN(NTOK)(5:5).EQ.'I' .OR. 1 TOKEN(NTOK)(5:5).EQ.'e' .OR. TOKEN(NTOK)(5:5).EQ.'E')THEN C Pisces or Piscium. TOKEN(NTOK)(:3)='Psc' GO TO 50 END IF GO TO 60 C C SAG: Sagitta or Sagittarius? 39 CONTINUE IF (LEN(NTOK).EQ.8 .OR. LEN(NTOK).EQ.7) THEN C Sagittae or Sagitta. TOKEN(NTOK)(:3)='Sge' GO TO 50 ELSE IF (LEN(NTOK).EQ.10 .OR. LEN(NTOK).EQ.11) THEN C Sagittarii or Sagittarius. TOKEN(NTOK)(:3)='Sgr' GO TO 50 END IF GO TO 60 C C SCU: Sculptor or Scutum? 40 CONTINUE IF (TOKEN(NTOK)(4:4).EQ.'l' .OR. TOKEN(NTOK)(4:4).EQ.'L')THEN TOKEN(NTOK)(:3)='Scl' GO TO 50 ELSE IF (TOKEN(NTOK)(4:4).EQ.'t' .OR. TOKEN(NTOK)(4:4).EQ.'T')THEN TOKEN(NTOK)(:3)='Sct' GO TO 50 END IF GO TO 60 C C TAU: Tau or Taurus? 41 CONTINUE IF (LEN(NTOK).EQ.3)THEN C "Tau" input. IF (NTOK.EQ.NTOKENS .OR. 1 NTOKENS.GT.NTOK .AND. TOKEN(NTOK+1)(:1).EQ.'=') THEN C Probably constellation name. NTYPE(NTOK)=2 ELSE C Wait till later to resolve ntype. NTYPE(NTOK)=12 END IF TOKEN(NTOK)(:3)='Tau' LEN(NTOK)=3 GO TO 60 ELSE IF (TOKEN(NTOK)(4:4).EQ.'r' .OR. TOKEN(NTOK)(4:4).EQ.'R')THEN C Tauri or Taurus. IF (LEN(NTOK).EQ.5) THEN TOKEN(NTOK)(:5)='Tauri' ELSE IF (LEN(NTOK).EQ.6) THEN TOKEN(NTOK)(:6)='Taurus' END IF GO TO 50 END IF GO TO 60 C C TRI: Triangulum or TrA? 42 CONTINUE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.9) THEN TOKEN(NTOK)(:3)='TrA' GO TO 45 ELSE IF (LEN(NTOK).EQ.3 .OR.LEN(NTOK).EQ.9.OR.LEN(NTOK).EQ.10)THEN TOKEN(NTOK)(:3)='Tri' GO TO 50 END IF GO TO 60 C C URS: Ursa Major or Minor? 43 CONTINUE IF (TOKEN(NTOK)(4:4).EQ.'a' .OR. TOKEN(NTOK)(4:4).EQ.'A') THEN IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.35) THEN TOKEN(NTOK)(:3)='UMa' GO TO 45 ELSE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.36) THEN TOKEN(NTOK)(:3)='UMi' GO TO 45 END IF END IF GO TO 60 C C 45 CONTINUE C Remove ntok+1st item from list: DO 46 K=NTOK+1,NTOKENS-1 TOKEN(K)=TOKEN(K+1) LEN(K)=LEN(K+1) NTYPE(K)=NTYPE(K+1) NBGN(K)=NBGN(K+1) NEND(K)=NEND(K+1) 46 CONTINUE TOKEN(NTOKENS)='=' LEN(NTOKENS)=1 NTYPE(NTOKENS)=0 C 50 CONTINUE C set to constellation. LEN(NTOK)=3 NTYPE(NTOK)=2 C 60 CONTINUE C IF (TOKEN(NTOKENS).EQ.'=') NTOKENS=NTOKENS-1 C C Now assemble pieces, and decide if a synonym exists: C NTOK=1 LAST=1 70 GO TO (100, 200, 300, 400, 500, 600, 700, 800, 900, 1000, C Greek Cons AGK BD BD+ CoD BS BSn Aus Bor C 1 1100,1200,1300,1400,1500,1600,1700),NTYPE(NTOK) C CPD TAU NGC Nova cat LS PK C C C Falls through to here for "other". C IF (NTOKENS.EQ.NTOK .OR. TOKEN(NTOK+1)(:1).EQ.'=') THEN IF (LEN(NTOK).GT.2)THEN C one-word name; we are done. GO TO 2100 ELSE C could be 1- or 2-letter component suffix to previous name. IF (TOKEN(NTOK)(:1).GE.'A' .AND. NITEM.GT.0 .AND. 1 TOKEN(NTOK-1)(:1).NE.'=' .AND. 2 NBGN(NTOK).EQ.NEND(NTOK-1)+2 .AND. 3 (TOKEN(NTOK)(LEN(NTOK):LEN(NTOK)).LE.'G' .OR. 4 (TOKEN(NTOK)(LEN(NTOK):LEN(NTOK)).GE.'a' .AND. 5 TOKEN(NTOK)(LEN(NTOK):LEN(NTOK)).LE.'g') ) ) THEN C add to previous name. GO TO 2600 ELSE C not a suffix, so DON'T convert to caps. GO TO 2150 END IF END IF C C - - - - - from here on, more tokens may belong to name - - - - - C ELSE IF (TOKEN(NTOK)(:1).LE.'9') THEN C name begins with NUMBER. IF (LEN(NTOK).LT.4 .AND. 1 TOKEN(NTOK)(LEN(NTOK):LEN(NTOK)).LE.'9') THEN C could be Flamsteed number. IF (NTYPE(NTOK+1).EQ.2) THEN C followed by constl., so accept as Flamsteed. GO TO 2200 ELSE IF (NTOKENS.GT.NTOK+1 .AND. NTYPE(NTOK+2).EQ.2) THEN IF ( (LEN(NTOK+1).EQ.1 .AND. 1 TOKEN(NTOK+1)(:1).GE.'A') .OR. C might be "44 i Boo" form. 2 NTYPE(NTOK+1).EQ.1 .OR. NTYPE(NTOK+1).EQ.12) THEN C might be "54 alpha Peg" form. C save Flamsteed pair... NITEM=NITEM+1 STAR5(NITEM)=TOKEN(NTOK)(:LEN(NTOK))// 1 TOKEN(NTOK+2) C then save letter pair. NTOK=NTOK+1 GO TO 2500 END IF ELSE IF (NTOKENS.GT.NTOK+2 .AND. NTYPE(NTOK+3).EQ.2) THEN IF (LEN(NTOK+2).EQ.1 .AND. 1 NTYPE(NTOK+1).EQ.1) THEN C might be "78 Theta 3 Tauri" form. C save Flamsteed pair... NITEM=NITEM+1 STAR5(NITEM)=TOKEN(NTOK)(:LEN(NTOK))// 1 TOKEN(NTOK+3) C then save letter pair. NTOK=NTOK+1 GO TO 2300 END IF END IF ELSE IF (LEN(NTOK).LE.5 .AND. NTYPE(NTOK+1).EQ.2 .AND. 1 TOKEN(NTOK)(LEN(NTOK):LEN(NTOK)).GE.'A' .AND. 2 TOKEN(NTOK)(LEN(NTOK)-1:LEN(NTOK)-1).LE.'9' .AND. 3 NTOKENS.GT.NTOK) THEN C looks like "44i Boo". NITEM=NITEM+1 STAR5(NITEM)=TOKEN(NTOK)(:LEN(NTOK)-1)//TOKEN(NTOK+1) STDNAM=TOKEN(NTOK)(LEN(NTOK):LEN(NTOK))// 1 '_'//TOKEN(NTOK+1) LAST=NTOK+1 GO TO 3000 ELSE C could be like 3C273... DO 77 K=1,LEN(NTOK)-1 IF (TOKEN(NTOK)(K:K).GT.'9') GO TO 78 77 CONTINUE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).GT.0) GO TO 2100 NERR=77 GO TO 9000 78 CONTINUE C string contains non-numeric char; assume 1-word name. GO TO 2100 END IF C ELSE IF (TOKEN(NTOK).GE.'A') THEN C name begins with LETTER. M=LEN(NTOK) IF (TOKEN(NTOK)(M:M).LE.'9' .AND. NTOKENS.GT.NTOK .AND. C this token begins with letter, ends with digit. 1 (NTYPE(NTOK+1).GT.0 C next token is recognized. 2 .OR. 3 (TOKEN(NTOK+1)(:1).GE.'A' .AND. 4 TOKEN(NTOK+1)(LEN(NTOK+1):LEN(NTOK+1)).LE.'9') C next token looks like catalog&number. 5 .OR. 6 (NTOKENS.GT.NTOK+1 .AND. C next 2 tokens look like... 7 (NTYPE(NTOK+2).EQ.2 .OR. C ...something + constl. 8 (TOKEN(NTOK+1)(:1).GE.'A' .AND. 9 TOKEN(NTOK+2)(:1).LE.'9') ) ) C ...catalog + number. X ) ) THEN C next word looks like start of new name & this one ends in digit. IF (NTOKENS.GT.NTOK .AND. 1 NTYPE(NTOK+1).EQ.2 .AND. TOKEN(NTOK)(:1).EQ.'V')THEN C variable star number. GO TO 2200 ELSE GO TO 2100 END IF ELSE IF (TOKEN(NTOK)(M:M).LE.'9' .AND. 1 TOKEN(NTOK)(:1).EQ.'H' .AND. 2 (TOKEN(NTOK)(2:2).EQ.'D' .OR.TOKEN(NTOK)(2:2).EQ.'R') 3 .AND. TOKEN(NTOK)(3:3).GE.'1' .AND.TOKEN(NTOK)(3:3).LE.'9' 4 )THEN C HD or HR number concatenated. GO TO 2100 END IF C IF (LEN(NTOK).GT.5)THEN IF (TOKEN(NTOK)(M:M).GE.'A' .AND. C first word ends in letter, second begins w. number; 1 TOKEN(NTOK+1)(:1).LT.'A') THEN C probably a catalog name; reduce to cap + l.c.: IF(TOKEN(NTOK)(:1).GT.'Z') 1 TOKEN(NTOK)(:1)=CHAR(ICHAR(TOKEN(NTOK)(:1))-32) DO 80 K=2,M IF(TOKEN(NTOK)(K:K).GE.'A'.AND.TOKEN(NTOK)(K:K).LE.'Z') 1 TOKEN(NTOK)(K:K)=CHAR(ICHAR(TOKEN(NTOK)(K:K))+32) 80 CONTINUE GO TO 2200 ELSE IF (TOKEN(NTOK)(M:M).GE.'A' .AND. 1 NTYPE(NTOK+1).GT.0) THEN C probably a long single name. GO TO 2100 END IF ELSE IF (LEN(NTOK).LE.2) THEN C could be var.star OR unknown catalog OR suffix "A", "AB", etc. IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.2 .AND. 1 TOKEN(NTOK)(:1).LE.TOKEN(NTOK)(M:M) .AND. 2 TOKEN(NTOK)(M:M).LE.'Z') THEN IF (NTOKENS.GT.NTOK+1 .AND.TOKEN(NTOK)(:1).LT.'G'.AND. 1 TOKEN(NTOK+2)(:1).EQ.'X' .AND. NITEM.GT.0)THEN C suffix, not a variable; next field is X-ray source. GO TO 2600 ELSE C variable star. GO TO 2500 END IF ELSE IF (NTOKENS.GT.NTOK .AND. 1 NBGN(NTOK+1).EQ.NEND(NTOK)+2 .AND. 2 TOKEN(NTOK+1)(:1).GE.'0' .AND. 3 TOKEN(NTOK+1)(:1).LE.'9') THEN C unknown 1- or 2-letter catalog. GO TO 2200 ELSE IF (NITEM.GT.0 .AND. TOKEN(NTOK-1)(:1).NE.'=' .AND. 1 NBGN(NTOK).EQ.NEND(NTOK-1)+2 .AND. 2 (TOKEN(NTOK)(:1).LT.'G' .OR. 3 TOKEN(NTOK)(:1).GE.'a' .AND. TOKEN(NTOK)(:1).LT.'g') 4 .AND. 5 (TOKEN(NTOK)(M:M).LT.'G' .OR. 6 TOKEN(NTOK)(M:M).GE.'a'.AND.TOKEN(NTOK)(M:M).LT.'g') 7 ) THEN C suffix. GO TO 2600 ELSE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.2 .AND. 1 LEN(NTOK).EQ.1) THEN C something like P Cyg or i Boo. GO TO 2500 ELSE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).GT.0 .AND. 1 NITEM.GT.0) THEN C probably a suffix. GO TO 2600 ELSE C not a suffix, so DON'T convert to caps. GO TO 2150 END IF ELSE IF (NTOKENS.GT.NTOK+1 .AND. NTYPE(NTOK+2).EQ.0 .AND. 1 (TOKEN(NTOK+1)(:1).EQ.'+' .OR. TOKEN(NTOK+1)(:1).EQ.'-').AND. 2 TOKEN(NTOK+2)(:1).LE.'9') THEN C looks like a zone cat. GO TO 500 ELSE IF (NTOKENS.GT.NTOK .AND. TOKEN(NTOK+1)(:1).LE.'9'.AND. 1 TOKEN(NTOK)(M:M).LE.'Z') THEN C next token starts w.number; probably a catalog abbreviation. GO TO 2200 ELSE IF (NTYPE(NTOK+1).GT.0) THEN C probably a single name. GO TO 2100 END IF GO TO 1300 C ELSE IF (TOKEN(NTOK)(:1).EQ.'=')THEN NTOK=NTOK+1 LAST=NTOK GO TO 70 END IF NERR=99 GO TO 9000 C C Greek letter. 100 CONTINUE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.2) THEN C like "Alpha Cyg". GO TO 2500 ELSE IF(NTOKENS.GE.NTOK+2 .AND. NTYPE(NTOK+2).EQ.2 .AND. 1 LEN(NTOK+1).EQ.1 .AND. TOKEN(NTOK+1)(:1).LE.'9') THEN C like "Pi 5 Ori". GO TO 2300 ELSE NERR=160 GO TO 9000 END IF C NERR=180 C GO TO 9000 C C Constellation name first. 200 CONTINUE IF (NTOKENS.GT.NTOK+2 .AND. TOKEN(NTOK+1)(:1).EQ.'X') THEN C special for X-ray sources with other names: IF (NTYPE(NTOK+3).EQ.2 .AND. 1 (LEN(NTOK+2).LT.3 .OR. TOKEN(NTOK+2)(:1).EQ.'V')) THEN C probably followed by var.star name. GO TO 2200 ELSE IF (TOKEN(NTOK+2)(:1).GE.'A' .AND. 1 TOKEN(NTOK+3)(:1).LE.'9') THEN C probably followed by catalog + number. GO TO 2200 END IF ELSE IF (NTOKENS.GT.NTOK+1 .AND. TOKEN(NTOK+1)(:1).EQ.'X') THEN C special for X-ray sources with other names: IF (TOKEN(NTOK+2)(:1).GE.'A' .AND. 1 TOKEN(NTOK+2)(LEN(NTOK+2):LEN(NTOK+2)).LE.'9') THEN C probably followed by catalog + number. GO TO 2200 END IF END IF GO TO 1300 C C AGK, Grw, etc. 300 CONTINUE IF (TOKEN(NTOK+1)(:1).EQ.'+' .OR. TOKEN(NTOK+1)(:1).EQ.'-') THEN C zone in next field. GO TO 400 ELSE C zone appended. GO TO 500 END IF C C BD or CD 400 CONTINUE K=LEN(NTOK+1) M=LEN(NTOK+2) C normal format: BD +12 3456 IF (NTOKENS.GE.NTOK+2 .AND. LEN(NTOK+1).LE.3 .AND. 1 (TOKEN(NTOK+1)(:1).EQ.'+' .OR. TOKEN(NTOK+1)(:1).EQ.'-') .AND. 2 (TOKEN(NTOK+1)(K:K).GE.'0' .AND. TOKEN(NTOK+1)(K:K).LE.'9').AND. 3 (TOKEN(NTOK+2)(1:1).GE.'0' .AND. TOKEN(NTOK+2)(1:1).LE.'9') 4 ) THEN IF (LEN(NTOK+1).EQ.3 .AND. TOKEN(NTOK+1)(2:2).EQ.'0')THEN C trim leading zero from zone. TOKEN(NTOK+1)(2:2)=TOKEN(NTOK+1)(3:3) LEN(NTOK+1)=2 END IF GO TO 2400 C ELSE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.2) THEN C it is a variable-star name. GO TO 2500 ELSE NERR=480 GO TO 9000 END IF C C BD+ or BD- or CD+ or CD- 500 CONTINUE M=LEN(NTOK+2) C normal format: BD+12 3456 IF (NTOKENS.GE.NTOK+1 .AND. 1 TOKEN(NTOK)(LEN(NTOK):LEN(NTOK)).GE.'0' .AND. 2 TOKEN(NTOK)(LEN(NTOK):LEN(NTOK)).LE.'9' .AND. 3 TOKEN(NTOK+1)(:1).GE.'0' .AND. TOKEN(NTOK+1)(:1).LE.'9' 5 ) THEN IF (LEN(NTOK).EQ.5 .AND. TOKEN(NTOK)(4:4).EQ.'0')THEN C trim leading zero from zone. TOKEN(NTOK)(4:4)=TOKEN(NTOK)(5:5) LEN(NTOK)=4 END IF GO TO 2500 C C wierd format: BD+ 2 3456 ELSE IF (NTOKENS.GE.NTOK+2 .AND. LEN(NTOK+1).EQ.1 .AND. 1 (TOKEN(NTOK+1)(:1).GE.'0' .AND. TOKEN(NTOK+1)(:1).LE.'9').AND. 3 (TOKEN(NTOK+2)(1:1).GE.'0' .AND. TOKEN(NTOK+2)(1:1).LE.'9').AND. 4 (TOKEN(NTOK+2)(M:M).GE.'0' .AND. TOKEN(NTOK+2)(M:M).LE.'9') 5 ) THEN GO TO 2400 C ELSE C complain. NERR=580 GO TO 9000 END IF C C CoD or COD (always -) 600 CONTINUE IF (LEN(NTOK).EQ.3) THEN TOKEN(NTOK)(2:3)='D ' LEN(NTOK)=2 GO TO 400 ELSE IF (LEN(NTOK).GE.4 .AND. TOKEN(NTOK)(4:4).EQ.'-') THEN TOKEN(NTOK)(2:2)='D ' STR(3:LEN(NTOK))=TOKEN(NTOK)(4:) TOKEN(NTOK)(3:LEN(NTOK))=STR(3:LEN(NTOK)) LEN(NTOK)=LEN(NTOK)-1 GO TO 500 END IF GO TO 2200 C C BS 700 CONTINUE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).NE.2) THEN TOKEN(NTOK)(:2)='HR' GO TO 2200 ELSE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.2) THEN C var.star. GO TO 2500 ELSE GO TO 2100 END IF C C BS1 to BS9 800 CONTINUE TOKEN(NTOK)(:2)='HR' GO TO 2100 C C AUST... (used) 900 CONTINUE C C BOR... (used) 1000 CONTINUE C C CPD 1100 CONTINUE C format: CPD -12 3456 IF (LEN(NTOK).EQ.3) THEN GO TO 400 ELSE IF (TOKEN(NTOK)(4:4).EQ.'-') THEN K=LEN(NTOK+1) M=LEN(NTOK+2) C format: CPD-12 3456 IF (NTOKENS.GE.NTOK+1 .AND. LEN(NTOK+1).LE.4 .AND. 1 TOKEN(NTOK)(LEN(NTOK):LEN(NTOK)).GE.'0' .AND. 2 TOKEN(NTOK)(LEN(NTOK):LEN(NTOK)).LE.'9' .AND. 3 TOKEN(NTOK+1)(:1).GE.'0' .AND. TOKEN(NTOK+1)(:1).LE.'9' .AND. 4 TOKEN(NTOK+1)(K:K).GE.'0' .AND. TOKEN(NTOK+1)(K:K).LE.'9' 5 ) THEN IF (LEN(NTOK).EQ.6 .AND. TOKEN(NTOK)(5:5).EQ.'0')THEN C trim leading zero from zone. TOKEN(NTOK)(5:5)=TOKEN(NTOK)(6:6) LEN(NTOK)=5 END IF GO TO 2500 C C wierd format: CPD+ 2 3456 ELSE IF (NTOKENS.GE.NTOK+2 .AND. LEN(NTOK+1).EQ.1 .AND. 1 (TOKEN(NTOK+1)(:1).GE.'0' .AND. TOKEN(NTOK+1)(:1).LE.'9').AND. 3 (TOKEN(NTOK+2)(1:1).GE.'0' .AND. TOKEN(NTOK+2)(1:1).LE.'9').AND. 4 (TOKEN(NTOK+2)(M:M).GE.'0' .AND. TOKEN(NTOK+2)(M:M).LE.'9') 5 ) THEN GO TO 2400 C ELSE C complain. NERR=1180 GO TO 9000 END IF C ELSE NERR=1190 GO TO 9000 END IF C C TAU (TAU or Taurus?) 1200 CONTINUE IF (LEN(NTOK).EQ.3 .AND. NTYPE(NTOK+1).EQ.2) THEN C definitely Greek Tau, followed by constellation. GO TO 2500 ELSE IF (LEN(NTOK).EQ.6 .AND. NTYPE(NTOK+1).NE.2) THEN C definitely Taurus. GO TO 2300 ELSE IF (LEN(NTOK).EQ.3 .AND. NTYPE(NTOK+1).EQ.12) THEN C Tau Tauri. GO TO 2500 ELSE NERR=1290 GO TO 9000 END IF C C NGC, IC, Pal, UGC, M, LMC, SMC -- likely to have other stuff after it. 1300 CONTINUE KOL=1 NEW=0 DO 1310 K=NTOK,NTOKENS IF (TOKEN(K)(:1).EQ.'=' .OR. 1 K.GT.NTOK .AND. NTYPE(K).GT.0) THEN LAST=K-1 GO TO 1311 ELSE NEW=NEW+LEN(K) STDNAM(KOL:NEW)=TOKEN(K)(:LEN(K)) KOL=NEW+1 END IF 1310 CONTINUE LAST=NTOKENS 1311 CONTINUE STDNAM(NEW+1:)=' ' GO TO 3000 C C Nova 1400 CONTINUE IF (NTOKENS.GT.NTOK+1 .AND. NTYPE(NTOK+1).EQ.2 .AND. 1 TOKEN(NTOK+2)(:1).GE.'1' .AND. 2 TOKEN(NTOK+2)(:1).LE.'9') THEN C Nova constl year STDNAM=TOKEN(NTOK)(:LEN(NTOK))//'_'// 1 TOKEN(NTOK+1)(:LEN(NTOK+1))//'_'// 2 TOKEN(NTOK+2)(:LEN(NTOK+2)) LAST=NTOK+2 C ELSE IF (NTOKENS.GT.NTOK .AND. NTYPE(NTOK+1).EQ.2) THEN C Nova constl STDNAM=TOKEN(NTOK)(:LEN(NTOK))//'_'// 1 TOKEN(NTOK+1)(:LEN(NTOK+1)) LAST=NTOK+1 C ELSE IF (NTOKENS.EQ.NTOK .OR. TOKEN(NTOK+1).EQ.'=') THEN GO TO 2100 ELSE NERR=1490 GO TO 9000 END IF GO TO 3000 C C common catalog if followed by number. 1500 CONTINUE IF (NTOKENS.GT.NTOK .AND. TOKEN(NTOK+1)(:1).LE.'9' .AND. 1 ( TOKEN(NTOK+1)(LEN(NTOK+1):LEN(NTOK+1)).LE.'9' .OR. 2 (TOKEN(NTOK+1)(LEN(NTOK+1):LEN(NTOK+1)).GE.'A' .AND. 3 TOKEN(NTOK+1)(LEN(NTOK+1):LEN(NTOK+1)).LE.'D') ) ) THEN C next token numeric, maybe with A-D; assume it is catalog number. GO TO 2200 ELSE IF ( (LEN(NTOK).GT.3 .AND. 1 TOKEN(NTOK)(LEN(NTOK):LEN(NTOK)).LE.'9') .OR. 2 (NTOKENS.GT.NTOK .AND. 3 TOKEN(NTOK+1)(:1).GE.'A') 4 ) THEN C cat.number appears to be concatenated. GO TO 2100 END IF C missing cat.number. NERR=1590 GO TO 9000 C C LS II+42 123 (could be Var.star) 1600 CONTINUE IF (NTOKENS.GT.NTOK+1 .AND. TOKEN(NTOK+1)(:1).EQ.'I') THEN IF ((TOKEN(NTOK+2)(:1).GE.'1') .AND. 1 TOKEN(NTOK+2)(:1).LE.'9') THEN C 3 tokens. STDNAM=TOKEN(NTOK)(:LEN(NTOK))//'_'// 1 TOKEN(NTOK+1)(:LEN(NTOK+1))//'_'// 2 TOKEN(NTOK+2)(:LEN(NTOK+2)) LAST=NTOK+2 GO TO 3000 C ELSE IF (NTOKENS.GT.NTOK+2 .AND. 1 (TOKEN(NTOK+2)(:1).EQ.'+' .OR. 1 TOKEN(NTOK+2)(:1).EQ.'-') .AND. 3 TOKEN(NTOK+3)(:1).LE.'9') THEN C 4 tokens. STDNAM=TOKEN(NTOK)(:LEN(NTOK))//'_'// 1 TOKEN(NTOK+1)(:LEN(NTOK+1))// 2 TOKEN(NTOK+2)(:LEN(NTOK+2))//'_'// 3 TOKEN(NTOK+3)(:LEN(NTOK+3)) LAST=NTOK+3 GO TO 3000 C ELSE IF (NTYPE(NTOK+1).EQ.2) THEN C var.star. GO TO 2500 ELSE NERR=1680 GO TO 9000 END IF C ELSE IF (NTYPE(NTOK+1).EQ.2) THEN C var.star. GO TO 2500 END IF NERR=1690 GO TO 9000 C C PK LLL+BB 123 1700 CONTINUE IF (NTOKENS.GT.NTOK+1 .AND. 1 TOKEN(NTOK+1)(:1).LE.'9' .AND. 2 TOKEN(NTOK+1)(LEN(NTOK):LEN(NTOK)).LE.'9' .AND. 3 TOKEN(NTOK+2)(:1).LE.'9' .AND. 4 TOKEN(NTOK+2)(LEN(NTOK):LEN(NTOK)).LE.'9') THEN GO TO 2400 END IF GO TO 3000 C C 1-word name. C 2100 CONTINUE C convert to caps. DO 2120 K=1,LEN(NTOK) IF(TOKEN(NTOK)(K:K).GT.'Z') 1 TOKEN(NTOK)(K:K)=CHAR(ICHAR(TOKEN(NTOK)(K:K))-32) C 32 is ascii offset from A to a. 2120 CONTINUE C 2150 CONTINUE STDNAM=TOKEN(NTOK) LAST=NTOK GO TO 3000 C C combine 2 words. C 2200 CONTINUE STDNAM=TOKEN(NTOK)(:LEN(NTOK))//TOKEN(NTOK+1) LAST=NTOK+1 GO TO 3000 C C combine 3 words. C 2300 CONTINUE STDNAM=TOKEN(NTOK)(:LEN(NTOK))//TOKEN(NTOK+1)(:LEN(NTOK+1)) 1 //TOKEN(NTOK+2) LAST=NTOK+2 GO TO 3000 C C combine 3 words with "_" between last 2. C 2400 CONTINUE STDNAM=TOKEN(NTOK)(:LEN(NTOK))//TOKEN(NTOK+1)(:LEN(NTOK+1)) 1 //'_'//TOKEN(NTOK+2) LAST=NTOK+2 GO TO 3000 C C combine 2 words with "_" between them. C 2500 CONTINUE STDNAM=TOKEN(NTOK)(:LEN(NTOK))//'_'//TOKEN(NTOK+1) LAST=NTOK+1 GO TO 3000 C C add to end of previous name. C 2600 CONTINUE C stdnam contains no embedded blanks, so find end by binary search. IF (STDNAM(16:16).NE.' ') THEN LAST=5 ELSE LAST=0 END IF IF (STDNAM(LAST+8:LAST+8).NE.' ') LAST=LAST+8 IF (STDNAM(LAST+4:LAST+4).NE.' ') LAST=LAST+4 IF (STDNAM(LAST+2:LAST+2).NE.' ') LAST=LAST+2 IF (STDNAM(LAST+1:LAST+1).NE.' ') LAST=LAST+1 C last is now the last non=blank char. IF (STDNAM(LAST:LAST).GE.'A') THEN STDNAM(LAST+1:)='_'//TOKEN(NTOK) ELSE STDNAM(LAST+1:)=TOKEN(NTOK) END IF LAST=NTOK NITEM=NITEM-1 GO TO 3000 C C Done with name. C 3000 CONTINUE NITEM=NITEM+1 STAR5(NITEM)=STDNAM C C Uncomment for debugging: C PRINT* C PRINT*,'Std.name is '//STDNAM C PRINT*,(TOKEN(K)(:LEN(K)),K=1,NTOKENS) C PRINT*,(NTYPE(K),K=1,NTOKENS) C IF (LAST .LT. NTOKENS) THEN C loop back to do remaining tokens. NTOK=LAST+1 GO TO 70 END IF C C Clear tokens used: DO 3010 K=1,NTOKENS TOKEN(K)(2:LEN(K))=' ' 3010 CONTINUE NUMBER=NITEM RETURN C C Here for help. C 9000 CONTINUE IF (C32.EQ.' ') THEN CALL TV('Blank name read') NUMBER=0 RETURN END IF CALL SPACE2 CALL TV(' *** HELP ***') C C Uncomment for debugging: C PRINT* C PRINT*,'Std.name is '//STDNAM C PRINT*,(TOKEN(K)(:LEN(K)),K=1,NTOKENS) C PRINT*,(NTYPE(K),K=1,NTOKENS) C WRITE(CARD,'(''Cannot parse: '',A32)') C32 WRITE(CARD(60:),'(''near'',I5)') NERR CALL TV(CARD) CALL TV('Please re-enter this star name, with = between synonyms') CALL TVN('-->..............................<-- 32 characters MAX') DO 9010 K=1,NTOKENS TOKEN(K)=' ' 9010 CONTINUE CALL ASKFIL(' ? ',C32) GO TO 2 C END FUNCTION NBIN(WORD,WORDS,N) C C Does binary search for word in previously sorted word list of length N. C Returns position of word if found, or 0 if not found. C C Method: see p.87 of Jon Bentley's "Programming Pearls". C C CAUTION: This version ONLY supports arrays shorter than 4096 entries !! C C IMPLICIT NONE INTEGER NBIN, N, L C CHARACTER*(*) WORDS(N),WORD C C L=0 IF (N.GT.2048) THEN IF(WORDS(2048).LT.WORD) L=N+1-2048 GOTO 2048 ELSE IF (N.GT.1024) THEN IF(WORDS(1024).LT.WORD) L=N+1-1024 GOTO 1024 ELSE IF (N.GT.512) THEN IF(WORDS(512).LT.WORD) L=N+1-512 GOTO 512 ELSE IF (N.GT.256) THEN IF(WORDS(256).LT.WORD) L=N+1-256 GOTO 256 ELSE IF (N.GT.128) THEN IF(WORDS(128).LT.WORD) L=N+1-128 GOTO 128 ELSE IF (N.GT.64) THEN IF(WORDS(64).LT.WORD) L=N+1-64 GOTO 64 ELSE IF (N.GT.32) THEN IF(WORDS(32).LT.WORD) L=N+1-32 GOTO 32 ELSE IF (N.GT.16) THEN IF(WORDS(16).LT.WORD) L=N+1-16 GOTO 16 ELSE IF (N.GT.8) THEN IF(WORDS(8).LT.WORD) L=N+1-8 GOTO 8 ELSE IF (N.GT.4) THEN IF(WORDS(4).LT.WORD) L=N+1-4 GOTO 4 ELSE IF (N.GT.2) THEN IF(WORDS(2).LT.WORD) L=N+1-2 GOTO 2 ELSE IF(WORDS(1).LT.WORD) L=N+1-1 GOTO 1 END IF C 2048 IF (WORDS(L+1024).LT.WORD) L=L+1024 1024 IF (WORDS(L+512).LT.WORD) L=L+512 512 IF (WORDS(L+256).LT.WORD) L=L+256 256 IF (WORDS(L+128).LT.WORD) L=L+128 128 IF (WORDS(L+64).LT.WORD) L=L+64 64 IF (WORDS(L+32).LT.WORD) L=L+32 32 IF (WORDS(L+16).LT.WORD) L=L+16 16 IF (WORDS(L+8).LT.WORD) L=L+8 8 IF (WORDS(L+4).LT.WORD) L=L+4 4 IF (WORDS(L+2).LT.WORD) L=L+2 2 IF (WORDS(L+1).LT.WORD) L=L+1 1 CONTINUE C NBIN=L+1 IF (NBIN.GT.N .OR. WORDS(NBIN).NE.WORD) NBIN=0 C RETURN END SUBROUTINE SRTNAM(WORDS, NTYPE, N) C C sorts word list of length N. Carries ntype along. C C IMPLICIT NONE INTEGER N, I, M, JJ, NDUM C CHARACTER*(20) WORDS(N) INTEGER NTYPE(N) CHARACTER*20 WORD C C I=1 1 I=I+I IF(I.LT.N) GO TO 1 M=I-1 2 M=M/2 IF (M.EQ.0) RETURN DO 10 JJ=1,N-M DO 8 I=JJ,1,-M IF(WORDS(I+M).GE.WORDS(I)) GO TO 10 WORD=WORDS(I) WORDS(I)=WORDS(I+M) WORDS(I+M)=WORD NDUM=NTYPE(I) NTYPE(I)=NTYPE(I+M) NTYPE(I+M)=NDUM 8 CONTINUE 10 CONTINUE GO TO 2 C END