C OPTIONS(SAVE,DREAL) C OPTIONS(SAVE,DREAL,CHECK) OPTIONS(SAVE,DREAL,OPTIMISE) C A CODE FOR Teff-LOG G DETERMINATION C FROM UBV,uvbybeta AND Geneva PHOTOMETRY C IT IS A SUBJECTIVE COMPILATION OF DIFFERENT CALIBRATIONS C AND METHODS JUST TO MAKE YOUR TASK EASIER c c authors: J. Budaj c contact: budaj@ta3.sk c published: http://www.ta3.sk/~budaj/software c special requirements: DBOS environement c non original routins: intep (Press.et.al. 1992, Numerical recipes) c input: keyboard + phot.dat.+north.dat c output: photfit.out C C PARAMETER (NMOM1=103,NSYN=26,NEZ2=20) IMPLICIT DOUBLE PRECISION(A-H,O-Z) CHARACTER*12 INN1 C INPUT DIALOG WRITE(*,*)' EXAMPLE OF THE INPUT FILE: PHOTFIT.IN' WRITE(*,*)' OUTPUT: PHOTFIT.OUT' OPEN(9,FILE='PHOTFIT.OUT',STATUS='UNKNOWN') WRITE(*,*) WRITE(*,'(A,$)')' INPUT DATA FILE => ' READ(5,'(A12)')INN1 OPEN(7,FILE=INN1,STATUS='OLD') READ(7,*) READ(7,*) READ(7,*)UB1,BV1,VV1,EBV1,UB0,BV0 READ(7,*) READ(7,*)SUB,SBY,SM1,SC1,BETA,WGAMA,EBY READ(7,*) READ(7,*)GU,GV,GB1,GB2,GV1,GG C------------------------------PHOTOMETRY------------------------------- IF(ABS(UB1-1.E6).GT.1.E-10.OR.ABS(BV1-1.E6).GT.1.E-10.OR. P ABS(UB0-1.E6).GT.1.E-10.OR.ABS(BV0-1.E6).GT.1.E-10.OR. P ABS(SUB-1.E6).GT.1.E-10.OR.ABS(SBY-1.E6).GT.1.E-10.OR. P ABS(SM1-1.E6).GT.1.E-10.OR.ABS(SC1-1.E6).GT.1.E-10.OR. P ABS(GU-1.E6).GT.1.E-10.OR.ABS(GV-1.E6).GT.1.E-10.OR. P ABS(GB1-1.E6).GT.1.E-10.OR.ABS(GB2-1.E6).GT.1.E-10.OR. P ABS(GV1-1.E6).GT.1.E-10.OR.ABS(GG-1.E6).GT.1.E-10)THEN C P ABS(VV1-1.E6).GT.1.E-10.OR. C P ABS(BETA-1.E6).GT.1.E-10.OR.ABS(WGAMA-1.E6).GT.1.E-10.OR. CALL PHOT(UB1,BV1,VV1,EBV1,UB0,BV0,SUB,SBY,SC1,SM1,BETA, P WGAMA,EBY,GU,GV,GB1,GB2,GV1,GG) ENDIF CLOSE(9) STOP END C----------------------------------------------------------------------- C PODPROGRAMY C----------------------------------------------------------------------- C SUBROUTINE I N T E P : SPLINE INTERPOLATION SCHEME BASED C ON HERMITE POLYNOMIALS C INPUT : XP - THE CHOSEN ARGUMENT VALUE C X - THE VECTOR OF INDEPENDENT VALUES C F - THE VECTOR OF FUNCTION OR DEPENDENT VALUES C N - THE NUMBER OF POINTS IN THE (X,F) VECTORS C OUTPUT : P - THE RESULTANT INTERPOLATED VALUE C IER - THE RESULTANT ERROR PARAMETER SUBROUTINE INTEP(XP,P,X,F,N,IER) IMPLICIT DOUBLE PRECISION(A-H,O-Z) REAL LP1,LP2,L1,L2 DIMENSION F(N),X(N) IER=1 IO=1 IUP=0 IF(X(2).LT.X(1)) IUP=1 N1=N-1 IF((XP.GE.X(N).AND.IUP.EQ.0).OR.(XP.LE.X(N).AND.IUP.EQ.1)) THEN P=F(N) IER=2 RETURN ELSE IF((XP.LE.X(1).AND.IUP.EQ.0).OR. * (XP.GE.X(1).AND.IUP.EQ.1)) THEN P=F(1) IER=2 RETURN END IF DO 1 I=IO,N IF(XP.LT.X(I).AND.IUP.EQ.0) GOTO 2 IF(XP.GT.X(I).AND.IUP.EQ.1) GOTO 2 1 CONTINUE P=F(N) IER=2 RETURN 2 I=I-1 IF(I.EQ.IO-1) GOTO 4 IO=I+1 LP1=1./(X(I)-X(I+1)) LP2=1./(X(I+1)-X(I)) IF(I.EQ.1) FP1=(F(2)-F(1))/(X(2)-X(1)) IF(I.EQ.1) GOTO 3 FP1=(F(I+1)-F(I-1))/(X(I+1)-X(I-1)) 3 IF(I.GE.N1) FP2=(F(N)-F(N-1))/(X(N)-X(N-1)) IF(I.GE.N1) GOTO 4 FP2=(F(I+2)-F(I))/(X(I+2)-X(I)) 4 XPI1=XP-X(I+1) XPI=XP-X(I) L1=XPI1*LP1 L2=XPI*LP2 P=F(I)*(1.-2.*LP1*XPI)*L1*L1+F(I+1)*(1.-2.*LP2*XPI1) * *L2*L2+FP2*XPI1*L2*L2+FP1*XPI*L1*L1 RETURN END C----------------------------------------------------------------------- SUBROUTINE ZORAD(D,OMM,L,NMOM,IVOL,NMOM1) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION D(NMOM1),OMM(NMOM1),L(NMOM1) DO 260 I=1,IVOL OMM(I)=1.E20 L(I)=0 260 CONTINUE DO 300 J=1,IVOL DO 290 I=1,NMOM DO 280 IL=1,IVOL IF (I.EQ.L(IL).OR.ABS(D(I)-0.).LT.1.E-20) GOTO 290 280 CONTINUE IF (D(I).LT.OMM(J)) THEN OMM(J)=D(I) L(J)=I ENDIF 290 CONTINUE 300 CONTINUE RETURN END C----------------------------------------------------------------------- SUBROUTINE PHOT(UB1,BV1,VV1,EBV1,UB0,BV0,SUB,SBY,SC1,SM1,BETA, P WGAMA,EBY1,GU,GV,GB1,GB2,GV1,GG) C NMOM1 - POCET MODELOV DIMENZACIA C NMOM - POCET MODELOV C UB1,BV1,V1=OBSERVED, UB0,BV0,V0=DEREDDENED PARAMETER (NMOM1=500) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION TEP(NMOM1),GRAV(NMOM1),AB(NMOM1) P ,UB(NMOM1),BV(NMOM1),C1(NMOM1),C2(NMOM1),BY(NMOM1) P ,D(NMOM1),OMM(NMOM1),L(NMOM1) OPEN(8,FILE='PHOT.DAT',STATUS='OLD') READ(8,*) I=1 10 READ(8,*,END=30)TEP(I),GRAV(I),AB(I),UB(I),BV(I),C1(I),BY(I) I=I+1 GOTO 10 30 NMOM=I-1 CLOSE(8) C---------------U-B-V----- C UB1,BV1 OBSERVED; UB0,BV0 -DEREDDENED C UB2,BV2,EBV2 -DEREDDENED OUTPUT FROM HEINTZE IF(ABS(BV1-1.E6).GT.1.E-10.OR.ABS(UB1-1.E6).GT.1.E-10.OR. P ABS(BV0-1.E6).GT.1.E-10.OR.ABS(UB0-1.E6).GT.1.E-10)THEN WRITE(*,*) WRITE(9,*) WRITE(*,'(10X,A10)')' U B V : ' WRITE(9,'(10X,A10)')' U B V : ' UB2=1.E6 BV2=1.E6 EBV2=1.E6 IF(ABS(EBV1-1.E6).LT.1.E-10.AND.ABS(UB0-1.E6).LT.1.E-10.AND. P ABS(BV0-1.E6).LT.1.E-10.AND.ABS(UB1-1.E6).GT.1.E-10.AND. P ABS(BV1-1.E6).GT.1.E-10) THEN CALL HEINTZE(UB1,BV1,EBV2,UB2,BV2) ENDIF ENDIF C IF(ABS(BV0-1.E6).GT.1.E-10.AND.ABS(UB0-1.E6).GT.1.E-10)THEN CALL HYLAND(UB0,BV0) CALL SCHILD(UB0,BV0) PAUSE GOTO 40 ENDIF IF(ABS(BV1-1.E6).GT.1.E-10.AND.ABS(UB1-1.E6).GT.1.E-10)THEN CALL HYLAND(UB1,BV1) CALL SCHILD(UB1,BV1) PAUSE ENDIF C 40 IF(ABS(BV1-1.E6).GT.1.E-10.OR.ABS(BV0-1.E6).GT.1.E-10)THEN IF(ABS(BV0-1.E6).GT.1.E-10) THEN CALL UNDERHILL(BV0) ELSE IF(ABS(BV2-1.E6).GT.1.E-10) CALL UNDERHILL(BV2) IF(ABS(BV1-1.E6).GT.1.E-10) CALL UNDERHILL(BV1) ENDIF PAUSE ENDIF C HAUCK & KUNZLI 1995 IF(ABS(BV1-1.E6).GT.1.E-10.OR.ABS(BV0-1.E6).GT.1.E-10)THEN IF(ABS(BV0-1.E6).GT.1.E-10) THEN CALL HAKUN(BV0) ELSE IF(ABS(BV2-1.E6).GT.1.E-10) CALL HAKUN(BV2) IF(ABS(BV1-1.E6).GT.1.E-10) CALL HAKUN(BV1) ENDIF PAUSE ENDIF C IF(ABS(BV1-1.E6).GT.1.E-10.OR.ABS(BV0-1.E6).GT.1.E-10)THEN IF(ABS(BV0-1.E6).GT.1.E-10) THEN CALL NAPI3(BV0) ELSE IF(ABS(BV2-1.E6).GT.1.E-10) CALL NAPI3(BV2) IF(ABS(BV1-1.E6).GT.1.E-10) CALL NAPI3(BV1) ENDIF PAUSE ENDIF C IF(ABS(UB1-1.E6).GT.1.E-10.OR.ABS(UB0-1.E6).GT.1.E-10)THEN IF(ABS(UB0-1.E6).GT.1.E-10) THEN CALL HHSA(UB0) ELSE IF(ABS(UB2-1.E6).GT.1.E-10) CALL HHSA(UB2) IF(ABS(UB1-1.E6).GT.1.E-10) CALL HHSA(UB1) ENDIF PAUSE ENDIF C IF(ABS(BV1-1.E6).GT.1.E-10)BV3=BV1 IF(ABS(BV2-1.E6).GT.1.E-10)BV3=BV2 IF(ABS(BV0-1.E6).GT.1.E-10)BV3=BV0 IF(ABS(BV1-1.E6).GT.1.E-10.OR.ABS(BV0-1.E6).GT.1.E-10)THEN DO 250 I=1,NMOM D(I)=ABS(BV(I)-BV3) IF(ABS(D(I)-0.).LT.1.E-4) D(I)=0.0001 250 CONTINUE WRITE(*,*) WRITE(9,*) WRITE(*,'(5X,A20,F6.3)')' considering (B-V)o=',BV3 WRITE(9,'(5X,A20,F6.3)')' considering (B-V)o=',BV3 WRITE(*,*) WRITE(*,'(A,$)')' HOW MANY BEST MODELS TO FIT IT => ' READ(5,*)IVOL WRITE(*,*) IF (NMOM.LE.IVOL) IVOL=NMOM CALL ZORAD(D,OMM,L,NMOM,IVOL,NMOM1) WRITE(*,*)' chosen from Kurucz models to fit (B-V)o' WRITE(9,*)' chosen from Kurucz models to fit (B-V)o' DO 300 J=1,IVOL WRITE(*,310)L(J),TEP(L(J)),GRAV(L(J)),AB(L(J)),BV(L(J)) P ,UB(L(J)),OMM(J) WRITE(9,310)L(J),TEP(L(J)),GRAV(L(J)),AB(L(J)),BV(L(J)) P ,UB(L(J)),OMM(J) 300 CONTINUE PAUSE 310 FORMAT(' PC:',I2,' T=',F6.0,' LOG G=',F4.2,' LOG A=',F4.2, P ' B-V=',F6.3,' U-B=',F6.3,' DEV.:',F6.3) ENDIF C---------------u-v-b-y-beta---- IF(ABS(EBY1-1.E6).LT.1.E-10.AND.ABS(SUB-1.E6).GT.1.E-10.AND. P ABS(SBY-1.E6).GT.1.E-10.AND.SBY.LT.0.0)THEN EBY=(13.608*SBY-SUB+1.467)/(13.608-1.53) C CASTELLI 1991 AA,251,106-116 for B stars only ELSE IF(ABS(EBY1-1.E6).LT.1.E-10)THEN EBY=0.D0 ELSE EBY=EBY1 ENDIF ENDIF C Philip et al. (1976) C SC0=SC1-0.25*EBY C SM0=SM1+0.32*EBY C SUB0=SUB-1.61*EBY C SBY0=SBY-EBY C SC0=SC1-0.19*EBY SM0=SM1+0.33*EBY SUB0=SUB-1.53*EBY SBY0=SBY-EBY C CASTELLI 1991 AA,251,106-116 WRITE(*,*) WRITE(9,*) WRITE(*,*)' u v b y : ' WRITE(9,*)' u v b y : ' WRITE(*,*) WRITE(9,*) CALL SM(SBY0,SBY,SM0,SC0,SC1,BETA) IF(ABS(SBY-1.E6).GT.1.E-10)THEN CALL NAPI4(SBY0) CALL HAKUN2(SBY0) ENDIF IF(ABS(SC1-1.E6).GT.1.E-10)THEN IF(ABS(BETA-1.E6).GT.1.E-10.OR.ABS(WGAMA-1.E6).GT.1.E-10)THEN CALL BALONA(BETA,WGAMA,SC0) CALL CASTEL(SC0,BETA) ENDIF IF(ABS(SBY-1.E6).GT.1.E-10)THEN CALL NAPI2(SC1,SBY) ENDIF ENDIF IF(ABS(SUB-1.E6).GT.1.E-10.AND.ABS(SBY-1.E6).GT.1.E-10)THEN CALL NAPI1(SUB,SBY) ENDIF WRITE(*,*) WRITE(9,*) WRITE(*,'(10X,A41)')' u v b y : CORRECTED FOR REDDENING' WRITE(*,'(10X,2(A9,F6.3),2(A6,F6.3),A9,F6.3)') P ' (u-b)o=',SUB0,' (b-y)o=',SBY0,' C0=',SC0,' M0=',SM0, P ' E(b-y)=',EBY WRITE(9,'(10X,A41)')' u v b y : CORRECTED FOR REDDENING' WRITE(9,'(10X,2(A9,F6.3),2(A6,F6.3),A9,F6.3)') P ' (u-b)o=',SUB0,' (b-y)o=',SBY0,' C0=',SC0,' M0=',SM0, P ' E(b-y)=',EBY IF(ABS(SC1-1.E6).GT.1.E-10)THEN DO 350 I=1,NMOM D(I)=ABS(C1(I)-SC0) IF(ABS(D(I)-0.).LT.1.E-4) D(I)=0.0001 350 CONTINUE WRITE(*,*) WRITE(*,'(A,$)')' HOW MANY BEST MODELS TO FIT IT => ' READ(5,*)IVOL WRITE(*,*) IF (NMOM.LE.IVOL) IVOL=NMOM CALL ZORAD(D,OMM,L,NMOM,IVOL,NMOM1) WRITE(*,*)' chosen from Kurucz models to fit C0' WRITE(9,*)' chosen from Kurucz models to fit C0' DO 400 J=1,IVOL WRITE(*,410)L(J),TEP(L(J)),GRAV(L(J)),AB(L(J)),C1(L(J)) P ,OMM(J) WRITE(9,410)L(J),TEP(L(J)),GRAV(L(J)),AB(L(J)),C1(L(J)) P ,OMM(J) 400 CONTINUE PAUSE 410 FORMAT(' PC:',I2,' T=',F6.0,' LOG G=',F4.2,' LOG A=',F4.2, P ' C0=',F6.3,' DEV.:',F6.3) ENDIF IF(ABS(SC1-1.E6).GT.1.E-10.AND.ABS(SBY-1.E6).GT.1.E-10)THEN C Philip et al. (1976) SC2=SC1-0.20*SBY SM2=SM1+0.18*SBY WRITE(*,*) WRITE(9,*) WRITE(*,'(10X,A41)')' u v b y : [c1] reddening independent' WRITE(*,'(10X,2(A6,F6.3))') P ' [c1]=',SC2,' [m1]=',SM2 WRITE(9,'(10X,A41)')' u v b y : [c1] reddening independent' WRITE(9,'(10X,2(A6,F6.3))') P ' [c1]=',SC2,' [m1]=',SM2 DO 450 I=1,NMOM C2(I)=C1(I)-0.20*BY(I) D(I)=ABS(C2(I)-SC2) IF(ABS(D(I)-0.).LT.1.E-4) D(I)=0.0001 450 CONTINUE WRITE(*,*) WRITE(*,'(A,$)')' HOW MANY BEST MODELS TO FIT IT => ' READ(5,*)IVOL WRITE(*,*) IF (NMOM.LE.IVOL) IVOL=NMOM CALL ZORAD(D,OMM,L,NMOM,IVOL,NMOM1) WRITE(*,*)' chosen from Kurucz models to fit [c1]' WRITE(9,*)' chosen from Kurucz models to fit [c1]' DO 460 J=1,IVOL WRITE(*,470)L(J),TEP(L(J)),GRAV(L(J)),AB(L(J)),C2(L(J)) P ,OMM(J) WRITE(9,470)L(J),TEP(L(J)),GRAV(L(J)),AB(L(J)),C2(L(J)) P ,OMM(J) 460 CONTINUE PAUSE 470 FORMAT(' PC:',I2,' T=',F6.0,' LOG G=',F4.2,' LOG A=',F4.2, P ' [c1]=',F6.3,' DEV.:',F6.3) ENDIF C---------------U-V-B1-B2-V1-G----- IF((ABS(GB2-1.E6).GT.1.E-10.AND.ABS(GV1-1.E6).GT.1.E-10).OR. P (ABS(GB2-1.E6).GT.1.E-10.AND.ABS(GG-1.E6).GT.1.E-10))THEN WRITE(*,*) WRITE(9,*) WRITE(*,'(10X,A41)')' GENEVA PHOTOMETRY : ' WRITE(9,'(10X,A41)')' GENEVA PHOTOMETRY : ' CALL HAUCK(GB2,GV1,GG) CALL HAKUN3(GB2,GV1,GG) ENDIF IF(ABS(GU-1.E6).GT.1.E-10.AND.ABS(GV-1.E6).GT.1.E-10.AND. P ABS(GB1-1.E6).GT.1.E-10.AND.ABS(GB2-1.E6).GT.1.E-10.AND. P ABS(GV1-1.E6).GT.1.E-10.AND.ABS(GG-1.E6).GT.1.E-10)THEN CALL CRAMER(GU,GV,GB1,GB2,GV1,GG) CALL MEGESS(GU,GV,GB1,GB2,GV1,GG) CALL NORTH(GU,GV,GB1,GB2,GV1,GG) CALL KOBI(GU,GV,GB1,GB2,GV1,GG) ENDIF RETURN END C----------------------------------------------------------------------- c SUBROUTINE HYLAND(UB0,BV0) c IMPLICIT DOUBLE PRECISION(A-H,O-Z) c WRITE(*,*) c WRITE(9,*) c WRITE(*,*)' Hylandov vztah from Qeff-Q ?' c WRITE(9,*)' Hylandov vztah from Qeff-Q ?' c Q=UB0-0.645*BV0 c QEFF=0.406*Q+0.51 c TEFF=5040./QEFF c WRITE(*,'(10X,A6,F7.0)')' Teff=',TEFF c WRITE(9,'(10X,A6,F7.0)')' Teff=',TEFF c RETURN c END C----------------------------------------------------------------------- SUBROUTINE HEINTZE(UB1,BV1,EBV,UB0,BV0) IMPLICIT DOUBLE PRECISION(A-H,O-Z) Q=UB1-0.645*BV1 BV2=0.277*Q-0.045 IF(BV2.LT.-0.32.OR.BV2.GT.-0.05)RETURN BV0=BV2 EBV=BV1-BV0 UB0=4.246*BV0+0.161 WRITE(*,*) WRITE(9,*) WRITE(*,'(A38,A23)')' Heintze J.R.W., 1973, in Problems of ', P'calibration of absolute' WRITE(*,*)' magnitudes and temperatures of stars, ' WRITE(*,*)' eds. Hauck B., Westelund B.E., IAU, p.231' WRITE(*,*)' from reddening indep. Q for B1V-A0V' WRITE(9,'(A38,A23)')' Heintze J.R.W., 1973, in Problems of ', P'calibration of absolute' WRITE(9,*)' magnitudes and temperatures of stars, ' WRITE(9,*)' eds. Hauck B., Westelund B.E., IAU, p.231' WRITE(9,*)' from reddening indep. Q for B1V-A0V' WRITE(*,'(10X,3(A8,F6.3))')' (U-B)o=',UB0,' (B-V)o=',BV0, P' E(B-V)=',EBV WRITE(9,'(10X,3(A8,F6.3))')' (U-B)o=',UB0,' (B-V)o=',BV0, P' E(B-V)=',EBV RETURN END C----------------------------------------------------------------------- SUBROUTINE HYLAND(UB1,BV1) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION Q0(12),QEFF0(12) DATA Q0/0.0,-0.078,-0.148,-0.235,-0.334,-0.389,-0.445,-0.566 P,-0.687,-0.743,-0.808,-0.864/ DATA QEFF0/0.520,0.485,0.455,0.417,0.375,0.350,0.330,0.290 P,0.246,0.225,0.197,0.175/ Q=UB1-0.72*BV1 IF(Q.LT.-0.864.OR.Q.GT.0.0)RETURN CALL INTEP(Q,QEFF,Q0,QEFF0,12,IER) TEFF=5040./QEFF WRITE(*,*) WRITE(9,*) WRITE(*,*)' Hyland A.R., 1969, in Theory and Observations of Nor pmal Stellar Atmospheres' WRITE(*,*)' p.271, The M.I.T. Press' WRITE(*,*)' from redd. indep. Qeff-Q relation for B stars' WRITE(9,*)' Hyland A.R., 1969, in Theory and Observations of Nor pmal Stellar Atmospheres' WRITE(9,*)' p.271, The M.I.T. Press' WRITE(9,*)' from redd. indep. Qeff-Q relation for B stars' WRITE(*,'(10X,A6,F7.0,5X,A6,F6.3)')' Teff=',TEFF,'for Q=',Q WRITE(9,'(10X,A6,F7.0,5X,A6,F6.3)')' Teff=',TEFF,'for Q=',Q RETURN END C----------------------------------------------------------------------- SUBROUTINE SCHILD(UB,BV) C IT DOES NOT MATTER WEATHER UB, BV OR UB0, BV0 IMPLICIT DOUBLE PRECISION(A-H,O-Z) WRITE(*,*) WRITE(9,*) WRITE(*,*)' Schild, R., Peterson, D., M., Oke, J., B., 1971,', P ' ApJ 166, 95' WRITE(*,*)' from Qeff-Q (red. indep. param.) for (B-V)<0' WRITE(9,*)' Schild, R., Peterson, D., M., Oke, J., B., 1971,', P ' ApJ 166, 95' WRITE(9,*)' from Qeff-Q (red. indep. param.) for (B-V)<0' Q=UB-0.72*BV IF(Q.LT.-0.1)THEN QEFF=0.378*Q+0.500 ELSE QEFF=0.625*Q+0.525 ENDIF TEFF=5040./QEFF WRITE(*,'(10X,A6,F7.0,5X,A6,F6.3)')' Teff=',TEFF,'for Q=',Q WRITE(9,'(10X,A6,F7.0,5X,A6,F6.3)')' Teff=',TEFF,'for Q=',Q RETURN END C----------------------------------------------------------------------- SUBROUTINE UNDERHILL(BV0) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION BV00(14),TEFF0(14) c CHARACTER*4 SP(14) DATA BV00/-0.30,-0.28,-0.26,-0.25,-0.24,-0.22,-0.20,-0.18,-0.16, P-0.14,-0.13,-0.10,-0.07,-0.04/ DATA TEFF0/3.078,2.927,2.690,2.572,2.282,2.038,1.853,1.634,1.517 P,1.374,1.298,1.190,1.092,1.020/ c DATA SP/'B0 ','B0.5','B1 ','B1.5','B2 ','B2.5','B3 ','B4 ', c P'B5 ','B6 ','B7 ','B8 ','B9 ','B9.5'/ IF(BV0.LT.-0.30.OR.BV0.GT.-0.04)RETURN WRITE(*,*) WRITE(9,*) WRITE(*,*)' Underhill A., Doazan V., 1982, "B stars with and wit Phout emision lines, NASA' WRITE(*,*)' using intrinsic colors (B-V)o from FitzGerald(1970)' WRITE(*,*)' just for BIV-V stars' WRITE(9,*)' Underhill A., Doazan V., 1982, "B stars with and wit Phout emision lines, NASA' WRITE(9,*)' using intrinsic colors (B-V)o from FitzGerald(1970)' WRITE(9,*)' just for BIV-V stars' CALL INTEP(BV0,TEFF,BV00,TEFF0,14,IER) TEFF=TEFF*1.D4 WRITE(*,'(10X,A6,F7.0,5X,A11,F6.3)')' Teff=',TEFF,'for (B-V)o=' P,BV0 WRITE(9,'(10X,A6,F7.0,5X,A11,F6.3)')' Teff=',TEFF,'for (B-V)o=' P,BV0 RETURN END C----------------------------------------------------------------------- SUBROUTINE HHSA(UB0) IMPLICIT DOUBLE PRECISION(A-H,O-Z) WRITE(*,*) WRITE(9,*) WRITE(*,'(A38,A23)')' Heintze J.R.W., 1973, in Problems of ', P'calibration of absolute' WRITE(*,*)' magnitudes and temperatures of stars, ' WRITE(*,*)' eds. Hauck B., Westelund B.E., IAU, p.231' WRITE(*,*)' from reddening indep. Q for B1V-A0V' WRITE(*,*)' calibrated results of different authors on (U-B)o' WRITE(9,'(A38,A23)')' Heintze J.R.W., 1973, in Problems of ', P'calibration of absolute' WRITE(9,*)' magnitudes and temperatures of stars, ' WRITE(9,*)' eds. Hauck B., Westelund B.E., IAU, p.231' WRITE(9,*)' from reddening indep. Q for B1V-A0V' WRITE(9,*)' calibrated results of different authors on (U-B)o' QEFF=0.3145*UB0+0.513 TEFF=5040./QEFF WRITE(*,'(10X,A18,A6,F7.0)')' from Hyland(1969)',' Teff=',TEFF WRITE(9,'(10X,A18,A6,F7.0)')' from Hyland(1969)',' Teff=',TEFF QEFF=0.306*UB0+0.507 TEFF=5040./QEFF WRITE(*,'(10X,A19,A6,F7.0)')' from Heintze(1969)',' Teff=',TEFF WRITE(9,'(10X,A19,A6,F7.0)')' from Heintze(1969)',' Teff=',TEFF QEFF=0.3045*UB0+0.502 TEFF=5040./QEFF WRITE(*,'(10X,A31,A26,F7.0)')' from Auer & Mihalas(1972) and ', p'Schild et.al(1971) Teff=',TEFF WRITE(9,'(10X,A31,A26,F7.0)')' from Auer & Mihalas(1972) and ', p'Schild et.al(1971) Teff=',TEFF WRITE(*,'(A15,F6.3)')' all for (U-B)o=',UB0 WRITE(9,'(A15,F6.3)')' all for (U-B)o=',UB0 RETURN END C----------------------------------------------------------------------- SUBROUTINE HAUCK(GB2,GV1,GG) IMPLICIT DOUBLE PRECISION(A-H,O-Z) WRITE(*,*) WRITE(9,*) WRITE(*,*)' Hauck, B., North, P., 1982, AA 114, 23', P ' for normal B and A stars' WRITE(9,*)' Hauck, B., North, P., 1982, AA 114, 23', P ' for normal B and A stars' IF(ABS(GB2-1.E6).GT.1.E-10.AND.ABS(GV1-1.E6).GT.1.E-10)THEN B2V1=GB2-GV1 IF((GB2-GV1).GT.-0.172)THEN TEFF=5040./(0.635*B2V1+0.634) WRITE(*,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-V1=' P ,B2V1 WRITE(9,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-V1=' P ,B2V1 ENDIF IF((GB2-GV1).LT.-0.138)THEN TEFF=5040./(1.8*B2V1+0.798) WRITE(*,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-V1=' P ,B2V1 WRITE(9,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-V1=' P ,B2V1 ENDIF ENDIF IF(ABS(GB2-1.E6).GT.1.E-10.AND.ABS(GG-1.E6).GT.1.E-10)THEN B2G=GB2-GG IF((GB2-GG).GT.-0.677)THEN TEFF=5040./(0.458*B2G+0.835) WRITE(*,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-G=' P ,B2G WRITE(9,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-G=' P ,B2G ENDIF IF((GB2-GG).LT.-0.632)THEN TEFF=5040./(1.362*B2G+1.411) WRITE(*,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-G=' P ,B2G WRITE(9,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-G=' P ,B2G ENDIF ENDIF RETURN END C----------------------------------------------------------------------- SUBROUTINE HAKUN3(GB2,GV1,GG) IMPLICIT DOUBLE PRECISION(A-H,O-Z) WRITE(*,*) WRITE(9,*) WRITE(*,*)' Hauck B., Kunzli M., 1995, preprint' WRITE(*,*)' for MS stars, B2-V1 < 0.65; B2-G < 0.5' WRITE(9,*)' Hauck B., Kunzli M., 1995, preprint' WRITE(9,*)' for MS stars, B2-V1 < 0.65; B2-G < 0.5' IF(ABS(GB2-1.E6).GT.1.E-10.AND.ABS(GV1-1.E6).GT.1.E-10)THEN B2V1=GB2-GV1 IF((GB2-GV1).LT.-0.16)THEN TEFF=5040./(2.245*B2V1+0.902) WRITE(*,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-V1=' P ,B2V1 WRITE(9,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-V1=' P ,B2V1 ENDIF IF((GB2-GV1).GE.-0.16.AND.GB2-GV1.LE.0.65)THEN TEFF=5040./(0.629*B2V1+0.635) WRITE(*,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-V1=' P ,B2V1 WRITE(9,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-V1=' P ,B2V1 ENDIF ENDIF IF(ABS(GB2-1.E6).GT.1.E-10.AND.ABS(GG-1.E6).GT.1.E-10)THEN B2G=GB2-GG IF((GB2-GG).LT.-0.66)THEN TEFF=5040./(1.597*B2G+1.586) WRITE(*,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-G=' P ,B2G WRITE(9,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-G=' P ,B2G ENDIF IF((GB2-GG).GE.-0.66.AND.GB2-GG.LE.0.5)THEN TEFF=5040./(0.455*B2G+0.832) WRITE(*,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-G=' P ,B2G WRITE(9,'(10X,A6,F7.0,A12,F6.3)')' Teff=',TEFF,' B2-G=' P ,B2G ENDIF ENDIF RETURN END C----------------------------------------------------------------------- SUBROUTINE CRAMER(U,V,B1,B2,V1,G) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION XI(19),BCI(19),X0I(15),A0I(15),A1I(15),A2I(15) DATA X0I/0.4,0.5,0.6,0.7,0.8,0.9,1.0,1.1,1.2,1.3,1.4,1.5,1.6, P 1.7,1.8/ DATA A0I/-2.16,-1.65,-1.26,-0.94,-0.66,-0.40,-0.13,0.15,0.43, P 0.69,0.92,1.06,1.07,0.89,0.45/ DATA A1I/-19.24,-16.62,-13.88,-11.31,-9.11,-7.40,-6.25,-5.63, P -5.44,-5.50,-5.56,-5.30,-4.31,-2.10,1.87/ DATA A2I/-424.34,-347.14,-327.90,-285.62,-247.29,-212.92, P -182.51,-156.05,-133.55,-115.01,-100.43,-89.80,-83.13,-80.42, P -81.67/ DATA XI/-0.076,-0.020,0.042,0.110,0.185,0.269,0.364,0.473, P 0.600,0.752,0.840,0.940,1.054,1.188,1.349,1.552,1.678,1.836, P 2.044/ DATA BCI/-3.21,-3.06,-2.91,-2.75,-2.58,-2.41,-2.23,-2.02,-1.80, P -1.52,-1.35,-1.14,-0.90,-0.68,-0.48,-0.28,-0.18,-0.08,-0.02/ X=0.3788+1.3764*U-1.2162*B1-0.8498*B2-0.1554*V1+0.8450*G Y=-0.8288+0.3235*U-2.3228*B1+2.3363*B2+0.7495*V1-1.0865*G IF(X.GT.-0.076.AND.X.LT.2.044)THEN TEFF=10**(4.496-0.453*X+0.086*X*X) CALL INTEP(X,BC,XI,BCI,19,IER) ELSE RETURN ENDIF BETA=2.568+0.190*X-0.487*Y IF(X.GT.0.4.AND.X.LT.1.8.AND.Y.GT.-0.06)THEN CALL INTEP(X,A0,X0I,A0I,15,IER) CALL INTEP(X,A1,X0I,A1I,15,IER) CALL INTEP(X,A2,X0I,A2I,15,IER) AMV=A0+A1*Y+A2*Y*Y ELSE AMV=1.E6 ENDIF WRITE(*,*) WRITE(9,*) WRITE(*,*)' Cramer, N., Maeder, A., 1979, AA 78, 305' WRITE(*,*)' for B-type stars, from Geneva. phot.: redd.inde Pp. X-calib.' WRITE(9,*)' Cramer, N., Maeder, A., 1979, AA 78, 305' WRITE(9,*)' for B-type stars, from Geneva. phot.: redd.inde Pp. X-calib.' WRITE(*,'(10X,A6,F7.0,2(A5,F7.3),A7,F5.3)')' Teff=',TEFF, P ' Mv=',AMV,' BC=',BC,' BETA=',BETA WRITE(9,'(10X,A6,F7.0,2(A5,F7.3),A7,F5.3)')' Teff=',TEFF, P ' Mv=',AMV,' BC=',BC,' BETA=',BETA RETURN END C----------------------------------------------------------------------- SUBROUTINE MEGESS(U,V,B1,B2,V1,G) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION XM(5),TM(5) DATA XM/1.55,1.33,1.15,0.96,0.78/ DATA TM/10100.,11325.,12570.,14000.,15450./ X=0.3788+1.3764*U-1.2162*B1-0.8498*B2-0.1554*V1+0.8450*G IF(X.GT.0.529.AND.X.LT.1.55)THEN WRITE(*,*) WRITE(9,*) WRITE(*,*)' Megessier C., 1988, AA 206, 74' WRITE(9,*)' Megessier C., 1988, AA 206, 74' WRITE(*,*)' from Geneva phot., X-calib.' WRITE(9,*)' from Geneva phot., X-calib.' ENDIF IF(X.GT.0.78.AND.X.LT.1.55)THEN CALL INTEP(X,TEFF,XM,TM,5,IER) WRITE(*,'(10X,A6,F7.0,A17)')' Teff=',TEFF,' for norm. stars' WRITE(9,'(10X,A6,F7.0,A17)')' Teff=',TEFF,' for norm. stars' ENDIF IF(X.GT.0.529.AND.X.LT.1.429)THEN TEFF=10**(4.3373-0.2516*X) WRITE(*,'(10X,A6,F7.0,A15)')' Teff=',TEFF,' for CP2 stars' WRITE(9,'(10X,A6,F7.0,A15)')' Teff=',TEFF,' for CP2 stars' ENDIF RETURN END C----------------------------------------------------------------------- SUBROUTINE NORTH(U,V,B1,B2,V1,G) PARAMETER (NX=13,NY=22) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION XI(NY),YI(NX),Q(NY,NX),GLOG(NY,NX) DATA XI/0.0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0, P 1.1,1.2,1.3,1.4,1.5,1.6,1.7,1.8,1.9,2.0,2.1/ DATA YI/-0.050,-0.025,0.0,0.025,0.050,0.075,0.1,0.125,0.15, P 0.175,0.2,0.225,0.25/ X=0.3788+1.3764*U-1.2162*B1-0.8498*B2-0.1554*V1+0.8450*G Y=-0.8288+0.3235*U-2.3228*B1+2.3363*B2+0.7495*V1-1.0865*G WRITE(*,*) WRITE(9,*) WRITE(*,*)' North, P., Nicolet, B., 1990, AA 228, 78' WRITE(*,*)' for B stars, from X-Y plane' WRITE(9,*)' North, P., Nicolet, B., 1990, AA 228, 78' WRITE(9,*)' for B stars, from X-Y plane' WRITE(*,'(10X,2(A5,F6.3))')' X=',X,' Y=',Y WRITE(9,'(10X,2(A5,F6.3))')' X=',X,' Y=',Y IF(X.LT.0.0.OR.X.GT.2.1.OR.Y.LT.-0.05.OR.Y.GT.0.25)THEN RETURN ENDIF OPEN(8,FILE='NORTH.DAT',STATUS='OLD') DO 10,I=1,NY READ(8,*)(Q(I,J),J=1,NX) READ(8,*)(GLOG(I,J),J=1,NX) 10 CONTINUE CLOSE(8) DO 20,I=1,NY IF(X.LT.XI(I))THEN KKX=I-1 GOTO 25 ENDIF 20 CONTINUE 25 DO 30,I=1,NX IF(Y.LT.YI(I))THEN KKY=I-1 GOTO 35 ENDIF 30 CONTINUE 35 IF(ABS(Q(KKX,KKY)-0.0).LT.1.E-10.OR. P ABS(Q(KKX+1,KKY)-0.0).LT.1.E-10.OR. P ABS(Q(KKX,KKY+1)-0.0).LT.1.E-10.OR. P ABS(Q(KKX,KKY+1)-0.0).LT.1.E-10)THEN RETURN ENDIF POMQ1=(Y-YI(KKY))*(Q(KKX,KKY+1)-Q(KKX,KKY))/(YI(KKY+1)-YI(KKY)) P +Q(KKX,KKY) POMQ2=(Y-YI(KKY))*(Q(KKX+1,KKY+1)-Q(KKX+1,KKY)) P /(YI(KKY+1)-YI(KKY))+Q(KKX+1,KKY) TEFF=5040./((X-XI(KKX))*(POMQ2-POMQ1)/(XI(KKX+1)-XI(KKX))+POMQ1) POMG1=(Y-YI(KKY))*(GLOG(KKX,KKY+1)-GLOG(KKX,KKY))/ P (YI(KKY+1)-YI(KKY))+GLOG(KKX,KKY) POMG2=(Y-YI(KKY))*(GLOG(KKX+1,KKY+1)-GLOG(KKX+1,KKY))/ P (YI(KKY+1)-YI(KKY))+GLOG(KKX+1,KKY) GRAV=(X-XI(KKX))*(POMG2-POMG1)/(XI(KKX+1)-XI(KKX))+POMG1 WRITE(*,'(10X,A6,F7.0,A8,F4.2,A23)')' Teff=',TEFF,' log g=', P GRAV,' for solar metallicity' WRITE(9,'(10X,A6,F7.0,A8,F4.2,A23)')' Teff=',TEFF,' log g=', P GRAV,' for solar metallicity' RETURN END C----------------------------------------------------------------------- SUBROUTINE KOBI(U,V,B1,B2,V1,G) IMPLICIT DOUBLE PRECISION(A-H,O-Z) D=(U-B1)-1.430*(B1-B2) GM2=(B1-B2)-0.457*(B2-V1) WRITE(*,*) WRITE(9,*) WRITE(*,*)' Kobi D., North, P., 1990, AASS 85, 999' WRITE(*,*)' for A4-G5 stars' WRITE(9,*)' Kobi D., North, P., 1990, AASS 85, 999' WRITE(9,*)' for A4-G5 stars' WRITE(*,'(10X,2(A5,F6.3))')' d=',D,' m2=',GM2 WRITE(9,'(10X,2(A5,F6.3))')' d=',D,' m2=',GM2 RETURN END C----------------------------------------------------------------------- SUBROUTINE BALONA(BETA1,WGAMA,C00) IMPLICIT DOUBLE PRECISION(A-H,O-Z) WRITE(*,*) WRITE(9,*) WRITE(*,*)' Balona, L., A., 1984, Mon. Not. R. astr. Soc.,', P '211, 973' WRITE(*,*)' for early-type stars from beta and c0' WRITE(9,*)' Balona, L., A., 1984, Mon. Not. R. astr. Soc.,', P '211, 973' WRITE(9,*)' for early-type stars from beta and c0' IF(ABS(BETA1-1.E6).LT.1.E-10)THEN BETA=0.02565*WGAMA+2.5123 WRITE(*,'(A7,F5.3)')' BETA=',BETA WRITE(9,'(A7,F5.3)')' BETA=',BETA ELSE BETA=BETA1 ENDIF BET=ALOG10(BETA-2.500) C00T=ALOG10(C00+0.200) TEFF=10**(3.9036-0.4816*C00T-0.5290*BET- P 0.1260*C00T*C00T+0.0924*BET*C00T-0.4013*BET*BET) C FROM KURUCZ MODELS AND BETA-WGAMA(KURUCZ-LTE) CALIB. GRAV=5.9046-3.2262*C00T+4.0883*BET-0.5383*C00T*C00T- P 0.2774*BET*C00T-0.0007*BET*BET EG=ALOG10(BETA-2.515)-1.60*ALOG10(C00+0.322) AMV=3.499+7.203*ALOG10(BETA-2.515)-2.319*EG+2.938*EG*EG*EG BC=0.2900+2.8467*C00T+2.8334*BET+0.6481*C00T*C00T P -0.2997*BET*C00T+2.1487*BET*BET WRITE(*,'(10X,A6,F7.0,A8,F4.2,2(A5,F7.3))')' Teff=',TEFF, P ' log g=',GRAV,' Mv=',AMV,' BC=',BC WRITE(9,'(10X,A6,F7.0,A8,F4.2,2(A5,F7.3))')' Teff=',TEFF, P ' log g=',GRAV,' Mv=',AMV,' BC=',BC RETURN END C----------------------------------------------------------------------- SUBROUTINE CASTEL(C0,BETA) IMPLICIT DOUBLE PRECISION(A-H,O-Z) DIMENSION P(10,2),Q(7,2) DATA Q/9.372853735692513,0.1388984909726595,-0.3772751850721322, P -3.441202247069613,-1.2919132663971867E-2,0.1563028804655211, P 0.5329196601502442,41.12891680060272,0.3074969330177897, P 0.1249648644440178,-25.75280684590345,-1.8620519285948986E-2, P -0.1306123353098876,4.340621513119619/ DATA P/-34699.13571279180,-9.389628024837989,-14.85477894733068, P 49675.89762128829,17.42254584910010,-26659.84653847129, P -14.25166444541836,6364.673937260428,4.924571477326692, P -570.2261422955868,-102313.9917581691,-4.047990456431145, P -8.706895982165089,150275.8361010616,17.53795434313011, P -82781.98328595359,-44.19718767241700,20273.39016383133, P 44.95052473400207,-1862.257533577166/ WRITE(*,*) WRITE(*,*)' Castelli, F., 1991, AA 251, 106 from C0,BETA', P ' for B-stars' 5 WRITE(*,'(A,$)')' Teff initial ><15000 (TO SKIP -0-) => ' READ(*,*)TEFF IF(DABS(TEFF-0.).LT.1.E-30)GOTO 20 WRITE(9,*) WRITE(9,*)' Castelli, F., 1991, AA 251, 106 from C0,BETA', P ' for B-stars' WRITE(*,'(A,$)')' No. OF ITERATION => ' READ(*,*)N IF(TEFF.LT.15000)THEN J=1 ELSE J=2 ENDIF TEFFI=DLOG10(TEFF) DO 10 I=1,N GRAVI=P(1,J)+P(2,J)*TEFFI+P(3,J)*C0+P(4,J)*BETA+P(5,J)*C0*C0+ P P(6,J)*BETA*BETA+P(7,J)*C0*C0*C0+P(8,J)*BETA*BETA*BETA+ P P(9,J)*C0**4.+P(10,J)*BETA**4. TEFFI=Q(1,J)+Q(2,J)*GRAVI+Q(3,J)*C0+Q(4,J)*BETA+ P Q(5,J)*GRAVI*GRAVI+Q(6,J)*C0*C0+Q(7,J)*BETA*BETA WRITE(*,*)' TEFF, LOGG',TEFFI,GRAVI 10 CONTINUE WRITE(*,'(10X,A6,F7.0,A8,F4.2,A19,A10,F7.0)')' Teff=', P DEXP(TEFFI*2.302585D0), P ' log g=',GRAVI,' for 11000