      PROGRAM eqwidt
*
*-----------------------------------------------------------------------
*
* Main program for lte line calculations.
* Calculates equivalent widths for a line list and
* iterate on abundance or computes curve fo growth for each line
* in the list. Line list format identical with bsyn.
* Based on Bsyn (turbospectrum) by BPz 06/07-2000
*
*-----------------------------------------------------------------------
*
      INCLUDE 'spectrum.inc'
      include 'tsuji.par'
*
      parameter (maxim=1000)
      INTEGER    TLUNIT,   LUNIT,alunit
      PARAMETER (TLUNIT=13,alunit=16)
      INTEGER    SPUNIT
      PARAMETER (SPUNIT=15)
      INTEGER    MAXNL,maxfil
      PARAMETER (MAXNL=200,maxfil=100)
      parameter (nmemol=16)
*
      CHARACTER*256 DETOUT,INATOM,INMOD,INLINE,INSPEC,OUTFIL,inabun,
     &              filterfil
      character*80 filttitle,comment
      character*50 MCODE

      real scattfrac,absfrac
      real obs(3),abufact(3),eqwidth(3)
      REAL N,MA,MH,M,L,MUM,NTOT,MAM,MABUND(16),ntt
      REAL XIH,XIHM,XKHM,HJONH,HJONC,HJONN,HJONO,XNECNO
      REAL ABUVC(NDP),ABUVN(NDP),ABUVO(NDP),ABUVS(NDP),ABUVK(NDP)
      doubleprecision ionpot
      DIMENSION
     &          JLEV(NDP/5+1),EMOL(NMEMOL,NDP),BPLAN(NDP),
     &          X(NDP),S(NDP),plez(ndp),contop(ndp)
      doubleprecision XL1,XL2,DEL,XLMARG,XL1L,XL2R,XLBOFF,XLB
      doubleprecision DLAMB0,DOPPLC,DXLAMB,xlb_vshifted(ndp),lshift(ndp)
      CHARACTER*20 LELE
      real newvoigt
      logical formatlong

      COMMON/POP/ N(NDP),A(NDP),DNUD(NDP),STIM(NDP),QUO(NDP),DBVCON
      COMMON/ATOM/ XL,MA,CHI,CHI2,chi3,CHIE,G,IDAMP,FDAMP,
     &             GAMRAD,ALOGC6,ION
      COMMON/ATMOS/ T(NDP),PE(NDP),PG(NDP),XI(NDP),MUM(NDP),RO(NDP),NTAU
      logical hydrovelo,firstiter,strongflag,outofrange,notconvflag(3),
     &        infoonly

      real velocity
      common/velo/velocity(ndp),hydrovelo
      COMMON/CONST/ BOLTZ,MH,H,C,E,M
      COMMON/CQ/ Q1(NDP),Q2(NDP),Q3(NDP),AQ1(3),AQ2(3),TLIM1,TLIM2,
     &           Q1LIM,Q2LIM,AQ3(3),TLIM3,Q3LIM,TQA(3)
      COMMON/TAUC/ TAU(NDP),DTAULN(NDP),JTAU
      COMMON/ROSSC/ ROSS(NDP),cross(ndp)
      COMMON/CWAVES/ XLS
      COMMON/CNUMB/ NTOT(NDP),ntt(ndp),fpartition(ndp),
     &              PH(NDP),HEH,phe(ndp),ph2(ndp)
      COMMON/ATMOL/ NAT,NMOL
      COMMON/MODID/ MCODE
      COMMON/PIECES/ XL1,XL2,DEL,EPS,NMY,NLBLDU,IINT,XMYC,IWEAK
      COMMON/UTPUT/ IREAD,IWRIT
      COMMON/CI5/ MABUND,ANJON(16,5),DUMT(94)
      COMMON/CHECK/ ABURC,ABURN,ABURO,ABURS,ABURK
* COMMONs for the carbon MOL()
      dimension presmo(30)
      COMMON/CMOL1/ EH,FE,FH,FHE,FC,FCE,FN,FNE,FO,FOE,FK,FKE,FS,FSE
      COMMON/CMOL2/ NNMOL,PK(30)
*
* Special for spherical
*
      COMMON /RHOC/RHO(NDP)
      COMMON /CSPHER/NCORE,DIFLOG,RADIUS,RR(NDP)
      COMMON /CSTYR/MIHAL  /CTAUM/TAUM
      logical spherical,limbdark,multidump,skiprelim
*
* extension for large number of wavelengths and lines (monster II)
      character*256 linefil(maxfil),mongofil,filprint
      integer     isotope(5),atom(5)
      character*26   species,blabla

      doubleprecision xlambda
      common/large/ xlambda(lpoint),maxlam,ABSO(NDP,lpoint),
     & absos(ndp,lpoint),absocont(ndp,lpoint)
      real absoscont(ndp,lpoint)
      logical oldpart,Ames,scan2001,oldscan,Barber
      common/oldpart/oldpart
      common/h2ochoice/Ames,scan2001,oldscan,Barber
*
      common/count/icount1,icount2,icount3,icount4
*
* common for continuum lambdas. Nlcont lambdas at
* xlambda(jlcont(1:nlcont)).
      common/continuum/nlcont,jlcont(lpoint)
      real xx(lpoint),yyy(lpoint),zzz(lpoint)

      doubleprecision xlp
      common/babcont/xlp(20*numbset),nlq

* common for damping recipe
      real sigmacross,velexp,xlbr
      character*1 levlo,levup,recipe
      common/damping/sigmacross,velexp,recipe

*
* common for partial pressures
      logical tsuswitch,tsuji,chck
      doubleprecision parptsuji,presneutral,presion,presion2,presion3,
     &                partryck,xmettryck,xiontryck
      common /tsuji/ tsuji,tsuswitch,nattsuji,nmotsuji,
     &               parptsuji(maxim+400)
      character*128 filmet,filmol
      character*20 nametryck
      common /filetsuji/ filmet,filmol
      common /fullequilibrium/ partryck(ndp,maxmol),
     &  xmettryck(ndp,maxmet),xiontryck(ndp,maxmet),nametryck(maxmol)
      common /orderedpress/ presneutral(ndp,100),presion(ndp,100),
     &                      presion2(ndp,100),presion3(ndp,100)
      real rhotsuji,xmytsuji,ejontsuji
      common/rhotsu/ rhotsuji,xmytsuji,ejontsuji

      logical dattsuji,datspherical,datlimbdark,databfind,abfind,
     &        datmultidump,datxifix,datmrxf,dathydrovelo,datpureLTE
      integer datnoffil,datncore,datmaxfil,datmihal,datiint
      real    isoch(100),isochfact(100),datisoch(100),datisochfact(100)
      real    datxmyc,datscattfrac
      character*128 datfilmet,datfilmol,datfilwavel
      character*256 datlinefil(maxfil),datdetout,
     &          datinatom,datinmod,datinabun,datcontinopac,datinpmod,
     &          datinspec,datoutfil,datmongofil,datfilterfil
      doubleprecision   datxl1,datxl2,datdel,datxlmarg,datxlboff
      common/inputdata/datmaxfil,dattsuji,datfilmet,datfilmol,
     &                 datnoffil,datlinefil,
     &                 datspherical,datmihal,dattaum,datncore,
     &                 datdiflog,datdetout,datinatom,
     &                 datinmod,datinabun,datinspec,
     &                 datoutfil,datmongofil,databch(100),
     &                 datlimbdark,datfilterfil,
     &                 datoverall,databfind,
     &                 datmultidump,datisoch,datisochfact,
     &                 dathelium,datalpha,datrabund,datsabund,
     &                 datxifix,datxic,datmrxf,datinpmod,datcontinopac,
     &                 datfilwavel,dathydrovelo,
     &                 datxl1,datxl2,datdel,datxlmarg,datxlboff,
     &                 datiint,datxmyc,datscattfrac,datpureLTE

      real amass(92,0:250),abund(92),fixabund(92),
     &         isotopfrac(92,0:250)
      real overall,alpha,helium,rabund,sabund
      character*2 aname(92)

      common/refabundances/ abund,amass,aname,isotopfrac

      common/filter/limbdark,ifilt,filtlam(1000),filttrans(1000),
     &              filterfil,filttitle
      common/abundch/abch(100)
      real absave(100),symmfactor

******************************************
      integer version
      data version /151/
******************************************
      data nat/92/
      logical newformat
      character oneline*256

ccc      external commn_handler

      tsuswitch =.false.
      Ames=.false.
      scan2001=.false.
      oldscan=.false.
      Barber=.false.
      lunit =23
      chck=.false.
      do k=1,100
        abch(k)=-99.9
      enddo
*
*
      datmaxfil=maxfil
*
      print*
      print*,'***********************'
      print10,version*0.1
10    format(' * EQWIDT version ',f4.1,' *')
      print*,'***********************'
      print*
      call input

*  fraction of the line opacity to count as scattering.
*  Remaining is counted in absorption    BPz 27/09-2002
      scattfrac=datscattfrac
      absfrac=1.0-scattfrac
      if (scattfrac.gt.0.) then
        print*
        print*,' WARNING!!!!! ', scattfrac,' of the line opacity',
     &     ' counted as scattering!!!!!'
        print*
      endif
      tsuji=dattsuji
      filmet=datfilmet
      filmol=datfilmol
      noffil=datnoffil
      do i=1,noffil
        linefil(i)=datlinefil(i)
      enddo
      hydrovelo=dathydrovelo
      spherical=datspherical
      mihal=datmihal
      taum=dattaum
      ncore=datncore
      diflog=datdiflog
      detout=datdetout
      inatom=datinatom
      inmod=datinmod
      inabun=datinabun
      inspec=datinspec
      outfil=datoutfil
      mongofil=datmongofil
      limbdark=datlimbdark
      multidump=datmultidump
      filterfil=datfilterfil
      overall=datoverall
      alpha=datalpha
      rabund=datrabund
      sabund=datsabund
      helium=dathelium
      abfind=databfind
      xl1=datxl1
      xl2=datxl2
      del=datdel
      xlmarg=datxlmarg
      xlboff=datxlboff
      iint=datiint
      xmyc=datxmyc

      print*,' EQWIDT CHECK: xl1= ',xl1
      print*,' EQWIDT CHECK: xl2= ',xl2
      print*,' EQWIDT CHECK: del= ',del
      print*,' EQWIDT CHECK: iint=', iint
      print*,' EQWIDT CHECK: xmyc=',xmyc

      if (abfind) then
* we determine abundance for obseqwidt and obs+-error
        ieqmin=1
        ieqmax=3
      else
* otherwise we only do one computation
        ieqmin=2
        ieqmax=2
      endif

      do i=1,92
        fixabund(i)=databch(i)
        isoch(i)=datisoch(i)
        isochfact(i)=datisochfact(i)
      enddo

      print*,tsuji,filmet(1:index(filmet,' ')),
     &       filmol(1:index(filmol,' ')),
     &       noffil,(linefil(i),i=1,noffil),spherical,
     & mihal,taum,ncore,diflog,detout(1:index(detout,' ')),
     & inatom(1:index(inatom,' ')),inmod(1:index(inmod,' ')),
     & outfil(1:index(outfil,' '))
      do i=1,92
        if (fixabund(i).gt.-90.0) print*,'ab. changed: elt ',
     &      i,fixabund(i)
      enddo
*
* Tsuji molecular equilibrium?
*
      if (tsuji) then
       print*,'   Full molecular equilibrium, using:'
       print*,'     ',filmet(1:index(filmet,' '))
       print*,'     ',filmol(1:index(filmol,' '))
       tsuswitch=.true.
      else
       print*,'   Carbon Marcs molecular equilibrium'
      endif
*
* which kind of file for lines
*
      if (noffil.gt.maxfil) stop 'number of files too large. See maxfil'
      lunit=tlunit
*
* Read info for spherical
*
      print*,' '
      if (spherical) then
        print*,' Transfer treated in the spherical scheme'
      else
        print*,' Transfer treated in the plane parallel approximation'
      endif
      print*,' '
*
      OPEN(UNIT=7,FILE=DETOUT,STATUS='UNKNOWN')
      call clock
cc      OPEN(UNIT=12,FILE=INMOD,STATUS='OLD',recl=4*2*200)
      OPEN(UNIT=12,FILE=INMOD,STATUS='OLD')
cc      OPEN(UNIT=14,STATUS='SCRATCH',FORM='UNFORMATTED',RECL=16384)
      OPEN(UNIT=14,STATUS='SCRATCH',FORM='UNFORMATTED')
cc      open(unit=16,file=inabun,status='old')
cc      OPEN(UNIT=27,STATUS='SCRATCH',FORM='FORMATTED')
ccc      OPEN(UNIT=20,FILE=OUTFIL,STATUS='UNKNOWN',FORM='UNFORMATTED')
cc      OPEN(UNIT=20,FILE=OUTFIL,STATUS='UNKNOWN',FORM='UNFORMATTED',
cc     &     RECL=412)
cc      OPEN(UNIT=66,FILE='sphlimb',STATUS='UNKNOWN',FORM='UNFORMATTED',
cc     &     RECL=412)
      OPEN(UNIT=23,STATUS='SCRATCH',FORM='FORMATTED')
*
* Initiate
*
      open(20,file=outfil,status='unknown')
      if (abfind) then
        print*,'WARNING! You may consider to rerun with the abundances'
        print*,'WARNING! found by eqwidt, in order to have the correct'
        print*,'WARNING! molecular equilibrium.'
        write(20,460)
        write(20,461)
      endif

      IREAD=5
      IWRIT=6
      IP=1
*
      BOLTZ=1.38066E-16
      MH=1.6735E-24
      M=9.1091E-28
      C=2.9979E10
      E=4.80298E-10
      H=6.6256E-27
      constant=SQRT(4.*ATAN(1.))*E*E/M/C
      IDAMP=2
      IELP=0
      IONP=0
*
* NALLIN is total no of lines used; NREJCT total no rejected
*
      NALLIN=0
      NREJCT=0
*
* DBVCON depthconstant doppler broadening velocity, if zero then micro-
* turbulence is used.
*
      DBVCON=0.0
*
* get abundances and scale them by overall. Then
* if appropriate replace by fixabund.
* for molecular equilibrium calculation and damping
*
      call makeabund(overall,alpha,helium,rabund,sabund,fixabund,
     &                  abund,amass,aname,isotopfrac)

ccc      OPEN(UNIT=11,FILE=INATOM,STATUS='OLD')
      print*,'metallicity changed by ',overall,' dex'
      do i=2,92
        if (abund(i).lt.-28.) then
          abund(i)=0.0
        else
          abund(i)=10**(abund(i)-abund(1))
        endif
      enddo
      abund(1)=1.00
* change isotopic mixture if appropriate
      do i=1,100
        if (isoch(i).gt.0.) then
          write(blabla,'(f6.3,20x)') isoch(i)
          print*,blabla
          call getinfospecies(blabla,iel,natom,atom,isotope)
          if (natom.gt.1)  then
            print*,'eqwidt: error in isotope specification',isoch(i)
            stop
          endif
          print*,'ISOTOPIC fraction changed from ',
     &            isotopfrac(atom(1),isotope(1))
          isotopfrac(atom(1),isotope(1))=isochfact(i)
          print*,'to ',isotopfrac(atom(1),isotope(1)),' for element ',
     &            atom(1)
        endif
      enddo
*
      mabund(1)=abund(1)
      mabund(2)=abund(2)
      mabund(3)=abund(6)
      mabund(4)=abund(7)
      mabund(5)=abund(8)
      mabund(6)=abund(10)
      mabund(7)=abund(11)
      mabund(8)=abund(12)
      mabund(9)=abund(13)
      mabund(10)=abund(14)
      mabund(11)=abund(16)
      mabund(12)=abund(19)
      mabund(13)=abund(20)
      mabund(14)=abund(24)
      mabund(15)=abund(26)
      mabund(16)=abund(28)
      HEH=MABUND(2)
      ABURC=MABUND(3)
      ABURN=MABUND(4)
      ABURO=MABUND(5)
      ABURS=MABUND(11)
      ABURK=MABUND(10)
*
* Calculate grams of hydrogen/grams of stellar matter (ABUNDH)
*
      WGT=1.008+4.003*HEH+12.01*ABURC+14.01*ABURN+16.00*ABURO+
     &    20.183*MABUND(6)+22.9898*MABUND(7)+24.312*MABUND(8)+
     &    26.9815*MABUND(9)+28.086*MABUND(10)+32.064*MABUND(11)+
     &    39.102*MABUND(12)+40.08*MABUND(13)+51.996*MABUND(14)+
     &    55.847*MABUND(15)+58.71*MABUND(16)
      ABUNDH=1.008/WGT
      print*,'old abundh:',abundh
*
* Start reading data on lines to be calculated
*
* IP>=1 gives lots of printout, IP=0 less, IP=2 gives some on term.
* The spacing of points is proportional to DOPPLC
* NL is the number of points
*
cc      call cstrip(alunit,27)
cc      READ(27,101) IP,EPS
      ip=0
      eps=0.0001
      iweak=0
      nmy=6
*
      if (iint.gt.0.and.spherical) then
        print*,'Spherical Eqwidt cannot be run in intensity mode.'
        Stop
cc        print*,'WARNING! Running in flux mode this time.'
cc        iint=0
      endif

      IF(ABS(XLMARG).LT.1.E-6) XLMARG=5.0000
      XLM=(XL1+XL2)/2.
      XL1L=XL1-XLMARG
      XL2R=XL2+XLMARG
      do 400 j=1,lpoint
       do 401 k=1,ndp
        abso(k,j)=0.0
        absos(k,j)=0.0
        absocont(k,j)=0.0
        absoscont(k,j)=0.0
401    continue
400   continue

*
* EPS tells which small l/kappa is neglected.
* XLM is a characteristic wavelength
* XL1L is the left consideration limit for lines
* XL2R is the right consideration limit for lines
*
cc      IF(EPS.LE.0.0) EPS=0.0001
cc      READ(27,102) XITE5
      xite5=0.0
      xlboff=0.0
cc      READ(27,109) XLBOFF
      if (xlboff.lt.1.e-6) xlboff=0.0
*
* XITE5  is depth independent microturbulence parameter in
* km/s. If this is zero or unspecified, XI is taken from
* model file, read by subr. READMO.
* XLBOFF is the wavelength offset for each line (Angstroms)
*
* Next read model atm. and continuous abs. coeffs. at XLM
* readmo also interpolates the continuous opacities to all the
* lambdas . They are put into absos and abso. the wavelengths that
* were used in babsma for the calculation of the cont. opacities
* are put into xlp.
*
* We provide a single fake xlm lambda for continuum.
      maxlam=-200
      xlm=(xl1+xl2)*0.5e0
      CALL READMO(XLM,X,S)
* call again to get continuum absorption and scattering coefficients
* in abso and absos (common "large") at the xlp wavelengths of babsma.

      do i=1,nlq
        xlambda(i)=xlp(i)
      enddo
      maxlam=nlq
      call readmo(xlm,x,s)
      maxlam=-200
      do i=1,nlq
        do k=1,ntau
          absocont(k,i)=abso(k,i)
          absoscont(k,i)=absos(k,i)
        enddo
      enddo
*
* X  is kappa/stndop,
* S  is sigma/stndop
* at all depths of the model, at wavelength xlm.
* the complete description of the continuum absorption is in
* absocont (pure absorption) and absoscont (scattering) at
* wavelengths xlp. They are also
* divided by stndop. They are computed in readmo.
* stndop is called ross in this routine and is not ross.
*
      WRITE(7,237) MCODE(1:lenstr(mcode))
      IF(IP.EQ.0) WRITE(7,303)
      NLEV=0
      DO 25 K=1,NTAU,5
        NLEV=NLEV+1
        JLEV(NLEV)=K
   25 CONTINUE
      JLEV0=NTAU
      IF(XITE5.GT.0) THEN
        XITE=XITE5*1.E5
        DO 318 K=1,NTAU
          XI(K)=XITE
318     CONTINUE
      END IF
* Calculate number densities of molecules, put in EMOL()
*
      tp=1.e6
      pep=-1.
      print*,'eqwidt; k, pgmod, pg_calc, romod, ro_calc'
      do 43 k=1,ntau
        if ((abs((t(k)-tp)/t(k)).lt.3.e-2).and.
     &      (abs((pe(k)-pep)/pe(k)).lt.0.6)) then
          skiprelim=.true.
        else
          skiprelim=.false.
        endif
        tp=t(k)
        pep=pe(k)
        call eqmol_pe(t(k),pg(k),pgpg,pe(k),1.,1.,k,niter,skiprelim)
c        print*,'eqmol_pe calculated ',niter,' iterations'
c        print*,k,pg(k),pgpg,ro(k),rhotsuji

ccc      write(*,'(i3,15e10.3,/,3x,15e10.3)') k,presmo
*
        PH(K)=presneutral(k,1)
        phe(k)=presneutral(k,2)
        ph2(k)=partryck(k,2)
43    continue
      abundh=1./xmytsuji
      print*,'new abundh:',abundh
*
*
* molecules in presmo/partryck:
*        I=1 H-, 2 H2, 3 H2+, 4 H2O, 5 OH, 6 CH, 7 CO, 8 CN, 9 C2, 10 N2,
*         11 O2, 12 NO, 13 NH, 14 C2H2, 15 HCN, 16 C2H, 17 -, 18 HS
*         19 SIH, 20 C3H, 21 C3, 22 CS, 23 SIC, 24 SIC2, 25 NS
*         26 SIN, 27 SIO, 28 SO, 29 S2, 30 SIS etc etc (see takemolec.f)
*
* molecules present in atomda are:
*  CN, CH, C2, H2O, OH, NH, CO, N2, O2, H2, TiO, MgH,ZrO, HF
*                   et VO (12/2/96)
*                   et CaH (1/4/96) etc etc
*
* Here great loop over all elements and lines starts
*
* first, loop over line files
*

      do 98 ifil=1,noffil
*
        inline=linefil(ifil)
        OPEN(UNIT=13,FILE=INLINE,STATUS='old')
        call clock
        print*,' starting scan of linelist'
    1   CONTINUE
* security:
        ibadc6=0
        iel=-1
        ion=-1
        nline=0
*
        ielp=0
        read(lunit,*,end=9874) species,ion,nline
        read(lunit,*) comment
        call getinfospecies(species,iel,natom,atom,isotope)
* find out if Ames H2O or Joergensen's
        if (iel.eq.10108) then
          do ic=1,77
            if (comment(ic:ic+3).eq.'Ames') then
              Ames=.true.
              print*,'H2O line list from Ames. Using their partf.'
            endif
          enddo
          do ic=1,75
            if (comment(ic:ic+5).eq.'Barber') then
              Barber=.true.
              print*,'H2O line list from Barber.  Using their partf.'
            endif
          enddo
          do ic=1,73
            if (comment(ic:ic+7).eq.'scan2001') then
              scan2001=.true.
              print*,'H2O line list from SCAN2001. Using their partf.'
            endif
          enddo
          do ic=1,74
            if (comment(ic:ic+6).eq.'oldscan') then
              oldscan=.true.
              print*,'H2O line list from old SCAN. Using their partf.'
            endif
          enddo
        endif

* H I lines with Stark broadening. Special treatment.
        if (iel.eq.1) then
          print*,'eqwidt cannot treat H I lines '
          print*,' in particular the normalizing with the continuum '
          print*,' opacity is not made at the right wavelength'
          print*,' Also, iteration on abundance is not done'
          stop
ccc          lele='H '
ccc          print 1234,species,lele,iel,ion,(isotope(nn),nn=1,natom)
ccc          print*, 'nlines ', nline
ccccc          call Hlineadd(lunit,nline,xlboff)
ccc          call hydropac(lunit,xlboff)
ccc          goto 9874
        endif

*default fdamp (may be changed for each element further down)
****        if (iel.gt.92) then
****          fdamp=0.
****        else
****          fdamp=2.0
****        endif
        g=1.
ccc        raddmp=0.0
* new element. we must compute more in depth
        oldpart=.false.
        symmfactor=1.e0
        IF(IEL.LE.0) GOTO 9874
*
* IEL  is identification of the species (e.g. 3 = Li, 822 = TiO, 10108 = H2O)
*      defined in getinfospecies.
*
* ION  is the stage of ionization (=1 for neutral atoms or
*      molecules, 2 for singly ionized species etc)
*
*The abundance is by default the
* Anders and Grevesse abundance stored in makeabund.f)
* scaled by overall, helium, etc (see options in input.f).
* This value may be overwritten by using ABCHANGE in input file.
*
* We don't read the atomic/molec data table anymore (atomda): abunp not used.
* Partition functions
* come now from partf and molecpartf. Chi, chi2, chi3 come from partf.f for
* atoms (Irwin data tables).
* CHI is not needed for molecules anymore! as we don't want to use the
* Unsoeld recipe for vanderWaals broadening.
* Finally the mass is computed here.
*
ccc        CALL ATOMDA(IEL,LELE,CHI,CHI2,MAM,ABUNP)

        if (iel.le.92) then
          lele=aname(iel)
        else
          call getlele(iel,ion,lele)
        endif
        mam=0.
        do i=1,natom
* compute mass for isotopomer. If isotope is not specified (isotope=0),
* then standard mix is assumed, with mass=amass(atom(i),0)
          mam=mam+amass(atom(i),isotope(i))
        enddo
        MA=MAM*1.6603E-24
        print*,'Mass used for lines of ',iel,lele,' is ', mam

        print 1234,species,lele,iel,ion,(isotope(nn),nn=1,natom)
        print*, 'nlines ', nline
1234    format('species: ',a17,1x,a20,' iel: ',i8,' ion: ',i2,
     &         ' isotopes: ',5i3)
        print*,comment
        if (iel.le.92) then
          ABUL=abund(iel)
          abunp=abund(iel)
        else
* abunp is used when searching for abundance from equivalent width.
* we arbitrarily set it to zero for molecules that don't have "abundances".
* This avoids "inf" in output
          abunp=1.e-12
        endif
* Test for molecular list format
* partly allows backward compatibility for pre-v14.1 format molecular line lists
* can compute eqw for molecules, but not iterate on "abundance" as there is no eqw in the input
* So, abfind should be .false.
        if (iel.gt.92) then
          read(lunit,'(a)') oneline
          backspace(lunit)
          read(oneline,*,err=11,end=11) xlb,chie,gfelog,fdamp,gu,
     &                raddmp,levlo,levup,obseqw,eqwerror
          newformat=.true.
          goto 12
11        newformat=.false.
12        continue
        else
          newformat=.true.
        endif
*
* Start wavelength loop
*
      ILINE=0
      NALLIN=NALLIN+NLINE
*
* NLINE is the number of lines of the element IEL.
*
***************************************************************
*
*
***************************************************************
*
* Big jump to 64 from far below, line loop.
*
   64 CONTINUE
      DGFE=0.
*
* Loop for reading the lines
*
   50 CONTINUE
ccc        IF(IP.LE.0) WRITE(7,303)
ccc        IF(IP.LE.0) WRITE(7,302) LELE,ION,XLB,CHIE,XITE5,FDAMP,GFELOG
      IF(ILINE.EQ.NLINE) then
        print*,iline,' considered for element ',iel,ion
        print*,ibadc6,' lines rejected because of negative c6'
        GOTO 1
      ENDIF
*
* Now read the line data
*
* XLB= wavelength
* CHIE= excitation pot (in eV) of lower level
* GFELOG= log(gf)
* GU the upper statistical weight for the line, is only of
*    importance for damping and if raddmp is not 0.
* FDAMP  is a fudge factor to increase damping constant
* RADDMP externaly calculated radiation damping (if needed)
* f = f-value (as g=1., f is in fact gf-value).
*
* warning! xlb is real*8
*
* new format for molecules, identical to that for atoms, starting with v14.1
      if (newformat) then
        read(lunit,*) xlb,chie,gfelog,fdamp,gu,raddmp,levlo,levup,
     &                obseqw,eqwerror
      else
* allows backward compatibility for older format molecular line lists
        read(lunit,*) xlb,chie,gfelog,fdamp,gu,raddmp
      endif
      outofrange=.false.
*
* first, reject line if outside the wavelength range of babsma.
      if (xlb.le.xl1.or.xlb.ge.xl2) then
cc        print*,' line out of range for continuous opacity. Dropped.'
        outofrange=.true.
        abufact(2)=1.0
        NREJCT=NREJCT+1
        goto 2345
      endif
*
cc      if (iel.le.nat) then
      velexp=0.0
      sigmacross=0.0
      if (obseqw.gt.0.) then
        obs(1)=max(obseqw-eqwerror,0.1)
        obs(2)=obseqw
        obs(3)=obseqw+eqwerror
        if (eqwerror.le.0.0) then
* do only one computation for that one, at nominal abundance.
          ieqmin=2
          ieqmax=2
        endif
      else
        obs(1)=0.0
        obs(2)=0.0
        obs(3)=0.0
      endif
cc      endif
*
      f=10**(gfelog)
      xlb=xlb+xlboff

      if (.not.abfind.or.obseqw.gt.0.0) then
*
* if abfind and obseqw=0. we skip the line and do not output anyhting
* see tag "123" below
* Otherwise,
*   start line calculations
*
      if (IEL.ne.IELP) then
*
* Calculate abundance of molecule/atom per gram stellar matter
*
        symmfactor=1.e0
        infoonly=.false.
        if (iel.gt.nat) then
          molindex=0
          infoonly=.true.
          call takemolec(1,infoonly,lele,molindex)
          if (lele.eq.'C C                 ') then
            if ((isotope(1).eq.12.and.isotope(2).eq.13).or.
     &          (isotope(2).eq.12.and.isotope(1).eq.13)) then
              symmfactor=2.
              print*,' SYMMFACTOR = 2 for 12C13C'
            else if ((isotope(1).eq.12.and.isotope(2).eq.12).or.
     &               (isotope(1).eq.13.and.isotope(2).eq.13)) then
              symmfactor=1.
            else
              stop 'Bsyn: Problem with C2 isotopic mix!!'
            endif
          endif
          if (molindex.eq.0) then
           print*,'eqwidt: molecular species not implemented in atomda',
     &           lele
            stop
          endif
          do k=1,ntau
            ntot(k)=partryck(k,molindex)/boltz/t(k)/ro(k)*symmfactor
            ntt(k)=partryck(k,molindex)/boltz/t(k)/ro(k)*symmfactor
          enddo
          call partffordepth(ntau,t,lele,fpartition)
        else
          do k=1,ntau
            if (presneutral(k,iel).ge.0.) then
              ntot(k)=(presneutral(k,iel)+presion(k,iel)+
     &                 presion2(k,iel)+presion3(k,iel))/
     &               boltz/t(k)/ro(k)
              if (ion.eq.1) then
                ntt(k)=presneutral(k,iel)/boltz/t(k)/ro(k)
              else if (ion.eq.2) then
                ntt(k)=presion(k,iel)/boltz/t(k)/ro(k)
              else if (ion.eq.3) then
                ntt(k)=presion2(k,iel)/boltz/t(k)/ro(k)
              else if (ion.eq.4) then
                ntt(k)=presion3(k,iel)/boltz/t(k)/ro(k)
              endif
              call partf(iel,1,t(k),1,fpartition(k),ionpot)
              chi=ionpot
              call partf(iel,2,t(k),1,fpartition(k),ionpot)
              chi2=ionpot
              call partf(iel,3,t(k),1,fpartition(k),ionpot)
              chi3=ionpot
              call partf(iel,ion,t(k),1,fpartition(k),ionpot)
            else
              if (k.eq.1) then
                print*,'element not present in chemical equilibrium',
     &          ' adopted abundance: ',log10(abunp)+12.
              endif
              ntot(k)=abunp*abundh/mh
              ntt(k)=-1.0
            endif
          enddo
        endif

        do k=1,ntau

* prepare line shift vs. depth, from velocity in model (in cm/s)
* velocity in model should be positive outwards.
* If xlb_vshifted is the wavelength in the observer's frame at which
* the line position is shifted [(lambda_0-lambda)/lambda_0=v/c],
* xlb_vshifted=xlb*lshift, with lshift calculated here:

          lshift(k)=1.d0-velocity(k)/2.99792458d10

          do i=1,natom
            ntot(k)=ntot(k)*isotopfrac(atom(i),isotope(i))
            ntt(k)=ntt(k)*isotopfrac(atom(i),isotope(i))
            if (ntot(k).eq.0.) then
              print*,'eqwidt. WARNING!, ntot=0 for species: ',lele
              print*,'atom=',atom(i),' isotope=',isotope(i)
              print*,'isotopfrac =',isotopfrac(atom(i),isotope(i))
            endif
          enddo
***          ntot(k)=max(ntot(k),1.e-30)
        enddo

      endif
*
* Print line information
*
ccc      IF(IP.GE.1) WRITE(7,990)IEL,ION,NMY,FDAMP,IINT,IMY,MAM,ABUL,
ccc     &                       CHI,XITE
      CHIU=CHIE+3.40*3647./XLB
      if (iel.le.nat) then
        XIONP=CHI
        IF(ION.EQ.2) XIONP=CHI2
        IF(ION.EQ.3) XIONP=CHI3
        IF(ION.GT.3) THEN
          PRINT *,
     &       '*****************************************************'
          PRINT *,
     &       'Error in Eqwidt, ION.GT.3 which has not been foreseen'
          PRINT *,
     &       '*****************************************************'
          STOP '***** Eqwidt *****'
        END IF
      endif
*
* Calculate damping parameters
*
      if (fdamp.ge.20.) then
*
* BPz 02/06-2014
* 1) use ABO theory (Anstee, Barklem, O'Mara) for collisional damping with H,
* with data taken from line list: fdamp contains sigma.alpha.
* This number is available starting with VALD3 version of the VALD database.
* See : http://www.astro.uu.se/~barklem/howto.html
* 2) if (1) not available check if something can be computed in the anstee.f
* routine
* 3) if (2) not available, check in linelist for a gamma6 at 10000K
* 4) if nothing else worked, comput Unsoeld approximation.
*
        sigmacross=int(fdamp)
        velexp=fdamp-int(fdamp)
        recipe='S'
*
      else IF (FDAMP.GT.0..and.fdamp.lt.20.) THEN
* We may use Unsoeld theory with fudge factor fdamp, and prepare for it.
        XXXXX=ION**2*(1./(XIONP-CHIU)**2-1./(XIONP-CHIE)**2)
      END IF

      if (RADDMP.NE.0.) then
*       Use radiative damping data in line list if available
        GAMRAD=RADDMP
      else
*       default recipe for radiative damping
        GAMRAD=6.669E15*G*F/(GU*XLB**2)
      endif

      XL=XLB*1.D-8
*
* check whether there are quantum mechanical damping data for this line
*  (atoms only)
* Unsoeld recipe for atomic lines is default, but Barklem et al.'s treatment
* may be set in anstee.f
* we should not use the Unsoeld recipe for collisional broadening of molecular lines!
*
      if (iel.le.nat) then
        xlbr=xlb
        idamp=2
        if (fdamp.lt.20.) then
*
* We call anstee only if we don't have quantum mechanical collisional data
* in the line list
*
          call anstee(iel,ion,xlbr,chie,xionp,sigmacross,velexp,levlo,
     &              levup,recipe)
        endif
        if (recipe.eq.'U') then
* if the transition collisional broadening is not handled by anstee.f (e.g.
* for x ->x transitions), we have recipe='U' (Unsoeld approximation)
* However we may have gamma van der Waals data in the line list, which we then use

          if (fdamp.lt.0.) then
* fdamp contains log(gammavdW at 10000K) instead of the fudge factor for Unsoeld
* recipe. BPz 08/04-2013

            recipe='W'
          else if (xxxxx.le.0.) then
* skip the line
            ibadc6=ibadc6+1
            NALLIN=NALLIN-1
            NLINE=NLINE-1
            NREJCT=NREJCT+1
            goto 50
          else
* Unsoeld approximation
            ALOGC6=ALOG10(XXXXX)-29.7278
          endif
          ALOGC6=ALOG10(XXXXX)-29.7278
        endif
      else
        idamp=2
ccc        recipe='U'
ccc        recipe='T'
        recipe='R'
* we cannot use Unsoeld recipe for molecules !
* 'R' is for pure radiative damping
      endif
*
* Calculate occupation numbers
*
   54 CONTINUE
      CALL DEPTH(IEL)
      IELP=IEL
      IONP=ION
cc      IF(IP.GE.1) WRITE(7,230)
cc      DBVK=XL*1.E-05
cc      DO 6 JJ=1,NTAU,10
cc        DBV=DBVK*DNUD(JJ)
cc        IF(IEL.LE.NAT)  ANTEL=N(JJ)/(ABUND/MH/MUM(JJ))
cc        IF(IEL.GT.NAT) ANTEL=N(JJ)/NTOT(JJ)
cc        PARTK=Q1(JJ)
cc        IF(ION.EQ.2) PARTK=Q2(JJ)
cc        IF(IP.GE.1) WRITE(7,231)JJ,TAU(JJ),QUO(JJ),ANTEL,A(JJ),
cc     &                         PARTK,DBV,STIM(JJ),XC(JJ),S(JJ)
cc  6   CONTINUE
      DLAMB0=DOPPLC*DNUD(JLEV0)*XL**2/C
*
* Constants
*
      CALF=constant*F
*
cc      IF(FDAMP.GT.0..AND.IP.GE.1) WRITE(7,267) GAMRAD,ALOGC6
cc      IF(IP.GE.1) WRITE(7,265) LELE,ABUL,ABUND,NTAU
      do 111 j=1,ntau
       plez(j)=n(j)*stim(j)/dnud(j)/ross(j)
       xlb_vshifted(j)=xlb*lshift(j)
111   continue
*
* Start wavelength loop for this line
*
* Reference opacity for line contribution
      xlmb=xlb
      call readmo(xlmb,x,s)
      do j=1,ntau
cc        contop(j)=x(j)+s(j)
        contop(j)=x(j)
      enddo

      strongflag=.false.

      do ieq=ieqmin,ieqmax

      notconvflag(ieq)=.false.
      firstiter=.true.
      iterabu=1
      if ((ieq.eq.1).or.(ieqmin.eq.ieqmax)) then
        abufact(ieq)=1.0
      else
        abufact(ieq)=obs(ieq)/eqwidth(ieq-1)/1000.*abufact(ieq-1)
      endif
      abufactold=2.0

9876  continue
      lmin=1
      lmax=1
      do iloop=int(lpoint/2)+1,lpoint,1
        xkmax=0.
        i=iloop-int(lpoint/2)-1
        xlambda(iloop)=xlb+float(i)*del
        if (xlambda(iloop).gt.xl2) then
          lmax=iloop-1
          goto 155
        endif
        vt=(float(i)*del)*1.d-8
        vt=c*vt/xl**2
        do j=1,ntau
          v=vt/dnud(j)
c         CALL VOIGT(A(j),V,HVOIGT)
          hvoigt=newvoigt(a(j),v)
          l=calf*hvoigt*plez(j)
          l=l*abufact(ieq)
          ABSO(j,iloop)=l*absfrac
          absos(j,iloop)=l*scattfrac
          xkmax=max(xkmax,l/contop(j))
        enddo
        lmax=iloop
        if (xkmax.lt.eps) goto 15
      enddo
155   continue
      print*,' element: ', lele, ion
      print*,' the line may still contribute at ',xl2
      print*,' central lambda: ',xlmb
      print*,' abufact: ',abufact(ieq)
      print*,' obseqw: ',obs(ieq),' eqwidth: ',eqwidth(ieq)
      strongflag=.true.
cc      goto 2345

15    CONTINUE
* and now the other side of the profile
      do iloop=int(lpoint/2),1,-1
        xkmax=0.0
        i=int(lpoint/2)+1-iloop
        xlambda(iloop)=xlb-float(i)*del
        if (xlambda(iloop).lt.xl1) then
          lmin=iloop+1
          goto 165
        endif
        vt=(float(i)*del)*1.d-8
        vt=c*vt/xl**2
        do j=1,ntau
          v=vt/dnud(j)
c         CALL VOIGT(A(j),V,HVOIGT)
          hvoigt=newvoigt(a(j),v)
          l=calf*hvoigt*plez(j)
          l=l*abufact(ieq)
          ABSO(j,iloop)=l*absfrac
          absos(j,iloop)=l*scattfrac
          xkmax=max(xkmax,l/contop(j))
          lmin=iloop
        enddo
        if (xkmax.lt.eps) goto 16
      enddo
165   continue
      print*,' element: ', lele, ion
      print*,' the line may still contribute at ',xl1
      print*,' central lambda: ',xlmb
      print*,' abufact: ',abufact(ieq)
      print*,' obseqw: ',obs(ieq),' eqwidth: ',eqwidth(ieq)
      strongflag=.true.
cc      goto 2345

16    CONTINUE
*
cc      print*, 'EQWIDT: Line at ', sngl(xlb)
cc      print*, 'EQWIDT: lambda min and max ',
cc     &       lmin,lmax,sngl(xlambda(lmin)),sngl(xlambda(lmax))
*
      rewind(14)
*
* Continuum points for continuum flux calculations
* Calculate planck function.
* We catch the wavelengths from the continuum points of
* babsma. At these caught lambdas the continuum flux or intensity
* will be computed, and then interpolated to the other lambdas.
      nlq1=1
      nlq2=1
      i=1
      do while (xlp(i).lt.xlambda(lmin))
        nlq1=i
        i=i+1
      enddo
      i=nlq1
      nlq2=nlq1
      do while (xlp(i).le.xlambda(lmax).and.i.le.nlq)
        nlq2=i
        i=i+1
      enddo
      nlq2=min(nlq2+1,nlq)

      nlcont=nlq2-nlq1+1

cc      print*,'eqwidth check: line at ', xlb
cc      print*,'eqwidth check: ',nlcont,nlq1,nlq2,xlp(nlq1:nlq2)

      if (nlcont.lt.2) then
        print*,'ERROR in eqwidt: xlb=',sngl(xlb),' ; nlcont<2'
        stop
      endif

      if (xlp(nlq1).gt.xlambda(lmin)) then
        print*,
     &  'WARNING eqwidth; extrapolating continuous opacity downwards'
      endif
      if (xlp(nlq2).lt.xlambda(lmax)) then
        print*,
     &  'WARNING eqwidth; extrapolating continuous opacity upwards'
      endif

      do jc=nlq1,nlq2
        xx(jc)=sngl(xlp(jc))
        do k=1,ntau
          bplan(k)=bpl(T(k),xx(jc))
          x(k)=absocont(k,jc)
          s(k)=absoscont(k,jc)
* TEST all in pure absorption (i.e. S=B)   BPz 28/09/2002 (cf also below)
cc          x(k)=x(k)+s(k)
cc          s(k)=0.0
        enddo
*
        WRITE(14) MCODE,nlcont,xx(jc),BPLAN,X,S,XI
      enddo
*
* X  is kappa/stndop,
* S  is sigma/stndop
*    at each depth for a series of nlcont lambdas.
* The continuous opacity at the selected nlcont wavelengths is in
* absocont (pure absorption) and absoscont (scattering). They are also
* divided by stndop.
* stndop is called ross in the routine readmo but is not ross.
*
*
* add the continuous opacities at all wavelengths;
* they are first
* interpolated from the ones calculated above in readmo.
* and contained in absocont and absoscont.

      do j=1,ntau
        ii=1
        do jc=nlq1,nlq2
          yyy(ii)=absocont(j,jc)
          zzz(ii)=absoscont(j,jc)
          ii=ii+1
        enddo
        do iloop=lmin,lmax
          call lint(nlcont,xlp(nlq1),yyy(1),xlambda(iloop),x(j))
          call lint(nlcont,xlp(nlq1),zzz(1),xlambda(iloop),s(j))
          abso(j,iloop)=abso(j,iloop)+x(j)
          absos(j,iloop)=absos(j,iloop)+s(j)
* TEST all in pure absorption (i.e. S=B)   BPz 28/09/2002
cc          abso(j,iloop)=abso(j,iloop)+absos(j,iloop)
cc          absos(j,iloop)=0.0
        enddo
      enddo

      eqwidth(ieq)=0.0
      if (lmax.gt.lmin) then
        if (spherical) then
          CALL eqwidtb(lmin,lmax,eqwidth(ieq))
        else
          CALL eqwidtbplatt(lmin,lmax,eqwidth(ieq))
        endif
      endif
*
* iterate on abundance; epsabu = precision of determination in dex
*
      epsabu=0.001
      epsabu=log(10**epsabu)

      if (abfind) then
        if (obs(ieq).gt.0.e0) then
ccc          if (abs(log(obs(ieq)/eqwidth(ieq)/1000.)).gt.epsabu) then
          if (abs(log(abufact(ieq)/abufactold)).gt.epsabu.and.
     &        iterabu.le.14) then
            if (firstiter) then
              abufactold=abufact(ieq)
              abufact(ieq)=obs(ieq)/eqwidth(ieq)/1000.*abufact(ieq)
              eqwidthold=eqwidth(ieq)
              firstiter=.false.
            else
              dlnabufact=log(abufact(ieq)/abufactold)/
     &                log(eqwidth(ieq)/eqwidthold)*
     &                  log(obs(ieq)/eqwidth(ieq)/1000.)

              if (iterabu.eq.8) then
c we are likely stuck in an infinite loop
c we try to get out of it with a small kick
                dlnabufact=dlnabufact+1.1
              endif

              abufactold=abufact(ieq)
              abufact(ieq)=abufactold*exp(dlnabufact)
              eqwidthold=eqwidth(ieq)
              iterabu=iterabu+1
            endif
cc            print*, iterabu,abufactold,
cc     &              obs(ieq),eqwidth(ieq)*1000.,exp(dlnabufact)
cc            print*
            goto 9876
          else if (iterabu.gt.14) then
c obviously the kick at iteration 8 was not enough...
            print*,' WARNING!! abundance not converged for line:'
            print*,LELE,ION,XLB,CHIE,GFELOG,eqwidth(2)*1000.,
     &                  obs(2),
     &                  log10(abunp)+12.+log10(abufact(2))
* fake abufact
            abufact(ieq)=1.0
            notconvflag(ieq)=.true.
cc          print*, iterabu,abufactold,
cc     &          obs(ieq),eqwidth(ieq)*1000.,exp(dlnabufact)
cc          print*
          endif
        else
* observed equivalent width is zero mAA
          abufact(ieq)=1.e-30
        endif
      endif
* end of the ieq loop
      enddo

* Write line data
*
      gfelog=log10(f)
      if (gfelog.lt.-9.99) then
        formatlong=.true.
      else
        formatlong=.false.
      endif
      if (strongflag) then
        if (formatlong) then
        WRITE(20,455) LELE,ION,XLB,CHIE,GFELOG,eqwidth(2)*1000.,
     &                  obs(2),eqwerror,log10(abufact(2)),
     &                (log10(abunp)+12.+log10(abufact(ieq)),ieq=1,3)
        else
        WRITE(20,457) LELE,ION,XLB,CHIE,GFELOG,eqwidth(2)*1000.,
     &                  obs(2),eqwerror,log10(abufact(2)),
     &                (log10(abunp)+12.+log10(abufact(ieq)),ieq=1,3)
        endif
        strongflag=.false.
      else if (notconvflag(1).or.notconvflag(2).or.notconvflag(3)) then
        if (formatlong) then
        WRITE(20,4572) LELE,ION,XLB,CHIE,GFELOG,eqwidth(2)*1000.,
     &                  obs(2),eqwerror,log10(abufact(2)),
     &                (log10(abunp)+12.+log10(abufact(ieq)),ieq=1,3)
        else
        WRITE(20,4571) LELE,ION,XLB,CHIE,GFELOG,eqwidth(2)*1000.,
     &                  obs(2),eqwerror,log10(abufact(2)),
     &                (log10(abunp)+12.+log10(abufact(ieq)),ieq=1,3)
        endif
C Note that we could try to recover 1 or 2 abundances if
C they were converged. Here we throw away everything, even if only
C one of the cases did not work.
        do ieq=1,3
          notconvflag(ieq)=.false.
        enddo
      else
        if (eqwerror.le.0.0 .or. .not.abfind) then
* Case : find abundance, only for nominal measured eqw. No error
* on measured eqw.
* Or do not find abundance. Print same format, with all abundances the same.
          abufact(1)=abufact(2)
          abufact(3)=abufact(2)
        endif
        if (formatlong) then
        WRITE(20,4561) LELE,ION,XLB,CHIE,GFELOG,eqwidth(2)*1000.,
     &                obs(2),eqwerror,log10(abufact(2)),
     &                (log10(abunp)+12.+log10(abufact(ieq)),ieq=1,3)
        else
        WRITE(20,456) LELE,ION,XLB,CHIE,GFELOG,eqwidth(2)*1000.,
     &                obs(2),eqwerror,log10(abufact(2)),
     &                (log10(abunp)+12.+log10(abufact(ieq)),ieq=1,3)
        endif
      endif
* We arrive here, if obseqw=0. and abfind. We have skipped the calculations
* and we don't print anything
123   endif

*
* End of line calculation
*
2345  continue
      ILINE=ILINE+1
*
      GOTO 64
*
* End model loop
*
* end of line lists loop
9874  close(lunit)
98    continue
*
      WRITE(7,214) NREJCT,XL1L,XL2R,XLM
 214  FORMAT(1X,I8,' LINES WERE REJECTED, ONLY LINES BETWEEN',F10.3,
     &       ' AND',F10.3,' A CONSIDERED',/,'  CENTRAL WAVELENGTH=',
     &       F10.3,' A')
*
  100 FORMAT(4X,I1,6X,I3)
  101 FORMAT(3X,I1,5X,F6.4)
  102 FORMAT(6X,F4.0)
  103 FORMAT(4X,I3,5X,I1,7X,F6.2)
 1030 format(a3,17x,1x,e15.8,f9.3,1x,f6.3)
 1031 format(a3,7x,i3,7x,1x,e15.8,f9.3,1x,f6.3)
 1032 format(a3,i3,i3,1x,i3,7x,1x,e15.8,f9.3,1x,f6.3)
  107 FORMAT(7X,I3)
  109 FORMAT(7X,F6.3)
  137 FORMAT(7X,F10.0)
  212 FORMAT(4X,I1,7X,I1)
  213 FORMAT(' HE=',F6.2,'  C=',F6.2,'  N=',F6.2,'  O=',F6.2)
  230 FORMAT('0JLEV',3X,'  TAU ',8X,'ANJON',6X,'ANTEL',6X,'DAMP',7X,
     &       'PART',7X,'DBV',8X,'STIM',7X,'X',11X,'S')
  231 FORMAT(I5,1P10E11.3)
  235 FORMAT(2X,'CORRECTIONS FOR STIMULATED EMISSION'/20X,6F15.4)
  236 FORMAT(' ***STOP IN eqwidt***.NTOT(',I2,').LT.0.0, IEL=',
     & I3,/,' ION=',I3,' ABUND=',E10.3,' ILINE=',I4,' XLB=',F9.2)
  237 FORMAT(' MODEL IDENTIFICATION=',A,'; MAIN PROGRAMME eqwidt')
  240 FORMAT(' **DATA FOR LAMBDA',F10.3,'  FROM ',A2,I1,
     &       ' WRITTEN ON UNIT 14')
  265 FORMAT('0THE ABUNDANCE OF ',A3,' IS',F6.2,
     &       ' (NO OF FREE NUCLEI PER HYDROGEN: ',1PE9.2,
     &       ' AT DEPTHPOINT',I3,' )')
  266 FORMAT('0'/,' CHEMICAL COMPOSITION'//16(2X,A4)//16F6.2)
  267 FORMAT('0THE DAMPING WAS COMPUTED USING GAMRAD =',1PE9.2,
     &       ' AND LOG C6 =',0PF7.2)
  301 FORMAT()
 3301 FORMAT(D10.3,4F10.3,2E10.2)
  300 FORMAT(A2)
  302 FORMAT(1X,A2,I1,F6.0,F5.2,2F4.1,F6.3)
  303 FORMAT(' EL   XLB  CHIE   X  FD   GFE')
  460 format('       lambda    Exc  log(gf)           obs.eqw+- error',
     &'   delta    lower    abund    upper')
  461 format('                                                       ',
     &'   abund.   abund             abund')
 4572 format(a3,1x,i1,1x,f13.3,1x,f5.2,1x,f6.2,2(1x,f8.3),' +- ',f6.3,
     &       1x,f6.2,3(1x,f8.3),' abu not converged ')
 4571 format(a3,1x,i1,1x,f13.3,1x,f5.2,1x,f6.3,2(1x,f8.3),' +- ',f6.3,
     &       1x,f6.2,3(1x,f8.3),' abu not converged ')
 455  format(a3,1x,i1,1x,f13.3,1x,f5.2,1x,f6.2,2(1x,f8.3),' +- ',f6.3,
     &       1x,f6.2,3(1x,f8.3),' strong? wings cut?')
 457  format(a3,1x,i1,1x,f13.3,1x,f5.2,1x,f6.3,2(1x,f8.3),' +- ',f6.3,
     &       1x,f6.2,3(1x,f8.3),' strong? wings cut?')
 4561 format(a3,1x,i1,1x,f13.3,1x,f5.2,1x,f6.2,2(1x,f8.3),' +- ',f6.3,
     &       1x,f6.2,3(1x,f8.3))
  456 format(a3,1x,i1,1x,f13.3,1x,f5.2,1x,f6.3,2(1x,f8.3),' +- ',f6.3,
     &       1x,f6.2,3(1x,f8.3))
  990 FORMAT(' INPUT PARAMETERS:'/' IEL=',I3,
     & ' ION=',I1,' NMY=',I1,' FDAMP=',F3.1,' IINT=',I1,
     & ' IMY=',I1,' MA=',F6.2,' ABUND=',F4.2,' CHI=',F5.2,' XITE=',
     & 1PE8.2)
*
      END


      SUBROUTINE SMATRIX(P,ANS_SUMMED)
C
C     Simple routine wrapper to provide the same interface for
C     backward compatibility for usage without split orders.
C
C
C     CONSTANTS
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=3)
      INTEGER NSQAMPSO
      PARAMETER (NSQAMPSO=1)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL), ANS_SUMMED
C
C     VARIABLES
C
      INTEGER I
      REAL*8 ANS(0:NSQAMPSO)
C
C     BEGIN CODE
C
      CALL SMATRIX_SPLITORDERS(P,ANS)
      ANS_SUMMED=ANS(0)

      END

      SUBROUTINE SMATRIXHEL(P,HEL,ANS)
      IMPLICIT NONE
C
C     CONSTANT
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=3)
      INTEGER                 NCOMB
      PARAMETER (             NCOMB=12)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL),ANS
      INTEGER HEL
C
C     GLOBAL VARIABLES
C
      INTEGER USERHEL
      COMMON/HELUSERCHOICE/USERHEL
C     ----------
C     BEGIN CODE
C     ----------
      USERHEL=HEL
      CALL SMATRIX(P,ANS)
      USERHEL=-1

      END

      SUBROUTINE SMATRIX_SPLITORDERS(P,ANS)
C
C     Generated by MadGraph5_aMC@NLO v. %(version)s, %(date)s
C     By the MadGraph5_aMC@NLO Development Team
C     Visit launchpad.net/madgraph5 and amcatnlo.web.cern.ch
C
C     MadGraph StandAlone Version
C
C     Returns amplitude squared summed/avg over colors
C     and helicities
C     for the point in phase space P(0:3,NEXTERNAL)
C
C     Process: u d~ > w+ QED<=1 WEIGHTED<=2 [ all = QCD ]
C     Process: c s~ > w+ QED<=1 WEIGHTED<=2 [ all = QCD ]
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=3)
      INTEGER    NINITIAL
      PARAMETER (NINITIAL=2)
      INTEGER NPOLENTRIES
      PARAMETER (NPOLENTRIES=(NEXTERNAL+1)*6)
      INTEGER                 NCOMB
      PARAMETER (             NCOMB=12)
      INTEGER NSQAMPSO
      PARAMETER (NSQAMPSO=1)
      INTEGER HELAVGFACTOR
      PARAMETER (HELAVGFACTOR=4)
      LOGICAL CHOSEN_SO_CONFIGS(NSQAMPSO)
      DATA CHOSEN_SO_CONFIGS/.TRUE./
      COMMON/CHOSEN_BORN_SQSO/CHOSEN_SO_CONFIGS
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL),ANS(0:NSQAMPSO)
C
C     LOCAL VARIABLES
C
      INTEGER NTRY
      REAL*8 T(NSQAMPSO), BUFF
      INTEGER IHEL,IDEN, I, J
C     For a 1>N process, them BEAMTWO_HELAVGFACTOR would be set to 1.
      INTEGER BEAMS_HELAVGFACTOR(2)
      DATA (BEAMS_HELAVGFACTOR(I),I=1,2)/2,2/
      INTEGER JC(NEXTERNAL)
      LOGICAL GOODHEL(NCOMB)
      DATA NTRY/0/
      DATA GOODHEL/NCOMB*.FALSE./
      DATA IDEN/36/
C
C     GLOBAL VARIABLES
C
      INTEGER NHEL(NEXTERNAL,NCOMB)
      DATA (NHEL(I,   1),I=1,3) / 1,-1,-1/
      DATA (NHEL(I,   2),I=1,3) / 1,-1, 0/
      DATA (NHEL(I,   3),I=1,3) / 1,-1, 1/
      DATA (NHEL(I,   4),I=1,3) / 1, 1,-1/
      DATA (NHEL(I,   5),I=1,3) / 1, 1, 0/
      DATA (NHEL(I,   6),I=1,3) / 1, 1, 1/
      DATA (NHEL(I,   7),I=1,3) /-1,-1,-1/
      DATA (NHEL(I,   8),I=1,3) /-1,-1, 0/
      DATA (NHEL(I,   9),I=1,3) /-1,-1, 1/
      DATA (NHEL(I,  10),I=1,3) /-1, 1,-1/
      DATA (NHEL(I,  11),I=1,3) /-1, 1, 0/
      DATA (NHEL(I,  12),I=1,3) /-1, 1, 1/
      COMMON/PROCESS_NHEL/NHEL

      INTEGER USERHEL
      DATA USERHEL/-1/
      COMMON/HELUSERCHOICE/USERHEL

      INTEGER POLARIZATIONS(0:NEXTERNAL,0:5)
      COMMON/BORN_BEAM_POL/POLARIZATIONS
      DATA ((POLARIZATIONS(I,J),I=0,NEXTERNAL),J=0,5)/NPOLENTRIES*-1/

C
C     FUNCTIONS
C
      LOGICAL IS_BORN_HEL_SELECTED

C     ----------
C     BEGIN CODE
C     ----------
      NTRY=NTRY+1
      DO IHEL=1,NEXTERNAL
        JC(IHEL) = +1
      ENDDO
      DO I=1,NSQAMPSO
        ANS(I) = 0D0
      ENDDO
C     When spin-2 particles are involved, the Helicity filtering is
C      dangerous for the 2->1 topology.
C     This is because depending on the MC setup the initial PS points
C      have back-to-back initial states
C     for which some of the spin-2 helicity configurations are zero.
C      But they are no longer zero
C     if the point is boosted on the z-axis. Remember that HELAS
C      helicity amplitudes are no longer
C     lorentz invariant with expternal spin-2 particles (only the
C      helicity sum is).
C     For this reason, we simply remove the filterin when there is
C      only three external particles.
      IF (NEXTERNAL.LE.3) THEN
        DO IHEL=1,NCOMB
          GOODHEL(IHEL)=.TRUE.
        ENDDO
      ENDIF
      DO IHEL=1,NCOMB
        IF (USERHEL.EQ.-1.OR.USERHEL.EQ.IHEL) THEN
          IF (GOODHEL(IHEL) .OR. NTRY .LT. 2 .OR.USERHEL.NE.-1) THEN
            IF(NTRY.GE.2.AND.POLARIZATIONS(0,0).NE.
     $       -1.AND.(.NOT.IS_BORN_HEL_SELECTED(IHEL))) THEN
              CYCLE
            ENDIF
            CALL MATRIX(P ,NHEL(1,IHEL),JC(1), T)
            BUFF=0D0
            DO I=1,NSQAMPSO
              IF(POLARIZATIONS(0,0).EQ.-1.OR.IS_BORN_HEL_SELECTED(IHEL)
     $         ) THEN
                ANS(I)=ANS(I)+T(I)
              ENDIF
              BUFF=BUFF+T(I)
            ENDDO
            IF (BUFF .NE. 0D0 .AND. .NOT.    GOODHEL(IHEL)) THEN
              GOODHEL(IHEL)=.TRUE.
            ENDIF
          ENDIF
        ENDIF
      ENDDO
      ANS(0)=0.0D0
      DO I=1,NSQAMPSO
        ANS(I)=ANS(I)/DBLE(IDEN)
        IF (CHOSEN_SO_CONFIGS(I)) THEN
          ANS(0)=ANS(0)+ANS(I)
        ENDIF
      ENDDO
      IF(USERHEL.NE.-1) THEN
        DO I=0,NSQAMPSO
          ANS(I)=ANS(I)*HELAVGFACTOR
        ENDDO
      ELSE
        DO J=1,NINITIAL
          IF (POLARIZATIONS(J,0).NE.-1) THEN
            DO I=0,NSQAMPSO
              ANS(I)=ANS(I)*BEAMS_HELAVGFACTOR(J)
              ANS(I)=ANS(I)/POLARIZATIONS(J,0)
            ENDDO
          ENDIF
        ENDDO
      ENDIF
      END

      SUBROUTINE SMATRIXHEL_SPLITORDERS(P,HEL,ANS)
      IMPLICIT NONE
C
C     CONSTANT
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=3)
      INTEGER                 NCOMB
      PARAMETER (             NCOMB=12)
      INTEGER NSQAMPSO
      PARAMETER (NSQAMPSO=1)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL),ANS(0:NSQAMPSO)
      INTEGER HEL
C
C     GLOBAL VARIABLES
C
      INTEGER USERHEL
      COMMON/HELUSERCHOICE/USERHEL
C     ----------
C     BEGIN CODE
C     ----------
      USERHEL=HEL
      CALL SMATRIX_SPLITORDERS(P,ANS)
      USERHEL=-1

      END

      SUBROUTINE MATRIX(P,NHEL,IC,RES)
C
C     Generated by MadGraph5_aMC@NLO v. %(version)s, %(date)s
C     By the MadGraph5_aMC@NLO Development Team
C     Visit launchpad.net/madgraph5 and amcatnlo.web.cern.ch
C
C     Returns amplitude squared summed/avg over colors
C     for the point with external lines W(0:6,NEXTERNAL)
C
C     Process: u d~ > w+ QED<=1 WEIGHTED<=2 [ all = QCD ]
C     Process: c s~ > w+ QED<=1 WEIGHTED<=2 [ all = QCD ]
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NGRAPHS
      PARAMETER (NGRAPHS=1)
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=3)
      INTEGER    NWAVEFUNCS, NCOLOR
      PARAMETER (NWAVEFUNCS=3, NCOLOR=1)
      INTEGER NAMPSO, NSQAMPSO
      PARAMETER (NAMPSO=1, NSQAMPSO=1)
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
      COMPLEX*16 IMAG1
      PARAMETER (IMAG1=(0D0,1D0))
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL)
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      REAL*8 RES(NSQAMPSO)
C
C     LOCAL VARIABLES
C
      INTEGER I,J,M,N
      COMPLEX*16 ZTEMP
      REAL*8 DENOM(NCOLOR), CF(NCOLOR,NCOLOR)
      COMPLEX*16 AMP(NGRAPHS)
      COMPLEX*16 JAMP(NCOLOR,NAMPSO)
      COMPLEX*16 W(20,NWAVEFUNCS)
      COMPLEX*16 DUM0,DUM1
      DATA DUM0, DUM1/(0D0, 0D0), (1D0, 0D0)/
C
C     FUNCTION
C
      INTEGER SQSOINDEX
C
C     GLOBAL VARIABLES
C
      INCLUDE 'coupl.inc'
C
C     COLOR DATA
C
      DATA DENOM(1)/1/
      DATA (CF(I,  1),I=  1,  1) /    3/
C     1 T(2,1)
C     ----------
C     BEGIN CODE
C     ----------
      CALL IXXXXX(P(0,1),ZERO,NHEL(1),+1*IC(1),W(1,1))
      CALL OXXXXX(P(0,2),ZERO,NHEL(2),-1*IC(2),W(1,2))
      CALL VXXXXX(P(0,3),MDL_MW,NHEL(3),+1*IC(3),W(1,3))
C     Amplitude(s) for diagram number 1
      CALL FFV2_0(W(1,1),W(1,2),W(1,3),GC_11,AMP(1))
C     JAMPs contributing to orders QCD=0
      JAMP(1,1)=+AMP(1)

      RES = 0.D0
      DO M = 1, NAMPSO
        DO I = 1, NCOLOR
          ZTEMP = (0.D0,0.D0)
          DO J = 1, NCOLOR
            ZTEMP = ZTEMP + CF(J,I)*JAMP(J,M)
          ENDDO
          DO N = 1, NAMPSO
            RES(SQSOINDEX(M,N)) = RES(SQSOINDEX(M,N)) + ZTEMP
     $       *DCONJG(JAMP(I,N))/DENOM(I)
          ENDDO
        ENDDO
      ENDDO

      END

      SUBROUTINE GET_VALUE(P, ALPHAS, NHEL ,ANS)
      IMPLICIT NONE
C
C     CONSTANT
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=3)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL),ANS
      INTEGER NHEL
      DOUBLE PRECISION ALPHAS
      REAL*8 PI
CF2PY INTENT(OUT) :: ANS
CF2PY INTENT(IN) :: NHEL
CF2PY INTENT(IN) :: P(0:3,NEXTERNAL)
CF2PY INTENT(IN) :: ALPHAS
C     ROUTINE FOR F2PY to read the benchmark point.
C     the include file with the values of the parameters and masses
      INCLUDE 'coupl.inc'

      PI = 3.141592653589793D0
      G = 2* DSQRT(ALPHAS*PI)
      CALL UPDATE_AS_PARAM()
      IF (NHEL.NE.0) THEN
        CALL SMATRIXHEL(P, NHEL, ANS)
      ELSE
        CALL SMATRIX(P, ANS)
      ENDIF
      RETURN
      END

      SUBROUTINE INITIALISEMODEL(PATH)
C     ROUTINE FOR F2PY to read the benchmark point.
      IMPLICIT NONE
      CHARACTER*512 PATH
CF2PY INTENT(IN) :: PATH
      CALL SETPARA(PATH)  !first call to setup the paramaters
      RETURN
      END

      LOGICAL FUNCTION IS_BORN_HEL_SELECTED(HELID)
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=3)
      INTEGER    NCOMB
      PARAMETER (NCOMB=12)
C
C     ARGUMENTS
C
      INTEGER HELID
C
C     LOCALS
C
      INTEGER I,J
      LOGICAL FOUNDIT
C
C     GLOBALS
C
      INTEGER HELC(NEXTERNAL,NCOMB)
      COMMON/PROCESS_NHEL/HELC

      INTEGER POLARIZATIONS(0:NEXTERNAL,0:5)
      COMMON/BORN_BEAM_POL/POLARIZATIONS
C     ----------
C     BEGIN CODE
C     ----------

      IS_BORN_HEL_SELECTED = .TRUE.
      IF (POLARIZATIONS(0,0).EQ.-1) THEN
        RETURN
      ENDIF

      DO I=1,NEXTERNAL
        IF (POLARIZATIONS(I,0).EQ.-1) THEN
          CYCLE
        ENDIF
        FOUNDIT = .FALSE.
        DO J=1,POLARIZATIONS(I,0)
          IF (HELC(I,HELID).EQ.POLARIZATIONS(I,J)) THEN
            FOUNDIT = .TRUE.
            EXIT
          ENDIF
        ENDDO
        IF(.NOT.FOUNDIT) THEN
          IS_BORN_HEL_SELECTED = .FALSE.
          RETURN
        ENDIF
      ENDDO

      RETURN
      END

C     Set of functions to handle the array indices of the split orders

      INTEGER FUNCTION SQSOINDEX(ORDERINDEXA, ORDERINDEXB)
C
C     This functions plays the role of the interference matrix. It can
C      be hardcoded or
C     made more elegant using hashtables if its execution speed ever
C      becomes a relevant
C     factor. From two split order indices, it return the
C      corresponding index in the squared
C     order canonical ordering.
C
C     CONSTANTS
C

      INTEGER    NSO, NSQUAREDSO, NAMPSO
      PARAMETER (NSO=1, NSQUAREDSO=1, NAMPSO=1)
C
C     ARGUMENTS
C
      INTEGER ORDERINDEXA, ORDERINDEXB
C
C     LOCAL VARIABLES
C
      INTEGER I, SQORDERS(NSO)
      INTEGER AMPSPLITORDERS(NAMPSO,NSO)
      DATA (AMPSPLITORDERS(  1,I),I=  1,  1) /    0/
      COMMON/AMPSPLITORDERS/AMPSPLITORDERS
C
C     FUNCTION
C
      INTEGER SOINDEX_FOR_SQUARED_ORDERS
C
C     BEGIN CODE
C
      DO I=1,NSO
        SQORDERS(I)=AMPSPLITORDERS(ORDERINDEXA,I)
     $   +AMPSPLITORDERS(ORDERINDEXB,I)
      ENDDO
      SQSOINDEX=SOINDEX_FOR_SQUARED_ORDERS(SQORDERS)
      END

      INTEGER FUNCTION SOINDEX_FOR_SQUARED_ORDERS(ORDERS)
C
C     This functions returns the integer index identifying the squared
C      split orders list passed in argument which corresponds to the
C      values of the following list of couplings (and in this order).
C     ['QCD']
C
C     CONSTANTS
C
      INTEGER    NSO, NSQSO, NAMPSO
      PARAMETER (NSO=1, NSQSO=1, NAMPSO=1)
C
C     ARGUMENTS
C
      INTEGER ORDERS(NSO)
C
C     LOCAL VARIABLES
C
      INTEGER I,J
      INTEGER SQSPLITORDERS(NSQSO,NSO)
      DATA (SQSPLITORDERS(  1,I),I=  1,  1) /    0/
      COMMON/SQPLITORDERS/SQPLITORDERS
C
C     BEGIN CODE
C
      DO I=1,NSQSO
        DO J=1,NSO
          IF (ORDERS(J).NE.SQSPLITORDERS(I,J)) GOTO 1009
        ENDDO
        SOINDEX_FOR_SQUARED_ORDERS = I
        RETURN
 1009   CONTINUE
      ENDDO

      WRITE(*,*) 'ERROR:: Stopping in function'
      WRITE(*,*) 'SOINDEX_FOR_SQUARED_ORDERS'
      WRITE(*,*) 'Could not find squared orders ',(ORDERS(I),I=1,NSO)
      STOP

      END

      SUBROUTINE GET_NSQSO_BORN(NSQSO)
C
C     Simple subroutine returning the number of squared split order
C     contributions returned when calling smatrix_split_orders
C

      INTEGER    NSQUAREDSO
      PARAMETER  (NSQUAREDSO=1)

      INTEGER NSQSO

      NSQSO=NSQUAREDSO

      END

C     This is the inverse subroutine of SOINDEX_FOR_SQUARED_ORDERS.
C      Not directly useful, but provided nonetheless.
      SUBROUTINE GET_SQUARED_ORDERS_FOR_SOINDEX(SOINDEX,ORDERS)
C
C     This functions returns the orders identified by the squared
C      split order index in argument. Order values correspond to
C      following list of couplings (and in this order):
C     ['QCD']
C
C     CONSTANTS
C
      INTEGER    NSO, NSQSO
      PARAMETER (NSO=1, NSQSO=1)
C
C     ARGUMENTS
C
      INTEGER SOINDEX, ORDERS(NSO)
C
C     LOCAL VARIABLES
C
      INTEGER I
      INTEGER SQPLITORDERS(NSQSO,NSO)
      COMMON/SQPLITORDERS/SQPLITORDERS
C
C     BEGIN CODE
C
      IF (SOINDEX.GT.0.AND.SOINDEX.LE.NSQSO) THEN
        DO I=1,NSO
          ORDERS(I) =  SQPLITORDERS(SOINDEX,I)
        ENDDO
        RETURN
      ENDIF

      WRITE(*,*) 'ERROR:: Stopping function'
     $ //' GET_SQUARED_ORDERS_FOR_SOINDEX'
      WRITE(*,*) 'Could not find squared orders index ',SOINDEX
      STOP

      END SUBROUTINE

C     This is the inverse subroutine of getting amplitude SO orders.
C      Not directly useful, but provided nonetheless.
      SUBROUTINE GET_ORDERS_FOR_AMPSOINDEX(SOINDEX,ORDERS)
C
C     This functions returns the orders identified by the split order
C      index in argument. Order values correspond to following list of
C      couplings (and in this order):
C     ['QCD']
C
C     CONSTANTS
C
      INTEGER    NSO, NAMPSO
      PARAMETER (NSO=1, NAMPSO=1)
C
C     ARGUMENTS
C
      INTEGER SOINDEX, ORDERS(NSO)
C
C     LOCAL VARIABLES
C
      INTEGER I
      INTEGER AMPSPLITORDERS(NAMPSO,NSO)
      COMMON/AMPSPLITORDERS/AMPSPLITORDERS
C
C     BEGIN CODE
C
      IF (SOINDEX.GT.0.AND.SOINDEX.LE.NAMPSO) THEN
        DO I=1,NSO
          ORDERS(I) =  AMPSPLITORDERS(SOINDEX,I)
        ENDDO
        RETURN
      ENDIF

      WRITE(*,*) 'ERROR:: Stopping function GET_ORDERS_FOR_AMPSOINDEX'
      WRITE(*,*) 'Could not find amplitude split orders index ',SOINDEX
      STOP

      END SUBROUTINE

C     This function is not directly useful, but included for
C      completeness
      INTEGER FUNCTION SOINDEX_FOR_AMPORDERS(ORDERS)
C
C     This functions returns the integer index identifying the
C      amplitude split orders passed in argument which correspond to
C      the values of the following list of couplings (and in this
C      order):
C     ['QCD']
C
C     CONSTANTS
C
      INTEGER    NSO, NAMPSO
      PARAMETER (NSO=1, NAMPSO=1)
C
C     ARGUMENTS
C
      INTEGER ORDERS(NSO)
C
C     LOCAL VARIABLES
C
      INTEGER I,J
      INTEGER AMPSPLITORDERS(NAMPSO,NSO)
      COMMON/AMPSPLITORDERS/AMPSPLITORDERS
C
C     BEGIN CODE
C
      DO I=1,NAMPSO
        DO J=1,NSO
          IF (ORDERS(J).NE.AMPSPLITORDERS(I,J)) GOTO 1009
        ENDDO
        SOINDEX_FOR_AMPORDERS = I
        RETURN
 1009   CONTINUE
      ENDDO

      WRITE(*,*) 'ERROR:: Stopping function SOINDEX_FOR_AMPORDERS'
      WRITE(*,*) 'Could not find squared orders ',(ORDERS(I),I=1,NSO)
      STOP

      END


*----------------------------------------------------------------------*
      subroutine set_r12intm(op,name,dagger,
     &     min_rank,max_rank,ncadiff,iformal,op_info,orb_info)
*----------------------------------------------------------------------*
*     set up intermediate for R12 with open lines within
*     settings analoguous to R12coeff
*     hpvx_mnmx,irestr are chosen appropriately
*----------------------------------------------------------------------*
      implicit none
      include 'stdunit.h'
      include 'opdim.h'
c      include 'def_operator.h'
c      include 'def_operator_array.h'
      include 'mdef_operator_info.h'
      include 'def_orbinf.h'
      include 'par_opnames_gen.h'
      include 'ifc_input.h'

      integer, parameter ::
     &     ntest = 00

      type(operator), intent(inout) ::
     &     op
      character, intent(in) ::
     &     name*(*)
      logical, intent(in) ::
     &     dagger
      integer, intent(in) ::
     &     min_rank, max_rank, ncadiff, iformal

      type(operator_info), intent(inout) ::
     &     op_info
      type(orbinf), intent(inout) ::
     &     orb_info

      integer ::
     &     idx, idx_dum, i, j
      integer ::
     &     occ0(ngastp,2)
      logical ::
c     &     r12fix
     &     cclog
      type(operator), pointer ::
     &     dum1_pnt, dum2_pnt, dum3_pnt
      type(operator_array), pointer ::
     &     opscr(:)

      character(5) ::
     &     op_dummy1*5 = 'DUM-1',
     &     op_dummy2*5 = 'DUM-2',
     &     op_dummy3*5 = 'DUM-3'

      integer, external ::
     &     idx_oplist2

c      ! Do we want amplitudeless intermediates?
c      call get_argument_value('method','CC',lval=cclog)
      cclog = is_keyword_set('method.CC').gt.0

      if(ntest.ge.100)then
        write(lulog,*) '-------------'
        write(lulog,*) ' set_r12intm '
        write(lulog,*) '-------------'
        write(lulog,*) 'Intermediate: ',trim(name)
c        if(r12fix) write(lulog,*)'Fully contracted intermediate'
      endif

c      if(.not.r12fix)then
        allocate(opscr(2))
        allocate(opscr(1)%op)
        allocate(opscr(2)%op)

        ! no external lines, so:
        occ0 = 0
        call set_uop(opscr(1)%op,'scr1',.false.,
     &       occ0,1,orb_info)

        ! the internal lines are defined by a coefficient-like
        ! operator, so we use ...
        call set_r12c(opscr(2)%op,'scr2',dagger,
     &       min_rank,max_rank,ncadiff,iformal,orb_info)

        ! ... and define the intermediate:
        call set_gen_intermediate(op,name,
     &       opscr,2,orb_info)

        call dealloc_operator(opscr(1)%op)
        call dealloc_operator(opscr(2)%op)
        deallocate(opscr(1)%op)
        deallocate(opscr(2)%op)
        deallocate(opscr)
c      else
c        ! no external lines, so:
c        occ0 = 0
c        if(trim(name).ne.op_x_inter)then
c          call set_uop(op,name,.false.,
c     &         occ0,1,orb_info)
c        else
c          allocate(opscr(2))
c          allocate(opscr(1)%op)
c          allocate(opscr(2)%op)
c          call set_uop(opscr(1)%op,'scr1',.false.,
c     &         occ0,1,orb_info)
c
c          occ0(1,1:2) = 1
c          call set_uop(opscr(2)%op,'scr2',.false.,
c     &         occ0,1,orb_info)
c
c          call set_gen_intermediate(op,name,
c     &         opscr,2,orb_info)
c
c          call dealloc_operator(opscr(1)%op)
c          call dealloc_operator(opscr(2)%op)
c          deallocate(opscr(1)%op)
c          deallocate(opscr(2)%op)
c          deallocate(opscr)
c        endif
        do idx = 1, op%n_occ_cls
          op%formal_blk(idx) = .false.
        enddo

c      endif

      op%formal = .true.
      do idx = 1, op%n_occ_cls
        op%formal = op%formal.and.op%formal_blk(idx)
      end do

c      ! Extra terms required for CC-R12 intermediates.
c      ! Initially only for V.
c      if((trim(name).eq.op_v_inter.or.trim(name).eq.op_vbar_inter)
c     &     .and.cclog)then
c        if(trim(name).eq.op_v_inter)then
c          i=1
c          j=2
c        else
c          i=2
c          j=1
c        endif
c        allocate(opscr(2))
c        do idx = 1, 2
c          ! Shape of the operator.
c          occ0 = 0
c          call add_operator(op_dummy1,op_info)
c          idx_dum = idx_oplist2(op_dummy1,op_info)
c          dum1_pnt => op_info%op_arr(idx_dum)%op
c          occ0(2,i) = idx
c          call set_uop(dum1_pnt,op_dummy1,.false.,
c     &         occ0,1,orb_info)
c
cc          if(.not.r12fix)then
c            ! Spacer operator.
c            occ0 = 0
c            call add_operator(op_dummy2,op_info)
c            idx_dum = idx_oplist2(op_dummy2,op_info)
c            dum2_pnt => op_info%op_arr(idx_dum)%op
c            occ0(1,i) = 2
c            occ0(1,j) = 2-idx
c            call set_uop(dum2_pnt,op_dummy2,.false.,
c     &           occ0,1,orb_info)
c
c            opscr(1)%op => dum1_pnt
c            opscr(2)%op => dum2_pnt
c
c            ! Temporary intermediate.
c            call add_operator(op_dummy3,op_info)
c            idx_dum = idx_oplist2(op_dummy3,op_info)
c            dum3_pnt => op_info%op_arr(idx_dum)%op
c
c            call set_gen_intermediate(dum3_pnt,op_dummy3,
c     &           opscr,2,orb_info)
c
c            call join_operator(op,dum3_pnt,orb_info)
c
c            call del_operator(op_dummy3,op_info)
c            call del_operator(op_dummy2,op_info)
cc          else
cc            call join_operator(op,dum1_pnt,orb_info)
cc          endif
c          call del_operator(op_dummy1,op_info)
c        enddo
c        deallocate(opscr)
c      endif

      if (ntest.ge.100) then
        write(lulog,*) 'generated: '
        call print_op_occ(lulog,op)
        write(lulog,*) 'formal: ',op%formal_blk(1:op%n_occ_cls)
      end if

      return

      end


      SUBROUTINE PBDTRGET( ICONTXT, ADIST, M, N, MNB, A, LDA, MCROW,
     $                     MCCOL, IGD, MYROW, MYCOL, NPROW, NPCOL )
*
*  -- PB-BLAS routine (version 2.1) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory.
*     April 28, 1996
*
*     .. Scalar Arguments ..
      CHARACTER*1        ADIST
      INTEGER            ICONTXT, IGD, LDA, M, MCCOL, MCROW, MNB, MYCOL,
     $                   MYROW, N, NPCOL, NPROW
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  PBDTRGET forms a row block of A from scattered row subblocks if
*  ADIST = 'R', or forms a column block of A from scattered column
*  subblocks,  if ADIST = 'C'.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, TWO
      PARAMETER          ( ONE = 1.0E+0, TWO = 2.0E+0 )
*     ..
*     .. Local Variables ..
      INTEGER            KINT, KINT2, KLEN, KMOD, KPPOS, NLEN, NNUM,
     $                   NTLEN
      REAL               TEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ICEIL, NUMROC
      EXTERNAL           LSAME,  ICEIL, NUMROC
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGERV2D, DGESD2D
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, MOD
*
*     if A is a row block, it needs to communicate columnwise.
*
      IF( LSAME( ADIST, 'R' ) ) THEN
         KPPOS = MOD( NPROW+MYROW-MCROW, NPROW )
         IF( MOD( KPPOS, IGD ).EQ.0 ) THEN
            KINT = IGD
            NLEN = N
            NNUM = MIN( NPROW/IGD, MNB-MCCOL )
            TEMP = REAL( NNUM )
            NTLEN = N * NNUM
            NNUM = IGD * NNUM
            IF( KPPOS.GE.NNUM ) GO TO 30
            KPPOS = MOD( KPPOS, NPROW )
*
   10       CONTINUE
            IF( TEMP.GT.ONE ) THEN
               KINT2 = 2 * KINT
               KMOD = MOD( KPPOS, KINT2 )
*
               IF( KMOD.EQ.0 ) THEN
                  IF( KPPOS+KINT.LT.NNUM ) THEN
                     KLEN = NTLEN - (KPPOS/KINT2)*(KINT2/IGD)*N
                     KLEN = MIN( KLEN-NLEN, NLEN )
                     CALL DGERV2D( ICONTXT, M, KLEN, A(1,NLEN+1), LDA,
     $                             MOD(MYROW+KINT, NPROW), MYCOL )
                     NLEN = NLEN + KLEN
                  END IF
               ELSE
                  CALL DGESD2D( ICONTXT, M, NLEN, A, LDA,
     $                          MOD(NPROW+MYROW-KINT, NPROW), MYCOL )
                  GO TO 30
               END IF
*
               KINT = KINT2
               TEMP = TEMP / TWO
               GO TO 10
            END IF
         END IF
*
*     if A is a column block, it needs to communicate rowwise.
*
      ELSE IF( LSAME( ADIST, 'C' ) ) THEN
*
         KPPOS = MOD( NPCOL+MYCOL-MCCOL, NPCOL )
         IF( MOD( KPPOS, IGD ).EQ.0 ) THEN
            KINT = IGD
            NLEN = N
            NNUM = MIN( NPCOL/IGD, MNB-MCROW )
            TEMP = REAL( NNUM )
            NTLEN = N * NNUM
            NNUM = IGD * NNUM
            IF( KPPOS.GE.NNUM ) GO TO 30
            KPPOS = MOD( KPPOS, NPCOL )
*
   20       CONTINUE
            IF( TEMP.GT.ONE ) THEN
               KINT2 = 2 * KINT
               KMOD = MOD( KPPOS, KINT2 )
*
               IF( KMOD.EQ.0 ) THEN
                  IF( KPPOS+KINT.LT.NNUM ) THEN
                     KLEN = NTLEN - (KPPOS/KINT2)*(KINT2/IGD)*N
                     KLEN = MIN( KLEN-NLEN, NLEN )
                     CALL DGERV2D( ICONTXT, M, KLEN, A(1,NLEN+1), LDA,
     $                             MYROW, MOD(MYCOL+KINT, NPCOL) )
                     NLEN = NLEN + KLEN
                  END IF
               ELSE
                  CALL DGESD2D( ICONTXT, M, NLEN, A, LDA, MYROW,
     $                          MOD(NPCOL+MYCOL-KINT, NPCOL) )
                  GO TO 30
               END IF
*
               KINT = KINT2
               TEMP = TEMP / TWO
               GO TO 20
            END IF
         END IF
      END IF
*
   30 CONTINUE
*
      RETURN
*
*     End of PBDTRGET
*
      END


! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
! Utility Data Module File
!
! Generated by KPP-2.1 symbolic chemistry Kinetics PreProcessor
!       (http://www.cs.vt.edu/~asandu/Software/KPP)
! KPP is distributed under GPL, the general public licence
!       (http://www.gnu.org/copyleft/gpl.html)
! (C) 1995-1997, V. Damian & A. Sandu, CGRER, Univ. Iowa
! (C) 1997-2005, A. Sandu, Michigan Tech, Virginia Tech
!     With important contributions from:
!        M. Damian, Villanova University, USA
!        R. Sander, Max-Planck Institute for Chemistry, Mainz, Germany
!
! File                 : cbmz_sorgam_Monitor.f90
! Time                 : Wed Jun 14 17:35:22 2017
! Working directory    : /data/ksetigui/setigui/WRFnew/chem/KPP/mechanisms/cbmz_sorgam
! Equation file        : cbmz_sorgam.kpp
! Output root filename : cbmz_sorgam
!
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

MODULE cbmz_sorgam_Monitor

  CHARACTER(LEN=12), PARAMETER, DIMENSION(68) :: SPC_NAMES = (/ &
     'H2SO4       ','HCl         ','NH3         ', &
     'HCOOH       ','RCOOH       ','ARO1        ', &
     'ARO2        ','ALK1        ','OLE1        ', &
     'API1        ','API2        ','LIM1        ', &
     'LIM2        ','SO2         ','O1D         ', &
     'ANOL        ','H2O2        ','PAN         ', &
     'TOL         ','N2O5        ','XYL         ', &
     'CH4         ','CRO         ','API         ', &
     'LIM         ','HNO4        ','TO2         ', &
     'C2H6        ','XPAR        ','ETHOOH      ', &
     'HONO        ','CH3OOH      ','ETH         ', &
     'CH3OH       ','CRES        ','O3P         ', &
     'HNO3        ','CO          ','ISOPN       ', &
     'PAR         ','OPEN        ','ISOPP       ', &
     'ISOPO2      ','OLET        ','ISOP        ', &
     'HCHO        ','XO2         ','AONE        ', &
     'OLEI        ','MGLY        ','ETHP        ', &
     'NAP         ','ALD2        ','CH3O2       ', &
     'ISOPRD      ','ROOH        ','ANO2        ', &
     'RO2         ','ONIT        ','NO3         ', &
     'NO          ','NO2         ','OH          ', &
     'O3          ','HO2         ','C2O3        ', &
     'H2O         ','M           ' /)

  INTEGER, DIMENSION(1) :: LOOKAT
  INTEGER, DIMENSION(1) :: MONITOR
  CHARACTER(LEN=12), DIMENSION(1) :: SMASS
  CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_0 = (/ &
     '         NO2 --> O3P + NO                                                                           ', &
     '         NO3 --> 0.89 O3P + 0.11 NO + 0.89 NO2                                                      ', &
     '        HONO --> NO + OH                                                                            ', &
     '        HNO3 --> NO2 + OH                                                                           ', &
     '        HNO4 --> NO2 + HO2                                                                          ', &
     '        N2O5 --> NO3 + NO2                                                                          ', &
     '          O3 --> O3P                                                                                ', &
     '          O3 --> O1D                                                                                ', &
     '        H2O2 --> 2 OH                                                                               ', &
     '        HCHO --> CO + 2 HO2                                                                         ', &
     '        HCHO --> CO                                                                                ', &
     '      CH3OOH --> HCHO + OH + HO2                                                                    ', &
     '      ETHOOH --> ALD2 + OH + HO2                                                                    ', &
     '        ALD2 --> CO + CH3O2 + HO2                                                                   ', &
     '        AONE --> CH3O2 + C2O3                                                                       ', &
     '        MGLY --> CO + HO2 + C2O3                                                                    ', &
     '        OPEN --> CO + HO2 + C2O3                                                                    ', &
     '        ROOH --> 1.98 XPAR + 0.4 XO2 + 0.74 AONE + 0.1 ETHP + 0.3 ALD2 + OH + 0.9 HO2               ', &
     '        ONIT --> 1.98 XPAR + 0.41 XO2 + 0.74 AONE + 0.1 ETHP + 0.3 ALD2 + NO2 + 0.9 HO2             ', &
     '      ISOPRD --> 0.33 CO + 0.2 HCHO + 0.03 AONE + 0.07 ALD2 + 0.7 CH3O2 + 0.33 HO2 + 0.97 C2O3      ', &
     '     O1D + M --> O3P                                                                                ', &
     '   O1D + H2O --> 2 OH                                                                               ', &
     '     O3P + M --> O3                                                                                ', &
     '    O3P + O3 --> 0.42 M                                                                             ', &
     '   O3P + NO2 --> NO                                                                                ', &
     '   O3P + NO2 --> NO3                                                                                ', &
     '    O3P + NO --> NO2                                                                                ', &
     '     NO + O3 --> NO2                                                                                ', &
     '    NO2 + O3 --> NO3                                                                                ', &
     '     OH + O3 --> HO2                                                                                ' /)
  CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_1 = (/ &
     '    O3 + HO2 --> OH                                                                                ', &
     '      OH + M --> HO2 + H2O                                                                          ', &
     '     NO + OH --> HONO                                                                               ', &
     '    NO2 + OH --> HNO3                                                                               ', &
     '    NO3 + OH --> NO2 + HO2                                                                          ', &
     '   HONO + OH --> NO2                                                                                ', &
     '   HNO3 + OH --> NO3                                                                                ', &
     '   HNO4 + OH --> NO2                                                                                ', &
     '    OH + HO2 --> H2O + 0.21 M                                                                       ', &
     '   H2O2 + OH --> HO2                                                                                ', &
     '       2 HO2 --> H2O2                                                                               ', &
     ' 2 HO2 + H2O --> H2O2                                                                               ', &
     '    NO + HO2 --> NO2 + OH                                                                           ', &
     '   NO2 + HO2 --> HNO4                                                                               ', &
     '   NO2 + HO2 --> HONO                                                                               ', &
     '        HNO4 --> NO2 + HO2                                                                          ', &
     '    NO3 + NO --> 2 NO2                                                                              ', &
     '   NO3 + NO2 --> NO + NO2                                                                           ', &
     '   NO3 + NO2 --> N2O5                                                                               ', &
     '       2 NO3 --> 2 NO2                                                                              ', &
     '   NO3 + HO2 --> 0.3 HNO3 + 0.7 NO2 + 0.7 OH                                                        ', &
     '  N2O5 + H2O --> 2 HNO3                                                                             ', &
     '        N2O5 --> NO3 + NO2                                                                          ', &
     '     CO + OH --> HO2                                                                                ', &
     '    SO2 + OH --> H2SO4 + HO2                                                                        ', &
     '    CH4 + OH --> CH3O2                                                                              ', &
     '   C2H6 + OH --> ETHP                                                                               ', &
     '    PAR + OH --> 0.012 ALK1 + RO2                                                                   ', &
     '   HCHO + OH --> CO + HO2                                                                           ', &
     '  HCHO + NO3 --> HNO3 + CO + HO2                                                                    ' /)
  CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_2 = (/ &
     '   ALD2 + OH --> C2O3                                                                               ', &
     '  ALD2 + NO3 --> HNO3 + C2O3                                                                        ', &
     '   AONE + OH --> ANO2                                                                               ', &
     '   MGLY + OH --> XO2 + C2O3                                                                         ', &
     '  MGLY + NO3 --> HNO3 + CO + C2O3                                                                   ', &
     '    ETH + O3 --> 0.52 HCOOH + 0.24 CO + HCHO + 0.12 OH + 0.22 HO2                                   ', &
     '    ETH + OH --> 1.56 HCHO + XO2 + 0.22 ALD2 + HO2                                                  ', &
     '   OLET + O3 --> 0.22 HCOOH + 0.09 RCOOH + 0.008 OLE1 + 0.06 CH4 + 0.01 C2H6 + 1.06 XPAR + 0.03 CH3O', &
     '   OLEI + O3 --> 0.16 RCOOH + 0.008 OLE1 + 0.08 CH4 + 0.01 C2H6 + 2.26 XPAR + 0.04 CH3OH + 0.3 CO + ', &
     '   OLET + OH --> 0.008 OLE1 + XPAR + HCHO + XO2 + ALD2 + HO2                                        ', &
     '   OLEI + OH --> 0.008 OLE1 + 2.23 XPAR + XO2 + 0.23 AONE + 1.77 ALD2 + HO2                         ', &
     '  OLET + NO3 --> 0.008 OLE1 + NAP                                                                   ', &
     '  OLEI + NO3 --> 0.008 OLE1 + NAP                                                                   ', &
     '    TOL + OH --> 0.039 ARO1 + 0.108 ARO2 + 0.8 TO2 + 0.12 CRES + 0.08 XO2 + 0.2 HO2                 ', &
     '    XYL + OH --> 0.039 ARO1 + 0.108 ARO2 + 0.45 TO2 + 0.05 CRES + 1.1 PAR + 0.5 XO2 + 0.8 MGLY + 0.5', &
     '    TO2 + NO --> 0.95 OPEN + 0.05 ONIT + 0.95 NO2 + 0.95 HO2                                        ', &
     '   CRES + OH --> 0.039 ARO1 + 0.108 ARO2 + 0.4 CRO + 0.3 OPEN + 0.6 XO2 + 0.6 HO2                   ', &
     '  CRES + NO3 --> 0.039 ARO1 + 0.108 ARO2 + CRO + HNO3                                               ', &
     '   CRO + NO2 --> ONIT                                                                               ', &
     '   OPEN + OH --> 2 CO + HCHO + XO2 + 2 HO2 + C2O3                                                   ', &
     '   OPEN + O3 --> 0.69 CO + 0.7 HCHO + 0.03 XO2 + 0.2 MGLY + 0.03 ALD2 + 0.08 OH + 0.76 HO2 + 0.62 C2', &
     '   ISOP + OH --> ISOPP + 0.08 XO2                                                                   ', &
     '   ISOP + O3 --> 0.39 RCOOH + 0.07 CO + 0.6 HCHO + 0.2 XO2 + 0.15 ALD2 + 0.65 ISOPRD + 0.27 OH + 0.0', &
     '  ISOP + NO3 --> ISOPN                                                                              ', &
     ' ISOPRD + OH --> 0.5 ISOPO2 + 0.2 XO2 + 0.5 C2O3                                                    ', &
     ' ISOPRD + O3 --> 0.46 RCOOH + 0.16 CO + 0.15 HCHO + 0.07 XO2 + 0.09 AONE + 0.85 MGLY + 0.02 ALD2 + 0', &
     'ISOPRD + NO3 --> 0.07 HNO3 + 0.64 CO + 1.86 PAR + 0.28 HCHO + 0.93 XO2 + 0.28 ALD2 + 0.93 ONIT + 0.9', &
     '  ISOPP + NO --> 0.18 PAR + 0.63 HCHO + 0.91 ISOPRD + 0.09 ONIT + 0.91 NO2 + 0.91 HO2               ', &
     '  ISOPN + NO --> 1.6 PAR + 0.8 ALD2 + 0.2 ISOPRD + 0.8 ONIT + 1.2 NO2 + 0.8 HO2                     ', &
     ' ISOPO2 + NO --> 0.59 CO + 0.25 HCHO + 0.63 AONE + 0.34 MGLY + 0.55 ALD2 + NO2 + HO2                ' /)
  CHARACTER(LEN=100), PARAMETER, DIMENSION(30) :: EQN_NAMES_3 = (/ &
     ' ISOPP + HO2 --> ROOH                                                                               ', &
     ' ISOPN + HO2 --> 2 PAR + ONIT                                                                       ', &
     'ISOPO2 + HO2 --> ROOH                                                                               ', &
     ' CH3OOH + OH --> 0.3 HCHO + 0.7 CH3O2 + 0.3 OH                                                      ', &
     ' ETHOOH + OH --> 0.7 ETHP + 0.3 ALD2 + 0.3 OH                                                       ', &
     '   ROOH + OH --> 0.42 XPAR + 0.19 MGLY + 0.04 ALD2 + 0.77 RO2 + 0.23 OH                             ', &
     '   ONIT + OH --> NAP                                                                                ', &
     '  NO2 + C2O3 --> PAN                                                                                ', &
     '         PAN --> NO2 + C2O3                                                                         ', &
     '  CH3OH + OH --> HCHO + HO2                                                                         ', &
     '  CH3O2 + NO --> HCHO + NO2 + HO2                                                                   ', &
     '   ETHP + NO --> ALD2 + NO2 + HO2                                                                   ', &
     '    RO2 + NO --> 1.68 XPAR + 0.34 XO2 + 0.62 AONE + 0.08 ETHP + 0.25 ALD2 + 0.16 ONIT + 0.84 NO2 + 0', &
     '   NO + C2O3 --> CH3O2 + NO2                                                                        ', &
     '   ANO2 + NO --> HCHO + NO2 + C2O3                                                                  ', &
     '    NAP + NO --> XPAR + 0.5 HCHO + 0.5 ALD2 + 0.5 ONIT + 1.5 NO2 + 0.5 HO2                          ', &
     '    XO2 + NO --> NO2                                                                                ', &
     ' CH3O2 + NO3 --> HCHO + NO2 + HO2                                                                   ', &
     '  ETHP + NO3 --> ALD2 + NO2 + HO2                                                                   ', &
     '   RO2 + NO3 --> 1.98 XPAR + 0.4 XO2 + 0.74 AONE + 0.1 ETHP + 0.3 ALD2 + NO2 + 0.9 HO2              ', &
     '  NO3 + C2O3 --> CH3O2 + NO2                                                                        ', &
     '  ANO2 + NO3 --> HCHO + NO2 + C2O3                                                                  ', &
     '   NAP + NO3 --> XPAR + 0.5 HCHO + 0.5 ALD2 + 0.5 ONIT + 1.5 NO2 + 0.5 HO2                          ', &
     '   XO2 + NO3 --> NO2                                                                                ', &
     ' CH3O2 + HO2 --> CH3OOH                                                                             ', &
     '  ETHP + HO2 --> ETHOOH                                                                             ', &
     '   RO2 + HO2 --> ROOH                                                                               ', &
     '  HO2 + C2O3 --> 0.4 RCOOH + 0.4 O3                                                                 ', &
     '  ANO2 + HO2 --> ROOH                                                                               ', &
     '   NAP + HO2 --> ONIT                                                                               ' /)
  CHARACTER(LEN=100), PARAMETER, DIMENSION(22) :: EQN_NAMES_4 = (/ &
     '   XO2 + HO2 -->                                                                                ', &
     '   ANOL + OH --> ALD2 + HO2                                                                         ', &
     '  XPAR + PAR -->                                                                                ', &
     '         HCl --> HCl                                                                                ', &
     '         NH3 --> NH3                                                                                ', &
     '       H2SO4 --> H2SO4                                                                              ', &
     '       CH3O2 --> 0.34 CH3OH + 0.66 HCHO + 0.32 HO2                                                  ', &
     '        ETHP --> 0.2 C2H6 + 0.8 ALD2 + 0.6 HO2                                                      ', &
     '         RO2 --> 1.25 XPAR + 0.24 XO2 + 0.57 AONE + 0.06 ETHP + 0.21 ALD2 + 0.54 HO2                ', &
     '        C2O3 --> CH3O2                                                                              ', &
     '        ANO2 --> 0.7 HCHO + 0.15 AONE + 0.15 MGLY + 0.7 C2O3                                        ', &
     '         NAP --> XPAR + 0.5 HCHO + 0.5 ALD2 + 0.5 ONIT + 0.5 NO2                                    ', &
     '       ISOPP --> ISOPRD                                                                             ', &
     '       ISOPN --> 2 PAR + ALD2 + ONIT                                                                ', &
     '      ISOPO2 --> 0.5 AONE + 0.5 ALD2                                                                ', &
     '         XO2 -->                                                                                ', &
     '    API + OH --> 0.0064 API1 + 0.055 API2                                                           ', &
     '   API + NO3 -->                                                                                ', &
     '    API + O3 --> 0.022 API1 + 0.19 API2                                                             ', &
     '    LIM + OH --> 0.037 LIM1 + 0.056 LIM2                                                            ', &
     '   LIM + NO3 -->                                                                                ', &
     '    LIM + O3 --> 0.13 LIM1 + 0.19 LIM2                                                              ' /)
  CHARACTER(LEN=100), PARAMETER, DIMENSION(142) :: EQN_NAMES = (/&
    EQN_NAMES_0, EQN_NAMES_1, EQN_NAMES_2, EQN_NAMES_3, EQN_NAMES_4 /)

! INLINED global variables

! End INLINED global variables

END MODULE cbmz_sorgam_Monitor


      SUBROUTINE DT_FLAHAD(Id,If1,If2,If3)

C***********************************************************************
C sampling of FLAvor composition for HADrons/photons                   *
C              ID         BAMJET-id of hadron                          *
C              IF1,2,3    flavor content                               *
C                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
C Note:  -  u,d numbering as in BAMJET                                 *
C        -  All ID are accepted. ID above 39 taken from PHOJET.        *
C This version dated 12.03.96 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION DT_RNDM , one
      INTEGER Id , idcpc , idpdg , IDT_IPDGHA , If1 , If2 , If3 ,
     &        IPHO_PDG2ID , ipoqua , iq , ix , jsel , k
      SAVE

C auxiliary common for reggeon exchange (DTUNUC 1.x)
      INCLUDE 'inc/dtquar'
      INCLUDE 'inc/popar2'

      DIMENSION jsel(3,6)
      DATA jsel/1 , 2 , 3 , 2 , 3 , 1 , 3 , 1 , 2 , 1 , 3 , 2 , 2 , 1 ,
     &     3 , 3 , 2 , 1/
      DIMENSION ipoqua(3)

      one = 1.0D0
      IF ( Id.EQ.7 ) THEN
C photon (charge dependent flavour sampling)
         k = INT(DT_RNDM(one)*6.D0+1.D0)
         IF ( k.LE.4 ) THEN
            If1 = 2
            If2 = -2
         ELSE IF ( k.EQ.5 ) THEN
            If1 = 1
            If2 = -1
         ELSE
            If1 = 3
            If2 = -3
         END IF
         IF ( DT_RNDM(one).LT.0.5D0 ) THEN
            k = If1
            If1 = If2
            If2 = k
         END IF
         If3 = 0
      ELSE
C hadron
         ix = INT(1.0D0+5.99999D0*DT_RNDM(one))
         IF ( Id.LE.39 ) THEN
            If1 = MQUark(jsel(1,ix),Id)
            If2 = MQUark(jsel(2,ix),Id)
            If3 = MQUark(jsel(3,ix),Id)

C Use PHOJET quark tables if BAMJET id exceeds 39 (limit of MQUARK)
         ELSE
            idpdg = IDT_IPDGHA(Id)
            ! WRITE(6,*) 'DT_FLAHAD: ID, IDPDG', ID, IDPDG
            idcpc = IPHO_PDG2ID(idpdg)
            DO iq = 1 , 3
               ipoqua(iq) = IQ_list(iq,ABS(idcpc))
               ipoqua(iq) = SIGN(ipoqua(iq),idcpc)

C Swap u and d quarks to convert from PHOJET to DPMJET
               IF ( ABS(ipoqua(iq)).EQ.1 ) THEN
                  ipoqua(iq) = SIGN(2,ipoqua(iq))
               ELSE IF ( ABS(ipoqua(iq)).EQ.2 ) THEN
                  ipoqua(iq) = SIGN(1,ipoqua(iq))
               END IF
            END DO
            ! WRITE(6,*) 'DT_FLAHAD: ID, IPOQUA', ID, IPOQUA
            If1 = ipoqua(jsel(1,ix))
            If2 = ipoqua(jsel(2,ix))
            If3 = ipoqua(jsel(3,ix))
         END IF
         ! WRITE(6,*) 'DT_FLAHAD: ID, IF1, IF2, IF3', ID,IF1,IF2,IF3
         IF ( (If1.EQ.0) .AND. (If3.NE.0) ) THEN
            If1 = If3
            If3 = 0
         ELSE IF ( (If2.EQ.0) .AND. (If3.NE.0) ) THEN
            If2 = If3
            If3 = 0
         END IF
      END IF

      END SUBROUTINE