c ****************************************************************** c *** fortran code to operate on the *** c *** *** c *** OPEN CLUSTER ISM DATABASE *** c *** *** c *** current version of code written 2 March 1988 *** c *** *** c *** for information, contact D. Leisawitz *** c *** Laboratory for Astronomy and *** c *** Solar Physics *** c *** Code 685 *** c *** NASA/GSFC *** c *** Greenbelt, MD, USA *** c *** 20771 *** c *** *** c *** phone: (301) 286-2150 *** c *** *** c ****************************************************************** integer iserno(150) open(unit=9,file='ocdb.rec',status='old',readonly) open(unit=10,file='ocdb.ref',status='old',readonly) c c read the database write(6,2000) 2000 format(1h0,'Database being read ...') call dbread(ncl) if (ncl.ge.150) write(6,1000) 1000 format(1h1,'WARNING: DATABASE MAY CONTAIN MORE CLUSTERS ', *'THAN 150. IF SO, INCREASE DIMENSIONS.') mskd = 0 ! database currently unmasked c c read the reference information write(6,2001) 2001 format(1h0,'Reference file being read and ', * 'alphabetized ...') call rfread c c alphabetize the array of references call abceez c call outdev(iunit,iprint) c c initialize iserno, array of cluster indices on which to operate c (value of 1 => include cluster i; value of 0 => exclude cluster i) do 10 i=1,150 iserno(i)=0 10 continue c c menu of options to operate on database: call menu(iunit,iprint,mskd,ncl,iserno) stop end SUBROUTINE MENU(IUNIT,IPRINT,MSKD,NCL,ISERNO) c ****************************************************************** c *** this routine displays options available to the user to *** c *** operate on the database and enables the selection of an *** c *** option. *** c ****************************************************************** integer iserno(150) character*1 option,mskok 5 write(6,2000) 2000 format(1h0,'PROCESSING OPTIONS:'/ *3x,'(a) change output device and/or format'/ *3x,'(b) select clusters on which to operate'/ *3x,'(c) type list of selected clusters'/ *3x,'(d) print catalog of cluster information'/ *3x,'(e) mask out some references'/ *3x,'(f) average unmasked data and tabulate'/ *3x,'(g) restore database (necessary to change ', *'masking configuration)'/ *3x,'(h) type complete list of database references'/ *3x,'(i) stop processing'/) 10 write(6,2001) 2001 format(1h ,'Please select an option by entering the ', *'corresponding letter:') read(5,1000)option 1000 format(a1) if (option.eq.'a'.or.option.eq.'A') then call outdev(iunit,iprint) elseif (option.eq.'b'.or.option.eq.'B') then call select(ncl,iserno) elseif (option.eq.'c'.or.option.eq.'C') then call listcl(iunit,ncl,iserno) elseif (option.eq.'d'.or.option.eq.'D') then call seltst(iok,iserno) if (iok.eq.0) go to 5 if (mskd.ne.0) then write(6,2002) 2002 format(1h ,'WARNING: Currently the database is' * ' masked. Is this okay?') read(5,1000)mskok if (mskok.eq.'y'.or.mskok.eq.'Y') then write(6,2003) 2003 format(1h ,'Masked references will appear as', * ' "XXXXX" in printout') else write(6,2004) 2004 format(1h ,'You may want to restore the database' * ' (option g) then try again') go to 5 endif endif call prtcat(iunit,iprint,iserno,ncl) elseif (option.eq.'e'.or.option.eq.'E') then call seltst(iok,iserno) if (iok.eq.0) go to 5 if (mskd.ne.0) then write(6,2005) 2005 format(1h ,'Database is already masked. First restore' * ' it (option g).') go to 5 endif call masker(ncl,mskd) elseif (option.eq.'f'.or.option.eq.'F') then call seltst(iok,iserno) if (iok.eq.0) go to 5 if (mskd.ne.0) then write(6,2002) read(5,1000)mskok if (mskok.eq.'y'.or.mskok.eq.'Y') then write(6,2006) 2006 format(1h ,'MASKED REFERENCES WILL BE IGNORED', * ' IN AVERAGES') else write(6,2004) go to 5 endif endif call averag(iunit,iserno,ncl) elseif (option.eq.'g'.or.option.eq.'G') then rewind 9 write(6,2007) 2007 format(1h0,'database being restored ...') call dbread(ncl) mskd = 0 ! flag to indicate that database is unmasked elseif (option.eq.'h'.or.option.eq.'H') then call biblee(iunit) elseif (option.eq.'i'.or.option.eq.'I') then go to 100 else go to 10 endif go to 5 100 return end SUBROUTINE SELECT(NCL,ISERNO) c ****************************************************************** c *** this routine allows the user to select a set of clusters *** c *** on which to operate. *** c ****************************************************************** common/data/oclno,name,sharp,west,assoc,name2,glon,glat, *ra1,ra2,dec1,dec2,vst,vhii,vco,mux,muy,dist,ang,ldiam, *age,espt,mst,mhi,mhii,mco,mdust,prio,obs,avis,colexc, *nvalus,turnof integer iserno(150),oclno(150),sharp(150),west(150), *prio(150),obs(150),nvalus(150,17) real glon(150),glat(150),ra1(150),ra2(150),dec1(150), *dec2(150),vst(150,14),vhii(150,14),vco(150,14),mux(150,3), *muy(150,3),dist(150,18),ang(150,8),ldiam(150,7),age(150,14), *mst(150,6),mhi(150,6),mhii(150,6),mco(150,6),mdust(150,6), *avis(150,5),colexc(150,14),turnof(150,7) character*5 espt(150,8) character*10 name(150),name2(150),assoc(150) character*1 selopt,selyn c c initialize to no clusters selected: do 5 i=1,150 iserno(i) = 0 5 continue ncnt = 0 6 write(6,2000) 2000 format(1h0,'Cluster sample options:'/ *3x,'(a) all clusters in database'/ *3x,'(b) select individual clusters from list'/ *3x,'(c) include clusters specified by database number'/ *3x,'(d) 34 clusters mapped for CO emission by LEI88') read(5,1000)selopt 1000 format(a1) if (selopt.eq.'a'.or.selopt.eq.'A') then ncnt = ncl do 10 i=1,ncl iserno(i) = 1 10 continue elseif (selopt.eq.'b'.or.selopt.eq.'B') then write(6,2001) 2001 format(1h ,'Respond with "y" to select a cluster ', * '("q" to quit):') do 20 i=1,ncl write(6,2002)i,oclno(i),name(i) 2002 format(1h ,i3,1x,'include OCL ',i3,' (=',a10, * ')?') read(5,1000)selyn if (selyn.eq.'y'.or.selyn.eq.'Y') then ncnt = ncnt + 1 iserno(i) = 1 endif if (selyn.eq.'q'.or.selyn.eq.'Q') go to 21 20 continue 21 continue elseif (selopt.eq.'c'.or.selopt.eq.'C') then write(6,2003) 2003 format(1h ,'Enter list of cluster database numbers'/ * 3x,'(integers; one per line; 0 (zero) on last line)') 30 read(5,*)icl if (icl.gt.0.and.icl.le.ncl) then ncnt = ncnt + 1 iserno(icl) = 1 go to 30 endif elseif (selopt.eq.'d'.or.selopt.eq.'D') then do 40 i=1,ncl if (obs(i).eq.1) then ncnt = ncnt + 1 iserno(i) = 1 endif 40 continue else write(6,2004) 2004 format(1h ,'Please select one of the available options ...') go to 6 endif write(6,2005)ncnt 2005 format(1h ,i3,' CLUSTERS HAVE BEEN SELECTED'/) return end SUBROUTINE SELTST(IOK,ISERNO) c ****************************************************************** c *** this routine checks to see that a list of clusters has *** c *** been selected on which to operate. *** c ****************************************************************** integer iserno(150) iok = 0 ! initialize to no clusters selected do 10 i=1,150 if (iserno(i).eq.1) then iok = 1 ! at least one cluster has been selected go to 20 endif 10 continue 20 continue if (iok.eq.0) write(6,2000) 2000 format(1h0,'No clusters selected => CANNOT PERFORM ', *'REQUESTED OPERATION') return end SUBROUTINE LISTCL(IUNIT,NCL,ISERNO) c ****************************************************************** c *** this routine enables user to write a list of clusters *** c *** selected. Selected clusters are ones on which operations *** c *** are performed. *** c ****************************************************************** common/data/oclno,name,sharp,west,assoc,name2,glon,glat, *ra1,ra2,dec1,dec2,vst,vhii,vco,mux,muy,dist,ang,ldiam, *age,espt,mst,mhi,mhii,mco,mdust,prio,obs,avis,colexc, *nvalus,turnof integer iserno(150),oclno(150),sharp(150),west(150), *prio(150),obs(150),nvalus(150,17) real glon(150),glat(150),ra1(150),ra2(150),dec1(150), *dec2(150),vst(150,14),vhii(150,14),vco(150,14),mux(150,3), *muy(150,3),dist(150,18),ang(150,8),ldiam(150,7),age(150,14), *mst(150,6),mhi(150,6),mhii(150,6),mco(150,6),mdust(150,6), *avis(150,5),colexc(150,14),turnof(150,7) character*5 espt(150,8) character*10 name(150),name2(150),assoc(150) ncnt = 0 write(iunit,2003) 2003 format(1h1,'LIST OF SELECTED CLUSTERS:'/) if (iunit.ne.6) write(6,2000) write(iunit,2000) 2000 format(1h0,'DB#',2x,'OCL#',3x,'L II',3x,'B II',11x,'NAME', *11x,'MEM OF ASSOC',2x,'S',4x,'W'/) do 10 i=1,ncl if (iserno(i).eq.1) then if (iunit.ne.6) * write(6,2001)i,oclno(i),glon(i),glat(i),name(i), * name2(i),assoc(i),sharp(i),west(i) write(iunit,2001)i,oclno(i),glon(i),glat(i),name(i), * name2(i),assoc(i),sharp(i),west(i) 2001 format(1h ,i3,2x,i4,2x,f6.2,1x,f6.2,2x,a10,2x,a10, * 2x,a10,2x,i3,2x,i3) ncnt = ncnt + 1 endif 10 continue if (iunit.ne.6) write(6,2002)ncnt write(iunit,2002)ncnt 2002 format(1h0,'... a total of ',i3,' clusters in list.'/) if (iunit.ne.6) write(6,3000)iunit 3000 format(1h0,'this list was written to unit',i3,':') return end SUBROUTINE OUTDEV(IUNIT,IPRINT) c ****************************************************************** c *** this routine enables user to specify output device/unit *** c ****************************************************************** character*80 fname character*1 outfil write(6,2000) 2000 format(1h ,'Would you like to save output in a file?') read(5,3000)outfil 3000 format(a1) if (outfil.eq.'y') then call filer(fname) open(unit=11,file=fname,status='new') iunit = 11 else write(6,2001) 2001 format(1h ,'Output directed to terminal') iunit = 6 endif call prtlev(iprint) return end SUBROUTINE PRTLEV(IPRINT) c ***************************************************************** c *** this routine enables user to select volume of printout *** c ***************************************************************** character*1 prcl,blank,null data blank/' '/,null/'^@'/ write(6,2000) 2000 format(1h0,'Select level of printed output:'/ *5x,'m => minimal printout/messages'/ *5x,'r => restricted output'/ *5x,'s => standard output format (default)') read(5,1000)prcl 1000 format(a1) c c iprint = 2 => generate standard printout of database info for included c clusters c iprint = 1 => generate short printout of database info for included clusters c iprint = 0 => minimal printout and warning messages if (prcl.eq.blank.or.prcl.eq.null) iprint = 2 if (prcl.eq.'m'.or.prcl.eq.'M') iprint = 0 if (prcl.eq.'r'.or.prcl.eq.'R') iprint = 1 if (prcl.eq.'s'.or.prcl.eq.'S') iprint = 2 return end SUBROUTINE DBREAD(NCL) c ***************************************************************** c *** this routine reads information about open clusters from *** c *** the database and counts the number of clusters for which *** c *** information is stored (ncl) *** c ***************************************************************** common/data/oclno,name,sharp,west,assoc,name2,glon,glat, *ra1,ra2,dec1,dec2,vst,vhii,vco,mux,muy,dist,ang,ldiam, *age,espt,mst,mhi,mhii,mco,mdust,prio,obs,avis,colexc, *nvalus,turnof common/refs/vstref,vhiirf,vcoref,muref,disref,angref,ldref, *ageref,sptref,mstref,mhiref,mhiirf,mcoref,mdsref,avref, *cexref,turref integer oclno(150),sharp(150),west(150), *prio(150),obs(150),nvalus(150,17) c c IMPORTANT NOTE: IF CHANGING DIMENSIONS OF DATA ELEMENTS, ALSO CHANGE c DIMENSIONS OF codlst, ETC. IN ROUTINE "RFLIST" c real glon(150),glat(150),ra1(150),ra2(150),dec1(150), *dec2(150),vst(150,14),vhii(150,14),vco(150,14),mux(150,3), *muy(150,3),dist(150,18),ang(150,8),ldiam(150,7),age(150,14), *mst(150,6),mhi(150,6),mhii(150,6),mco(150,6),mdust(150,6), *avis(150,5),colexc(150,14),turnof(150,7) character*5 vstref(150,14),vhiirf(150,14),vcoref(150,14), *muref(150,3),disref(150,18),angref(150,8),ldref(150,7), *ageref(150,14),espt(150,8),sptref(150,8),mstref(150,6), *mhiref(150,6),mhiirf(150,6),mcoref(150,6),mdsref(150,6), *avref(150,5),cexref(150,14),turref(150,7),blank character*10 name(150),name2(150),assoc(150) data blank/' '/ ncl=0 c c initialize reference code arrays: do 1 i=1,150 do 2 j=1,14 vstref(i,j)=blank vhiirf(i,j)=blank vcoref(i,j)=blank ageref(i,j)=blank cexref(i,j)=blank 2 continue do 3 j=1,3 muref(i,j)=blank 3 continue do 4 j=1,18 disref(i,j)=blank 4 continue do 5 j=1,8 angref(i,j)=blank sptref(i,j)=blank 5 continue do 6 j=1,7 ldref(i,j)=blank turref(i,j)=blank 6 continue do 7 j=1,6 mstref(i,j)=blank mhiref(i,j)=blank mhiirf(i,j)=blank mcoref(i,j)=blank mdsref(i,j)=blank 7 continue do 8 j=1,5 avref(i,j)=blank 8 continue 1 continue do 10 i=1,150 c cluster identification info: read(9,1001)oclno(i),name(i),sharp(i),west(i), * assoc(i),name2(i) 1001 format(i4,1x,a10,1x,i3,2x,i3,2a10) if (oclno(i).eq.9999) go to 20 ! 9999 => end of cluster info ncl=ncl+1 c cluster position info: read(9,1002)glon(i),glat(i),ra1(i),ra2(i),dec1(i),dec2(i) 1002 format(2f6.2,3x,f3.0,1x,f4.1,2x,f4.0,1x,f3.0) c stellar radial velocity measurements and corresponding references: read(9,1003)nvalus(i,1),(vst(i,j),vstref(i,j),j=1,7) if (nvalus(i,1).gt.7) * read(9,1003)idum,(vst(i,j),vstref(i,j),j=8,14) 1003 format(i2,2x,7(f5.0,1x,a5,2x)) c H II region radial velocity measurements and corresponding references: read(9,1003)nvalus(i,2),(vhii(i,j),vhiirf(i,j),j=1,7) if (nvalus(i,2).gt.7) * read(9,1003)idum,(vhii(i,j),vhiirf(i,j),j=8,14) c molecular cloud radial velocity measurements and corresponding references: read(9,1003)nvalus(i,3),(vco(i,j),vcoref(i,j),j=1,7) if (nvalus(i,3).gt.7) * read(9,1003)idum,(vco(i,j),vcoref(i,j),j=8,14) c proper motion measurements and corresponding references: read(9,1006)nvalus(i,4),(mux(i,j),muy(i,j),muref(i,j), * j=1,3) 1006 format(i1,2x,3(f6.3,1x,f6.3,1x,a5,2x)) c cluster distance measurements and corresponding references: read(9,1007)nvalus(i,5),(dist(i,j),disref(i,j),j=1,9) if (nvalus(i,5).gt.9) * read(9,1007)idum,(dist(i,j),disref(i,j),j=10,18) 1007 format(i2,2x,9(f4.2,1x,a5,1x)) c angular diameter measurements and corresponding references: read(9,1008)nvalus(i,6),(ang(i,j),angref(i,j),j=1,8) 1008 format(i1,2x,8(f5.0,1x,a5,2x)) c linear diameter measurements and corresponding references: read(9,1009)nvalus(i,7),(ldiam(i,j),ldref(i,j),j=1,7) 1009 format(i1,2x,7(f5.0,1x,a5,2x)) c age estimates and corresponding references: read(9,1003)nvalus(i,8),(age(i,j),ageref(i,j),j=1,7) if (nvalus(i,8).gt.7) * read(9,1003)idum,(age(i,j),ageref(i,j),j=8,14) c earliest main sequence spectral type measurements and corresponding refs: read(9,1011)nvalus(i,9),(espt(i,j),sptref(i,j),j=1,8) 1011 format(i1,2x,8(a5,1x,a5,2x)) c cluster stellar mass estimates and corresponding references: read(9,1012)nvalus(i,10),(mst(i,j),mstref(i,j),j=1,6) 1012 format(i1,2x,6(e8.2,1x,a5,2x)) c associated H I mass estimates and corresponding references: read(9,1012)nvalus(i,11),(mhi(i,j),mhiref(i,j),j=1,6) c associated H II region mass estimates and corresponding references: read(9,1012)nvalus(i,12),(mhii(i,j),mhiirf(i,j),j=1,6) c associated molecular cloud mass estimates and corresponding references: read(9,1012)nvalus(i,13),(mco(i,j),mcoref(i,j),j=1,6) c associated dust mass estimates and corresponding references: read(9,1012)nvalus(i,14),(mdust(i,j),mdsref(i,j),j=1,6) c priority (1 - 10) assigned to cluster for CO survey observations (Leisawitz) read(9,1017)prio(i) 1017 format(i2) c flag to indicate if cluster region was included in Leisawitz CO survey of c young open clusters (obs = 1 => yes; 0 => no) read(9,1018)obs(i) 1018 format(i1) c visual extinction measurements and corresponding references: read(9,1009)nvalus(i,15),(avis(i,j),avref(i,j),j=1,5) c B-V color excess (reddening) measurements and corresponding references: read(9,1003)nvalus(i,16),(colexc(i,j),cexref(i,j),j=1,7) if (nvalus(i,16).gt.7) * read(9,1003)idum,(colexc(i,j),cexref(i,j),j=8,14) c main sequence turnoff color (B-V) measurements and corresponding references: read(9,1020)nvalus(i,17),(turnof(i,j),turref(i,j),j=1,7) 1020 format(i1,7(1x,f5.2,1x,a5)) 10 continue 20 continue return end SUBROUTINE PRTCAT(IUNIT,IPRINT,ISERNO,NCL) c ************************************************************************** c *** this routine prints information about selected clusters. The *** c *** array iserno determines which clusters are included. If ibib = 1 *** c *** then a short index of reference codes and the references to which *** c *** they correspond is printed on the page following the data *** c *** printout. *** c ************************************************************************** common/data/oclno,name,sharp,west,assoc,name2,glon,glat, *ra1,ra2,dec1,dec2,vst,vhii,vco,mux,muy,dist,ang,ldiam, *age,espt,mst,mhi,mhii,mco,mdust,prio,obs,avis,colexc, *nvalus,turnof common/refs/vstref,vhiirf,vcoref,muref,disref,angref,ldref, *ageref,sptref,mstref,mhiref,mhiirf,mcoref,mdsref,avref, *cexref,turref integer iserno(150),oclno(150),sharp(150),west(150), *prio(150),obs(150),nvalus(150,17) integer index(18),year(18) real glon(150),glat(150),ra1(150),ra2(150),dec1(150), *dec2(150),vst(150,14),vhii(150,14),vco(150,14),mux(150,3), *muy(150,3),dist(150,18),ang(150,8),ldiam(150,7),age(150,14), *mst(150,6),mhi(150,6),mhii(150,6),mco(150,6),mdust(150,6), *avis(150,5),colexc(150,14),turnof(150,7) real ddum(18),adum(18),vdum(18) character*5 drdum(18),ardum(18),vrdum(18) character*5 vstref(150,14),vhiirf(150,14),vcoref(150,14), *muref(150,3),disref(150,18),angref(150,8),ldref(150,7), *ageref(150,14),espt(150,8),sptref(150,8),mstref(150,6), *mhiref(150,6),mhiirf(150,6),mcoref(150,6),mdsref(150,6), *avref(150,5),cexref(150,14),turref(150,7),blank character*10 name(150),name2(150),assoc(150) c the array pgrows is a map of the page layout (120 rows x 132 columns) character*1 pgrows(132,120) character*1 irfs,iterm data blank/' '/ ibib = 0 ! default is no printing of short ref list if (iprint.eq.2) then write(6,8000) 8000 format(1h0,'Would you like a matched directory of ', * 'reference codes'/ * 3x,'printed with data for each cluster?') read(5,9000)irfs 9000 format(a1) if (irfs.eq.'y'.or.irfs.eq.'Y') ibib = 1 endif if (iunit.ne.6) then write(6,8001)iunit 8001 format(1h0,'Catalog being written to unit',i3,' ...') if (iprint.eq.2) write(6,8003) 8003 format(1h ,2x,'(this may take a few minutes)') elseif (iprint.ne.0) then write(6,8002) 8002 format(1h ,'Output may appear messy on terminal.'/ * ' If you would prefer to save in file, enter "f"'/ * ' and select option (a) in menu. ( to continue).') read(5,9000)iterm if (iterm.eq.'f'.or.iterm.eq.'F') go to 999 endif 1001 format(1h ) 1002 format(1h0) 1060 format(1h1) 1100 format(' NO VALUES AVAILABLE') if (iprint.lt.2) go to 600 c c loop for next cluster: do 10 i=1,ncl ipg=iserno(i) if (ipg.eq.0) go to 10 ! skip to next cluster if this one not included write(6,1900)name(i) 1900 format(1h ,'formatting/writing page(s) for ',a10) nrow = 0 c c initialize page to all blank: do 1 irow=1,120 encode(132,1111,pgrows(1,irow)) 1111 format(132(' ')) 1 continue c cluster identification info: nrow = nrow + 1 encode(132,2000,pgrows(1,nrow)) 2000 format('CLUSTER IDENTIFICATION:') nrow = nrow + 1 if (oclno(i).ne.0) then nrow = nrow + 1 encode(132,2010,pgrows(1,nrow))oclno(i) 2010 format(1x,'ALTER et al.:',t20,'OCL',i4) endif nrow = nrow + 1 encode(132,2011,pgrows(1,nrow))name(i) if (name2(i).ne.blank) then nrow = nrow + 1 encode(132,2911,pgrows(1,nrow))name2(i) endif 2011 format(1x,'COMMON NAME:',T20,A10) 2911 format(1X,'ALTERNATE NAME:',t20,a10) if (sharp(i).ne.0) then nrow = nrow + 1 encode(132,2012,pgrows(1,nrow))sharp(i) 2012 format(1x,'SHARPLESS:',t20,'S',i3) endif if (west(i).ne.0) then nrow = nrow + 1 encode(132,2013,pgrows(1,nrow))west(i) 2013 format(1x,'WESTERHOUT:',t20,'W',i3) endif if (assoc(i).ne.blank) then nrow = nrow + 1 encode(132,2014,pgrows(1,nrow))assoc(i) 2014 format(1x,'MEMBER OF ASSOC.:',t20,a10) endif nrow = nrow + 1 encode(132,2015,pgrows(1,nrow))i 2015 format(1x,'DATA BASE NUM:',t20,i3) nrow = nrow + 3 ntopr = nrow c radial velocity info: encode(60,2050,pgrows(1,nrow)) 2050 format('RADIAL VELOCITIES (w.r.t. LSR; km/s):') nrow = nrow + 1 encode(132,2060,pgrows(1,nrow)) 2060 format(2x,'STELLAR:') nrow = nrow + 1 if (nvalus(i,1).ne.0) then nrow = nrow + 1 encode(132,2070,pgrows(1,nrow)) 2070 format(4x,'VELOCITY',3X,'REF.') jmx=nvalus(i,1) c arrange data in chronological order of citations: do 19 j=1,jmx index(j)=jmx call refyr(vstref(i,j),year(j)) 19 continue call decr(jmx,year,index) do 20 j=1,jmx do 21 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(132,2080,pgrows(1,nrow))vst(i,k),vstref(i,k) 2080 format(5x,f6.1,4x,a5) endif 21 continue 20 continue else nrow = nrow + 1 encode(132,1100,pgrows(1,nrow)) endif nrow = nrow + 2 encode(132,2090,pgrows(1,nrow)) 2090 format(2x,'H II REGION:') nrow = nrow + 1 if (nvalus(i,2).ne.0) then nrow = nrow + 1 encode(132,2070,pgrows(1,nrow)) jmx=nvalus(i,2) c arrange data in chronological order of citations: do 29 j=1,jmx index(j)=jmx call refyr(vhiirf(i,j),year(j)) 29 continue call decr(jmx,year,index) do 30 j=1,jmx do 31 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(132,2080,pgrows(1,nrow))vhii(i,k),vhiirf(i,k) endif 31 continue 30 continue else nrow = nrow + 1 encode(132,1100,pgrows(1,nrow)) endif nrow = nrow + 2 encode(132,2100,pgrows(1,nrow)) 2100 format(2x,'CO CLOUDS:') nrow = nrow + 1 if (nvalus(i,3).ne.0) then nrow = nrow + 1 encode(132,2070,pgrows(1,nrow)) jmx=nvalus(i,3) c arrange data in chronological order of citations: do 39 j=1,jmx index(j)=jmx call refyr(vcoref(i,j),year(j)) 39 continue call decr(jmx,year,index) do 40 j=1,jmx do 41 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(132,2080,pgrows(1,nrow))vco(i,k),vcoref(i,k) endif 41 continue 40 continue else nrow = nrow + 1 encode(132,1100,pgrows(1,nrow)) endif c proper motion info: nrow = nrow + 3 encode(132,2110,pgrows(1,nrow)) 2110 format('PROPER MOTION (arcsec/100 yr):') nrow = nrow + 1 if (nvalus(i,4).ne.0) then nrow = nrow + 1 encode(132,2120,pgrows(1,nrow)) 2120 format(3x,'MU X',5x,'MU Y',5x,'REF.') jmx=nvalus(i,4) c arrange data in chronological order of citations: do 49 j=1,jmx index(j)=jmx call refyr(muref(i,j),year(j)) 49 continue call decr(jmx,year,index) do 50 j=1,jmx do 51 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(132,2130,pgrows(1,nrow))mux(i,k),muy(i,k), * muref(i,k) 2130 format(2x,f6.3,3x,f6.3,3x,a5) endif 51 continue 50 continue else c cluster distance info: nrow = nrow + 1 encode(132,1100,pgrows(1,nrow)) endif nrow = nrow + 3 encode(132,2140,pgrows(1,nrow)) 2140 format('DISTANCE FROM SOLAR NEIGHBORHOOD (kpc):') nrow = nrow + 1 if (nvalus(i,5).ne.0) then nrow = nrow + 1 encode(132,2150,pgrows(1,nrow)) 2150 format(2x,'DIST',5x,'REF.') jmx=nvalus(i,5) c arrange data in chronological order of citations: do 59 j=1,jmx index(j)=jmx call refyr(disref(i,j),year(j)) 59 continue call decr(jmx,year,index) do 60 j=1,jmx do 61 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(132,2160,pgrows(1,nrow))dist(i,k),disref(i,k) 2160 format(2x,f4.2,5x,a5) endif 61 continue 60 continue else nrow = nrow + 1 encode(132, 1100,pgrows(1,nrow)) endif nbotr = nrow ! store bottom row number c begin new column on page nrow = 1 c cluster position info: encode(77,2020,pgrows(55,nrow)) 2020 format('SPATIAL COORDINATES:') nrow = nrow + 2 encode(77,2030,pgrows(55,nrow))glon(i),ra1(i),ra2(i) 2030 format(2x,'L II:',t10,f6.2,t25,'RA(1950.0):',t40, * f3.0,1x,f4.1) nrow = nrow + 1 encode(77,2040,pgrows(55,nrow))glat(i),dec1(i),dec2(i) 2040 format(2x,'B II:',t10,f6.2,t25,'DEC(1950.0):',t40, * f4.0,1x,f3.0) nrow = ntopr ! skip to top data line c angular diameter info: encode(82,2170,pgrows(50,nrow)) 2170 format('ANGULAR DIAMETER (arcmin):') if (nvalus(i,6).ne.0) then nrow = nrow + 2 encode(80,2180,pgrows(52,nrow)) 2180 format('ANG D',4x,'REF.') jmx=nvalus(i,6) c arrange data in chronological order of citations: do 69 j=1,jmx index(j)=jmx call refyr(angref(i,j),year(j)) 69 continue call decr(jmx,year,index) do 70 j=1,jmx do 71 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(80,2190,pgrows(52,nrow))ang(i,k),angref(i,k) 2190 format(f5.1,4x,a5) endif 71 continue 70 continue else nrow = nrow + 1 encode(82,1100,pgrows(50,nrow)) endif c linear diameter info: nrow = nrow + 3 encode(82,2200,pgrows(50,nrow)) 2200 format('LINEAR DIAMETER (pc):') nrow = nrow + 1 if (nvalus(i,7).ne.0) then nrow = nrow + 1 encode(80,2210,pgrows(52,nrow)) 2210 format('LIN D',4x,'REF.') jmx=nvalus(i,7) c arrange data in chronological order of citations: do 79 j=1,jmx index(j)=jmx call refyr(ldref(i,j),year(j)) 79 continue call decr(jmx,year,index) do 80 j=1,jmx do 81 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(80,2190,pgrows(52,nrow))ldiam(i,k),ldref(i,k) endif 81 continue 80 continue else nrow = nrow + 1 encode(82,1100,pgrows(50,nrow)) endif c cluster age estimates: nrow = nrow + 3 encode(82,2220,pgrows(50,nrow)) 2220 format('AGE ESTIMATES:') nrow = nrow + 1 encode(80,2230,pgrows(52,nrow)) 2230 format('AGE (Myr):') nrow = nrow + 1 if (nvalus(i,8).ne.0) then nrow = nrow + 1 encode(78,2240,pgrows(54,nrow)) 2240 format('AGE',5x,'REF.') jmx=nvalus(i,8) c arrange data in chronological order of citations: do 89 j=1,jmx index(j)=jmx call refyr(ageref(i,j),year(j)) 89 continue call decr(jmx,year,index) do 90 j=1,jmx do 91 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(79,2250,pgrows(53,nrow))age(i,k),ageref(i,k) 2250 format(f5.0,4x,a5) endif 91 continue 90 continue else nrow = nrow + 1 encode(82,1100,pgrows(50,nrow)) endif nrow = nrow + 2 encode(80,2260,pgrows(52,nrow)) 2260 format('EARLIEST MS SPECTRAL TYPE:') nrow = nrow + 1 if (nvalus(i,9).ne.0) then nrow = nrow + 1 encode(77,2270,pgrows(55,nrow)) 2270 format('eSpT',4X,'REF.') jmx=nvalus(i,9) c arrange data in chronological order of citations: do 99 j=1,jmx index(j)=jmx call refyr(sptref(i,j),year(j)) 99 continue call decr(jmx,year,index) do 100 j=1,jmx do 101 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(77,2280,pgrows(55,nrow))espt(i,k),sptref(i,k) 2280 format(a5,3x,a5) endif 101 continue 100 continue else nrow = nrow + 1 encode(82,1100,pgrows(50,nrow)) endif nrow = nrow + 2 encode(80,2265,pgrows(52,nrow)) 2265 format('MS TURNOFF COLOR:') nrow = nrow + 1 if (nvalus(i,17).ne.0) then nrow = nrow + 1 encode(77,2275,pgrows(55,nrow)) 2275 format('(B-V)',3x,'REF.') jmx=nvalus(i,17) c arrange data in chronological order of citations: do 104 j=1,jmx index(j)=jmx call refyr(turref(i,j),year(j)) 104 continue call decr(jmx,year,index) do 105 j=1,jmx do 106 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(77,2285,pgrows(55,nrow))turnof(i,k),turref(i,k) 2285 format(f5.2,3x,a5) endif 106 continue 105 continue else nrow = nrow + 1 encode(82,1100,pgrows(50,nrow)) endif if (nrow.gt.nbotr) nbotr = nrow c begin new column on page nrow = ntopr c info about masses: encode(47,2290,pgrows(85,nrow)) 2290 format('MASSES (SOLAR MASS UNITS):') nrow = nrow + 1 encode(45,2300,pgrows(87,nrow)) 2300 format('STELLAR MASS:') nrow = nrow + 1 if (nvalus(i,10).ne.0) then nrow = nrow + 1 encode(41,2310,pgrows(91,nrow)) 2310 format('MASS',5X,'REF.') jmx=nvalus(i,10) c arrange data in chronological order of citations: do 109 j=1,jmx index(j)=jmx call refyr(mstref(i,j),year(j)) 109 continue call decr(jmx,year,index) do 110 j=1,jmx do 111 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(43,2320,pgrows(89,nrow))mst(i,k),mstref(i,k) 2320 format(1pe8.2,3x,a5) endif 111 continue 110 continue else nrow = nrow + 1 encode(47,1100,pgrows(85,nrow)) endif nrow = nrow + 2 encode(45,2330,pgrows(87,nrow)) 2330 format('MASS IN ASSOCIATED H I CLOUDS:') nrow = nrow + 1 if (nvalus(i,11).ne.0) then nrow = nrow + 1 encode(41,2310,pgrows(91,nrow)) jmx=nvalus(i,11) c arrange data in chronological order of citations: do 119 j=1,jmx index(j)=jmx call refyr(mhiref(i,j),year(j)) 119 continue call decr(jmx,year,index) do 120 j=1,jmx do 121 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(43,2320,pgrows(89,nrow))mhi(i,k),mhiref(i,k) endif 121 continue 120 continue else nrow = nrow + 1 encode(47,1100,pgrows(85,nrow)) endif nrow = nrow + 2 encode(45,2340,pgrows(87,nrow)) 2340 format('IONIZED HYDROGEN MASS:') nrow = nrow + 1 if (nvalus(i,12).ne.0) then nrow = nrow + 1 encode(41,2310,pgrows(91,nrow)) jmx=nvalus(i,12) c arrange data in chronological order of citations: do 129 j=1,jmx index(j)=jmx call refyr(mhiirf(i,j),year(j)) 129 continue call decr(jmx,year,index) do 130 j=1,jmx do 131 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(43,2320,pgrows(89,nrow))mhii(i,k),mhiirf(i,k) endif 131 continue 130 continue else nrow = nrow + 1 encode(47,1100,pgrows(85,nrow)) endif nrow = nrow + 2 encode(45,2350,pgrows(87,nrow)) 2350 format('MASS IN ASSOCIATED MOLECULAR CLOUDS:') nrow = nrow + 1 if (nvalus(i,13).ne.0) then nrow = nrow + 1 encode(41,2310,pgrows(91,nrow)) jmx=nvalus(i,13) c arrange data in chronological order of citations: do 139 j=1,jmx index(j)=jmx call refyr(mcoref(i,j),year(j)) 139 continue call decr(jmx,year,index) do 140 j=1,jmx do 141 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(43,2320,pgrows(89,nrow))mco(i,k),mcoref(i,k) endif 141 continue 140 continue else nrow = nrow + 1 encode(47,1100,pgrows(85,nrow)) endif nrow = nrow + 2 encode(45,2360,pgrows(87,nrow)) 2360 format('ASSOCIATED MASS IN THE FORM OF DUST:') nrow = nrow + 1 if (nvalus(i,14).ne.0) then nrow = nrow + 1 encode(41,2310,pgrows(91,nrow)) jmx=nvalus(i,14) c arrange data in chronological order of citations: do 149 j=1,jmx index(j)=jmx call refyr(mdsref(i,j),year(j)) 149 continue call decr(jmx,year,index) do 150 j=1,jmx do 151 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(43,2320,pgrows(89,nrow))mdust(i,k),mdsref(i,k) endif 151 continue 150 continue else nrow = nrow + 1 encode(47,1100,pgrows(85,nrow)) endif c visual extinction and reddening info: nrow = nrow + 3 encode(47,2370,pgrows(85,nrow)) 2370 format('VISUAL EXTINCTION TOWARD CLUSTER (mag):') nrow = nrow + 1 if (nvalus(i,15).ne.0) then nrow = nrow + 1 encode(44,2380,pgrows(88,nrow)) 2380 format('AV',6x,'REF.') jmx=nvalus(i,15) c arrange data in chronological order of citations: do 159 j=1,jmx index(j)=jmx call refyr(avref(i,j),year(j)) 159 continue call decr(jmx,year,index) do 160 j=1,jmx do 161 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(45,2390,pgrows(87,nrow))avis(i,k),avref(i,k) 2390 format(f5.2,4x,a5) endif 161 continue 160 continue else nrow = nrow + 1 encode(47,1100,pgrows(85,nrow)) endif nrow = nrow + 3 encode(47,2400,pgrows(85,nrow)) 2400 format('B-V COLOR EXCESS (mag):') nrow = nrow + 1 if (nvalus(i,16).ne.0) then nrow = nrow + 1 encode(45,2410,pgrows(87,nrow)) 2410 format('E(B-V)',3x,'REF.') jmx=nvalus(i,16) c arrange data in chronological order of citations: do 169 j=1,jmx index(j)=jmx call refyr(cexref(i,j),year(j)) 169 continue call decr(jmx,year,index) do 170 j=1,jmx do 171 k=1,jmx if (index(k).eq.j) then nrow = nrow + 1 encode(45,2390,pgrows(87,nrow))colexc(i,k),cexref(i,k) endif 171 continue 170 continue else nrow = nrow + 1 encode(47,1100,pgrows(85,nrow)) endif if (nrow.gt.nbotr) nbotr = nrow C write(6,1002) C if (obs(i).ne.0) then C write(6,2430) C 2430 format(1h0,'THIS REGION WAS MAPPED FOR CO EMISSION WITH', C * ' THE GODDARD-COLUMBIA TELESCOPE.') C else C write(6,2440) C 2440 format(1h0,'THIS REGION WAS NOT INCLUDED IN THE GODDARD-', C * 'COLUMBIA SURVEY.') C endif c c print the page(s): do 500 irows = 1,120 if (irows.gt.nbotr) go to 501 if (irows.eq.(ntopr-1)) write(iunit,1070) 1070 format(1h ,124('_')) if (irows.eq.1.or.irows.eq.60) then write(iunit,5001)(pgrows(jc,irows),jc=1,132) 5001 format(1h1,132a1) else write(iunit,5000)(pgrows(jc,irows),jc=1,132) 5000 format(1h ,132a1) endif 500 continue 501 continue c c print cited references for cluster i if ibib = 1 if (ibib.eq.1) then if (nbotr.lt.60) then write(iunit,1060) else write(iunit,1001) write(iunit,1002) endif call rflist(iunit,i) endif 10 continue go to 999 600 continue ! continue here if abbreviated printout write(iunit,6000) 6000 format(1h1) if (iprint.gt.0) go to 700 write(iunit,6001) 6001 format(1h ,'CLUSTER IDENTIFICATION:',7x, * 'SPATIAL COORDINATES:'/) do 610 i=1,ncl ipg = iserno(i) if (ipg.eq.0) go to 610 ! skip to next cluster write(iunit,6002)oclno(i),glon(i),ra1(i),ra2(i) 6002 format(1h ,1x,'ALTER et al.:',t20,'OCL',i4,t32, * 'L II:',t40,f6.2,t55,'RA(1950.0):',t70,f3.0,1x,f4.1) write(iunit,6003)name(i),glat(i),dec1(i),dec2(i) 6003 format(1h ,1x,'COMMON NAME:',t20,a10,t32, * 'B II:',t40,f6.2,t55,'DEC(1950.0):',t70,f4.0,1x,f3.0) write(iunit,6004) 6004 format(1h ) 610 continue go to 999 700 continue ! continue here if modest output do 710 i=1,ncl ipg = iserno(i) if (ipg.eq.0) go to 710 ! skip to next cluster write(iunit,6001) write(iunit,6002)oclno(i),glon(i),ra1(i),ra2(i) write(iunit,6003)name(i),glat(i),dec1(i),dec2(i) write(iunit,7001) 7001 format(1h0,'STELLAR RV (km/s):',t50, * 'DISTANCE FROM SOLAR NEIGHBORHOOD (kpc):',t105, * 'CLUSTER AGE (Myr):'/) write(iunit,7002) 7002 format(1h ,4x,'VELOCITY',3x,'REF.',t50, * 2x,'DIST',5x,'REF.',t105, * 4x,'AGE',5x,'REF.') mxv = nvalus(i,1) do 701 j=1,mxv index(j)=mxv call refyr(vstref(i,j),year(j)) 701 continue call decr(mxv,year,index) ix = 0 do 711 j=1,mxv do 721 k=1,mxv if (index(k).eq.j) then ix = ix + 1 vdum(ix) = vst(i,k) vrdum(ix) = vstref(i,k) endif 721 continue 711 continue mxd = nvalus(i,5) do 702 j=1,mxd index(j)=mxd call refyr(disref(i,j),year(j)) 702 continue call decr(mxd,year,index) ix = 0 do 712 j=1,mxd do 722 k=1,mxd if (index(k).eq.j) then ix = ix + 1 ddum(ix) = dist(i,k) drdum(ix) = disref(i,k) endif 722 continue 712 continue mxa = nvalus(i,8) do 703 j=1,mxa index(j)=mxa call refyr(ageref(i,j),year(j)) 703 continue call decr(mxa,year,index) ix = 0 do 713 j=1,mxa do 723 k=1,mxa if (index(k).eq.j) then ix = ix + 1 adum(ix) = age(i,k) ardum(ix) = ageref(i,k) endif 723 continue 713 continue do 720 j=1,18 if (j.le.mxv) then if (j.le.mxd) then if (j.le.mxa) then write(iunit,7003)vdum(j),vrdum(j), * ddum(j),drdum(j),adum(j),ardum(j) 7003 format(1h ,5x,f6.1,4x,a5,t50, * 2x,f4.2,5x,a5,t105,3x,f5.0,4x,a5) else write(iunit,7003)vdum(j),vrdum(j), * ddum(j),drdum(j) endif else if (j.le.mxa) then write(iunit,7004)vdum(j),vrdum(j), * adum(j),ardum(j) 7004 format(1h ,5x,f6.1,4x,a5, * t105,3x,f5.0,4x,a5) else write(iunit,7003)vdum(j),vrdum(j) endif endif else if (j.le.mxd) then if (j.le.mxa) then write(iunit,7005) * ddum(j),drdum(j),adum(j),ardum(j) 7005 format(1h ,t50, * 2x,f4.2,5x,a5,t105,3x,f5.0,4x,a5) else write(iunit,7005)ddum(j),drdum(j) endif else if (j.le.mxa) then write(iunit,7006)adum(j),ardum(j) 7006 format(1h ,t105,3x,f5.0,4x,a5) write(iunit,7003)vdum(j),vrdum(j) endif endif endif 720 continue write(iunit,1002) write(iunit,1070) write(iunit,1001) 710 continue 999 return end SUBROUTINE RFREAD c ****************************************************************** c *** this routine reads from the database file the references *** c *** and their corresponding codes. *** c ****************************************************************** common/bibli/refcod,rfrnce,nrefs character*1 refcod(500,5),rfrnce(500,116),a(64),b(64),blank data blank/' '/ c c initialize reference character array do 5 i=1,500 do 6 j=1,116 rfrnce(i,j)=blank 6 continue 5 continue nr=1 c c read first reference line 10 read(10,1000)(a(j),j=1,64) 11 if (a(1).eq.blank) go to 100 c c read second reference line read(10,1000)(b(j),j=1,64) 1000 format(64a1) c c is second line a continuation of first? (icont=0 means no) icont=1 do 15 j=1,5 c refcod is the code that refers to the reference stored in rfrnce refcod(nr,j)=a(j) if (a(j).eq.b(j)) go to 15 icont=0 15 continue c c store reference information in rfrnce array do 20 j=1,58 k=j+6 rfrnce(nr,j)=a(k) 20 continue if (icont.ne.0) go to 25 c c if ref info is not on two lines, return to read next line do 30 j=1,64 a(j)=b(j) 30 continue nr=nr+1 go to 11 25 continue c c if ref info is on two lines, store second half of ref info in rfrnce array do 35 j=59,116 k=j-52 rfrnce(nr,j)=b(k) 35 continue nr=nr+1 c c return to read next reference go to 10 100 continue c nrefs is the number of references stored in the array rfrnce nrefs=nr-1 return end SUBROUTINE BIBLEE(IUNIT) c ******************************************************************** c *** this routine prints the complete reference list as stored *** c *** in the array rfrnce. If the routine ABCEEZ is called *** c *** before this routine is called, the references will be in *** c *** alphabetical order. *** c ******************************************************************** common/bibli/refcod,rfrnce,nrefs character*1 refcod(500,5),rfrnce(500,116) character*5 notrf1,notrf2,notrf3 character*1 nt1(5),nt2(5),nt3(5) equivalence (nt1(1),notrf1),(nt2(1),notrf2),(nt3(1),notrf3) data notrf1/'?????'/,notrf2/'LDCAL'/,notrf3/'VCIRC'/ if (iunit.ne.6) write(6,2000)iunit 2000 format(1h0,'Reference list being written on unit',i3) write(iunit,1000) 1000 format(1h1,45x,'REFERENCES'/) do 10 i=1,nrefs c test to see if this is a "real" reference: do 21 k1=1,5 if (refcod(i,k1).ne.nt1(k1)) go to 31 21 continue go to 10 ! "i" is not a real reference 31 continue do 22 k2=1,5 if (refcod(i,k2).ne.nt2(k2)) go to 32 22 continue go to 10 ! "i" is not a real reference 32 continue do 23 k3=1,5 if (refcod(i,k3).ne.nt3(k3)) go to 33 23 continue go to 10 ! "i" is not a real reference 33 continue write(iunit,1100) 1100 format(1h ) write(iunit,1200)(refcod(i,j),j=1,5),(rfrnce(i,k),k=1,116) 1200 format(1h ,3x,5a1,2x,116a1) 10 continue return end SUBROUTINE ABCEEZ c ******************************************************************* c *** this routine alphabetizes references by sorting the array *** c *** rfrnce and the corresponding array of reference codes, *** c *** refcod. *** c ******************************************************************* common/bibli/refcod,rfrnce,nrefs character*1 refcod(500,5),rfrnce(500,116),comma,dot, * blank,rtemp(116),ctemp(5),press(16,500) character*4 refnam(4,500),temp(4) logical swt data comma/','/,dot/'.'/,blank/' '/ equivalence(press(1,1),refnam(1,1)) c c compress alphabetization names (1st author, 2nd author, etc.) by c stripping out blanks, periods, and commas and storing the first 16 c alphanumeric characters do 10 i=1,nrefs nchr=0 do 20 j=1,116 if (rfrnce(i,j).eq.blank) go to 20 if (rfrnce(i,j).eq.dot) go to 20 if (rfrnce(i,j).eq.comma) go to 20 nchr=nchr+1 press(nchr,i)=rfrnce(i,j) c change all lower case letters in sorting array to upper case letters call upcase(press(nchr,i)) if (nchr.eq.16) go to 10 20 continue 10 continue c c sort the reference arrays according to the values in the corresponding c sorting array, refnam nmax = nrefs-1 n=nmax do 30 i=1,nmax swt=.false. do 40 j=1,n jp1 = j+1 c Note: the sorting is done by comparing up to four 4-byte words. This c is an artifact of the transformation of this code from an earlier c version in which refnam was declared as an integer. if (refnam(1,j).lt.refnam(1,jp1)) go to 40 if (refnam(1,j).eq.refnam(1,jp1).and. * refnam(2,j).lt.refnam(2,jp1)) go to 40 if (refnam(1,j).eq.refnam(1,jp1).and. * refnam(2,j).eq.refnam(2,jp1).and. * refnam(3,j).lt.refnam(3,jp1)) go to 40 if (refnam(1,j).eq.refnam(1,jp1).and. * refnam(2,j).eq.refnam(2,jp1).and. * refnam(3,j).eq.refnam(3,jp1).and. * refnam(4,j).le.refnam(4,jp1)) go to 40 c continue here if swapping is required to sort (otherwise, go to 40) do 44 k=1,4 temp(k)=refnam(k,j) refnam(k,j)=refnam(k,jp1) refnam(k,jp1)=temp(k) 44 continue do 45 k=1,116 rtemp(k)=rfrnce(j,k) rfrnce(j,k)=rfrnce(jp1,k) rfrnce(jp1,k)=rtemp(k) 45 continue do 46 k=1,5 ctemp(k)=refcod(j,k) refcod(j,k)=refcod(jp1,k) refcod(jp1,k)=ctemp(k) 46 continue swt=.true. 40 continue if (.not.swt) go to 50 n=n-1 30 continue 50 continue return end SUBROUTINE RFLIST(IUNIT,ICL) c ******************************************************************** c *** this routine produces a cross-index of references and cor- *** c *** responding reference codes for the references cited for *** c *** cluster number icl. The short reference list is printed *** c *** on a single page. If the routine ABCEEZ was called before *** c *** this routine is called, the index will be printed with *** c *** references alphabetized. *** c ******************************************************************** common/refs/vstref,vhiirf,vcoref,muref,disref,angref, *ldref,ageref,sptref,mstref,mhiref,mhiirf,mcoref,mdsref, *avref,cexref,turref common/bibli/refcod,rfrnce,nrefs character*1 refcod(500,5),refc(5,500),rfrnce(500,116) *,b1 character*5 vstref(150,14),vhiirf(150,14),vcoref(150,14), *muref(150,3),disref(150,18),angref(150,8),ldref(150,7), *ageref(150,14),sptref(150,8),mstref(150,6),mhiref(150,6), *mhiirf(150,6),mcoref(150,6),mdsref(150,6),avref(150,5), *cexref(150,14),turref(150,7),blank,codlst(155),cdlst2(155), *cdlst3(155),code(500),temp data blank/' '/,bl/' '/ equivalence(refc(1,1),code(1)) c c initialize citation arrays do 5 i=1,155 codlst(i)=blank cdlst2(i)=blank cdlst3(i)=blank 5 continue c c store in array codlst a list of codes for the references cited for c cluster icl index=0 do 10 i=1,14 index = index+1 codlst(index)=vstref(icl,i) 10 continue do 20 i=1,14 index = index+1 codlst(index)=vhiirf(icl,i) 20 continue do 30 i=1,14 index = index+1 codlst(index)=vcoref(icl,i) 30 continue do 40 i=1,3 index = index+1 codlst(index)=muref(icl,i) 40 continue do 50 i=1,18 index = index+1 codlst(index)=disref(icl,i) 50 continue do 60 i=1,8 index = index+1 codlst(index)=angref(icl,i) 60 continue do 70 i=1,7 index = index+1 codlst(index)=ldref(icl,i) 70 continue do 80 i=1,14 index = index+1 codlst(index)=ageref(icl,i) 80 continue do 90 i=1,8 index = index+1 codlst(index)=sptref(icl,i) 90 continue do 100 i=1,6 index = index+1 codlst(index)=mstref(icl,i) 100 continue do 110 i=1,6 index = index+1 codlst(index)=mhiref(icl,i) 110 continue do 120 i=1,6 index = index+1 codlst(index)=mhiirf(icl,i) 120 continue do 130 i=1,6 index = index+1 codlst(index)=mcoref(icl,i) 130 continue do 140 i=1,6 index = index+1 codlst(index)=mdsref(icl,i) 140 continue do 150 i=1,5 index = index+1 codlst(index)=avref(icl,i) 150 continue do 160 i=1,14 index = index+1 codlst(index)=cexref(icl,i) 160 continue do 170 i=1,7 index = index+1 codlst(index)=turref(icl,i) 170 continue c c remove blanks from array of citations indx2=0 do 200 i=1,155 if (codlst(i).eq.blank) go to 200 indx2=indx2+1 cdlst2(indx2)=codlst(i) 200 continue c c reverse storage order of array of reference codes and store (by c equivalence) codes in char*5 array "code" do 350 i=1,500 do 351 j=1,5 refc(j,i)=refcod(i,j) 351 continue 350 continue c c write list of references for cluster icl by comparing array of c citations (cdlst2) with array of ref codes (code) write(iunit,1100) 1100 format(1h ,45x,'REFERENCES'/) indx3=0 c search reference list in stored order (presumably alphabetized) for c references cited do 400 i=1,nrefs do 410 j=1,indx2 c print reference info if the ith reference code appears in the list c of references cited if (code(i).ne.cdlst2(j)) go to 410 write(iunit,1300)(refcod(i,k),k=1,5),(rfrnce(i,k),k=1,116) 1300 format(1h ,6x,5a1,3x,116a1) c store array of codes for references printed indx3=indx3+1 cdlst3(indx3)=cdlst2(j) go to 400 410 continue 400 continue c c if the number of refs printed does not equal the number cited, print c warning that reference information is unavailable if (indx3.eq.indx2) go to 500 do 450 i=1,indx2 do 460 j=1,indx3 if (cdlst3(j).eq.cdlst2(i)) go to 450 460 continue if (iunit.ne.6) write(6,1500)cdlst2(i) write(iunit,1500)cdlst2(i) 1500 format(1h ,12x,'REFERENCE INFO IS UNAVAILABLE FOR ',a5) 450 continue 500 continue return end SUBROUTINE UPCASE(a) c ****************************************************************** c *** this routine changes lower case letters to upper case *** c *** letters. All letters must be of same case to alphabetize *** c *** by sorting character string arrays. *** c ****************************************************************** character*1 a if (a.eq.'a') a = 'A' if (a.eq.'b') a = 'B' if (a.eq.'c') a = 'C' if (a.eq.'d') a = 'D' if (a.eq.'e') a = 'E' if (a.eq.'f') a = 'F' if (a.eq.'g') a = 'G' if (a.eq.'h') a = 'H' if (a.eq.'i') a = 'I' if (a.eq.'j') a = 'J' if (a.eq.'k') a = 'K' if (a.eq.'l') a = 'L' if (a.eq.'m') a = 'M' if (a.eq.'n') a = 'N' if (a.eq.'o') a = 'O' if (a.eq.'p') a = 'P' if (a.eq.'q') a = 'Q' if (a.eq.'r') a = 'R' if (a.eq.'s') a = 'S' if (a.eq.'t') a = 'T' if (a.eq.'u') a = 'U' if (a.eq.'v') a = 'V' if (a.eq.'w') a = 'W' if (a.eq.'x') a = 'X' if (a.eq.'y') a = 'Y' if (a.eq.'z') a = 'Z' return end SUBROUTINE MASKER(NCL,MSKD) c *********************************************************************** c *** this routine masks all but the specified data base values. *** c *** In a calculation of, e.g., the distribution of a certain *** c *** cluster characteristic, or a comparison of one author's value *** c *** with that of another, only unmasked database entries are con- *** c *** sidered. A value is "masked" if its associated reference is *** c *** set to 'XXXXX'. The value of nrefs determines how masking *** c *** be done (see comments below). *** c *********************************************************************** common/data/oclno,name,sharp,west,assoc,name2,glon,glat, *ra1,ra2,dec1,dec2,vst,vhii,vco,mux,muy,dist,ang,ldiam, *age,espt,mst,mhi,mhii,mco,mdust,prio,obs,avis,colexc, *nvalus,turnof common/refs/vstref,vhiirf,vcoref,muref,disref,angref,ldref, *ageref,sptref,mstref,mhiref,mhiirf,mcoref,mdsref,avref, *cexref,turref integer oclno(150),sharp(150),west(150), *prio(150),obs(150),nvalus(150,17) integer index(18),year(18) real glon(150),glat(150),ra1(150),ra2(150),dec1(150), *dec2(150),vst(150,14),vhii(150,14),vco(150,14),mux(150,3), *muy(150,3),dist(150,18),ang(150,8),ldiam(150,7),age(150,14), *mst(150,6),mhi(150,6),mhii(150,6),mco(150,6),mdust(150,6), *avis(150,5),colexc(150,14),turnof(150,7) character*5 vstref(150,14),vhiirf(150,14),vcoref(150,14), *muref(150,3),disref(150,18),angref(150,8),ldref(150,7), *ageref(150,14),espt(150,8),sptref(150,8),mstref(150,6), *mhiref(150,6),mhiirf(150,6),mcoref(150,6),mdsref(150,6), *avref(150,5),cexref(150,14),turref(150,7) character*10 name(150),name2(150),assoc(150) character*5 mask,ref1,ref2 character*1 a1(5),a2(5) character*1 msktyp equivalence (a1(1),ref1),(a2(1),ref2) data mask/'XXXXX'/ c c select type of masking (see below) 1 write(6,4000) 4000 format(1h0,'Select type of masking:'/ *5x,'(c) for chronological masking, or'/ *5x,'(s) for selection of specific references'/ *' NOTE: enter "r" if you want to know the masking rules') read(5,5000)msktyp 5000 format(a1) if (msktyp.eq.'c'.or.msktyp.eq.'C') then write(6,4001) 4001 format(1h ,'retain how many "most current" references?') read(5,*)nrefs nrefs = -nrefs ! to signal type of masking elseif (msktyp.eq.'s'.or.msktyp.eq.'S') then write(6,4002) 4002 format(1h ,'retain how many (1 or 2) specific references?') read(5,*)nrefs else call mskrul go to 1 endif if (msktyp.eq.'s'.or.msktyp.eq.'S') then c c enter codes of references to leave unmasked: write(6,3000) 3000 format(1h0,'enter code for the (first) reference to ', * 'leave unmasked:') read(5,1000)ref1 1000 format(a5) do 31 ichr=1,5 call upcase(a1(ichr)) ! alpha characters in codes are upper case 31 continue if (nrefs.gt.1) then write(6,3001) 3001 format(1h ,'enter code for second reference to leave ', * 'unmasked:') read(5,1000)ref2 do 32 ichr=1,5 call upcase(a2(ichr)) ! alpha characters in codes are upper case 32 continue endif endif c c loop for new cluster do 10 i=1,ncl if (nrefs.gt.0) go to 30 mskd = 1 ! flag to indicate that database is masked c c ------------------------------------------------------------- c FIRST TYPE OF MASKING (CHRONOLOGICAL) c _____________________________________________________________ c Rules: Mask all but the most current database entries for each c cluster characteristic. Abs(nrefs) dictates the number of c references to escape masking. More than abs(nrefs) entries c can remain unmasked if the database contains multiple entries c for the same (most current) year. In other words, abs(nrefs) c is actually the number of most current years to be left c unmasked. 20 continue nunmsk=iabs(nrefs) ! number of database entries to be left unmasked c c steps to mask database entries of cluster characteristic determined by ichr: ichr=1 ! characteristic 1 => stellar RV jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then c in what years were the cited references published? do 251 j=1,jmx index(j)=jmx call refyr(vstref(i,j),year(j)) 251 continue call decr(jmx,year,index) !determine chronological ranks of citations c perform masking operation do 261 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 261 vstref(i,j)=mask 261 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=2 ! characteristic 2 => H II region RV jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 252 j=1,jmx index(j)=jmx call refyr(vhiirf(i,j),year(j)) 252 continue call decr(jmx,year,index) do 262 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 262 vhiirf(i,j)=mask 262 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=3 ! characteristic 3 => molec cloud RV jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 253 j=1,jmx index(j)=jmx call refyr(vcoref(i,j),year(j)) 253 continue call decr(jmx,year,index) do 263 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 263 vcoref(i,j)=mask 263 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=4 ! characteristic 4 => proper motion jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 254 j=1,jmx index(j)=jmx call refyr(muref(i,j),year(j)) 254 continue call decr(jmx,year,index) do 264 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 264 muref(i,j)=mask 264 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=5 ! characteristic 5 => cluster distance jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 255 j=1,jmx index(j)=jmx call refyr(disref(i,j),year(j)) 255 continue call decr(jmx,year,index) do 265 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 265 disref(i,j)=mask 265 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=6 ! characteristic 6 => angular diameter jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 256 j=1,jmx index(j)=jmx call refyr(angref(i,j),year(j)) 256 continue call decr(jmx,year,index) do 266 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 266 angref(i,j)=mask 266 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=7 ! characteristic 7 => linear diameter jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 257 j=1,jmx index(j)=jmx call refyr(ldref(i,j),year(j)) 257 continue call decr(jmx,year,index) do 267 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 267 ldref(i,j)=mask 267 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=8 ! characteristic 8 => cluster age jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 258 j=1,jmx index(j)=jmx call refyr(ageref(i,j),year(j)) 258 continue call decr(jmx,year,index) do 268 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 268 ageref(i,j)=mask 268 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=9 ! characteristic 9 => earliest MS spectral type jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 259 j=1,jmx index(j)=jmx call refyr(sptref(i,j),year(j)) 259 continue call decr(jmx,year,index) do 269 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 269 sptref(i,j)=mask 269 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=10 ! characteristic 10 => stellar mass jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 230 j=1,jmx index(j)=jmx call refyr(mstref(i,j),year(j)) 230 continue call decr(jmx,year,index) do 240 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 240 mstref(i,j)=mask 240 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=11 ! characteristic 11 => H I mass jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 231 j=1,jmx index(j)=jmx call refyr(mhiref(i,j),year(j)) 231 continue call decr(jmx,year,index) do 241 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 241 mhiref(i,j)=mask 241 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=12 ! characteristic 12 => H II region mass jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 232 j=1,jmx index(j)=jmx call refyr(mhiirf(i,j),year(j)) 232 continue call decr(jmx,year,index) do 242 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 242 mhiirf(i,j)=mask 242 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=13 ! characteristic 13 => molec cloud mass jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 233 j=1,jmx index(j)=jmx call refyr(mcoref(i,j),year(j)) 233 continue call decr(jmx,year,index) do 243 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 243 mcoref(i,j)=mask 243 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=14 ! characteristic 14 => dust mass jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 234 j=1,jmx index(j)=jmx call refyr(mdsref(i,j),year(j)) 234 continue call decr(jmx,year,index) do 244 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 244 mdsref(i,j)=mask 244 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=15 ! characteristic 15 => visual extinction jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 235 j=1,jmx index(j)=jmx call refyr(avref(i,j),year(j)) 235 continue call decr(jmx,year,index) do 245 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 245 avref(i,j)=mask 245 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=16 ! characteristic 16 => color excess jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 236 j=1,jmx index(j)=jmx call refyr(cexref(i,j),year(j)) 236 continue call decr(jmx,year,index) do 246 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 246 cexref(i,j)=mask 246 continue endif c c steps for chronological masking of next cluster characteristic (see above c for explanatory comments) ichr=17 ! characteristic 17 => MS turnoff color jmx=nvalus(i,ichr) if (jmx.gt.nunmsk) then do 237 j=1,jmx index(j)=jmx call refyr(turref(i,j),year(j)) 237 continue call decr(jmx,year,index) do 247 j=1,jmx imsk=index(j)+nunmsk if (imsk.gt.jmx) go to 247 turref(i,j)=mask 247 continue endif 120 continue go to 10 c c ------------------------------------------------------------- c SECOND TYPE OF MASKING (SPECIFIED REFERENCES) c _____________________________________________________________ c Rules: mask all database entries except those from reference(s) c specified in character strings ref1 and ref2. nrefs determines c the number of references to escape masking (1 => only ref1; c 2 => both ref1 and ref2) 30 continue mskd = 1 ! flag to indicate that database is masked c c steps to perform Specified References masking of cluster characteristic 1: c (see above for meanings of cluster characteristics) jmx=nvalus(i,1) do 301 j=1,jmx if (vstref(i,j).eq.ref1) go to 301 if (nrefs.gt.1.and.vstref(i,j).eq.ref2) go to 301 vstref(i,j)=mask 301 continue c c steps to perform Specified References masking of cluster characteristic 2: jmx=nvalus(i,2) do 302 j=1,jmx if (vhiirf(i,j).eq.ref1) go to 302 if (nrefs.gt.1.and.vhiirf(i,j).eq.ref2) go to 302 vhiirf(i,j)=mask 302 continue c c steps to perform Specified References masking of cluster characteristic 3: jmx=nvalus(i,3) do 303 j=1,jmx if (vcoref(i,j).eq.ref1) go to 303 if (nrefs.gt.1.and.vcoref(i,j).eq.ref2) go to 303 vcoref(i,j)=mask 303 continue c c steps to perform Specified References masking of cluster characteristic 4: jmx=nvalus(i,4) do 304 j=1,jmx if (muref(i,j).eq.ref1) go to 304 if (nrefs.gt.1.and.muref(i,j).eq.ref2) go to 304 muref(i,j)=mask 304 continue c c steps to perform Specified References masking of cluster characteristic 5: jmx=nvalus(i,5) do 305 j=1,jmx if (disref(i,j).eq.ref1) go to 305 if (nrefs.gt.1.and.disref(i,j).eq.ref2) go to 305 disref(i,j)=mask 305 continue c c steps to perform Specified References masking of cluster characteristic 6: jmx=nvalus(i,6) do 306 j=1,jmx if (angref(i,j).eq.ref1) go to 306 if (nrefs.gt.1.and.angref(i,j).eq.ref2) go to 306 angref(i,j)=mask 306 continue c c steps to perform Specified References masking of cluster characteristic 7: jmx=nvalus(i,7) do 307 j=1,jmx if (ldref(i,j).eq.ref1) go to 307 if (nrefs.gt.1.and.ldref(i,j).eq.ref2) go to 307 ldref(i,j)=mask 307 continue c c steps to perform Specified References masking of cluster characteristic 8: jmx=nvalus(i,8) do 308 j=1,jmx if (ageref(i,j).eq.ref1) go to 308 if (nrefs.gt.1.and.ageref(i,j).eq.ref2) go to 308 ageref(i,j)=mask 308 continue c c steps to perform Specified References masking of cluster characteristic 9: jmx=nvalus(i,9) do 309 j=1,jmx if (sptref(i,j).eq.ref1) go to 309 if (nrefs.gt.1.and.sptref(i,j).eq.ref2) go to 309 sptref(i,j)=mask 309 continue c c steps to perform Specified References masking of cluster characteristic 10: jmx=nvalus(i,10) do 310 j=1,jmx if (mstref(i,j).eq.ref1) go to 310 if (nrefs.gt.1.and.mstref(i,j).eq.ref2) go to 310 mstref(i,j)=mask 310 continue c c steps to perform Specified References masking of cluster characteristic 11: jmx=nvalus(i,11) do 311 j=1,jmx if (mhiref(i,j).eq.ref1) go to 311 if (nrefs.gt.1.and.mhiref(i,j).eq.ref2) go to 311 mhiref(i,j)=mask 311 continue c c steps to perform Specified References masking of cluster characteristic 12: jmx=nvalus(i,12) do 312 j=1,jmx if (mhiirf(i,j).eq.ref1) go to 312 if (nrefs.gt.1.and.mhiirf(i,j).eq.ref2) go to 312 mhiirf(i,j)=mask 312 continue c c steps to perform Specified References masking of cluster characteristic 13: jmx=nvalus(i,13) do 313 j=1,jmx if (mcoref(i,j).eq.ref1) go to 313 if (nrefs.gt.1.and.mcoref(i,j).eq.ref2) go to 313 mcoref(i,j)=mask 313 continue c c steps to perform Specified References masking of cluster characteristic 14: jmx=nvalus(i,14) do 314 j=1,jmx if (mdsref(i,j).eq.ref1) go to 314 if (nrefs.gt.1.and.mdsref(i,j).eq.ref2) go to 314 mdsref(i,j)=mask 314 continue c c steps to perform Specified References masking of cluster characteristic 15: jmx=nvalus(i,15) do 315 j=1,jmx if (avref(i,j).eq.ref1) go to 315 if (nrefs.gt.1.and.avref(i,j).eq.ref2) go to 315 avref(i,j)=mask 315 continue c c steps to perform Specified References masking of cluster characteristic 16: jmx=nvalus(i,16) do 316 j=1,jmx if (cexref(i,j).eq.ref1) go to 316 if (nrefs.gt.1.and.cexref(i,j).eq.ref2) go to 316 cexref(i,j)=mask 316 continue c c steps to perform Specified References masking of cluster characteristic 17: jmx=nvalus(i,17) do 317 j=1,jmx if (turref(i,j).eq.ref1) go to 317 if (nrefs.gt.1.and.turref(i,j).eq.ref2) go to 317 turref(i,j)=mask 317 continue 10 continue return end SUBROUTINE MSKRUL c ************************************************************************** c *** this routine displays the rules used in the masking procedure *** c ************************************************************************** write(6,1000) 1000 format(1h0,'MASKING is the procedure by which some database'/ *' entries can be ignored in subsequent operations (e.g.,'/ *' averaging). MASKED references are the ones that are'/ *' ignored and UNMASKED references are the ones that are'/ *' included. Since the masking operation alters the arrays'/ *' of references, you may desire to RESTORE the initial'/ *' database for later operations (see main menu).'/) write(6,2000) 2000 format(1h0,'CHRONOLOGICAL MASKING:'/) write(6,2001) 2001 format(1h , *5x,'Rules: Mask all but the most current database entries'/ *5x,'for each cluster characteristic. Enter the number of'/ *5x,'references to leave unmasked. More than that number of'/ *5x,'entries can remain unmasked if the database contains'/ *5x,'multiple entries for the same (most current) year.') write(6,3000) 3000 format(1h0,'MASKING OF ALL BUT SPECIFIC REFERENCES') write(6,3001) 3001 format(1h , *5x,'Rules: mask all database entries except the one (or'/ *5x,'two) specified.'/) return end SUBROUTINE DECR(JMAX,YR,IND) c ************************************************************************** c *** this routine calculates the chronological ranks of citations to *** c *** be used, e.g., in Chronological Masking (see subroutine MASKER for*** c *** explanation). Rank of citation is decreased if citation is older *** c *** than other citations in list for a given cluster and cluster *** c *** characteristic. *** c ************************************************************************** integer ind(18),yr(18) do 10 j1=1,jmax do 20 j2=1,jmax if (j2.eq.j1) go to 20 if (yr(j2).gt.yr(j1)) ind(j1)=ind(j1)-1 20 continue 10 continue return end SUBROUTINE AVERAG(IUNIT,ISERNO,NCL) c ********************************************************************** c *** this routine computes averages and standard deviations of *** c *** those cluster characteristics for which the database contains *** c *** multiple, unmasked entries. The parameter 'ichr' determines *** c *** which characteristic is to be averaged. *** c ********************************************************************** common/data/oclno,name,sharp,west,assoc,name2,glon,glat, *ra1,ra2,dec1,dec2,vst,vhii,vco,mux,muy,dist,ang,ldiam, *age,espt,mst,mhi,mhii,mco,mdust,prio,obs,avis,colexc, *nvalus,turnof common/refs/vstref,vhiirf,vcoref,muref,disref,angref,ldref, *ageref,sptref,mstref,mhiref,mhiirf,mcoref,mdsref,avref, *cexref,turref integer iserno(150),oclno(150),sharp(150),west(150), *prio(150),obs(150),nvalus(150,17) real glon(150),glat(150),ra1(150),ra2(150),dec1(150), *dec2(150),vst(150,14),vhii(150,14),vco(150,14),mux(150,3), *muy(150,3),dist(150,18),ang(150,8),ldiam(150,7),age(150,14), *mst(150,6),mhi(150,6),mhii(150,6),mco(150,6),mdust(150,6), *avis(150,5),colexc(150,14),turnof(150,7) character*5 vstref(150,14),vhiirf(150,14),vcoref(150,14), *muref(150,3),disref(150,18),angref(150,8),ldref(150,7), *ageref(150,14),espt(150,8),sptref(150,8),mstref(150,6), *mhiref(150,6),mhiirf(150,6),mcoref(150,6),mdsref(150,6), *avref(150,5),cexref(150,14),turref(150,7) character*10 name(150),name2(150),assoc(150) character*5 mask integer nvals(150) real avg(150),sd(150) data mask/'XXXXX'/ c c select parameter to be averaged 2 write(6,3000) 3000 format(1h0,'Select parameter to be averaged:'/ * 5x,'1 => stellar radial velocity'/ * 5x,'2 => H II region radial velocity'/ * 5x,'3 => molecular cloud radial velocity'/ * 5x,'4 => cluster proper motion'/ * 5x,'5 => cluster distance'/ * 5x,'6 => cluster angular diameter'/ * 5x,'7 => cluster linear diameter'/ * 5x,'8 => cluster age'/ * 5x,'9 => main sequence turnoff color'/ * 4x,'10 => stellar mass'/ * 4x,'11 => associated H I mass'/ * 4x,'12 => associated ionized gas mass'/ * 4x,'13 => associated molecular cloud mass'/ * 4x,'14 => associated dust mass'/ * 4x,'15 => visual extinction'/ * 4x,'16 => reddening') read(5,*)ichr if (ichr.lt.1.or.ichr.gt.16.or.ichr.eq.90) then write(6,3001) 3001 format(1h ,'Selected parameter type is invalid.', * ' Try again.'/) go to 2 endif c c consider only selected clusters (according to value of iserno) 1 do 5 i=1,ncl if (iserno(i).eq.0) go to 5 c c initialize count, sum(x) and sum(x*x) nvals(i)=0 sumx=0.0 sumxx=0.0 if (ichr.ne.45) then go to (10,20,30,40,50,60,70,80,90,100, * 110,120,130,140,150,160),ichr else go to 45 endif c c sum stellar radial velocities 10 continue jmx=nvalus(i,1) if (jmx.eq.0) go to 180 do 11 j=1,jmx if (vstref(i,j).eq.mask) go to 11 nvals(i)=nvals(i)+1 sumx=sumx+vst(i,j) sumxx=sumxx+vst(i,j)*vst(i,j) 11 continue go to 180 c c sum H II region radial velocities 20 continue jmx=nvalus(i,2) if (jmx.eq.0) go to 180 do 21 j=1,jmx if (vhiirf(i,j).eq.mask) go to 21 nvals(i)=nvals(i)+1 sumx=sumx+vhii(i,j) sumxx=sumxx+vhii(i,j)*vhii(i,j) 21 continue go to 180 c c sum CO radial velocities 30 continue jmx=nvalus(i,3) if (jmx.eq.0) go to 180 do 31 j=1,jmx if (vcoref(i,j).eq.mask) go to 31 nvals(i)=nvals(i)+1 sumx=sumx+vco(i,j) sumxx=sumxx+vco(i,j)*vco(i,j) 31 continue go to 180 c c sum proper motions 40 continue jmx=nvalus(i,4) if (jmx.eq.0) go to 180 do 41 j=1,jmx if (muref(i,j).eq.mask) go to 41 nvals(i)=nvals(i)+1 sumx=sumx+mux(i,j) sumxx=sumxx+mux(i,j)*mux(i,j) 41 continue go to 180 45 continue jmx=nvalus(i,4) if (jmx.eq.0) go to 180 do 46 j=1,jmx if (muref(i,j).eq.mask) go to 46 nvals(i)=nvals(i)+1 sumx=sumx+muy(i,j) sumxx=sumxx+muy(i,j)*muy(i,j) 46 continue go to 180 c c sum distances 50 continue jmx=nvalus(i,5) if (jmx.eq.0) go to 180 do 51 j=1,jmx if (disref(i,j).eq.mask) go to 51 nvals(i)=nvals(i)+1 sumx=sumx+dist(i,j) sumxx=sumxx+dist(i,j)*dist(i,j) 51 continue go to 180 c c sum angular diameters 60 continue jmx=nvalus(i,6) if (jmx.eq.0) go to 180 do 61 j=1,jmx if (angref(i,j).eq.mask) go to 61 nvals(i)=nvals(i)+1 sumx=sumx+ang(i,j) sumxx=sumxx+ang(i,j)*ang(i,j) 61 continue go to 180 c c sum linear diameters 70 continue jmx=nvalus(i,7) if (jmx.eq.0) go to 180 do 71 j=1,jmx if (ldref(i,j).eq.mask) go to 71 nvals(i)=nvals(i)+1 sumx=sumx+ldiam(i,j) sumxx=sumxx+ldiam(i,j)*ldiam(i,j) 71 continue go to 180 c c sum ages 80 continue jmx=nvalus(i,8) if (jmx.eq.0) go to 180 do 81 j=1,jmx if (ageref(i,j).eq.mask) go to 81 nvals(i)=nvals(i)+1 sumx=sumx+age(i,j) sumxx=sumxx+age(i,j)*age(i,j) 81 continue go to 180 c c sum main sequence turnoff color values 90 continue jmx=nvalus(i,17) if (jmx.eq.0) go to 180 do 91 j=1,jmx if (turref(i,j).eq.mask) go to 91 nvals(i)=nvals(i)+1 sumx=sumx+turnof(i,j) sumxx=sumxx+turnof(i,j)*turnof(i,j) 91 continue go to 180 c c sum stellar mass values 100 continue jmx=nvalus(i,10) if (jmx.eq.0) go to 180 do 101 j=1,jmx if (mstref(i,j).eq.mask) go to 101 nvals(i)=nvals(i)+1 sumx=sumx+mst(i,j) sumxx=sumxx+mst(i,j)*mst(i,j) 101 continue go to 180 c c sum estimates for mass in H I clouds 110 continue jmx=nvalus(i,11) if (jmx.eq.0) go to 180 do 111 j=1,jmx if (mhiref(i,j).eq.mask) go to 111 nvals(i)=nvals(i)+1 sumx=sumx+mhi(i,j) sumxx=sumxx+mhi(i,j)*mhi(i,j) 111 continue go to 180 c c sum estimates for ionized mass 120 continue jmx=nvalus(i,12) if (jmx.eq.0) go to 180 do 121 j=1,jmx if (mhiirf(i,j).eq.mask) go to 121 nvals(i)=nvals(i)+1 sumx=sumx+mhii(i,j) sumxx=sumxx+mhii(i,j)*mhii(i,j) 121 continue go to 180 c c sum estimates for mass in CO clouds 130 continue jmx=nvalus(i,13) if (jmx.eq.0) go to 180 do 131 j=1,jmx if (mcoref(i,j).eq.mask) go to 131 nvals(i)=nvals(i)+1 sumx=sumx+mco(i,j) sumxx=sumxx+mco(i,j)*mco(i,j) 131 continue go to 180 c c sum estimates for mass in the form of dust 140 continue jmx=nvalus(i,14) if (jmx.eq.0) go to 180 do 141 j=1,jmx if (mdsref(i,j).eq.mask) go to 141 nvals(i)=nvals(i)+1 sumx=sumx+mdust(i,j) sumxx=sumxx+mdust(i,j)*mdust(i,j) 141 continue go to 180 c c sum visual extinction values 150 continue jmx=nvalus(i,15) if (jmx.eq.0) go to 180 do 151 j=1,jmx if (avref(i,j).eq.mask) go to 151 nvals(i)=nvals(i)+1 sumx=sumx+avis(i,j) sumxx=sumxx+avis(i,j)*avis(i,j) 151 continue go to 180 c c sum color excess values 160 continue jmx=nvalus(i,16) if (jmx.eq.0) go to 180 do 161 j=1,jmx if (cexref(i,j).eq.mask) go to 161 nvals(i)=nvals(i)+1 sumx=sumx+colexc(i,j) sumxx=sumxx+colexc(i,j)*colexc(i,j) 161 continue go to 180 c c compute average and standard deviation of parameter 180 continue if (nvals(i).eq.0) then avg(i)=999. sd(i)=999. else avg(i)=sumx/float(nvals(i)) sd(i)=0.0 if (nvals(i).ge.2) then arg=(sumxx-2.0*avg(i)*sumx+float(nvals(i))*avg(i)* * avg(i))/float(nvals(i)-1) if (arg.ge.0.0.or.abs(arg).ge.1.0e-5) sd(i)=sqrt(arg) endif endif 5 continue c c tabulate computed averages: if (ichr.ne.45) write(iunit,4500) 4500 format(1h1,'TABLE OF AVERAGED PARAMETERS:'/) if (iunit.ne.6.and.ichr.ne.45)write(6,4501)iunit 4501 format(1h0,'Table of averaged parameters written to unit',i3) if (ichr.eq.1)write(iunit,4110) 4110 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' Cl RV ',1x,'s.d. (km/s)'/) if (ichr.eq.2)write(iunit,4120) 4120 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * 'H II RV',1x,'s.d. (km/s)'/) if (ichr.eq.3)write(iunit,4130) 4130 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' CO RV ',1x,'s.d. (km/s)'/) if (ichr.eq.4)write(iunit,4140) 4140 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' MU X ',1x,'s.d. ("/100yr)'/) if (ichr.eq.45)write(iunit,4145) 4145 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' MU Y ',1x,'s.d. ("/100yr)'/) if (ichr.eq.5)write(iunit,4150) 4150 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' d ',1x,'s.d. (kpc)'/) if (ichr.eq.6)write(iunit,4160) 4160 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * 'Ang Diam',1x,'s.d. (arcmin)'/) if (ichr.eq.7)write(iunit,4170) 4170 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * 'Lin Diam',1x,'s.d. (pc)'/) if (ichr.eq.8)write(iunit,4180) 4180 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' Age ',1x,'s.d. (Myr)'/) if (ichr.eq.9)write(iunit,4190) 4190 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' (B-V)t ',1x,'s.d. (mag)'/) if (ichr.eq.10)write(iunit,4200) 4200 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' Cl Mass',1x,'s.d. (Mo)'/) if (ichr.eq.11)write(iunit,4210) 4210 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * 'H I Mass',1x,'s.d. (Mo)'/) if (ichr.eq.12)write(iunit,4220) 4220 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * 'HII Mass',1x,'s.d. (Mo)'/) if (ichr.eq.13)write(iunit,4230) 4230 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' H2 Mass',1x,'s.d. (Mo)'/) if (ichr.eq.14)write(iunit,4240) 4240 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * 'Dst Mass',1x,'s.d. (Mo)'/) if (ichr.eq.15)write(iunit,4250) 4250 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' AV ',1x,'s.d. (mag)'/) if (ichr.eq.16)write(iunit,4260) 4260 format(1h0,'DB#',2X,'OCL#',5X,'NAME',6x,'N',3x, * ' E(B-V)',1x,'s.d. (mag)'/) do 300 i=1,ncl if (iserno(i).eq.0) go to 300 if (nvals(i).eq.0) then write(iunit,4000)i,oclno(i),name(i) 4000 format(1h ,i3,2x,i4,2x,a10,2x, * 'no database entries to average') elseif(nvals(i).eq.1) then write(iunit,4001)i,oclno(i),name(i),nvals(i),avg(i) 4001 format(1h ,i3,2x,i4,2x,a10,i5,2x,f8.2,3x, * 'only one entry => no s.d.') else write(iunit,4002)i,oclno(i),name(i),nvals(i), * avg(i),sd(i) 4002 format(1h ,i3,2x,i4,2x,a10,i5,2x,f8.2,1x,f8.2) endif 300 continue if (ichr.eq.4) then ! if averaging proper motions, then ichr = 45 ! return to calculate proper motion in declination go to 1 endif return end SUBROUTINE REFYR(REFDUM,YR) c ************************************************************************ c *** this routine extracts the last two digits from a reference code *** c *** to specify the year in which the corresponding reference was *** c *** published. *** c ************************************************************************ character*5 refdum integer check,yr,y1,y10 character*1 dgchk1,dgchk2,digit(10) data digit/'0','1','2','3','4','5','6','7','8','9'/ check=0 c c initialize yr to zero (this is the value returned if at least one of c the last two digits of the reference code is non-numeric) yr = 0 c c extract the single years digit decode(10,1015,refdum)dgchk1 1015 format(4x,a1) c c extract the tens of years digit decode(10,1016,refdum)dgchk2 1016 format(3x,a1) c c check for non-numeric characters (check non-zero => numeric) do 18 i=1,10 if (dgchk1.ne.digit(i)) go to 18 check=1 y1 = i - 1 ! integer equivalent of digit(i) go to 19 18 continue 19 if (check.ne.1) go to 20 ! no calculation if non-numeric c c do 17 i=1,10 if (dgchk2.ne.digit(i)) go to 17 check=2 y10 = i - 1 ! integer equivalent of digit(i) go to 16 17 continue 16 if (check.ne.2) go to 20 ! no calculation if non-numeric c c calculate value of publication year yr = 10*y10 + y1 20 return end SUBROUTINE FILER(FNAME) c ************************************************************************* c *** this routine enables user to specify name of a disk data file *** c *** to create for output. *** c ************************************************************************* character*80 fname 1010 write(*,1011) 1011 format(' ENTER FILE NAME: ',$) read(*,1012,end=99,err=1010)len,fname 1012 format(q,a) 99 if (len.eq.0) go to 1010 return end