PROGRAM RH2OSLOW C SLOW VERSION, COMPUTE WAVELENGTHS FROM ENERGY LEVELS C READS PACKED BINARY VERSION OF PARTRIDGE AND SCHWENKE'S H2O LINELIST C AND THEIR ENERGY LEVEL LIST C THROWS AWAY LEVEL INFORMATION IF LINOUT < 0 PARAMETER (kw=99) REAL*8 EH2O(273201) CHARACTER*8 JKK(273201),V1V2V3PS(273201) COMMON /LINDAT/WL,E,EP,LABEL(2),LABELP(2),OTHER1(2),OTHER2(2), 1 WLVAC,CENTER,CONCEN, NELION,GAMMAR,GAMMAS,GAMMAW,REF, 2 NBLO,NBUP,ISO1,X1,ISO2,X2,GFLOG,XJ,XJP,CODE,ELO,GF,GS,GR,GW, 3 DWL,DGFLOG,DGAMMAR,DGAMMAS,DGAMMAW,DWLISO,ISOSHIFT,EXTRA3 REAL*8 LINDAT8(14) REAL*4 LINDAT4(28) EQUIVALENCE (LINDAT8(1),WL),(LINDAT4(1),NELION) REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN,UNPACKWL,WLVAC1 REAL*8 LABEL,LABELP,OTHER1,OTHER2,LABELISO(4) CHARACTER*10 COTHER1,COTHER2,CLABEL,CLABELP EQUIVALENCE (COTHER1,OTHER1(1)),(COTHER2,OTHER2(1)) EQUIVALENCE (CLABEL,LABEL(1)),(CLABELP,LABELP(1)) INTEGER TYPE EQUIVALENCE (GF,G,CGF),(TYPE,NLAST) REAL*8 VACAIR REAL*8 RESOLU,RATIO,RATIOLG,WLBEG,WLEND,RATIOLOG,WLBEG1,WLEND1 REAL*4 DECKJ(7,kw),XISO(4),X2ISO(4) REAL*4 TABLOG(32768),AIRSHIFT(100000) INTEGER*2 IELO,IGFLOG BYTE IELOBYTES(2),IGFLOGBYTES(2),ONEBYTE EQUIVALENCE (IELOBYTES(1),IELO),(IGFLOGBYTES(1),IGFLOG) C 1H1H16O 1H1H17O 1H1H18O 1H2H16O DATA XISO/ .9976, .0004, .0020, .00001/ DATA X2ISO/-0.001, -3.398, -2.690, -5.000/ DATA LABELISO/2H16,2H17,2H18,2H26/ C DO 1 I=1,32768 1 TABLOG(I)=10.**((I-16384)*.001) IF(IFPRED.NE.1)CALL TABVACAIR(AIRSHIFT) READ(48)EH2O,JKK,V1V2V3PS CLOSE(UNIT=48) OPEN(UNIT=11,STATUS='OLD',READONLY,SHARED,FORM='UNFORMATTED', 1RECORDTYPE='FIXED',RECORDSIZE=2,ACCESS='DIRECT') OPEN(UNIT=12,TYPE='OLD',FORM='UNFORMATTED',ACCESS='APPEND') OPEN(UNIT=14,TYPE='OLD',FORM='UNFORMATTED',ACCESS='APPEND') READ(93)NLINES,LENGTH,IFVAC,IFNLTE,N19,TURBV,DECKJ,IFPRED, 1WLBEG,WLEND,RESOLU,RATIO,RATIOLG,CUTOFF,LINOUT RATIOLOG=LOG(1.D0+1.D0/2000000.D0) IXWLBEG=DLOG(WLBEG)/RATIOLG IF(DEXP(IXWLBEG*RATIOLG).LT.WLBEG)IXWLBEG=IXWLBEG+1 N14=0 NBLO=0 NBUP=0 OTHER1(1)=(8H ) OTHER1(2)=(2H ) OTHER2(1)=(8H ) OTHER2(2)=(2H ) LABEL(2)=(2H ) LABELP(2)=(2H ) REF=(4HPART) ISO1=1 X1=0. CODE=10108. DWL=0. DGFLOG=0. DGAMMAR=0. DGAMMAS=0. DGAMMAW=0. DWLISO=0. ISOSHIFT=0 C WLBEG1=WLBEG-1. WLEND1=WLEND+1. N=0 READ(11,REC=1)ILEVELS WLVAC=UNPACKWL(ILEVELS,IE,IEP,EH2O) KWL=WLVAC*10.+.5 WL=WLVAC+AIRSHIFT(KWL) IF(IFVAC.NE.1)WLVAC=WL PRINT 3334,WLVAC 3334 FORMAT(' FIRST LINE IS 1',' WL',F12.4) IF(WLVAC.GT.WLEND1)GO TO 21 LENGTHFILE=65912356 READ(11,REC=LENGTHFILE)ILEVELS WLVAC=UNPACKWL(ILEVELS,IE,IEP,EH2O) WL=VACAIR(WLVAC) IF(IFVAC.NE.1)WLVAC=WL PRINT 3335,LENGTHFILE,WLVAC 3335 FORMAT(' LAST LINE IS ',I9,' WL',F12.4) IF(WLBEG1.GT.WLVAC)GO TO 21 C FIND THE FIRST LINE AFTER ISTART LIMITBLUE=1 LIMITRED=LENGTHFILE 12 NEWLIMIT=(LIMITRED+LIMITBLUE)/2 PRINT 3333,LIMITBLUE,NEWLIMIT,LIMITRED 3333 FORMAT(3I10) READ(11,REC=NEWLIMIT)ILEVELS WLVAC=UNPACKWL(ILEVELS,IE,IEP,EH2O) WL=VACAIR(WLVAC) IF(IFVAC.NE.1)WLVAC=WL IF(WLVAC.LT.WLBEG1)GO TO 13 LIMITRED=NEWLIMIT IF(LIMITRED-LIMITBLUE.LE.1)GO TO 14 GO TO 12 13 LIMITBLUE=NEWLIMIT IF(LIMITRED-LIMITBLUE.LE.1)GO TO 14 GO TO 12 14 ISTART=NEWLIMIT PRINT 3333,LIMITBLUE,LIMITRED,NEWLIMIT WRITE(6,6)ISTART 6 FORMAT(I10,14H IS FIRST LINE) C DO 20 ILINE=ISTART,LENGTHFILE READ(11,REC=ILINE)ILEVELS,IELO,IGFLOG WLVAC=UNPACKWL(ILEVELS,IE,IEP,EH2O) KWL=WLVAC*10.+.5 WL=WLVAC+AIRSHIFT(KWL) IF(IFVAC.NE.1)WLVAC=WL IF(WLVAC.GT.WLEND1)GO TO 21 C IF COMPUTER REQUIRES BYTE ROTATION C ONEBYTE=IELOBYTES(1) C IELOBYTES(1)=IELOBYTES(2) C IELOBYTES(2)=ONEBYTE C ONEBYTE=IGFLOGBYTES(1) C IGFLOGBYTES(1)=IGFLOGBYTES(2) C IGFLOGBYTES(2)=ONEBYTE ISO=1 IF(IE.LT.170626)GO TO 19 ISO=2 IF(IE.LT.200841)GO TO 19 ISO=3 IF(IE.LT.231286)GO TO 19 ISO=4 19 ISO2=ISO+15 IF(ISO2.EQ.19)ISO2=2 X2=X2ISO(ISO) C NELIONNEW=ABS(IELION)/10 C NELION=NELIONOLD(NELIONNEW) C IF(NELION.EQ.0)GO TO 20 NELION=534 c WRITE(6,666)ILINE,IWL,IELION,IELO,IGFLOG,IGR,IGS,IGW,WL c 666 FORMAT(I9,I9,6I8,F11.4) ELO=IELO IXWL=DLOG(WLVAC)/RATIOLG+.5D0 NBUFF=IXWL-IXWLBEG+1 FREQ=2.99792458E17/WLVAC CONGF=.01502*TABLOG(IGFLOG)/FREQ*XISO(ISO) FRQ4PI=FREQ*12.5664 C GAMMAS=0 C LOG GAMMAW=-7 C IGR= IGS=1 IGW=9384 GAMMAR=2.223E13/WLVAC**2*.001 GAMRF=GAMMAR/FRQ4PI C GAMRF=TABLOG(IGR)/FRQ4PI GAMSF=TABLOG(IGS)/FRQ4PI GAMWF=TABLOG(IGW)/FRQ4PI WRITE(12)NBUFF,CONGF,NELION,ELO,GAMRF,GAMSF,GAMWF NLINES=NLINES+1 IF(N.EQ.0)WRITE(6,1919)WLVAC 1919 FORMAT(F12.4) N=N+1 IF(LINOUT.LT.0)GO TO 20 E=EH2O(IE) EP=EH2O(IEP) READ(JKK(IE),'(I2)')JLO XJ=JLO READ(JKK(IEP),'(I2)')JUP XJP=JUP CLABEL=JKK(IE)(1:2)//JKK(IE)(4:5)//JKK(IE)(7:8) CLABELP=JKK(IEP)(1:2)//JKK(IEP)(4:5)//JKK(IEP)(7:8) COTHER1=' '//V1V2V3PS(IE)(1:6) COTHER2=' '//V1V2V3PS(IEP)(1:6) LABELP(2)=LABELISO(ISO) GFLOG=(IGFLOG-16384)*.001 GF=TABLOG(IGFLOG) C GUESS GAMMAR=2.223E13/WLVAC**2*.001 GR=ALOG10(GAMMAR) C GR=(IGR-16384)*.001 C GS=-16.383 GS=-9.99 GW=-7. WRITE(14)LINDAT8,LINDAT4 N14=N14+1 c WRITE(6,144)WL,GFLOG,CODE,E,XJ,LABEL,EP,XJP,LABELP, c 1GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2 C 1GR,GS,GW,REF,NBLO,NBUP,ISO1,X1,ISO2,X2,OTHER1(1),OTHER2 144 FORMAT(F11.4,F7.3,F6.0,F12.3,F5.1,1X,A8,A2,F12.3,F5.1,1X,A8,A2, 1 F6.2,F6.2,F6.2,A4,I2,I2,I3,F7.3,I3,F7.3,A6,A8,A2) 20 CONTINUE 21 WRITE(6,22)N 22 FORMAT(I10,13H IS LAST LINE) WRITE(6,1919)WLVAC 25 WRITE(6,26)NLINES 26 FORMAT(I10,25H LINES WRITTEN ON TAPE 12) REWIND 93 WRITE(93)NLINES,LENGTH,IFVAC,IFNLTE,N19,TURBV,DECKJ,IFPRED, 1WLBEG,WLEND,RESOLU,RATIO,RATIOLG,CUTOFF,LINOUT CALL EXIT END SUBROUTINE TABVACAIR(AIRSHIFT) REAL*4 AIRSHIFT(100000) REAL*8 WLVAC,VACAIR DO 1 IWL=1,1999 1 AIRSHIFT(IWL)=0. DO 2 IWL=2000,100000 WLVAC=IWL*.1 2 AIRSHIFT(IWL)=VACAIR(WLVAC)-WLVAC RETURN END FUNCTION VACAIR(W) IMPLICIT REAL*8 (A-H,O-Z) C W IS VACUUM WAVELENGTH IN NM WAVEN=1.D7/W VACAIR=W/(1.0000834213D0+ 1 2406030.D0/(1.30D10-WAVEN**2)+15997.D0/(3.89D9-WAVEN**2)) C 1(1.000064328+2949810./(1.46E10-WAVEN**2)+25540./(4.1E9-WAVEN**2)) RETURN END FUNCTION UNPACKWL(ILEVELS,IE,IEP,EH2O) REAL*8 EH2O(273201),WAVENO,UNPACKWL BYTE FOURBYTES(4),ONEBYTE(1) EQUIVALENCE (FOURBYTES(1),ILEV) C IF COMPUTER REQUIRES BYTE ROTATION C ILEV=ILEVELS C ONEBYTE=FOURBYTES(1) C FOURBYTES(1)=FOURBYTES(4) C FOURBYTES(4)=ONEBYTE C ONEBYTE=FOURBYTES(2) C FOURBYTES(2)=FOURBYTES(3) C FOURBYTES(3)=ONEBYTE C ILEVELS=ILEV IONE=0 IF(ILEVELS.LT.0)IONE=1 ILEVELS=ABS(ILEVELS) IE=ILEVELS/5500 IEP=IE+(ILEVELS-IE*5500)*2+IONE WAVENO=ABS(EH2O(IEP)-EH2O(IE)) UNPACKWL=1.D7/WAVENO RETURN END