PROGRAM EXPANDFORBIDDEN3007 C Puts the linelist and energy levels together and writes lines C in 160 column format. If input is wavelengths output is wavelengths. C If input is wavenumbers output is wavenumbers. C C TAPE1 GAM*E.LIN OR *.WNLIN input wavelength or wavenumber linelist C TAPE2 GAM*O.LIN OR *.WNLIN input wavelength or wavenumber linelist C TAPE3 GAQ*E.LIN OR *.WNLIN input wavelength or wavenumber linelist C TAPE4 GAQ*O.LIN OR *.WNLIN input wavelength or wavenumber linelist C (air nm) (cm-1) C TAPE8 GF*.GAM input energy levels C C TAPE11 GAM*E.LINES or *.WNLINES output lines C TAPE12 GAM*E.META or *.WNMETA subset of GF*.LINES with metastable levels C TAPE13 GAM*E.POS or *.WNPOS subset of GA*.LINES with good wl C TAPE14 GFM*E.METAPOS or *.WNMETAPOS subset of GA*.META with good wl C C TAPE21 GAM*O.LINES or *.WNLINES output lines C TAPE22 GAM*O.META or *.WNMETA subset of GF*.LINES with metastable levels C TAPE23 GAM*O.POS or *.WNPOS subset of GA*.LINES with good wl C TAPE24 GFM*O.METAPOS or *.WNMETAPOS subset of GA*.META with good wl C C TAPE31 GAQ*E.LINES or *.WNLINES output lines C TAPE32 GAQ*E.META or *.WNMETA subset of GF*.LINES with metastable levels C TAPE33 GAQ*E.POS or *.WNPOS subset of GA*.LINES with good wl C TAPE34 GFQ*E.METAPOS or *.WNMETAPOS subset of GA*.META with good wl C C TAPE41 GAQ*O.LINES or *.WNLINES output lines C TAPE42 GAQ*O.META or *.WNMETA subset of GF*.LINES with metastable levels C TAPE43 GAQ*O.POS or *.WNPOS subset of GA*.LINES with good wl C TAPE44 GFQ*O.METAPOS or *.WNMETAPOS subset of GA*.META with good wl 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)ELABO(K),EXTRAJO(K) DO 338 K=1,NE 338 READ(8,7)ELABE(K),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 DO 999 IT=1,4 JT1=IT*10+1 JT2=IT*10+2 JT3=IT*10+3 JT4=IT*10+4 JT5=IT*10+5 OPEN(UNIT=IT,STATUS='OLD') OPEN(UNIT=JT1,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=JT2,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=JT3,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=JT4,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') OPEN(UNIT=JT5,STATUS='NEW',RECL=160,CARRIAGECONTROL='LIST') READ(IT,'(I22,1X,A1,1X,A3)')ICODE,EMQ,PARITY CODE=FLOAT(ICODE)*.01 ICHARGE=MOD(ICODE,100) NELION=(ICODE/100-1)*6+ICHARGE+1 NBLO=0 NBUP=0 ISO1=0 X1=0. ISO2=0 X2=0. OTHER1=' ' OTHER2=' ' ISOSHIFT=0 DO 99 ILINE=1,99999999 READ(IT,5,END=100)WL,GALOG,K,KP,IFPRED C PRINT 5,WL,GFLOG,K,KP,IFPRED 5 FORMAT(F18.8,F7.3,I5,I5,I1,I4) IF(PARITY.EQ.'ODD')THEN E=EXTRAJO(K) EP=EXTRAJO(KP) ELAB=ELABO(K) ELABP=ELABO(KP) ASUM=ASUMO(K) ASUMP=ASUMO(KP) STARK=STARKO(K) STARKP=STARKO(KP) WAALS=WAALSO(K) WAALSP=WAALSO(KP) LANDE=GLANDEO(K)*1000.+.5 LANDEP=GLANDEO(KP)*1000.+.5 IF(LANDE.LT.0)LANDE=GLANDEO(K)*1000.-.5 IF(LANDEP.LT.0)LANDEP=GLANDEO(KP)*1000.-.5 ELSE E=EXTRAJE(K) EP=EXTRAJE(KP) ELAB=ELABE(K) ELABP=ELABE(KP) ASUM=ASUME(K) ASUMP=ASUME(KP) STARK=STARKE(K) STARKP=STARKE(KP) WAALS=WAALSE(K) WAALSP=WAALSE(KP) LANDE=GLANDEE(K)*1000.+.5 LANDEP=GLANDEE(KP)*1000.+.5 IF(LANDE.LT.0)LANDE=GLANDEE(K)*1000.-.5 IF(LANDEP.LT.0)LANDEP=GLANDEE(KP)*1000.-.5 ENDIF REF='K07'//EMQ REF='K08'//EMQ REF='K09'//EMQ ASUMASUMP=ASUM+ASUMP IF(ASUMASUMP.EQ.0.D0)ASUMASUMP=1.03D-10 GAMMAR=LOG10(ASUMASUMP) C TRY NOT DIFFERENCING GAMMAS=LOG10(15835.*MAX(ABS(STARK),ABS(STARKP),1.D-20)**.6666667) GAMMAW=LOG10(84762.*MAX(ABS(WAALS),ABS(WAALSP),1.D-40)**.4) C WAVENO=ABS(ABS(E)-ABS(EP)) IF(WAVENO.EQ.0.D0)WAVENO=0.001D0 WLVAC=1.D7/WAVENO WL=MIN(WL,999999.9999D0) WLVAC=MIN(WLVAC,999999.9999D0) WAVENO=MIN(WAVENO,9999999.9999D0) GFLOG=GALOG-LOG10(66702.D9/WLVAC**2) C .LINES WRITE(JT1,140)WL,GALOG,CODE,ELAB,ELABP,GAMMAR,GAMMAS,GAMMAW,REF, 1 NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2,LANDE,LANDEP,ISOSHIFT C .META IF(GAMMAR.LE.2.)THEN WRITE(JT2,140)WL,GALOG,CODE,ELAB,ELABP,GAMMAR,GAMMAS,GAMMAW,REF, 1 NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2,LANDE,LANDEP,ISOSHIFT ENDIF C GA*.POS IF(IFPRED.EQ.1)GO TO 99 WRITE(JT3,140)WL,GALOG,CODE,ELAB,ELABP,GAMMAR,GAMMAS,GAMMAW,REF, 1 NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2,LANDE,LANDEP,ISOSHIFT C GF*.POS WRITE(JT5,140)WL,GFLOG,CODE,ELAB,ELABP,GAMMAR,GAMMAS,GAMMAW,REF, 1 NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2,LANDE,LANDEP,ISOSHIFT C GF*.METAPOS IF(GAMMAR.GT.2.)GO TO 99 WRITE(JT4,140)WL,GFLOG,CODE,ELAB,ELABP,GAMMAR,GAMMAS,GAMMAW,REF, 1 NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1,OTHER2,LANDE,LANDEP,ISOSHIFT 140 FORMAT(F11.4,F7.3,F6.2,2A28, 1 F6.2,F6.2,F6.2,A4,I2,I2,I3,F6.3,I3,F6.3,2A10,2I5,I6) 99 CONTINUE 100 CLOSE(UNIT=IT) CLOSE(UNIT=JT1) CLOSE(UNIT=JT2) CLOSE(UNIT=JT3) CLOSE(UNIT=JT4) CLOSE(UNIT=JT5) 999 CONTINUE CALL EXIT END