Initial commit

1 files changed, 569 insertions, 0 deletions

diff --git a/synthe/rmolecasc.for b/synthe/rmolecasc.for
new file mode 100644
index 0000000..5f01393
--- /dev/null
+++ b/synthe/rmolecasc.for
@@ -0,0 +1,569 @@
+      PROGRAM RMOLECASC
+c     revised 4nov14    cosntatns given D exponents
+c     revised 27jul13   CaH and CrH added
+      IMPLICIT REAL*4 (A-H,O-Z)
+      PARAMETER (kw=99)
+      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,EXTRA1,EXTRA2,EXTRA3
+      REAL*8 LINDAT8(14)
+      REAL*4 LINDAT4(28)
+      EQUIVALENCE (LINDAT8(1),WL),(LINDAT4(1),NELION)
+      REAL*8 RESOLU,RATIO,RATIOLG,SIGMA2,WLBEG,WLEND
+      REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN
+      REAL*8 LABEL,LABELP,OTHER1,OTHER2
+      CHARACTER*8 CLABELP
+      EQUIVALENCE (CLABELP,LABELP(1))
+      CHARACTER*4 CREF
+      EQUIVALENCE (CREF,REF)
+      DIMENSION DECKJ(7,kw)
+C     REAL*4 LOGGR CHANGE TO INTEGER
+      REAL*8 START,STOP
+      REAL*8 ISOLAB(60)
+      DATA ISOLAB/2H 1,2H 2,2H 3,2H 4,2H 5,2H 6,2H 7,2H 8,2H 9,2H10,
+     1            2H11,2H12,2H13,2H14,2H15,2H16,2H17,2H18,2H19,2H20,
+     2            2H21,2H22,2H23,2H24,2H25,2H26,2H27,2H28,2H29,2H30,
+     3            2H31,2H32,2H33,2H34,2H35,2H36,2H37,2H38,2H39,2H40,
+     4            2H41,2H42,2H43,2H44,2H45,2H46,2H47,2H48,2H49,2H50,
+     5            2H51,2H52,2H53,2H54,2H55,2H56,2H57,2H58,2H59,2H60/
+C      OPEN(UNIT=11,TYPE='OLD',FORM='UNFORMATTED',RECORDTYPE='FIXED',
+C     1ACCESS='DIRECT',RECL=16,READONLY,SHARED)
+      OPEN(UNIT=12,STATUS='OLD',FORM='UNFORMATTED',ACCESS='APPEND')
+      OPEN(UNIT=14,STATUS='OLD',FORM='UNFORMATTED',ACCESS='APPEND')
+      READ(93)NLINES,LENGTH,IFVAC,IFNLTE,N19,TURBV,DECKJ,IFPRED,
+     1WLBEG,WLEND,RESOLU,RATIO,RATIOLG,CUTOFF,LINOUT
+      IXWLBEG=DLOG(WLBEG)/RATIOLG
+      IF(DEXP(IXWLBEG*RATIOLG).LT.WLBEG)IXWLBEG=IXWLBEG+1
+      NBLO=0
+      NBUP=0
+      OTHER1(1)=(8H        )
+      OTHER1(2)=(2H  )
+      OTHER2(1)=(8H        )
+      OTHER2(2)=(2H  )
+      LABEL(2)=(2H  )
+      REF=(2HK )
+      ION=1
+      ZEFF=ION
+      START=WLBEG-.1
+      STOP=WLEND+1.
+      STOP1=STOP+1.
+      N=0
+C      READ(11,REC=1)WL
+C      IF(ABS(WL).GT.STOP1)GO TO 21
+CC     FIND NUMBER OF LINES
+C      LIMITBLUE=1
+C      LIMITRED=10000000
+C    8 NEWLIMIT=(LIMITRED+LIMITBLUE)/2
+C      READ(11,REC=NEWLIMIT,ERR=9)WL
+C      LIMITBLUE=NEWLIMIT
+C      IF(LIMITRED-LIMITBLUE.EQ.1)GO TO 11
+C      GO TO 8
+C    9 LIMITRED=NEWLIMIT
+C      IF(LIMITRED-LIMITBLUE.EQ.1)GO TO 11
+C      GO TO 8
+C   11 LENGTHFILE=LIMITBLUE
+C      READ(11,REC=1)WL
+C      PRINT 3334,WL
+C 3334 FORMAT(' FIRST LINE IS      1','  WL',F11.4)
+C      READ(11,REC=LENGTHFILE)WL
+C      PRINT 3335,LENGTHFILE,WL
+C 3335 FORMAT(' LAST LINE IS ',I7,'  WL',F11.4)
+C      IF(ABS(WL).LT.START)GO TO 21
+CC     FIND THE FIRST LINE AFTER START
+C      LIMITBLUE=1
+C      LIMITRED=LENGTHFILE
+C   12 NEWLIMIT=(LIMITRED+LIMITBLUE)/2
+C      PRINT 3333,LIMITBLUE,NEWLIMIT,LIMITRED
+C 3333 FORMAT(3I10)
+C      READ(11,REC=NEWLIMIT)WL
+C      IF(ABS(WL).LT.START)GO TO 13
+C      LIMITRED=NEWLIMIT
+C      IF(LIMITRED-LIMITBLUE.LE.1)GO TO 14
+C      GO TO 12
+C   13 LIMITBLUE=NEWLIMIT
+C      IF(LIMITRED-LIMITBLUE.LE.1)GO TO 14
+C      GO TO 12
+C   14 ISTART=NEWLIMIT
+C      PRINT 3333,LIMITBLUE,LIMITRED,NEWLIMIT
+C      DO 20 ILINE=ISTART,LENGTHFILE
+C      READ(11,REC=ILINE)WL,E,EP,LABEL(1),LABELP(1),GFLOG,XJ,XJP,CODE,
+C     1 ISO,LOGGR
+C
+C
+      print *,'NO FUDGES'
+c     example
+c     print *, 'FUDGE 12C12C=+0.30 12C13C=+0.30 13C13C=+0.30
+c
+c
+c
+C
+C
+      DO 2000 ILINE=1,99999999
+      READ(11,1111,END=2001)WL,GFLOG,XJ,E,XJP,EP,ICODE,LABEL(1),
+     1 LABELP(1),ISO,LOGGR
+ 1111 FORMAT(F10.4,F7.3,F5.1,F10.3,F5.1,F11.3,I4,A8,A8,I2,I4)
+      IF(ABS(WL).GT.STOP1)GO TO 2001
+      IF(IFPRED.EQ.0.AND.E.LT.0.)GO TO 2000
+      IF(IFPRED.EQ.0.AND.EP.LT.0.)GO TO 2000
+      CODE=ICODE
+      WLVAC=ABS(WL)
+      IF(IFVAC.EQ.1)WLVAC=1.E7/ABS(ABS(EP)-ABS(E))
+      IF(WLVAC.LT.START)GO TO 2000
+      IF(N.EQ.0)THEN
+      WRITE(6,6)ILINE
+    6 FORMAT(I10,19H IS FIRST LINE READ)
+      PRINT 3,ILINE,WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL(1),LABELP(1),ISO
+      ENDIF
+      IF(WLVAC.GT.STOP)GO TO 2001
+      GO TO (10,20,99,99,99,99,99,99,99,99,99,120,130,140,150,160,170,
+     1 180,99,99,99,99,99,240,250,260,99,280,290,300,99,99,330,
+     2 99,99,99,99,99,99,400,99,420,430,440,99,460,470,480,490, 500,
+     3 510,520,530,540,99,560,570,580,99,99,99),ISO
+C     H2
+   10 NELION=240
+      FUDGE=0.00
+      IS01=1
+      IS02=1
+      X1=0.
+      X2=-5.
+      GO TO 5000
+C     HD
+   20 NELION=240
+      FUDGE=0.00
+      IS01=1
+      IS02=2
+      X1=0.
+      X2=-4.469
+      GO TO 5000
+  120 IF(CODE.EQ.606.)GO TO 1200
+      IF(CODE.EQ.608.)GO TO 1210
+      IF(CODE.EQ.106.)GO TO 1220
+C     CN
+      NELION=270
+      FUDGE=0.00
+      ISO1=12
+      ISO2=14
+      X1=-.005
+      X2=-.002
+      GO TO 5000
+  130 IF(CODE.EQ.606.)GO TO 1300
+      IF(CODE.EQ.608.)GO TO 1310
+      IF(CODE.EQ.106.)GO TO 1320
+C     CN
+      NELION=270
+      FUDGE=0.00
+      ISO1=13
+      ISO2=14
+      X1=-1.955
+      X2=-.002
+      GO TO 5000
+C     NH
+  140 NELION=252
+      FUDGE=0.00
+      ISO1=1
+      ISO2=14
+      X1=0.
+      X2=-.002
+      GO TO 5000
+C     NH
+  150 IF(CODE.EQ.607.)GO TO 1500
+      NELION=252
+      FUDGE=0.00
+      ISO1=1
+      ISO2=15
+      X1=0.
+      X2=-2.444
+      GO TO 5000
+C     OH
+  160 NELION=258
+      FUDGE=0.00
+      ISO1=1
+      ISO2=16
+      X1=0.
+      X2=-.001
+      GO TO 5000
+C     CO
+  170 NELION=276
+      FUDGE=0.00
+      ISO1=12
+      ISO2=17
+      X1=-.005
+      X2=-3.398
+      GO TO 5000
+  180 IF(CODE.EQ.814.)GO TO 1800
+      IF(CODE.EQ.608.)GO TO 1810
+C     OH
+      NELION=258
+      FUDGE=0.00
+      ISO1=1
+      ISO2=18
+      X1=0.
+      X2=-2.690
+      GO TO 5000
+C     MgH
+  240 NELION=300
+      FUDGE=0.00
+      ISO1=1
+      ISO2=24
+      X1=0.
+      X2=-.105
+      GO TO 5000
+C     MgH
+  250 NELION=300
+      FUDGE=0.00
+      ISO1=1
+      ISO2=25
+      X1=0.
+      X2=-.996
+      GO TO 5000
+C     MgH
+  260 NELION=300
+      FUDGE=0.00
+      ISO1=1
+      ISO2=26
+      X1=0.
+      X2=-.947
+      GO TO 5000
+  280 IF(CODE.EQ.814.)GO TO 2800
+C     SiH
+      ISO1=1
+      ISO2=28
+      NELION=312
+      FUDGE=0.00
+      X1=0.
+      X2=-.035
+      GO TO 5000
+  290 IF(CODE.EQ.814.)GO TO 2900
+C     SiH
+      NELION=312
+      FUDGE=0.00
+      ISO1=1
+      ISO2=29
+      X1=0.
+      X2=-1.331
+      GO TO 5000
+  300 IF(CODE.EQ.814.)GO TO 3000
+C     SiH
+      NELION=312
+      FUDGE=0.00
+      ISO1=1
+      ISO2=30
+      X1=0.
+      X2=-1.516
+      GO TO 5000
+C     C2
+  330 NELION=264
+      FUDGE=0.00
+      ISO1=13
+      ISO2=13
+      X1=-1.955
+      X2=-1.955
+      GO TO 5000
+C     C2
+ 1200 NELION=264
+      FUDGE=0.00
+      ISO1=12
+      ISO2=12
+      X1=-.005
+      X2=-.005
+      GO TO 5000
+C     CaH
+  400 NELION=342
+      FUDGE=0.00
+      ISO1=40
+      ISO2=1
+      X1=-0.013
+      X2=0.
+      GO TO 5000
+C     CaH
+  420 NELION=342
+      FUDGE=0.00
+      ISO1=42
+      ISO2=1
+      X1=-2.189
+      X2=0.
+      GO TO 5000
+C     CaH
+  430 NELION=342
+      FUDGE=0.00
+      ISO1=43
+      ISO2=1
+      X1=-2.870
+      X2=0.
+      GO TO 5000
+C     CaH
+  440 NELION=342
+      FUDGE=0.00
+      ISO1=44
+      ISO2=1
+      X1=-1.681
+      X2=0.
+      GO TO 5000
+C     CaH
+ 4600 NELION=342
+      FUDGE=0.00
+      ISO1=46
+      ISO2=1
+      X1=-4.398
+      X2=0.
+      GO TO 5000
+C     CaH
+ 4800 NELION=342
+      FUDGE=0.00
+      ISO1=48
+      ISO2=1
+      X1=-2.728
+      X2=0.
+      GO TO 5000
+  460 IF(CODE.EQ.120.)GO TO 4600
+C     TiO
+      NELION=366
+      FUDGE=0.00
+      ISO1=16
+      ISO2=46
+      X1=0.
+      X2=-1.101
+      GO TO 5000
+C     TiO
+  470 NELION=366
+      FUDGE=0.00
+      ISO1=16
+      ISO2=47
+      X1=0.
+      X2=-1.138
+      GO TO 5000
+  480 IF(CODE.EQ.120.)GO TO 4800
+C     TiO
+      NELION=366
+      FUDGE=0.00
+      ISO1=16
+      ISO2=48
+      X1=0.
+      X2=-0.131
+      GO TO 5000
+C     TiO
+  490 NELION=366
+      FUDGE=0.00
+      ISO1=16
+      ISO2=49
+      X1=0.
+      X2=-1.259
+      GO TO 5000
+  500 IF(CODE.EQ.124.)GO TO 5010
+C     TiO
+      NELION=366
+      FUDGE=0.00
+      ISO1=16
+      ISO2=50
+      X1=0.
+      X2=-1.272
+      GO TO 5000
+C     VO
+  510 NELION=372
+      FUDGE=0.00
+      ISO1=16
+      ISO2=51
+      X1=0.
+      X2=-0.001
+      GO TO 5000
+C     CrH
+ 5010 NELION=432
+      FUDGE=0.00
+      ISO1=50
+      ISO2=1
+      X1=-1.362
+      X2=0.
+      GO TO 5000
+C     CrH
+  520 NELION=432
+      FUDGE=0.00
+      ISO1=52
+      ISO2=1
+      X1=-0.077
+      X2=0.
+      GO TO 5000
+C     CrH
+  530 NELION=432
+      FUDGE=0.00
+      ISO1=53
+      ISO2=1
+      X1=-1.022
+      X2=0.
+      GO TO 5000
+C     CrH
+ 5400 NELION=432
+      FUDGE=0.00
+      ISO1=54
+      ISO2=1
+      X1=-1.626
+      X2=0.
+      GO TO 5000
+  540 IF(CODE.EQ.124.)GO TO 5400
+C     FeH
+      NELION=444
+      FUDGE=0.00
+      ISO1=54
+      ISO2=1
+      X1=-1.237
+      X2=0.
+      GO TO 5000
+C     FeH
+  560 NELION=444
+      FUDGE=0.00
+      ISO1=56
+      ISO2=1
+      X1=-0.038
+      X2=0.
+      GO TO 5000
+C     FeH
+  570 NELION=444
+      FUDGE=0.00
+      ISO1=57
+      ISO2=1
+      X1=-1.658
+      X2=0.
+      GO TO 5000
+C     FeH
+  580 NEILON=444
+      ISO1=58
+      ISO2=1
+      X1=-2.553
+      X2=0.
+      GO TO 5000
+C     CO
+ 1210 NELION=276
+      FUDGE=0.00
+      ISO1=12
+      ISO2=16
+      X1=-.005
+      X2=-.001
+      GO TO 5000
+C     CH
+ 1220 NELION=246
+      FUDGE=0.00
+      ISO1=1
+      ISO2=12
+      X1=0.
+      X2=-.005
+      GO TO 5000
+C     C2
+ 1300 NELION=264
+      FUDGE=0.00
+      ISO1=12
+      ISO2=13
+      X1=-.005
+      X2=-1.955
+      GO TO 5000
+C     CO
+ 1310 NELION=276
+      FUDGE=0.00
+      ISO1=13
+      ISO2=16
+      X1=-1.955
+      X2=-.001
+      GO TO 5000
+C     CH
+ 1320 NELION=246
+      FUDGE=0.00
+      ISO1=1
+      ISO2=13
+      X1=0.
+      X2=-1.955
+      GO TO 5000
+C     CN
+ 1500 NELION=270
+      FUDGE=0.00
+      ISO1=12
+      ISO2=15
+      X1=-.005
+      X2=-2.444
+      GO TO 5000
+C     SiO
+ 1800 NELION=330
+      FUDGE=0.00
+      ISO1=28
+      ISO2=18
+      X1=-.035
+      X2=-2.690
+      GO TO 5000
+C     CO
+ 1810 NELION=276
+      FUDGE=0.00
+      ISO1=12
+      ISO2=18
+      X1=-.005
+      X2=-2.690
+      GO TO 5000
+C     SiO
+ 2800 NELION=330
+      FUDGE=0.00
+      ISO1=28
+      ISO2=16
+      X1=-.035
+      X2=-.001
+      GO TO 5000
+C     SiO
+ 2900 NELION=330
+      FUDGE=0.00
+      ISO1=29
+      ISO2=16
+      X1=-1.328
+      X2=-.001
+      GO TO 5000
+C     SiO
+ 3000 NELION=330
+      FUDGE=0.00
+      ISO1=30
+      ISO2=16
+      X1=-1.510
+      X2=-.001
+      GO TO 5000
+ 5000 GF=EXP((GFLOG+X1+X2+FUDGE)*2.30258509299405D0)
+      ELO=DMIN1(ABS(E),ABS(EP))
+      IXWL=DLOG(WLVAC)/RATIOLG+.5D0
+      NBUFF=IXWL-IXWLBEG+1
+      FREQ=2.99792458D17/WLVAC
+      CONGF=.01502D0*GF/FREQ
+      FRQ4PI=FREQ*12.5664D0
+      GAMMAR=10.**(LOGGR*.01)
+C     GUESSES
+C     ELECTRON
+      GAMMAS=3.D-5
+      GAMMAW=1.D-7
+C     VIBRATION-ROTATIONAL
+      IF(CLABELP(1:1).EQ.'X')THEN
+      GAMMAS=3.D-8
+      GAMMAW=1.D-8
+      ENDIF
+      GR=LOG10(GAMMAR)
+      GS=LOG10(GAMMAS)
+      GW=LOG10(GAMMAW)
+      GAMRF=GAMMAR/FRQ4PI
+      GAMSF=GAMMAS/FRQ4PI
+      GAMWF=GAMMAW/FRQ4PI
+      WRITE(12)NBUFF,CONGF,NELION,ELO,GAMRF,GAMSF,GAMWF
+   17 FORMAT(I10)
+      IF(NELION.EQ.270)THEN
+C     FIX REFERENCE
+      CREF='K'//CLABELP(7:8)
+      CLABELP=CLABELP(1:6)
+      ENDIF
+      LABELP(2)=ISOLAB(ISO)
+      IF(LINOUT.GE.0)WRITE(14)LINDAT8,LINDAT4
+      N=N+1
+      NLINES=NLINES+1
+ 2000 CONTINUE
+ 2001 WRITE(6,2002)ILINE
+ 2002 FORMAT(I10,18H IS LAST LINE READ)
+ 2005 WRITE(6,2006)N
+ 2006 FORMAT(I10,' LINES ADDED TO TAPE 12')
+      WRITE(6,2007)NLINES
+ 2007 FORMAT(I10,' LINES TOTAL ON TAPE 12')
+      REWIND 93
+      WRITE(93)NLINES,LENGTH,IFVAC,IFNLTE,N19,TURBV,DECKJ,IFPRED,
+     1WLBEG,WLEND,RESOLU,RATIO,RATIOLG,CUTOFF,LINOUT
+   99 PRINT 3,ILINE,WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL(1),LABELP(1),ISO
+    3 FORMAT(I10,1X,F10.4,F7.3,F5.1,F12.3,F5.1,F12.3,F9.2,A8,2X,A8,I2)
+      CALL EXIT
+      END