CCC Program rderlc#t.for . Read ZABYC#T.FIN catalog data CCC ERLC#T.INF catalog info file CCC Last modification 22/03/2000 CdV CCC New Version revised catalog-data 21/03/2000 IMPLICIT NONE integer I,J,K,count,N447,NSMAX PARAMETER(NSMAX=5000,N447=447) integer MERK(1:N447),ZQ(1:N447,1:2) character*8 CIAU(1:N447),CSOURCE character*2 CZB(1:N447),CZBX character*7 MFILE(1:N447),MSP(1:3),CMFID,FSEL,MSEL character*70 FOUT1,FOUT2 double precision MEPOC(1:N447),EPOC(1:3),EPC,FAC integer NS(1:N447),NP(1:N447),NF(1:4),COUNTZ1,COUNTB1,IFIND, + COUNTZB1 CCC Variables for ZABYC#T.FIN Catalog-Data reading integer N1,N2,IJ,STARNR,CAT,ZSS,IMAG,ISP,INP,ICAT(1:NSMAX,1:6) double precision RA,DK,MRA,MDK,RCAT(1:NSMAX,1:4),RA0,DK0 double precision RMAG(1:NSMAX),RACOS CCC SUBROUTINE SKCSX4 ,output RA,DK sexagesimal Double precision RAX, DKX Character*13 CREKT,CDEKL FAC=3.141592654D0/(648000.0D0) CCC read IAU radio source name, example: 0420-014 1 write(*,*) 'CSOURCE= ' read(*,*) CSOURCE write(*,*) CSOURCE write(*,*) ' ' CCC terminate program loop:: use ### for radio source name input if(CSOURCE.EQ.'###') goto 1000 count=0 countZ1=0 countB1=0 COUNTZB1=0 DO 2 I=1,N447 MERK(i)=0 2 continue IFIND=0 open(20,FILE='erlc#t.inf',Status='OLD') DO 20 J=1,N447 read(20,*) MFILE(J),NS(J),CIAU(J),CZB(J),MERK(J) + ,NP(J),MEPOC(J),ZQ(J,1),ZQ(J,2) IF(CSOURCE.EQ.CIAU(J)) then IFIND=1 COUNT=COUNT+1 NF(1)=COUNT NF(COUNT+1)=J MSP(COUNT)=MFILE(J) EPOC(COUNT)=MEPOC(J) end if 20 continue close(20) IF(IFIND.EQ.0) then write(*,*) 'Source not found' goto 1 end if write(*,*) '-----------------------------------------------------' write(*,'(1X,A21,2X,4I5)') 'NDATA, Data set Nos. ', + (NF(K),K=1,NF(1)+1) write(*,'(1X,A21,8X,4A5)') 'Catalog ID (Z or B) ', + (CZB(NF(K)),K=2,NF(1)+1) write(*,'(1X,A13,10X,3A10)') 'Data set ID ', + (MSP(K),K=1,NF(1)) write(*,'(1X,A16,7X,3F10.4)') 'Data set epoch ', + (EPOC(K),K=1,NF(1)) DO 99 J=2,NF(1)+1 write(*,'(1X,A36,2X)') 'Data set No. Catalog line numbers: ' write(*,'(1X,3I9)') NF(J),ZQ(NF(J),1),ZQ(NF(J),2) 99 continue write(*,*) '-----------------------------------------------------' IF(NF(1).GT.1) then write(*,'(1X,I4,2X,A15,2X,A8)') NF(1), ' data sets for ',CSOURCE write(*,*) 'Select field-name [MxxxxxH]= ' read(*,*) FSEL IJ=0 MSEL='#######' CZBX='##' DO 21 J=1,NF(1) IF (FSEL.EQ.MSP(J)) then IJ=NF(J+1) N1=ZQ(IJ,1) MSEL=FSEL EPC=EPOC(J) CZBX=CZB(IJ) goto 101 end if 21 continue 101 continue IF(IJ.EQ.0) then write(*,*) 'FSEL invalid Member-name ' goto 1 end if end if CCC ============= Read Catalog-Data ======================== CCC select 1 data set, some radio sources may have <= 3 different CCC data sets (different epochs and/or telescopes) IF(NF(1).EQ.1) then N1=ZQ(NF(2),1) IJ=NF(2) MSEL=MSP(1) EPC=EPOC(1) CZBX=CZB(IJ) end if write(*,*) 'Line start= ',N1 CC OPEN(30,FILE='ZABYC#T.FIN',ACTION='READ',STATUS='OLD') OPEN(30,FILE='ZABYC#T.FIN',STATUS='OLD') DO 24 K=1,N1 read(30,*) 24 continue backspace 30 CCC write selected data set to file (file expected in same directory) FOUT1=MSEL//'.ERL' FOUT2=MSEL//'.AXU' write(*,*) FOUT1 write(*,*) FOUT2 OPEN(50,FILE=FOUT1,STATUS='UNKNOWN') OPEN(60,FILE=FOUT2,STATUS='UNKNOWN') write(50,'(1X,A8,2X,A7,2X,A2,2X,I5,2X,F10.4)') CSOURCE,MSEL,CZBX, + NS(IJ),EPC C write(60,'(1X,A8,2X,A7,2X,A2,2X,I5,2X,F10.4)') CSOURCE,MSEL,CZBX, C + NS(IJ),EPC RA0=0.0D0 DK0=0.0D0 write(*,*) 'IJ= ',IJ write(*,'(1X,2A10)') 'FILE= ',FSEL write(*,*) 'Number of stars in file= ',NS(IJ) DO 25 K=1,NS(IJ) read(30,*) STARNR,CAT,ZSS,IMAG,ISP,RA,DK,MRA,MDK,INP,CMFID IF(MFILE(IJ).NE.CMFID) then write(*,*) 'Data in File not correct' write(*,*) 'J/CMFID= ', K,' ',CMFID CLOSE(30) CLOSE(50) goto 1 end if ICAT(K,1)=STARNR ICAT(K,2)=CAT ICAT(K,3)=ZSS ICAT(K,4)=IMAG ICAT(K,5)=ISP ICAT(K,6)=INP RCAT(K,1)=RA RCAT(K,2)=DK RCAT(K,3)=MRA RCAT(K,4)=MDK RA0=RA0+RA DK0=DK0+DK RMAG(K)=DBLE(IMAG)*0.01D0 write(50,'(I10,I5,I2,I5,I4,2F15.3,2X,2F7.3,I5,1X,A7)') + STARNR,CAT,ZSS,IMAG,ISP,RA,DK,MRA,MDK,INP,CMFID 25 continue write(*,*) '----------------------------------------------------' close(30) RA0=RA0/DBLE(NS(IJ)) DK0=DK0/DBLE(NS(IJ)) write(*,*) 'approximate field center [arcsec]: ' write(*,*) 'RA0/DK0= ',RA0,DK0 CALL SKCSX4 (RA0,DK0,CREKT,CDEKL) write(*,*) 'approximate field center [sexagesimal]: ' write(*,'(2X,2A16)') CREKT,CDEKL DO 26 K=1,NS(IJ) RCAT(K,1)=RCAT(K,1)-RA0 RACOS=RCAT(K,1)*DCOS(DK0*FAC) RCAT(K,2)=RCAT(K,2)-DK0 write(60,'(1X,I10,3F15.3,2X,F7.2)') ICAT(K,1), + RCAT(K,1),RACOS,RCAT(K,2),RMAG(K) 26 continue close(50) close(60) goto 1 1000 continue end C FORTRAN-UNTERPROGRAMM ZUR TRANSFORMATION EINES DATENPAARES C VON DEZIMALER (BOGENSEKUNDEN) IN SEXAGESIMALE (STUNDEN,GRAD) C TEILUNG SUBROUTINE SKCSX4 (RA,DK,CREKT,CDEKL) C 01. ERLAEUTERUNGEN C GEGEBEN SIND C DIE DOPPELTGENAUEN WINKEL RA UND DK IN BOGENSEKUNDEN. C AUSGEGEBEN WERDEN C RA UND DK ALS CHARACTER*12-GROESSEN. C RA WIRD AUF CREKT, DK MIT VORZEICHEN AUF CDEKL GESCHRIEBEN. C 02. VEREINBARUNGEN IMPLICIT REAL*8 (A-H,L-Z) CHARACTER*1 CVZ CHARACTER*13 CREKT,CDEKL C 03. TRANSFORMATIONEN IF (RA.GT.1296000.D0.OR.RA.LT.0.D0) THEN WRITE (6,'(1X//1X,A,F13.3/)') 'RA > 24 UHR ODER < 0 :',RA RETURN END IF RASTD = RA/(3600.D0*15.D0) IRASTD= IDINT(RASTD) RAREST= RASTD-DBLE(IRASTD) IRAMIN= IDINT(RAREST*60.D0) RASEC = RAREST*3600.D0-DBLE(IRAMIN)*60.D0 IF (DABS(RASEC-60.D0).LT.0.001D0) THEN RASEC = 0.D0 IRAMIN= IRAMIN+1 IF (IRAMIN.EQ.60) THEN IRAMIN= 0 IRASTD= IRASTD+1 IF (IRASTD.EQ.24) IRASTD= 0 END IF END IF IF (DABS(DK).GT.324000.D0) THEN WRITE (6,'(1X//1X,A,F13.3/)') 'DK-BETRAG > 90 GRD :',DK RETURN END IF DKGRD = DK/3600.D0 CVZ= '+' IF (DK.LT.0.D0) THEN CVZ= '-' DKGRD= -DKGRD END IF IDKGRD= IDINT(DKGRD) DKREST= DKGRD-DBLE(IDKGRD) IDKMIN= IDINT(DKREST*60.D0) DKSEC = DKREST*3600.D0-DBLE(IDKMIN)*60.D0 IF (DABS(DKSEC-60.D0).LT.0.01D0) THEN DKSEC = 0.D0 IDKMIN= IDKMIN+1 IF (IDKMIN.EQ.60) THEN IDKMIN= 0 IDKGRD= IDKGRD+1 END IF END IF WRITE (CREKT,'( I2,1X,I2,1X,F7.4)') IRASTD,IRAMIN,RASEC WRITE (CDEKL,'(A1,I2,1X,I2,1X,F6.3)') CVZ,IDKGRD,IDKMIN,DKSEC RETURN END SUBROUTINE READERL(CMFILE,NMAX,ICAT,RCAT,NS,CSOURCE,CZB,EPOC,FAIL) IMPLICIT NONE integer NMAX,NS,FAIL integer ICAT(1:NMAX,1:6) double precision RCAT(1:NMAX,1:4) character*1 CZB character*11 CMFILE character*8 CSOURCE integer I,STARNR,CAT,ZSS,IMAG,ISP,INP double precision RA,DEC,MRA,MDEC,EPOC character*7 CFILE,CMFID FAIL=0 OPEN(10,FILE=CMFILE,STATUS='OLD') read(10,'(1X,A8,2X,A7,2X,A2,2X,I5,2X,F10.4)') CSOURCE,CFILE,CZB, + NS,EPOC C write(*,'(1X,A8,2X,A7,2X,A2,2X,I5,2X,F10.4)') CSOURCE,CFILE,CZB, C + NS,EPOC DO 10 I=1,NS read(10,'(I10,I5,I2,I5,I4,2F15.3,2X,2F7.3,I5,1X,A7)') + STARNR,CAT,ZSS,IMAG,ISP,RA,DEC,MRA,MDEC,INP,CMFID IF(CMFID.NE.CFILE) then write(*,*) 'MFILE-ID wrong ,line-No= ',I FAIL=1 goto 100 end if ICAT(I,1)=STARNR ICAT(I,2)=CAT ICAT(I,3)=ZSS ICAT(I,4)=IMAG ICAT(I,5)=ISP ICAT(I,6)=INP RCAT(I,1)=RA RCAT(I,2)=DEC RCAT(I,3)=MRA RCAT(I,4)=MDEC 10 continue 100 close(10) return end