SUBROUTINE COG(IVT,ABLG,TAULG,xl,yy,n1) IMPLICIT REAL*8 (A-H,O-Z) COMMON /CONTIN/CONTIN COMMON /CURVE/MINLOG,DABLOG,NABLOG REAL*8 MINLOG COMMON /GAM/GLOGR,GLOGS,GLOGW COMMON/LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,GAMMAR,GAMMAS,GAMMAW, *ELO,GF,X1,X2,REF,OTHER1(3),OTHER2(3),LABEL(3),LABELP(3),NELION, 1 NBLO,NBUP,ISO1,ISO2 REAL*8 WL,E,EP COMMON /OBS/EW,WLOBS,STAR(19) COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15) COMMON /TAUBAR/TAUBAR COMMON /VTS/VTS(10),NVT DIMENSION ABLOG(9),EWLOG(9),TAULOG(9) DIMENSION RESID0(9) character*6 idln common/lineid/wave,idln integer xl(*),yy C EXP10(X)=EXP(X*2.30258509299405E0) IF(NABLOG.EQ.0)GO TO 63 ABLOG(1)=MINLOG+ABLG EWLOG(1)= LOG10(WID(EXP10(ABLOG(1)),IVT)) RESID0(1)=RESIDU(1) TAULOG(1)= LOG10(TAUBAR) DO 162 I=2,NABLOG ABLOG(I)=ABLOG(I-1)+DABLOG EWLOG(I)= LOG10(WID(EXP10(ABLOG(I)),IVT)) RESID0(I)=RESIDU(1) TAULOG(I)= LOG10(TAUBAR) 162 continue NAB=NABLOG OBEWLG=0. GO TO 76 63 OBEWLG= LOG10(EW) ABLOG(1)=ABLG EWLOG(1)= LOG10(WID(EXP10(ABLOG(1)),IVT)) TAULOG(1)= LOG10(TAUBAR) IF(EWLOG(1).GT.OBEWLG)GO TO 71 ABLOG(2)=ABLOG(1)+1. EWLOG(2)= LOG10(WID(EXP10(ABLOG(2)),IVT)) TAULOG(2)= LOG10(TAUBAR) ABLOG(3)=ABLOG(2)+1. IF(EWLOG(2).GT.OBEWLG)ABLOG(3)=ABLOG(3)-1.5 GO TO 72 71 ABLOG(2)=ABLOG(1)-1. EWLOG(2)= LOG10(WID(EXP10(ABLOG(2)),IVT)) TAULOG(2)= LOG10(TAUBAR) ABLOG(3)=ABLOG(2)+.5 IF(EWLOG(2).GT.OBEWLG)ABLOG(3)=ABLOG(3)-1.5 72 EWLOG(3)= LOG10(WID(EXP10(ABLOG(3)),IVT)) TAULOG(3)= LOG10(TAUBAR) DO 73 IAB=3,8 NAB=IAB IF(ABS(OBEWLG-EWLOG(IAB)).LT..005)GO TO 76 NAB1=NAB-1 DO 79 KK=1,NAB1 DO 79 II=1,NAB1 IF(ABLOG(II+1).GE.ABLOG(II))GO TO 79 DUMMY=ABLOG(II+1) ABLOG(II+1)=ABLOG(II) ABLOG(II)=DUMMY DUMMY=EWLOG(II+1) EWLOG(II+1)=EWLOG(II) EWLOG(II)=DUMMY DUMMY=TAULOG(II+1) TAULOG(II+1)=TAULOG(II) TAULOG(II)=DUMMY 79 CONTINUE DO 80 I=2,NAB K=I IF(OBEWLG.LT.EWLOG(I))GO TO 81 80 CONTINUE 81 ABLOG(NAB+1)=ABLOG(K-1)+(ABLOG(K)-ABLOG(K-1))/(EWLOG(K)-EWLOG(K-1) 1)*(OBEWLG-EWLOG(K-1)) EWLOG(IAB+1)= LOG10(WID(EXP10(ABLOG(IAB+1)),IVT)) 73 TAULOG(IAB+1)= LOG10(TAUBAR) NAB=NAB+1 write(6,"('Line ',f9.3,1x,a6,' not converged')")wave,idln 76 continue ABLG=ABLOG(NAB) TAULG=TAULOG(NAB) RETURN END FUNCTION WID(ABUND,IVT) IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (kw=99) common /abross/abross(kw),tauros(kw) COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL COMMON /MUS/ANGLE(20),SURFI(20),NMU COMMON /OPTOT/ACONT(kw),SCONT(kw),ALINE(kw),SLINE(kw),SIGMAC(kw), 1 SIGMAL(kw) COMMON /RHOX/RHOX(kw),NRHOX COMMON /TAUSHJ/TAUNU(kw),SNU(kw),HNU(kw),JNU(kw),JMINS(kw) REAL*8 JNU,JMINS COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND, 1 IFTURB C COMMON /CONTIN/CONTIN COMMON /IFPROF/IFPROF COMMON/LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,GAMMAR,GAMMAS,GAMMAW, *ELO,GF,X1,X2,REF,OTHER1(3),OTHER2(3),LABEL(3),LABELP(3),NELION, 1 NBLO,NBUP,ISO1,ISO2 COMMON /LINEY/LINE0(10,kw),DOPWAV(10,kw),ADAMP(10,kw) REAL*8 LINE0 COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15) COMMON /TAUBAR/TAUBAR COMMON /VTS/VTS(10),NVT DIMENSION DEL(15),WEIGHT(15),ALINE0(kw) C IN PM DATA DEL/0.,.5,1.,1.5,2.,2.5,3.,3.5,4.,4.5,5.,6.25,7.5,8.75,10./ DATA WEIGHT/.166667,.666667,.333333,.666667,.333333,.666667, 1.333333,.666667,.333333,.666667,.583333,1.666667,.833333,1.666667, 2 10.416667/ data iter/0/ ! EXP10(X)=EXP(X*2.30258509299405E0) iter=iter+1 numout=iter+30 ! write(numout,*)log10(abund) DO 1 J=1,NRHOX 1 ALINE0(J)=LINE0(IVT,J)*ABUND ASSIGN 73 TO ISWTCH C MICROTURBULENCE IN PM DOPVT=(VTS(IVT)*(1.E5/2.997925E10))*(WL*1000.) SCALE=SQRT(2.5**2+DOPVT**2)/2.5 DO 70 MDUMMY=1,10 CCC=5.*SCALE DO 71 J=1,NRHOX 71 ALINE(J)=ALINE0(J)*VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J)) CALL JOSH(IFSCAT,IFSURF) IF(IFSURF.LT.2)RESID=HNU(1)/CONTIN IF(IFSURF.EQ.2)RESID=SURFI(1)/CONTIN IF(MDUMMY.EQ.1)GO TO 75 IF(RESID.GT..93)GO TO 74 GO TO ISWTCH,(73,76) 75 IF(RESID.GE..91)GO TO 80 73 SCALE1=SCALE SCALE=SCALE*2. ASSIGN 73 TO ISWTCH GO TO 70 74 SCALE2=SCALE SCALE=(SCALE1+SCALE2)/2. ASSIGN 76 TO ISWTCH GO TO 70 76 SCALE1=SCALE SCALE=(SCALE1+SCALE2)/2. 70 CONTINUE 80 WIDTH=0. TAUSUM=0. DO 81 I=1,15 CCC=DEL(I)*SCALE DELWAV(I)=CCC DO 82 J=1,NRHOX 82 ALINE(J)=ALINE0(J)*VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J)) CALL JOSH(IFSCAT,IFSURF) IF(IFSURF.LT.2)RESIDU(I)=HNU(1)/CONTIN IF(IFSURF.EQ.2)RESIDU(I)=SURFI(1)/CONTIN MAX=MAP1(TAUNU,tauros,NRHOX,1.D0,TAUONE(I),1) ! TAUONE(I)= LOG10(TAUONE(I)) TAUSUM=TAUSUM+WEIGHT(I)*TAUONE(I)*(1.-RESIDU(I)) 81 WIDTH=WIDTH+WEIGHT(I)*(1.-RESIDU(I)) ! TAUBAR=EXP10(TAUSUM/WIDTH) taubar=tausum/width WID=WIDTH*SCALE*2. ! write(numout,*)wid ! do i=1,15 ! write(numout,*)delwav(i),residu(i) ! enddo IF(IFPROF.EQ.0)RETURN RETURN END SUBROUTINE LINCEN(ABUND1,VTS,NVT) IMPLICIT REAL*8 (A-H,O-Z) PARAMETER (kw=99) common/vmag/vmag COMMON /ELEM/ABUND(99),ATMASS(99),ELEM(99) COMMON /FREQ/FREQ,FREQLG,EHVKT(kw),STIM(kw),BNU(kw) COMMON /IONS/XNFPH(kw,2),XNFPHE(kw,3),XNFH(kw,2),XNFHE(kw,3) COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL COMMON /RHOX/RHOX(kw),NRHOX COMMON /STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw) COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND, 1 IFTURB COMMON /XABUND/XABUND(99),WTMOLE C COMMON/LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,GAMMAR,GAMMAS,GAMMAW, *ELO,GF,X1,X2,REF,OTHER1(3),OTHER2(3),LABEL(3),LABELP(3),NELION, 1 NBLO,NBUP,ISO1,ISO2 COMMON /LINEY/LINE0(10,kw),DOPWAV(10,kw),ADAMP(10,kw) REAL*8 LINE0 COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15) DIMENSION VTS(10) DIMENSION TDOP(kw),ADAMP1(kw),LINE(kw),XNFPRC(kw),TXNXN(kw) REAL*8 LINE DIMENSION XCODE(8) DATA XCODE/1.E14,1.E12,1.E10,1.E8,1.E6,1.E4,1.E2,1.E0/ DATA ITEMP1/0/ IF(ITEMP.EQ.ITEMP1)GO TO 2 XNFH2=0. DO 1 J=1,NRHOX C NUMBER DENSITIES FOR VAN DER WAALS BROADENING 1 TXNXN(J)=(XNFPH(J,1)*2.+.42*XNFPHE(J,1)*1.+.85*XNFH2)* 1(T(J)/10000.)**.3 ITEMP1=ITEMP SAVE=0. 2 IF(CODE.EQ.SAVE)GO TO 18 AMASS=0. ABUND1=1. C=CODE DO 11 II=1,8 IF(C.GE.XCODE(II))GO TO 12 11 CONTINUE CALL EXIT 12 DO 13 I=II,8 ID=C/XCODE(I) IF(ID.LT.100)ABUND1=ABUND1*XABUND(ID) AMASS=AMASS+ATMASS(ID) 13 C=C-FLOAT(ID)*XCODE(I) SAVE=CODE CALL POPS(CODE,1,XNFPRC) TWOMAS=2./AMASS/1.660E-24 DO 17 J=1,NRHOX XNFPRC(J)=XNFPRC(J)*(.026538/1.77245)/ABUND1/RHO(J) 17 TDOP(J)=TK(J)*TWOMAS 18 ELOC=ELO*2.997925E10 DO 5 J=1,NRHOX ADAMP1(J)=(GAMMAR+GAMMAS*XNE(J)+GAMMAW*TXNXN(J))/12.5664 5 LINE(J)=GF*EXP(-ELOC*HKT(J))*STIM(J)*XNFPRC(J) FREQC=FREQ/2.997925E10 WAVENU=1.E10/FREQC/FREQ ! IF(VTS(1).EQ.0..AND.NVT.EQ.1)GO TO 7 DO 6 IVT=1,NVT VT2=VTS(IVT)**2*1.E10+vmag*vmag*1.E10 DO 6 J=1,NRHOX DOPNU=SQRT(TDOP(J)+VT2)*FREQC C DOPWAV IS DOPLER WIDTH IN PM DOPWAV(IVT,J)=DOPNU*WAVENU C LINE ABSORPTION COEFFICIENT PER UNIT ABUNDANCE LINE0(IVT,J)=LINE(J)/DOPNU 6 ADAMP(IVT,J)=ADAMP1(J)/DOPNU RETURN ! 7 DO 8 J=1,NRHOX ! DOPNU=SQRT(TDOP(J)+VTURB(J)**2)*FREQC ! DOPWAV(1,J)=DOPNU*WAVENU ! LINE0(1,J)=LINE(J)/DOPNU ! 8 ADAMP(1,J)=ADAMP1(J)/DOPNU RETURN END subroutine blockpt implicit real*8 (a-h,o-z) common/potion/potion(594) DIMENSION POTA(114),POTB(114),POTC(114),POTD(114),POTE(114) DIMENSION POTF(24) EQUIVALENCE (POTION(1),POTA(1)),(POTION(115),POTB(1)) EQUIVALENCE (POTION(229),POTC(1)),(POTION(343),POTD(1)) EQUIVALENCE (POTION(457),POTE(1)),(POTION(571),POTF(1)) DATA POTA/ 1 13.598, 0. , 0. , 0. , 0. , 0. , 1 2 24.587, 54.416, 0. , 0. , 0. , 0. , 2 3 5.392, 75.638, 122.451, 0. , 0. , 0. , 3 4 9.322, 18.211, 153.893, 217.713, 0. , 0. , 4 5 8.298, 25.154, 37.930, 259.368, 340.217, 0. , 5 6 11.260, 24.383, 47.887, 64.492, 392.077, 489.981, 6 7 14.534, 29.601, 47.448, 77.472, 97.888, 552.057, 7 8 13.618, 35.116, 54.934, 77.412, 113.896, 138.116, 8 9 17.422, 34.970, 62.707, 87.138, 114.240, 157.161, 9 T 21.564, 40.962, 63.45 , 97.11 , 126.21 , 157.93 , 10 1 5.139, 47.286, 71.64 , 98.91 , 138.39 , 172.15 , 11 2 7.646, 15.035, 80.143, 109.24 , 141.26 , 186.50 , 12 3 5.986, 18.828, 28.447, 119.99 , 153.71 , 190.47 , 13 4 8.151, 16.345, 33.492, 45.141, 166.77 , 205.05 , 14 5 10.486, 19.725, 30.18 , 51.37 , 65.023, 220.43 , 15 6 10.36 , 23.33 , 34.83 , 47.30 , 72.68 , 88.049, 16 7 12.967, 23.81 , 39.61 , 53.46 , 67.80 , 97.03 , 17 8 15.759, 27.629, 40.74 , 59.81 , 75.02 , 91.007, 18 9 4.341, 31.625, 45.72 , 60.91 , 82.66 , 100.0 / 19 DATA POTB/ 1 6.113, 11.871, 50.908, 67.10 , 84.41 , 108.78 , 20 2 6.54 , 12.80 , 24.76 , 73.47 , 91.66 , 111.1 , 21 3 6.82 , 13.58 , 27.491, 43.266, 99.22 , 119.36 , 22 4 6.74 , 14.65 , 29.310, 46.707, 65.23 , 128.12 , 23 5 6.766, 16.50 , 30.96 , 49.1 , 69.3 , 90.56 , 24 6 7.435, 15.640, 33.667, 51.2 , 72.4 , 95. , 25 7 7.870, 16.18 , 30.651, 54.8 , 75.0 , 99.0 , 26 8 7.86 , 17.06 , 33.50 , 51.3 , 79.5 , 102.0 , 27 9 7.635, 18.168, 35.17 , 54.9 , 75.5 , 108.0 , 28 T 7.726, 20.292, 36.83 , 55.2 , 79.9 , 103.0 , 29 1 9.394, 17.964, 39.722, 59.4 , 82.6 , 108.0 , 30 2 5.999, 20.51 , 30.71 , 64.0 , 0. , 0. , 31 3 7.899, 15.934, 34.22 , 45.71 , 93.5 , 0. , 32 4 9.81 , 18.633, 28.351, 50.13 , 62.63 , 127.6 , 33 5 9.752, 21.19 , 30.820, 42.944, 68.3 , 81.70 , 34 6 11.814, 21.8 , 36. , 47.3 , 59.7 , 88.6 , 35 7 13.999, 24.359, 36.95 , 52.5 , 64.7 , 78.5 , 36 8 4.177, 27.28 , 40.0 , 52.6 , 71.0 , 84.4 , 37 9 5.695, 11.030, 43.6 , 57.0 , 71.6 , 90.8 / 38 DATA POTC/ 1 6.38 , 12.24 , 20.52 , 61.8 , 77.0 , 93.0 , 39 2 6.84 , 13.13 , 22.99 , 34.34 , 81.50 , 0. , 40 3 6.88 , 14.32 , 25.04 , 38.3 , 50.55 , 102.6 , 41 4 7.099, 16.15 , 27.16 , 46.4 , 61.2 , 68.0 , 42 5 7.28 , 15.26 , 29.54 , 0. , 0. , 0. , 43 6 7.37 , 16.76 , 28.47 , 0. , 0. , 0. , 44 7 7.46 , 18.08 , 31.06 , 0. , 0. , 0. , 45 8 8.34 , 19.43 , 32.93 , 0. , 0. , 0. , 46 9 7.576, 21.49 , 34.83 , 0. , 0. , 0. , 47 T 8.993, 16.908, 34.48 , 0. , 0. , 0. , 48 1 5.786, 18.869, 28.03 , 54.0 , 0. , 0. , 49 2 7.344, 14.632, 30.502, 40.734, 72.28 , 0. , 50 3 8.641, 16.53 , 25.3 , 44.2 , 56.0 , 108.0 , 51 4 9.009, 18.6 , 27.96 , 37.41 , 58.75 , 70.7 , 52 5 10.451, 19.131, 33.0 , 0. , 0. , 0. , 53 6 12.130, 21.21 , 32.1 , 0. , 0. , 0. , 54 7 3.894, 25.1 , 35.0 , 0. , 0. , 0. , 55 8 5.212, 10.004, 37.000, 0. , 0. , 0. , 56 9 5.577, 11.06 , 19.177, 49.954, 0. , 0. / 57 DATA POTD/ 1 5.47 , 10.85 , 20.197, 36.758, 0. , 0. , 58 2 5.42 , 10.55 , 21.624, 38.981, 0. , 0. , 59 3 5.49 , 10.72 , 22.14 , 40.42 , 0. , 0. , 60 4 5.55 , 10.90 , 22.42 , 41.09 , 0. , 0. , 61 5 5.63 , 11.07 , 23.45 , 41.47 , 0. , 0. , 62 6 5.67 , 11.25 , 24.71 , 42.65 , 0. , 0. , 63 7 6.14 , 12.1 , 20.38 , 44.03 , 0. , 0. , 64 8 5.85 , 11.52 , 21.98 , 39.84 , 0. , 0. , 65 9 5.93 , 11.67 , 22.83 , 41.56 , 0. , 0. , 66 T 6.02 , 11.80 , 22.84 , 42.51 , 0. , 0. , 67 1 6.10 , 11.93 , 22.74 , 42.66 , 0. , 0. , 68 2 6.18 , 12.05 , 23.68 , 42.69 , 0. , 0. , 69 3 6.254, 12.17 , 25.03 , 43.74 , 0. , 0. , 70 4 5.426, 13.9 , 20.960, 45.193, 0. , 0. , 71 5 7.0 , 14.9 , 23.3 , 33.319, 0. , 0. , 72 6 7.89 , 16.200, 24.0 , 0. , 0. , 0. , 73 7 7.98 , 17.70 , 25.0 , 0. , 0. , 0. , 74 8 7.88 , 16.6 , 26.0 , 0. , 0. , 0. , 75 9 8.7 , 17.0 , 27.0 , 0. , 0. , 0. / 76 DATA POTE/ 1 9.1 , 20.0 , 28.0 , 0. , 0. , 0. , 77 2 9.0 , 18.563, 29.0 , 0. , 0. , 0. , 78 3 9.225, 20.5 , 30.0 , 0. , 0. , 0. , 79 4 10.437, 18.756, 34.2 , 0. , 0. , 0. , 80 5 6.108, 20.428, 29.83 , 0. , 0. , 0. , 81 6 7.416, 15.032, 31.937, 42.32 , 68.8 , 0. , 82 7 7.289, 16.69 , 25.56 , 45.3 , 56.0 , 88.3 , 83 8 8.42 , 19.0 , 27.0 , 0. , 0. , 0. , 84 9 9.3 , 20.0 , 30. , 0. , 0. , 0. , 85 T 10.748, 20.0 , 30.0 , 0. , 0. , 0. , 86 1 4.0 , 22.0 , 33.0 , 0. , 0. , 0. , 87 2 5.279, 10.147, 34.0 , 0. , 0. , 0. , 88 3 6.9 , 12.1 , 20.0 , 0. , 0. , 0. , 89 4 6.0 , 11.5 , 20.0 , 28.8 , 0. , 0. , 90 5 6.0 , 12.0 , 20.0 , 0. , 0. , 0. , 91 6 6.0 , 12.0 , 20.0 , 0. , 0. , 0. , 92 7 6.0 , 12.0 , 20.0 , 0. , 0. , 0. , 93 8 5.800, 12.0 , 20.0 , 0. , 0. , 0. , 94 9 6.0 , 12.0 , 20.0 , 0. , 0. , 0. / 95 DATA POTF/ 1 6.0 , 12.0 , 20.0 , 0. , 0. , 0. , 96 2 6.0 , 12.0 , 20.0 , 0. , 0. , 0. , 97 3 6.0 , 12.0 , 20.0 , 0. , 0. , 0. , 98 4 6.0 , 12.0 , 20.0 , 0. , 0. , 0. / 99 end