C DOUBLE BEHANDELT DEN FALL, DASS VERSCHIEDENEN KATALOGSTERNEN DERSELBE C MASTER ZUGEORDNET WIRD. SUBROUTINE IDOUBLE INTEGER M,I,J,K,L,BL,POS1,POS2 INTEGER ARINR,ARINR1,DCOUNT CHARACTER FNAM*15,HEADER(12)*34,FNAM2*16 CHARACTER*34 BUFFER(500),NWSTR,DATNAM2*3 CHARACTER*60 STR(34) COMMON /RUN/ DATNAM2 FNAM = DATNAM2//'.T2' CALL FILEOP(1,FNAM,'U',EX) FNAM = DATNAM2//'.id' FNAM2 = DATNAM2//'.nid' CALL FILEOP(2,FNAM,'U',EX) CALL FILEOP(3,FNAM2,'U',EX) C*** EINLESEN DES HEADERS AUS TIIIIPII.NID DO I = 1,11 READ (3,END=1) HEADER(I) WRITE (2) HEADER(I) END DO CLOSE(3,STATUS='KEEP') c REWIND 2 1 READ (1,end = 1000) NWSTR READ (NWSTR(9:12),'(A4)') ARINR1 DCOUNT = 1 BUFFER(DCOUNT) = NWSTR 10 READ (1,end =100) NWSTR READ (NWSTR(9:12),'(A4)') ARINR IF (ARINR .EQ. ARINR1) THEN DCOUNT = DCOUNT + 1 BUFFER(DCOUNT) = NWSTR ELSE CALL CHANGE (BUFFER,DCOUNT) ARINR1 = ARINR DCOUNT = 1 BUFFER(DCOUNT) = NWSTR END IF I = I + 1 GOTO 10 100 CALL CHANGE (BUFFER,DCOUNT) 1000 CLOSE(2,STATUS='KEEP') CLOSE(1,STATUS='DELETE') END C************************************************************* SUBROUTINE CHANGE (IBUFFER,IDCOUNT) CHARACTER*(*) IBUFFER(500) INTEGER CATCN1,CATCN2,FLAG,IDCOUNT,I,ari INTEGER*2 IQ IF (IDCOUNT .EQ. 1) THEN WRITE (2) IBUFFER(1) read(ibuffer(1)(9:12),'(a4)') ari RETURN END IF FLAG = 0 DO I = 1,IDCOUNT READ (IBUFFER(I)(15:16),'(A2)') IQ IF (IQ .EQ. 2) FLAG = 1 END DO C *** FLAG = 0 --> KEIN STERN MIT DER NOTE 2 VORHANDEN IF (FLAG .EQ. 1) THEN IF (IDCOUNT .EQ. 2) THEN READ (IBUFFER(1)(27:30),'(A4)') CATCN1 READ (IBUFFER(2)(27:30),'(A4)') CATCN2 IF (CATCN1 .EQ. CATCN2) FLAG = 0 END IF END IF C *** FLAG = 0 --> CATCN1 = CATCN2 (GLEICHER BEOBACHTUNGS-STERN) C *** FLAG = 1 --> ALLE IQ WERDEN MIT -1 MULTIPLIZIERT IF (FLAG .EQ. 1) THEN DO I = 1,IDCOUNT READ (IBUFFER(I)(15:16),'(A2)') IQ IQ = IQ * (-1) WRITE (IBUFFER(I)(15:16),'(A2)') IQ END DO END IF DO I = 1,IDCOUNT WRITE (2) IBUFFER(I) read(ibuffer(i)(9:12),'(a4)') ari END DO END SUBROUTINE MAINID(STRI) INTEGER NSTAR PARAMETER (NSTAR = 612627) C EXPLIZITE DEFINITION DER INTEGERVARIABELN INTEGER NWORK,LRECL,LBLK,NINDEX(3000000) INTEGER OLDNUM,INUMBER,NCOUNT INTEGER ZAHL,A1,D1,RE,N,RE1,KNOT,JID INTEGER*2 FFLAG C RECORDLAENGE VON MAIN. 60000 = (NWORK/3)*LEN(MAS) PARAMETER (NWORK=2400,LRECL=104,LBLK=83200) C C EXPLIZITE DEFINITION DER REALVARIABELN REAL*8 PI,A,D,NALFMAX,NALFMIN,NDELMAX,NDELMIN,ALFMAX,ALFMIN REAL*8 DELMAX,DELMIN,NIDEPMAX,NIDEPMIN,IDEPMAX,IDEPMIN REAL*8 XMTX(3,3),EPO,EPOCHE,zw REAL*4 VK,DELTAV,MINMAG,MAXMAG,MGMAX,MGMIN,NMGMAX,NMGMIN C EXPLIZITE DEFINITION DER CHARACTERVARIABELN CHARACTER BS5*320,MAS*45 ! BS5=STR1 , MAS=STR2 CHARACTER WORK(NWORK)*45 ! LEN(WORK)=LEN(MAS) CHARACTER FILES(4)*72,STR*26 CHARACTER*38 BUFFER(100) CHARACTER*34 RSTR(12) CHARACTER*(*) STRI(34) CHARACTER*9 HSTR(8) C COMMON BLOECKE FUER STATISTIK & IDENT1 COMMON /ICOM/ BUFFER,INUMBER,OLDNUM, ico COMMON /MAG/ VK,DELTAV,MINMAG,MAXMAG,FFLAG COMMON /NID/ NIDEPMAX,NIDEPMIN,NALFMAX,NALFMIN,NDELMAX,NDELMIN &,NMGMAX,NMGMIN COMMON /ID/ IDEPMAX,IDEPMIN,ALFMAX,ALFMIN,DELMAX,DELMIN,MGMAX &,MGMIN COMMON /FOUND/ KNOT,JID COMMON /MSTAR/ NINDEX,NCOUNT COMMON /idrun/idrun COMMON /MATRIX/ XMTX COMMON /YEAR/ EPO COMMON /headlen/ headlen integer headlen,idrun,nrun EXTERNAL IKATALOG,IDENT,NIDENT EXTERNAL IMASTER,IDENTC ZAHL = NSTAR NCOUNT = 0 PI = 4.D0*DATAN(1.0D0) NIDEPMIN = 8888.D0 NIDEPMAX = -8888.D0 IDEPMIN = 8888.D0 IDEPMAX = -8888.D0 C ALFMAX = -8888.D0 C ALFMIN = 8888.D0 DELMAX = -8888.D0 DELMIN = 8888.D0 C NALFMAX = -8888.D0 C NALFMIN = 8888.D0 NDELMAX = -8888.D0 NDELMIN = 8888.D0 NMGMAX = 8888.0 NMGMIN = -8888.0 MGMAX = 8888.0 MGMIN =-8888.0 CALL EXTRACT(STRI,FILES,A1,D1,RE,RSTR) CALL FILEOP(3,FILES(3),'U',EX) CALL FILEOP(4,FILES(4),'U',EX) N = 9 CALL FILEOP(N,FILES(1),'U',EX) C MASTER IS A DIRECT ACCESS FILE!!!!! c c Das folgende ist das Oeffnen des UNIX- Masters c CALL FILEOPDA(2,FILES(2),'U',45,EX) c c Das folgende ist das Oeffnen des LINUX Masters c c CALL FILEOPDA(2,FILES(2),'U',61,EX) c c C HEADER WIRD IN IDENT.... DATEI GESCHRIEBEN DO I = 1,headlen WRITE (3) RSTR(I) WRITE (4) RSTR(I) END DO IF (idrun.GT.1) THEN DO I = 1,headlen READ (N) RSTR(I) END DO END IF C-------------------------------------------------------------- C SETTING OF PARAMETERS A = 2.D0*DFLOAT(A1)*PI/(180.D0*3600.D0) D = 2.D0*DFLOAT(D1)*PI/(180.D0*3600.D0) OLDNUM = -999 EPOCHE = EPO C IDENTIFICATION STARTS HERE CALL IDENTC (IKATALOG,N,BS5,IMASTER,2,MAS,ZAHL,IDENT,3,NIDENT, & 4,A,D,6,WORK,NWORK,LBLK,LRECL,EPOCHE) III = -1 WRITE (BS5(221:224),'(A4)') III CALL IDENT(3,BS5,MAS,1.D0,1.D0,0) C IDENTIFICATION STOPS HERE CLOSE (N) CLOSE (2) C CLOSE (3) CLOSE (4) C AUSGABE DER STATISTIK C CALL RADCHA(ALFMAX,'HHMMSS.SS',HSTR(1),IER,6) C CALL RADCHA(ALFMIN,'HHMMSS.SS',HSTR(2),IER,6) C CALL RADCHA(NALFMAX,'HHMMSS.SS',HSTR(3),IER,6) C CALL RADCHA(NALFMIN,'HHMMSS.SS',HSTR(4),IER,6) CALL RADCHA(DELMAX,'VDDMMSS.S',HSTR(6),IER,6) CALL RADCHA(NDELMAX,'VDDMMSS.S',HSTR(8),IER,6) CALL RADCHA(NDELMIN,'VDDMMSS.S',HSTR(7),IER,6) CALL RADCHA(DELMIN,'VDDMMSS.S',HSTR(5),IER,6) C MGMIN = 11.1 C MGMAX = 3.2 C NMGMIN = -0.3 C NMGMAX = -1.2 C WRITE(6,'(a1,i1,A,2(F8.5),4X,2(F8.5))') '@',idrun, C & 'Mag. original Ident./nicht Ident. :', C & MGMIN,MGMAX,NMGMIN,NMGMAX MGMAX = floor(MGMAX) MGMIN = ceiling(MGMIN) C NMGMAX = floor(NMGMAX) NMGMIN = ceiling(NMGMIN) if (IDEPMIN.eq.8888.d0) IDEPMIN = -8888.d0 if (NIDEPMIN.eq.8888.d0) NIDEPMIN = -8888.d0 if (IDEPMIN.gt.10000.d0) then zw = idepmin call jdbe(zw,idepmin) endif if (idepmax.gt.10000.d0) then zw = idepmax call jdbe(zw,idepmax) endif if (NIDEPMIN.gt.10000.d0) then zw = nidepmin call jdbe(zw,nidepmin) endif if (nidepmax.gt.10000.d0) then zw = nidepmax call jdbe(zw,nidepmax) endif IF (JID .GT. 0 .AND. KNOT .GT. 0) THEN WRITE(6,'(A1,i1,A,2(F7.1,1X),4X,2(F7.1,1X))') '@',idrun, & 'Epoche min/max Ident./nicht Ident. :', & IDEPMIN,IDEPMAX,NIDEPMIN,NIDEPMAX WRITE(6,'(A1,i1,A,4X,2(A,5X),4X,2(A,5X))') '@',idrun, & 'Dekl. min/max Ident./nicht Ident. :', & HSTR(5)(1:3),HSTR(6)(1:3),HSTR(7)(1:3),HSTR(8)(1:3) IF (NMGMIN.LT.8000.AND.NMGMAX.LT.8000.)THEN C WRITE(6,'(a1,i1,A,2(F8.5),4X,2(F8.5))') '@',idrun, C & 'Mag. floo/cei Ident./nicht Ident. :', C & MGMIN,MGMAX,NMGMIN,NMGMAX WRITE(6,'(a1,i1,A,2(F8.0),4X,2(F8.0))') '@',idrun, & 'Mag. min/max Ident./nicht Ident. :', & MGMIN,MGMAX,NMGMIN,NMGMAX ELSE WRITE(6,'(a1,i1,A,2(F8.0),4X,A)') '@',idrun, & 'Mag. min/max Ident./nicht Ident. :', & MGMIN,MGMAX,' Keine Mag. geg.' END IF END IF IF (JID .GT. 0 .AND. KNOT .EQ. 0) THEN WRITE(6,'(a1,i1,A,2(F7.1,1X))') '@',idrun, & 'Epoche min/max Ident. :', & IDEPMIN,IDEPMAX WRITE(6,'(a1,i1,A,4X,2(A,5X),4X,2(A,5X))') '@',idrun, & 'Dekl. min/max Ident. :', & HSTR(5)(1:3),HSTR(6)(1:3) WRITE(6,'(a1,i1,A,F8.0,F8.0)') '@',idrun, & 'Mag. min/max Ident. :', & MGMIN,MGMAX END IF IF (JID .EQ. 0 .AND. KNOT .GT. 0) THEN WRITE(6,'(a1,i1,A,2(F7.1,1X))') '@',idrun, & 'Epoche min/max nicht Ident. :', & NIDEPMIN,NIDEPMAX WRITE(6,'(a1,i1,A,4X,2(A,5X))') '@',idrun, & 'Dekl. min/max nicht Ident. :', & HSTR(7)(1:3),HSTR(8)(1:3) WRITE(6,'(a1,i1,A,F8.0,F8.0)') '@',idrun, & 'Mag. min/max nicht Ident. :', & NMGMIN,NMGMAX END IF c print*,ico END SUBROUTINE EXTRACT(ST,FL,a1r,d1r,R,RSTR) C Vorsicht!!! R-Parameter ist jetzt unbenutzt. Stattdessen C wird jetzt idrun als Common-Block *importiert* und daraus C auf Nachidentifizierung geschlossen. CHARACTER*(*) ST(34),FL(4),DIS*6,SF*3,RSTR(12),STR*7 INTEGER I,POS1,POS2,POS3,POS4,POS5,POS6,R,POS7 INTEGER*2 FFLAG REAL*8 EP REAL*4 VK,DELTAV,MINMAG,MAXMAG integer a1r,d1r ccc character*34 mastername ccc character*39 mastername ccc character*41 mastername ccc character*40 mastername ! Tuc5 character*72 mastername ! mod. am 17.2.05 COMMON /MAG/ VK,DELTAV,MINMAG,MAXMAG,FFLAG COMMON /idrun/ idrun integer idrun,nrun COMMON /nrun/ nrun common /mastername/ mastername 10 CALL SEEK(ST(19),17,POS1,POS2) write(sf,'(a2,i1)') 'id',idrun FL(3)=sf//'.id' FL(4)=sf//'.nid' FL(2)=mastername FL(1)=' dummy ' ! mod. am 17.2.05 call nthnum(st(33),idrun,a1r) call nthnum(st(34),idrun,d1r) write(*,'(A1,I1,A,I2,A,I2)') '@',idrun,'Fenster ALF/DEL: ' C ,a1r,' ',d1r CALL SEEK(FL(2),1,POS1,POS2) ! mod. am 17.2.05 write(*,'(A1,I1,A,A)') '@',idrun,'Master: ',FL(2)(POS1:POS2) ! mod. am 17.2.05 CALL SEEK(ST(29),17,POS1,POS2) READ(ST(29)(POS1:POS2),'(F6.1)') EP CALL SEEK(ST(27),17,POS1,POS2) READ (ST(27)(POS1:POS2),'(I1)') nrun CALL SEEK(ST(19),17,POS1,POS2) IF (idrun .gt. 1) THEN write(FL(1),'(a2,i1,a4)') 'id',idrun-1,'.nid' ELSE fl(1) = 'id1' END IF DO I = 1,10 RSTR(I) = ST(I)(17:50) END DO c rstr(10) = Mastername(29:29) rstr(10) = Mastername(33:33) CALL SEEK(ST(20),17,POS1,POS2) CALL SEEK(ST(21),17,POS3,POS4) CALL SEEK(ST(22),17,POS5,POS6) pos7 = 0 DO I = 50,24,-1 IF (ST(20)(I:I) .NE. ' ') THEN POS7 = I GOTO 20 END IF END DO 20 IF (POS7 .GT. 25) THEN STR = ST(20)(POS1+3:POS1+5)//'|'//ST(20)(POS7-2:POS7) ELSE STR=ST(20)(POS1:POS1+6) END IF RSTR(11) = STR//' '//ST(21)(POS3:POS4)//' ' &//ST(22)(POS5:POS6) CALL SEEK(ST(30),17,POS1,POS2) c print*,pos1,pos2 IF (POS2-POS1+1.EQ.1) READ(ST(30)(POS1:POS2),'(F1.0)') DELTAV IF (POS2-POS1+1.EQ.2) READ(ST(30)(POS1:POS2),'(F2.0)') DELTAV C um Sterne mit Deltav = 3.0 mitzunehmen wird zum Helligkeitsfenster 0.0001 addiert. DELTAV=DELTAV+0.0001 CALL SEEK(ST(31),17,POS1,POS2) IF (POS2-POS1+1.EQ.1) READ(ST(31)(POS1:POS2),'(F1.0)') MAXMAG IF (POS2-POS1+1.EQ.2) READ(ST(31)(POS1:POS2),'(F2.0)') MAXMAG CALL SEEK(ST(32),17,POS1,POS2) IF (POS2-POS1+1.EQ.1) READ(ST(32)(POS1:POS2),'(F1.0)') MINMAG IF (POS2-POS1+1.EQ.2) READ(ST(32)(POS1:POS2),'(F2.0)') MINMAG PRINT*,'DELTAV ',DELTAV,' MAXMAG ',MAXMAG,' MINMAG ',MINMAG END C extrahiert die ind-te Zahl aus str ab Position 17 und speichert C sie in num subroutine nthnum(str,iind,num) character*(*) str integer iind integer num integer i,xxxind i = 17 xxxind = iind 40 if (str(i:i).eq.' ') then i = i+1 goto 40 end if xxxind = xxxind-1 if (xxxind.eq.0) then read(str(i:i+3),'(i3)') num goto 49 end if 41 if (str(i:i).ne.' ') then i = i+1 goto 41 end if goto 40 49 continue end C BEHANDELT DIE IDENTIFIZIERTEN STERNE SUBROUTINE NIDENT (M,STRI1,STRI2) CHARACTER*(*) STRI1,STRI2 REAL*8 ALFA,DELTA,EPOCH,NALFMAX,NALFMIN,NDELMAX,NDELMIN REAL*8 NIDEPMAX,NIDEPMIN REAL*8 EPALF,EPDEL,EPOCHE REAL*4 NMGMAX,NMGMIN,MAG COMMON /DAT/ ALFA,DELTA,EPOCH,MAG COMMON /NID/ NIDEPMAX,NIDEPMIN,NALFMAX,NALFMIN,NDELMAX,NDELMIN &,NMGMAX,NMGMIN C IF (ALFA .GT. NALFMAX) NALFMAX = ALFA C IF (ALFA .LT. NALFMIN) NALFMIN = ALFA IF (DELTA .GT. NDELMAX) NDELMAX = DELTA IF (DELTA .LT. NDELMIN) NDELMIN = DELTA IF (MAG .GT. -8888.0) THEN IF (MAG .LT. NMGMAX) NMGMAX = MAG IF (MAG .GT. NMGMIN) NMGMIN = MAG END IF read(stri1(97:104),'(A8)') epalf read(stri1(105:112),'(A8)') epdel CALL BEPREAD(EPALF,EPDEL,EPOCHE) IF (EPOCHe.GT. -8888.D0) THEN if (nidepmin.eq.8888.d0) nidepmin = epoche IF (EPOCHe.GT. NIDEPMAX) NIDEPMAX = EPOCHe IF (EPOCHe.LT. NIDEPMIN) NIDEPMIN = EPOCHe END IF C PRINT*,NMGMIN,' ',NMGMAX WRITE (M) STRI1 RETURN END C BEHANDELT DIE IDENTIFIZIERTEN STERNE SUBROUTINE IDENT (M,STRI1,STRI2,DALPH,DDELT,IOK) CHARACTER*(*) STRI1,STRI2 CHARACTER*38 BUFFER(100),HBUF,KOMP*1 REAL*8 DIST,DIST1,DIST2,DALPH,DDELT,DALPH1,DDELT1,PI REAL*8 ALFMAX,ALFMIN,DELMAX,DELMIN,IDEPMAX,IDEPMIN REAL*8 ALFA,DELTA,EPOCHE,MEPALF,MEPDEL,x1,EP REAL*4 VK,V,B,DELTAV,MAXMAG,MINMAG REAL*4 MGMAX,MGMIN,MAG,MVB1,MVB2,MVB INTEGER M,IOK,ico,i1,i2 INTEGER*2 CATCA,CSORT,CAT,CATPV,DCOMP,QIDENT,CATDC,IQ INTEGER*2 FFLAG,PMF,DCOMP1,DCOMP2 INTEGER ARINR,CATAN,CATCN,INUMBER,OLDNUM,IDCOMP INTEGER ARI1,ARI2 REAL*8 EPALF,EPDEL COMMON /ICOM/ BUFFER,INUMBER,OLDNUM,ico COMMON /MAG/ VK,DELTAV,MAXMAG,MINMAG,FFLAG COMMON /DAT/ ALFA,DELTA,EP,MAG COMMON /BEP/ MEPALF,MEPDEL COMMON /ID/ IDEPMAX,IDEPMIN,ALFMAX,ALFMIN,DELMAX,DELMIN &,MGMAX,MGMIN COMMON /TAUSCH/ DIST1,DIST2,MVB1,MVB2,DCOMP1,DCOMP2, & ARI1,ARI2 10 FORMAT (A8,A4,5A2,2A4,2A2,A4) PI = 3.1415926535897932D0 PMF = 1 MVB = 8888.0 MVB1 = 8888.0 MVB2 = 8888.0 C ------------------------------------------------------------- C HELLIGKEITSFENSTER C ------------------------------------------------------------- C C DATA FOR STATISTICS C IF (ALFA .GT. ALFMAX) ALFMAX = ALFA C IF (ALFA .LT. ALFMIN) ALFMIN = ALFA IF (DELTA .GT. DELMAX) DELMAX = DELTA IF (DELTA .LT. DELMIN) DELMIN = DELTA IF (MAG .GT. -8888.0) THEN IF (MAG .LT. MGMAX) MGMAX = MAG IF (MAG .GT. MGMIN) MGMIN = MAG END IF read(stri1(97:104),'(A8)') epalf read(stri1(105:112),'(A8)') epdel CALL BEPREAD(EPALF,EPDEL,EPOCHE) IF (EPOCHE.GT. -8888.D0) THEN if (idepmin.eq.8888.d0) idepmin = epoche IF (EPOCHE.GT. IDEPMAX) IDEPMAX = EPOCHE IF (EPOCHE.LT. IDEPMIN) IDEPMIN = EPOCHE END IF C--------------------------------------------------- C C APPLICATION OF MAGNITUDE AS CRITERION FOR IDENTIFICATION READ (STRI1(221:224),'(A4)') CATAN IF (CATAN .EQ. -1) GOTO 111 READ (STRI1(225:228),'(A4)') CATCN C FFLAG = 1 IOK = 0 READ (STRI2(37:44),'(2A4)') V,B READ (STRI2(45:45),'(A1)') KOMP IF (MAG .EQ. -8888.0) THEN IF (KOMP.EQ.' '.OR.KOMP.EQ.'A')THEN IF (V .GT. -200.0 )THEN IF (V .LT. MGMAX) MGMAX = V IF (V .GT. MGMIN) MGMIN = V ELSE IF (B .GT. -200.0 )THEN IF (B .LT. MGMAX) MGMAX = B IF (B .GT. MGMIN) MGMIN = B END IF END IF END IF END IF IF (V .GT. -200.) MVB = V-VK IF (V .LT. -200. .AND. B .GT. -200.) MVB = B-VK MVB = abs(MVB) IF (VK .EQ. -8888.0) GOTO 11 IF ((V.LT.-200.0).AND.(B.LT.-200.0)) GOTO 11 IF ((FFLAG .EQ. 1) .OR. (FFLAG .EQ. 2)) THEN IF (V .LT. -200.0) THEN IF ((B.LT.VK-DELTAV-1.0).OR.(B.GT.VK+DELTAV+1.0)) THEN WRITE (STRI1(303:304),'(A2)') PMF RETURN END IF ELSE IF ((V.LT.VK-DELTAV).OR.(V.GT.VK+DELTAV)) THEN WRITE (STRI1(303:304),'(A2)') PMF RETURN END IF END IF END IF IF (FFLAG .EQ. 3) THEN IF (B .LT. -200.0) THEN IF ((V.LT.VK-DELTAV-1.0).OR.(V.GT.VK+DELTAV+1.0)) THEN WRITE (STRI1(303:304),'(A2)') PMF RETURN END IF ELSE IF ((B.LT.VK-DELTAV).OR.(B.GT.VK+DELTAV)) THEN WRITE (STRI1(303:304),'(A2)') PMF RETURN END IF END IF END IF C --------------------------------------------------------- 11 IOK = 1 READ (STRI2(1:4),'(A4)') ARINR READ (STRI2(5:12),'(A8)') DELTA READ (STRI1(221:224),'(A4)') CATAN READ (STRI1(225:228),'(A4)') CATCN IDCOMP = ICHAR(STRI2(45:45)) DCOMP = IDCOMP READ (STRI1(261:262),'(A2)') CSORT READ (STRI1(263:264),'(A2)') CAT READ (STRI1(265:266),'(A2)') CATPV READ (STRI1(267:268),'(A2)') CATCA READ (STRI1(269:270),'(A2)') CATDC DALPH1 = DCOS(DELTA)*DALPH*3600.D0*180.D0/PI DDELT1 = DDELT*3600.D0*180.D0/PI DIST = DSQRT(DDELT1*DDELT1 + DALPH1*DALPH1) 111 IQ = 0 C IF (OLDNUM .LT. -1) THEN IF (OLDNUM .LE. -1) THEN INUMBER = 1 OLDNUM = CATAN WRITE (BUFFER(INUMBER),10) DIST,ARINR,DCOMP,IQ,CSORT,CAT, & CATPV,CATAN,CATCN,CATCA,CATDC & ,MVB RETURN END IF IF (OLDNUM.EQ.CATAN) THEN INUMBER = INUMBER + 1 WRITE (BUFFER(INUMBER),10) DIST,ARINR,DCOMP,IQ,CSORT,CAT, & CATPV,CATAN,CATCN,CATCA,CATDC & ,MVB RETURN END IF IF (INUMBER.EQ.1) THEN QIDENT = 2 WRITE (BUFFER(1)(15:16),'(A2)') QIDENT c read(buffer(inumber)(9:12),'(a4)') inr ico = ico + 1 WRITE (M) BUFFER(1)(1:38) ELSE DO J = 1,INUMBER-1 READ (BUFFER(J)(1:8),'(A8)') DIST1 READ (BUFFER(J)(35:38),'(A4)') MVB1 READ (BUFFER(J)(13:14),'(A2)') DCOMP1 READ (BUFFER(J)(9:12),'(A4)') ARI1 DO I = J+1,INUMBER READ (BUFFER(I)(1:8),'(A8)') DIST2 READ (BUFFER(I)(35:38),'(A4)') MVB2 READ (BUFFER(I)(13:14),'(A2)') DCOMP2 READ (BUFFER(I)(9:12),'(A4)') ARI2 C IF (DIST2.LT.DIST1) THEN CALL MOVE(BUFFER,J,I,HBUF) C C C IF THE DISTANCES ARE EQUAL DECIDE BY MAG. ELSEIF (DIST2 .EQ. DIST1) THEN IF (MVB1.LT. 200. .AND. MVB2 .LT. 200.) THEN IF (MVB2 .LT. MVB1) THEN CALL MOVE(BUFFER,J,I,HBUF) C C C IF THE MAGNITUDES ARE EQUAL DECIDE BY DOUBLE STAR COMPONENTS ELSEIF (MVB2 .EQ. MVB1) THEN IF (DCOMP2.EQ.0.OR.DCOMP1.EQ.0)THEN IF (ARI2 .LT. ARI1) CALL MOVE(BUFFER,J,I,HBUF) elseIF (DCOMP2 .LT. DCOMP1) THEN CALL MOVE(BUFFER,J,I,HBUF) C C C IF THE COMPONENTS ARE EQUAL DECIDE BY ARI NOS ELSEIF (DCOMP2 .EQ. DCOMP1)THEN IF (ARI2 .LT. ARI1) CALL MOVE(BUFFER,J,I,HBUF) END IF END IF C C C IF THE MAGNITUDES ARE MISSING THEN DECIDE BY DOUBLE STAR COMPONENTS ELSE IF (DCOMP2.EQ.0.OR.DCOMP1.EQ.0)THEN IF (ARI2 .LT. ARI1) CALL MOVE(BUFFER,J,I,HBUF) elseIF (DCOMP2 .LT. DCOMP1) THEN CALL MOVE(BUFFER,J,I,HBUF) ELSEIF(DCOMP2.EQ.DCOMP1)THEN IF (ARI2 .LT. ARI1) CALL MOVE(BUFFER,J,I,HBUF) END IF END IF END IF C END DO END DO DO I = 1,INUMBER QIDENT = I+2 WRITE (BUFFER(I)(15:16),'(A2)') QIDENT c read(buffer(i)(9:12),'(a4)') inr c print*,inr ico = ico +1 WRITE (M) BUFFER(I)(1:38) END DO END IF c print*,inr OLDNUM = CATAN INUMBER = 1 WRITE (BUFFER(INUMBER),10) DIST,ARINR,DCOMP,IQ,CSORT,CAT,CATPV, & CATAN,CATCN,CATCA,CATDC & ,MVB RETURN END C C************************************************************* C SUBROUTINE MOVE (BUFFER,J,I,HBUF) C C CHARACTER*(*) BUFFER(100),HBUF INTEGER*2 DCOMP1,DCOMP2 INTEGER ARI1,ARI2 REAL*4 MVB1,MVB2 REAL*8 DIST1,DIST2 C COMMON /TAUSCH/ DIST1,DIST2,MVB1,MVB2,DCOMP1,DCOMP2, & ARI1,ARI2 C HBUF = BUFFER(I) BUFFER(I) = BUFFER(J) BUFFER(J) = HBUF DIST1 = DIST2 MVB1=MVB2 DCOMP1=DCOMP2 ARI1=ARI2 C END C LESE EINEN DATENSATZ AUS MASTER SUBROUTINE IMASTER(M,STR2,ALFA,DELTA,MUALF,MUDEL,EPOCH,IEND) PARAMETER (NSTAR = 612627) CHARACTER*45 STR2 ! LENGTH STR2 = 45 NEUER MASTER CHARACTER*1 KOMP,str*10 INTEGER NR,NCOUNT,NINDEX(3000000) REAL*8 ALFA,DELTA,EPOCH,EPOZIEL,EPOSTART REAL*8 MUALF,MUDEL,XMTX(3,3) REAL*4 MV,MB COMMON /MATRIX/ XMTX COMMON/MSTAR/ NINDEX,NCOUNT COMMON /YEAR/ EPOZIEL EPOSTART = 2000.D0 c EPOZIEL = EPOCH if (NCOUNT.GE.NSTAR) then IEND = 1 goto 999 ENDIF 10 FORMAT (A4,4A8,2A4,A1) NCOUNT = NCOUNT + 1 c IF (NCOUNT .eq. 1)print*,xmtx(1,1),xmtx(2,2),xmtx(3,3) READ (M,REC=NINDEX(NCOUNT)) & NR,DELTA,ALFA,MUDEL,MUALF,MV,MB,KOMP CALL TRANSF(EPOSTART,EPOZIEL,XMTX,ALFA,DELTA,MUALF,MUDEL) c IF (NCOUNT .LT. 20)print*,nindex(ncount),delta WRITE (STR2,10) NR,DELTA,ALFA,MUDEL,MUALF,MV,MB,KOMP c if (ncount .le. 100) then c call radcha(delta,'vddmmss.ss',str,ier,6) c print*,str c end if IEND = 0 999 CONTINUE END C LESE EINEN DATENSATZ AUS DEM ZU IDENTIFIZIERENDEN KATALOG SUBROUTINE IKATALOG(M,STRI1,ALFA,DELTA,EPOCH,MAG,IEND) PARAMETER (NSTAR=612627) CHARACTER*320 STRI1 INTEGER IEND,CATCN,CATAN,ISTAR4(10),KENNA,KENND INTEGER*2 ISTAR2(30),CSORT,CATDC,CATPV,CATCA,CAT,FFLAG REAL*8 ALFA,DELTA,EPOCH,XSTAR8(20),EPALF,EPDEL REAL*4 XSTAR4(15) REAL*4 VK,DELTAV,MAXMAG,MINMAG,MAG integer kennx8(20), kennx4(15) C NEW NEW COMMON /MAG/ VK,DELTAV,MAXMAG,MINMAG,FFLAG C END NEW 10 FORMAT (14A8,12A4,9A4,6A4,2A4,2A4,6A4,30A2) c READ (M,'(A)',END=100) STRI1 READ(M,END = 100) (XSTAR8(I),I=1,14), & (KENNX8(I), I=1,12), & (XSTAR4(I),I=1,9), & (KENNX4(I),I=1,6), & (ISTAR4(I),I=1,2), & (KENNX8(I),I=13,14), & (KENNX4(I),I=7,12), & (ISTAR2(I),I=1,30) c READ(STRI1,10) (XSTAR8(I),I=1,20),(XSTAR4(I),I=1,15), c & (ISTAR4(I),I=1,10),(ISTAR2(I),I=1,30) WRITE(STRI1,10) (XSTAR8(I),I=1,14), & (KENNX8(I), I=1,12), & (XSTAR4(I),I=1,9), & (KENNX4(I),I=1,6), & (ISTAR4(I),I=1,2), & (KENNX8(I),I=13,14), & (KENNX4(I),I=7,12), & (ISTAR2(I),I=1,30) c WRITE(*,'(1X,A,I8,F10.7)')'IKATA',ISTAR4(2),XSTAR8(6) DELTA = XSTAR8(6) ALFA = XSTAR8(3) EPALF = XSTAR8(2) EPDEL = XSTAR8(5) c C ES WIRD ABGEFRAGT, OB DIE EPOCH IN JULIANISCHEM DATUM GEGEBEN IST C UND GEGEBENENFALLS IN BESSELSCHE EPOCHE UMGERECHNET ( BEPOCH(...,....) KENNA= ISTAR2(10)-INT(ISTAR2(10)/100)*100 KENND= ISTAR2(13)-INT(ISTAR2(13)/100)*100 IF (KENNA.GE. 30 .AND. EPALF .NE. -8888.D0) CALL & JDBE(XSTAR8(2),EPALF) IF (KENND.GE. 30 .AND. EPDEL .NE. -8888.D0) CALL & JDBE(XSTAR8(5),EPDEL) C HIER WIRD UEBERPRUEFT, OB INDIVIDUELLE EPOCHEN FUER EINEN STERN C GEGEBEN SIND. BEI UNTERSCHIEDELICHEN EPOCHEN WIRD DER MITTELWERT C VERWENDET. IF (EPALF .LT. 0.D0 .AND. EPDEL .GT. 0.D0) EPALF = EPDEL IF (EPDEL .LT. 0.D0 .AND. EPALF .GT. 0.D0) EPDEL = EPALF EPOCH = 0.5D0*(EPDEL+EPALF) C VK WIRD AN IDENT.F UEBERGEBEN FUER DAS HELLIGKEITSFENSTER. 20 VK = XSTAR4(1) C FFLAG WIRD MIT VK AN IDENT1.F UEBERGEBEN. ES WIRD HIER DIE ART DER C HELLIGKEIT (VISUELL ETC.) ANGEGEBEN. FFLAG = ISTAR2(9) C MAG DIENT ALS VARIABLE ZUR BESTIMMUNG DER MAXIMALEN/MINIMALEN C HELLIGKEIT FUER STATISTISCHE ZWECKE MAG = VK IEND = 0 RETURN 100 IEND = 1 RETURN END SUBROUTINE IDENTC(GETRE1,LUNR1,ISTR1,GETRE2,LUNR2,ISTR2,NTOT, *GIVID,LUNID,GIVNOT,LUNNOT,AWIND,DWIND,LUNRCO, *WORK,NWORK,LBLK,LRECL,EPOCH) C C AUTOR S.ROESER SEPTEMBER 1987 C VERSION DES IDENT1 MIT KERNSPEICHERNUTZUNG C C PARAMETERBERECHNUNG FUER BLOCKUNG C C LBLK = BLOCKSIZE WIE IM DAC AUFRUF C LRECL = RECORDLAENGE VON ISTR2 (SIEHE HAUPTPROGRAMM) C NRECB = ZAHL DER RECORDS IM BLOCK ( LBLK/LRECL ) C NWORK = LAENGE DES FELDES WORK C LASTBL = ANZAHL DER BLOECKE DES MASTERKATALOGS C NTOT = ANZAHL DER RECORDS IM MASTERKATALOG C NBLK = ANZAHL DER BLOECKE, DIE IN DEN KSP. GELADEN WERDEN KOENNEN. C KKLEIN = MAXIMALZAHL FUER DEN ERSTEN EINGELADENEN BLOCK C IMPLICIT REAL*8 (A-H,O-Z),INTEGER (I-N) EXTERNAL GETRE1,GETRE2,GIVID,GIVNOT PARAMETER (NSTAR=612627) C DIMENSION AMAST(2048),DMAST(2048),PAMAST(2048),PDMAST(2048) C DIMENSION EPMAST(2048) DIMENSION AMAST(5096),DMAST(5096),PAMAST(5096),PDMAST(5096) DIMENSION EPMAST(5096) CHARACTER ISTR1*(*),ISTR2*(*),WORK(1)*(*),DCHAR(5096)*4 C INTEGER NUM(14) REAL*8 ALFMEM,DELMEM,EPMEM REAL*4 MAGMEM,MAG REAL*4 xxx INTEGER NCOUNT,NINDEX(3000000) integer*4 iijunk integer*4 CATCN COMMON /DAT/ ALFMEM,DELMEM,EPMEM,MAGMEM COMMON /FOUND/ KNOT,JID COMMON /MSTAR/ NINDEX,NCOUNT COMMON /YEAR/ EPO common /idrun/idrun integer idrun DATA PI,DNULL /3.141592653589793D0,0.D0/ CALL BEJD(EPO,DAJU50) NZAEHL = 0 c print *,'Fenster',AWIND,DWIND ZPI = 2.D0*PI PIH = .5D0*PI DALPHW= AWIND*.5D0 DDELTW= DWIND*.5D0 NRECB = LBLK/LRECL NBLK = NWORK/NRECB LASTBL = (NTOT-10)/NRECB+1 KKLEIN = LASTBL-NBLK+1 IGES = 0 KNOT = 0 KDOPP= 0 JID = 0 EPOCA = EPO C ccc open (99,file='xxxident.dat') C HIER WIRD NUN VERSUCHSWEISE DAS FENSTER FUER DEN SUCHBEREICH C VERGROESSERT, UM GROESSERE EIGENBEWEGUNGEN IN DELTA ZUZULASSEN. C DERZEIT 1.0 BOGENMINUTEN FENSTER !!!!!!!!!!! C DASUCH = DALPHW DDSUCH = MAX(DDELTW,3.0D0*PI/180.D0/60.D0*.5D0) C PRINT *, 'DASUCH, DDSUCH ', DASUCH,DDSUCH C C BERECHNUNG DER MAXIMALEN XMAX UND YMAX C CALL GNOMAP(DNULL,DNULL,DALPHW,DNULL,XMAX,DUMMY) XMAX=DABS(XMAX) CALL GNOMAP(DNULL,DNULL,DNULL,DDELTW,DUMMY,YMAX) YMAX=DABS(YMAX) C PRINT *, 'XMAX,YMAX ', XMAX,YMAX C CALL GETRE2(LUNR2,ISTR2,ALPHA2,DELTA2,PMA2,PMD2,EPOCA,KEND) 99 CALL GETRE1(LUNR1,ISTR1,ALPHA1,DELTA1,EPOCH,MAG,MEND) READ(istr1(225:228),'(a4)') CATCN IF (EPOCH.LT.-1000.D0) EPOCH = EPO IF(MEND.EQ.1) GOTO 2 IGES = IGES + 1 CALL BEJD(EPOCH,TJD) C C BERECHNUNG DES IDAGK0 FENSTERS,WELCHES DAS GEWUENSCHTE IDAGK1 C FENSTER ENTHAELT. C CALL ARCWIN(DELTA1,DASUCH,DDSUCH,DALF,DELN,DELS,IARCWI) C PRINT *, ' DELTA1,DASUCH,DDSUCH,DALF,DELN,DELS,IARCWI' C PRINT *, DELTA1,DASUCH,DDSUCH,DALF,DELN,ps IF (DELN .LT. DELTA2) THEN ALFMEM = ALPHA1 DELMEM = DELTA1 MAGMEM = MAG EPMEM = EPOCH CALL GIVNOT(LUNNOT,ISTR1,ISTR2) KNOT = KNOT + 1 GOTO 99 END IF NCOUNT = NCOUNT -1 C BACKSPACE LUNR2 100 CONTINUE C C SUCHE DEN ERSTEN RECORD, DER FUER IDENTIFIZIERUNG C DES ERSTEN STERNS AUSSERHALB DES BISH. KSP. MOEGLICH IST. C D.H. LESE SEQUENTIELL SO LANGE EIN, BIS DAS MASTER-FILE C AN DER ENTSPRECHENDEN STELLE STEHT. C DO 31 I = 1,NRECB CALL GETRE2(LUNR2,ISTR2,ALPHA2,DELTA2,PMA2,PMD2,EPOCA,KEND) IF (KEND .EQ. 1) THEN IF (I .EQ. 1) GO TO 25 GO TO 301 END IF 31 CONTINUE IF(DELTA2.LT.DELS) GOTO 100 301 I = I - 1 DO 32 K = 1,I 32 NCOUNT = NCOUNT - 1 C 32 BACKSPACE LUNR2 C C KERNSPEICHER NEU AUFFUELLEN C NUMMER DES ERSTEN RECORDS DES ERSTEN MOEGLICHEN BLOCKS BESTIMMEN C NEND = NWORK DO 200 KK = 1,NWORK CALL GETRE2(LUNR2,ISTR2,ALPHA2,DELTA2,PMA2,PMD2,EPOCA,KEND) IF(KEND .EQ. 1) THEN NEND = KK-1 GOTO 201 END IF AMAST(KK) = ALPHA2 DMAST(KK) = DELTA2 PAMAST(KK) = PMA2 PDMAST(KK) = PMD2 EPMAST(KK) = EPOCA WRITE(DCHAR(KK),'(A4)') SNGL(DELTA2) WORK(KK) = ISTR2 200 CONTINUE 201 CONTINUE C do iii = 1,nwork read(dchar(iii),'(a4)') xxx ccc write(99,'(a,i5,3x,f8.3)') 'i, dchar(i) ',iii,xxx end do c C JETZT ERFOLGT DIE EIGENTLICHE IDENTIFIZIERUNG. C IANF = 1 IEND = NEND 24 CONTINUE KID = 0 CALL CORBSR(IANF,IEND,SNGL(DELS),'(A4)',NU1,DCHAR,IER) IF(IER.EQ.6) NU1 = IANF CALL CORBSR(IANF,IEND,SNGL(DELN),'(A4)',NU2,DCHAR,IER) IF(IER.EQ.7) NU2 = NWORK DO 1 I= NU1,NU2 C C RECORD AUS DEM AGKCAT HOLEN. C PMA = PAMAST(I) PMD = PDMAST(I) ALP = AMAST(I) DEL = DMAST(I) EP = EPMAST(I) CALL BEJD(EP,DAJU50) CALL BEJD(EPOCH,TJD) IF(PMA .LT.-100.D0) PMA = 0.D0 IF(PMD .LT.-100.D0) PMD = 0.D0 C PMA = PMA*100.D0 C PMD = PMD*100.D0 AUSKOMMENTIERT REFFERT 27.10.94 CALL TPMPOS(ALP,DEL,PMA,PMD,0.D0,DAJU50,TJD,ALPHA2,DELTA2) C C DIFFERENZEN BILDEN (AUCH SCHNITT 24H NACH 0H BERUECKSICHTIGT) C IF(IARCWI.NE.0) GO TO 23 DALPH = ALPHA1-ALPHA2 DDALPH = DABS(DALPH) DALPH2 = DALPH + ZPI DDAL2 = DABS(DALPH2) IF(DDAL2.GT.DDALPH) GOTO 21 DALPH = DALPH2 DDALPH = DDAL2 21 DALPH3 = DALPH2 - ZPI - ZPI DDAL3 = DABS(DALPH3) IF(DDAL3.GT.DDALPH) GOTO 22 DALPH = DALPH3 DDALPH = DDAL3 C C AUFTEILUNG IN IDENTIFIZIERTE UND NICHT IDENTIFIZIERTE STERNE. C 22 IF(DDALPH.GT.DALF) GOTO 1 C22 CONTINUE 23 CALL GNOMAP(ALPHA1,DELTA1,ALPHA2,DELTA2,X,Y) IF (ABS(X).GT.XMAX .OR. ABS(Y).GT.YMAX) GO TO 1 C IF ( ABS(Y).GT.YMAX) GO TO 1 C KID = KID + 1 DDELT = DELTA1-DELTA2 ALFMEM = ALPHA1 DELMEM = DELTA1 MAGMEM = MAG EPMEM = EPOCH CALL GIVID(LUNID,ISTR1,WORK(I),DALPH,DDELT,IOK) KID = KID + IOK 1 CONTINUE IF(KID.GT.1) KDOPP = KDOPP + 1 IF(KID.GE.1) JID = JID + 1 10 IF(KID.EQ.0) THEN ALFMEM = ALPHA1 DELMEM = DELTA1 MAGMEM = MAG EPMEM = EPOCH CALL GIVNOT(LUNNOT,ISTR1,ISTR2) KNOT = KNOT + 1 END IF C C NAECHSTEN RECORD EINLESEN C 26 CALL GETRE1(LUNR1,ISTR1,ALPHA1,DELTA1,EPOCH,MAG,MEND) READ(istr1(225:228),'(a4)') CATCN IF (EPOCH.LT.-1000.D0) EPOCH = EPO IF(MEND.EQ.1) GOTO 2 IGES = IGES + 1 CALL BEJD(EPOCH,TJD) C C BERECHNUNG DES IDAGK0 FENSTERS,WELCHES DAS GEWUENSCHTE IDAGK1 C FENSTER ENTHAELT. C CALL ARCWIN(DELTA1,DASUCH,DDSUCH,DALF,DELN,DELS,IARCWI) C C BERECHNUNG DES SUEDENDES FUER ENTSCHEIDUNG, WAS WEITER ZU TUN IST C SUEDENDE GROESSER ALS LETZTER RECORD: GEHE NACH 100 C SUEDENDE IM ERSTEN UND NORDENDE OBERHALB DES LETZTEN BLOCKS: C FEHLERMELDUNG. C SUED-UND NORDENDE IM BEREICH: WEITERMACHEN C SUEDENDE IM BEREICH UND NORDENDE DRAUSSEN: UMNUMERIEREN CALL CORBSR(1,NEND,SNGL(DELS),'(A4)',NU1,DCHAR,IER) IF(IER.EQ.7) THEN IF(KEND.NE.1) GO TO 100 GO TO 25 END IF CALL CORBSR(1,NEND,SNGL(DELN),'(A4)',NU2,DCHAR,IER) IF(IER.EQ.0) GOTO 24 IF(IER.NE.7) THEN WRITE(LUNRCO,'(A)')' FEHLER: DELTA DES NAECHSTEN STERNS ZU KLEIN.' C WRITE(LUNRCO,'(A,A)')' RECORD: ',ISTR1 C STOP ALFMEM = ALPHA1 DELMEM = DELTA1 MAGMEM = MAG EPMEM = EPOCH CALL GIVNOT(LUNNOT,ISTR1,ISTR2) KNOT = KNOT + 1 GOTO 26 END IF C C SUCHE ERSTEN BLOCK, DEN ICH NOCH BRAUCHE(FUERS UMNUMERIEREN) C IK = NRECB DO 30 I = 1,NBLK IF(NU1.LT.IK) GOTO 33 30 IK = IK + NRECB 33 IBLFI = I C C UMSPEICHERN (d.h. die noch gebrauchten Sterne nach unten C bewegen, neue werden angehaengt) C IANF = (IBLFI-1) * NRECB + 1 LK = 1 DO 50 LL = IANF,NEND AMAST(LK) = AMAST(LL) DMAST(LK) = DMAST(LL) PAMAST(LK) = PAMAST(LL) PDMAST(LK) = PDMAST(LL) EPMAST(LK) = EPMAST(LL) WORK(LK) = WORK(LL) DCHAR(LK) = DCHAR(LL) LK = LK + 1 50 CONTINUE IF(NEND.LT.NWORK) THEN IANF = 1 IEND = LK-1 NEND = LK-1 GOTO 24 END IF C Jetzt das Feld mit den Vergleichssternen aus dem C Hauptkatalog auffüllen DO 60 LL = LK,NWORK CALL GETRE2(LUNR2,ISTR2,ALPHA2,DELTA2,PMA2,PMD2,EPOCA,KEND) IF(KEND.EQ.1) THEN NEND = LL-1 GOTO 61 END IF AMAST(LL) = ALPHA2 DMAST(LL) = DELTA2 PAMAST(LL) = PMA2 PDMAST(LL) = PMD2 EPMAST(LL) = EPOCA WRITE(DCHAR(LL),'(A4)') SNGL(DELTA2) WORK(LL) = ISTR2 60 CONTINUE 61 CONTINUE IANF = 1 IEND = NEND GOTO 24 25 ALFMEM = ALPHA1 DELMEM = DELTA1 MAGMEM = MAG EPMEM = EPOCH CALL GIVNOT(LUNNOT,ISTR1,ISTR2) KNOT = KNOT +1 CALL GETRE1(LUNR1,ISTR1,ALPHA1,DELTA1,EPOCH,MAG,MEND) READ(istr1(225:228),'(a4)') CATCN IF (EPOCH.LT.-1000.D0) EPOCH = EPO IF(MEND.EQ.1) GOTO 2 IGES = IGES + 1 GO TO 25 2 WRITE(6,'(A1,i1,A,I7)') c '@',idrun,'Zahl der eingelesenen Sterne : ',IGES WRITE(LUNRCO,'(A1,i1,A,I7)') '@', c idrun,'Gesamtz. der identif. Sterne: ',JID WRITE(LUNRCO,'(A1,i1,A,I7)') '@', c idrun,'Vorl. dopp. identif. Sterne: ',KDOPP WRITE(LUNRCO,'(A1,i1,A,I7)') '@', c idrun,'Anzahl der nicht identif. Sterne: ',KNOT PRINt *,NZAEHL RETURN END SUBROUTINE GIVID(LUNID,ISTR1,ISTR2,DALPH,DDELT,KID) IMPLICIT REAL*8 (A-H,O-Z),INTEGER (I-N) CHARACTER ISTR1*(*),ISTR2*(*) RETURN END SUBROUTINE GIVNOT(LUNNOT,ISTR1,ISTR2) IMPLICIT REAL*8 (A-H,O-Z),INTEGER (I-N) CHARACTER ISTR1*(*),ISTR2*(*) RETURN END C C C SUBROUTINE ARCWIN(DELTA,AWH,DWH,DALF,DELN,DELS,IARCWI) C C BERECHNUNG EINES VORLAEUFIGEN IDENTIFIKATIONSFENSTERS IN C ABHAENGIGKEIT VON DELTA , DAS INNERHALB SEINER FESTEN GRENZEN C +/-DALFA UND DELP (DELTA-POL) BZW. DELE (DELTA-EQUATOR) MINDESTENS C DAS VORGEGEBENE , POSITIONSUNABHAENGIGE UND FLAECHENKONSTANTE , C EIGENTLICHE IDENTIFIKATIONSFENSTER ENTHAELT . C IMPLICIT REAL*8 (A-H,O-Z) PI=3.141592653589793D0 PIH=0.5D0*PI IARCWI=0 ADEL=ABS(DELTA) C DELTA-POL ADELP=ADEL+DWH C FALLS POL IM FENSTER (DELP=PI/2) : IARCWI=1 IF (ADELP .GT. PIH) THEN IARCWI=1 ADELP=PIH END IF DELP=SIGN(ADELP,DELTA) C DELTA-EQUATOR ARG=PIH-ADEL+DWH CD=COS(AWH)*COS(ARG) DELE=PIH-ACOS(CD) IF(DELTA.LT.0.D0) DELE=-DELE DELN=MAX(DELE,DELP) DELS=MIN(DELE,DELP) C DELTA-ALPHA C FALLS POL IM FENSTER WIRD GESETZT : DELTA-ALPHA=+/-12H IF (IARCWI .EQ. 1) THEN DALF=PI ELSE DALF=AWH/COS(ADELP) C FALLS POL NICHT IM FENSTER UND DELTA-ALPHA=+/-12H : IARCWI=2 IF(DALF.GE.PI) THEN DALF=PI IARCWI=2 END IF END IF RETURN END SUBROUTINE BEPREAD(EPALF,EPDEL,EPOCHE) REAL*8 EPALF,EPDEL,EPOCHE EPOCHE = 0.5D0*(EPALF+EPDEL) IF (EPALF .EQ. -8888.D0) EPOCHE = EPDEL IF (EPDEL .EQ. -8888.D0) EPOCHE = EPALF END SUBROUTINE CORBSR(NANF,NEND,WERT,FORMAT,NREC,SATZ,IER) C IMPLICIT REAL*8 (A-H,O-Z),INTEGER (I-N) CHARACTER*(*) SATZ(1),FORMAT IER=0 C C ANALOGES PROGRAMM ZU DACBSR, NUR WIRD IM KERNSPEICHER GESUCHT C UEBERPRUEFEN,OB WERT IM WERTEBEREICH DER DATEI LIEGT C READ(SATZ(NANF),FORMAT) WERTP ccc write(99,*) 'WERT, WERTP = ',wert,wertp IF (WERT.LT.WERTP) THEN IER=6 RETURN ENDIF IF(WERT.EQ.WERTP) THEN NREC=NANF RETURN ENDIF READ(SATZ(NEND),FORMAT) WERTP IF (WERT.GT.WERTP) THEN IER=7 RETURN ENDIF IF (WERT.EQ.WERTP) THEN NREC=NEND RETURN ENDIF C C STARTE BINAERE SUCHE C C DEFINIERE DERZEITIGES SUCHPROGRAMM C N1=NANF N2=NEND C C IST DAS SUCHINTERVALL NUR EIN RECORD LANG C 101 CONTINUE IF (N2-N1.LE.1) THEN NREC=N1 RETURN END IF C C C HALBIERE DAS INTERVALL C N3=(N1+N2)/2 READ(SATZ(N3),FORMAT) WERTP C C NEUDEFINITION DES SUCHINTERVALLS UND RUECKSPRUNG IF (WERTP.GT.WERT) THEN N2=N3 GOTO 101 ELSEIF(WERTP.LT.WERT) THEN N1=N3 GOTO 101 ELSE NREC=N3 RETURN ENDIF END !@process free(f90) ! applycor.f muss am Schluss der Leseroutine aufgerufen werden und ! prueft, ob eine (oder mehrere) Korrektur(en) fuer einen Stern ! (identifiziert durch CATCN=xstar4(2)) vorliegen. Wenn dem so ! ist, werden die Korrekturen in den uebergebenen Feldern vorgenommen ! und in einer Protokolldatei vermerkt. Damit das alles funktioniert, ! muss das aufrufende Programm genau einmal loadcor aufrufen. subroutine applycor(xstar4,kennx4,xstar8,kennx8,istar2,istar4) implicit none include 'cors.f' real*4 xstar4(*) real*8 xstar8(*) integer*2 istar2(*) integer*4 kennx4(*),kennx8(*),istar4(*) logical kor_checkmark integer binarysearch ! Common-Block aus loadcor.f common /korrekturen/ thecors type (t_cordata),target :: thecors type (t_cor),pointer :: cur_cor integer*2 kindex,index,findex character*17 ostr,nstr,ostr1,nstr1 ! fuer xstar8 integer ier ! wenn nokor==0 ist, dann war die Korrekturdatei leer oder ! fehlte und es ist nichts zu tun if (thecors%nokor.eq.0) return ! Erst nachsehen, ob ueberhaupt Korrekturen anzubringen sind if (.not.kor_checkmark(istar4(2),thecors%korflags)) return ! Jetzt einen Binary Search auf kornr laufen lassen kindex=binarysearch(istar4(2),thecors%nokor,thecors%cors) if (kindex.EQ.0) then print *,'Interner Fehler! Bitte Markus Demleitner Bescheid sagen' return end if ! und zuruecksteppen, bis erster Eintrag zur betreffenden Nummer kommt 1 if (thecors%cors(kindex)%catcn.ne.istar4(2)) goto 2 kindex=kindex-1 if (kindex.le.0) goto 2 goto 1 2 kindex=kindex+1 cur_cor => thecors%cors(kindex) ! Eine anzubringende Korrektur steht jetzt in cur_cor ! Jetzt ggf. kontrollieren, ob der Appendix stimmt if (thecors%hasapp.eq.1) then if (cur_cor%app.ne.istar2(4)) then goto 3 ! continue endif endif call blankstounder(cur_cor%bem) findex=mod(cur_cor%dest,100_2) patchit: select case (cur_cor%dest/100) case default patchit print *,'Interner Fehler in applycor: Code',cur_cor%dest/100, f 'nicht definiert' case (1) if (xstar4(findex).eq.cur_cor%realval) goto 400 if (xstar4(findex).ne.-8888.) then write(prounit,'(i6,a1,i3,a1,i4,a1,1pg12.4,a1,1pg12.4,a1,a)') f istar4(2),' ',cur_cor%app,' ',cur_cor%dest,' ',xstar4(findex), f ' ', cur_cor%realval,' ',cur_cor%bem else write(prounit,'(i6,a1,i3,a1,i4,a1,1pg12.4,a1,1pg12.4,a1,a)') f istar4(2),' ',cur_cor%app,' ',cur_cor%dest,' ', f '',' ',cur_cor%realval,' ',cur_cor%bem end if 400 xstar4(findex)=cur_cor%realval case (2) nstr=' ' ostr=' ' nstr1=' ' ostr1=' ' if (findex.eq.3) then call radcha(cur_cor%realval,'hh mm ss.ssss',nstr(1:13),ier,6) call radcha(xstar8(findex),'hh mm ss.ssss',ostr(1:13),ier,6) else if (findex.eq.6) then call radcha(cur_cor%realval,'vdd mm ss.sss',nstr(1:13),ier,6) call radcha(xstar8(findex),'vdd mm ss.sss',ostr(1:13),ier,6) else write(nstr,'(1pg16.8)') cur_cor%realval write(ostr,'(1pg16.8)') xstar8(findex) end if if (xstar8(findex).eq.-8888.d0) then ostr = '' else if (xstar8(findex).eq.-9999.d0) then ostr = '' end if if (ostr(1:1).eq.'<')then ostr1= ostr else if (ostr(1:1).ne.'+'.and.ostr(1:1).ne.'-')then if (ostr(2:2).eq.' ')ostr1=' '//ostr(1:15) if (ostr(2:2).ne.' ')ostr1=' '//ostr(1:16) else ostr1= ostr end if end if if (nstr(1:1).ne.'+'.and.nstr(1:1).ne.'-')then if (nstr(2:2).eq.' ')nstr1=' '//nstr(1:15) if (nstr(2:2).ne.' ')nstr1=' '//nstr(1:16) else nstr1= nstr end if call blankstounder(ostr1) call blankstounder(nstr1) if (xstar8(findex).ne.cur_cor%realval) then write(prounit,'(i6,a1,i3,a1,i4,a1,a,a1,a,a1,a)') istar4(2),' ', f cur_cor%app,' ',cur_cor%dest,' ',ostr1,' ',nstr1,' ', f cur_cor%bem end if xstar8(findex)=cur_cor%realval case (3) if (kennx4(findex).ne.cur_cor%intval) then write(prounit,'(i6,a1,i3,a1,i4,a1,i5,a1,i5,a1,a)') f istar4(2),' ', f cur_cor%app,' ',cur_cor%dest,' ',kennx4(findex),' ', f cur_cor%intval,' ',cur_cor%bem end if kennx4(findex)=cur_cor%intval case (4) if (kennx8(findex).ne.cur_cor%intval) then write(prounit,'(i6,a1,i3,a1,i4,a1,i5,a1,i5,a1,a)') f istar4(2),' ', f cur_cor%app,' ',cur_cor%dest,' ',kennx8(findex),' ', f cur_cor%intval,' ',cur_cor%bem end if kennx8(findex)=cur_cor%intval case (5) if (istar2(findex).eq.cur_cor%intval) goto 500 if (istar2(findex).ne.-8888) then write(prounit,'(i6,a1,i3,a1,i4,a1,i4,a1,i4,a1,a)') f istar4(2), F ' ',cur_cor%app,' ',cur_cor%dest,' ',istar2(findex),' ', F cur_cor%intval,' ',cur_cor%bem else write(prounit,'(i6,a1,i3,a1,i4,a1,i4,a1,i4,a1,a)') f istar4(2), F ' ',cur_cor%app,' ',cur_cor%dest,' ','',' ', F cur_cor%intval,' ',cur_cor%bem end if 500 istar2(findex)=cur_cor%intval case (6) if (istar4(findex).ne.cur_cor%intval) then write(prounit,'(i6,a1,i3,a1,i4,a1,i6,a1,i6,a1,a)') f istar4(2), F ' ',cur_cor%app,' ',cur_cor%dest,' ',istar4(findex),' ', F cur_cor%intval,' ',cur_cor%bem end if istar4(findex)=cur_cor%intval end select patchit ! Wenn noch mehr Korrekturen da sind, diese abarbeiten 3 if ((kindex.lt.thecors%nokor).and. F (thecors%cors(kindex+1)%catcn.eq.istar4(2))) goto 2 end subroutine !@process free(f90) ! kor_checkmark sieht nach, ob das bit index im bitfeld korflags gesetzt ist. ! Zum Sinn vgl. libuse/loadcor.f:kor_mark logical function kor_checkmark(index,korflags) integer*4 index integer*2 korflags(*) integer*2 mask mask=2**mod(index,16) ! print *,index if (index/16.gt.flgsz) then ! wir koennen gracefully failen, kor_checkmark=.FALSE. ! weil sich loadkors schon beschwert return ! wenn flgsz zu klein waere. endif if (index.lt.0) then print *, f 'applycor: CATCN darf nicht kleiner als Null werden (',index,')' kor_checkmark = .FALSE. return endif if (iand(korflags(index/16),mask).eq.0) then kor_checkmark=.FALSE. else kor_checkmark=.TRUE. end if end function kor_checkmark !@process free(f90) ! blankstounder wandelt blanks in einem String in underscores ! und bei der Gelegenheit gleich noch \0en in Spaces. Alles Quatsch, ! Fortran halt. subroutine blankstounder(str) character*(*) str integer i logical b b=.FALSE. do i=1,len(str) if (str(i:i).ne.' ') b=.TRUE. ! if (b.AND.(str(i:i).eq.' ')) str(i:i)='_' if (str(i:i).eq.' ') str(i:i)='_' if (str(i:i).lt.'!') str(i:i) = ' ' end do end subroutine blankstounder !@process free(f90) ! binarysearch ist eine einfache Suchroutine. Hoffentlich wird es ! bei keinem Katalog knapp wg. der Rechenzeit... ! gibt Null zurueck, wenn die Suche erfolglos war, sonst den *index* ! *eines* gesuchten Feldes integer function binarysearch(item,noent,data) include 'cors.f' integer*4 item ! Gesuchter Eintrag integer*2 noent ! Zahl der Eintraege in data type (t_cor) data(*) ! In diesem (nach catcn sortierten!) Feld wird gesucht integer upper,lower ! Obere und untere Grenze integer med upper=noent lower=1 3000 continue ! do { med=(upper+lower)/2 if (data(med)%catcn.gt.item) then upper=med elseif (data(med)%catcn.lt.item) then lower=med else binarysearch=med return end if ! Spezialfall, weil int/int abgerundet wird: if (data(upper)%catcn.eq.item) then binarysearch=upper return endif if (lower.lt.upper) goto 3000 ! } while (lower0 fuer einen harmlosen ! "Fehler" (z.B. keine Korrekturdatei), <0 fuer einen Fehler, der zum ! Abbruch des Programms fuehern sollte (z.B. Syntaxfehler in der ! Korrekturdatei). integer*4 inunit parameter (inunit=1000) !unit, von der gelesen wird integer ios integer arrind ! 1=XSTAR4 bis 7=Sonderfall integer i,ierd integer*2 nokor integer index,dummy character*132 inlin type (t_cordata),target :: thecors type (t_cor),pointer :: cur_cor common /korrekturen/ thecors ! Wenn irgendwas schiefgeht, soll zumindest keineR mehr versuchen, Korrekturen ! zu lesen thecors%nokor = 0 ! Bitfeld und anderes initialisieren do i=1,flgsz thecors%korflags(i)=0 end do ! Datei aufmachen, Header lesen und parsen open(UNIT=inunit,FILE=name,STATUS='OLD',IOSTAT=ios) if (ios.ne.0) then ier = 1 return end if read(inunit,'(A)') inlin if (inlin(1:4).ne.'GFhK') then print *,'Korrekturdatei hat falsche Kennung' ier = -1 return end if ! hier koennte die Teleki-Nummer geprueft werden ! Gibt es Appendices? if (inlin(15:15).eq.'1') then thecors%hasapp=1 else thecors%hasapp=0 end if ! Jetzt Zeile fuer Zeile parsen nokor = 0 1 continue ! while(1) { read(inunit,'(A)',END=999) inlin ! Kommentar -- naechste Zeile lesen if (inlin(1:3).eq.' ') goto 1 nokor=nokor+1 if (nokor.gt.korsz) then print *,'Zu viele Korrekturen. Bitte korsz erhoehen' ier = -10 return end if cur_cor => thecors%cors(nokor) ! Erst das Zielarray bestimmen, dann entscheiden, was weiter zu tun ist read(inlin,*) arrind if (thecors%hasapp.eq.0) then call findfield(inlin,5,index,dummy) cur_cor%bem = inlin(index:index+7) withoutapp: select case(arrind) case default withoutapp print *,'Index des Zielarrays muss zwischen 1 und 7 liegen.' print *,'Zeile: ',inlin case (1) ! XSTAR4 read(inlin,*) arrind,cur_cor%dest,cur_cor%catcn,cur_cor%realval case (2) ! XSTAR8 read(inlin,*) arrind,cur_cor%dest,cur_cor%catcn,cur_cor%realval if ((cur_cor%dest.eq.3).or.(cur_cor%dest.eq.6)) f call getpos(cur_cor,thecors%hasapp,inlin) case (3:6) read(inlin,*) arrind,cur_cor%dest,cur_cor%catcn,cur_cor%intval case (7) read(inlin,*) arrind,cur_cor%dest,cur_cor%catcn call dospecials(inlin,thecors%hasapp,nokor,ierd) if (ierd.lt.0) then ier = ierd return endif goto 1 ! dospecials macht alles selbst end select withoutapp else call findfield(inlin,6,index,dummy) cur_cor%bem = inlin(index:index+7) withapp: select case(arrind) case default withapp print *,'Index des Zielarrays muss zwischen 1 und 7 liegen.' print *,'Zeile: ',inlin case (1) read(inlin,*) arrind,cur_cor%dest,cur_cor%catcn, f cur_cor%app,cur_cor%realval case (2) read(inlin,*) arrind,cur_cor%dest,cur_cor%catcn, f cur_cor%app,cur_cor%realval if ((cur_cor%dest.eq.3).or.(cur_cor%dest.eq.6)) F call getpos(cur_cor,thecors%hasapp,inlin) case (3:6) read(inlin,*) arrind,cur_cor%dest,cur_cor%catcn, f cur_cor%app,cur_cor%intval case (7) read(inlin,*) arrind,cur_cor%dest,cur_cor%catcn,cur_cor%app call dospecials(inlin,thecors%hasapp,nokor,ierd) if (ierd.lt.0) then ier = ierd return endif goto 1 ! dospecials macht alles selbst end select withapp end if !in cur_cor%dest stehen Arraycode und Feldindex: cur_cor%dest=cur_cor%dest+arrind*100 ! Stern markieren if (cur_cor%catcn.gt.flgsz*16) then print *, flgsz,' flgsz' print *, cur_cor%catcn,' curcor' print *, f 'Kein Platz fuer Marker, flgsz in libuse/cors.f vergroessern.' print *,'Zeile: ',inlin ier=-5 return end if call kor_mark(cur_cor%catcn,thecors%korflags) goto 1 ! } 999 continue ! Fertig mit Lesen ! Jetzt wird nach Sternnummer sortiert. Dazu wird ueber das Feld ! thecors%sortcors operiert, das Zeiger auf die Eintraege in cors ! bekommt. call korsort(nokor) !nokor in thecors aktualisieren thecors%nokor=nokor ! Zum Schluss die Protokolldatei oeffnen open(unit=prounit,FILE='korrprot',status='REPLACE'); end subroutine !@process free(f90) ! dospecials behandelt Spezialfaelle, im Augenblick lediglich genaeherte ! Koordinaten. subroutine dospecials(inlin,hasapp,nokor,ierd) include 'cors.f' character*(*), INTENT(IN):: inlin integer*2, INTENT(IN):: hasapp integer*2, INTENT(INOUT):: nokor integer, INTENT(OUT):: ierd type (t_cordata),target:: thecors common /korrekturen/ thecors integer valfield ! Index des Anfangszeichens des Wertefelds integer index,dummy integer pos_len type (t_cor),pointer :: cur_cor type (t_cor),pointer :: org_cor ! Hier drin steht die Korrektur der Position character*10 rafmt,decfmt data rafmt,decfmt /'hhmmssssss','vddmmsssss'/ cur_cor=>thecors%cors(nokor) org_cor=>cur_cor specials: select case (cur_cor%dest) case default specials print *,'Sonderfallkennung',cur_cor%dest,'unbekannt.' print *,'Zeile: ', inlin ier = -2 return case (1) !genaeherte RA if (hasapp.eq.0) then call findfield(inlin,5,index,dummy) cur_cor%bem = inlin(index:index+7) call findfield(inlin,4,valfield,pos_len) else call findfield(inlin,6,index,dummy) cur_cor%bem = inlin(index:index+7) call findfield(inlin,5,valfield,pos_len) end if call charad(inlin(valfield:valfield+pos_len-1), f rafmt(1:pos_len),cur_cor%realval,ier,6) cur_cor%dest=203 if (cur_cor%catcn.gt.flgsz*16) then print *, f 'Kein Platz fuer Marker, flgsz in libuse/cors.f vergroessern.' print *,'Zeile: ',inlin ierd=-5 return end if call kor_mark(cur_cor%catcn,thecors%korflags) nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! Kennung(RA) anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=403 cur_cor%intval=4990 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! EPRAS anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=202 cur_cor%realval=-8888.d0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! Kennung(EPRAS) anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=402 cur_cor%intval=0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! EPMRAS anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=213 cur_cor%realval=-8888.d0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! Kennung(EPMRAS) anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=413 cur_cor%intval=0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! NOBRAS anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=103 cur_cor%realval=-8888.0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! Kennung(NOBRAS) anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=303 cur_cor%intval=0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! QRAS anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=511 cur_cor%intval=0 case (2) ! genaeherte DEC if (hasapp.eq.0) then call findfield(inlin,5,index,dummy) cur_cor%bem = inlin(index:index+7) call findfield(inlin,4,valfield,pos_len) else call findfield(inlin,6,index,dummy) cur_cor%bem = inlin(index:index+7) call findfield(inlin,5,valfield,pos_len) end if call charad(inlin(valfield:valfield+pos_len-1), F decfmt(1:pos_len),cur_cor%realval,ier,6) cur_cor%dest=206 nokor=nokor+1 if (cur_cor%catcn.gt.flgsz*16) then print *, f 'Kein Platz fuer Marker, flgsz in libuse/cors.f vergroessern.' print *,'Zeile: ',inlin ierd=-5 return end if call kor_mark(cur_cor%catcn,thecors%korflags) cur_cor=>thecors%cors(nokor) ! Kennung(DEC) anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=406 cur_cor%intval=4990 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! EPDEC anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=205 cur_cor%realval=-8888.d0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! Kennung(EPDEC) anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=405 cur_cor%intval=0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! EPMDEC anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=214 cur_cor%realval=-8888.d0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! Kennung(EPMDEC) anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=414 cur_cor%intval=0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! NOBDEC anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=105 cur_cor%realval=-8888.0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! Kennung(NOBDEC) anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=305 cur_cor%intval=0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! QDEC anpassen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=514 cur_cor%intval=0 ! INDVAR setzen, evtl. geg. Mag loeschen case (3) ! Stern als variabel kennzeichnen if (hasapp.eq.0) then call findfield(inlin,5,index,dummy) cur_cor%bem = inlin(index:index+7) call findfield(inlin,4,valfield,pos_len) else call findfield(inlin,6,index,dummy) cur_cor%bem = inlin(index:index+7) call findfield(inlin,5,valfield,pos_len) end if read(inlin(valfield:valfield+1),'(i1)') cur_cor%intval cur_cor%dest = 507 if (cur_cor%catcn.gt.flgsz*16) then print *, F 'Kein Platz fuer Marker, flgsz in libuse/cors.f vergroessern.' print *,'Zeile: ',inlin ierd=-5 return end if call kor_mark(cur_cor%catcn,thecors%korflags) nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! CATMAG löschen cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=101 cur_cor%realval=-8888.d0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! Kennung(CATMAG) cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=301 cur_cor%intval=0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! SYSMAG cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=509 cur_cor%intval=0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) ! INDMAG cur_cor%catcn=org_cor%catcn cur_cor%app=org_cor%app cur_cor%dest=508 cur_cor%intval=0 nokor=nokor+1 cur_cor=>thecors%cors(nokor) end select specials end subroutine !@process free(f90) ! findfield gibt den Anfangsindex des nf-ten Feldes (durch Leerzeichen ! getrennt) von str in index zurueck, sowie in flen die Laenge des Feldes subroutine findfield(str,nf,index,flen) character*(*) str integer nf,index integer flen integer cf ! augenblickliches Feld integer spacing ! 1=ueberlese Leerzeichen,0=ueberlese Feld integer len character char index = 1 flen = 1 lgt=len(str) if (str(index:index).eq.' ') then cf = 0 spacing = 1 else cf = 1 spacing = 0 end if 2000 index=index+1 ! while (!nf=cf) { if (spacing.eq.1) then if (str(index:index).eq.' ') goto 2000 cf = cf+1 if (cf.eq.nf) goto 2002 spacing = 0 else if (str(index:index).ne.' ') goto 2000 spacing = 1 end if if (index.gt.lgt) goto 2001 ! break goto 2000 ! } 2001 index = 0 flen = 0 return 2002 char=str(index+flen:index+flen) ! if ((char.ge.'0'.and.char.le.'9').or.char.eq.'+'.or.char.eq.'-') then if (char.ne.' ') then flen=flen+1 if (index+flen.lt.lgt) goto 2002 end if end subroutine ! kor_mark markiert einen Stern im bitfeld korflags als ! korrekturbeduerftig. Es wird nicht ueberprueft, ob in korflags ! Platz ist -- dies muss die Routine tun, die korflags definiert. subroutine kor_mark(index,korflags) integer*4 index integer*2 korflags(*) integer*2 mask if (index.lt.0) then print *,'loadcor: Fehler: Negative CATCN nicht zugelassen (' C ,index,')' return endif k=index/16 mask=2**mod(index,16) korflags(k)=ior(korflags(k),mask) end subroutine ! Sortierroutine -- leidlich angepasst aus Numerical Recipes ! (bzw. xsort) !@process FREE(F90) subroutine korsort(ntot) include 'cors.f' common /korrekturen/ thecors type (t_cordata),target:: thecors integer*2 ntot integer i,k,l,ir type (t_cor) rra if (ntot.le.1) goto 30 l = 0.5d0 * ntot + 1 ir = ntot 10 continue if (l .gt. 1) then l = l - 1 rra = thecors%cors(l) else rra = thecors%cors(ir) thecors%cors(ir) = thecors%cors(1) ir = ir - 1 if ( ir .le. 1) then thecors%cors(1) = rra return end if end if i = l j = l + l 20 if ( j .le. ir) then if ( j .lt. ir) then if (thecors%cors(j)%catcn .lt. thecors%cors(j+1)%catcn) j=j +1 end if if (rra%catcn .lt. thecors%cors(j)%catcn ) then thecors%cors(i) = thecors%cors(j) i = j j = j + j else j = ir + 1 end if goto 20 end if thecors%cors(i) = rra goto 10 30 continue end !@process FREE(F90) !Spezialbehandlung fuer Positionen subroutine getpos(cur_cor,hasapp,inlin) include 'cors.f' type (t_cor) cur_cor integer*2 hasapp character*(*) inlin character*10 rafmt,decfmt data rafmt,decfmt /'hhmmssssss','vddmmsssss'/ integer pos_start,ier,pos_len if (hasapp.eq.0) then call findfield(inlin,4,pos_start,pos_len) else call findfield(inlin,5,pos_start,pos_len) end if if (cur_cor%dest.eq.3) then call charad(inlin(pos_start:pos_start+pos_len-1), f rafmt(1:pos_len),cur_cor%realval,ier,6) end if if (cur_cor%dest.eq.6) then call charad(inlin(pos_start:pos_start+pos_len-1), f decfmt(1:pos_len),cur_cor%realval,ier,6) end if end subroutine