PROGRAM EXPAND3007 C PUTS THE LINE LIST AND ENERGY LEVELS TOGETHER AND WRITE LINES C IN ONE RECORD FORMAT C ONLY FOR LINES WITH POSITIVE (NOT-PREDICTED) WAVELENGTHS IMPLICIT REAL*8 (A-H,O-Z) CHARACTER*10 ELABJE(20000),ELABJO(20000) CHARACTER*4 REF CHARACTER*3 EVEODD(20000),ODDEVE(20000) CHARACTER*10 OTHER1,OTHER2 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 TAPE1 GF*.LIN C TAPE8 GF*.GAM C WAVELENGTH IN NM C TAPE11 GF*.POS C TAPE12 GF*.PRED C TAPE13 GF*.LINES = GF*.POS + GF*.PRED C TAPE14 GF*.LOW GF*.LINES WITH UPPER ENERGY BELOW THE IP C WAVENUMBERS IN CM-1 C TAPE21 GF*.WNPOS C TAPE22 GF*.WNPRED C TAPE23 GF*.WNLINES = GF*.WNPOS + GF*.WNPRED C TAPE24 GF*.WNLOW GF*.WNLINES WITH UPPER ENERGY BELOW THE IP C WRITE(8,996)ELEM,NLINES,NPOS,JJSUML,JJSUMLP,IEION 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)NLINES,NPOS,NE,NO,IEION,EVENODD 1 FORMAT(5X,I10,12X,I10,21X,I7,5X,I7,11X,I10,14X,A3) EION=IEION DO 987 ISKIP=1,27 987 READ(8,1) IF(EVENODD.EQ.3Hodd)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) 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) ENDIF 7 FORMAT(40X,E24.14) DO 8 K=1,NE 8 READ(8,7)EXTRAJE(K) DO 9 K=1,NO 9 READ(8,7)EXTRAJO(K) C READ(1,5)W,GFLOG,KE,KO,IFPRED,ICODE 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' NBLO=0 NBUP=0 ISO1=0 X1=0. ISO2=0 X2=0. OTHER1=' ' OTHER2=' ' ISOSHIFT=0 REWIND 1 OPEN(UNIT=11,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=12,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=13,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=14,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=21,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=22,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=23,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=24,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') DO 99 ILINE=1,NLINES READ(1,5)WL,GFLOG,KE,KO,IFPRED C PRINT 5,WL,GFLOG,KE,KO,IFPRED C 5 FORMAT(F11.4,F7.3,I5,I5,I1,I4) 5 FORMAT(F18.8,F7.3,I5,I5,I1,I4) IF(EVENODD.EQ.3Hodd)THEN KK=KE KE=KO KO=KK ENDIF REF='K04 ' IF(EVEODD(KE).EQ.'EPo')REF='K04P' IF(EVEODD(KE).EQ.'ERy')REF='K04R' IF(ODDEVE(KO).EQ.'OPo')REF='K04P' IF(ODDEVE(KO).EQ.'ORy')REF='K04R' 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))) WL=MIN(WL,999999.9999D0) WAVENO=MIN(WAVENO,999999.9999D0) 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 WRITE(21,140)WAVENO,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 IF(IFPRED.EQ.1)THEN WRITE(12,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 WRITE(22,140)WAVENO,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(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 WRITE(23,140)WAVENO,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 WRITE(24,140)WAVENO,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) 99 CONTINUE CALL EXIT END