      PROGRAM DIATOMICPACK
      REAL*8 E,EP,WL,WLVAC,RATIOLG
      INTEGER*2 IELION,IELO,IGFLOG,IGR,IGS,IGW
      INTEGER*4 IWL
      CHARACTER*8 LABEL,LABELP,ISOTOPE
      CHARACTER*2 BAND
C
C     C2AX,C2BA=3B3A,C2DA=3D3A,C2EA=3E3A   12 13 33
C     CaHAX,CaHBX,CaHEX,CAHXX 40 42 43 44 46 48
C     CHAX,CHBX,CHCX,CHXX   12 13
C     CNAX,CNBX,CNXX   12 13 15
C     COAX,COXX   12 13 17 18
C     CrHAX   50 52 53 54
C     FeHFX     54 56 57 58 
C     H2BX,H2CX,H2XX,HDXX    1  2
C     MgHAX,MgHBX 24 25 26
C     NHAX,NHca   14 15
C     OHAX,OHXX   16 17 18
C     SiHAX  28 29 30
C     SIOAX,SIOEX,SIOXX  28 29 30 18
C     VOAX,VOBX,VOCX 51
c
c     example for CNAX 
c     insert under CN     IF(BAND.EQ.'AX')FUDGE=+0.30
c
c     print *,'  CNAX FUDGE=+0.30'
c
      print *,'  NO FUDGES   FUDGE=0.00'
c
c
C     OPEN(UNIT=12,TYPE='NEW',FORM='UNFORMATTED',
C    1RECORDTYPE='FIXED',RECORDSIZE=4)
      OPEN(UNIT=12,STATUS='UNKNOWN',FORM='UNFORMATTED',
     1 RECL=16)
      NLINES=0
      RATIOLG=LOG(1.D0+1.D0/2000000.D0)
      DO 25 LINE=1,99999999
      READ(11,1111,END=33)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)
      CODE=ICODE
      ELO=MIN(ABS(E),ABS(EP))
      BAND=LABELP(1:1)//LABEL(1:1)
      GW=-7.
C     H2
      IF(CODE.EQ.101.)THEN
      IF(ISO.EQ. 1)IELION=8410
      IF(ISO.EQ. 2)IELION=8411
      IF(BAND.EQ.'BX')IBAND=1
      IF(BAND.EQ.'CX')IBAND=2
      IF(BAND.EQ.'XX')IBAND=3
      IF(BAND.EQ.'BX')FUDGE=0.00
      IF(BAND.EQ.'CX')FUDGE=0.00
      IF(BAND.EQ.'XX')FUDGE=0.00
      GO TO 4
      ENDIF
C     CH
      IF(CODE.EQ.106.)THEN 
      IF(ISO.EQ.12)IELION=8460
      IF(ISO.EQ.13)IELION=8461
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'BX')IBAND=2
      IF(BAND.EQ.'CX')IBAND=3
      IF(BAND.EQ.'XX')IBAND=4
      IF(BAND.EQ.'AX')FUDGE=0.00
      IF(BAND.EQ.'BX')FUDGE=0.00
      IF(BAND.EQ.'CX')FUDGE=0.00
      IF(BAND.EQ.'XX')FUDGE=0.00
      GO TO 4
      ENDIF
C     NH
      IF(CODE.EQ.107.)THEN
      IF(ISO.EQ.14)IELION=8470
      IF(ISO.EQ.15)IELION=8471
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'ca')IBAND=2
      IF(BAND.EQ.'AX')FUDGE=0.00
      IF(BAND.EQ.'ca')FUDGE=0.00
      GO TO 4
      ENDIF
C     OH
      IF(CODE.EQ.108.)THEN
      IF(ISO.EQ.16)IELION=8480
      IF(ISO.EQ.18)IELION=8482
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'XX')IBAND=2
      IF(BAND.EQ.'XX')GW=-8.
      IF(BAND.EQ.'AX')FUDGE=0.00
      IF(BAND.EQ.'XX')FUDGE=0.00
      GO TO 4
      ENDIF
C     MgH
      IF(CODE.EQ.112.)THEN
      IF(ISO.EQ.24)IELION=8510
      IF(ISO.EQ.25)IELION=8511
      IF(ISO.EQ.26)IELION=8512
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'BX')IBAND=2
      IF(BAND.EQ.'AX')FUDGE=0.00
      IF(BAND.EQ.'BX')FUDGE=0.00
      GO TO 4
      ENDIF
C     SiH
      IF(CODE.EQ.114.)THEN
      IF(ISO.EQ.28)IELION=8530
      IF(ISO.EQ.29)IELION=8531
      IF(ISO.EQ.30)IELION=8532
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'AX')FUDGE=0.00
      GO TO 4         
      ENDIF
C     CN
      IF(CODE.EQ.607.)THEN 
      IF(ISO.EQ.12)IELION=8690
      IF(ISO.EQ.13)IELION=8691
      IF(ISO.EQ.15)IELION=8692
      IF(ISO.EQ.35)IELION=8693
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'BX')IBAND=2
      IF(BAND.EQ.'XX')IBAND=3
      IF(BAND.EQ.'AX')FUDGE=0.00
      IF(BAND.EQ.'BX')FUDGE=0.00
      IF(BAND.EQ.'XX')FUDGE=0.00
      GO TO 4
      ENDIF
C     MgO
      IF(CODE.EQ.812.)GO TO 25
C
C     AlO
      IF(CODE.EQ.813.)GO TO 25
C
C     NaH
      IF(CODE.EQ.111.)GO TO 25
C
C     CO
      IF(CODE.EQ.608.)THEN 
      IF(ISO.EQ.12)IELION=8700
      IF(ISO.EQ.13)IELION=8701
      IF(ISO.EQ.17)IELION=8702
      IF(ISO.EQ.37)IELION=8703
      IF(ISO.EQ.18)IELION=8704
      IF(ISO.EQ.38)IELION=8705
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'XX')IBAND=2
      IF(BAND.EQ.'XX')GW=-8.
      IF(BAND.EQ.'AX')FUDGE=0.00
      IF(BAND.EQ.'XX')FUDGE=0.00
      GO TO 4
      ENDIF
C     SiO
      IF(CODE.EQ.814.)THEN 
      IF(ISO.EQ.28)IELION=8890
      IF(ISO.EQ.29)IELION=8891
      IF(ISO.EQ.30)IELION=8892
      IF(ISO.EQ.18)IELION=8896
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'EX')IBAND=2
      IF(BAND.EQ.'XX')IBAND=3
      IF(BAND.EQ.'XX')GW=-8.
      IF(BAND.EQ.'AX')FUDGE=0.00
      IF(BAND.EQ.'EX')FUDGE=0.00
      IF(BAND.EQ.'XX')FUDGE=0.00
      GO TO 4
      ENDIF
C     C2
      IF(CODE.EQ.606.)THEN 
      IF(ISO.EQ.12)IELION=8680
      IF(ISO.EQ.13)IELION=8681
      IF(ISO.EQ.33)IELION=8682
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'AX')FUDGE=0.00
      IF(BAND.NE.'33')GO TO 4
      BAND=LABELP(2:2)//LABEL(2:2)
      IF(BAND.EQ.'BA')IBAND=2
      IF(BAND.EQ.'DA')IBAND=3
      IF(BAND.EQ.'EA')IBAND=4
      IF(BAND.EQ.'BA')FUDGE=0.00
      IF(BAND.EQ.'DA')FUDGE=0.00
      IF(BAND.EQ.'EA')FUDGE=0.00
      GO TO 4
      ENDIF
C     VO
      IF(CODE.EQ.823.)THEN
      IF(ISO.EQ.51)IELION=8960
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'BX')IBAND=2
      IF(BAND.EQ.'CX')IBAND=3
      IF(BAND.EQ.'AX')FUDGE=0.00
      IF(BAND.EQ.'BX')FUDGE=0.00
      IF(BAND.EQ.'CX')FUDGE=0.00
      GO TO 4
      ENDIF
C     CrH
      IF(CODE.EQ.124.)THEN     
      IF(ISO.EQ.50)IELION=8620 
      IF(ISO.EQ.52)IELION=8621
      IF(ISO.EQ.53)IELION=8622
      IF(ISO.EQ.54)IELION=8623 
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'AX')FUDGE=0.00
      GO TO 4 
      ENDIF
C     FeH
      IF(CODE.EQ.126.)THEN
      IF(ISO.EQ.54)IELION=8640 
      IF(ISO.EQ.56)IELION=8641 
      IF(ISO.EQ.57)IELION=8642 
      IF(ISO.EQ.58)IELION=8643 
      IF(BAND.EQ.'FX')IBAND=1
      IF(BAND.EQ.'FX')FUDGE=0.00
      GO TO 4
      ENDIF
C     CaH
      IF(CODE.EQ.120.)THEN
      IF(ISO.EQ.40)IELION=8580 
      IF(ISO.EQ.42)IELION=8581 
      IF(ISO.EQ.43)IELION=8582
      IF(ISO.EQ.44)IELION=8583 
      IF(ISO.EQ.46)IELION=8584 
      IF(ISO.EQ.48)IELION=8585 
      IF(BAND.EQ.'AX')IBAND=1
      IF(BAND.EQ.'BX')IBAND=2
      IF(BAND.EQ.'EX')IBAND=3
      IF(BAND.EQ.'XX')IBAND=4
      IF(BAND.EQ.'AX')FUDGE=0.00
      IF(BAND.EQ.'BX')FUDGE=0.00
      IF(BAND.EQ.'EX')FUDGE=0.00
      IF(BAND.EQ.'XX')FUDGE=0.00
      GO TO 4
      ENDIF
   5  WRITE(6,666)NLINES,IWL,IELION,IELO,IGFLOG,IGR,IGS,IGW,
     1WL,wlvac,GFLOG,XJ,E,XJP,EP,icode,LABEL,LABELP,ISO
      CALL EXIT
    4 IF(E.LT.0.)IELION=-IELION
      IF(EP.LT.0.)IELION=-ABS(IELION)
      WLVAC=1.D7/DABS(DABS(E)-DABS(EP))
      IWL=DLOG(WLVAC)/RATIOLG+.5
      GR=LOGGR/100.
      IGR=GR*1000.+16384.5
      IGS=IBAND*1000.+16384.5
      IGW=GW*1000.+16384.5
      IGFLOG=(GFLOG+FUDGE)*1000.+16384.5
      IELO=LOG10(MAX(ELO,1.))*1000.+16384.5
      WRITE(12)IWL,IELION,IELO,IGFLOG,IGR,IGS,IGW
c      WRITE(6,667)IWL,IELION,IELO,IGFLOG,IGR,IGS,IGW
 667  format(i10,6i7)
      NLINES=NLINES+1
      IF(MOD(NLINES,1000).EQ.1)
     1WRITE(6,666)NLINES,IWL,IELION,IELO,IGFLOG,IGR,IGS,IGW,
     2WL,wlvac,GFLOG,XJ,E,XJP,EP,ICODE,LABEL,LABELP,ISO
      IF(NLINES.gt.11594001.and.nlines.le.11594101)
     1WRITE(6,666)NLINES,IWL,IELION,IELO,IGFLOG,IGR,IGS,IGW,
     2WL,wlvac,GFLOG,XJ,E,XJP,EP,ICODE,LABEL,LABELP,ISO
  666 FORMAT(I9,I9,6I7,2F11.4,F7.3,F5.1,F11.3,F5.1,F11.3,I5,2A8,I2)
c      IF(MOD(Nlines,100000).EQ.1)WRITE(7,77)NLINES,IWL,WL
   77 FORMAT(2I10,F10.4)
   25 CONTINUE
   33 WRITE(6,26)NLINES
   26 FORMAT(I10,25H LINES WRITTEN ON TAPE 12)
      WRITE(6,666)NLINES,IWL,IELION,IELO,IGFLOG,IGR,IGS,IGW,
     1WL,wlvac,GFLOG,XJ,E,XJP,EP,ICODE,LABEL,LABELP,ISO
      CALL EXIT
      END
