PROGRAM RMOLECASC
c     revised 16jul18   AlH, ScH, TiH, VH added (lines only for TiH)
c     revised 30sep15   MgO and CaO added
c     revised 27may15   NaH and KH added
c     revised  4nov14    constants given D exponents
c     revised 27jul13   CaH and CrH added
      IMPLICIT REAL*4 (A-H,O-Z)
      PARAMETER (kw=99)
c      COMMON /LINDAT/WL,E,EP,LABEL(2),LABELP(2),OTHER1(2),OTHER2(2),
      COMMON /LINDAT/WL,E,EP,LABEL,LABELP,OTHER1,OTHER2,
     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
c      REAL*8 LINDAT8(14)
c      REAL*4 LINDAT4(28)
      REAL*8 LINDAT8I(3)
      REAL*8 LINDAT8II(3)
      REAL*4 LINDAT4I(4)
      REAL*4 LINDAT4II(23)
c      EQUIVALENCE (LINDAT8(1),WL),(LINDAT4(1),NELION)
      EQUIVALENCE (LINDAT8I(1),WL)
      EQUIVALENCE (LINDAT8II(1),WLVAC)
      EQUIVALENCE (LINDAT4I(1),NELION)
      EQUIVALENCE (LINDAT4II(1),NBLO)
      character*10 LABEL,LABELP,OTHER1,OTHER2
      REAL*8 RESOLU,RATIO,RATIOLG,SIGMA2,WLBEG,WLEND
      REAL*8 WL,E,EP,WLVAC,CENTER,CONCEN
c      REAL*8 LABEL,LABELP,OTHER1,OTHER2
c      CHARACTER*8 CLABELP
      CHARACTER*10 CLABELP
c      EQUIVALENCE (CLABELP,LABELP(1))
      EQUIVALENCE (CLABELP,LABELP)
      CHARACTER*4 CREF,REF
      EQUIVALENCE (CREF,REF)
      DIMENSION DECKJ(7,kw)
C     REAL*4 LOGGR CHANGE TO INTEGER
      REAL*8 START,STOP
c      REAL*8 ISOLAB(60)
      character*2 isolab(60)
      data alpha/0./
      DATA ISOLAB/' 1',' 2',' 3',' 4',' 5',' 6',' 7',' 8',' 9','10',
     1            '11','12','13','14','15','16','17','18','19','20',
     2            '21','22','23','24','25','26','27','28','29','30',
     3            '31','32','33','34','35','36','37','38','39','40',
     4            '41','42','43','44','45','46','47','48','49','50',
     5            '51','52','53','54','55','56','57','58','59','60'/
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=('          ')
      OTHER2=('          ')
c      LABEL(2)=(2H  )
      REF='K   '
      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
c      READ(11,1111,END=2001)WL,GFLOG,XJ,E,XJP,EP,ICODE,LABEL(1),
c     1 LABELP(1),ISO,LOGGR
      READ(11,1111,END=2001)WL,GFLOG,XJ,E,XJP,EP,ICODE,LABEL,
     1 LABELP,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)
c      PRINT 3,ILINE,WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL(1),LABELP(1),ISO
      PRINT 3,ILINE,WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,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,230,240,250,260,270,280,290,300,99,99,330,
     2 99,99,99,99,99,390,400,410,420,430,440,450,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 IF(CODE.EQ.813.)GO TO 1600
      NELION=258
      FUDGE=0.00
      ISO1=1
      ISO2=16
      X1=0.
      X2=-.001
      GO TO 5000
C     CO
  170 IF(CODE.EQ.813.)GO TO 1700
      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
      IF(CODE.EQ.813.)GO TO 1820
C     OH
      NELION=258
      FUDGE=0.00
      ISO1=1
      ISO2=18
      X1=0.
      X2=-2.690
      GO TO 5000
C     NaH
  230 NELION=492
      FUDGE=0.00
      ISO1=1
      ISO2=23
      X1=0.
      X2=0.
      GO TO 5000
  240 IF(CODE.EQ.812.)GO TO 2400
C     MgH
      NELION=300
      FUDGE=0.00
      ISO1=1
      ISO2=24
      X1=0.
      X2=-.105
      GO TO 5000
  250 IF(CODE.EQ.812.)GO TO 2500
C     MgH
      NELION=300
      FUDGE=0.00
      ISO1=1
      ISO2=25
      X1=0.
      X2=-.996
      GO TO 5000
  260 IF(CODE.EQ.812.)GO TO 2600
C     MgH
      NELION=300
      FUDGE=0.00
      ISO1=1
      ISO2=26
      X1=0.
      X2=-.947
      GO TO 5000
C     AlH
  270 NELION=306
      FUDGE=0.00
      ISO1=27
      ISO2=1
      X1=0.000
      X2=0.000
      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     KH
  390 NELION=498
      FUDGE=0.00
      ISO1=39
      ISO2=1
      X1=-0.030
      X2=0.
      GO TO 5000
  400 IF(CODE.EQ.820.)GO TO 4000
C     CaH
      NELION=342
      FUDGE=0.00
      ISO1=40
      ISO2=1
      X1=-0.013
      X2=0.
      GO TO 5000
C     CaO
 4000 NELION=354
      FUDGE=0.00
      ISO1=40
      ISO2=16
      X1=-0.013
      X2=-0.001
      GO TO 5000
C     KH
  410 NELION=498
      FUDGE=0.00
      ISO1=41
      ISO2=1
      X1=-1.172
      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     ScH
  450 NELION=414
      FUDGE=0.00
      ISO1=45
      ISO2=1
      X1=0.
      X2=0.
      GO TO 5000
  460 IF(CODE.EQ.120.)GO TO 4600
      IF(CODE.EQ.122.)GO TO 4610
C     TiO
      NELION=366
      FUDGE=0.00
      ISO1=16
      ISO2=46
      X1=0.
      X2=-1.101
      GO TO 5000
C     CaH
 4600 NELION=342
      FUDGE=0.00
      ISO1=46
      ISO2=1
      X1=-4.398
      X2=0.
      GO TO 5000
C     TiO
 4610 NELION=366
      FUDGE=0.00
      ISO1=16
      ISO2=46
      X1=0.
      X2=-1.101
      GO TO 5000
  470 IF(CODE.EQ.122)GO TO 4700
C     TiH
 4700 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
      IF(CODE.EQ.122)GO TO 4810
C     TiO
      NELION=366
      FUDGE=0.00
      ISO1=16
      ISO2=48
      X1=0.
      X2=-0.131
      GO TO 5000
C     CaH
 4800 NELION=342
      FUDGE=0.00
      ISO1=48
      ISO2=1
      X1=-2.728
      X2=0.
      GO TO 5000
C     TiH
 4810 NELION=420
      FUDGE=0.00
      ISO1=1
      ISO2=48
      X1=0.
      X2=-0.131
      GO TO 5000
  490 IF(CODE.EQ.122.)GO TO 4900
C     TiO
      NELION=366
      FUDGE=0.00
      ISO1=16
      ISO2=49
      X1=0.
      X2=-1.259
      GO TO 5000
C     TiH
 4900 NELION=366
      FUDGE=0.00
      ISO1=1
      ISO2=49
      X1=0.
      X2=-1.259
      GO TO 5000
  500 IF(CODE.EQ.124.)GO TO 5020
      IF(CODE.EQ.122.)GO TO 5010
C     TiO
      NELION=366
      FUDGE=0.00
      ISO1=16
      ISO2=50
      X1=0.
      X2=-1.272
      GO TO 5000
C     TiH
 5010 NELION=366
      FUDGE=0.00
      ISO1=1
      ISO2=50
      X1=0.
      X2=-1.272
      GO TO 5000
C     CrH
 5020 NELION=432
      FUDGE=0.00
      ISO1=50
      ISO2=1
      X1=-1.362
      X2=0.
      GO TO 5000
  510 IF(CODE.EQ.123.)GO TO 5110
C     VO
      NELION=372
      FUDGE=0.00
      ISO1=16
      ISO2=51
      X1=0.
      X2=-0.001
      GO TO 5000
C     VH
 5110 NELION=426
      FUDGE=0.
      ISO1=50
      ISO2=1
      X1=-0.001
      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     AlO
 1600 NELION=324
      FUDGE=0.00
      ISO1=27
      ISO2=16
      X1=-.000
      X2=-0.001
      GO TO 5000
C     AlO
 1700 NELION=324
      FUDGE=0.00
      ISO1=27
      ISO2=17
      X1=-.000
      X2=-3.398
      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     AlO
 1820 NELION=324
      FUDGE=0.00
      ISO1=27
      ISO2=18
      X1=-.000
      X2=-2.690
      GO TO 5000
C     MgO
 2400 NELION=318
      FUDGE=0.00
      ISO1=16
      ISO2=24
      X1=-0.001
      X2=-.102
      GO TO 5000
C     MgO
 2500 NELION=318
      FUDGE=0.00
      ISO1=16
      ISO2=25
      X1=-0.001
      X2=-1.000
      GO TO 5000
C     MgO
 2600 NELION=318
      FUDGE=0.00
      ISO1=16
      ISO2=26
      X1=-0.001
      X2=-.958
      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
C
C     7 april 2015  improved constant from Phil Cargile
C     CONGF=.01502D0*GF/FREQ
      CONGF=.026538D0/1.77245D0*GF/FREQ
C
      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,alpha
   17 FORMAT(I10)
      IF(NELION.EQ.270)THEN
C     FIX REFERENCE
      CREF='K'//CLABELP(7:8)
      CLABELP=CLABELP(1:6)
      ENDIF
c      LABELP(2)=ISOLAB(ISO)
      LABELP(9:10)=ISOLAB(ISO)
c      IF(LINOUT.GE.0)WRITE(14)LINDAT8,LINDAT4
      IF(LINOUT.GE.0)WRITE(14)LINDAT8I,LABEL,LABELP,OTHER1,OTHER2,
     1 LINDAT8II,LINDAT4I,REF,LINDAT4II
      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
c   99 PRINT 3,ILINE,WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL(1),LABELP(1),ISO
   99 PRINT 3,ILINE,WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,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