PROGRAM EXPAND3007 C Puts the linelist and energy levels together and writes lines C in various formats. If input is wavelengths output is wavelengths. C If input is wavenumbers output is wavenumbers. C C TAPE1 GF*.LIN OR GF*.WNLIN input wavelength or wavenumber linelist C (air nm) (cm-1) C TAPE8 GF*.GAM input energy levels C C TAPE11 GF*.POS or GF*.WNPOS subset of GF*.LINES with good positions C TAPE12 GF*.80COL or GF*.WN80COL GF*.LINES with no damping or splitting C TAPE13 GF*.LINES or GF*.WNLINES output linelist C TAPE14 GF*.LOW or GF*.WNLOW GF*.LINES with upper energy below IP C TAPE15 GF*.AGAFGF GF*.LINES with WL,WN,gf,f,femiss,A,gA C but no broadening for commparison C with other work C TAPE16 GF*.BF or GF*.WNBF branching fractions C IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*80 STRING80 CHARACTER*10 ELABJE(20000),ELABJO(20000) CHARACTER*28 ELABE(20000),ELABO(20000),ELAB,ELABP CHARACTER*4 REF CHARACTER*3 EVEODD(20000),ODDEVE(20000),PARITY,EVENODD CHARACTER*10 OTHER1,OTHER2 CHARACTER*1 EMQ REAL*8 EXTRAJE(20000),EXTRAJO(20000) REAL*8 XJE(20000),LJE(20000),ASUME(20000), 1EJE(20000),WAALSE(20000),STARKE(20000),FSUME(20000),GLANDEE(20000) REAL*8 XJO(20000),LJO(20000),ASUMO(20000), 1EJO(20000),WAALSO(20000),STARKO(20000),FSUMO(20000),GLANDEO(20000) C WRITE(8,996)ELEM,NLINES,NPOS,JJSUML,JJSUMLP,IEION,EVENODD C 996 FORMAT(F5.2,I10,' lines saved',I10,' positive lines saved',I7, C 1' even',I7,' odd levels',I10,' ion pot cm-1') READ(8,1)ELEM,NLINES,NPOS,NE,NO,IEION,EVENODD 1 FORMAT(F5.2,I10,12X,I10,21X,I7,5X,I7,11X,I10,14X,A3) PRINT 996,ELEM,NLINES,NPOS,NE,NO,IEION,EVENODD 996 FORMAT(F6.2,I10,' lines saved',I10,' positive lines saved',I7, 1' even',I7,' odd levels',I10,' ion pot cm-1',1X,A3) EION=IEION DO 987 ISKIP=1,29 READ(8,991)STRING80 991 FORMAT(A80) PRINT 997,STRING80 997 FORMAT(1X,A80) IF(STRING80(1:4).EQ.'ELEM')GO TO 988 987 CONTINUE 988 CONTINUE IF(EVENODD.EQ.'odd')THEN DO 334 K=1,NO 334 READ(8,2)ODDEVE(K),EJO(K),XJO(K),ELABJO(K),GLANDEO(K),ASUMO(K), 1STARKO(K),WAALSO(K) DO 333 K=1,NE 333 READ(8,2)EVEODD(K),EJE(K),XJE(K),ELABJE(K),GLANDEE(K),ASUME(K), 1STARKE(K),WAALSE(K) DO 339 K=1,NO 339 READ(8,7)EXTRAJO(K) DO 338 K=1,NE 338 READ(8,7)EXTRAJE(K) ELSE DO 3 K=1,NE 3 READ(8,2)EVEODD(K),EJE(K),XJE(K),ELABJE(K),GLANDEE(K),ASUME(K), 1STARKE(K),WAALSE(K) 2 FORMAT(5X,A3,4X,F12.3,F5.1,1X,A10,F7.3,1P3E9.2,0PF10.3) DO 4 K=1,NO 4 READ(8,2)ODDEVE(K),EJO(K),XJO(K),ELABJO(K),GLANDEO(K),ASUMO(K), 1STARKO(K),WAALSO(K) 7 FORMAT(12X,A28,E24.14) DO 8 K=1,NE 8 READ(8,7)ELABE(K),EXTRAJE(K) DO 9 K=1,NO 9 READ(8,7)ELABO(K),EXTRAJO(K) ENDIF CLOSE(UNIT=8) C READ(1,'(I22,1X,A1,1X,A3)')ICODE,EMQ,PARITY CODE=FLOAT(ICODE)*.01 ICHARGE=MOD(ICODE,100) NELION=(ICODE/100-1)*6+ICHARGE+1 REF='K89' REF='K94' REF='K98' REF='K99' REF='K00' REF='K03' REF='K04' REF='K06' REF='K07' NBLO=0 NBUP=0 ISO1=0 X1=0. ISO2=0 X2=0. OTHER1=' ' OTHER2=' ' ISOSHIFT=0 OPEN(UNIT=11,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=12,STATUS='NEW',CARRIAGECONTROL='LIST') OPEN(UNIT=13,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=14,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=15,STATUS='NEW',CARRIAGECONTROL='LIST') OPEN(UNIT=16,STATUS='NEW',CARRIAGECONTROL='LIST') WRITE(15,1515) 1515 FORMAT(' wl(nm) ',' wn(cm-1)',' log gf',' log f',' log fe', 1 ' log A',' log gA') DO 99 ILINE=1,NLINES READ(1,5)WL,GFLOG,KE,KO,IFPRED C PRINT 5,WL,GFLOG,KE,KO,IFPRED 5 FORMAT(F18.8,F7.3,I5,I5,I1,I4) IF(EVENODD.EQ.'odd')THEN ELAB=ELABE(KO) ELABP=ELABO(KE) KK=KE KE=KO KO=KK ELSE ELAB=ELABE(KE) ELABP=ELABO(KO) ENDIF REF='K07 ' IF(EVEODD(KE).EQ.'EPo')REF='K07P' IF(EVEODD(KE).EQ.'ERy')REF='K07R' IF(ODDEVE(KO).EQ.'OPo')REF='K07P' IF(ODDEVE(KO).EQ.'ORy')REF='K07R' C C THE DAMPING CONSTANTS ARE COMPUTED FROM SUMS OVER ALL POSSIBLE C TRANSITIONS TO A GIVEN LEVEL (KURUCZ, SAO SPECIAL REPORT 390,1981). C THESE SUMS ARE NOT COMPLETE EXCEPT FOR ASUMS FOR LEVELS BELOW C THE LOWEST LEVEL LEFT OUT OF THE CALCULATIONS. CONSULT THE OUTPUT C LISTINGS FOR THE LEAST SQUARES FITS BXXXXE.OUT,BXXXXO.OUT, C CXXXXE.OUT,CXXXXO.OUT TO DETERMINE WHICH CONFIGURATIONS WERE INCLUDED. C THE SUMS SHOULD BE COMPLETE OR NEARLY SO FOR MOST STRONG LINES. C C GAMMAW IS THE DAMPING CONSTANT PER HYDROGEN ATOM FOR VAN DER WAALS C BROADENING BY HYDROGEN AT T=10000K. C =84762*C6**.4 FROM ALLER C FOR HELIUM MULTIPLY BY .42 C FOR H2 MULTIPLY BY .85 C GAMMAS IS THE STARK DAMPING CONSTANT PER ELECTRON ASSUMED TO BE C TEMPERATURE INDEPENDENT C =15385*C4**(2/3) AT 10000K FROM ALLER C GAMMAR=LOG10(ASUME(KE)+ASUMO(KO)) C THESE DAMPING CONSTANTS ARE TOO SMALL C GSLOG=LOG10(15835.*(MAX(ABS(C4P-C4), C 1AMIN1(ABS(C4),ABS(C4P))))**.6666667) C GWLOG=LOG10(84762.*(MAX(ABS(C6P-C6), C 1AMIN1(ABS(C6),ABS(C6P))))**.4) C C TRY SUMMING C GAMMAS=LOG10(15835.*(ABS(STARKE(KE))+ C 1 ABS(STARKO(KO)))**.6666667) C GAMMAW=LOG10(84762.*(ABS(WAALSE(KE))+ABS(WAALSO(KO)))**.4) C C TRY NOT DIFFERENCING GAMMAS=LOG10(15835.*MAX(ABS(STARKE(KE)), 1 ABS(STARKO(KO)),1.D-20)**.6666667) GAMMAW= 1 LOG10(84762.*MAX(ABS(WAALSE(KE)),ABS(WAALSO(KO)),1.D-40)**.4) C LANDE=GLANDEE(KE)*1000.+.5 IF(LANDE.LT.0)LANDE=GLANDEE(KE)*1000.-.5 LANDEP=GLANDEO(KO)*1000.+.5 IF(LANDEP.LT.0)LANDEP=GLANDEO(KO)*1000.-.5 C C WAVENO=ABS(ABS(EJE(KE))-ABS(EJO(KO))) WAVENO=ABS(ABS(EXTRAJE(KE))-ABS(EXTRAJO(KO))) WLVAC=1.D7/WAVENO WL=MIN(WL,999999.9999D0) WAVENO=MIN(WAVENO,9999999.9999D0) IF(IFPRED.EQ.1)WW=-WL IF(ABS(EXTRAJE(KE)).LT.ABS(EXTRAJO(KO)))THEN XJUP=XJO(KO) XJLO=XJE(KE) ASUM=ASUMO(KO) ELSE XJUP=XJE(KE) XJLO=XJO(KO) ASUM=ASUME(KE) ENDIF GLO=XJLO+XJLO+1. GUP=XJUP+XJUP+1. GF=10**GFLOG A=GF*66702.E9/WLVAC**2/GUP BRANCHINGFRAC=A/ASUM FLOG=GFLOG-LOG10(GLO) FEMISSLOG=GFLOG-LOG10(GUP) GALOG=GFLOG+LOG10(66702.E9/WLVAC**2) ALOG=GALOG-LOG10(GUP) C IF(IFPRED.EQ.0)THEN WRITE(11,140)WL,GFLOG,CODE,EJE(KE),XJE(KE),ELABJE(KE),EJO(KO), 1 XJO(KO),ELABJO(KO),GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1, 2 ISO2,X2,OTHER1,OTHER2,LANDE,LANDEP,ISOSHIFT ENDIF C WRITE(12,140)WL,GFLOG,CODE,EJE(KE),XJE(KE),ELABJE(KE),EJO(KO), 1 XJO(KO),ELABJO(KO) C WRITE(15,144)WW,WAVENO,GFLOG,FLOG,FEMISSLOG,ALOG,GALOG,CODE, 1 EJE(KE),XJE(KE),ELABJE(KE),EJO(KO),XJO(KO),ELABJO(KO) 144 FORMAT(F12.4,F12.3,5F7.3,F6.2,F12.3,F5.1,1X,A10,F12.3,F5.1,1X,A10) C WRITE(13,140)WL,GFLOG,CODE,EJE(KE),XJE(KE),ELABJE(KE),EJO(KO), 1 XJO(KO),ELABJO(KO),GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1, 2 ISO2,X2,OTHER1,OTHER2,LANDE,LANDEP,ISOSHIFT C IF(ABS(EJE(KE)).GT.EION)GO TO 99 IF(ABS(EJO(KO)).GT.EION)GO TO 99 WRITE(14,140)WL,GFLOG,CODE,EJE(KE),XJE(KE),ELABJE(KE),EJO(KO), 1 XJO(KO),ELABJO(KO),GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1, 2 ISO2,X2,OTHER1,OTHER2,LANDE,LANDEP,ISOSHIFT 140 FORMAT(F11.4,F7.3,F6.2,F12.3,F5.1,1X,A10,F12.3,F5.1,1X,A10, 1 F6.2,F6.2,F6.2,A4,I2,I2,I3,F6.3,I3,F6.3,2A10,2I5,I6) C WRITE(16,149)WL,GFLOG,CODE,ELAB,ELABP,REF,ASUM,A,BRANCHINGFRAC 149 FORMAT(F11.4,F7.3,F6.2,A28,A28,1X,A4,1P3E12.3) 99 CONTINUE CALL EXIT END