PROGRAM REDDENING DIMENSION WAVE(1221) DIMENSION AMAGI(13,1221),REDI(13,1221),EBVI(13),AMAG(1221) DIMENSION EBVI2(13) CHARACTER*80 TITLE DATA EBVI/0.,.1,.2,.3,.4,.5,.6,.8,1.,2.,3.,4.,5./ DATA EBVI2/0.,.002,.005,.01,.02,.03,.04,.05,.06,.07,.08,.09,.1/ C C wavelength in nm READ(1,1)WAVE 1 FORMAT(8F10.2) DO 500 ICASE=1,2 IF(ICASE.EQ.2)THEN DO 303 IRED=1,13 303 EBVI(IRED)=EBVI2(IRED) ENDIF RV=3.1 EBV=.1 CALL MATHIS(WAVE,RV,EBV,AMAG) WRITE(7,345) 345 FORMAT(' MAGNITUDES INTERSTELLAR REDDENING VS', 1' E(B-V) AFTER MATHIS FOR RV=3.1 AT ATLAS9 FLUX WAVELENGTHS') WRITE(7,340)(EBVI(IRED),IRED=2,13) 340 FORMAT(15X,12F9.3) DO 366 NU=1,1221 DO 355 IRED=1,13 AMAGI(IRED,NU)=EBVI(IRED)/EBV*AMAG(NU) 355 REDI(IRED,NU)=10**(-AMAGI(IRED,NU)/2.5) WRITE(7,358)NU,WAVE(NU),(AMAGI(IRED,NU),IRED=2,13) 358 FORMAT(I5,F10.1,12F9.3) 366 CONTINUE WRITE(7,347) 347 FORMAT(' INTERSTELLAR TRANSMISSION VS E(B-V)', 1 ' AFTER MATHIS FOR RV=3.1 AT ATLAS9 FLUX WAVELENGTHS') WRITE(7,344)(EBVI(IRED),IRED=2,13) 344 FORMAT(12X,12F10.3) DO 367 NU=1,1217 WRITE(7,359)NU,WAVE(NU),(REDI(IRED,NU),IRED=2,13) 359 FORMAT(I5,F8.1,1P12E10.3) 367 CONTINUE DO 368 NU=1218,1221 WRITE(7,357)NU,WAVE(NU),(REDI(IRED,NU),IRED=2,13) 357 FORMAT(I5,F8.0,1P12E10.3) 368 CONTINUE 500 CONTINUE CALL EXIT END SUBROUTINE MATHIS(WAVE,RV,EBV,A) C BASED ON MEAN REDDENING GIVEN BY c Mathis, J.S. Ann. Rev. 28,37-70,1990 C WAVE IN NM DIMENSION A31(41),A50(41),W(41),WINV(41),AR(41),WNM(41) DIMENSION WAVE(1221),A(1221),WAVEINV(1221),AA(1221) DATA W/ 1 1000., 250., 100., 60., 35., 25., 20., 18., 15., 12., 2 10., 9.7, 9.0, 7., 5., 3.4, 2.2, 1.65, 1.25, .9, 3 .7, .55, .44, .365, .33, .28, .26, .24, .218, .2, 4 .18, .15, .13, .12, .091, .073, .041, .023, .004, .002,0./ DATA A31/ 1 .0001,.0015,.0041,.0071, .013, .048, .075, .083, .053, .098, 2 .192, .208, .157, .070, .095, .182, .382, .624, 1., 1.70, 3 2.66, 3.55, 4.70, 5.53, 5.87, 6.90, 7.63, 9.03,11.29,10.08, 4 8.93, 9.44,11.09,12.71, 17.2, 19.1, 9.15, 7.31, 3.39, 1.35,0./ DATA A50/ 1 .0001,.0015,.0041,.0071, .013, .048, .075, .083, .053, .098, 2 .192, .208, .157, .070, .095, .182, .382, .624, 1., 1.70, 3 2.43, 3.06, 3.67, 4.07, 4.12, 4.34, 4.59, 5.13, 6.03, 5.32, 4 4.66, 4.57, 4.89, 5.32, 7.20, 7.99, 3.83, 3.06, 1.42, .57,0./ DO 1 I=1,40 1 WINV(I)=1./W(I) WINV(41)=1000. DO 2 I=1,1221 2 WAVEINV(I)=1000./WAVE(1222-I) DO 11 I=1,41 11 AR(I)=A50(I)+(1./RV-1./5.0)/(1./3.1-1./5.0)*(A31(I)-A50(I)) C AR(22)=AV TABULATED AV MEASURED = R*E(B-V) SCALE=RV*EBV/AR(20) SCALE=RV*EBV/AR(22) DO 12 I=1,41 12 AR(I)=AR(I)*SCALE NN=MAP1(WINV,AR,41,WAVEINV,AA,1221) DO 13 I=1,1221 13 A(I)=AA(1222-I) RETURN END FUNCTION MAP1(XOLD,FOLD,NOLD,XNEW,FNEW,NNEW) DIMENSION XOLD(1),FOLD(1),XNEW(1),FNEW(1) L=2 LL=0 DO 50 K=1,NNEW 10 IF(XNEW(K).LT.XOLD(L))GO TO 20 L=L+1 IF(L.GT.NOLD)GO TO 30 GO TO 10 20 IF(L.EQ.LL)GO TO 50 IF(L.EQ.2)GO TO 30 IF(L.EQ.3)GO TO 30 L1=L-1 IF(L.GT.LL+1.OR.L.EQ.3)GO TO 21 IF(L.GT.LL+1.OR.L.EQ.4)GO TO 21 CBAC=CFOR BBAC=BFOR ABAC=AFOR IF(L.EQ.NOLD)GO TO 22 GO TO 25 21 L2=L-2 D=(FOLD(L1)-FOLD(L2))/(XOLD(L1)-XOLD(L2)) CBAC=FOLD(L)/((XOLD(L)-XOLD(L1))*(XOLD(L)-XOLD(L2)))+ 1(FOLD(L2)/(XOLD(L)-XOLD(L2))-FOLD(L1)/(XOLD(L)-XOLD(L1)))/ 2(XOLD(L1)-XOLD(L2)) BBAC=D-(XOLD(L1)+XOLD(L2))*CBAC ABAC=FOLD(L2)-XOLD(L2)*D+XOLD(L1)*XOLD(L2)*CBAC IF(L.LT.NOLD)GO TO 25 22 C=CBAC B=BBAC A=ABAC LL=L GO TO 50 25 D=(FOLD(L)-FOLD(L1))/(XOLD(L)-XOLD(L1)) CFOR=FOLD(L+1)/((XOLD(L+1)-XOLD(L))*(XOLD(L+1)-XOLD(L1)))+ 1(FOLD(L1)/(XOLD(L+1)-XOLD(L1))-FOLD(L)/(XOLD(L+1)-XOLD(L)))/ 2(XOLD(L)-XOLD(L1)) BFOR=D-(XOLD(L)+XOLD(L1))*CFOR AFOR=FOLD(L1)-XOLD(L1)*D+XOLD(L)*XOLD(L1)*CFOR WT=0. IF(ABS(CFOR).NE.0.)WT=ABS(CFOR)/(ABS(CFOR)+ABS(CBAC)) A=AFOR+WT*(ABAC-AFOR) B=BFOR+WT*(BBAC-BFOR) C=CFOR+WT*(CBAC-CFOR) LL=L GO TO 50 30 IF(L.EQ.LL)GO TO 50 L=MIN0(NOLD,L) C=0. B=(FOLD(L)-FOLD(L-1))/(XOLD(L)-XOLD(L-1)) A=FOLD(L)-XOLD(L)*B LL=L 50 FNEW(K)=A+(B+C*XNEW(K))*XNEW(K) MAP1=LL-1 RETURN END