SUBROUTINE PRECES (XA,XD,XMUE,XMUES,PX,YA,YD,YMUE,YMUES) 00003850 C 00003860 C PRAEZESSIONSUEBERTRAGUNG VON EIGENBEWEGUNGEN UND OERTERN 00003870 C EINE PRAEZESSION DER EIGENBEWEGUNGEN ERFORDERT STETS AUCH DIE 00003880 C PRAEZESSION DER OERTER. 00003890 C 00003900 C EINGABE: XA = ALPHA FUER AUSGANGSAEQUINOX 00003910 C XD = DELTA FUER AUSGANGSAEQUINOX 00003920 C XMUE = E.B. IN ALPHA FUER AUSGANGSAEQUINOX 00003930 C XMUES = E.B. IN DELTA FUER AUSGANGSAEQUINOX 00003940 C PX = PRAEZESSIONSMATRIX 00003950 C AUSGABE: YA = ALPHA FUER ENDAEQUINOX 00003960 C YD = DELTA FUER ENDAEQUINOX 00003970 C YMUE = E.B. IN ALPHA FUER ENDAEQUINOX 00003980 C YMUES = E.B. IN DELTA FUER ENDAEQUINOX 00003990 C ALLE WINKEL IM BOGENMASS 00004000 C 00004010 C 00004020 IMPLICIT REAL*8 (A-H,O-Z) 00004030 REAL*8 PX(3,3),VA(3,1),VD(3,1),XRES(3,1),YRES(3,1),ZRES(3,1) 00004040 C 00004050 C PRAEZESSION DES ORTES 00004060 C 00004070 CALL PRCPOS (XA,XD,YA,YD,PX) 00004080 C 00004090 C BERECHNUNG DER VEKTOREN DER ABGELEITETEN RICHTUNGSKOSINUSSE 00004100 C 00004110 CALL DLDA (XA,XD,VA) 00004120 CALL DLDD (XA,XD,VD) 00004130 C 00004180 C PRAEZESSION DER EIGENBEWEGUNGEN 00004190 C 00004200 CALL GMPRD (PX,VA,XRES,3,3,1) 00004210 CALL SMPY (XRES,XMUE,YRES,3,1) 00004240 CALL GMPRD (PX,VD,XRES,3,3,1) 00004260 CALL SMPY (XRES,XMUES,ZRES,3,1) 00004290 CALL GMADD (YRES,ZRES,XRES,3,1) 00004310 C 00004350 C AUFLOESUNG NACH DEN EIGENBEWEGUNGS-KOMPONENETEN 00004360 C 00004370 CALL DLDA (YA,YD,VA) 00004380 CALL SCLPRD (XRES,VA,YMUE,3) 00004390 C 00004440 YMUE = YMUE/(DCOS(YD)*DCOS(YD)) 00004450 C 00004460 CALL DLDD (YA,YD,VD) 00004470 CALL SCLPRD (XRES,VD,YMUES,3) 00004480 C 00004530 YMUES = YMUES 00004540 RETURN 00004550 END 00004560 SUBROUTINE PRZMTX (ZET,TETA,ZETA,PREC) 00003200 C 00003210 C BERECHNUNG DER PRAEZESSIONSMATRIX 00003220 C 00003230 C EINGABE DER PRAEZESSINSWINKEL IM BOGENMASS 00003240 C 00003250 IMPLICIT REAL*8 (A-H,O-Z) 00003260 REAL*8 PREC(3,3) 00003270 C 00003280 SZET = DSIN(ZET) 00003290 CZET = DCOS(ZET) 00003300 SZETA = DSIN(ZETA) 00003310 CZETA = DCOS(ZETA) 00003320 STETA = DSIN(TETA) 00003330 CTETA = DCOS(TETA) 00003340 C 00003350 PREC(1,1) = +CZETA*CTETA*CZET - SZETA*SZET 00003360 PREC(1,2) = -SZETA*CTETA*CZET - CZETA*SZET 00003370 PREC(1,3) = -STETA*CZET 00003380 PREC(2,1) = +CZETA*CTETA*SZET + SZETA*CZET 00003390 PREC(2,2) = -SZETA*CTETA*SZET + CZETA*CZET 00003400 PREC(2,3) = -STETA*SZET 00003410 PREC(3,1) = +CZETA*STETA 00003420 PREC(3,2) = -SZETA*STETA 00003430 PREC(3,3) = +CTETA 00003440 RETURN 00003450 END 00003460 SUBROUTINE KPRZ(IP,T0,T1,ZET,TETA,ZETA) C C BESTIMMUNG DER PRAEZESSIONSWINKEL NACH VERSCHIEDENEN KONSTANTEN C JE NACH WAHL DES PARAMETERS IP: C C IP = 1 : NEUE IAU(1976) PRAEZESSION, C IP = 2 : NEWCOMB'S PRAEZESSION, C IP = 3 : STRUVE'S PRAEZESSION. C C EINGABE: T0 = JULIANISCHES DATUM DER AUSGANGSEPOCHE C T1 = JULIANISCHES DATUM DER ENDEPOCHE C AUSGABE: PRAEZESSIONSWINKEL IM BOGENMASS C C IMPLICIT REAL*8 (A-H,O-Z) C PI = 3.141592653589793D0 C C EPOCHENDIFFERENZEN IN JULIANISCHE JAHRHUNDERTE UMRECHNEN C XJ2000 = 2451545.D0 DT0 = (T0-XJ2000)/36525.D0 DT1 = (T1-T0)/36525.D0 C C................................................................ IF (IP.NE.1) GOTO 200 C C BESTIMMUNG DER PRAEZESSINSWINKEL NACH DEN ANGABEN C BEI LIESKE, ASTRON.&ASTROPHYS., 73, 282-284,(1979). C ...................................................... C ZETA = ( 2306.2181D0 + 1.39656D0*DT0 - 0.000139D0*DT0*DT0)*DT1 + 1 ( 0.30188D0 - 0.000344D0*DT0)*DT1*DT1 + 2 0.017998D0*DT1*DT1*DT1 ZET = ( 2306.2181D0 + 1.39656D0*DT0 - 0.000139D0*DT0*DT0)*DT1 + 1 ( 1.09468D0 + 0.000066D0*DT0)*DT1*DT1 + 2 0.018203D0*DT1*DT1*DT1 TETA = ( 2004.3109D0 - 0.85330D0*DT0 - 0.000217D0*DT0*DT0)*DT1 + 1 (-0.42665D0 - 0.000217D0*DT0)*DT1*DT1 - 2 0.041833D0*DT1*DT1*DT1 C GOTO 700 C 200 CONTINUE C C .................................................... IF (IP.NE.2) GOTO 300 C C PRAEZESSIONSWINKEL NACH NEWCOMBS PRAEZESSIONSWERTEN C .................................................... C ZETA = ( 2305.69970D0 + 1.3974397D0*DT0 + 0.000060D0*DT0*DT0)*DT1+ 1 ( 0.3020079D0 - 0.000270D0*DT0)*DT1*DT1 + 2 0.0179962D0*DT1*DT1*DT1 ZET = ( 2305.69970D0 + 1.3974397D0*DT0 + 0.000060D0*DT0*DT0)*DT1+ 1 ( 1.095432D0 + 0.00039D0*DT0)*DT1*DT1 + 2 0.018326D0*DT1*DT1*DT1 TETA = ( 2003.874600D0 - 0.8540465D0*DT0 - 0.000370D0*DT0*DT0)*DT1 1 +(-0.427073D0 - 0.000370D0*DT0)*DT1*DT1 - 2 0.041803D0*DT1*DT1*DT1 C GOTO 700 C 300 CONTINUE C C ........................................................... IF (IP.NE.3) GOTO 400 C C BESTIMMUNG DER PRAEZESSIONSWINKEL NACH STRUVE'S PRAEZESSION C ........................................................... C ZETA = ( 2306.013272D0 + 1.424560853 D0*DT0)*DT1 + 1 0.316313512D0*DT1*DT1 ZET = ( 2306.013272D0 + 1.424560853 D0*DT0)*DT1 + 1 1.108347345D0*DT1*DT1 TETA = ( 2004.386800D0 - 0.8630368665D0*DT0)*DT1 + 1 (-0.4315184332D0)*DT1*DT1 C 400 CONTINUE C 700 CONTINUE C C UMWANDLUNG INS BOGENMASS C X = (180.D0*3600.D0) ZETA = (ZETA*PI)/X TETA = (TETA*PI)/X ZET = (ZET *PI)/X RETURN END SUBROUTINE JEJD(JE,JD) 00002100 C 00002200 C UMWANDLUNG DER JULIANISCHEN EPOCHE IN JULIANISCHES DATUM 00002300 C 00002400 REAL*8 JE,JD 00002500 C 00002600 JD = (JE-2000.D0)*365.25D0 + 2451545.D0 00002700 C 00002800 RETURN 00002900 END 00003000 C 00002091 SUBROUTINE DIRCOS (A,D,V) 00002100 C 00002110 C BERECHNUNG DES VEKTORS V DER RICHTUNGSKOSINUSSE 00002120 C 00002130 C EINGABE: A, D = ALPHA, DELTA IM BOGENMASS 00002140 C AUSGABE: V = VEKTOR DER RICHTUNGSKOSINUSSE 00002150 C 00002160 IMPLICIT REAL*8 (A-H,O-Z) 00002170 C 00002180 REAL*8 V(3,1) 00002190 C 00002200 C 00002210 V(1,1) = DCOS(A)*DCOS(D) 00002220 V(2,1) = DSIN(A)*DCOS(D) 00002230 V(3,1) = DSIN(D) 00002240 RETURN 00002250 END 00002260 C 00007890 SUBROUTINE GMPRD (A,B,R,N,M,L) 00007900 C 00007910 C MULTIPLIKATION ZWEIER ALLGEMEINER MATRIZEN, R = A.B 00007920 C A = NAME DER 1. EINGABEMATRIX 00007930 C B = NAME DER 2. EINGABEMATRIX 00007940 C R = NAME DES PRODUKTES R = A.B 00007950 C N = ZAHL DER ZEILEN VON A = ZAHL DER ZEILEN VON R 00007960 C M = ZAHL DER SPALTEN VON A = ZAHL DER ZEILEN VON B 00007970 C L = ZAHL DER SPALTEN VON B = ZAHL DER SPALTEN VON R 00007980 C 00007990 C 00008000 IMPLICIT REAL*8 (A-H,O-Z) 00008010 C 00008020 DIMENSION A(N,M),B(M,L),R(N,L) 00008030 C 00008040 C 00008050 DO 20 I = 1,N 00008060 DO 20 J = 1,L 00008070 R(I,J) = 0.D0 00008080 DO 20 K = 1,M 00008090 20 R(I,J) = R(I,J) + A(I,K)*B(K,J) 00008100 RETURN 00008110 END 00008120 C 00007630 SUBROUTINE NUTMTX (DPSI,DEPS,EPS,XN) 00007640 C 00007650 C BERECHNUNG DER NUTATIONSMATRIX 00007660 C 00007670 IMPLICIT REAL*8 (A-H,O-Z) 00007680 REAL*8 XN(3,3) 00007690 C 00007700 CDP= DCOS(DPSI) 00007710 SDP= DSIN(DPSI) 00007720 CE = DCOS(EPS) 00007730 SE = DSIN(EPS) 00007740 CEDE = DCOS(-EPS-DEPS) 00007750 SEDE = DSIN(-EPS-DEPS) 00007760 C 00007770 XN(1,1) = CDP 00007780 XN(1,2) = -SDP*CE 00007790 XN(1,3) = -SDP*SE 00007800 XN(2,1) = +CEDE*SDP 00007810 XN(2,2) = +CEDE*CDP*CE - SEDE*SE 00007820 XN(2,3) = +CEDE*CDP*SE + SEDE*CE 00007830 XN(3,1) = -SEDE*SDP 00007840 XN(3,2) = -SEDE*CDP*CE - CEDE*SE 00007850 XN(3,3) = -SEDE*CDP*SE + CEDE*CE RETURN 00007870 END 00007880 SUBROUTINE KSTNUT (T,DPSIL,DPSIS,DEPSL,DEPSS,EPS) 00000100 C 00000200 C BERECHNUNG DER LANG- UND KURZPERIODISCHEN NUTATION IN 00000300 C LAENGE UND SCHIEFE (BEZOGEN AUF ECLIPTIC OF DATE), 00000400 C SOWIE DIE SCHIEFE DER EKLIPTIK FUER DAS JULIANISCHE 00000500 C DATUM T. 00000600 C 00000700 C............................................................. 00000800 C GRUNDLAGE: WAHR'S THEORIE. 00000900 C............................................................. 00001000 C 00001100 C EINGABE: T = JULIANISCHES DATUM 00001200 C AUSGABE: DPSIL = LANGPERIODISCHE NUTATION IN LAENGE 00001300 C DPSIS = KURZPERIODISCHE NUTATION IN LAENGE 00001400 C DEPSL = LANGPERIODISCHE NUTATION IN SCHIEFE 00001500 C DEPSS = KURZPERIODISCHE NUTATION IN SCHIEFE 00001600 C EPS = MITTLERE SCHIEFE DER EKLIPTIK 00001700 C ALLE WINKEL IM BOGENMASS 00001800 C 00001900 IMPLICIT REAL*8 (A-H,O-Z) 00002000 REAL*8 XL(106),XLS(106),XF(106),XD(106),XOMEGA(106), 00002100 1 CLONG(106),COBL(106),XLONG(106),XOBL(106), 00002200 2 L,LS 00002300 C 00002400 C 00002500 DATA XL /0.D0,0.D0,-2.D0,2.D0,-2.D0,1.D0,0.D0,2.D0,5*0.D0, 00002600 1 2.D0,5*0.D0,-2.D0,0.D0,2.D0,0.D0,1.D0,2.D0,3*0.D0, 00002700 2 -1.D0,0.D0,0.D0,1.D0,0.D0,1.D0,1.D0,-1.D0,0.D0, 00002800 3 1.D0,-1.D0,-1.D0,1.D0,0.D0,2.D0,1.D0,2.D0,0.D0, 00002900 4 -1.D0,-1.D0,1.D0,-1.D0,1.D0,0.D0,0.D0,1.D0,1.D0, 00003000 5 2.D0,0.D0,0.D0,1.D0,0.D0,1.D0,2.D0,0.D0,1.D0,0.D0, 00003100 6 3*1.D0,-1.D0,-2.D0,3.D0,0.D0,1.D0,-1.D0,2.D0,1.D0, 00003200 7 3.D0,0.D0,-1.D0,1.D0,-2.D0,-1.D0,2.D0,1.D0,1.D0, 00003300 8 -2.D0,-1.D0,1.D0,2.D0,2.D0,1.D0,0.D0,3.D0,1.D0,0.D0, 00003400 9 -1.D0,3*0.D0,1.D0,0.D0,1.D0,1.D0,2.D0,0.D0,0.D0/ 00003500 DATA XLS /5*0.D0,-1.D0,-2.D0,0.D0,0.D0,1.D0,1.D0,-1.D0,3*0.D0, 00003600 1 2.D0,1.D0,2.D0,-1.D0,0.D0,-1.D0,0.D0,1.D0,0.D0,1.D0,0.D000003700 2 ,2*1.D0,0.D0,1.D0,20*0.D0,1.D0,1.D0,-1.D0,7*0.D0,-1.D0, 00003800 3 0.D0,1.D0,0.D0,0.D0,1.D0,0.D0,-1.D0,-1.D0,0.D0,0.D0, 00003900 4 -1.D0,1.D0,10*0.D0,1.D0,3*0.D0,-1.D0,6*0.D0,1.D0,-1.D0, 00004000 5 0.D0,0.D0,1.D0,0.D0,-1.D0,1.D0,3*0.D0,1.D0/ 00004100 DATA XF /0.D0,0.D0,2.D0,-2.D0,2.D0,0.D0,2.D0,-2.D0,2.D0,0.D0, 00004200 1 3*2.D0,0.D0,2.D0,0.D0,0.D0,2.D0,0.D0,0.D0,2.D0,0.D0,2.D0,00004300 2 2*0.D0,-2.D0,-2.D0,0.D0,0.D0,2.D0,2.D0,0.D0,2.D0,2.D0, 00004400 3 0.D0,2.D0,3*0.D0,3*2.D0,0.D0,4*2.D0,2*0.D0,2.D0,0.D0, 00004500 4 3*2.D0,0.D0,2.D0,0.D0,2.D0,2.D0,2*0.D0,2.D0,0.D0,-2.D0, 00004600 5 2*0.D0,3*2.D0,0.D0,4*2.D0,3*0.D0,2.D0,2*0.D0,2*2.D0,0.D0, 00004700 6 3*2.D0,4.D0,0.D0,2*2.D0,0.D0,4.D0,3*2.D0,0.D0,-2.D0, 00004800 7 2.D0,0.D0,-2.D0,2.D0,0.D0,-2.D0,0.D0,2.D0,0.D0/ 00004900 DATA XD /5*0.D0,-1.D0,-2.D0,0.D0,-2.D0,0.D0,5*-2.D0,2*0.D0, 00005000 1 -2.D0,0.D0,2.D0,3*-2.D0,-1.D0,-2.D0,2*2.D0,0.D0,1.D0, 00005100 2 -2.D0,4*0.D0,-2.D0,0.D0,2.D0,2*0.D0,2.D0,0.D0,2.D0,0.D0,00005200 3 -2.D0,3*0.D0,2.D0,-2.D0,2.D0,-2.D0,2*0.D0,2*2.D0,-2.D0, 00005300 4 2*2.D0,2*-2.D0,2*0.D0,-2.D0,0.D0,1.D0,3*0.D0,2.D0, 00005400 5 2*0.D0,2.D0,0.D0,-2.D0,3*0.D0,1.D0,0.D0,-4.D0,2.D0, 00005500 6 4.D0,-4.D0,-2.D0,2.D0,4.D0,0.D0,2*-2.D0,2*2.D0,3*-2.D0, 00005600 7 0.D0,2.D0,0.D0,-1.D0,2.D0,-2.D0,0.D0,-2.D0,2*2.D0, 00005700 8 4.D0,1.D0/ 00005800 DATA XOMEGA /1.D0,2.D0,1.D0,0.D0,2.D0,0.D0,1.D0,1.D0,2.D0,0.D0, 00005900 1 2*2.D0,1.D0,3*0.D0,1.D0,2.D0,5*1.D0,2*0.D0,1.D0, 00006000 2 0.D0,2.D0,1.D0,0.D0,2.D0,0.D0,1.D0,2.D0,0.D0,2.D0, 00006100 3 0.D0,2*1.D0,2.D0,1.D0,2.D0,0.D0,2.D0,2.D0,0.D0, 00006200 4 4*1.D0,0.D0,3*2.D0,0.D0,2.D0,4*1.D0,0.D0,1.D0,5*0.D0,00006300 5 2.D0,2.D0,1.D0,3*2.D0,1.D0,1.D0,2.D0,0.D0,2.D0,2.D0, 00006400 6 0.D0,2*2.D0,0.D0,2.D0,1.D0,2.D0,2.D0,0.D0,1.D0,2.D0, 00006500 7 1.D0,2.D0,2.D0,0.D0,3*1.D0,2.D0,2*0.D0,2*1.D0,2*0.D0,00006600 8 2.D0,0.D0/ 00006700 DATA XLONG /-171996.D0,2062.D0,46.D0,11.D0,-3.D0,-3.D0,-2.D0, 00006800 1 1.D0,-13187.D0,1426.D0,-517.D0,217.D0,129.D0,48.D0, 00006900 2 -22.D0,17.D0,-15.D0,-16.D0,-12.D0,-6.D0,-5.D0,4.D0, 00007000 3 4.D0,-4.D0,1.D0,1.D0,-1.D0,2*1.D0,-1.D0,-2274.D0, 00007100 4 712.D0,-386.D0,-301.D0,-158.D0,123.D0,2*63.D0, 00007200 5 -58.D0,-59.D0,-51.D0,-38.D0,2*29.D0,-31.D0,26.D0, 00007300 6 21.D0,16.D0,-13.D0,-10.D0,-7.D0,7.D0,-7.D0,-8.D0, 00007400 7 2*6.D0,-6.D0,-7.D0,6.D0,-5.D0,5.D0,-5.D0,-4.D0,4.D0, 00007500 8 -4.D0,-3.D0,3.D0,2*-3.D0,-2.D0,2*-3.D0,2.D0,-2.D0, 00007600 9 2.D0,-2.D0,2*2.D0,1.D0,-1.D0,1.D0,-2.D0,-1.D0,1.D0, 00007700 1 2*-1.D0,3*1.D0,2*-1.D0,2*1.D0,-1.D0,2*1.D0,7*-1.D0, 00007800 2 1.D0,-1.D0,1.D0/ 00007900 DATA XOBL /92025.D0,-895.D0,-24.D0,0.D0,1.D0,0.D0,1.D0,0.D0, 00008000 1 5736.D0,54.D0,224.D0,-95.D0,-70.D0,1.D0,2*0.D0,9.D0, 00008100 2 7.D0,6.D0,2*3.D0,2*-2.D0,7*0.D0,977.D0,-7.D0,200.D0, 00008200 3 129.D0,-1.D0,-53.D0,-2.D0,-33.D0,32.D0,26.D0,27.D0, 00008300 4 16.D0,-1.D0,-12.D0,13.D0,-1.D0,-10.D0,-8.D0,7.D0, 00008400 5 5.D0,0.D0,-3.D0,2*3.D0,0.D0,-3.D0,2*3.D0,-3.D0, 00008500 6 3.D0,0.D0,3.D0,5*0.D0,5*1.D0,-1.D0,1.D0,-1.D0,1.D0, 00008600 7 0.D0,2*-1.D0,0.D0,-1.D0,1.D0,0.D0,-1.D0,2*1.D0, 00008700 8 2*0.D0,-1.D0,17*0.D0/ 00008800 C 00008900 PI = 3.141592653589793D0 00009000 C 00009100 GO TO 99 00009200 1729 FORMAT(1X,5F25.14) 00009300 DO 80 I = 1,106 00009400 80 WRITE(6,1729) XL(I),XLS(I),XF(I),XD(I),XOMEGA(I) 00009500 DO 90 I = 1,106 00009600 90 WRITE(6,1729) XLONG(I),XOBL(I) 00009700 99 CONTINUE 00009800 C 00009900 C KOEFFIZIENTEN FUER JULIANISCHES EINGABEDATUM T BERECHNEN. 00010000 C 00010100 DT = (T - 2451545.D0)/36525.D0 00010200 C 00010300 PI2 = 2.D0*PI 00010400 C 00010500 DPSIL= 0.D0 00010600 DPSIS= 0.D0 00010700 DEPSL= 0.D0 00010800 DEPSS= 0.D0 00010900 C 00011000 C 00011100 L = 2.355548393543940D00 + 3.470890870943613D00*DT + 00011200 1 0.151795163555D-03*DT*DT 00011300 2 + 0.310280756D-06*DT*DT*DT + 1325.D0*PI2*DT 00011400 LS = 6.240035939326022D00 + 6.266610613405095D00*DT - 00011500 1 0.279737494D-05*DT*DT - 00011600 2 0.58177642D-07*DT*DT*DT + 99.D0*PI2*DT 00011700 F = 1.627901933971961D0 + 1.431476083449192D00*DT - 00011800 1 0.64271749705D-04*DT*DT + 00011900 2 0.53329505D-07*DT*DT*DT + 1342.D0*PI2*DT 00012000 D = 5.198469513579921D00 + 5.360106496672713D00*DT - 00012100 1 0.33408510765D-04*DT*DT + 00012200 2 0.92114599D-07*DT*DT*DT + 1236.D0*PI2*DT 00012300 OMEGA = 2.182438624360994D00 - 2.341119397855579D00*DT + 00012400 1 0.36142859927D-04*DT*DT + 00012500 2 0.38785094D-07*DT*DT*DT - 5.D0*PI2*DT 00012600 C 00012700 C 00012800 DO 10 I = 1,106 00012900 CLONG(I) = XLONG(I) 00013000 COBL(I) = XOBL(I) 00013100 10 CONTINUE 00013200 C 00013300 CLONG( 1) = XLONG( 1) - 174.2D0*DT 00013400 CLONG( 2) = XLONG( 2) + 0.2D0*DT 00013500 CLONG( 9) = XLONG( 9) - 1.6D0*DT 00013600 CLONG(10) = XLONG(10) - 3.4D0*DT 00013700 CLONG(11) = XLONG(11) + 1.2D0*DT 00013800 CLONG(12) = XLONG(12) - 0.5D0*DT 00013900 CLONG(13) = XLONG(13) + 0.1D0*DT 00014000 CLONG(16) = XLONG(16) - 0.1D0*DT 00014100 CLONG(18) = XLONG(18) + 0.1D0*DT 00014200 CLONG(31) = XLONG(31) - 0.2D0*DT 00014300 CLONG(32) = XLONG(32) + 0.1D0*DT 00014400 CLONG(33) = XLONG(33) - 0.4D0*DT 00014500 CLONG(38) = XLONG(38) + 0.1D0*DT 00014600 CLONG(39) = XLONG(39) - 0.1D0*DT 00014700 COBL( 1) = XOBL( 1) + 8.9D0*DT 00014800 COBL( 2) = XOBL( 2) + 0.5D0*DT 00014900 COBL( 9) = XOBL( 9) - 3.1D0*DT 00015000 COBL(10) = XOBL(10) - 0.1D0*DT 00015100 COBL(11) = XOBL(11) - 0.6D0*DT 00015200 COBL(12) = XOBL(12) + 0.3D0*DT 00015300 COBL(31) = XOBL(31) - 0.5D0*DT 00015400 COBL(34) = XOBL(34) - 0.1D0*DT 00015500 C 00015600 C 00015700 DO 20 I = 1,30 00015800 DPSIL = DPSIL + CLONG(I) * DSIN( XL(I)*L + XLS(I)*LS + XF(I)*F 00015900 1 + XD(I)*D + XOMEGA(I)*OMEGA ) 00016000 DEPSL = DEPSL + COBL(I) * DCOS( XL(I)*L + XLS(I)*LS + XF(I)*F 00016100 1 + XD(I)*D + XOMEGA(I)*OMEGA ) 00016200 20 CONTINUE 00016300 C 00016400 DO 40 I = 31,106 00016500 DPSIS = DPSIS + CLONG(I) * DSIN( XL(I)*L + XLS(I)*LS + XF(I)*F 00016600 1 + XD(I)*D + XOMEGA(I)*OMEGA ) 00016700 DEPSS = DEPSS + COBL(I) * DCOS( XL(I)*L + XLS(I)*LS + XF(I)*F 00016800 1 + XD(I)*D + XOMEGA(I)*OMEGA ) 00016900 40 CONTINUE 00017000 C 00017100 C 00017200 EPS = +0.001813D0*DT*DT*DT - 0.00059D0*DT*DT - 46.8150*DT + 00017300 1 84381.448D0 00017400 EPS = (EPS*PI2)/(1296.D+03) 00017500 DPSIL= (DPSIL*PI2)/1296.D+07 00017600 DPSIS= (DPSIS*PI2)/1296.D+07 00017700 DEPSL= (DEPSL*PI2)/1296.D+07 00017800 DEPSS= (DEPSS*PI2)/1296.D+07 00017900 RETURN 00018000 END 00018100 integer function irund(x) c c Real*8 - Zahl x auf Integer runden. c implicit real*8 (a-h,o-z) c if (x.ge.0.d0) irund = dint(x+0.5d0) if (x.lt.0.d0) irund = dint(x-0.5d0) c return end REAL*8 FUNCTION XRUND (R,N) C C RUNDEN DER DOPPELT GENAUEN REAL-ZAHL X AUF N DEZIMALEN C C REAL*8 R,X,Y,Z INTEGER I,N C C X = DABS(R) DO 10 I = 1,N 10 X = X*10.D0 I = X Y = X-I IF (Y.GE.0.5D0) I = I+1 X = I DO 20 I = 1,N 20 X = X/10.D0 IF (R.LT.0.D0) X = -X XRUND = X RETURN END SUBROUTINE DOPTRA(ALF0,STEP,BY,MONAT,TAG) 00074100 C 00074200 C BERECHNUNG DES DOPPELTRANSITS (OBERE UND UNTERE KULMINATION) 00074300 C FUER EINEN STERN MIT DER KONSTANTEN SCHEINBAREN REKTASZENSION 00074400 C POLSTERNE: STEP = 1 00074500 C 10-TAGE-STERNE: STEP = 10. 00074600 C STEP UNTERSCHEIDET POL- UND 10-TAGE-STERNE 00074700 C BEI POLSTERNEN WIRD SIDERISCHE ZEIT MIT KURZPERIODISCHEM 00074800 C EFFEKTEN GERECHNET, BEI 10-TAGE-STERNNEN NUR LANG- 00074900 C PERIODISCHER ANTEIL. 00075000 C 00075100 C 00075200 C ALF (IM BOGENMASS) FUER DAS KALENDERJAHR BY 00075300 C 00075400 C IN DIE ARRAYS MONAT, TAG WERDEN FOLGENDE DATEN GESPEICHERT: 00075500 C 1. MONAT (TAG) DER DOPPELTEN OBEREN KULMINATION 00075600 C 2. MONAT (TAG) DER DOPPELTEN UNTEREN KULMINATION 00075700 C 3. MONAT (TAG) DER ZWEITEN DOPPELTEN OBEREN KULMINATION 00075800 C 4. MONAT (TAG) DER ZWEITEN DOPPELTEN UNTEREN KULMINATION 00075900 C 00076000 C EINE ZWEIFACHE DOPPELTE KULMINATION TRITT IN DEN SCHALTJAHREN AUF 00076100 C FUER STERNE MIT ALPHA CA. 6 H. 40 M. 00076200 C 00076300 IMPLICIT REAL*8 (A-Z) 00076400 INTEGER I,KUL(2),ITIME(2),K,K1 00076500 LOGICAL SCHALT,SJ,ENDE 00076600 DIMENSION TSID(5,2),MONAT(4),TAG(4),TKUL(2),JDANF(2) 00076700 C 00076800 PI = 3.141592653589793D0 00076900 XTR = (180.D0/PI)*3600.D0 00077000 C = 12.D0/PI 00077100 DT = (3.D0+56.55536D0/60.D0)/60.D0 00077200 ALF = ALF0 00077300 C WRITE(6,1314) DT 00077400 SJ = .FALSE. 00077500 IF (SCHALT(BY)) SJ = .TRUE. 00077600 ENDE = .FALSE. 00077700 C 00077800 DO 10 I = 1,4 00077900 MONAT(I) = -10.D0 00078000 10 TAG(I) = -10.D0 00078100 C 00078200 C ALF IN STUNDEN UMRECHNEN 00078300 C 00078400 ALF = ALF*C 00078500 C WRITE(6,1314) ALF 00078600 C 00078700 5 CONTINUE 00078800 C 00078900 CALL KALJUL(BY,1.D0,1.D0,0.D0,0.D0,0.D0,JD1) 00079000 C WRITE(6,1314) BY,JD1 00079100 1314 FORMAT(1X,2(4D19.11,/)) 00079200 C 00079300 C 00079400 C UNGEFAEHRE DOPPELKULMINATION BERECHNEN. 00079500 C SIE LIEGT UM I TAGE (I WIRD NACHSTEHEND BERECHNET) NACH JD0 00079600 C 00079700 CALL UTST (JD1,0.D0,0.D0,0.D0,XH,XM,XS,GSD1) 00079800 C WRITE(6,1314) GSD1 00079900 C WRITE(6,1314) XH,XM,XS 00080000 XH = (XH+XM/60.D0+XS/3600.D0) 00080100 C WRITE(6,1314) XH 00080200 C 00080300 C 00080400 DO 20 K = 1,2 00080500 X = ALF - XH + 12.D0*(K-1) 00080600 IF (X.LT.0.D0) X = X + 24.D0 00080700 IF (X.GT.24.D0) X = X - 24.D0 00080800 C WRITE(6,1314) X 00080900 I = X/DT 00081000 C WRITE(6,1315) I 00081100 1315 FORMAT(1X,4I15) 00081200 IF ( (SJ) .AND. (ENDE) ) I = I + 365 00081300 KUL(K) = I 00081400 JDANF(K) = JD1 + I-2 00081500 C IF (JDANF(K).LT.JD1) JDANF(K) = JD1 00081600 C WRITE(6,1314) JDANF(K) 00081700 20 CONTINUE 00081800 C WRITE(6,1314) JDANF 00081900 C 00082000 C 00082100 C SCHEINBARE SIDERISCHE ZEIT FUER JEWEILS 0 UHR U.T. IN 00082200 C UMGEBUNG DER GENAEHERTEN KULMINATION RECHNEN UND SPEICHERN 00082300 C 00082400 DO 50 I = 1,5 00082500 DO 50 K = 1,2 00082600 JD = JDANF(K) + I -1 00082700 C WRITE(6,1314) JD 00082800 CALL UTST (JD,0.D0,0.D0,0.D0,XH,XM,XS,GSD) 00082900 C WRITE(6,1314) JD,GSD 00083000 C WRITE(6,1314) XH,XM,XS 00083100 C T = (JD-241 5020.D0)/36525.D0 00083200 C WRITE(6,1314) T 00083300 C CALL NUTAT(T,DPSIL,DPSIS,DEPSL,DEPSS) 00083400 CALL KSTNUT (JD,DPSIL,DPSIS,DEPSL,DEPSS,EPS) 00083500 DPSIL = DPSIL*XTR 00083600 DPSIS = DPSIS*XTR 00083700 DEPSL = DEPSL*XTR 00083800 DEPSS = DEPSS*XTR 00083900 C WRITE(6,1314) DPSIL,DPSIS,DEPSL,DEPSS 00084000 C DTTROP = (JD-241 5020.313D0)/36524.21988D0 00084100 C EPS = ((0.87751 276280826D-08*DTTROP - 0.28604 00718 54626 2D-7)* 00084200 C F DTTROP - 0.22711 09689 15762 1D-03)*DTTROP + 00084300 C F 0.40931 97552 027299D0 00084400 COSEPS = DCOS(EPS) 00084500 C WRITE(6,1314) COSEPS 00084600 EQEQ = DPSIL 00084700 c IF (STEP.LT.1.1D0) EQEQ = EQEQ + DPSIS 00084800 EQEQ = EQEQ + DPSIS 00084800 EQEQ = EQEQ*COSEPS/15.D0 00084900 C WRITE(6,1314) EQEQ 00085000 C 00085100 C 00085200 C SCHEINBARE SIDERISCHE ZEIT IN STUNDEN 00085300 C 00085400 XH = XH + XM/60.D0 + XS/3600.D0 + EQEQ/3600.D0 00085500 TSID(I,K) = XH 00085600 C WRITE(6,1314) TSID(I,K) 00085700 50 CONTINUE 00085800 1419 FORMAT(1X,/////,5(1X,2D25.11,/)) 00085900 C WRITE(6,1419) TSID 00086000 DO 60 K = 1,2 00086100 DO 60 I = 2,5 00086200 IF (TSID(I,K).LT.TSID(I-1,K)) TSID(I,K) = TSID(I,K) + 24.D0 00086300 60 CONTINUE 00086400 C WRITE(6,1419) TSID 00086500 C 00086600 C 00086700 C DOPPELKULMINATION TESTEN DURCH BESTIMMUNG DES SIDERISCHEN 00086800 C ZEITINTERVALLS, IN DEM ALF LIEGT 00086900 C 00087000 DO 100 K = 1,2 00087100 ITIME(K) = -100 00087200 X = ALF + (K-1)*12.D0 00087300 IF (X.GT.24.D0) X = X-24.D0 00087400 IF (X.LT.TSID(1,K)) X = X+24.D0 00087500 DO 100 I = 1,4 00087600 IF ( (TSID(I,K).LT.X) .AND. (X.LT.TSID(I+1,K)) ) ITIME(K) = I 00087700 TKUL(K) = JDANF(K) + ITIME(K) - 1 00087800 100 CONTINUE 00087900 C WRITE(6,1315) ITIME 00088000 C WRITE(6,1314) TKUL 00088100 C 00088200 C 00088300 C BERECHNUNG DES DOPPELTRANSITS IN BUERGERLICHER ZEIT 00088400 C 00088500 DO 150 K1 = 1,2 00088600 K = K1 00088700 IF (ENDE) K = 2 + K1 00088800 CALL JULKAL(TKUL(K1),XJ,MONAT(K),TAG(K),XH,XM,XS) 00088900 C WRITE(6,1314) TKUL(K1) 00089000 C WRITE(6,1314) XJ,MONAT(K),TAG(K) 00089100 C WRITE(6,1314) XH,XM,XS 00089200 IF (XJ.LT.BY) MONAT(K) = 1.D0 00089300 IF (XJ.LT.BY) TAG(K) = 0.D0 00089400 IF (XJ.GT.BY) MONAT(K) = 12.D0 00089500 IF (XJ.GT.BY) TAG(K) = 32.D0 00089600 IF ( (TAG(K).GT.1.5D0) .AND. ( (XJ.LT.BY) .OR. (XJ.GT.BY) ) ) 00089700 1 MONAT(K) = -10.D0 00089800 IF ( (TAG(K).GT.1.5D0) .AND. ( (XJ.LT.BY) .OR. (XJ.GT.BY) ) ) 00089900 1 TAG(K) = -10.D0 00090000 150 CONTINUE 00090100 C WRITE(6,1314) MONAT 00090200 C WRITE(6,1314) TAG 00090300 IF (.NOT.SJ) GO TO 500 00090400 write(30,'(''bin in doptra'')') IF (ENDE) GO TO 500 00090500 ENDE = .TRUE. 00090600 IF((DABS(ALF-6.7D0).LT.0.15D0).OR.(DABS(ALF-18.7D0).LT.0.15D0)) 00090700 1 GO TO 5 00090800 C GO TO 5 00090900 500 RETURN 00091000 END 00091100 SUBROUTINE GRGMS (GR,G,M,S) C C BERECHNUNG DER GRAD, MINUTEN UND SEKUNDEN (AUF 2 DEZIMALEN) C AUS DEN GEGEBENEN GRAD (MIT DEZIMALEN) C DAS VORZEICHEN WIRD UNTERDRUECKT UND MUSS IM HAUPTPROGRAMM C BERUECKSICHTIGT WERDEN. DAS IST NOTWENDIG, DA DIE MASCHINE C +0 UND -0 NICHT UNTERSCHEIDEN KANN, SO DASS MAN NICHT -0 GRAD C ( G = -0 ) AUSGEBEN KANN. C C ALLES DOPPELT GENAU C C IMPLICIT REAL*8 (A-Z) INTEGER I C C X = DABS(GR) C I = X G = I X = (X-G)*60.D0 I = X M = I S = (X-M)*60.D0 C C SEKUNDEN EVTL ZU DEN MINUTEN ADDIREN C S0 = 5999.5D0 IF (S*100D0-S0) 30,10,10 10 S = 0.D0 M = M + 1.D0 IF (M-59.D0) 30,20,20 20 M = 0.D0 G = G + 1.D0 30 CONTINUE RETURN END SUBROUTINE STHMS (X,H,M,S) C C BERECHNUNG DER STUNDEN, MINUTEN UND SEKUNDEN (AUF 3 DEZIMALEN) C AUS DEN GEGEBENEN STUNDEN (MIT DEZIMALEN) C C DIE SEKUNDEN WERDEN AUF 3 DEZIMALEN GERUNDET (S0=59999.5) UND C EVTL. ZU DEN MINUTEN ADDIERT C C C ALLES DOPPELT GENAU C C IMPLICIT REAL*8 (A-Z) INTEGER I C ST = X C C REDUKTION AUF DAS INTERVALL (0,24) C ST = DMOD(ST,24.D0) IF (ST.LT.0.D0) ST = ST + 24.D0 C C I = ST H = I ST = (ST-H)*60.D0 I = ST M = I S = (ST-M)*60.D0 C C SEKUNDEN EVTL. ZU DEN MINUTEN ADDIEREN C S0 = 59999.5D0 IF (S*1000.D0-S0) 30,10,10 10 S = 0.D0 M = M+1.D0 IF (M-59.5D0) 30,20,20 20 M = 0.D0 H = H + 1.D0 30 CONTINUE H = DMOD(H,24.D0) RETURN END SUBROUTINE JULKAL(JD,JAHR,MONAT,TAG,ST,MIN,SEC) 00000010 C 00000020 C COMM. ACM, VOL. 11, P. 657, (1968) 00000030 C ICH HABE DAS PROGRAMM ETWAS GEAENDERT UND ERWEITERT 00000040 C 00000050 C 00000060 C 00000070 IMPLICIT REAL*8 (A-Z) 00000080 INTEGER I,J,K,L,M,N 00000090 LOGICAL SCHALT 00000100 DIMENSION TAGPM(12) 00000110 C 00000120 DATA TAGPM /31.D0,28.D0,31.D0,30.D0,31.D0,30.D0,31.D0,31.D0, 00000130 F 30.D0,31.D0,30.D0,31.D0/ 00000140 C 00000150 C 00000160 L = JD + 68569 00000170 N = 4*L/146097 00000180 L = L - (146097*N+3)/4 00000190 I = 4000*(L+1)/1461001 00000200 L = L - 1461*I/4 + 31 00000210 J = 80*L/2447 00000220 K = L - 2447*J/80 00000230 L = J/11 00000240 J = J + 2 - 12*L 00000250 I = 100*(N-49) + I + L 00000260 JAHR = I 00000270 MONAT = J 00000280 TAG = K 00000290 L = JD 00000300 C 00000310 TAGPM(2) = 28.D0 00000320 IF (SCHALT(JAHR)) TAGPM(2) = 29.D0 00000330 C 00000340 C 00000350 C 00000360 C DER WERT 1.D-9 (ENTSPRECHEND 0.0000864 SEC) IST ZU ADDIEREN, 00000370 C DA BEI DER SUBTRAKTION JD-L NUR 9 KORREKTE STELLEN HINTER 00000380 C DEM KOMMA STEHEN, DA JD UND L 7-STELLIGE ZAHLEN SIND. DIE NACH- 00000390 C FOLGENDE ABFRAGE WUERDE OHNE DIESE ADDITION ALSO EVTL. SCHIEF 00000400 C GEHEN. 00000410 C 00000420 X = JD - L + 1.D-9 00000430 IF ( X.GE.0.5D0) TAG = TAG + 1.D0 00000440 C 00000450 IF (TAG.LE.TAGPM(J)) GO TO 100 00000460 TAG = 1.D0 00000470 MONAT = MONAT + 1.D0 00000480 IF (MONAT.LE.12.D0) GO TO 100 00000490 MONAT = 1.D0 00000500 JAHR = JAHR + 1.D0 00000510 100 CONTINUE 00000520 C 00000530 C 00000540 C 00000550 C 00000560 C STUNDEN, MINUTEN, SEKUNDEN BESTIMMEN 00000570 C 00000580 M = JD 00000590 X = M + 0.5D0 00000600 IF (X.GT.JD) X = X - 1.D0 00000610 X = (JD-X)*24.D0 00000620 CALL STHMS (X,ST,MIN,SEC) 00000630 RETURN 00000640 END 00000650 SUBROUTINE UTST (JD,HW,MW,SW,HS,MS,SS,GSD) 00000010 C 00000020 C GUELTIG AB 1984 00000030 C 00000040 C 00000050 C DIE KONSTANTEN BASIEREN AUF IAU - RESOLUTION 3 DER KOMMISION 4, 00000060 C DIE IN PATRAS 1984 ANGENAOMMEN WURDE. 00000070 C 00000080 C 00000090 C BERECHNUNG DER MITTLEREN SIDERISCHEN ZEIT IN STUNDEN, MINUTEN, 00000100 C SEKUNDEN SOWIE DER GREENWICH SIDERIAL DAY NUMBER FUER DAS 00000110 C JULIANISCHE DATUM JD, HW STUNDEN, MW SEKUNDEN, SW SEKUNDEN 00000120 C MITTLERER WELTZEIT. 00000130 C LITERATUR : EXPL. SUPPL. P. 73 FF 00000140 C 00000150 C JD IST FUER 0 UHR WELTZEIT ANZUGEBEN, MUSS ALSO EXAKT AU .5 ENDEN00000160 C 00000170 C ES WIRD DAS UNTERPROGRAMM STHMS BENOETIGT 00000180 C 00000190 C 00000200 IMPLICIT REAL*8 (A-Z) 00000210 INTEGER I 00000220 C 00000230 C 00000240 1000 FORMAT(1X,/////,' FALSCHE EINGABE DES JUL. DATUMS ',D25.16) 00000250 C 00000260 C 00000270 C TESTEN, OB DAS JUL. DATUM KORREKT EINGEGEBEN WURDE 00000280 C 00000290 JD1 = JD 00000300 I = JD1 00000310 IF (DABS(JD1-0.5D0-I).GT.1.D-14) WRITE(6,1000) JD1 00000320 C 00000330 C 00000340 C STUNDEN, MINUTEN, SEKUNDEN IN JULIANISCHES DATUM EINARBEITEN 00000350 C 00000360 JD1 = JD1 + HW/24.D0 + MW/1440.D0 + SW/86400.D0 00000370 C 00000380 C 00000390 C ZUNAECHST DAS SIDERISCHE DATUM GROB NACH EXPL. SUPPL. P. 489 00000400 C BERECHNEN. (ZUR GENAUIGKEIT VGL. MEINE AUFZEICHNUNGEN UEBER DIE 00000410 C BERECHNUNG DER WELTZEIT: UNTERPROGRAMM GSDUT) 00000420 C 00000430 C 00000440 GSD = 0.671D0 + 1.00273 7909351D0*JD1 00000450 C 00000460 C 00000470 TU = (JD1 - 2451545.D0)/36525.D0 00000480 C 00000490 C GREENWICH SIDERIAL DAY BERECHNEN, DER GERADE ANGEBROCHEN IST 00000500 C 00000510 I = GSD 00000520 GSD = I 00000530 C 00000540 C 00000550 C LETZTE FORMEL SEITE 74, EXPL. SUPPL. ANWENDEN 00000560 C 00000570 X = 24110.54841D0 + TU*(8640184.812866D0 + TU*(0.093104D0 00000580 1 - TU*6.2D-06)) 00000590 2 + HW*3600.D0 + MW*60.D0 + SW 00000600 C 00000610 C 00000620 C 00000630 C BERECHNUNG DER STUNDEN, MINUTEN UND SEKUNDEN 00000640 C 00000650 X = X/3600.D0 00000660 CALL STHMS (X,HS,MS,SS) 00000670 C 00000680 C NUN GREENWICH SIDERIAL DAY NUMBER BERECHNEN 00000690 C 00000700 X = HS + MS/60.D0 + SS/3600.D0 00000710 X = DMOD(X,24.D0) 00000720 X = X/24.D0 00000730 GSD = GSD + X 00000740 RETURN 00000750 END 00000760 C 00008570 SUBROUTINE SCLPRD (A,B,R,M) 00008580 C 00008590 C SKALRAPRODUKT R = A.B ZWEIER VEKTOREN 00008600 C 00008610 C A = NAME DES 1. EINGABEVEKTORS (M-MAL-1 MATRIX) 00008620 C B = NAME DES 2. EINGABEVEKTORS (M-MAL-1 MATRIX) 00008630 C R = SKALAR-PRODUKT 00008640 C M = ZAHL DER ZEILEN VON A = ZAHL DER ZEILEN VON B 00008650 C 00008660 C 00008670 IMPLICIT REAL*8 (A-H,O-Z) 00008680 DIMENSION A(M,1),B(M,1) 00008690 C 00008700 R = 0.D0 00008710 C 00008720 DO 10 I = 1,M 00008730 10 R = R + A(I,1)*B(I,1) 00008740 RETURN 00008750 END 00008760 C 00002640 SUBROUTINE DLDD (A,D,V) 00002650 C 00002660 C BERECHNUNG DES NACH DELTA ABGELEITETEN VEKTORS DER 00002670 C RICHTUNGSKOSINUSSE 00002680 C 00002690 C EINGABE: A, D = ALPHA,DELTA (IM BOGENMASS) 00002700 C AUSGABE: V = VEKTOR DER RICHTUNGSKOSINUSSE 00002710 C 00002720 IMPLICIT REAL*8 (A-H,O-Z) 00002730 REAL*8 V(3,1) 00002740 C 00002750 V(1,1) = -DSIN(D)*DCOS(A) 00002760 V(2,1) = -DSIN(D)*DSIN(A) 00002770 V(3,1) = +DCOS(D) 00002780 RETURN 00002790 END 00002800 C 00008130 SUBROUTINE GMADD (A,B,R,N,M) 00008140 C 00008150 C ADDITION ZWEIER MATRIZEN : R = A + B 00008160 C 00008170 C A = NAME DES 1. SUMMANDEN 00008180 C B = NAME DES 2. SUMMANDEN 00008190 C R = NAME DER SUMME: R = A + B 00008200 C N = ZAHL DER ZEILEN VON A, B, R 00008210 C M = ZAHL DER SPALTEN VON A, B, R 00008220 C 00008230 C 00008240 IMPLICIT REAL*8 (A-H,O-Z) 00008250 C 00008260 DIMENSION A(N,M),B(N,M),R(N,M) 00008270 C 00008280 C 00008290 DO 20 I = 1,N 00008300 DO 20 J = 1,M 00008310 20 R(I,J) = A(I,J) + B(I,J) 00008320 RETURN 00008330 END 00008340 C 00008350 SUBROUTINE SMPY (A,C,R,N,M) 00008360 C 00008370 C MULTIPLIKATION EINER MATRIX MIT EINEM SKALAR 00008380 C 00008390 C A = NAME DER EINGABEMATRIX 00008400 C C = SKALAR 00008410 C R = NAME DER AUSGABEMATRIX, R = C.A 00008420 C N = ZAHL DER ZEILEN VON A 00008430 C M = ZAHL DER SPALTEN VON A 00008440 C 00008450 C 00008460 IMPLICIT REAL*8 (A-H,O-Z) 00008470 C 00008480 DIMENSION A(N,M),R(N,M) 00008490 C 00008500 C 00008510 DO 10 I = 1,N 00008520 DO 10 J = 1,M 00008530 10 R(I,J) = C*A(I,J) 00008540 RETURN 00008550 END 00008560 C 00002470 SUBROUTINE DLDA (A,D,V) 00002480 C 00002490 C BERECHNUNG DES NACH ALPHA ABGELEITETEN VEKTORS DER RICHTUNGSKOS. 00002500 C 00002510 C EINGABE : A, D = ALPHA, DELTA (IM BOGENMASS) 00002520 C AUSGABE : V = VEKTOR DER ABGELETETEN RICHTUNGSKOSINUSSE 00002530 C 00002540 C 00002550 IMPLICIT REAL*8 (A-H,O-Z) 00002560 REAL*8 V(3,1) 00002570 C 00002580 V(1,1) = -DCOS(D)*DSIN(A) 00002590 V(2,1) = +DCOS(D)*DCOS(A) 00002600 V(3,1) = 0.D0 00002610 RETURN 00002620 END 00002630 C 00003470 SUBROUTINE PRCPOS (AOLD,DOLD,ANEW,DNEW,PX) 00003480 C 00003490 C PRAEZESSIONSUEBERTRAGUNG VON OERTERN 00003500 C 00003510 C EINGABE: AOLD = REKTASZENSION FUER AUSGANGSAEQUINOX 00003520 C DOLD = DEKLINATION FUER AUSGANGSAEQUINOX 00003530 C PX = PRAEZESSIONSMATRIX 00003540 C AUSGABE: ANEW = REKTASZENSION FUER ENDAEQUINOX 00003550 C DNEW = DEKLINATION FUER ENDAEQUINOX 00003560 C ALLE WINKEL IM BOGENMASS 00003570 C 00003580 C 00003590 IMPLICIT REAL*8 (A-H,O-Z) 00003600 REAL*8 PX(3,3),RCOLD(3,1),RCNEW(3,1) 00003610 C 00003620 C 00003630 C BERECHNUNG DER RICHTUNGSKOSINUSSE 00003640 C 00003650 CALL DIRCOS (AOLD,DOLD,RCOLD) 00003660 C 00003670 C PRAEZESSIONSUEBERTRAGUNG 00003680 C 00003690 C 00003740 CALL GMPRD (PX,RCOLD,RCNEW,3,3,1) 00003750 C 00003770 C BERECHNUNG VON ALPHA, DELTA AUS DEN RICHTUNGSKOSINUSSEN 00003780 C 00003790 CALL ANGLE (RCNEW,ANEW,DNEW) 00003800 C 00003810 RETURN 00003820 END 00003830 SUBROUTINE INPOL2 (FM1,F0,F1,F2,S,FS) 00000100 C 00000200 C QUADRATISCHE INTERPOLATION 00000300 C 00000320 C BENUTZUNG DER BESSELSCHEN INTERPOLATIONSFORMEL 00000340 C 00000360 C 00000380 C EINGABE: FUNKTIONSWERTE FM1 = F AN DER STELLE X-1 00000400 C F0 = F AN DER STELLE X 00000500 C F1 = F AN DER STELLE X+1 00000600 C F2 = F AN DER STELLE X+2 00000700 C INTERPOLATIONSSCHRITT S, (S = 0,......,1) 00000800 C AUSGABE: FS = F AN DER STELLE S. 00000900 C 00001000 C ALLE WERTE DOPPELT GENAU. 00001100 C 00001200 C 00001300 IMPLICIT REAL*8 (A-H,O-Z) 00001400 C 00001500 FS = 0.5D0*(F0+F1) + (S-0.5D0)*(F1-F0) 00001600 1 +0.25D0*(S-1.D0)*S*(FM1-F0-F1+F2) 00001700 RETURN 00001800 END 00001900 C 00000100 SUBROUTINE ANGLE(V,A,D) 00000200 C 00000300 C BERECHNUNG VON ALPHA, DELTA AUS DEM VEKTOR DER RICHTUNGSKOSIN. 00000400 C 00000500 C EINGABE : V = VEKTOR DER RICHTUNGSKOSINUSSE 00000600 C AUSGABE : A,D = ALPHA, DELTA IM BOGENMASS 00000700 C 00000800 C 00000900 IMPLICIT REAL*8 (A-H,O-Z) 00001000 REAL*8 V(3,1) 00001100 C 00001200 C 00001300 PI = 3.141592653589793D0 00001400 C 00001500 C 00001600 C UEBERGANG ZUM EINHEITSVEKTOR. 00001700 C DIES IST DANN NOTWENDIG, WENN VERSEHENTLICH NICHT DIE 00001800 C RICHTUNGSKOSINUSSE SELBST, SONDERN EIN VEKTOR, DER EIN 00001900 C VIELFACHES DAVON IST, EINGEGEBEN WURDE 00002000 C 00002100 CALL SCLPRD (V,V,X,3) 00002200 X = DSQRT(X) 00002300 DO 10 I = 1,3 00002400 10 V(I,1) = V(I,1)/X 00002500 C 00002600 D = DASIN(V(3,1)) 00002700 A = DATAN2(V(2,1),V(1,1)) 00002800 IF ( A.LT.0.D0 ) A = A + 2.D0*PI 00002900 RETURN 00003000 END 00003100 SUBROUTINE ETERM(ALF,DEL,C0,D0,EPS,C1,C2) C C BERECHNUNG DER KORREKTIONEN, DIE VON DER ELLIPTIZITAET C DER ERDBAHN HERRUEHREN (LINEARER TEIL) C C LITERATUR: WOOLARD & CLEMENCE, SPHER. ASTR., P. 114 C EXPL. SUPPL. P. 48,151 C EPS = SCHIEFE DER EKLIPTIK, WIRD IN GESONDERTEM U.P. BERECHNET C C0,D0 = "ELLIPTISCHER TEIL DER ABERRATION DAY NUMBERS", WERDEN C KSTETR BERECHNET C C,CS,D,DS = STAR NUMBERS C A,D = ORT IM BOGENMASS C C1,C2 = E-TERM DER ELLIPTISCHEN ABERRATION (LINEARER TEIL) C IMPLICIT REAL*8 (A-H,O-Z) REAL*8 ALF,DEL,C1,C2,C0,D0,C,CS,D,DS,EPS C = DCOS(ALF)/DCOS(DEL) D = DSIN(ALF)/DCOS(DEL) CS = DTAN(EPS)*DCOS(DEL) - DSIN(ALF)*DSIN(DEL) DS = DCOS(ALF)*DSIN(DEL) C1 = C*C0 + D*D0 C2 = CS*C0 + DS*D0 RETURN END SUBROUTINE KSTETR(BY,C0,D0,EPS) C BESTIMMUNG DES "ELLIPTISCHEN TEILS DER ABERRATION DAY NUMBERS" C EPS WIRD BEZOGEN AUF DAS MITTLERE AEQUNOX FUER BEGINN DES C BESSELSCHEN JAHRES DER EPOCHE TA. DIE ZEIT IST IN C EPHEMERIDENZEIT (JULIANISCH) ZU RECHNEN (EXPL. SUPPL. P.98, 489) C BY = BESSELSCHES JAHR UND TEILE DAVON, FUER DAS GERECHNET WIRD C DT = DIFFERENZ ZWISCHEN 1900.0 UND BY IN JULIANISCHEN JAHRHUNDERTEN C DTEPS = DIFFERENZ ZWISCHEN 1900.0 UND BY IN TROPISCHEN JAHRHUNDERTEN C KAPPA = ABERRATIONS-KONSTANTE = 20.496" (AB 1968) C C IMPLICIT REAL*8 (A-H,O-Z) REAL*8 T,BY,DT,DTEPS,PERL,EXC,EPS,C0,D0,KAPPA T = 3.1415926535897932D0/(180.D0*3600.D0) KAPPA = 20.496D0 DT = 365.2422D0*(BY-1900.D0)/36525.D0 DTEPS = (BY - 1900.D0)/100.D0 PERL = 281.22083 3D0 + 1.71917 5D0*DT + 0.00045 2778D0*DT*DT + 1 0.00000 33333D0*DT*DT*DT EXC = 0.01675 104D0 - 0.00004 180D0*DT - 0.00000 0126D0*DT*DT EPS = 23.45229 4D0 - 0.01301 25D0*DTEPS - 1 0.00000 164D0*DTEPS*DTEPS + 0.00000 0503D0*DTEPS*DTEPS*DTEPS PERL = PERL - 180.D0 PERL = PERL*3600.D0*T EPS = EPS*3600.D0*T KAPPA = KAPPA*T C0 = KAPPA*EXC*DCOS(PERL)*DCOS(EPS) D0 = KAPPA*EXC*DSIN(PERL) RETURN END LOGICAL FUNCTION SCHALT (JAHR) C C PRUEFEN, OB JAHR EIN SCHALTJAHR IST (ERGEBNIS .TRUE.) C DAS UNTERPROGRAMM DRTEIL WIRD BENOETIGT C C REAL*8 X,JAHR,eps INTEGER I LOGICAL L1,L2,L3,DRTEIL C SCHALT = .FALSE. EPS = 1.D-13 L1 = DRTEIL(JAHR,4.D0,EPS) L2 = DRTEIL(JAHR,100.D0,EPS) L3 = DRTEIL(JAHR,400.D0,EPS) IF (L1) SCHALT = .TRUE. IF (L2) SCHALT = .FALSE. IF (L3) SCHALT = .TRUE. RETURN END SUBROUTINE KALJUL (JAHR,MONAT,TAG,ST,MIN,SEC,JD) 00000010 C 00000020 C BERECHNUNG DES JULIANISCHEN DATUMS JD FUER DIE EPOCHE JAHR, 00000030 C MONAT, TAG ST, MIN SEC IN BUERGERLICHER ZEIT. 00000040 C 00000050 C 00000060 IMPLICIT REAL*8 (A-Z) 00000070 INTEGER I,J,K,L,M,N 00000080 C 00000090 C 00000100 I = JAHR 00000110 J = MONAT 00000120 K = TAG 00000130 JD = K - 32075 + 1461*(I+4800+(J-14)/12)/4 + 367*(J-2-(J-14)/12*1200000140 F )/12 - 3*((I+4900+(J-14)/12)/100)/4 + 00000150 F ST/24.D0 + MIN/1440.D0 + SEC/86400.D0 - 0.5D0 00000160 RETURN 00000170 END 00000180 subroutine stut(gsd,sth,stm,sts,uth,utm,uts,xjd) c c Version: 24. Novemer 2000, H. Schwan c c c Computation of Greenwich sidereal date: c c Input: c ====== c gsd: Grenwich sidereal day (no decimals !!) c sth: sidereal hours elapsed in the Greenwich sidereal day gsd c stm: sidereal minutes elapsed in the Greenwich sidereal day gsd c sts: sidereal seconds elapsed in the Greenwich sidereal day gsd c c c Output: c ======= c xjed: Julian Ephemeris date (with decimals !!) c uth: hours of universal time c utm: minutes of universal time c uts: seconds of universal time c c Es wird auch noch Jahr, Monat und Tag berechnet, c Diese werden aber nicht ausgegeben, da das bei der frueheren c Programmversion auch nicht der Fall war. c Das neue Programm soll aber voellig kompatibel mit dem alten sein!! c c implicit real*8 (a-h,o-z) c xn = 0.d0 fact = 0.997269566329084d0 c c c Computation of the sidereal date under consideration c (i.e. add the fraction of the day to the current sidereal day) c xgsd = gsd + sth/24.d0 + stm/(60.d0*24.d0) f + sts/(3600.d0*24.d0) c c Computation of GSD at J2000 = JD 2451545.d0 c call utst (2451544.5d0,xn,xn,xn,sth0,stm0,sts0,xgsd0) c c Computation of the sidereal time-inetrval between J2000 and c the date under consideration: c xdtst = xgsd - xgsd0 c c Transfirmation into an interval of universal time c xdtut = xdtst*fact c c add the universal time-interval to JD = 2451544.5 to obtain c the Julian date of the moment under consideration c xjd = 2451544.5d0 + xdtut c c Transformation of the Julian date into calendar date c call julkal(xjd,xj,xm,xt,uth,utm,uts) c return end SUBROUTINE JDJE(JD,JE) 00002100 C 00002200 C UMWANDLUNG DES JULIANISCHEN DATUMS IN JULIANISCHE EPOCHE 00002300 C 00002400 REAL*8 JE,JD 00002500 C 00002600 JE = 2000.d0 + (JD-2451545.d0)/365.25d0 00002800 C 00002800 RETURN 00002900 END 00003000 SUBROUTINE JUDATY (Y,TA,TE,TM) 00000100 C 00000200 C BESTIMMUNG DES JULIANISCHEN DATUMS FUER DEN JAHRESANFANG (TA), 00000300 C DAS JAHRESENDE (TE) UND DIE JAHRESMITTE (TM) FUER DAS JAHR Y 00000400 C ENTSPRECHEND DEN KONVENTIONEN DER I.A.U. AB 1984. 00000500 C 00000600 IMPLICIT REAL*8 (A-H,O-Z) 00000700 C 00000800 T2000 = 245 1545.D0 00000900 C 00001000 TA = T2000 + (Y-2000.D0)*365.25D0 00001100 TE = T2000 + (Y-1999.D0)*365.25D0 00001200 TM = (TA+TE)/2.D0 00001300 C 00001400 RETURN 00001500 END 00001600 LOGICAL FUNCTION DRTEIL (R1,R2,EPS) C C PRUEFEN, OB R1 DURCH R2 (ALLES DOPPELT GENAU) TEILBAR IST C D.H.: REST KLEINER ALS EPS C C REAL*8 R1,R2,EPS,X INTEGER I C R1 = DABS(R1) R2 = DABS(R2) DRTEIL = .FALSE. I = R1/R2 + 1.D-15 X = R1/R2 IF (DABS(X-I).LT.EPS) DRTEIL = .TRUE. RETURN END SUBROUTINE TPMSPC(T0,T1,A0,D0,XMY0,XMYS0,PAR0,VEL0, 00000010 1 A1,D1,XMY1,XMYS1,PAR1,VEL1,IER) 00000020 C 00000030 C 00000040 C EPOCHENUEBERTRAGUNG VON OERTERN UND EIGENBEWEGUNGEN UNTER DER 00000050 C ANNAHME KONSTANTER RAUMGESCHWINDIGKEIT. 00000060 C 00000070 C EINGABEDATEN: 00000080 C.................. 00000090 C T0, T1: ANFANGS-UND ENDEPOCHE IN JULIANISCHEM DATUM 00000100 C A0, D0: ORT ZUR ANFANGSEPOCHE, IM BOGENMASS 00000110 C XMY0,XMYS0: EIG.BEW.KOMP. IM BOGENMASS, PRO JUL. JAHRH. 00000120 C PAR: PARALLAXE IM BOGENMASS ZUR ANFANGS-EPOCHE 00000130 C VEL0: RADIALGSCHW. IN KM/SEC ZUR ANFANGSEPOCHE 00000140 C 00000150 C AUSGABEDATEN: 00000160 C.................. 00000170 C WIE EINGABEDATEN, MIT '1' STATT '0' 00000180 C RETURN-CODE IER: = 0: RAD.VEL. UND PAR. UNGLEICH 0 00000190 C..................... 00000200 C = 1: RAD.VEL. ODER PAR. GLEICH 0 00000210 C 00000220 C 00000230 IMPLICIT REAL*8 (A-H,O-Z) 00000240 C 00000250 DIMENSION R0(3),R0P(3),XA(3),XD(3),R(3) 00000260 C 00000270 PI = 3.141592653589793D0 00000280 TR = PI/180.D0 00000290 TR1 = 3600.D0/TR 00000300 TR2 = 1.D0/TR1 00000310 IER = 0 00000320 F1 = 21.094953D0 00000330 F2 = 4.8481368D-6 00000340 1700 FORMAT(/,1X,3D25.10) 00000350 C 00000360 C WRITE(6,1700) T0,T1 00000370 C WRITE(6,1700) A0,D0 00000380 C WRITE(6,1700) XMY0,XMYS0 00000390 X1 = DABS(PAR0) 00000400 X2 = DABS(VEL0) 00000410 IF ( ( X1 .LT.1.D-15) .OR. ( X2 .LT.1.D-15) ) IER = 1 00000420 C 00000430 C 00000440 C EIGENBEWEGUNGEN UND PARALLAXE IN BOGENSEKUNDEN UMRECHNEN. 00000450 C 00000460 AA = A0 00000470 DA = D0 00000480 XMYA = XMY0 00000490 XMYSA = XMYS0 00000500 PARA = PAR0 00000510 VELA = VEL0 00000520 XMYA = XMYA*TR1 00000530 XMYSA=XMYSA*TR1 00000540 PARA = PARA*TR1 00000550 C WRITE(6,1700) XMYA,XMYSA,PARA 00000560 C 00000570 C 00000580 C VEKTOR ZUM STERN UND GESCHWINDIGKEITSVEKTOR BERECHNEN, 00000590 C REDUZIERT AUF DIE EINHEITSSPHAERE. 00000600 C 00000610 CALL DIRCOS(AA,DA,R0) 00000620 C WRITE(6,1720) AA,DA 00000630 C WRITE(6,1720) R0 00000640 1720 FORMAT(/,1X,3D25.13) 00000650 CALL DLDA(AA,DA,XA) 00000660 CALL DLDD(AA,DA,XD) 00000670 C WRITE(6,1720) XA 00000680 C WRITE(6,1720) XD 00000690 DO 20 I = 1,3 00000700 20 R0P(I) = XMYA*XA(I)+XMYSA*XD(I) + F1*PARA*VELA*R0(I) 00000710 C WRITE(6,1720) R0P 00000720 C 00000730 C 00000740 C EPOCHENDIFFERENZ IN JULIANISCHEN JAHRHUNDERTEN: 00000750 C 00000760 DT = (T1-T0)/36525.D0 00000770 C WRITE(6,1720) DT 00000780 C 00000790 C 00000800 C VEKTOR ZUM STERN ZUR ENDEPOCHE 00000810 C 00000820 DO 80 I = 1,3 00000830 80 R(I) = R0(I) + R0P(I)*DT*F2 00000840 C WRITE(6,1720) R 00000850 C 00000860 C 00000870 C ENTFERNUNG DES STERNS IM BOGENMASS ZUR ENDEPOCHE: 00000880 C 00000890 CALL SCLPRD(R,R,E,3) 00000900 E = DSQRT(E) 00000910 C WRITE(6,1720) E 00000920 PAR1 = PARA/E 00000930 C WRITE(6,1720) PAR1 00000940 C 00000950 C 00000960 C UEBERGANG ZUM EINHEITSVEKTOR 00000970 C ALPHA , DELTA AUR ENDEPOCHE BERECHNEN. 00000980 C 00000990 DO 100 I = 1,3 00001000 100 R(I) = R(I)/E 00001010 C WRITE(6,1700) R 00001020 C 00001030 CALL ANGLE(R,A1,D1) 00001040 C WRITE(6,1700) A1,D1 00001050 C 00001060 C 00001070 C NEUE RADIALGESCHWINDIGKEIT ZUR ENDEPOCHE: 00001080 C 00001090 CALL SCLPRD(R0P,R,VEL1,3) 00001100 IF (IER.EQ.0) VEL1 = VEL1/(F1*PAR1) 00001110 IF (IER.EQ.1) VEL1 = VELA 00001120 C WRITE(6,1700) VEL1 00001130 C 00001140 C 00001150 C NEUE EIGENBEW.KOMP. ZUR ENDEPOCHE BERECHNEN: 00001160 C 00001170 CD = DCOS(D1) 00001180 CALL DLDA(A1,D1,XA) 00001190 CALL DLDD(A1,D1,XD) 00001200 CALL SCLPRD(R0P,XA,XMY1,3) 00001210 CALL SCLPRD(R0P,XD,XMYS1,3) 00001220 C WRITE(6,1700) XMY1,XMYS1 00001230 XMY1 = XMY1/(E*CD*CD) 00001240 XMYS1 = XMYS1/E 00001250 C WRITE(6,1700) XMY1,XMYS1 00001260 C 00001270 C EIGENBEW. UND PARALLAXE IN BOGENMASS UMWANDELN. 00001280 C 00001290 XMY1 = XMY1*TR2 00001300 XMYS1 = XMYS1*TR2 00001310 PAR1 = PAR1*TR2 00001320 C 00001330 RETURN 00001340 END 00001350 C****************************************** C SUBROUTINE EARTH (T,ER,EV,SR,IERR) C C****************************************** C C*ROL DER BARYZENTRISCHE ORTS- UND GESCHW.-VEKTOR DER ERDE C*ROL UND DER GEOZENTR. ORTSVEKTOR DER SONNE WERDEN IM C*ROL KOORD.-SYSTEM J2000 BESTIMMT. C C C EINGABE: T = JULIANISCHES DATUM C AUSGABE: ER = BARYZENTRISCHER ORTSVEKTOR DER ERDE C EV = BARYZENTRISCHER GESCHWIND.VEKTOR DER ERDE C SR = GEOZENTRISCHER ORTSVEKTOR DER SONNE C C C ****BENOETIGTE UNTERPROGRAMME**** C C PLEPH - PAKET VOM JPL (HIER ANGEFUEGT) C C STAND : 05/11/96 C (H.-H. BERNSTEIN) C ********************** C C implicit real*8 (a-h,o-z) c DIMENSION ER(3),EV(3),SR(3),HV(6),pvsun(3,2) C LOGICAL BSAVE,KM,BARY COMMON/STCOMX/KM,BARY,PVSUN C IERR=0 C KM=.FALSE. C C********************************************************************** C c write(*,'(//,''ich gehe nach pleph'',//)') CALL PLEPH (T,3,12,HV) C c write(*,'(//,''in earth ; T '',f20.6)') T ER(1)=HV(1) ER(2)=HV(2) ER(3)=HV(3) c write(*,'(//,''in earth ; ER '',3f20.6)') ER EV(1)=HV(4) EV(2)=HV(5) EV(3)=HV(6) c write(*,'(//,''in earth ; EV '',3f20.6)') EV C CALL PLEPH (T,11,3,HV) C SR(1)=HV(1) SR(2)=HV(2) SR(3)=HV(3) c write(*,'(//,''in earth ; SR '',3f20.6)') SR C C********************************************************************** C RETURN END C+++++++++++++++++++++++++++++++++ C C C ******************************************************************* C ***** * C ***** UNTERPROGRAMM CHARAD * C ***** * C ***** UMWANDLUNG EINES WINKELS, DER IN GRAD ODER STUNDEN ODER * C ***** MINUTEN (ZEIT ODER BOGEN-) ODER IN SEKUNDEN (ZEIT ODER * C ***** BOGEN-) ODER IN EINER SINNVOLLEN KOMBINATION DER GENANN- * C ***** TEN EINHEITEN ALS CHARCTERSTRING ANGEGEBEN IST, IN * C ***** BOGENMASS (DOPPELTGENAUE REALGROESSE). * C ***** * C ******************************************************************* C ***** * C ***** AUFGERUFEN WIRD DAS UNTERPROGRAM MIT * C ***** * C ***** CALL CHARAD (C1,C2,RDG,IER,LUNERR) * C ***** * C ***** WOBEI BEDEUTEN : * C ***** C1 = WINKEL IN D,H,M,S ETC C*(*) EINGABE * C ***** C2 = FORMAT VON C1 C*(*) EINGABE * C ***** RDG = WINKEL IM BOGENMASS R*8 AUSGABE * C ***** IER = FEHLERMELDUNG I3 AUSGABE * C ***** LUNERR = LOGICAL UNIT NUMBER FUER DIE AUSGABE EINER * C ***** FEHLERMELDUNG I2 EINGABE * C ***** * C ******************************************************************* SUBROUTINE CHARAD(CHA,FORMAT,RAD,IER,LUNERR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DATA FZ,SZ /15.D0,60.D0/ CHARACTER*1 CH(20),KCH(20) CHARACTER*(*) CHA,FORMAT,ierstr*3 CHARACTER*70 text0,text1,text2,text3,text4,text5,text6,text7 CHARACTER*70 text8 ILE1= LEN(CHA) ILE2= LEN(FORMAT) C text0 = 'von charad behoben, Fehlerangabe nur zur Information' text1 = 'XSTAR8(3 bzw 6) auf -9999.d0 KENNX8(3 bzw 6) auf 0 setz *en' text2 = 'korrigierter Wert ist in die Datei korrektur einzutragen' text3 = 'Koordinate fehlt' text4 = 'XSTAR8(3 bzw 6) auf -8888.d0 KENNX8(3 bzw 6) auf 0 setz *en' text5 = 'falls es zuviele sind charad ueberspringen' text6 = 'Fehler in der Formatangabe des Charad-Aufrufes' text7 = 'im Leseprogramm zu korrigieren' text8 = 'ergaenzte Koordinate ist in die Datei korrektur einzutrag *en' C Erstmal den Formatstring auf Grossbuchstaben bringen do i=1,ile2 call upcase(format(i:i)) end do IF(ILE1.NE.ILE2) THEN IER = 93 GOTO 900 END IF DO 99 I=ILE1,1,-1 IF (CHA(I:I).NE.' ') GOTO 9 99 CONTINUE IER = 99 GOTO 900 9 LCHA=I C ******************************************************************* C ***** * C ***** RA = 1 WENN DER WINKEL IN GRAD, BOGENMINUTEN ODER * C ***** -SEKUNDEN ANGEBEN IST * C ***** = 15 WENN DER WINKEL IN STUNDEN, ZEITMINUTEN * C ***** -SEKUNDEN ANGEBEN IST * C ***** = 0 WENN EIN FEHLER AUFGETRETEN IST, DER MIT * C ***** IER-MELDUNG ENDET * C ***** ZU BEGINN DES PROGRAMMS WIRD RA=1 GESETZT * C ***** * C ***** IER = 0 KEIN FEHLER BEI DER EINGABE * C ***** > 0 FEHLER BEI DER EINGABE * C ***** WENN MOD(10) = 0 FEHLER IN FORMATEINAGE (C2) * C ***** WENN MOD(10) > 0 FEHLER IN WERTEINGABE (C1) * C ***** ZU BEGINN DES PROGRAMMS WIRD IER=0 GESETZT * C ***** * C ***** IVA = 1 POSITIVES VORZEICHEN (' ' , + , & ) * C ***** = -1 NEGATIVES VORZEICHEN ( - ) * C ***** ZU BEGINN DES PROGRAMMS WIRD IVA=1 GESETZT * C ***** * C ***** IVK = 0 KEINE UEBERLOCHUNG DER LETZTEN STELLE IN C1 * C ***** = 1 UEBERLOCHUNG DER LETZTEN STELLE IN C1 * C ***** ZU BEGINN DES PROGRAMMS WIRD IVK=0 GESET C ***** * C ******************************************************************* RA=1.D0 PI = 3.1415926535897932D0 IER = 0 IVA=1 IVK=0 A=3600.D0 RADZ=0.D0 DO 10 I=1,LCHA CH(I)=CHA(I:I) KCH(I)=FORMAT(I:I) 10 CONTINUE C ******************************************************************* C ***** * C ***** ABFRAGE DES FORMATS, IN WELCHER EINHEIT C1 ANGEGEBEN IST * C ***** * C ***** H = STUNDEN (REKTASZENSION) * C ***** D = GRAD (DEKLINATION, GAL.BREITE ETC.) * C ***** L = LAENGE (GAL.LAENGE) * C ***** T = ZEIT- (-MINUTEN ODER -SEKUNDEN) * C ***** A = BOGEN (-MINUTEN ODER -SEKUNDEN) * C ***** V = VORZEICHEN (POS: ' ','+','&') * C ***** (NEG: '-') * C ***** X = UEBERLOCHUNG (DER 1. ODER LETZTEN STELLE) * C ***** M = MINUTEN (ZUSAMMEN MIT T ODER HH : ZEIT C ***** (MIT A, DD ODER ' ' : BOGENMINUTEN) * C ***** S = SEKUNDEN (ZUSAMMEN MIT T ODER HH : ZEITSEKUNDEN) * C ***** (MIT A, DD ODER ' ' : BOGENSEKUNDEN) * C ***** * C ******************************************************************* IF (KCH(2).EQ.'H') GOTO 100 IF (KCH(2).EQ.'D') GOTO 200 IF (KCH(2).EQ.'L') GOTO 300 J=1 IF (KCH(1).NE.'T') GOTO 20 RA=FZ GOTO 50 20 IF (KCH(1).EQ.'A') GOTO 50 IF (KCH(1).EQ.'V') GOTO 30 IF (KCH(1).EQ.'X') GOTO 50 IF (KCH(LCHA).EQ.'X') GOTO 40 IF (KCH(1).EQ.'Y') GOTO 61 IF (KCH(LCHA).EQ.'Y') GOTO 60 GOTO 50 61 RA=FZ GOTO 50 60 RA=FZ GOTO 40 29 IF (KCH(1).EQ.'D') GOTO 401 IF (KCH(1).EQ.'M') GOTO 411 IF (KCH(1).EQ.'S') GOTO 421 GOTO 90 50 IF (KCH(2).EQ.'M') GOTO 210 A=SZ IF (KCH(2).EQ.'S') GOTO 220 90 IER = 90 GOTO 900 30 IVA=1 IF (CH(1).EQ.'-') IVA=-1 J=J+1 IF (KCH(2).EQ.'T') RA=FZ IF (KCH(3).EQ.'M') GOTO 210 IF (KCH(3).EQ.'S') GOTO 220 GOTO 90 40 IVK=1 CALL INPUT(CH(LCHA),Z,IV,IE) IF (IE.EQ.0) GOTO 41 IF (IE.GT.0) IER = 91 IF (IE.LT.0) IER = 92 GOTO 900 41 B=Z IVA=IV IF (LCHA.EQ.2) GOTO 29 GOTO 50 C ******************************************************************* C ***** * C ***** UMRECHNUNG VON STUNDENWINKELN * C ***** * C ******************************************************************* 100 RA=FZ J=0 ZW=0.D0 DO 102 K=10,1,-9 J=J+1 CALL INPUT (CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 1010 IF (IE.GT.0) IER = 151 IF (IE.LT.0) IER = 152 GOTO 900 1010 ZZ = Z * DBLE(K) ZW = ZW + ZZ IF (ZW.LE.24.) GOTO 101 IER = 111 GOTO 900 101 RADZ=RADZ + ZZ * 3600.D0 IF (J.GE.LCHA) GOTO 900 102 CONTINUE 103 J=J+1 IF (KCH(J).EQ.' ') GOTO 103 IF (KCH(J).EQ.'M') GOTO 110 IF (KCH(J).EQ.'.') GOTO 150 IF (KCH(J).EQ.'H') GOTO 151 IER = 110 GOTO 900 110 J=J-1 ZW = 0.D0 DO 112 K=10,1,-9 J=J+1 CALL INPUT (CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 1100 IF (IE.GT.0) IER = 151 IF (IE.LT.0) IER = 152 GOTO 900 1100 ZZ = Z * DBLE(K) ZW = ZW + ZZ IF (ZW.LE.SZ) GOTO 111 IER = 121 WRITE (LUNERR,1111) CHA,IER,FORMAT C print *, text0 C C GOTO 900 111 RADZ = RADZ + ZZ * SZ IF (J.GE.LCHA) GOTO 900 112 CONTINUE A=A/SZ 115 J=J+1 IF (KCH(J).EQ.' ') GOTO 115 IF (KCH(J).EQ.'S') GOTO 120 IF (KCH(J).EQ.'.') GOTO 150 IF (KCH(J).EQ.'M') GOTO 151 IER = 120 GOTO 900 120 J=J-1 ZW = 0.D0 DO 122 K=10,1,-9 J=J+1 CALL INPUT (CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 1200 IF (IE.GT.0) IER = 151 IF (IE.LT.0) IER = 152 GOTO 900 1200 ZZ = Z * DBLE (K) ZW = ZW + ZZ IF (ZW.LE.SZ) GOTO 121 IER = 131 WRITE (LUNERR,1111) CHA,IER,FORMAT C print *, text0 C C GOTO 900 121 RADZ = RADZ + Z * DBLE(K) IF (J.GE.LCHA) GOTO 900 122 CONTINUE A=A/SZ 123 J=J+1 IF (KCH(J).EQ.'.') GOTO 150 IF (KCH(J).EQ.'S') GOTO 151 IF (KCH(J).EQ.' ') GOTO 123 IER = 130 GOTO 900 150 J=J+1 151 CONTINUE DO 152 K=J,LCHA CALL INPUT (CH(K),Z,IV,IE) IF (IE.EQ.0) GOTO 1520 IF (IE.GT.0) IER = 91 IF (IE.LT.0) IER = 92 GOTO 900 1520 RADZ = RADZ +A * Z/(10.D0**DBLE(K-J+1)) 152 CONTINUE GOTO 900 C ******************************************************************* C ***** * C ***** UMRECHNUNG VON GRAD * C ***** * C ******************************************************************* 200 IVK=0 IV =0 J=0 IVA=1 N=0 IF (KCH(LCHA).EQ.'X') GOTO 270 IF (KCH(1).EQ.'X') GOTO 203 IF (KCH(1).EQ.'D') GOTO 203 IF (CH(1).EQ.'-') GOTO 201 IF (CH(1).EQ.'&') GOTO 202 IF (CH(1).EQ.'+') GOTO 202 IF (CH(1).EQ.' ') GOTO 202 IER = 200 GOTO 900 201 IVA=-1 202 J=J+1 203 IF (KCH(2).EQ.'X') GOTO 401 ZW = 0.D0 DO 204 K=10,1,-9 J=J+1 N=N+1 CALL INPUT (CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 2203 IF (IE.GT.0) IER = 251 IF (IE.LT.0) IER = 252 GOTO 900 2203 IF(IVA.LT.0) GOTO 2204 IF(K.EQ.10) IVA=IV 2204 ZZ = Z * DBLE(K) ZW = ZW + ZZ IF (ZW.LE.90.D0) GOTO 204 IER = 211 GOTO 900 204 RADZ = (RADZ + ZZ * 3600.D0) IF (J.GE.LCHA) GOTO 900 205 CONTINUE 206 J=J+1 IF (KCH(J).EQ.' ') GOTO 206 IF (KCH(J).EQ.'M') GOTO 210 IF (KCH(J).EQ.'.') GOTO 250 IF (KCH(J).EQ.'D') GOTO 251 IF (KCH(J).EQ.'X') GOTO 251 IER = 210 GOTO 900 210 IF (KCH(J+1).EQ.'X') GOTO 411 J=J-1 ZW = 0.D0 DO 212 K=10,1,-9 J=J+1 CALL INPUT (CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 2110 IF (IE.GT.0) IER = 251 IF (IE.LT.0) IER = 252 GOTO 900 2110 ZZ = Z * DBLE(K) ZW = ZW + ZZ IF (ZW.LE.SZ) GOTO 211 IER = 221 WRITE (LUNERR,1111) CHA,IER,FORMAT C print *, text0 C C GOTO 900 211 RADZ = RADZ + Z * DBLE(K) * SZ IF (J.GE.LCHA) GOTO 900 212 CONTINUE A=A/SZ 215 J=J+1 IF (KCH(J).EQ.' ') GOTO 215 IF (KCH(J).EQ.'S') GOTO 220 IF (KCH(J).EQ.'.') GOTO 250 IF (KCH(J).EQ.'M') GOTO 251 IF (KCH(J).EQ.'X') GOTO 251 IER = 220 GOTO 900 220 IF (KCH(J+1).EQ.'X') GOTO 421 J=J-1 ZW = 0.D0 DO 222 K=10,1,-9 J=J+1 CALL INPUT (CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 2200 IF (IE.GT.0) IER = 251 IF (IE.LT.0) IER = 252 GOTO 900 2200 ZZ = Z * DBLE(K) ZW = ZW + ZZ IF (ZW.LE.SZ) GOTO 221 IER = 231 WRITE (LUNERR,1111) CHA,IER,FORMAT C print *, text0 C C GOTO 900 221 RADZ = RADZ + Z * DBLE(K) IF (J.GE.LCHA) GOTO 900 222 CONTINUE A=A/SZ 223 J=J+1 IF(KCH(J).EQ.'.') GOTO 250 IF(KCH(J).EQ.'S') GOTO 251 IF(KCH(J).EQ.' ') GOTO 223 IF(KCH(J).EQ.'X') GOTO 251 IER = 230 GOTO 900 250 J=J+1 251 J1 = LCHA IF (IVK.NE.1) GOTO 252 J1 = J1-1 RADZ = RADZ + A * B/(10.D0**DBLE(LCHA-J+1)) 252 IF (J.GT.J1) GOTO 900 DO 253 K=J,J1 CALL INPUT (CH(K),Z,IV,IE) IF (IE.EQ.0) GOTO 2520 IF (IE.GT.0) IER = 251 IF (IE.LT.0) IER = 252 GOTO 900 2520 RADZ = RADZ + A * Z/(10.D0** DBLE(K-J+1)) 253 CONTINUE GOTO 900 270 IVK=1 CALL INPUT (CH(LCHA),Z,IV,IE) IF (IE.EQ.0) GOTO 2700 IF (IE.GT.0) IER = 251 IF (IE.LT.0) IER = 252 GOTO 900 2700 B=Z IVA=IV GOTO 203 401 CALL INPUT(CH(1),Z,IV,IE) IF (IE.EQ.0) GOTO 4010 IF (IE.GT.0) IER = 251 IF (IE.LT.0) IER = 252 GOTO 900 4010 ZW=10.D0*Z IF (ZW.LE.90.D0) GOTO 402 IER = 211 GOTO 900 402 RADZ = RADZ + Z * 36000.D0 + B * 3600.D0 GOTO 900 411 CALL INPUT(CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 4110 IF (IE.GT.0) IER = 251 IF (IE.LT.0) IER = 252 GOTO 900 4110 ZW=10.D0*Z IF (ZW.LE.SZ) GOTO 412 IER = 221 WRITE (LUNERR,1111) CHA,IER,FORMAT C print *, text0 C C GOTO 900 412 RADZ = RADZ + Z * 600.D0 + B * SZ GOTO 900 421 CALL INPUT(CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 4210 IF (IE.GT.0) IER = 251 IF (IE.LT.0) IER = 252 GOTO 900 4210 ZW=10.D0*Z IF (ZW.LE.SZ) GOTO 422 IER = 231 WRITE (LUNERR,1111) CHA,IER,FORMAT C print *, text0 C C go to 900 422 RADZ = RADZ + Z * 10.D0 + B GOTO 900 C ******************************************************************* C ***** * C ***** UMRECHNUNG VON GAL.LAENGE * C ***** * C ******************************************************************* 300 J=1 IVA=1 IF(CH(1).EQ.'-') IVA=-1 ZW=0.D0 DO 302 K=2,0,-1 J=J+1 CALL INPUT(CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 3000 IF (IE.GT.0) IER = 351 IF (IE.LT.0) IER = 352 GOTO 900 3000 ZZ=Z*10.D0**DBLE(K) ZW=ZW+ZZ IF (ZZ.LE.360.D0) GOTO 301 IER = 311 GOTO 900 301 RADZ=RADZ+ZZ*3600.D0 IF (J.GE.LCHA) GOTO 900 302 CONTINUE 303 J=J+1 IF (KCH(J).EQ.' ') GOTO 303 IF (KCH(J).EQ.'M') GOTO 310 IF (KCH(J).EQ.'.') GOTO 350 IF (KCH(J).EQ.'L') GOTO 351 IER = 310 GOTO 900 310 J=J-1 ZW = 0.D0 DO 312 K=10,1,-9 J=J+1 CALL INPUT (CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 3100 IF (IE.GT.0) IER = 351 IF (IE.LT.0) IER = 352 GOTO 900 3100 ZZ = Z * DBLE(K) ZW = ZW + ZZ IF (ZW.LE.SZ) GOTO 311 IER = 321 WRITE (LUNERR,1111) CHA,IER,FORMAT C print *, text0 C C GOTO 900 311 RADZ = RADZ + ZZ * SZ IF (J.GE.LCHA) GOTO 900 312 CONTINUE A=A/SZ 315 J=J+1 IF (KCH(J).EQ.' ') GOTO 315 IF (KCH(J).EQ.'S') GOTO 320 IF (KCH(J).EQ.'.') GOTO 350 IF (KCH(J).EQ.'M') GOTO 351 IER = 320 GOTO 900 320 J=J-1 ZW = 0.D0 DO 322 K=10,1,-9 J=J+1 CALL INPUT (CH(J),Z,IV,IE) IF (IE.EQ.0) GOTO 3200 IF (IE.GT.0) IER = 351 IF (IE.LT.0) IER = 352 GOTO 900 3200 ZZ = Z * DBLE (K) ZW = ZW + ZZ IF (ZW.LE.SZ) GOTO 321 IER = 331 WRITE (LUNERR,1111) CHA,IER,FORMAT C print *, text0 C C GOTO 900 321 RADZ = RADZ + Z * DBLE(K) IF (J.GE.LCHA) GOTO 900 322 CONTINUE A=A/SZ 323 J=J+1 IF (KCH(J).EQ.'.') GOTO 350 IF (KCH(J).EQ.'S') GOTO 351 IF (KCH(J).EQ.' ') GOTO 323 IER = 330 GOTO 900 350 J=J+1 351 CONTINUE DO 352 K=J,LCHA CALL INPUT (CH(K),Z,IV,IE) IF (IE.EQ.0) GOTO 3510 IF (IE.GT.0) IER = 351 IF (IE.LT.0) IER = 352 GOTO 900 3510 RADZ = RADZ +A * Z/(10.D0**DBLE(K-J+1)) 352 CONTINUE GOTO 900 900 CONTINUE IF (IER.EQ.0) GOTO 910 IF (IER.EQ.121) GOTO 910 IF (IER.EQ.131) GOTO 910 IF (IER.EQ.221) GOTO 910 IF (IER.EQ.231) GOTO 910 WRITE (LUNERR,1111) CHA,IER,FORMAT 1111 FORMAT (//, 'FEHLER AUFGETRETEN BEI UMRECHNUNG VON'/ *1X,A,' IN RAD. FEHLERMELDUNG = ',I3/1X,A) C write(ierstr,'(i3)')ier C if(ier.eq.99)then print *, text3 print *, text4 print *, text8 print *, text5 end if C if(ierstr(3:3).eq.'0')then print *, text6 print *, text7 else if(ier.gt.100)then print *, text1 print *, text2 end if end if C RAD = 0.D0 GOTO 920 910 RAD = ( RADZ / 3600.D0 ) * RA * ( PI / 180.D0) IF (IVA.EQ.-1) RAD=-RAD 920 CONTINUE RETURN END C ******************************************************************* C ***** * C ***** UNTERPROGRAMM : INPUT * C ***** * C ***** UMWANDLUNG EINER CHARCTERGROESSE IN EINE REALGROESSE * C ***** * C ******************************************************************* C ***** * C ***** AUFGERUFEN WIRD DAS UNTERPROGRAMM MIT * C ***** * C ***** CALL INPUT(C,R,IV,IE) * C ***** * C ***** WOBEI BEDEUTEN * C ***** C = CHARACTERGROESSE A*1 EINGABE * C ***** R = REALGROESSE (DOPPELTGENAU) R*8 AUSGABE * C ***** IV = VORZEICHEN A*1 AUSGABE * C ***** WIRD DURCH INPUT NUR GEAENDERT, WENN EINE * C ***** ENTSPRECHENDE UEBERLOCHUNG VORLIEGT * C ***** IE = FEHLERMELDUNG I1 AUSGABE * C ***** = 1 WENN C NICHT MIT DEM VORGEGEBENEN * C ***** ZEICHENSATZ UEBEREINSTIMMT * C ***** BEWIRKT, DASS IER = 301 * C ***** = -1 WENN C = '.' (PUNKT) * C ***** BEWIRKT, DASS IER = 311 * C ***** * C ******************************************************************* SUBROUTINE INPUT(C,Z,IV,IE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER*1 C,IZI(10),IBUP(10),IBUN(10) DATA IZI/'0','1','2','3','4','5','6','7','8','9'/ DATA IBUN/ '}','J','K','L','M','N','O','P','Q','R'/ DATA IBUP/ '{','A','B','C','D','E','F','G','H','I'/ IV =1 IE = 0 IF (C.NE.' ') GOTO 9 I=1 GOTO 21 9 CONTINUE DO 10 I=1,10 IF (C.EQ.IZI(I)) GOTO 21 IF (C.EQ.IBUP(I)) GOTO 21 IF (C.EQ.IBUN(I)) GOTO 20 10 CONTINUE IE = 1 IF (C.EQ.'.') IE=-1 Z = 0.D0 GOTO 22 20 IV=-1 21 Z = DBLE(I-1) 22 CONTINUE RETURN END C******************************************************************** SUBROUTINE RADCHA(RADX,C2,CWERT,IER,LUNERR) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER*(*) C2,CWERT CHARACTER*10 CBT CHARACTER*1 CHR(20),CZ(4) CHARACTER*2 CH,CM,CS,CD,CV DATA CZ/' ','1','2','3'/ ILE1= LEN(C2) ILE2= LEN(CWERT) C Erstmal den Formatstring auf Grossbuchstaben bringen do i=1,ile1 call upcase(c2(i:i)) end do RAD=RADX IE1=0 INULF=0 DO 99 I=ILE1,1,-1 IF (C2(I:I).NE.' ') GOTO 98 99 CONTINUE IER=90 GOTO 900 98 LAE=I IF (C2(I:I).NE.'F') GOTO 97 LAE=I-1 INULF=1 97 CONTINUE IF (C2(ILE1:ILE1).EQ.'F') ILE1 = ILE1 - 1 IF(ILE1.NE.ILE2) THEN IER = 93 GOTO 900 END IF DO 96 I=1,ILE2 CWERT(I:I)=' ' CHR(I)=' ' 96 CONTINUE DO 95 I=1,LAE CHR(I)=C2(I:I) 95 CONTINUE RA=1. PI = 3.1415926535897932D0 IER=0 IVA=1 IH=0 IRUND=0 K1=0 IF (RAD.LT.0.D0) IVA=-1 RAD = RAD * IVA IF (CHR(2).EQ.'H') IH=1 IF (CHR(1).EQ.'T') IH=1 IF (CHR(2).EQ.'T') IH=1 IF (IH.EQ.1) GOTO 50 C******************************************************************** C C C C******************************************************************** R1=RAD*180.D0/PI RD=DINT(R1) RDB=R1-RD R2=RDB*60.D0 RM=DINT(R2) RMB=R2-RM R3=RMB*60.D0 RS=DINT(R3) RSB=R3-RS IF (RS.LT.60.D0) GOTO 41 RS=RS-60.D0 RM=RM+1.D0 41 IF (RM.LT.60.D0) GOTO 42 RM=RM-60.D0 RD=RD+1.D0 42 IF (CHR(2).EQ.'M') GOTO 60 IF (CHR(2).EQ.'A') GOTO 60 IF (CHR(2).EQ.'L' .AND. RD.LT.360.D0) GOTO 60 IF (CHR(2).EQ.'D' .AND. RD.LT.90.D0) GOTO 60 IF (CHR(2).EQ.'L') RD=RD-360.D0 IF (CHR(2).EQ.'D') RD=RD-90.D0 GOTO 42 C******************************************************************** C C C C******************************************************************** 50 R1=RAD*180.D0/(PI*15.D0) RH=DINT(R1) RHB=R1-RH R2=RHB*60.D0 RM=DINT(R2) RMB=R2-RM R3=RMB*60.D0 RS=DINT(R3) RSB=R3-RS IF (RS.LT.60.D0) GOTO 51 RS=RS-60.D0 RM=RM+1.D0 51 IF (RM.LT.60.D0) GOTO 52 RM=RM-60.D0 RH=RH+1.D0 52 IF (RH.LT.24.D0) GOTO 60 RH=RH-24.D0 GOTO 52 C******************************************************************** C C C C******************************************************************** 60 IF (CHR(1).EQ.'H') GOTO 100 IF (CHR(2).EQ.'D') GOTO 200 IF (CHR(2).EQ.'L') GOTO 500 IF (CHR(2).EQ.'T') GOTO 600 IF (CHR(2).EQ.'A') GOTO 700 IF (CHR(2).EQ.'M') GOTO 700 C******************************************************************** C C C C******************************************************************** 100 IE1=0 IF (INULF.EQ.1) GOTO 180 CALL INPUT1(RH,CH,IE) IE1=IE1+IE CALL INPUT1(RM,CM,IE) IE1=IE1+IE CALL INPUT1(RS,CS,IE) IE1=IE1+IE IF (IE1.EQ.0) GOTO 190 IER=101 GOTO 900 180 CALL INPUT2(RH,CH,IE) IE1=IE1+IE CALL INPUT2(RM,CM,IE) IE1=IE1+IE CALL INPUT2(RS,CS,IE) IE1=IE1+IE IF (IE1.EQ.0) GOTO 190 IER=102 GOTO 900 190 CWERT(1:2)=CH J=2 101 J=J+1 IF (J.GT.LAE) GOTO 401 IF (CHR(J).NE.' ') GOTO 102 CWERT(J:J)=' ' GOTO 101 102 IF (CHR(J).NE.'M') GOTO 110 C CWERT=CWERT//CM J1=J J2=J+1 CWERT(J1:J2)=CM J=J+1 103 J=J+1 IF (J.GT.LAE) GOTO 402 IF (CHR(J).NE.' ') GOTO 104 CWERT(J:J)=' ' GOTO 103 104 IF (CHR(J).NE.'S') GOTO 120 J1=J J2=J+1 CWERT(J1:J2)=CS J=J+1 C J=J+2 IF (J.GT.LAE) GOTO 403 105 J=J+1 IF (J.GT.LAE) GOTO 403 IF (CHR(J).NE.' ') GOTO 130 CWERT(J:J)=' ' GOTO 105 110 IF (CHR(J).NE.'.') GOTO 112 CWERT(J:J)='.' 111 J=J+1 IF (J.GT.LAE) GOTO 401 IF (CHR(J).NE.' ') GOTO 112 CWERT(J:J)=' ' GOTO 111 112 IF (CHR(J).NE.'H') GOTO 113 BT=RHB K1=1 GOTO 350 113 IF (CHR(J).NE.' ') GOTO 114 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 401 GOTO 112 114 IER=111 GOTO 900 120 IF (CHR(J).NE.'.') GOTO 122 CWERT(J:J)='.' 121 J=J+1 IF (J.GT.LAE) GOTO 402 IF (CHR(J).NE.' ') GOTO 122 CWERT(J:J)=' ' GOTO 121 122 IF (CHR(J).NE.'M') GOTO 123 BT=RMB K1=2 GOTO 350 123 IF (CHR(J).NE.' ') GOTO 124 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 402 GOTO 122 124 IER=121 GOTO 900 130 IF (CHR(J).NE.'.') GOTO 132 CWERT(J:J)='.' 131 J=J+1 IF (J.GT.LAE) GOTO 403 IF (CHR(J).NE.' ') GOTO 132 CWERT(J:J)=' ' GOTO 131 132 IF (CHR(J).NE.'S') GOTO 133 BT=RSB K1=3 GOTO 350 133 IF (CHR(J).NE.' ') GOTO 134 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 403 GOTO 132 134 IER=131 GOTO 900 C******************************************************************** C C C C******************************************************************** 200 IE1=0 IF (INULF.EQ.1) GOTO 280 CALL INPUT1(RD,CD,IE) IE1=IE1+IE CALL INPUT1(RM,CM,IE) IE1=IE1+IE CALL INPUT1(RS,CS,IE) IE1=IE1+IE IF (IE1.EQ.0) GOTO 290 IER=201 GOTO 900 280 CALL INPUT2(RD,CD,IE) IE1=IE1+IE CALL INPUT2(RM,CM,IE) IE1=IE1+IE CALL INPUT2(RS,CS,IE) IE1=IE1+IE IF (IE1.EQ.0) GOTO 290 IER=202 GOTO 900 290 CWERT(2:3)=CD J=3 201 J=J+1 IF (J.GT.LAE) GOTO 411 IF (CHR(J).NE.' ') GOTO 202 CWERT(J:J)=' ' GOTO 201 202 IF (CHR(J).NE.'M') GOTO 210 J1=J J2=J+1 CWERT(J1:J2)=CM J=J+1 203 J=J+1 IF (J.GT.LAE) GOTO 412 IF (CHR(J).NE.' ') GOTO 204 CWERT(J:J)=' ' GOTO 203 204 IF (CHR(J).NE.'S') GOTO 220 J1=J J2=J+1 CWERT(J1:J2)=CS J=J+1 IF (J.GT.LAE) GOTO 413 205 J=J+1 IF (J.GT.LAE) GOTO 413 IF (CHR(J).NE.' ') GOTO 230 CWERT(J:J)=' ' GOTO 205 210 IF (CHR(J).NE.'.') GOTO 212 CWERT(J:J)='.' 211 J=J+1 IF (J.GT.LAE) GOTO 411 IF (CHR(J).NE.' ') GOTO 212 CWERT(J:J)=' ' GOTO 211 212 IF (CHR(J).NE.'D') GOTO 213 BT=RDB K1=4 GOTO 350 213 IF (CHR(J).NE.' ') GOTO 214 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 411 GOTO 212 214 IER=211 GOTO 900 220 IF (CHR(J).NE.'.') GOTO 222 CWERT(J:J)='.' 221 J=J+1 IF (J.GT.LAE) GOTO 412 IF (CHR(J).NE.' ') GOTO 222 CWERT(J:J)=' ' GOTO 221 222 IF (CHR(J).NE.'M') GOTO 223 BT=RMB K1=5 GOTO 350 223 IF (CHR(J).NE.' ') GOTO 224 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 412 GOTO 222 224 IER=221 GOTO 900 230 IF (CHR(J).NE.'.') GOTO 232 CWERT(J:J)='.' 231 J=J+1 IF (J.GT.LAE) GOTO 413 IF (CHR(J).NE.' ') GOTO 232 CWERT(J:J)=' ' GOTO 231 232 IF (CHR(J).NE.'S') GOTO 233 BT=RSB K1=6 GOTO 350 233 IF (CHR(J).NE.' ') GOTO 234 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 413 GOTO 232 234 IER=231 GOTO 900 C******************************************************************** C C C C******************************************************************** 500 IE1=0 IF (RD.LT.360.D0) GOTO 591 RD=RD-360.D0 GOTO 500 591 RD1=DINT(RD/100.D0) RD2=RD-RD1*100.D0 IF (INULF.EQ.1) GOTO 580 CALL INPUT1(RD2,CD,IE) IE1=IE1+IE CALL INPUT1(RM,CM,IE) IE1=IE1+IE CALL INPUT1(RS,CS,IE) IE1=IE1+IE IF (IE1.EQ.0) GOTO 590 IER=301 GOTO 900 580 CALL INPUT2(RD2,CD,IE) IE1=IE1+IE CALL INPUT2(RM,CM,IE) IE1=IE1+IE CALL INPUT2(RS,CS,IE) IE1=IE1+IE IF (IE1.EQ.0) GOTO 590 IER=302 GOTO 900 590 CONTINUE DO 599 I=0,3 IF (RD1.EQ.DBLE(I)) GOTO 598 599 CONTINUE IER=301 GOTO 900 598 CWERT(2:2)=CZ(I+1) CWERT(3:4)=CD IF (CWERT(2:2).NE.' '.AND.CWERT(3:3).EQ.' ') CWERT(3:3)='0' IF (INULF.NE.1) GOTO 597 IF (CWERT(2:2).EQ.' ') CWERT(2:2)='0' IF (CWERT(3:3).EQ.' ') CWERT(3:3)='0' 597 J=4 501 J=J+1 IF (J.GT.LAE) GOTO 421 IF (CHR(J).NE.' ') GOTO 502 CWERT(J:J)=' ' GOTO 501 502 IF (CHR(J).NE.'M') GOTO 510 J1=J J2=J+1 CWERT(J1:J2)=CM J=J+1 503 J=J+1 IF (J.GT.LAE) GOTO 422 IF (CHR(J).NE.' ') GOTO 504 CWERT(J:J)=' ' GOTO 503 504 IF (CHR(J).NE.'S') GOTO 520 J1=J J2=J+1 CWERT(J1:J2)=CS J=J+1 IF (J.GT.LAE) GOTO 423 505 J=J+1 IF (J.GT.LAE) GOTO 423 IF (CHR(J).NE.' ') GOTO 530 CWERT(J:J)=' ' GOTO 505 510 IF (CHR(J).NE.'.') GOTO 512 CWERT(J:J)='.' 511 J=J+1 IF (J.GT.LAE) GOTO 421 IF (CHR(J).NE.' ') GOTO 512 CWERT(J:J)=' ' GOTO 511 512 IF (CHR(J).NE.'L') GOTO 513 BT=RDB K1=7 GOTO 350 513 IF (CHR(J).NE.' ') GOTO 514 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 421 GOTO 512 514 IER=311 GOTO 900 520 IF (CHR(J).NE.'.') GOTO 522 CWERT(J:J)='.' 521 J=J+1 IF (J.GT.LAE) GOTO 422 IF (CHR(J).NE.' ') GOTO 522 CWERT(J:J)=' ' GOTO 521 522 IF (CHR(J).NE.'M') GOTO 523 BT=RMB K1=8 GOTO 350 523 IF (CHR(J).NE.' ') GOTO 524 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 422 GOTO 522 524 IER=321 GOTO 900 530 IF (CHR(J).NE.'.') GOTO 532 CWERT(J:J)='.' 531 J=J+1 IF (J.GT.LAE) GOTO 423 IF (CHR(J).NE.' ') GOTO 532 CWERT(J:J)=' ' GOTO 531 532 IF (CHR(J).NE.'S') GOTO 533 BT=RSB K1=9 GOTO 350 533 IF (CHR(J).NE.' ') GOTO 534 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 423 GOTO 532 534 IER=331 GOTO 900 C******************************************************************** C C C C******************************************************************** 600 IE1=0 IF (INULF.EQ.1) GOTO 680 CALL INPUT1(RM,CM,IE) IE1=IE1+IE CALL INPUT1(RS,CS,IE) IE1=IE1+IE IF (IE1.EQ.0) GOTO 690 IER=101 GOTO 900 680 CALL INPUT2(RM,CM,IE) IE1=IE1+IE CALL INPUT2(RS,CS,IE) IE1=IE1+IE IF (IE1.EQ.0) GOTO 690 IER=102 GOTO 900 690 CWERT(2:3)=CM J=3 603 J=J+1 IF (J.GT.LAE) GOTO 432 IF (CHR(J).NE.' ') GOTO 604 CWERT(J:J)=' ' GOTO 603 604 IF (CHR(J).NE.'S') GOTO 620 J1=J J2=J+1 CWERT(J1:J2)=CS J=J+1 IF (J.GT.LAE) GOTO 433 605 J=J+1 IF (J.GT.LAE) GOTO 433 IF (CHR(J).NE.' ') GOTO 630 CWERT(J:J)=' ' GOTO 605 620 IF (CHR(J).NE.'.') GOTO 622 CWERT(J:J)='.' 621 J=J+1 IF (J.GT.LAE) GOTO 432 IF (CHR(J).NE.' ') GOTO 622 CWERT(J:J)=' ' GOTO 621 622 IF (CHR(J).NE.'M') GOTO 623 BT=RMB K1=11 GOTO 350 623 IF (CHR(J).NE.' ') GOTO 624 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 432 GOTO 622 624 IER=121 GOTO 900 630 IF (CHR(J).NE.'.') GOTO 632 CWERT(J:J)='.' 631 J=J+1 IF (J.GT.LAE) GOTO 433 IF (CHR(J).NE.' ') GOTO 632 CWERT(J:J)=' ' GOTO 631 632 IF (CHR(J).NE.'S') GOTO 633 BT=RSB K1=12 GOTO 350 633 IF (CHR(J).NE.' ') GOTO 634 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 433 GOTO 632 634 IER=131 GOTO 900 C******************************************************************** C C C C C******************************************************************** 700 IE1=0 IF (INULF.EQ.1) GOTO 780 CALL INPUT1(RM,CM,IE) IE1=IE1+IE CALL INPUT1(RS,CS,IE) IE1=IE1+IE IF (IE1.EQ.0) GOTO 790 IER=201 GOTO 900 780 CALL INPUT2(RM,CM,IE) IE1=IE1+IE CALL INPUT2(RS,CS,IE) IE1=IE1+IE IF (IE1.EQ.0) GOTO 790 IER=202 GOTO 900 790 CWERT(2:3)=CM J=3 703 J=J+1 IF (J.GT.LAE) GOTO 442 IF (CHR(J).NE.' ') GOTO 704 CWERT(J:J)=' ' GOTO 703 704 IF (CHR(J).NE.'S') GOTO 720 J1=J J2=J+1 CWERT(J1:J2)=CS J=J+1 IF (J.GT.LAE) GOTO 443 705 J=J+1 IF (J.GT.LAE) GOTO 443 IF (CHR(J).NE.' ') GOTO 730 CWERT(J:J)=' ' GOTO 705 720 IF (CHR(J).NE.'.') GOTO 722 CWERT(J:J)='.' 721 J=J+1 IF (J.GT.LAE) GOTO 442 IF (CHR(J).NE.' ') GOTO 722 CWERT(J:J)=' ' GOTO 721 722 IF (CHR(J).NE.'M') GOTO 723 BT=RMB K1=13 GOTO 350 723 IF (CHR(J).NE.' ') GOTO 724 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 442 GOTO 722 724 IER=221 GOTO 900 730 IF (CHR(J).NE.'.') GOTO 732 CWERT(J:J)='.' 731 J=J+1 IF (J.GT.LAE) GOTO 443 IF (CHR(J).NE.' ') GOTO 732 CWERT(J:J)=' ' GOTO 731 732 IF (CHR(J).NE.'S') GOTO 733 BT=RSB K1=15 GOTO 350 733 IF (CHR(J).NE.' ') GOTO 734 CWERT(J:J)=' ' J=J+1 IF (J.GT.LAE) GOTO 443 GOTO 732 734 IER=231 GOTO 900 C******************************************************************** C C C C******************************************************************** 350 IF (IRUND.NE.0) GOTO 380 K=LAE-J+1 A=DBLE(K) BT=DINT(BT*10.**A+0.5D0) AT=BT/(10.D0**A) IF (AT.LT.1.D0) GOTO 380 BT=BT-10.D0**(A+1.D0) IRUND=1 IF (K1.EQ.1) GOTO 361 IF (K1.EQ.4) GOTO 364 IF (K1.EQ.7) GOTO 367 IF (K1.EQ.2) GOTO 362 IF (K1.EQ.5) GOTO 365 IF (K1.EQ.8) GOTO 368 IF (K1.EQ.3) GOTO 363 IF (K1.EQ.6) GOTO 366 IF (K1.EQ.9) GOTO 369 IF (K1.EQ.11) GOTO 371 IF (K1.EQ.12) GOTO 372 IF (K1.EQ.14) GOTO 374 IF (K1.EQ.15) GOTO 375 361 RH=RH+1 IF (RH.EQ.24.) RH=0.D0 IF (RH.EQ.25.) RH=1.D0 GOTO 100 362 RM=RM+1 IF (RM.LT.60.D0) GOTO 100 RM=RM-60.D0 GOTO 361 363 RS=RS+1 IF (RS.LT.60.D0) GOTO 100 RS=RS-60.D0 GOTO 362 364 RD=RD+1 GOTO 200 365 RM=RM+1 IF (RM.LT.60.D0) GOTO 200 RM=RM-60.D0 GOTO 364 366 RS=RS+1 IF (RS.LT.60.D0) GOTO 200 RS=RS-60.D0 GOTO 365 367 RD=RD+1 IF (RD.GE.360.D0) RD=RD-360.D0 GOTO 500 368 RM=RM+1 IF (RM.LT.60.D0) GOTO 500 RM=RM-60.D0 GOTO 367 369 RS=RS+1 IF (RS.LT.60.D0) GOTO 500 RS=RS-60.D0 GOTO 368 371 RM=RM+1 IF (RM.LT.60.D0) GOTO 600 RM=RM-60.D0 GOTO 600 372 RS=RS+1 IF (RS.LT.60.D0) GOTO 600 RS=RS-60.D0 GOTO 371 374 RM=RM+1 IF (RM.LT.60.D0) GOTO 700 RM=RM-60.D0 GOTO 700 375 RS=RS+1 IF (RS.LT.60.D0) GOTO 700 RS=RS-60.D0 GOTO 374 C******************************************************************** C C C C******************************************************************** 380 CALL INPUT3(BT,K,CBT,IE) J1=J J2=LAE CWERT(J1:J2)=CBT GOTO 900 C******************************************************************** C C C C******************************************************************** 401 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RHB1=RHB+0.5D0 IF (RHB1.LT.1.0D0) GOTO 900 GOTO 361 402 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RMB1=RMB+0.5D0 IF (RMB1.LT.1.0D0) GOTO 900 GOTO 362 403 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RSB1=RSB+0.5D0 IF (RSB1.LT.1.0D0) GOTO 900 GOTO 363 411 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RDB1=RDB+0.5D0 IF (RDB1.LT.1.0D0) GOTO 900 GOTO 364 412 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RMB1=RMB+0.5D0 IF (RMB1.LT.1.0D0) GOTO 900 GOTO 365 413 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RSB1=RSB+0.5D0 IF (RSB1.LT.1.0D0) GOTO 900 GOTO 366 421 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RDB1=RDB+0.5D0 IF (RDB1.LT.1.0D0) GOTO 900 GOTO 367 422 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RMB1=RMB+0.5D0 IF (RMB1.LT.1.0D0) GOTO 900 GOTO 368 423 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RSB1=RSB+0.5D0 IF (RSB1.LT.1.0D0) GOTO 900 GOTO 369 432 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RMB1=RMB+0.5D0 IF (RMB1.LT.1.0D0) GOTO 900 GOTO 371 433 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RSB1=RSB+0.5D0 IF (RSB1.LT.1.0D0) GOTO 900 GOTO 372 442 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RMB1=RMB+0.5D0 IF (RMB1.LT.1.0D0) GOTO 900 GOTO 374 443 IF (IRUND.EQ.1) GOTO 900 IRUND=1 RSB1=RSB+0.5D0 IF (RSB1.LT.1.0D0) GOTO 900 GOTO 375 C******************************************************************** C C C C******************************************************************** 900 CONTINUE IF (IER.EQ.0) GOTO 910 WRITE(LUNERR,1111) RAD,C2,IER 1111 FORMAT (1X, 'FEHLER AUFGETRETEN BEI UMRECHNUNG VON'/ *1X,F11.8,' IN ',A/1X,'FEHLERMELDUNG = ',I3//) RAD = 0.D0 GOTO 920 910 CONTINUE CV='+' IF (CHR(1).EQ.'N') CV=' ' IF (IVA.EQ.-1) CV='-' IF (IH.NE.1) CWERT(1:1)=CV IF (IH.EQ.1 .AND. CHR(2).EQ.'T') CWERT(1:1)=CV 920 CONTINUE 999 CONTINUE RETURN END C******************************************************************** C C C C******************************************************************** SUBROUTINE INPUT1(Z,C,IE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER*2 IZI(100),C DATA IZI/' 0',' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9', *'10','11','12','13','14','15','16','17','18','19', *'20','21','22','23','24','25','26','27','28','29', *'30','31','32','33','34','35','36','37','38','39', *'40','41','42','43','44','45','46','47','48','49', *'50','51','52','53','54','55','56','57','58','59', *'60','61','62','63','64','65','66','67','68','69', *'70','71','72','73','74','75','76','77','78','79', *'80','81','82','83','84','85','86','87','88','89', *'90','91','92','93','94','95','96','97','98','99'/ IE = 0 DO 10 I=0,99 IF (Z.EQ.DBLE(I)) C=IZI(I+1) 10 CONTINUE RETURN END C******************************************************************** C C C C******************************************************************** SUBROUTINE INPUT2(Z,C,IE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) CHARACTER*2 IZI(100),C DATA IZI/'00','01','02','03','04','05','06','07','08','09', *'10','11','12','13','14','15','16','17','18','19', *'20','21','22','23','24','25','26','27','28','29', *'30','31','32','33','34','35','36','37','38','39', *'40','41','42','43','44','45','46','47','48','49', *'50','51','52','53','54','55','56','57','58','59', *'60','61','62','63','64','65','66','67','68','69', *'70','71','72','73','74','75','76','77','78','79', *'80','81','82','83','84','85','86','87','88','89', *'90','91','92','93','94','95','96','97','98','99'/ IE = 0 DO 10 I=0,99 IF (Z.EQ.DBLE(I)) C=IZI(I+1) 10 CONTINUE RETURN END C******************************************************************** C C C******************************************************************** SUBROUTINE INPUT3(B,L,CC,IE) IMPLICIT DOUBLE PRECISION (A-H,O-Z) DIMENSION Z(9) CHARACTER*10 CC CHARACTER*1 IZ(10),IZI(10) DATA IZ/'0','1','2','3','4','5','6','7','8','9'/ DO 99 I=1,10 CC(I:I)=' ' 99 CONTINUE IF (L.GT.9) GOTO 90 DO 10 I=1,9 Z(I)=0 IZI(I)=' ' 10 CONTINUE GOTO(1,2,3,4,5,6,7,8,9) L 9 Z(9)=DINT(B/10.**8.D0) 8 Z(8)=DINT((B-Z(9)*10.D0**8.D0)/10.**7.D0) 7 Z(7)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0)/10.**6.D0) 6 Z(6)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0- F Z(7)*10.D0**6.D0)/10.**5.D0) 5 Z(5)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0- F Z(7)*10.D0**6.D0-Z(6)*10.D0**5.D0)/10.**4.D0) 4 Z(4)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0- F Z(7)*10.D0**6.D0-Z(6)*10.D0**5.D0- F Z(5)*10.D0**4.D0)/1000.) 3 Z(3)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0- F Z(7)*10.D0**6.D0-Z(6)*10.D0**5.D0- F Z(5)*10.D0**4.D0-Z(4)*10.D0**3.D0)/100.) 2 Z(2)=DINT((B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0- F Z(7)*10.D0**6.D0-Z(6)*10.D0**5.D0- F Z(5)*10.D0**4.D0-Z(4)*10.D0**3.D0- F Z(3)*10.D0**2.D0)/10.) 1 Z(1)= DINT(B-Z(9)*10.D0**8.D0-Z(8)*10.D0**7.D0- F Z(7)*10.D0**6.D0-Z(6)*10.D0**5.D0- F Z(5)*10.D0**4.D0-Z(4)*10.D0**3.D0- F Z(3)*10.D0**2.D0-Z(2)*10.D0**1.D0) DO 12 I=0,9 DO 11 J=1,9 IF (Z(J).EQ.DBLE(I)) IZI(J)=IZ(I+1) 11 CONTINUE 12 CONTINUE CC(1:1)=IZI(L) DO 13 I=L-1,1,-1 L1=L-I+1 CC(L1:L1)=IZI(I) 13 CONTINUE GOTO 14 90 IE=1 14 CONTINUE RETURN C******************************************************************** C C C C******************************************************************** END C Wandeln von Klein- nach Grossbuchstaben Subroutine Upcase(c) character c*1 integer i i = ichar(c) if ((i.ge.97).and.(i.le.122)) then c = char(i-32) end if end SUBROUTINE ELAB(IVERS,XEQJ,ALPHA1,DELTA1,ALPHA2,DELTA2) 00003500 C 00003600 C BEHANDLUNG DER ELLIPTISCHEN ABERRATION 00003700 C 00003800 C EINGABE: 00003900 C ======== 00004000 C 00004100 C IVERS : 1 = DIE EINGABEKOORDINATEN SIND MIT ELLIPTISCHER 00004200 C ABERRATION BEHAFTET; DIESE WIRD ELIMINIERT. 00004300 C 2 = DIE EINGABEKOORDINATEN SIND NICHT MIT ELLIPTISCHER 00004400 C ABERRATION BEHAFTET; DIESE WIRD ANGEBRACHT. 00004500 C XEQJ : AEQUINOKTIUM VON ALPHA1, DELTA1 IN JUL. DATUM 00004600 C ALPHA1 : REKTASZENSION (RADIAN) 00004700 C DELTA1 : DEKLINATION (RADIAN) 00004800 C 00004900 C AUSGABE: 00005000 C ======== 00005100 C 00005200 C ALPHA2 : REKTASZENSION (RADIAN) 00005300 C DELTA2 : DEKLINATION (RADIAN) 00005400 C 00005500 C 00005600 IMPLICIT REAL*8 (A-H,O-Z) 00005700 C 00005800 C 00005900 C AEQUINOKTIUM IN BESSELSCHE EPOCHE UMRECHNEN 00006000 C 00006100 CALL JDBE(XEQJ,XEQB) 00006200 CALL KSTETR (XEQB,C0,D0,EPS) 00006300 CALL ETERM (ALPHA1,DELTA1,C0,D0,EPS,CORRA,CORRD) 00006400 C 00006500 C NUN ELLIPTISCHE ABERRATION ELIMINIEREN ODER ANBRINGEN 00006600 C 00006700 IF (IVERS.EQ.2) GOTO 200 00006800 C 00006900 C ELLIPTISCHE ABERRATION ELIMINIEREN 00007000 C 00007100 ALPHA2 = ALPHA1 - CORRA 00007200 DELTA2 = DELTA1 - CORRD 00007300 C 00007400 RETURN 00007500 C 00007600 200 CONTINUE 00007700 C 00007800 C ELLIPTISCHE ABERRATION ANBRINGEN 00007900 C 00008000 ALPHA2 = ALPHA1 + CORRA 00008100 DELTA2 = DELTA1 + CORRD 00008200 RETURN 00008300 END 00008400 SUBROUTINE TSPV2 (IP,XEQ,XEP,YEQ,YEP,XA,XD,XM,XMS,XP0,XVEL0, 00081500 1 YA,YD,YM,YMS,YP0,YVEL0,IER) 00081600 C 00081700 C EPOCHEN- UND AEQUINOX-UEBERTRAGUNG VON OERTERN U. EIGENBEWEGUNGEN 00081800 C 00081900 C EOCHEN-UEBERTRAGUNG MIT BENUTZUNG DER RAUMGESCHWINDIGKEIT 00082000 C.............................................................. 00082100 C ................... 00082200 C 00082300 C IP : STEUERT, WELCHE PRAEZESSIONSWERTE GENOMMEN WERDEN. 00082400 C IP= 1 : NEUE IAU(1976) WERTE; 00082500 C IP = 2 : NEWCOMBS PRAEZESSION; 00082600 C IP = 3 : STRUVE'S PRAEZESSION; 00082700 C 00082800 C EINGABE: XEQ = JULIANISCHES DATUM DES AUSGANGS-AEQUINOXES 00082900 C YEQ = JULIANISCHES DATUM DES END-AEQUINOXES 00083000 C XEP = JULIANISCHES DATUM DER AUSGANGS-EPOCHE 00083100 C YEP = JULIANISCHES DATUM DER END-EPOCHE 00083200 C XA = REKTASZENSION FOER EPOCHE XEP, AEQUINOX XEQ 00083300 C XD = DEKLINATION FUER EPOCHE XEP, AEQUINOX XEQ 00083400 C XM = E.B. IN ALPHA FUER EPOCHE YEP, AEQUINOX XEQ 00083500 C XMS = E.B. IN DELTA FUER EPOCHE XEP, AEQUINOX XEQ 00083600 C XP0 = PARALLAXE ZUR EPOCHE XEP IM BOGENMASS 00083700 C XVEL0 = RADIALGESCHWINDIGKEIT ZUR EPOCH XEP 00083800 C 00083900 C AUSGABE: YA = REKTASZENSION FUER EPOCHE YEP, AEQUINOX YEQ 00084000 C YD = DEKLINATION FUER EPOCHE YEP, AEQUINOX YEQ 00084100 C YM = E.B. IN ALPHA FUER EPOCHE YEP, AEQUINOX YEQ 00084200 C YMS = E.B. IN DELTA FUER EPOCHE YEP, AEQUINOX YEQ 00084300 C YP0 = PARALLAXE ZUR EPOCHE XEP IM BOGENMASS 00084400 C YVEL0 = RADIALGESCHWINDIGKEIT ZUR EPOCH XEP 00084500 C RETURN-CODE IER: = 0: RAD.VEL. UND PAR. UNGLEICH O 00084600 C = 1: RAD.VEL. ODER PAR. GLEICH 0 00084700 C 00084800 C ALLE WINKEL IM BOGENMASS 00084900 C ZEITEINHEIT = JULIANISCHES JAHRHUNDERT 00085000 C 00085100 C 00085200 IMPLICIT REAL*8 (A-H,O-Z) 00085300 C 00085400 REAL*8 PX(3,3) 00085500 C 00085600 C 00085700 C 00085800 C EPOCHENUEBERTRAGUNG DER OERTER UND EIGENBEWEGUNGEN 00085900 C 00086000 CALL TPMSPC (XEP,YEP,XA ,XD ,XM ,XMS ,XP0,XVEL0, 00086100 1 XA2,XD2,XM2,XMS2,YP0,YVEL0,IER) 00086200 C 00086300 C PRAEZESSIONSUEBERTRAGUNG VON OERTERN UND EIGENBEWEGUNGEN 00086400 C 00086500 CALL KPRZ (IP,XEQ,YEQ,ZET,TETA,ZETA) 00086600 CALL PRZMTX( ZET,TETA,ZETA,PX) 00086700 C 00086800 CALL PRECES(XA2,XD2,XM2,XMS2,PX,XA3,XD3,XM3,XMS3) 00086900 C 00087000 YA = XA3 00087100 YD = XD3 00087200 YM = XM3 00087300 YMS=XMS3 00087400 RETURN 00087500 END 00087600 C 1. Name: Subroutine BEJD U. Bastian, Okt. 1984 00000100 C 00000300 C 2. Zweck: Besselsche Epochen in Julianische Daten umwandeln. 00000400 C 00000550 C 3. Aufruf: 00000600 C CALL BEJD(BE,TJD) 00000700 C 00000800 C 4. Parameter: 00000900 C 00001000 C BE Input Besselsche Epoche (Jahre) Real*8 00001650 C 00001760 C TJD Output Julianisches (Ephemeris) Datum (Tage) Real*8 00001800 C 00001900 C 00002000 SUBROUTINE BEJD(BE,TJD) 00002100 IMPLICIT REAL*8 (A-Z) 00002200 C 00002300 TJD=(BE-1900.D0)*365.242198781D0+2415020.31352D0 00003300 RETURN 00003400 END 00003500 SUBROUTINE TSPVEL (XEQ,XEP,YEQ,YEP,XA,XD,XM,XMS,XP0,XVEL0, 00000100 1 YA,YD,YM,YMS,YP0,YVEL0,IER) 00000200 C 00000300 C EPOCHEN- UND AEQUINOX-UEBERTRAGUNG VON OERTERN U. EIGENBEWEGUNGEN 00000400 C 00000500 C EOCHEN-UEBERTRAGUNG MIT BENUTZUNG DER RAUMGESCHWINDIGKEIT 00000600 C.............................................................. 00000700 C ................... 00000800 C 00000900 C EINGABE: XEQ = JULIANISCHES DATUM DES AUSGANGS-AEQUINOXES 00001000 C YEQ = JULIANISCHES DATUM DES END-AEQUINOXES 00001100 C XEP = JULIANISCHES DATUM DER AUSGANGS-EPOCHE 00001200 C YEP = JULIANISCHES DATUM DER AUSGANGS-EPOCHE 00001300 C XA = REKTASZENSION FOER EPOCHE XEP, AEQUINOX XEQ 00001400 C XD = DEKLINATION FUER EPOCHE XEP, AEQUINOX XEQ 00001500 C XM = E.B. IN ALPHA FUER EPOCHE YEP, AEQUINOX XEQ 00001600 C XMS = E.B. IN DELTA FUER EPOCHE XEP, AEQUINOX XEQ 00001700 C XP0 = PARALLAXE ZUR EPOCHE XEP IM BOGENMASS 00001800 C XVEL0 = RADIALGESCHWINDIGKEIT ZUR EPOCH XEP 00001900 C 00002000 C AUSGABE: YA = REKTASZENSION FUER EPOCHE YEP, AEQUINOX YEQ 00002100 C YD = DEKLINATION FUER EPOCHE YEP, AEQUINOX YEQ 00002200 C YM = E.B. IN ALPHA FUER EPOCHE YEP, AEQUINOX YEQ 00002300 C YMS = E.B. IN DELTA FUER EPOCHE YEP, AEQUINOX YEQ 00002400 C YP0 = PARALLAXE ZUR EPOCHE XEP IM BOGENMASS 00002500 C YVEL0 = RADIALGESCHWINDIGKEIT ZUR EPOCH XEP 00002600 C RETURN-CODE IER: = 0: RAD.VEL. UND PAR. UNGLEICH O 00002700 C = 1: RAD.VEL. ODER PAR. GLEICH 0 00002800 C 00002900 C ALLE WINKEL IM BOGENMASS 00003000 C ZEITEINHEIT = JULIANISCHES JAHRHUNDERT 00003100 C 00003200 C 00003300 IMPLICIT REAL*8 (A-H,O-Z) 00003400 C 00003500 REAL*8 PX(3,3) 00003600 C 00003700 C 00003800 C 00003900 C EPOCHENUEBERTRAGUNG DER OERTER UND EIGENBEWEGUNGEN 00004000 C 00004100 CALL TPMSPC (XEP,YEP,XA ,XD ,XM ,XMS ,XP0,XVEL0, 00004200 1 XA2,XD2,XM2,XMS2,YP0,YVEL0,IER) 00004300 C 00004400 C PRAEZESSIONSUEBERTRAGUNG VON OERTERN UND EIGENBEWEGUNGEN 00004500 C 00004600 CALL KSTPRZ(XEQ,YEQ,ZET,TETA,ZETA) 00004700 CALL PRZMTX( ZET,TETA,ZETA,PX) 00004800 C 00004900 CALL PRECES(XA2,XD2,XM2,XMS2,PX,XA3,XD3,XM3,XMS3) 00005000 C 00005100 YA = XA3 00005200 YD = XD3 00005300 YM = XM3 00005400 YMS=XMS3 00005500 RETURN 00005600 END 00005700 SUBROUTINE JDBE(JD,BE) 00001100 C 00001200 C UMWANDLUNG DES JULIANISCHEN DATUMS IN BESSELSCHE EPOCHE 00001300 C 00001400 REAL*8 JD,BE 00001500 C 00001600 BE = (JD-2415020.31352D0)/365.242198781D0 + 1900.D0 00001700 C 00001800 RETURN 00001900 END 00002000 SUBROUTINE TRANS (XEQ,XEP,YEQ,YEP,XA,XD,XM,XMS,XFOR,YA,YD,YM,YMS) 00001360 C 00001370 C EPOCHEN- UND AEQUINOX-UEBERTRAGUNG VON OERTERN U. EIGENBEWEGUNGEN 00001380 C 00001390 C EINGABE: XEQ = EPOCHE DES ANFANGSAEQUINOX 00001400 C YEQ = EPOCHE DES ENDAEQUINOX 00001410 C XEP = ANFANGSEPOCHE 00001420 C YEP = ENDEPOCHE 00001430 C XA = REKTASZENSION FOER EPOCHE XEP, AEQUINOX XEQ 00001440 C XD = DEKLINATION FUER EPOCHE XEP, AEQUINOX XEQ 00001450 C XM = E.B. IN ALPHA FUER EPOCHE YEP, AEQUINOX XEQ 00001460 C XMS = E.B. IN DELTA FUER EPOCHE XEP, AEQUINOX XEQ 00001470 C XFOR = FORESHORTENING-EFFEKT 00001480 C 00001490 C AUSGABE: YA = REKTASZENSION FUER EPOCHE YEP, AEQUINOX YEQ 00001500 C YD = DEKLINATION FUER EPOCHE YEP, AEQUINOX YEQ 00001510 C YM = E.B. IN ALPHA FUER EPOCHE YEP, AEQUINOX YEQ 00001520 C YMS = E.B. IN DELTA FUER EPOCHE YEP, AEQUINOX YEQ 00001530 C 00001540 C ALLE WINKEL IM BOGENMASS 00001550 C ZEITEINHEIT = JULIANISCHES JAHRHUNDERT 00001560 C 00001570 C 00001580 IMPLICIT REAL*8 (A-H,O-Z) 00001590 C 00001600 REAL*8 PX(3,3) 00001610 C 00001620 PI = 3.141592653589793D0 00001630 C 00001631 C 00001632 C EPOCHENUEBERTRAGUNG DER OERTER UND EIGENBEWEGUNGEN 00001770 C 00001780 CALL TPMPM (XA,XD,XM,XMS,XFOR,XEP,YEP,XA2,XD2,XM2,XMS2) 00001790 C 00001800 C PRAEZESSIONSUEBERTRAGUNG VON OERTERN UND EIGENBEWEGUNGEN 00001990 C 00001991 CALL KSTPRZ(XEQ,YEQ,ZET,TETA,ZETA) 00001992 CALL PRZMTX( ZET,TETA,ZETA,PX) 00001993 C 00002000 CALL PRECES(XA2,XD2,XM2,XMS2,PX,XA3,XD3,XM3,XMS3) 00002010 C 00002020 YA = XA3 00002040 YD = XD3 00002050 YM = XM3 00002060 YMS=XMS3 00002070 RETURN 00002080 END 00002090 C 00005130 SUBROUTINE TPMPM (XA,XD,XMUE,XMUES,DMUFOR,T0,T1,YA,YD,YMUE,YMUES) 00005140 C 00005150 C EPOCHENUEBERTRAGUNG VON OERTERN UND EIGENBEWEGUNGEN 00005160 C 00005170 C EINGABE: XA = ALPHA FUER AUSGANGSEPOCHE 00005180 C XD = DELTA FUER AUSGANGSEPOCHE 00005190 C XMUE = E.B. IN ALPHA ZUR AUSGANGSEPOCHE 00005200 C XMUES = E.B. IN DELTA ZUR AUSGANGSEPOCHE 00005210 C T0 = AUSGANGSEPOCHE 00005220 C T1 = ENDEPOCHE 00005230 C DMUFOR = FORESHORTENING-EFFEKT 00005240 C AUSGABE: YA = ALPHA FUER ENDEPOCHE 00005250 C YD = DELTA FUER ENDEPOCHE 00005260 C YMUE = E.B. IN ALPHA ZUR ENDEPOCHE 00005270 C YMUES = E.B. IN DELTA ZUR ENDEPOCHE 00005280 C ALLE WINKEL IM BOGENMASS 00005290 C ZEITEINHEIT DER EIGENBEWEGUNGEN: JULIANISCHES JAHRHUNDERT 00005300 C T0, T1 IN JULIANISCHEM DATUM 00005310 C 00005320 C 00005330 IMPLICIT REAL*8 (A-H,O-Z) 00005340 REAL*8 XM(3,1),ABLA(3,1),ABLD(3,1) 00005350 C 00005360 C 00005370 DT = (T1-T0)/36525.D0 00005380 C 00005410 SD = DSIN(XD) 00005420 CD = DCOS(XD) 00005430 SA = DSIN(XA) 00005440 CA = DCOS(XA) 00005450 C 00005460 XMUE0 = DSQRT(XMUE*XMUE*CD*CD + XMUES*XMUES) 00005461 XMUTOT = XMUE0 + 0.5D0*DMUFOR*DT 00005470 C 00005480 SPSI = (XMUE*CD)/XMUE0 00005490 CPSI = XMUES/XMUE0 00005500 SMT = DSIN(XMUTOT*DT) 00005510 CMT = DCOS(XMUTOT*DT) 00005520 C 00005530 C BERECHNUNG DES VEKTORS "M-PUNKT MAL X" (SIEHE UNTERLAGEN) 00005540 C 00005550 C 'ABLEITUNG DER ORTS-AENDERUNG BERECHNEN', SIEHE UNTERLAGEN 00005560 C 00005570 XMUPKT = XMUTOT + 0.5D0*DMUFOR*DT 00005580 C 00005590 XM(1,1) = -XMUPKT*(+SD*CA*CPSI*CMT + SA*SPSI*CMT + CD*CA*SMT) 00005600 XM(2,1) = -XMUPKT*(+SD*SA*CPSI*CMT - CA*SPSI*CMT + CD*SA*SMT) 00005610 XM(3,1) = -XMUPKT*(-CD*CPSI*CMT + SD*SMT) 00005620 C 00005630 C BERECHNUNG DES ORTES FUER DIE ENDEPOCHE 00005640 C 00005650 CALL TPMPOS (XA,XD,XMUE,XMUES,DMUFOR,T0,T1,YA,YD) 00005660 C 00005680 C BERECHNUNG DES VEKTORS DER ABGELEITETEN RICHTUNGSKOSINUSSE 00005690 C FUER DIE OERTER ZUR ENDEPOCHE 00005700 C 00005710 CALL DLDA (YA,YD,ABLA) 00005720 CALL DLDD (YA,YD,ABLD) 00005730 C 00005760 C TRANSFORMIERTE EIGENBEWEGUNGEN BERECHNEN 00005770 C 00005780 CALL SCLPRD (XM,ABLA,YMUE ,3) 00005790 CALL SCLPRD (XM,ABLD,YMUES,3) 00005800 YMUE = YMUE/(DCOS(YD)*DCOS(YD)) 00005810 RETURN 00005830 END 00005840 C 00004570 SUBROUTINE TPMPOS (XA,XD,XMUE,XMUES,DMUFOR,T0,T1,YA,YD) 00004580 C 00004590 C EIGENBEWEGUNGSUEBERTRAGUNG VON MITTLEREN OERTERN 00004600 C 00004610 C EINGABE: XA = ALPHA ZUR EPOCHE T0 00004620 C XD = DELTA ZUR EPOCHE T0 00004630 C XMUE = E.B. IN ALPHA ZUR EPOCHE T0 00004640 C XMUES = E.B. IN DELTA ZUR EPOCHE T0 00004650 C DMUFOR = FORESHORTENING-EFFEKT 00004660 C T0 = AUSGANGSEPOCHE 00004670 C T1 = ENDEPOCHE 00004680 C AUSGABE: YA = ALPHA ZUR ENDEPOCHE 00004690 C YD = DELTA ZUR ENDEPOCHE 00004700 C 00004710 C ALLE WINKEL IM BOGENMASS 00004720 C ZEITEINHEIT JULIANISCHES JAHRHUNDERT 00004730 C 00004740 C 00004750 IMPLICIT REAL*8 (A-H,O-Z) 00004760 REAL*8 XM(3,1) 00004770 C 00004780 PI = 3.141592653589793D0 00004790 C 00004800 DT = (T1-T0)/36525.D0 00004840 C 00004850 SD = DSIN(XD) 00004860 CD = DCOS(XD) 00004870 SA = DSIN(XA) 00004880 CA = DCOS(XA) 00004890 C 00004900 XMUE0 = DSQRT(XMUE*XMUE*CD*CD + XMUES*XMUES) 00004901 XMUTOT = XMUE0 + 0.5D0*DMUFOR*DT 00004910 C 00004930 SPSI = (XMUE*CD)/XMUE0 00004940 CPSI = XMUES/XMUE0 00004950 C 00004960 SMT = DSIN(XMUTOT*DT) 00004970 CMT = DCOS(XMUTOT*DT) 00004980 C 00004990 C BERECHNUNG DES VEKTOR "M.X" NACH MUELLER, S.115, FORMEL 4.94 00005000 C 00005010 XM(1,1) = -SD*CA*CPSI*SMT - SA*SPSI*SMT + CD*CA*CMT 00005020 XM(2,1) = -SD*SA*CPSI*SMT + CA*SPSI*SMT + CD*SA*CMT 00005030 XM(3,1) = +CD*CPSI*SMT + SD*CMT 00005040 C 00005050 C BERECHNUNG DER WINKEL AUS DEN RICHTUNGSKOSINUSSEN 00005060 C 00005070 CALL ANGLE (XM,YA,YD) 00005090 RETURN 00005110 END 00005120 SUBROUTINE GSDBY (BY,GSD) 00000100 C 00000200 C BESTIMMUNG DES ERSTEN DURCH 10 TEILBAREN GREENWICH SIDERIAL 00000300 C DAY-NUMBER (+0.5) VOR BEGINN DES BESSELSCHEN JAHRES BY 00000400 IMPLICIT REAL*8 (A-Z) 00000500 INTEGER I 00000600 X = 241 5020.313D0 + 365.2421988D0*(BY-1900.D0) 00000700 JD = X 00000800 X = 0.671D0 + 1.00273 79093D0*X 00000900 I = X/10.D0 00001000 I = I*10 00001100 X = I + 0.5D0 00001200 Y = -0.669D0 + 0.99726 95664D0*X 00001300 IF (Y.GE.JD) X = X-10.D0 00001400 GSD = X 00001500 RETURN 00001600 END 00001700 SUBROUTINE BDN (T,TEQU,INCLEA,AL,BL,C,D,EL,AG,BG,EG,TAU) 00002060 C 00002070 C BERECHNUNG DER DAY-NUMBERS 00002080 C 00002090 C EINGABE: T = JULIANISCHES DATUM FUER DAS DIE DAY-NUMBERS 00002100 C GERECHNET WERDEN SOLLEN 00002110 C TEQU = JULIANISCHES DATUM FUER MITTLERES AEQUINOX 00002120 C UND AEQUATOR, AUF DAS SICH DIE DAY-NUMBERS 00002130 C BEZIEHEN 00002140 C INCLEA : = .T. , DANN WIRD DIE ELLIPTISCHE ABEREATION00002150 C IN DIE DAY-NUMBERS HINEINGENOMMEN 00002160 C = .F. , DANN WIRD DIE ELLIPTISCHE ABERRATION00002170 C AUS DEN DAY-NUMBERS HERAUSGERECHET 00002180 C AUSGABE: A, B, C, D, E = DAY-NUMBERS (IN BOGENSEKUNDEN) 00002190 C DIE WERTE MIT "L" ENTHALTEN NUR DIE LANGPERIODISCHE 00002200 C NUTATION, DIE WERTE MIT "G" ENTHALTEN AUCH DIE 00002210 C KURZPERIODISCHE NUTATION. 00002220 C 00002230 C 00002240 C C,D ENTHALTN ELLIPT. ABERRATION, FALLS INCLEA = .T., 00002250 C 00002260 C C,D ENTHALTEN SIE NICHT, FALLS INCLEA=.F. 00002270 C VOR 1984 HABEN C,D KEINN ELL. ABERR. ENTHALTEN 00002280 C AB 1984 SOLLEN C,D ELL. ABERR. ENTHALTEN 00002290 C 00002300 C 00002310 C 00002320 C 00002330 IMPLICIT REAL*8 (A-H,O-Z) 00002340 LOGICAL INCLEA 00002350 C 00002360 DIMENSION XLA(3),XLA1(3),XF(3),PREC(3,3),XLE(3),XLSUN(3) 00002370 C 00002380 C 00002390 PI = 3.141592653589793D0 00002400 XTR = 3600.D0*(180.D0/PI) 00002410 C 00002420 VC = 299 792.458D0 00002430 C 00002440 C 00002450 C ORTS- UND GESCHW.-VEKTOR DER ERDE(BARYZENTRISCH) BESTIMEN 00002460 C 00002470 CALL EARTH (T,XLE,XLA,XLSUN,ier) 00002480 C WRITE(6,1723) T,TEQU 00002490 1723 FORMAT(1X,5F20.8) 00002500 C 00002510 C 00002520 C UMRECHNUNG DES ORTS- UND GESCHW.-VEKTORS DER ERDE AUF MOMEN 00002530 C TANES MITTLERES AEQUINOX UND EPOCHE 00002540 C 00002550 C 00002560 CALL KSTPRZ (245 1545.00000000D0,TEQU,ZET,TETA,ZETA) 00002570 CALL PRZMTX (ZET,TETA,ZETA,PREC) 00002580 CALL GMPRD(PREC,XLA,XF,3,3,1) 00002590 C 00002600 C ABSOLUT-BETRAG DER ERDBAHNGESCHWINDIGKEIT BERECHNEN 00002610 C 00002620 CALL SCLPRD (XF,XF,V,3) 00002630 V = DSQRT(V) 00002640 C WRITE(6,1723) V 00002650 C 00002660 C BERECHNUNG DES EINHEITSVEKTORS DER ERDBAHNGESCHWINDIGKEIT 00002670 C 00002680 DO 10 I = 1,3 00002690 10 XLA1(I) = XF(I)/V 00002700 C WRITE(6,1723) XLA1 00002710 C 00002720 C UMRECHNUNG VON V IN KM/SEC (HAT HIER NOCH DIE DIMENSION A.U./TAG) 00002730 C 00002740 V = V*(1.495 978 70D8)/86400.D0 00002750 C WRITE(6,1723) V 00002760 BQ = V/VC 00002770 C WRITE(6,1723) BQ 00002780 C = XLA1(2)*BQ*XTR 00002790 D = -XLA1(1)*BQ*XTR 00002800 C 00002810 C 00002820 IF (INCLEA) GO TO 40 00002830 C 00002840 C JETZT ELLIPTISCHE ABERRATION ELIMINIEREN 00002850 C 00002860 X = 1950.D0 + (T-2433282.423D0)/365.2422D0 00002870 CALL KSTETR (X,DC,DD,EPS) 00002880 DC = DC*XTR 00002890 DD = DD*XTR 00002900 C = C -DC 00002910 D = D -DD 00002920 40 CONTINUE 00002930 C 00002940 C 00002950 CALL KSTNUT (T,DPSIL,DPSIS,DEPSL,DEPSS,EPS) 00002960 C 00002970 DPSIL = DPSIL*XTR 00002980 DPSIS = DPSIS*XTR 00002990 DEPSL = DEPSL*XTR 00003000 DEPSS = DEPSS*XTR 00003010 C 00003020 C HIER EVTL. NOCH EINHEITEN KORRIGIEREN 00003030 C 00003040 C 00003050 C ZUM TESTEN ALTE NUTATION NEHMEN 00003060 C 00003070 C X = (T-2415020.D0)/36525.D0 00003080 C CALL NUTAT(X,DPSIL,DPSIS,DEPSL,DEPSS) 00003090 C 00003100 TAU = (T-TEQU)/365.25D0 00003110 C WRITE(6,1723) TAU 00003120 XDT = (T-2451545.D0)/36525.D0 00003130 YN = 20.043109D0 - 0.008533D0*XDT 00003140 YPSIS = 50.387784D0 + 0.0049263D0*XDT 00003150 YLAMBS = 0.105526D0 - 0.0188623D0*XDT 00003160 C 00003170 AL = YN*TAU + YN*DPSIL/YPSIS 00003180 AG = YN*TAU + YN*(DPSIL+DPSIS)/YPSIS 00003190 BL = -DEPSL 00003200 BG = -(DEPSL+DEPSS) 00003210 EL = YLAMBS*DPSIL/YPSIS 00003220 EG = YLAMBS*(DPSIL+DPSIS)/YPSIS 00003230 RETURN 00003240 END 00003250