integer function rdascat1 (luin,cname,psrname,npsr,nbin) c Subroutine to read pulsar catalogue data from an ascii file ASCAT1.DAT. c The file is produced by the program PSRLIST c AGL Sept 1990, May 1991 as READASCAT c RNM/JHT January, 1993. Revised ascat and array format. c Up to 3 planets. Names changed to ASCAT1 and RDASCAT1 c PAH/MXB Environment variable for ascat1.dat directory. c RNM March 1, 1993. New variables for distance codes. c LUIN is the logical unit from which the catalogue is read upon c first entry. c CNAME is a code for name class: c if cname(1:1) is B (or b), psrname is assumed to be B1950 c if cname(1:1) is J (or j), psrname is assumed to be J2000 c if cname(1:1) is A (or a), psrname may be either B or J c PSRNAME is the name of the pulsar whose data is required. If this c parameter contains ' ', then the reading will be sequential. c NPSR is the total number of pulsars in the file (returned) c NBIN is the total number of orbiting companions for which data is in c the file (returned). c The value returned is 1 if the operation is successful. c The calling module must contain 'ascat1.def' include statement which c contains the definitions of the parameters. See this for more information. c The calling module may also include 'psrcat1.def' which defines the arrays c into which READASCAT reads data from the disk file. implicit none include 'ascat1.def' include 'psrcat1.def' integer*4 rdascat1,luin,npsr,nbin,i,j,k,length,npulsar,nbinary, & ldir character cbuf*80,psrname*(*),psrnam*12,cname*(*),cnam*1, & directory*32 logical first data first/.true./ if (first) then call getenv('PSRCATDIR',directory) ldir = index(directory,' ')-1 open(unit=luin,file=directory(1:ldir)//'ascat1.dat', & status='old',err=888) c Vax open(unit=luin,file='psrcatdir:ascat1.dat', c Vax: status='old',carriagecontrol='list',readonly,err=888) c In the file, no line is longer than 80 characters. Non-binary pulsars c have seven lines of data. Binary/multiple pulsars have three extra lines for c each companion. The flag 'ibin', on the end of the seventh card, is set to c the number of companions (currently limited to 3 by ascat1.def) if binary data c follows. j=1 k=0 10 continue read(luin,1000,end=999)cbuf 1000 format(a) read(cbuf,1005)jname(j),bname(j),ra2000(j),ra1950(j),rae(j) 1005 format(a12,a8,2f16.12,1p,e10.2,0p) read(luin,1000,end=999)cbuf read(cbuf,1003)dec2000(j),dec1950(j),dece(j),nobs(j), & dmin(j),dmax(j),dist(j),dflag(j),lcode(j),ucode(j) 1003 format(2f16.12,1p,e10.2,0p,i6,3x,3f8.2,i2,1x,2a1) read(luin,1000,end=999)cbuf read(cbuf,1010)gl(j),gb(j), - pmra(j),pmrae(j),pmdec(j),pmdece(j),posepch(j) 1010 format(2f10.4,2(f10.4,f8.4),f10.2) read(luin,1000,end=999)cbuf read(cbuf,1020)p(j),pe(j),pdot(j),pdote(j),epoch(j) 1020 format(f22.19,1p,e10.2,d16.8,e10.2,0p,f14.6) read(luin,1000,end=999)cbuf read(cbuf,1022)f2(j),f2e(j),f3(j),f3e(j),altsc(j),scflag(j), + tbg(j),ntype(j) 1022 format(1p,d14.6,e10.2,d14.6,e10.2,0p,f6.2,i2,f8.1,o6) read(luin,1000,end=999)cbuf read(cbuf,1030)dm(j),dme(j),rm(j),rme(j),we(j),w50(j),w10(j) 1030 format(f14.5,f12.5,2f12.3,3f10.3) read(luin,1000,end=999)cbuf read(cbuf,1040)s400(j),s600(j),s1400(j),modcode(j),limcode(j), _ dmodel(j),allum(j),albsurf(j),alage(j),aledot(j),ibin(j) 1040 format(3f8.2,2i2,f8.4,4f10.3,3x,i4) if(ibin(j).gt.0)then kbin(j)=k+1 do i=1,ibin(j) k=k+1 read(luin,1000,end=999)cbuf read(cbuf,1050)pbin(k),pbine(k),xbin(k),xbine(k), - wbin(k),wbine(k) 1050 format(f18.12,1p,e10.2,0p,f15.8,1p,e10.2,0p,f12.6,f10.6) read(luin,1000,end=999)cbuf read(cbuf,1060)wdotbin(k),wdotbine(k),eccbin(k),eccbine(k), - epbin(k),epbine(k) 1060 format(f12.6,f10.6,f12.9,1p,e10.2,0p,f18.10,1p,e10.2,0p) read(luin,1000,end=999)cbuf read(cbuf,1070)gambin(k),gambine(k),pdbin(k),pdbine(k), - sinibin(k),sinibine(k),rbin(k),rbine(k) 1070 format(1p,2(e12.4,e10.2),0p,f8.4,f6.2,1p,e12.4,e10.2,0p) enddo endif j=j+1 goto 10 999 npulsar=j-1 nbinary=k j=1 close(luin) first=.false. endif if(psrname.ne.' ') then psrnam=psrname call upcase(psrnam) cnam=cname(1:1) call upcase(cnam) do j=1,npulsar if(psrnam(1:length(bname(j))).eq.bname(j)(1:length(bname(j))) : .and.(cnam.eq.'B'.or.cnam.eq.'A') : .and.(length(bname(j)).ne.0)) goto 20 if(psrnam(1:length(jname(j))).eq.jname(j)(1:length(jname(j))) : .and.(cnam.eq.'J'.or.cnam.eq.'A')) goto 20 enddo rdascat1=0 go to 800 else if(j.gt.npulsar)then rdascat1=0 go to 800 endif endif 20 cat_bname =bname(j) cat_jname =jname(j) cat_ra2000 =ra2000(j) cat_dec2000 =dec2000(j) cat_ra1950 =ra1950(j) cat_dec1950 =dec1950(j) cat_ra_err =rae(j) cat_dec_err =dece(j) cat_pmra =pmra(j) cat_pmra_err =pmrae(j) cat_pmdec =pmdec(j) cat_pmdec_err =pmdece(j) cat_posepch =posepch(j) cat_gl =gl(j) cat_gb =gb(j) cat_pb =p(j) cat_pb_err =pe(j) cat_pbdot =pdot(j) cat_pbdot_err =pdote(j) cat_f2 =f2(j) cat_f2_err =f2e(j) cat_f3 =f3(j) cat_f3_err =f3e(j) cat_pbepoch =epoch(j) cat_dm =dm(j) cat_dm_err =dme(j) cat_rm =rm(j) cat_rm_err =rme(j) cat_we =we(j) cat_w50 =w50(j) cat_w10 =w10(j) cat_s400 =s400(j) cat_s600 =s600(j) cat_s1400 =s1400(j) cat_altsc =altsc(j) cat_scflag =scflag(j) cat_dist =dist(j) cat_dflag =dflag(j) cat_dmin =dmin(j) cat_dmax =dmax(j) cat_dmodel =dmodel(j) cat_lcode =lcode(j) cat_ucode =ucode(j) cat_mcode =modcode(j) cat_mdflag =limcode(j) cat_nobs =nobs(j) cat_ntype =ntype(j) cat_tbg =tbg(j) cat_aledot =aledot(j) cat_allum =allum(j) cat_albsurf =albsurf(j) cat_alage =alage(j) cat_ibin =ibin(j) if(cat_ibin.gt.0)then k=kbin(j) cat_epbin =epbin(k) cat_epbin_err =epbine(k) cat_pbin =pbin(k) cat_pbin_err =pbine(k) cat_xbin =xbin(k) cat_xbin_err =xbine(k) cat_wbin =wbin(k) cat_wbin_err =wbine(k) cat_wdotbin =wdotbin(k) cat_wdotbin_err =wdotbine(k) cat_eccbin =eccbin(k) cat_eccbin_err =eccbine(k) cat_gambin =gambin(k) cat_gambin_err =gambine(k) cat_pdbin =pdbin(k) cat_pdbin_err =pdbine(k) cat_sinibin =sinibin(k) cat_sinibin_err =sinibine(k) cat_rbin =rbin(k) cat_rbin_err =rbine(k) else cat_pbin=0.d0 endif if(cat_ibin.gt.1)then k=k+1 cat_epbin1 =epbin(k) cat_epbin1_err =epbine(k) cat_pbin1 =pbin(k) cat_pbin1_err =pbine(k) cat_xbin1 =xbin(k) cat_xbin1_err =xbine(k) cat_wbin1 =wbin(k) cat_wbin1_err =wbine(k) cat_wdotbin1 =wdotbin(k) cat_wdotbin1_err =wdotbine(k) cat_eccbin1 =eccbin(k) cat_eccbin1_err =eccbine(k) cat_gambin1 =gambin(k) cat_gambin1_err =gambine(k) cat_pdbin1 =pdbin(k) cat_pdbin1_err =pdbine(k) cat_sinibin1 =sinibin(k) cat_sinibin1_err =sinibine(k) cat_rbin1 =rbin(k) cat_rbin1_err =rbine(k) else cat_pbin1=0.d0 endif if(cat_ibin.gt.2)then k=k+1 cat_epbin2 =epbin(k) cat_epbin2_err =epbine(k) cat_pbin2 =pbin(k) cat_pbin2_err =pbine(k) cat_xbin2 =xbin(k) cat_xbin2_err =xbine(k) cat_wbin2 =wbin(k) cat_wbin2_err =wbine(k) cat_wdotbin2 =wdotbin(k) cat_wdotbin2_err =wdotbine(k) cat_eccbin2 =eccbin(k) cat_eccbin2_err =eccbine(k) cat_gambin2 =gambin(k) cat_gambin2_err =gambine(k) cat_pdbin2 =pdbin(k) cat_pdbin2_err =pdbine(k) cat_sinibin2 =sinibin(k) cat_sinibin2_err =sinibine(k) cat_rbin2 =rbin(k) cat_rbin2_err =rbine(k) else cat_pbin2=0.d0 endif if(cat_ibin.gt.3)stop 'Too many planets!' j=j+1 rdascat1=1 800 npsr=npulsar nbin=nbinary return 888 write(*,'(a)') ' Failure opening the catalogue file ascat1.dat' rdascat1=0 end ******************************************************************************* function length(string) ******************************************************************************* c returns the length of 'string' excluding any trailing spaces. c character string*(*) c c obtain the location of the last non-space character. c do 1 i=len(string),1,-1 if(string(i:i).ne.' ') then c c length found. c length=i return endif 1 continue c c string is all spaces or zero length. c length=0 return c c end of integer function length. c end ********************************************************************* subroutine upcase(w) ********************************************************************* C Converts string (up to first blank) to upper case. character*(*) w do 10 i=1,len(w) if(w(i:i).eq.' ') go to 20 j=ichar(w(i:i)) if(j.ge.97.and.j.le.122) w(i:i)=char(j-32) 10 continue 20 return end