      subroutine yprep(iph0, nat, inclus, iphat, rmax, rat)
c
c  removed izx, nopt, rdirec from arg list, unused or use commented out
c
c    yprep is the same as xprep for negative idwopt
c    simlifies calls in SCF and LDOS where DW factors should not enter

      implicit real (a-h,o-z)
      implicit integer (i-n)

      include '../HEADERS/dim.h'
      include 'xparam.h'
c====================================================================
c  This header file contains the structural information about the
c  cluster to be used for the full multiple scattering calculation

      common /xstruc/ xphi(nclusx,nclusx), xrat(3,nclusx),
     $            iphx(nclusx)
      save /xstruc/

c  xphi:  matrix of angles between the z axis and pairs of atoms
c  xrat:  xyz coordinates of the atoms in the cluster, the first
c         npot+1 entries are examples of each unique potential
c  iphx:  potential indeces of each atom in the cluster, ordered like
c         xrat
c********************************************************************
c**** rotation matrices for entire cluster
c
      complex drix
      common /rotx/ drix(-lx:lx, -lx:lx, 0:lx, 0:1, nclusx, nclusx)
      save /rotx/
c********************************************************************
c common blocks for saving rotation matrices between xanes and rotxan
       integer    jsavx, jsav, jbmagk
       parameter (jsavx = 150, roteps = 1.e-12,jbmagk=-9999)
       dimension drisav(-lx:lx,-lx:lx,0:lx,jsavx), betsav(jsavx)
       integer   ldsav(jsavx), mdsav(jsavx)
       common /rotsav/  drisav, betsav, ldsav, mdsav, jsav
       save  /rotsav/
c********************************************************************
c**** legendre polynomial normalization constants
c
      common /lnlm/ xnlm(0:lx,0:lx)
      save   /lnlm/

c********************************************************************
c**** legendre polynomial normalization constants
c
      common /xdwf/ sigsqr(nclusx,nclusx)
      save   /xdwf/

c  end of xstruc.h
c********************************************************************
      parameter(zero=0.e0)
      parameter (bohr = 0.529 177 249e0)
      integer   iphat(natxx), iphat2(natxx)
c      integer izpair(0:2), izx(0:nphasx)
      dimension rat(3,natxx), rat2(3,natxx)
      double precision ra(natxx)
      character*78 line
c     sigms is written in double precision.  these are the variables
c     that it uses
c      double precision dtemp, dthet, drs, dsigsq, pair(3,0:2)
c      double precision sig2mx, sig2x(0:nphx,0:nphx)
c     iwarn - needed to wrtite waqrning just one time
      integer iwarn
      save iwarn
      data  iwarn /0/

c  initialize geometrical arrays
      do 30 i=1,nclusx
        do 10 j=1,nclusx
          xphi(j,i) = zero
 10     continue
        do 20 j=1,3
          xrat(j,i) = zero
 20     continue
        iphx(i) = 0
 30   continue
      inclus = 0

c --- find the central atom, ipot=iph0 (iph0=0 for the absorbing atom)
      icen = 0
      do 40 i=1,nat
        iphat2(i) = iphat(i)
        if (iphat(i).eq.iph0) then
            if (icen.eq.0) then
                icen = i
            elseif (iph0.eq.0) then
                call wlog('* * * ERROR!  More than one atom '//
     $                      'in the extended cluster have ipot=0')
                call wlog('      You may only have one central atom.')
                call wlog('      Stopping in xprep.')
                call par_stop('YPREP-1')
            endif
        endif
 40   continue
c --- make sure central atom is at (0,0,0)
      do 45 i=1,nat
        rat2(1,i) = rat(1,i)-rat(1,icen)
        rat2(2,i) = rat(2,i)-rat(2,icen)
        rat2(3,i) = rat(3,i)-rat(3,icen)
 45   continue

c --- sort the atoms from extended cluster by distance from central
c     atom.
      call atheap(nat, rat2, iphat2, ra)

c --- define cluster from extended cluster by as those closer than
c     rmax to central atom
      inclus=0
      rmax2 = rmax**2
      do 50 i=1,nat
        rr = (rat2(1,i)**2 + rat2(2,i)**2 + rat2(3,i)**2)
        if (rr.gt.rmax2) then
            inclus = i-1
            goto 60
        endif
 50   continue
 60   continue
      if (inclus.eq.0) inclus=nat

c --- sanity check size of cluster
      if (inclus.gt.nclusx) then
        if (iwarn.eq.0) then
          call wlog('* * * WARNING preparing cluster for '//
     $                'FMS calculation.')
          write(line,400) inclus
 400      format('      You specified a cluster of ', i3,
     $                ' atoms for the FMS calculation.')
          call wlog(line)
          write(line,410)nclusx
          call wlog(line)
 410      format('      This exceeds the hard wired limit of ', i3,
     $                ' atoms.')
          write(line,420)nclusx
          call wlog(line)
 420      format('      The cluster size was reset to ', i3,
     $                ' and the calculation will continue.')
          iwarn = 1
        endif
        inclus = nclusx
      endif

c --- make the first few entries in xrat represent each of the
c     unique potentials, sorting around the chosen center
c     (iph0=0 for the absorbing atom)
c     call sortat(iph0, inclus, npot, iphat2, iphx, rat2, xrat)
      do 430 iat = 1, inclus
          iphx(iat) = iphat2(iat)
          xrat(1,iat) = real (rat2(1,iat))
          xrat(2,iat) = real (rat2(2,iat))
          xrat(3,iat) = real (rat2(3,iat))
 430  continue

c --- Calculate and store rotation matrix elements and phi angles
c     the k loop calculates the forward then the backward rotation
c     for an atom pair (ij). k = 0-->forward, 1-->backward
      call rotint
      lplus1 = lx+1
      mplus1 = lx+1
      do 150  i=1,inclus
        do 140 j=1,inclus
          rr = (xrat(1,i)-xrat(1,j))**2 + (xrat(2,i)-xrat(2,j))**2
     1       + (xrat(3,i)-xrat(3,j))**2
c         if (rr.gt.rdirec**2) goto 140

          call getang(nclusx, xrat, i, j, xbeta, xphi(i,j))
          if (i.eq.j) goto 140
          do 130 k=0,1
            if (k.eq.1) xbeta = (-1) * xbeta
            call rotxan(lplus1, mplus1, xbeta, i, j, k)
 130      continue
 140    continue
 150  continue

c --- calculate spherical harmonic normalization factors
      call xanlm(lplus1,mplus1)

      do 200 iat2=1,nclusx
      do 200 iat1=1,nclusx
        sigsqr(iat1,iat2) = zero
 200  continue

      return
      end


module stptgasmod

!$$$ module documentation block
!           .        .    .                                       .
! module:   stptgasmod    module for stptgas and its tangent linear stptgas_tl
!  prgmmr:
!
! abstract: module for stptgas and its tangent linear stptgas_tl
!
! program history log:
!   2014-08-22  weir    - initial code, based on stpozmod
!   2021-05-10  guo     - replaced ob_type by polymorphic obsNode with type casting
!
! subroutines included:
!   sub stptgas
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

implicit none

private
public :: stptgas

contains

subroutine stptgas(tgashead, rval, sval, out, sges, nstep)
!$$$  subprogram documentation block
!                .     .    .                                       .
! subprogram:    stptgas    compute contribution to penalty and stepsize for
!                           trace gases using nonlinear qc
!   prgmmr: weir            org: gmao                 date: 2014-08-22
!
! abstract: The routine computes the contribution to the penalty from trace
!           gas observations.  The routine also computes the contribution of
!           trace gas observations to the step size.  This version includes
!           nonlinear qc.
!
!  warning: I have no idea what this subroutine is supposed to compute, it
!           was merely translated from other stp routines and tested a
!           couple of times. It could contain serious errors (weir).
!
!
! program history log:
!   2014-08-22  weir    - initial code, based on stpozlay_
!
!   input argument list:
!     tgashead - trace gas obs type pointer to obs structure
!     rval     - search direction for trace gas
!     sval     - input trace gas correction field
!     sges     - step size estimates (nstep)
!     nstep    - number of stepsize estimates (== 0 means use outer iteration
!                value)
!
!   output argument list:
!     out(1:nstep) - contribution of trace gas data to penalty sges(1:nstep)
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use kinds,         only: r_kind, i_kind, r_quad
  use constants,     only: zero, zero_quad, one, r3600
  use gridmod,       only: lat2, lon2, nsig
  !use jfunc,         only: l_foto, xhat_dt, dhat_dt
  use gsi_bundlemod, only: gsi_bundle, gsi_bundlegetpointer
  use tgasinfo,      only: ihave_co, ihave_co2
  use m_obsNode,     only: obsNode
  use m_tgasNode,    only: tgasNode
  use m_tgasNode,    only: tgasNode_typecast
  use m_tgasNode,    only: tgasNode_nextcast
  implicit none

! Declare passed variables
  class(obsNode),     pointer, intent(in   ) :: tgashead
  integer(i_kind),             intent(in   ) :: nstep
  real(r_quad),                intent(inout) :: out(max(1,nstep))
  type(gsi_bundle),            intent(in   ) :: rval, sval
  real(r_kind),                intent(in   ) :: sges(max(1,nstep))

! Declare local variables
  integer(i_kind) :: i, j, k, l, ij, is, ier, istatus
  integer(i_kind) :: ij1, ij2, ij3, ij4 !, ij1x, ij2x, ij3x, ij4x
  integer(i_kind) :: nchanl, npro

  real(r_kind) :: w1, w2, w3, w4, tgas
  !real(r_kind) :: w1, w2, w3, w4, time, tgas
  real(r_quad) :: val, val1, val_lay, val1_lay, valr, vals

  character(len=256) :: obstype

  real(r_kind), dimension(max(1,nstep)) :: pen

  !real(r_kind), pointer,     dimension(:)     :: xhat_dt_co,  dhat_dt_co
  !real(r_kind), pointer,     dimension(:)     :: xhat_dt_co2, dhat_dt_co2
  real(r_kind), allocatable, dimension(:,:)   :: sco, rco, sco2, rco2
  real(r_kind), pointer,     dimension(:,:,:) :: scoptr,  rcoptr
  real(r_kind), pointer,     dimension(:,:,:) :: sco2ptr, rco2ptr

  type(tgasNode), pointer :: tgasptr

! Return if no trace gas observations
  if (.not. associated(tgashead)) return

! Initialize carbon monoxide arrays
  if (ihave_co) then
!    Retrieve pointers and return if any pointer not found
     ier = 0

     call gsi_bundlegetpointer(sval, 'co', scoptr, istatus)
     ier = istatus + ier
     call gsi_bundlegetpointer(rval, 'co', rcoptr, istatus)
     ier = istatus + ier

     !if (l_foto) then
     !   call gsi_bundlegetpointer(xhat_dt, 'co', xhat_dt_co, istatus)
     !   ier = istatus + ier
     !   call gsi_bundlegetpointer(dhat_dt, 'co', dhat_dt_co, istatus)
     !   ier = istatus + ier
     !end if

     if (ier /= 0) return

!    Can't do rank-2 pointer into rank-2, therefore, allocate work space
     allocate(sco(lat2*lon2,nsig), rco(lat2*lon2,nsig))

     do k = 1,nsig
        ij = 0
        do j = 1,lon2
           do i = 1,lat2
              ij = ij+1
              sco(ij,k) = scoptr(i,j,k)
              rco(ij,k) = rcoptr(i,j,k)
           end do
        end do
     end do
  end if

! Initialize carbon dioxide arrays
  if (ihave_co2) then
!    Retrieve pointers and return if any pointer not found
     ier = 0

     call gsi_bundlegetpointer(sval, 'co2', sco2ptr, istatus)
     ier = istatus + ier
     call gsi_bundlegetpointer(rval, 'co2', rco2ptr, istatus)
     ier = istatus + ier

     !if (l_foto) then
     !   call gsi_bundlegetpointer(xhat_dt, 'co2', xhat_dt_co2, istatus)
     !   ier = istatus + ier
     !   call gsi_bundlegetpointer(dhat_dt, 'co2', dhat_dt_co2, istatus)
     !   ier = istatus + ier
     !end if

     if (ier /= 0) return

!    Can't do rank-2 pointer into rank-2, therefore, allocate work space
     allocate(sco2(lat2*lon2,nsig), rco2(lat2*lon2,nsig))

     do k = 1,nsig
        ij = 0
        do j = 1,lon2
           do i = 1,lat2
              ij = ij+1
              sco2(ij,k) = sco2ptr(i,j,k)
              rco2(ij,k) = rco2ptr(i,j,k)
           end do
        end do
     end do
  end if

! Loop over trace gas observations
  tgasptr => tgasNode_typecast(tgashead)
  do while (associated(tgasptr))
     if (tgasptr%luse) then
!       Get level and constituent info
        obstype = tgasptr%obstype
        nchanl  = tgasptr%nchanl
        npro    = tgasptr%npro

        if (0 < nstep) then
!          Get location
           ij1 = tgasptr%ij(1)
           ij2 = tgasptr%ij(2)
           ij3 = tgasptr%ij(3)
           ij4 = tgasptr%ij(4)

           w1 = tgasptr%wij(1)
           w2 = tgasptr%wij(2)
           w3 = tgasptr%wij(3)
           w4 = tgasptr%wij(4)

           !if (l_foto) time = tgasptr%time*r3600
        end if

        do k = 1,nchanl
           if (0 < nstep) then
              val  =  zero_quad
              val1 = -tgasptr%res(k)

              if (trim(obstype) == 'mopitt' .and. ihave_co) then
                 do j = 1,npro
                    val_lay  = zero_quad
                    val1_lay = zero_quad

                    do l = 1,nsig
                       valr = w1*rco(ij1,l) + w2*rco(ij2,l) + &
                              w3*rco(ij3,l) + w4*rco(ij4,l)
                       vals = w1*sco(ij1,l) + w2*sco(ij2,l) + &
                              w3*sco(ij3,l) + w4*sco(ij4,l)

                       val_lay  = val_lay  + tgasptr%avgwgt(j,l)*valr
                       val1_lay = val1_lay + tgasptr%avgwgt(j,l)*vals

                       !if (l_foto) then
                       !   ij1x = ij1 + (l-1)*lat2*lon2
                       !   ij2x = ij2 + (l-1)*lat2*lon2
                       !   ij3x = ij3 + (l-1)*lat2*lon2
                       !   ij4x = ij4 + (l-1)*lat2*lon2

                       !   valr = w1*dhat_dt_co(ij1x) + w2*dhat_dt_co(ij2x) + &
                       !          w3*dhat_dt_co(ij3x) + w4*dhat_dt_co(ij4x)
                       !   vals = w1*xhat_dt_co(ij1x) + w2*xhat_dt_co(ij2x) + &
                       !          w3*xhat_dt_co(ij3x) + w4*xhat_dt_co(ij4x)

                       !   val_lay  = val_lay  + time*tgasptr%avgwgt(j,l)*valr
                       !   val1_lay = val1_lay + time*tgasptr%avgwgt(j,l)*vals
                       !end if
                    end do

                    val  = val  + tgasptr%avgker(k,j)*val_lay
                    val1 = val1 + tgasptr%avgker(k,j)*val1_lay
                 end do

              else if (trim(obstype) == 'acos' .and. ihave_co2) then
                 do j = 1,npro
                    val_lay  = zero_quad
                    val1_lay = zero_quad

                    do l = 1,nsig
                       valr = w1*rco2(ij1,l) + w2*rco2(ij2,l) + &
                              w3*rco2(ij3,l) + w4*rco2(ij4,l)
                       vals = w1*sco2(ij1,l) + w2*sco2(ij2,l) + &
                              w3*sco2(ij3,l) + w4*sco2(ij4,l)

                       val_lay  = val_lay  + tgasptr%avgwgt(j,l)*valr
                       val1_lay = val1_lay + tgasptr%avgwgt(j,l)*vals

                       !if (l_foto) then
                       !   ij1x = ij1 + (l-1)*lat2*lon2
                       !   ij2x = ij2 + (l-1)*lat2*lon2
                       !   ij3x = ij3 + (l-1)*lat2*lon2
                       !   ij4x = ij4 + (l-1)*lat2*lon2

                       !   valr = w1*dhat_dt_co2(ij1x) + w2*dhat_dt_co2(ij2x) + &
                       !          w3*dhat_dt_co2(ij3x) + w4*dhat_dt_co2(ij4x)
                       !   vals = w1*xhat_dt_co2(ij1x) + w2*xhat_dt_co2(ij2x) + &
                       !          w3*xhat_dt_co2(ij3x) + w4*xhat_dt_co2(ij4x)

                       !   val_lay  = val_lay  + time*tgasptr%avgwgt(j,l)*valr
                       !   val1_lay = val1_lay + time*tgasptr%avgwgt(j,l)*vals
                       !end if
                    end do

                    val  = val  + tgasptr%avgker(k,j)*val_lay
                    val1 = val1 + tgasptr%avgker(k,j)*val1_lay
                 end do

              else if (trim(obstype) == 'flask') then
                 if (ihave_co) then
                    val_lay  = w1*rco(ij1,1) + w2*rco(ij2,1) &
                             + w3*rco(ij3,1) + w4*rco(ij4,1)
                    val1_lay = w1*sco(ij1,1) + w2*sco(ij2,1) &
                             + w3*sco(ij3,1) + w4*sco(ij4,1)

                    !if (l_foto) then
                    !   val_lay  = val_lay  + time*(  w1*dhat_dt_co(ij1) &
                    !                               + w2*dhat_dt_co(ij2) &
                    !                               + w3*dhat_dt_co(ij3) &
                    !                               + w4*dhat_dt_co(ij4) )
                    !   val1_lay = val1_lay + time*(  w1*xhat_dt_co(ij1) &
                    !                               + w2*xhat_dt_co(ij2) &
                    !                               + w3*xhat_dt_co(ij3) &
                    !                               + w4*xhat_dt_co(ij4) )
                    !end if

                    val  = val  + tgasptr%avgker(k,1)*val_lay
                    val1 = val1 + tgasptr%avgker(k,1)*val1_lay
                 end if

                 if (ihave_co2) then
                    val_lay  = w1*rco2(ij1,1) + w2*rco2(ij2,1) &
                             + w3*rco2(ij3,1) + w4*rco2(ij4,1)
                    val1_lay = w1*sco2(ij1,1) + w2*sco2(ij2,1) &
                             + w3*sco2(ij3,1) + w4*sco2(ij4,1)
                    !if (l_foto) then
                    !   val_lay  = val_lay  + time*(  w1*dhat_dt_co2(ij1) &
                    !                               + w2*dhat_dt_co2(ij2) &
                    !                               + w3*dhat_dt_co2(ij3) &
                    !                               + w4*dhat_dt_co2(ij4) )
                    !   val1_lay = val1_lay + time*(  w1*xhat_dt_co2(ij1) &
                    !                               + w2*xhat_dt_co2(ij2) &
                    !                               + w3*xhat_dt_co2(ij3) &
                    !                               + w4*xhat_dt_co2(ij4) )
                    !end if

                    val  = val  + tgasptr%avgker(k,2)*val_lay
                    val1 = val1 + tgasptr%avgker(k,2)*val1_lay
                 end if

              end if

              do is = 1,nstep
                 tgas = val1 + sges(is)*val
                 pen(is) = tgasptr%err2(k)*tgas*tgas
              end do
           else
              pen(1) = tgasptr%res(k)*tgasptr%res(k)*tgasptr%err2(k)
           end if

           out(1) = out(1) + pen(1)*tgasptr%raterr2(k)
           do is = 2,nstep
              out(is) = out(is) + (pen(is) - pen(1))*tgasptr%raterr2(k)
           end do
        end do
     end if

     tgasptr => tgasNode_nextcast(tgasptr)
  end do ! loop over observations

! Clean
  if (ihave_co)  deallocate(sco,  rco)
  if (ihave_co2) deallocate(sco2, rco2)

  return

end subroutine stptgas

end module stptgasmod


      SUBROUTINE PHO_MASCOR(Irej)
C********************************************************************
C
C    check and adjust parton momenta for fragmentation
C
C    input:      /POEVT1/
C                /POSTRG/
C                IREJ    -1          initialization
C                        -2          output of statistics
C
C    output:     /POEVT1/
C                /POSTRG/
C                IREJ    0  successful
C                        1  failure
C
C    in case of very small string mass:
C       - direct manipulation of /POEVT1/ and /POEVT2/
C       - string will be deleted from /POSTRG/ (label -99)
C
C********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION am1 , am2 , am3 , am4 , chmass , cmass0 ,
     &                 cmass1 , cmass2 , dele , delm1 , delm2 , DEPS ,
     &                 DT_RNDM , EMIN , EPS , esum , fac , gam , gamb ,
     &                 p1
      DOUBLE PRECISION pc1 , pc2 , ptr
      INTEGER i , iccor , ictot , idev , ii , im1 , im2 , ineed , ip1 ,
     &        ip2 , ipos , Irej , irejl , ist , ista , istb , iter ,
     &        itouch , j1 , j2
      INTEGER k , k1 , k1a , k1b , k2 , k2a , k2b , niter
      SAVE

      PARAMETER (EPS=1.D-10,EMIN=0.3D0,DEPS=1.D-15)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  internal rejection counters
      INCLUDE 'inc/poloop'
C  model switches and parameters
      INCLUDE 'inc/pomdls'

C  standard particle data interface

      INCLUDE 'inc/poevt1'
C  extension to standard particle data interface (PHOJET specific)
      INCLUDE 'inc/poevt2'

C  color string configurations including collapsed strings and hadrons
      INCLUDE 'inc/postrg'

      DIMENSION pc1(4) , pc2(4) , p1(4) , ptr(4) , gam(3) , gamb(3)

      IF ( Irej.EQ.-1 ) THEN
         ictot = 0
         iccor = 0
         RETURN
      ELSE IF ( Irej.EQ.-2 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,2I8/)')
     &         'PHO_MASCOR: total/converted strings' , ictot , iccor
         RETURN
      END IF

      Irej = 0
      niter = 100
      iter = 0
      ictot = ictot + ISTr
      IF ( ISWmdl(7).EQ.-1 ) RETURN
C  debug /POSTRG/
      IF ( IDEb(42).GE.25 ) CALL PHO_PRSTRG

      itouch = 0
 100  iter = iter + 1
      IF ( iter.GE.niter ) THEN
         Irej = 1
         IF ( IDEb(42).GE.2 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,2I5)')
     &            'PHO_MASCOR: rejection' , iter , niter
            IF ( IDEb(42).GE.10 ) CALL PHO_PREVNT(0)
         END IF
         RETURN
      END IF

C  check mass limits
      IF ( DT_RNDM(cmass0).LT.0.5D0 ) THEN
         im1 = 1
         im2 = ISTr
         ist = 1
      ELSE
         im1 = ISTr
         im2 = 1
         ist = -1
      END IF
      DO i = im1 , im2 , ist
         j1 = NPOs(1,i)
         cmass0 = PHEp(5,j1)
C  get masses
         IF ( NCOde(i).EQ.3 ) THEN
            CALL PHO_MEMASS(IPAr1(i),IPAr2(i),am1,am2,am3,am4,ip1,ip2)
         ELSE IF ( (NCOde(i).EQ.4) .OR. (NCOde(i).EQ.6) ) THEN
            CALL PHO_BAMASS(IPAr1(i),IPAr2(i),IPAr3(i),am1,am2,am3,am4,
     &                      ip1,ip2)
         ELSE IF ( NCOde(i).EQ.5 ) THEN
            CALL PHO_DQMASS(IPAr1(i),IPAr2(i),IPAr3(i),IPAr4(i),am1,am2)
            am3 = 0.D0
            am4 = 0.D0
            ip1 = 0
            ip2 = 0
         ELSE IF ( NCOde(i).EQ.7 ) THEN
            am1 = 0.15D0
            am2 = 0.3D0
            am3 = 0.765D0
            am4 = 1.5D0
C??????????????????????????????????
            ip1 = 23
            ip2 = 33
C??????????????????????????????????
         ELSE IF ( NCOde(i).LT.0 ) THEN
            GOTO 200
         ELSE
            IF ( LPRi.GT.4 ) WRITE (LO,'(/,1X,A,2I5)')
     &            'PHO_MASCOR:ERROR: string no,NCODE ' , j1 , NCOde(i)
            CALL PHO_ABORT
         END IF
         IF ( LPRi.GT.4 .AND. IDEb(42).GE.20 )
     &         WRITE (LO,'(1X,A,/3X,I3,5E11.3,2I5)')
     &         'PHO_MASCOR: string no CHMASS,AM1,AM2,AM3,AM4,IP1,IP2:' ,
     &        i , cmass0 , am1 , am2 , am3 , am4 , ip1 , ip2
C  select masses to correct
         IBHad(i) = 0
         NNCh(i) = 0
C  correction needed?
C  no resonances for diquark-antidiquark and gluon-gluon strings
         IF ( NCOde(i).NE.5 ) THEN
            ineed = 0
C  resonances possible
            IF ( ISWmdl(7).EQ.0 ) THEN
               IF ( cmass0.LT.am1*0.99D0 ) THEN
                  IBHad(i) = ip1
                  NNCh(i) = -1
                  chmass = am1
                  ineed = 1
               ELSE IF ( cmass0.LT.MIN(am2,am4)*1.2D0 ) THEN
                  delm1 = 1.D0/((cmass0-am1)**2+EPS)
                  delm2 = 1.D0/((cmass0-am3)**2+EPS)
                  IF ( DT_RNDM(delm1).LT.delm1/(delm1+delm2) ) THEN
                     IBHad(i) = ip1
                     NNCh(i) = -1
                     chmass = am1
                  ELSE
                     IBHad(i) = ip2
                     NNCh(i) = 1
                     chmass = am3
                  END IF
               END IF
            ELSE IF ( (ISWmdl(7).EQ.1) .OR. (ISWmdl(7).EQ.2) ) THEN
               IF ( cmass0.LT.am1*0.99 ) THEN
                  IBHad(i) = ip1
                  NNCh(i) = -1
                  chmass = am1
                  ineed = 1
               END IF
            ELSE IF ( ISWmdl(7).EQ.3 ) THEN
               IF ( cmass0.LT.am1 ) THEN
                  Irej = 1
                  RETURN
               END IF
            ELSE
               IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,A,I5)')
     &               'PHO_MASCOR:ERROR:UNSUPPORTED ISWMDL(7)' ,
     &              ISWmdl(7)
               CALL PHO_ABORT
            END IF
         ELSE IF ( cmass0.LT.1.3D0*am1 ) THEN
            IF ( ISWmdl(7).LE.2 ) THEN
               IBHad(i) = 90
               NNCh(i) = -1
               chmass = am1*1.3D0
            ELSE
               Irej = 1
               RETURN
            END IF
         END IF
C
C  correction necessary?
         IF ( IBHad(i).NE.0 ) THEN
C  find largest invar. mass
            ipos = 0
            cmass1 = -1.D0
            DO j2 = NHEp , 3 , -1

               IF ( ABS(ISThep(j2)).EQ.1 ) THEN
                  IF ( (IPHist(1,j2).LE.0) .OR. (IPHist(1,j2).GT.ISTr) )
     &                 THEN
                     IF ( LPRi.GT.4 ) WRITE (LO,'(1X,2A,I7,I12)')
     &                     'PHO_MASCOR: ' ,
     &                    'inconsistent IPHIST(1,J2) entry (J2,KEV):' ,
     &                    j2 , KEVent
                     CALL PHO_PREVNT(0)
                  ELSE IF ( NCOde(IPHist(1,j2)).GT.0 ) THEN
                     cmass2 = (PHEp(4,j1)+PHEp(4,j2))
     &                        **2 - (PHEp(1,j1)+PHEp(1,j2))
     &                        **2 - (PHEp(2,j1)+PHEp(2,j2))
     &                        **2 - (PHEp(3,j1)+PHEp(3,j2))**2
                     IF ( cmass2.GT.cmass1 ) THEN
                        ipos = j2
                        cmass1 = cmass2
                     END IF
                  END IF
               END IF

            END DO
            j2 = ipos
            IF ( (j1.EQ.j2) .OR. (cmass1.LE.EMIN) ) THEN
               IF ( ineed.EQ.1 ) THEN
                  Irej = 1
                  RETURN
               ELSE
                  IBHad(i) = 0
                  NNCh(i) = 0
                  GOTO 200
               END IF
            END IF
            ista = ISThep(j1)
            istb = ISThep(j2)
            cmass1 = SQRT(cmass1)
            cmass2 = PHEp(5,j2)
            IF ( cmass1.LT.(cmass2+chmass) ) cmass2 = cmass1 -
     &           1.1D0*chmass
            Irej = 1
            IF ( cmass2.GT.0.D0 ) CALL PHO_MSHELL(PHEp(1,j1),PHEp(1,j2),
     &           chmass,cmass2,pc1,pc2,Irej)
            IF ( Irej.NE.0 ) THEN
               IFAil(24) = IFAil(24) + 1
               IF ( IDEb(42).GE.2 ) THEN
                  IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,2I4)')
     &                  'PHO_MASCOR: rejection by PHO_MSHELL (J1,J2):' ,
     &                 j1 , j2
                  IF ( IDEb(42).GE.10 ) CALL PHO_PREVNT(0)
               END IF
               Irej = 1
               RETURN
            END IF
C  momentum transfer
            DO ii = 1 , 4
               ptr(ii) = PHEp(ii,j2) - pc2(ii)
            END DO
            IF ( LPRi.GT.4 .AND. IDEb(42).GE.10 )
     &            WRITE (LO,'(1X,A,/5X,2I3,4E12.3)')
     &            'PHO_MASCOR: J1,J2,transfer' , j1 , j2 , ptr
C  copy parents of strings
C  register partons belonging to first string
            IF ( IDHep(j1).EQ.90 ) THEN
               k1 = JMOhep(1,j1)
               k2 = MAX(JMOhep(1,j1),-JMOhep(2,j1))
               esum = 0.D0
               DO ii = k1 , k2
                  esum = esum + PHEp(4,ii)
               END DO
               IF ( JMOhep(2,j1).GT.0 ) esum = esum +
     &              PHEp(4,JMOhep(2,j1))
               IF ( ABS(esum).LT.1.D-38 ) THEN
                  Irej = 1
                  RETURN
               END IF
               DO ii = k1 , k2
                  fac = PHEp(4,ii)/esum
                  DO k = 1 , 4
                     p1(k) = PHEp(k,ii) + fac*ptr(k)
                  END DO
                  CALL PHO_REGPAR(-1,IDHep(ii),0,j1,j2,p1(1),p1(2),
     &               p1(3),p1(4),IPHist(1,ii),IPHist(2,ii),ICOlor(1,ii),
     &               ICOlor(2,ii),ipos,1)
               END DO
               k1a = ipos + k1 - k2
               IF ( JMOhep(2,j1).GT.0 ) THEN
                  ii = JMOhep(2,j1)
                  fac = PHEp(4,ii)/esum
                  DO k = 1 , 4
                     p1(k) = PHEp(k,ii) + fac*ptr(k)
                  END DO
                  CALL PHO_REGPAR(-1,IDHep(ii),0,j1,j2,p1(1),p1(2),
     &               p1(3),p1(4),IPHist(1,ii),IPHist(2,ii),ICOlor(1,ii),
     &               ICOlor(2,ii),ipos,1)
               END IF
               k2a = -ipos
            ELSE
               k1a = j1
               k2a = j2
            END IF
C  register partons belonging to second string
            IF ( IDHep(j2).EQ.90 ) THEN
               CALL PHO_GETLTR(PHEp(1,j2),pc2,gam,gamb,dele,irejl)
               k1 = JMOhep(1,j2)
               k2 = MAX(JMOhep(1,j2),-JMOhep(2,j2))
               esum = 0.D0
               DO ii = k1 , k2
                  esum = esum + PHEp(4,ii)
               END DO
               IF ( JMOhep(2,j2).GT.0 ) esum = esum +
     &              PHEp(4,JMOhep(2,j2))
               DO ii = k1 , k2
                  IF ( esum.GT.0.D0 ) fac = PHEp(4,ii)/esum
                  IF ( irejl.EQ.0 ) THEN
                     CALL PHO_MKSLTR(PHEp(1,ii),p1,gam,gamb)
                     p1(4) = p1(4) + fac*dele
                  ELSE
                     DO k = 1 , 4
                        p1(k) = PHEp(k,ii) - fac*ptr(k)
                     END DO
                  END IF
                  CALL PHO_REGPAR(-1,IDHep(ii),0,j1,j2,p1(1),p1(2),
     &               p1(3),p1(4),IPHist(1,ii),IPHist(2,ii),ICOlor(1,ii),
     &               ICOlor(2,ii),ipos,1)
               END DO
               k1b = ipos + k1 - k2
               IF ( JMOhep(2,j2).GT.0 ) THEN
                  ii = JMOhep(2,j2)
                  fac = PHEp(4,ii)/esum
                  IF ( irejl.EQ.0 ) THEN
                     CALL PHO_MKSLTR(PHEp(1,ii),p1,gam,gamb)
                     p1(4) = p1(4) + fac*dele
                  ELSE
                     DO k = 1 , 4
                        p1(k) = PHEp(k,ii) - fac*ptr(k)
                     END DO
                  END IF
                  CALL PHO_REGPAR(-1,IDHep(ii),0,j1,j2,p1(1),p1(2),
     &               p1(3),p1(4),IPHist(1,ii),IPHist(2,ii),ICOlor(1,ii),
     &               ICOlor(2,ii),ipos,1)
               END IF
               k2b = -ipos
            ELSE
               k1b = j1
               k2b = j2
            END IF
C  register first string/collapsed to hadron
            IF ( (ISWmdl(7).EQ.0) .OR. (ISWmdl(7).EQ.1) ) THEN
               IF ( NCOde(i).NE.5 ) THEN
                  CALL PHO_REGPAR(1,0,IBHad(i),k1a,k2a,pc1(1),pc1(2),
     &               pc1(3),pc1(4),IPHist(1,j1),IPHist(2,j1),0,0,ipos,1)
C  label string as collapsed to hadron/resonance
                  NCOde(i) = -99
                  IDHep(j1) = 92
               ELSE
                  CALL PHO_REGPAR(-1,90,0,k1a,k2a,pc1(1),pc1(2),pc1(3),
     &               pc1(4),IPHist(1,j1),IPHist(2,j1),0,0,ipos,1)
                  IDHep(j1) = 91
               END IF
               NPOs(1,i) = ipos
               NPOs(2,i) = k1a
               NPOs(3,i) = k2a
            ELSE
               CALL PHO_REGPAR(ista,IDHep(j1),IMPart(j1),k1a,k2a,pc1(1),
     &            pc1(2),pc1(3),pc1(4),IPHist(1,j1),IPHist(2,j1),
     &            ICOlor(1,j1),ICOlor(2,j1),ipos,1)
               IF ( IDHep(j1).EQ.90 ) THEN
                  NPOs(1,IPHist(1,j1)) = ipos
                  NPOs(2,IPHist(1,j1)) = k1a
                  NPOs(3,IPHist(1,j1)) = k2a
C  label string as collapsed to resonance-string
                  IDHep(j1) = 91
               ELSE IF ( (IPHist(1,j1).GE.1) .AND.
     &                   (IPHist(1,j1).LE.ISTr) ) THEN
                  IF ( NPOs(1,IPHist(1,j1)).EQ.j1 ) NPOs(1,IPHist(1,j1))
     &                 = ipos
               END IF
            END IF
C  register second string/hadron/parton
            CALL PHO_REGPAR(istb,IDHep(j2),IMPart(j2),k1b,k2b,pc2(1),
     &                      pc2(2),pc2(3),pc2(4),IPHist(1,j2),
     &                      IPHist(2,j2),ICOlor(1,j2),ICOlor(2,j2),ipos,
     &                      1)
            IF ( IDHep(j2).EQ.90 ) THEN
               NPOs(1,IPHist(1,j2)) = ipos
               NPOs(2,IPHist(1,j2)) = k1b
               NPOs(3,IPHist(1,j2)) = k2b
C  label string touched by momentum transfer
               IDHep(j2) = 91
            ELSE IF ( (IPHist(1,j2).GE.1) .AND. (IPHist(1,j2).LE.ISTr) )
     &                THEN
               IF ( NPOs(1,IPHist(1,j2)).EQ.j2 ) NPOs(1,IPHist(1,j2))
     &              = ipos
            END IF
            iccor = iccor + 1
            itouch = itouch + 1
C  consistency checks
            IF ( IDEb(42).GE.5 ) THEN
               CALL PHO_CHECK(-1,idev)
               IF ( IDEb(42).GE.25 ) CALL PHO_PREVNT(0)
            END IF
C  jump to next iteration
            GOTO 100
         END IF
 200  END DO
C  debug output
      IF ( IDEb(42).GE.15 ) THEN
         IF ( (itouch.GT.0) .OR. (IDEb(42).GE.25) ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I5)')
     &            'PHO_MASCOR: iterations:' , iter
            CALL PHO_PREVNT(1)
         END IF
      END IF
      END SUBROUTINE


! Note, in general it is better to use the interface_mod.f90 located in matmodfits src/gen folder to ensure compatability
module interface_mod
    implicit none

    private
    public :: sim_template  ! Simulation template
    abstract interface

        subroutine sim_template(error, xvar, f_data, evec)
        use iso_c_binding
            double precision, intent(out)               :: error                        ! Error from simulation
            double precision, intent(in)                :: xvar(:)                      ! Variables to be simulated
            type(c_ptr)                                 :: f_data                       ! Data to be used in simulation
            double precision, intent(out), allocatable, optional     :: evec(:)         ! If requested, supplies vector with errors e_i
        end subroutine

    end interface

    contains

end module interface_mod

subroutine opt(simfun, xvar, lb, ub, user_data, error, f_data)
!DEC$ ATTRIBUTES DLLEXPORT :: opt
use iso_c_binding
use interface_mod
implicit none
    ! Input/output variables
    procedure(sim_template)                     :: simfun           ! Simulation procedure
    double precision, intent(inout)             :: xvar(:)          ! Initial parameters, to be updated to final optimized parameters
    double precision, intent(in)                :: lb(:), ub(:)     ! Lower and upper bounds for xvar
    double precision, allocatable, intent(in)   :: user_data(:)     ! User data to be used as optimization settings
    double precision, intent(out)               :: error            ! Error at optimized parameters
    type(c_ptr)                                 :: f_data           ! Data to be used in simulation, to be passed as pointer in user routines
    ! Internal variables
    double precision                            :: xbest(size(xvar))
    double precision                            :: ebest
    double precision                            :: alpha
    integer                                     :: n, nmax

    ! Make a very simple and stupid optimization algorithm
    ! Make a number of random guesses and see which one produce the lowest error
    nmax = int(user_data(1))
    call simfun(error, xvar, f_data)
    ebest = error
    xbest = xvar
    do n=2,nmax
        call random_number(xvar)    ! Random between 0 and 1
        xvar = xvar*(ub-lb) + lb    ! Random between lb and ub
        call simfun(error, xvar, f_data)
        if (error<ebest) then
            ebest = error
            xbest = xvar
            write(*,*) 'ebest = ', ebest
            write(*,*) xbest
            write(*,*)
        endif
    enddo
    error = ebest
    xvar = xbest

end subroutine


C     - DAEPACK Version 1.1 - Copyright (C) Numerica Technology, LLC
C     - DERIVATIVE COMPUTATION -
C     -   GENERATED: Wed Jan 31 02:09:44 2007
      subroutine res_rpar(t,y,yprime,cj,del,rpar,ipar,senpar,
     $   zzzderiv,zzzne,zzzirn,zzzjcn,zzziw)
!!independent { rpar }
!!dependent   { del(1:nstate) }
!DEC$ IF DEFINED(DLLEXP)
!DEC$ ATTRIBUTES DLLEXPORT :: res_rpar
!DEC$ END IF
      implicit none
      integer neqmax
      parameter(neqmax=500*25000)
      integer spmax
      parameter(spmax=500)
      integer rmax
      parameter(rmax=25000)
      integer tbrmax
      parameter(tbrmax=50)
      integer troemax
      parameter(troemax=50)
      integer lindemax
      parameter(lindemax=50)
      integer i
      integer j
      integer k
      double precision t
      double precision temperature
      integer nstate
      double precision pressure
      integer troereactionsize
      integer lindereactionsize
      integer ires
      double precision cj
      integer ijac
      integer senpar
      integer thirdbodyreactionsize
      integer nparam
      integer neq
      integer reactionsize
      double precision thirdbodyreactionratearray
      integer thirdbodyreactionarray
      double precision y(neq)
      double precision reactionratearray
      integer ipar(*)
      double precision del(neq)
      double precision yprime(neq)
      double precision rpar(reactionsize+thirdbodyreactionsize+
     $     troereactionsize+lindereactionsize+nstate-1)
      integer reactionarray
      integer troereactionarray
      integer lindereactionarray
      double precision troereactionratearray
      double precision lindereactionratearray
      common /size/ nstate,neq,nparam,reactionsize,troereactionsize,
     $   thirdbodyreactionsize,lindereactionsize
      common /reac/ reactionratearray(5*rmax),
     $   thirdbodyreactionratearray(16*tbrmax),troereactionratearray(
     $   21*troemax),temperature,pressure,reactionarray(10*rmax),
     $   thirdbodyreactionarray(21*tbrmax),troereactionarray(22*
     $   troemax),lindereactionarray(21*lindemax),
     $   lindereactionratearray(17*lindemax)
C        zzzderiv - partial derivative array stored in sparse matrix
C                   format, pattern contained in zzzirn and zzzjcn.
C        zzzne    - number of entries in zzzderiv.
C        zzzirn   - row numbers for entries in zzzderiv.
C        zzzjcn   - column numbers for entries in zzzderiv.
      double precision zzzderiv(*)
      integer zzzne,zzzirn(zzzne),zzzjcn(zzzne)
C        zzziw - integer workspace array.
      integer zzziw(*)
C        zzzimodel - unique key for this model.
      integer zzzimodel
C
C     Define elementary variables and adjoints
      double precision zzzv1,zzzvbar1
      double precision zzzv2,zzzvbar2
      double precision zzzv3,zzzvbar3
C
C     Active variable offsets and counters
      integer deloft
      integer rparoft
      integer reactionratearrayoft
      integer thirdbodyreactionratearrayoft
      integer troereactionratearrayoft
      integer lindereactionratearrayoft
      integer temperatureoft
      integer pressureoft
      integer zzzindx
C     Declare number of independent and dependent variables
      integer zzzn
      integer zzzm
C     Loop control variables
      integer izzz1
C
C     Variable offsets for independent, dependent, and
C     non-common block local active variables.
      deloft=0
      rparoft=deloft+neq
C     Variable offsets for COMMON BLOCK size
C     Variable offsets for COMMON BLOCK reac
      reactionratearrayoft=0
      thirdbodyreactionratearrayoft=reactionratearrayoft+(5*rmax)
      troereactionratearrayoft=thirdbodyreactionratearrayoft+(16*tbrmax)
      lindereactionratearrayoft=troereactionratearrayoft+(21*troemax)
      temperatureoft=lindereactionratearrayoft+(17*lindemax)
      pressureoft=temperatureoft+1
C     Number of independent and dependent variables.
      zzzn=reactionsize+thirdbodyreactionsize+troereactionsize+
     $   lindereactionsize+nstate-1
      zzzm=nstate
C     Create unique identifier for this model.
      call GETMDLID(zzzimodel,'res_rpar')
C      call SETTABLESIZE()
C      call SETSEGMENTSIZE()
C      call SETNUMSEGMENTS()
C     Create SVM for SUBROUTINE/FUNCTION res
      call CREATESV(zzzimodel,1,zzzn)
C     Create SVM for SUBROUTINE/FUNCTION getflux
      call CREATESV(zzzimodel,2,zzzn)
C     Create SVM for COMMON BLOCK reac
      call CREATESV(zzzimodel,3,zzzn)
C     Create SVM for COMMON BLOCK size
      call CREATESV(zzzimodel,4,zzzn)
C     Construct mapping between independent variable offsets and indices
      zzzindx=0
      do izzz1=1,reactionsize+thirdbodyreactionsize+troereactionsize+
     $   lindereactionsize+nstate-1
         zzzindx=zzzindx+1
         zzziw(zzzindx)=rparoft+izzz1
      end do
C     Initialize independent variable gradients to Cartesian basis vectors.
      call DSETIVCV(1,zzzn,zzziw)
C
C     Save SVMs of arguments
      zzziw(1)=1
      zzziw(2)=1
C     Save current offsets for use within embedded subroutine
      zzziw(3)=deloft
      zzziw(4)=rparoft
C     Call modifed embedded subroutine
      call getflux_rpar(y,del,rpar,zzziw)
      do i=1,nstate
         zzzv3=del(i)-yprime(i)
         zzzvbar1=1.0d0
         del(i)=zzzv3
         call DSVM1(deloft+i,1,zzzvbar1,deloft+i,1)
C
      end do
C     Construct derivative matrix and sparsity pattern before returning.
C     Construct mapping between dependent variable offsets and indices
      zzzindx=0
      do izzz1=1,nstate
         zzzindx=zzzindx+1
         zzziw(zzzindx)=deloft+izzz1
      end do
      call DCPRVS(1,zzzm,zzziw,zzzderiv,zzzne,zzzirn,zzzjcn)
C     UNCOMMENT BELOW TO SAVE STATISTICS TO FILE
C           call writesvmstats(zzzimodel,'svm.stats')
C     Delete SVM for SUBROUTINES/FUNCTIONS
      call DELETESV(zzzimodel,1)
      call DELETESV(zzzimodel,2)
C     Delete SVM for COMMON BLOCK reac
      call DELETESV(zzzimodel,3)
C     Delete SVM for COMMON BLOCK size
      call DELETESV(zzzimodel,4)
C     Done
      end
      subroutine getflux_rpar(tempy,del,rpar,zzziw)
      implicit none
      integer neqmax
      parameter(neqmax=500*25000)
      integer spmax
      parameter(spmax=500)
      integer rmax
      parameter(rmax=25000)
      integer tbrmax
      parameter(tbrmax=50)
      integer troemax
      parameter(troemax=50)
      integer lindemax
      parameter(lindemax=50)
      integer numcollider
      double precision logpr
      double precision lowrate
      double precision frate
      double precision c
      double precision d
      double precision f
      integer i
      integer j
      double precision m
      double precision n
      double precision temperature
      double precision flux
      integer nstate
      double precision pressure
      double precision pr
      integer troereactionsize
      integer lindereactionsize
      double precision dg
      integer thirdbodyreactionsize
      integer nparam
      double precision alpha
      double precision logf
      double precision sumyprime
      integer direction
      integer neq
      double precision tstar
      double precision rate
      double precision rrate
      double precision keq
      integer rnum
      double precision fcent
      integer pnum
      double precision t3star
      double precision t2star
      integer reactionsize
      double precision sumy
      double precision inertefficiency
      double precision logfcent
      double precision inside
      double precision thirdbodyreactionratearray
      integer thirdbodyreactionarray
      double precision y(neq)
      double precision reactionratearray
      double precision tempy(*)
      double precision thermo(spmax)
      double precision del(*)
      double precision rpar(*)
      integer reactionarray
      integer troereactionarray
      integer lindereactionarray
      double precision troereactionratearray
      double precision lindereactionratearray
      common /size/ nstate,neq,nparam,reactionsize,troereactionsize,
     $   thirdbodyreactionsize,lindereactionsize
      common /reac/ reactionratearray(5*rmax),
     $   thirdbodyreactionratearray(16*tbrmax),troereactionratearray(
     $   21*troemax),temperature,pressure,reactionarray(10*rmax),
     $   thirdbodyreactionarray(21*tbrmax),troereactionarray(22*
     $   troemax),lindereactionratearray(17*lindemax),
     $   lindereactionarray(21*lindemax)
C     Additional arguments for partial derivative construction
C        zzziw - integer workspace
      integer zzziw(*)
C     Define elementary variables and adjoints
      double precision zzzv1,zzzvbar1
      double precision zzzv2,zzzvbar2
      double precision zzzv3,zzzvbar3
      double precision zzzv4,zzzvbar4
      double precision zzzv5,zzzvbar5
      double precision zzzv6,zzzvbar6
      double precision zzzv7,zzzvbar7
      double precision zzzv8,zzzvbar8
      double precision zzzv9,zzzvbar9
      double precision zzzv10,zzzvbar10
      double precision zzzv11,zzzvbar11
      double precision zzzv12,zzzvbar12
      double precision zzzv13,zzzvbar13
      double precision zzzv14,zzzvbar14
      double precision zzzv15,zzzvbar15
      double precision zzzv16,zzzvbar16
      double precision zzzv17,zzzvbar17
      double precision zzzv18,zzzvbar18
      double precision zzzv19,zzzvbar19
      double precision zzzv20,zzzvbar20
      double precision zzzv21,zzzvbar21
      double precision zzzv22,zzzvbar22
      double precision zzzv23,zzzvbar23
C
C     Active variable offsets and counters
      integer deloft
      integer rparoft
      integer reactionratearrayoft
      integer thirdbodyreactionratearrayoft
      integer troereactionratearrayoft
      integer lindereactionratearrayoft
      integer temperatureoft
      integer pressureoft
      integer thermooft
      integer frateoft
      integer dgoft
      integer keqoft
      integer rrateoft
      integer inertefficiencyoft
      integer moft
      integer alphaoft
      integer tstaroft
      integer t2staroft
      integer t3staroft
      integer lowrateoft
      integer rateoft
      integer fcentoft
      integer proft
      integer logfcentoft
      integer logproft
      integer noft
      integer coft
      integer insideoft
      integer logfoft
      integer foft
      integer sumyprimeoft
      integer zzzindx
      integer zzzsvm1
      integer zzzsvm2
      zzzsvm1=zzziw(1)
      zzzsvm2=zzziw(2)
C
C     Compute offsets for arguments and local non-common
C     block active variables
      deloft=zzziw(3)
      rparoft=zzziw(4)
C
      thermooft=0
      frateoft=thermooft+spmax
      dgoft=frateoft+1
      keqoft=dgoft+1
      rrateoft=keqoft+1
      inertefficiencyoft=rrateoft+1
      moft=inertefficiencyoft+1
      alphaoft=moft+1
      tstaroft=alphaoft+1
      t2staroft=tstaroft+1
      t3staroft=t2staroft+1
      lowrateoft=t3staroft+1
      rateoft=lowrateoft+1
      fcentoft=rateoft+1
      proft=fcentoft+1
      logfcentoft=proft+1
      logproft=logfcentoft+1
      noft=logproft+1
      coft=noft+1
      insideoft=coft+1
      logfoft=insideoft+1
      foft=logfoft+1
      sumyprimeoft=foft+1
C
C     Variable offsets for COMMON BLOCK size
C     Variable offsets for COMMON BLOCK reac
      reactionratearrayoft=0
      thirdbodyreactionratearrayoft=reactionratearrayoft+(5*rmax)
      troereactionratearrayoft=thirdbodyreactionratearrayoft+(16*tbrmax)
      lindereactionratearrayoft=troereactionratearrayoft+(21*troemax)
      temperatureoft=lindereactionratearrayoft+(17*lindemax)
      pressureoft=temperatureoft+1
C
      do i=1,neq
         del(i)=0
         call SVZ(deloft+i,zzzsvm1)
C
      end do
      do i=1,nstate-1
         y(i)=tempy(i)/tempy(nstate)
      end do
      y(nstate)=tempy(nstate)
      do i=1,nstate-1
         zzzvbar1=1.0d0
         thermo(i)=rpar(reactionsize+thirdbodyreactionsize+
     $      troereactionsize+lindereactionsize+i)
         call DSVM1(thermooft+i,2,1.0d0,rparoft+reactionsize+
     $      thirdbodyreactionsize+troereactionsize+lindereactionsize
     $      +i,zzzsvm2)
C
      end do
      do i=0,reactionsize-1
         zzzvbar1=1.0d0
         frate=rpar(i+1)
         call DSVM1(frateoft+1,2,1.0d0,rparoft+i+1,zzzsvm2)
C
         rnum=reactionarray(10*i+1)
         pnum=reactionarray(10*i+2)
         dg=0
         call SVZ(dgoft+1,2)
C
         do j=1,rnum
            zzzv3=dg-thermo(reactionarray(10*i+2+j))
            zzzvbar2=-1.0d0
            zzzvbar1=1.0d0
            dg=zzzv3
            call DSVM2(dgoft+1,2,zzzvbar2,thermooft+reactionarray(10*i+
     $         2+j),2,zzzvbar1,dgoft+1,2)
C
         end do
         do j=1,pnum
            zzzv3=dg+thermo(reactionarray(10*i+5+j))
            zzzvbar2=1.0d0
            zzzvbar1=1.0d0
            dg=zzzv3
            call DSVM2(dgoft+1,2,zzzvbar2,thermooft+reactionarray(10*i+
     $         5+j),2,zzzvbar1,dgoft+1,2)
C
         end do
         zzzv2=-dg
         zzzv4=zzzv2*4184
         zzzv6=zzzv4/8.314
         zzzv8=zzzv6/temperature
         zzzv9=exp(zzzv8)
         zzzv11=82.053*temperature
         zzzv14=rnum-pnum
         zzzv15=zzzv11**zzzv14
         zzzv16=zzzv9*zzzv15
         zzzvbar15=zzzv9
         zzzvbar11=zzzv14*zzzv11**(zzzv14-1.0d0)*zzzvbar15
         zzzvbar9=zzzv15
         zzzvbar8=zzzv9*zzzvbar9
         zzzvbar7=-zzzv8/temperature*zzzvbar8+82.053*zzzvbar11
         zzzvbar6=1.0d0/temperature*zzzvbar8
         zzzvbar4=1.0d0/8.314*zzzvbar6
         zzzvbar2=4184*zzzvbar4
         zzzvbar1=-zzzvbar2
         keq=zzzv16
         call DSVM2(keqoft+1,2,zzzvbar7,temperatureoft+1,3,zzzvbar1,
     $      dgoft+1,2)
C
         if(reactionarray(10*i+10)==1) then
            zzzv3=rpar(i+1)/keq
            zzzvbar2=-zzzv3/keq
            zzzvbar1=1.0d0/keq
            rrate=zzzv3
            call DSVM2(rrateoft+1,2,zzzvbar2,keqoft+1,2,zzzvbar1,
     $         rparoft+i+1,zzzsvm2)
C
         else
            rrate=0
            call SVZ(rrateoft+1,2)
C
         end if
         do j=1,rnum
            zzzv3=frate*y(reactionarray(10*i+2+j))
            zzzvbar1=y(reactionarray(10*i+2+j))
            frate=zzzv3
            call DSVM1(frateoft+1,2,zzzvbar1,frateoft+1,2)
C
         end do
         do j=1,pnum
            zzzv3=rrate*y(reactionarray(10*i+5+j))
            zzzvbar1=y(reactionarray(10*i+5+j))
            rrate=zzzv3
            call DSVM1(rrateoft+1,2,zzzvbar1,rrateoft+1,2)
C
         end do
         do j=1,rnum
            zzzv3=del(reactionarray(10*i+2+j))-frate
            zzzv5=zzzv3+rrate
            zzzvbar4=1.0d0
            zzzvbar2=-1.0d0
            zzzvbar1=1.0d0
            del(reactionarray(10*i+2+j))=zzzv5
            call DSVM3(deloft+reactionarray(10*i+2+j),zzzsvm1,zzzvbar4,
     $         rrateoft+1,2,zzzvbar2,frateoft+1,2,zzzvbar1,deloft+
     $         reactionarray(10*i+2+j),zzzsvm1)
C
         end do
         do j=1,pnum
            zzzv3=del(reactionarray(10*i+5+j))+frate
            zzzv5=zzzv3-rrate
            zzzvbar4=-1.0d0
            zzzvbar2=1.0d0
            zzzvbar1=1.0d0
            del(reactionarray(10*i+5+j))=zzzv5
            call DSVM3(deloft+reactionarray(10*i+5+j),zzzsvm1,zzzvbar4,
     $         rrateoft+1,2,zzzvbar2,frateoft+1,2,zzzvbar1,deloft+
     $         reactionarray(10*i+5+j),zzzsvm1)
C
         end do
      end do
      do i=0,thirdbodyreactionsize-1
         zzzvbar1=1.0d0
         frate=rpar(reactionsize+i+1)
         call DSVM1(frateoft+1,2,1.0d0,rparoft+reactionsize+i+1,
     $      zzzsvm2)
C
         rnum=thirdbodyreactionarray(i*21+1)
         pnum=thirdbodyreactionarray(i*21+2)
         dg=0
         call SVZ(dgoft+1,2)
C
         do j=1,rnum
            zzzv3=dg-thermo(thirdbodyreactionarray(21*i+2+j))
            zzzvbar2=-1.0d0
            zzzvbar1=1.0d0
            dg=zzzv3
            call DSVM2(dgoft+1,2,zzzvbar2,thermooft+
     $         thirdbodyreactionarray(21*i+2+j),2,zzzvbar1,dgoft+1,2)
C
         end do
         do j=1,pnum
            zzzv3=dg+thermo(thirdbodyreactionarray(21*i+5+j))
            zzzvbar2=1.0d0
            zzzvbar1=1.0d0
            dg=zzzv3
            call DSVM2(dgoft+1,2,zzzvbar2,thermooft+
     $         thirdbodyreactionarray(21*i+5+j),2,zzzvbar1,dgoft+1,2)
C
         end do
         zzzv2=-dg
         zzzv4=zzzv2*4184
         zzzv6=zzzv4/8.314
         zzzv8=zzzv6/temperature
         zzzv9=exp(zzzv8)
         zzzv11=82.053*temperature
         zzzv14=rnum-pnum
         zzzv15=zzzv11**zzzv14
         zzzv16=zzzv9*zzzv15
         zzzvbar15=zzzv9
         zzzvbar11=zzzv14*zzzv11**(zzzv14-1.0d0)*zzzvbar15
         zzzvbar9=zzzv15
         zzzvbar8=zzzv9*zzzvbar9
         zzzvbar7=-zzzv8/temperature*zzzvbar8+82.053*zzzvbar11
         zzzvbar6=1.0d0/temperature*zzzvbar8
         zzzvbar4=1.0d0/8.314*zzzvbar6
         zzzvbar2=4184*zzzvbar4
         zzzvbar1=-zzzvbar2
         keq=zzzv16
         call DSVM2(keqoft+1,2,zzzvbar7,temperatureoft+1,3,zzzvbar1,
     $      dgoft+1,2)
C
         zzzv3=pressure*1e-6
         zzzv5=zzzv3/8.314
         zzzv7=zzzv5/temperature
         zzzvbar6=-zzzv7/temperature
         zzzvbar5=1.0d0/temperature
         zzzvbar3=1.0d0/8.314*zzzvbar5
         zzzvbar1=1e-6*zzzvbar3
         inertefficiency=zzzv7
         call DSVM2(inertefficiencyoft+1,2,zzzvbar6,temperatureoft+1,3
     $      ,zzzvbar1,pressureoft+1,3)
C
         numcollider=thirdbodyreactionarray(i*21+11)
         do j=1,numcollider
            zzzv5=thirdbodyreactionratearray(16*i+6+j)-1
            zzzv6=y(thirdbodyreactionarray(i*21+11+j))*zzzv5
            zzzv7=inertefficiency+zzzv6
            zzzvbar5=y(thirdbodyreactionarray(i*21+11+j))
            zzzvbar3=zzzvbar5
            zzzvbar1=1.0d0
            inertefficiency=zzzv7
            call DSVM2(inertefficiencyoft+1,2,zzzvbar3,
     $         thirdbodyreactionratearrayoft+16*i+6+j,3,zzzvbar1,
     $         inertefficiencyoft+1,2)
C
         end do
         zzzv3=frate*inertefficiency
         zzzvbar2=frate
         zzzvbar1=inertefficiency
         frate=zzzv3
         call DSVM2(frateoft+1,2,zzzvbar2,inertefficiencyoft+1,2,
     $      zzzvbar1,frateoft+1,2)
C
         if(thirdbodyreactionarray(21*i+10)==1) then
            zzzv3=frate/keq
            zzzvbar2=-zzzv3/keq
            zzzvbar1=1.0d0/keq
            rrate=zzzv3
            call DSVM2(rrateoft+1,2,zzzvbar2,keqoft+1,2,zzzvbar1,
     $         frateoft+1,2)
C
         else
            rrate=0
            call SVZ(rrateoft+1,2)
C
         end if
         do j=1,rnum
            zzzv3=frate*y(thirdbodyreactionarray(21*i+2+j))
            zzzvbar1=y(thirdbodyreactionarray(21*i+2+j))
            frate=zzzv3
            call DSVM1(frateoft+1,2,zzzvbar1,frateoft+1,2)
C
         end do
         do j=1,pnum
            zzzv3=rrate*y(thirdbodyreactionarray(21*i+5+j))
            zzzvbar1=y(thirdbodyreactionarray(21*i+5+j))
            rrate=zzzv3
            call DSVM1(rrateoft+1,2,zzzvbar1,rrateoft+1,2)
C
         end do
         do j=1,rnum
            zzzv3=del(thirdbodyreactionarray(21*i+2+j))-frate
            zzzv5=zzzv3+rrate
            zzzvbar4=1.0d0
            zzzvbar2=-1.0d0
            zzzvbar1=1.0d0
            del(thirdbodyreactionarray(21*i+2+j))=zzzv5
            call DSVM3(deloft+thirdbodyreactionarray(21*i+2+j),zzzsvm1
     $         ,zzzvbar4,rrateoft+1,2,zzzvbar2,frateoft+1,2,zzzvbar1,
     $         deloft+thirdbodyreactionarray(21*i+2+j),zzzsvm1)
C
         end do
         do j=1,pnum
            zzzv3=del(thirdbodyreactionarray(21*i+5+j))+frate
            zzzv5=zzzv3-rrate
            zzzvbar4=-1.0d0
            zzzvbar2=1.0d0
            zzzvbar1=1.0d0
            del(thirdbodyreactionarray(21*i+5+j))=zzzv5
            call DSVM3(deloft+thirdbodyreactionarray(21*i+5+j),zzzsvm1
     $         ,zzzvbar4,rrateoft+1,2,zzzvbar2,frateoft+1,2,zzzvbar1,
     $         deloft+thirdbodyreactionarray(21*i+5+j),zzzsvm1)
C
         end do
      end do
      do i=0,troereactionsize-1
         rnum=troereactionarray(i*22+1)
         pnum=troereactionarray(i*22+2)
         dg=0
         call SVZ(dgoft+1,2)
C
         do j=1,rnum
            zzzv3=dg-thermo(troereactionarray(22*i+2+j))
            zzzvbar2=-1.0d0
            zzzvbar1=1.0d0
            dg=zzzv3
            call DSVM2(dgoft+1,2,zzzvbar2,thermooft+troereactionarray(
     $         21*i+2+j),2,zzzvbar1,dgoft+1,2)
C
         end do
         do j=1,pnum
            zzzv3=dg+thermo(troereactionarray(22*i+5+j))
            zzzvbar2=1.0d0
            zzzvbar1=1.0d0
            dg=zzzv3
            call DSVM2(dgoft+1,2,zzzvbar2,thermooft+troereactionarray(
     $         21*i+5+j),2,zzzvbar1,dgoft+1,2)
C
         end do
         zzzv2=-dg
         zzzv4=zzzv2*4184
         zzzv6=zzzv4/8.314
         zzzv8=zzzv6/temperature
         zzzv9=exp(zzzv8)
         zzzv11=82.053*temperature
         zzzv14=rnum-pnum
         zzzv15=zzzv11**zzzv14
         zzzv16=zzzv9*zzzv15
         zzzvbar15=zzzv9
         zzzvbar11=zzzv14*zzzv11**(zzzv14-1.0d0)*zzzvbar15
         zzzvbar9=zzzv15
         zzzvbar8=zzzv9*zzzvbar9
         zzzvbar7=-zzzv8/temperature*zzzvbar8+82.053*zzzvbar11
         zzzvbar6=1.0d0/temperature*zzzvbar8
         zzzvbar4=1.0d0/8.314*zzzvbar6
         zzzvbar2=4184*zzzvbar4
         zzzvbar1=-zzzvbar2
         keq=zzzv16
         call DSVM2(keqoft+1,2,zzzvbar7,temperatureoft+1,3,zzzvbar1,
     $      dgoft+1,2)
C
         zzzv3=pressure*1e-6
         zzzv5=zzzv3/8.314
         zzzv7=zzzv5/temperature
         zzzvbar6=-zzzv7/temperature
         zzzvbar5=1.0d0/temperature
         zzzvbar3=1.0d0/8.314*zzzvbar5
         zzzvbar1=1e-6*zzzvbar3
         m=zzzv7
         call DSVM2(moft+1,2,zzzvbar6,temperatureoft+1,3,zzzvbar1,
     $      pressureoft+1,3)
C
         numcollider=troereactionarray(i*22+11)
         do j=1,numcollider
            zzzv5=troereactionratearray(21*i+6+j)-1
            zzzv6=y(troereactionarray(i*22+11+j))*zzzv5
            zzzv7=m+zzzv6
            zzzvbar5=y(troereactionarray(i*22+11+j))
            zzzvbar3=zzzvbar5
            zzzvbar1=1.0d0
            m=zzzv7
            call DSVM2(moft+1,2,zzzvbar3,troereactionratearrayoft+21*i
     $         +6+j,3,zzzvbar1,moft+1,2)
C
         end do
         zzzvbar1=1.0d0
         alpha=troereactionratearray(21*i+17)
         call DSVM1(alphaoft+1,2,1.0d0,troereactionratearrayoft+21*i+
     $      17,3)
C
         zzzvbar1=1.0d0
         tstar=troereactionratearray(21*i+18)
         call DSVM1(tstaroft+1,2,1.0d0,troereactionratearrayoft+21*i+
     $      18,3)
C
         zzzvbar1=1.0d0
         t2star=troereactionratearray(21*i+19)
         call DSVM1(t2staroft+1,2,1.0d0,troereactionratearrayoft+21*i+
     $      19,3)
C
         zzzvbar1=1.0d0
         t3star=troereactionratearray(21*i+20)
         call DSVM1(t3staroft+1,2,1.0d0,troereactionratearrayoft+21*i+
     $      20,3)
C
         zzzvbar1=1.0d0
         lowrate=troereactionratearray(21*i+21)
         call DSVM1(lowrateoft+1,2,1.0d0,troereactionratearrayoft+21*i
     $      +21,3)
C
         zzzvbar1=1.0d0
         rate=rpar(reactionsize+thirdbodyreactionsize+i+1)
         call DSVM1(rateoft+1,2,1.0d0,rparoft+reactionsize+
     $      thirdbodyreactionsize+i+1,zzzsvm2)
C
         direction=troereactionarray(22*i+10)
         if(troereactionarray(22*i+22)==0) then
            zzzv3=1-alpha
            zzzv5=-temperature
            zzzv7=zzzv5/t3star
            zzzv8=exp(zzzv7)
            zzzv9=zzzv3*zzzv8
            zzzv11=zzzv5/tstar
            zzzv12=exp(zzzv11)
            zzzv13=alpha*zzzv12
            zzzv14=zzzv9+zzzv13
            zzzv16=-t2star
            zzzv17=zzzv16/temperature
            zzzv18=exp(zzzv17)
            zzzv19=zzzv14+zzzv18
            zzzvbar17=zzzv18
            zzzvbar16=1.0d0/temperature*zzzvbar17
            zzzvbar15=-zzzvbar16
            zzzvbar12=alpha
            zzzvbar11=zzzv12*zzzvbar12
            zzzvbar10=-zzzv11/tstar*zzzvbar11
            zzzvbar8=zzzv3
            zzzvbar7=zzzv8*zzzvbar8
            zzzvbar6=-zzzv7/t3star*zzzvbar7
            zzzvbar5=1.0d0/t3star*zzzvbar7+1.0d0/tstar*zzzvbar11
            zzzvbar4=-zzzvbar5-zzzv17/temperature*zzzvbar17
            zzzvbar3=zzzv8
            zzzvbar2=-zzzvbar3+zzzv12
            fcent=zzzv19
            call DSVM5(fcentoft+1,2,zzzvbar15,t2staroft+1,2,zzzvbar10,
     $         tstaroft+1,2,zzzvbar6,t3staroft+1,2,zzzvbar4,
     $         temperatureoft+1,3,zzzvbar2,alphaoft+1,2)
C
         else
            if(troereactionarray(22*i+22)==1) then
               zzzv3=1-alpha
               zzzv5=-temperature
               zzzv7=zzzv5/t3star
               zzzv8=exp(zzzv7)
               zzzv9=zzzv3*zzzv8
               zzzv11=zzzv5/tstar
               zzzv12=exp(zzzv11)
               zzzv13=alpha*zzzv12
               zzzv14=zzzv9+zzzv13
               zzzvbar12=alpha
               zzzvbar11=zzzv12*zzzvbar12
               zzzvbar10=-zzzv11/tstar*zzzvbar11
               zzzvbar8=zzzv3
               zzzvbar7=zzzv8*zzzvbar8
               zzzvbar6=-zzzv7/t3star*zzzvbar7
               zzzvbar5=1.0d0/t3star*zzzvbar7+1.0d0/tstar*zzzvbar11
               zzzvbar4=-zzzvbar5
               zzzvbar3=zzzv8
               zzzvbar2=-zzzvbar3+zzzv12
               fcent=zzzv14
               call DSVM4(fcentoft+1,2,zzzvbar10,tstaroft+1,2,
     $            zzzvbar6,t3staroft+1,2,zzzvbar4,temperatureoft+1,3,
     $            zzzvbar2,alphaoft+1,2)
C
            else
               stop
            end if
         end if
         d=0.14
         zzzv3=lowrate*m
         zzzv5=zzzv3/rate
         zzzvbar4=-zzzv5/rate
         zzzvbar3=1.0d0/rate
         zzzvbar2=lowrate*zzzvbar3
         zzzvbar1=m*zzzvbar3
         pr=zzzv5
         call DSVM3(proft+1,2,zzzvbar4,rateoft+1,2,zzzvbar2,moft+1,2,
     $      zzzvbar1,lowrateoft+1,2)
C
         if(fcent>=1e-30) then
            zzzv2=log10(fcent)
            zzzvbar1=1.0d0/(fcent*log(10.0))
            logfcent=log10(fcent)
            call DSVM1(logfcentoft+1,2,zzzvbar1,fcentoft+1,2)
C
         else
            logfcent=-30
            call SVZ(logfcentoft+1,2)
C
         end if
         if(pr>=1e-30) then
            zzzv2=log10(pr)
            zzzvbar1=1.0d0/(pr*log(10.0))
            logpr=log10(pr)
            call DSVM1(logproft+1,2,zzzvbar1,proft+1,2)
C
         else
            logpr=-30
            call SVZ(logproft+1,2)
C
         end if
         zzzv4=1.27*logfcent
         zzzv5=0.75-zzzv4
         zzzvbar4=-1.0d0
         zzzvbar3=1.27*zzzvbar4
         n=zzzv5
         call DSVM1(noft+1,2,zzzvbar3,logfcentoft+1,2)
C
         zzzv4=0.67*logfcent
         zzzv5=-0.4-zzzv4
         zzzvbar4=-1.0d0
         zzzvbar3=0.67*zzzvbar4
         c=zzzv5
         call DSVM1(coft+1,2,zzzvbar3,logfcentoft+1,2)
C
         zzzv3=logpr+c
         zzzv6=d*zzzv3
         zzzv7=n-zzzv6
         zzzv8=zzzv3/zzzv7
         zzzvbar7=-zzzv8/zzzv7
         zzzvbar6=-zzzvbar7
         zzzvbar4=zzzvbar7
         zzzvbar3=1.0d0/zzzv7+d*zzzvbar6
         zzzvbar2=zzzvbar3
         zzzvbar1=zzzvbar3
         inside=zzzv8
         call DSVM3(insideoft+1,2,zzzvbar4,noft+1,2,zzzvbar2,coft+1,2,
     $      zzzvbar1,logproft+1,2)
C
         zzzv5=inside**2
         zzzv6=1+zzzv5
         zzzv7=logfcent/zzzv6
         zzzvbar6=-zzzv7/zzzv6
         zzzvbar5=zzzvbar6
         zzzvbar3=2*inside*zzzvbar5
         zzzvbar1=1.0d0/zzzv6
         logf=zzzv7
         call DSVM2(logfoft+1,2,zzzvbar3,insideoft+1,2,zzzvbar1,
     $      logfcentoft+1,2)
C
         zzzv3=10**logf
         zzzvbar2=zzzv3*log(10.0)
         f=zzzv3
         call DSVM1(foft+1,2,zzzvbar2,logfoft+1,2)
C
         IF (RNUM .GT. 1 .AND. PNUM .GT. 1) THEN
            zzzv4=1+pr
            zzzv5=1.0d0/zzzv4
            zzzv6=lowrate*zzzv5
            zzzv8=zzzv6*f
            zzzvbar7=zzzv6
            zzzvbar6=f
            zzzvbar5=lowrate*zzzvbar6
            zzzvbar4=-zzzv5/zzzv4*zzzvbar5
            zzzvbar2=zzzvbar4
            zzzvbar1=zzzv5*zzzvbar6
            frate=zzzv8
            call DSVM3(frateoft+1,2,zzzvbar7,foft+1,2,zzzvbar2,
     $         proft+1,2,zzzvbar1,lowrateoft+1,2)
         ELSE
            zzzv4=1+pr
            zzzv5=pr/zzzv4
            zzzv6=rate*zzzv5
            zzzv8=zzzv6*f
            zzzvbar7=zzzv6
            zzzvbar6=f
            zzzvbar5=rate*zzzvbar6
            zzzvbar4=-zzzv5/zzzv4*zzzvbar5
            zzzvbar2=1.0d0/zzzv4*zzzvbar5+zzzvbar4
            zzzvbar1=zzzv5*zzzvbar6
            frate=zzzv8
            call DSVM3(frateoft+1,2,zzzvbar7,foft+1,2,zzzvbar2,
     $      proft+1,2,zzzvbar1,rateoft+1,2)
         END IF

         zzzv4=1+pr
         zzzv5=pr/zzzv4
         zzzv6=rate*zzzv5
         zzzv8=zzzv6*f
         zzzvbar7=zzzv6
         zzzvbar6=f
         zzzvbar5=rate*zzzvbar6
         zzzvbar4=-zzzv5/zzzv4*zzzvbar5
         zzzvbar2=1.0d0/zzzv4*zzzvbar5+zzzvbar4
         zzzvbar1=zzzv5*zzzvbar6
         frate=zzzv8
         call DSVM3(frateoft+1,2,zzzvbar7,foft+1,2,zzzvbar2,proft+1,2,
     $      zzzvbar1,rateoft+1,2)
C
         if(troereactionarray(22*i+10)==1) then
            zzzv3=frate/keq
            zzzvbar2=-zzzv3/keq
            zzzvbar1=1.0d0/keq
            rrate=zzzv3
            call DSVM2(rrateoft+1,2,zzzvbar2,keqoft+1,2,zzzvbar1,
     $         frateoft+1,2)
C
         else
            rrate=0
            call SVZ(rrateoft+1,2)
C
         end if
         do j=1,rnum
            zzzv3=frate*y(troereactionarray(22*i+2+j))
            zzzvbar1=y(troereactionarray(22*i+2+j))
            frate=zzzv3
            call DSVM1(frateoft+1,2,zzzvbar1,frateoft+1,2)
C
         end do
         do j=1,pnum
            zzzv3=rrate*y(troereactionarray(22*i+5+j))
            zzzvbar1=y(troereactionarray(22*i+5+j))
            rrate=zzzv3
            call DSVM1(rrateoft+1,2,zzzvbar1,rrateoft+1,2)
C
         end do
         do j=1,rnum
            zzzv3=del(troereactionarray(22*i+2+j))-frate
            zzzv5=zzzv3+rrate
            zzzvbar4=1.0d0
            zzzvbar2=-1.0d0
            zzzvbar1=1.0d0
            del(troereactionarray(22*i+2+j))=zzzv5
            call DSVM3(deloft+troereactionarray(22*i+2+j),zzzsvm1,
     $         zzzvbar4,rrateoft+1,2,zzzvbar2,frateoft+1,2,zzzvbar1,
     $         deloft+troereactionarray(22*i+2+j),zzzsvm1)
C
         end do
         do j=1,pnum
            zzzv3=del(troereactionarray(22*i+5+j))+frate
            zzzv5=zzzv3-rrate
            zzzvbar4=-1.0d0
            zzzvbar2=1.0d0
            zzzvbar1=1.0d0
            del(troereactionarray(22*i+5+j))=zzzv5
            call DSVM3(deloft+troereactionarray(22*i+5+j),zzzsvm1,
     $         zzzvbar4,rrateoft+1,2,zzzvbar2,frateoft+1,2,zzzvbar1,
     $         deloft+troereactionarray(22*i+5+j),zzzsvm1)
C
         end do
      end do

      do i=0,lindereactionsize-1
         rnum=lindereactionarray(i*21+1)
         pnum=lindereactionarray(i*21+2)
         dg=0
         call SVZ(dgoft+1,2)
C
         do j=1,rnum
            zzzv3=dg-thermo(lindereactionarray(21*i+2+j))
            zzzvbar2=-1.0d0
            zzzvbar1=1.0d0
            dg=zzzv3
            call DSVM2(dgoft+1,2,zzzvbar2,thermooft+lindereactionarray(
     $         20*i+2+j),2,zzzvbar1,dgoft+1,2)
C
         end do
         do j=1,pnum
            zzzv3=dg+thermo(lindereactionarray(21*i+5+j))
            zzzvbar2=1.0d0
            zzzvbar1=1.0d0
            dg=zzzv3
            call DSVM2(dgoft+1,2,zzzvbar2,thermooft+lindereactionarray(
     $         20*i+5+j),2,zzzvbar1,dgoft+1,2)
C
         end do
         zzzv2=-dg
         zzzv4=zzzv2*4184
         zzzv6=zzzv4/8.314
         zzzv8=zzzv6/temperature
         zzzv9=exp(zzzv8)
         zzzv11=82.053*temperature
         zzzv14=rnum-pnum
         zzzv15=zzzv11**zzzv14
         zzzv16=zzzv9*zzzv15
         zzzvbar15=zzzv9
         zzzvbar11=zzzv14*zzzv11**(zzzv14-1.0d0)*zzzvbar15
         zzzvbar9=zzzv15
         zzzvbar8=zzzv9*zzzvbar9
         zzzvbar7=-zzzv8/temperature*zzzvbar8+82.053*zzzvbar11
         zzzvbar6=1.0d0/temperature*zzzvbar8
         zzzvbar4=1.0d0/8.314*zzzvbar6
         zzzvbar2=4184*zzzvbar4
         zzzvbar1=-zzzvbar2
         keq=zzzv16
         call DSVM2(keqoft+1,2,zzzvbar7,temperatureoft+1,3,zzzvbar1,
     $      dgoft+1,2)
C
         zzzv3=pressure*1e-6
         zzzv5=zzzv3/8.314
         zzzv7=zzzv5/temperature
         zzzvbar6=-zzzv7/temperature
         zzzvbar5=1.0d0/temperature
         zzzvbar3=1.0d0/8.314*zzzvbar5
         zzzvbar1=1e-6*zzzvbar3
         m=zzzv7
         call DSVM2(moft+1,2,zzzvbar6,temperatureoft+1,3,zzzvbar1,
     $      pressureoft+1,3)
C
         numcollider=lindereactionarray(i*21+11)
         do j=1,numcollider
            zzzv5=lindereactionratearray(17*i+6+j)-1
            zzzv6=y(lindereactionarray(i*21+11+j))*zzzv5
            zzzv7=m+zzzv6
            zzzvbar5=y(lindereactionarray(i*21+11+j))
            zzzvbar3=zzzvbar5
            zzzvbar1=1.0d0
            m=zzzv7
            call DSVM2(moft+1,2,zzzvbar3,lindereactionratearrayoft+17*i
     $         +6+j,3,zzzvbar1,moft+1,2)
C
         end do

         zzzvbar1=1.0d0
         lowrate=lindereactionratearray(17*i+17)
         call DSVM1(lowrateoft+1,2,1.0d0,lindereactionratearrayoft+17*i
     $      +17,3)
C
         zzzvbar1=1.0d0
         rate=rpar(reactionsize+thirdbodyreactionsize+troereactionsize
     $      +i+1)
         call DSVM1(rateoft+1,2,1.0d0,rparoft+reactionsize+
     $      thirdbodyreactionsize+troereactionsize+i+1,zzzsvm2)
C
         direction=lindereactionarray(21*i+10)

         zzzv3=lowrate*m
         zzzv5=zzzv3/rate
         zzzvbar4=-zzzv5/rate
         zzzvbar3=1.0d0/rate
         zzzvbar2=lowrate*zzzvbar3
         zzzvbar1=m*zzzvbar3
         pr=zzzv5
         call DSVM3(proft+1,2,zzzvbar4,rateoft+1,2,zzzvbar2,moft+1,2,
     $      zzzvbar1,lowrateoft+1,2)
C
         IF (RNUM .GT. 1 .AND. PNUM .GT. 1) THEN
            zzzv4=1+pr
            zzzv5=1.0d0/zzzv4
            zzzvbar5=lowrate
            zzzvbar4=-zzzv5/zzzv4*zzzvbar5
            zzzvbar2=zzzvbar4
            zzzvbar1=zzzv5
            frate=zzzv5*zzzvbar5
            call DSVM2(frateoft+1,2,zzzvbar2,proft+1,2,
     $         zzzvbar1,lowrateoft+1,2)
         ELSE
            zzzv4=1+pr
            zzzv5=pr/zzzv4
            zzzvbar5=rate
            zzzvbar4=-zzzv5/zzzv4*zzzvbar5
            zzzvbar2=1.0d0/zzzv4*zzzvbar5+zzzvbar4
            zzzvbar1=zzzv5
            frate=zzzv5*zzzvbar5
            call DSVM2(frateoft+1,2,zzzvbar2,proft+1,2,
     $         zzzvbar1,rateoft+1,2)
         END IF
C
         if(lindereactionarray(21*i+10)==1) then
            zzzv3=frate/keq
            zzzvbar2=-zzzv3/keq
            zzzvbar1=1.0d0/keq
            rrate=zzzv3
            call DSVM2(rrateoft+1,2,zzzvbar2,keqoft+1,2,zzzvbar1,
     $         frateoft+1,2)
C
         else
            rrate=0
            call SVZ(rrateoft+1,2)
C
         end if
         do j=1,rnum
            zzzv3=frate*y(lindereactionarray(21*i+2+j))
            zzzvbar1=y(lindereactionarray(21*i+2+j))
            frate=zzzv3
            call DSVM1(frateoft+1,2,zzzvbar1,frateoft+1,2)
C
         end do
         do j=1,pnum
            zzzv3=rrate*y(lindereactionarray(21*i+5+j))
            zzzvbar1=y(lindereactionarray(21*i+5+j))
            rrate=zzzv3
            call DSVM1(rrateoft+1,2,zzzvbar1,rrateoft+1,2)
C
         end do
         do j=1,rnum
            zzzv3=del(lindereactionarray(21*i+2+j))-frate
            zzzv5=zzzv3+rrate
            zzzvbar4=1.0d0
            zzzvbar2=-1.0d0
            zzzvbar1=1.0d0
            del(lindereactionarray(21*i+2+j))=zzzv5
            call DSVM3(deloft+lindereactionarray(21*i+2+j),zzzsvm1,
     $         zzzvbar4,rrateoft+1,2,zzzvbar2,frateoft+1,2,zzzvbar1,
     $         deloft+lindereactionarray(21*i+2+j),zzzsvm1)
C
         end do
         do j=1,pnum
            zzzv3=del(lindereactionarray(21*i+5+j))+frate
            zzzv5=zzzv3-rrate
            zzzvbar4=-1.0d0
            zzzvbar2=1.0d0
            zzzvbar1=1.0d0
            del(lindereactionarray(21*i+5+j))=zzzv5
            call DSVM3(deloft+lindereactionarray(21*i+5+j),zzzsvm1,
     $         zzzvbar4,rrateoft+1,2,zzzvbar2,frateoft+1,2,zzzvbar1,
     $         deloft+lindereactionarray(21*i+5+j),zzzsvm1)
C
         end do
      end do

      sumyprime=0
      call SVZ(sumyprimeoft+1,2)
C
      sumy=0
      do i=1,nstate-1
         zzzv3=del(i)*tempy(nstate)
         zzzvbar1=tempy(nstate)
         del(i)=zzzv3
         call DSVM1(deloft+i,zzzsvm1,zzzvbar1,deloft+i,zzzsvm1)
C
      end do
      do i=1,nstate-1
         zzzv3=sumyprime+del(i)
         zzzvbar2=1.0d0
         zzzvbar1=1.0d0
         sumyprime=zzzv3
         call DSVM2(sumyprimeoft+1,2,zzzvbar2,deloft+i,zzzsvm1,
     $      zzzvbar1,sumyprimeoft+1,2)
C
      end do
      zzzv3=sumyprime*8.314
      zzzv5=zzzv3*temperature
      zzzv7=zzzv5/pressure
      zzzv9=zzzv7/1e-6
      zzzvbar7=1.0d0/1e-6
      zzzvbar6=-zzzv7/pressure*zzzvbar7
      zzzvbar5=1.0d0/pressure*zzzvbar7
      zzzvbar4=zzzv3*zzzvbar5
      zzzvbar3=temperature*zzzvbar5
      zzzvbar1=8.314*zzzvbar3
      del(nstate)=zzzv9
      call DSVM3(deloft+nstate,zzzsvm1,zzzvbar6,pressureoft+1,3,
     $   zzzvbar4,temperatureoft+1,3,zzzvbar1,sumyprimeoft+1,2)
C
C     Done
      end


c estimates depth to a single interface from an input receiver function
c  GAA 11/93
C   GAA 1/03  upgraded for Antelope 4.3u
	parameter (NMAX=16386,NMAX2=2*NMAX)
	character*80 argu, pfile

	dimension datin(NMAX),dat(NMAX),syn(NMAX2),res(NMAX),
     *    synsave(NMAX2)
	complex zfilt(NMAX),tranf(NMAX)
	real*8 alphm(10),betam(10),rhom(10),thkm(10)
	real*8 vp2,vs2,rho2,phvel
	character*1 astar(2), cdum
	character*80 atest

c DB stuff

	integer db(4), dbrf(4)
	real*8 t0_req, t1_req, t0, t1, srate
	character*10 sta, chan
	real zero
	include 'db.i'
c	include 'coords.i'

	equivalence(syn(1),tranf(1))

        data pi/3.141592653/
	data vp2/8.0d0/,vs2/4.62d0/,rho2/3.3d0/
	data alpbasin/3.9/,rhobasin/2.4/
c	data betbasin/2.3/
	data astar/" ","*"/,cdum/"\0"/
	data luniasp/21/, lunsyn/22/, lundat/23/

	write (0,*) "  DBDEPEST:  version 01.01.19GAA "

	zero = 0.
	izero = 0
	dpds = sqrt(3.0)
	dpdssed = sqrt(3.0)
c read command-line arguments
	if (iargc().lt.13) then
		write(0,*)
     -	"Usage: depest z1 z2 dz Vcrust Fmin Fmax Delta Tfit Zbasin VpVs
     -tshift inwf_file subset_rf [depest.pf]"
	    write(0,*) " subset_rf: dbsubset string to select desired RF"
	    write(0,*) "[depest.pf] can reset: vpm, vsm, rhom (mantle),"
 	    write(0,*) "    vpb,vsb,rhob (top-layer), vpvs, vpvssed"
c23456789012345678901234567890123456789012345678901234567890123456789012
c	    write(0,*) "NOTE:  Ain is now Del (distance, degrees)"

		stop
	end if
	call getarg(1,argu)
	read(argu,1000) z1
1000	format(f10.5)
	call getarg(2,argu)
	read(argu,1000) z2
	call getarg(3,argu)
	read(argu,1000) delz
	call getarg(4,argu)
	read(argu,1000) alphcr
	call getarg(5,argu)
	read(argu,1000) fmin
	call getarg(6,argu)
	read(argu,1000) fmax
	call getarg(7,argu)
	read(argu,1000) delta
	call getarg(8,argu)
	read(argu,1000) tfitmax
	call getarg(9,argu)
	read(argu,1000) zbasin
	call getarg(10,argu)
	read(argu,1000) dpdsin
	call getarg(11,argu)
	read(argu,*) tshift
	call getarg(13,atest)
	call getarg(12,argu)
	lb=lnblnk(argu)+1
	argu(lb:lb)='\0'
	if (iargc().gt.13) then
	  call getarg(14, pfile)
	  call readpf(pfile, vp2,vs2,rho2,alpbasin,betbasin,rhobasin,
     -		dpds, dpdssed)

	endif

c constants (uses my GETIASP for now)
	rpd = pi/180.
	call readiasp(luniasp)
	zsrc = 33.
	call getiasp(delta, zsrc, pt,st,dpdx,dpddep,dsdx,dsddep)
	raypar = dpdx/111.19
	phvel = 1./raypar
c	ainc = asin(raypar*vp2)
c	phvel = vp2/sin(ainc)

c Vp/Vs:  if there's a basin dpds refers to basin, otherwise to crust
	if (dpdsin.gt.0.1) then
	  if (zbasin.le.0.) then
	    dpds = dpdsin
	  else
	    dpdssed = dpdsin
	  endif
	endif
	betacr= alphcr/dpds
	if (zbasin.gt.0.) then
	    nl = 3
	    alphm(1) = alpbasin
	    betam(1) = alpbasin/dpdssed
	    rhom(1) = rhobasin
	    thkm(1) = zbasin
	else
	    nl = 2
	end if
	nlcr = nl - 1
	alphm(nlcr) = alphcr
	betam(nlcr) = betacr
c rough fit to Nafe-Drake
	rhocr = 2.7 + 0.2*(alphcr - 6.0)
	rhom(nlcr) = rhocr
	zupper = 0.
	if (nlcr.gt.1) then
	  do i=1, nlcr-1
	    zupper = zupper + thkm(i)
	  end do
	  if (zupper.gt.z2) then
	    write (0,*) " ERROR:  Seds thicker than z2"
	    stop
	  else if (zupper.gt.z1) then
	    write (0,*) "Warning: resetting z1 to ", zupper
	    z1 = zupper + 0.1
	  endif
	end if

c open db and get time series
	if ( dbopen_table ( argu, "r", db ) .lt. 0 )
     *         call die ( 0, "Can't open wfdisc table" )
	call dbsubset(dbrf, db, atest(1:lnblnk(atest)), "\0")
	call dbquery(dbrf, dbRECORD_COUNT, n)
	if (n.le.0) call die (0, "No records found")
	dbrf(4) = 0
c--- read wfdisc line
	if( dbgetv ( dbrf, "",
     * 	  "sta", sta, "chan", chan, "time", t0_req, "samprate", srate,
     *		"nsamp", numdb, 0) .lt. 0)
     *    call complain (0, "dbgetv error" )
	write (0,*) "station ",sta(1:lnblnk(sta)),
     -		" chan: ",chan(1:lnblnk(chan))," samprate ",srate

	if (numdb.gt.NMAX) then
	    write (0,*) "Too many points in wfdisc, just using ",NMAX
	    numdb = NMAX
	endif
	t1_req=t0_req + float(numdb-1)/srate
	delt = 1./srate
c--- get data (last 2 entries are "fill" and fill-value
	call trgetwf ( dbrf, cdum, datin, NMAX, t0_req, t1_req,
     *         t0, t1, npts, izero, zero )
	if ( npts .lt. 1 ) call die ( 0, "Couldnt read waveform")
	write(0,*) " Read in ",npts," data points starting ",t0
	numdb = npts

c-- avoid wraparound
	if (npts.lt.NMAX/2) then
	  numdb=2*npts
	  do i=npts+1,numdb
		datin(i) = 0.
	  end do
	endif

c -- construct 3-pole zero-phase butterworth filter and apply to data
	if (fmax.gt.0..or.fmin.gt.0.) then
     	    call mkbutter3(delt,df,numdb,nfilt,fmin,fmax,zfilt)
	    call filt(delt,df,numdb,nfilt,zfilt,datin,dat)
	else
	    do i=1,numdb
		dat(i) = datin(i)
	    end do
	    do i=numdb,nfilt
		dat(i) = 0.
	    end do
	end if

c debug output
	open(lundat,file="dat.filt")
	do i=1,numdb
	    write(lundat,*) float(i-1)*delt, dat(i)
	end do
	close(lundat)

c start up statistics
	    drms = 0.
	    nfit = min(numdb,1 + int(tfitmax/delt))
	    do i=1,nfit
	      drms = drms + dat(i)*dat(i)
	    end do
	    drms = sqrt(drms/float(nfit-1))

c -- solve the system
	nz = (z2-z1)/delz + 1
	zz = z1 - delz
	n2 = nfilt/2
	tleng = float(nfilt-1)*delt

c modify zfilt by a phase-shift
	ff = df
	do i=2,n2
	    zfilt(i)=zfilt(i)*cexp(cmplx(0.,-2.*pi*df*float(i)*tshift))
	enddo

	thkm(nlcr) = z1 - zupper
	do i=1, nl-1
	  write (0,2000) alphm(i), betam(i), rhom(i), thkm(i)
	enddo
	write (0,2000) vp2, vs2, rho2, 0.
2000	format("Vp: ",f6.3, " Vs: ", f6.3, " rho:", f5.3,
     -		" Thk:", f7.3)

	do k=1,nz
	    zz = zz + delz
	    thkm(nlcr) = zz - zupper

	    do i=1,nfilt
		tranf(i) = cmplx(0.,0.)
	    end do
          call rayle (n2,tleng,vp2,vs2,rho2,phvel, alphm,betam,rhom,
     2                   thkm, nl,tranf,3)
	    if (fmin.gt.0..or.fmax.gt.0.) then
	      do i=1,n2
		tranf(i) = tranf(i)*zfilt(i)
	      end do
	    end if
c force real output, and set Nyquist and DC response to zero

	    do i=2,n2
	 	tranf(nfilt-i+2)=conjg(tranf(i))
	    end do
            tranf(n2)=cmplx(real(tranf(n2+1)), 0.0)
            tranf(1)=cmplx(0.,0.)
c   recover time-domain response by IFFT, then normalize by 1/dt (?)
c  note --- this if forward:    call fast (x,n)
            call fsst (syn,nfilt)

c --- set residuals
c  rrms:  un-normalized rms of misfit
c  nrms:  rrms/rms of data
c  rms2:  rms misfit where data and synthetic are each normalized
c ** USE rms2 FOR BEST FIT HERe!
	    rrms = 0.
	    srms = 0.
	    do i=1,nfit
	      rrms = rrms + (dat(i)-syn(i))**2
	      srms = srms + syn(i)*syn(i)
	    end do
	    rrms = sqrt(rrms/float(nfit-1))
	    srms = sqrt(srms/float(nfit-1))
	    rms2 = 0.
	    do i=1,nfit
		rms2 = rms2 + (dat(i)/drms - syn(i)/srms)**2
	    end do
	    rms2 = sqrt(rms2/float(nfilt-1))
c  4/15/98:  next line fixed to not re-sqrt, after AFS suggestion
	    rmsn = rrms/drms
	    write(*,*) zz,rrms,rmsn,rms2
	    res(k) = rrms
	    if (k.eq.1.or.rms2.lt.rmsmin) then
	      do i=1,numdb
		synsave(i) = syn(i)*drms/srms
	      end do
	      rmsmin = rms2
	    end if
	end do

c debug output of best-fitting synthetic
	open(lunsyn,file="syn.filt")
	do i=1,numdb
	 	write(lunsyn,*) float(i-1)*delt, synsave(i)
	end do
	close(lunsyn)

	stop
	end


*
*     ------------------------------------------------------------------
*     3          P R O G R A M   L I S T I N G
*     ------------------------------------------------------------------
*
*
*     All comments in the program listing assume the radial function P
*     is the solution of an equation of the form
*
*      P" + ( 2Z/R - Y - L(L+1)/R**2 - E)P = X + T
*
*     where Y is called a potential function
*           X is called an exchange function, and
*           T includes contributions from off-diagonal energy parameter,
*             interactions between configurations, etc.
*
*     The program uses LOG(Z*R) as independent variable and
*                      P/DSQRT(R) as dependent variable.
*
*     Modified by:
*     G. Tachiev for simultaneous optimization of multiple blocks
*     August, 2000
*                  C O P Y R I G H T   2000
*     ------------------------------------------------------------------
*                   M A I N    P R O G R AM
*     ------------------------------------------------------------------
*
*       The MAIN program controls the overall calculation and  allows
*   a series of cases to be processed as one run.  Each  case  itself
*   may  consist  of  a  series of atoms or ions in an iso-electronic
*   sequence.  In each case, all but the initial  estimates  for  the
*   first  are  obtained  by  scaling  the previous results using the
*   scaling of Sec.  (7-2).   Mixing coefficients are left unchanged.
*
*
*
        PROGRAM MCHF
        IMPLICIT DOUBLE PRECISION(A-H,O-Z)

        PARAMETER (NWD=60,NOD=220,NOFFD=800,MTERM=20,MEIG=20)
        DIMENSION IVAR(NWD)
*
      CHARACTER EL*3,ATOM*6,TERMs(20)*6, string*72
      LOGICAL PRINT,LD,STRONG, quest
      CHARACTER*8 ANS*1
      character whp*5, buffer*8

      integer	    iblock, nblock
      INTEGER       IN,OUT,PRI,OUC,OUF,OUH,OUD,IOU(7)
      COMMON/INOUT/ IN,OUT,PRI,IUC,IUF,IUD,OUC,OUF,OUD,OUH,ISCW
      COMMON/LABEL/ EL(NWD),ATOM,TERMs
      LOGICAL       FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIEDKE
      COMMON/TEST/  FAIL,OMIT,EZERO,REL,ALL,TRACE
      COMMON/WAVE/  EC,ED,AZD,PDE(NOD),IJE(noffd),EIJ(noffd),IPR
      COMMON/PARAM/ H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID
     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
      COMMON/RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
      POINTER       (IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
     :     (IQMAX,MAX(1)),(QVARD,VARIED(1)),(QSUM,SUM(1)),(QS,S(1)),
     :     (QDPM,DPM(1)),(QACC,ACC(1)),(QMETH,METH(1)),(QIEPTR,IEPTR(1))
      COMMON/NEL/   IQP,IQN,IQL,IQAZ,IQMAX,QVARD,QSUM,QS,QDPM,QACC,
     :      QMETH,QIEPTR

      COMMON/STATE/INTPTR(6),IDIM,PKVAL,PVALUE,NZE,PIH,PJH,
     :             NCODIM,PCOEFF,PNIJPTR,PINPTR
*
      POINTER (QWT,WT(1)),(QWP,WP(1)),  (IQWPTR,W(1))
      COMMON /CFGS/ETOTAL,QWT,QWP,IQWPTR
      logical 			:: leigen(meig,mterm), lguess
      integer			:: unit_n
      character (len=5)		:: name_dotL
      double precision 			:: eigst_weight(meig,mterm)
      integer 			:: cf_tot(mterm)
      Character*2 idstring
      integer nume(mterm),iws(mterm),iiws(mterm),
     :        nze_bl(mterm), ncfg_bl(mterm), niv_bl(mterm),
     :        nze_max(mterm)
      character term_bl(mterm)*3
      pointer   (qeigvec,eigvec(1)),(pen,en(1))
      common/st/leigen,nblock,nume,iws,iiws,ncfg_bl,nze_bl,
     :          term_bl, qeigvec, pen, lguess,nze_max

      logical	:: hmx_memory, ico_memory, ih_memory, clst_memory
      common/memory_use/hmx_memory, ico_memory, ih_memory, clst_memory

*
*
      REAL TIME(2)
      EQUIVALENCE (IUC,IOU(1)),(OUC,IOU(4))
*
*  ***** Define unit numbers and open files *********************
*                                                               *
*        UNIT NUMBERS AND FILE NAMES MAY BE MACHINE             *
*        DEPENDENT. CHECK THE FOLLOWING SECTION.                *
*                                                               *
*        IN - Standard input unit, normally the terminal        *
*        OUT- Standard output unit, normally the terminal       *
*        PRI- Printer output unit or file.                      *
*                                                               *

*      ... initialize mpi

      IN = 5
      OUT = 6
      PRI = 3
      ISCW = 0

      OPEN(UNIT=PRI,FILE='summry',STATUS='UNKNOWN')

      ISCW = 0
      IWRITE = 6

*
*  *****  WRITE OUT HEADER
*
 9    FORMAT(//20X,'======================='/
     :         25X,'   M C H F  ... 2000   '/
     :         20X,'======================='/)

      write(iscw,9)
      write(iscw,*)

*
*  *****  WRITE OUT DIMENSION INFORMATION
*
      WRITE(iscw,99) 'NWD',NWD,'NO',NOD,'Lagrange Multipliers',(noffd)
99    FORMAT(//10X,'THE DIMENSIONS FOR THE CURRENT VERSION ARE:'/
     :       (10X,2(A6,'=',I3,4X),A,'=',I3/)/)
*
*  *****  INITIALIZE COMMON DATA ARRAYS
*

      CALL INITA
      CALL INITR
*                                                               *
*  ***** IN THE OPEN STATEMENTS CHECK FOR VALID FILE NAMES ******
*                                                               *

1     write(iscw, '(/A/A/)') ' START OF CASE',' ============='

      iuc = 21
      inquire(file='wfn.inp',exist=ld)
      if (ld) then
        iuf = 22
        open(unit=iuf,file='wfn.inp',status='old',form='unformatted')
      else
        iuf = 0
      end if
      iud = 23
*      open(unit=iud,file='yint.lst',status='old',form='unformatted')
*      open(unit=11,file='ih.lst',status='old',form='unformatted')
      open(unit=12,file='ico.lst',status='old',form='unformatted')
      open(unit=23,file='yint.lst',status='unknown',
     :     form='unformatted');
      ouc = 24
      ouf = 25
      open(unit=ouf,file='wfn.out',status='unknown',form='unformatted')
*     file cfg.h contains header information for the block
      open(unit=29,file ='cfg.h',status='old',form = 'formatted')
      open(unit=30,file ='cfg.inp',status='old',form = 'formatted')
      OPEN(unit=39,file='c.lst',status='old', form='unformatted')
      OPEN(UNIT=35,STATUS='SCRATCH',FORM='UNFORMATTED')

      lguess = .false.

*  ***** END OF INPUT/OUTPUT INTERFACE **************************
*

      FAIL = .FALSE.
      IJE(1:noffd) = 0
6     write(iscw,'(/A)') ' ATOM, Z in FORMAT(A, F) : '

      READ(IN,'(A)') STRING
      I = INDEX(STRING,',')
      IF ( I .EQ. 0) THEN
        write(iscw,*)' ATOM, and Z must be separated by commas '
        GO TO 6
      END IF
      ATOM = STRING(1:I-1)
      BUFFER = STRING(I+1:)
      J = INDEX(BUFFER,'.')
      IF (J .EQ. 0) THEN
        J = INDEX(BUFFER,' ')
        IF (J .NE. 0) BUFFER(J:J) = '.'
      END IF
      READ(BUFFER,'(F8.0)') Z

*
*  *****  DETERMINE DATA ABOUT THE PROBLEM
*
*  initialize logical variables for memory use
      hmx_memory = .true.;
      ico_memory = .true.;
      ih_memory = .true.;
      clst_memory = .true.;

      call data(IVAR,eigst_weight,cf_tot);

      do i = 1, nblock;
        unit_n = 40 + i;
        name_dotL = term_bl(i)//'.l';
        open(unit_n,file=name_dotL,status='unknown',form='formatted');
      end do;
*
*  *****  SET PARAMETERS TO THEIR DEFAULT VALUE; NO,REL, and STRONG
*         were set in SUBROUTINE DATA
*
13    PRINT = .FALSE.
      CFGTOL = 1.D-8
      SCFTOL = 1.D-7
      NSCF = 200
      IC = 0
      ACFG = D0
      LD = .TRUE.
      TRACE = .FALSE.

        write(iscw,'(/A)')'Default values for other parameters? (Y/N) '
        READ (IN,'(A)') ANS
        IF (ANS .EQ. 'N' .OR. ANS .EQ. 'n') THEN
*  *****  ADDITIONAL PARAMETERS
   50   write(iscw,'(/A)') ' Default values (NO,REL,STRONG) ? (Y/N) '
        READ(IN,'(A)') ANS
        IF (ANS .NE. 'Y' .AND. ANS .NE. 'y') THEN
          write(iscw,*) ' Enter values in FORMAT(I,L,L) '
          READ(IN,*) NO, REL, STRONG
          OMIT = .NOT. STRONG
          IF (NO .GT. (220)) THEN
            write(iscw,*)
     :            ' TOO MANY POINTS FOR EACH FUNCTION: MAX=(220)'
            STOP
          END IF
          ND = NO - 2
        END IF
        WRITE(iscw,61) ATOM,Z,NO,NWF,NWF-IB+1,NCFG,REL
61    FORMAT(/1X,A6,F6.0,I6,3I3,L3)
         write(iscw,'(/A,A)')' Default values for',
     :   ' PRINT, CFGTOL, SCFTOL ? (Y/N) '
          READ(IN,'(A)') ANS
          IF ( ANS .NE. 'Y' .AND. ANS .NE. 'y'  ) THEN
             write(iscw,'(A)')' Input free FORMAT(L, F, F) '
             READ(IN,*) PRINT, CFGTOL, SCFTOL
          END IF
          write(iscw,'(/A)') ' Default values for NSCF, IC ? (Y/N) '
          READ(IN,'(A)') ANS
          IF (ANS .NE. 'Y' .AND. ANS .NE. 'y' ) THEN
             write(iscw,'(A)') ' Input free FORMAT(I, I) '
             READ(IN,*) NSCF, IC
          END IF
          write(iscw,'(/A)') 'Default values for ACFG,LD,TRACE? (Y/N) '
          READ(IN,'(A)') ANS
          IF (ANS .NE. 'Y' .AND. ANS .NE. 'y') THEN
             write(iscw,'(A)') ' Input free FORMAT( F, L, L) '
             READ(IN,*) ACFG,LD,TRACE
          END IF
        END IF

*     .. solve the problem
      CALL SCF(IVAR,ACFG,SCFTOL,CFGTOL,LD,eigst_weight,cf_tot)
      close(11);
      close(12);
      close(13);
      CALL OUTPUT(PRINT);
      CALL SUMMRY;
*
*      call etime(time)
*6     write(iscw,'(//A/A//A,F8.3,A//)') ' END OF CASE',' ===========',
*     :      ' Total CPU time was ', TIME(1)/60, ' minutes'
      CLOSE(PRI)

      END


c
c ---------------------------------------------------------------------
c
       subroutine qslopes(qp,qx,qy,mitot,mjtot,irr,lstgrd,lwidth,
     &                    hx,hy,xlow,ylow,qxx,qxy,qyy,mptr,nvar)
      implicit double precision(a-h,o-z)
      dimension qp(mitot,mjtot,nvar),qx(mitot,mjtot,nvar),
     &          qy(mitot,mjtot,nvar),irr(mitot,mjtot)
      dimension qxx(mitot,mjtot,nvar),qxy(mitot,mjtot,nvar)
      dimension qyy(mitot,mjtot,nvar)
      dimension recon(nvar)
      common /order2/ ssw, quad, nolimiter
      include "cirr.i"
      common   /userdt/ cfl,gamma,gamma1,xprob,yprob,alpha,Re,iprob,
     .                ismp,gradThreshold

      return
      end


C    %W% %G%
      subroutine svsss2
C * * *
C * * * THIS SUBROUTINE DECODES AND ERROR CHECKS TYPE X SUPPLEMENTARY
C * * * SIGNAL DATA FOR THE SVS MODEL.  IT IS CALLED BY INPUT3.
C * * *
      include 'tspinc/param.inc'
      include 'tspinc/svs.inc'
      include 'tspinc/inp3.inc'
      include 'tspinc/inp3a.inc'
      include 'tspinc/tzro.inc'
      include 'tspinc/prt.inc'
      dimension temp(16)
C     -     begin     begin     begin     begin     begin     begin
      read (work80(icard),8420) (temp(i),i=1,4)
8420  format (bz,16x,f4.0,3f4.4)

      if (isupt(ksv) .le. 0)then
         write(errbuf(1),8422)
8422     format(1h0,5x,'SUPPLEMENTARY DATA SUBTYPE D,E,OR F MUST INCLUDE
     1           subtype a,b, or c data')
          call prterr('E',1)
          imchn = 1
       endif

       if (temp(1) .eq. 0.0) then
         write(errbuf(1),8430) nbname,bkv,nid
8430     format(1h0,2x,a8,1x,f5.1,2x,a1,5x,
     1         'KS2 CANNOT BE ZERO')
         call prterr('E',1)
         imchn = 1
       endif

      if (temp(4) .le. 0.0)then
         write(errbuf(1),8450) nbname,bkv,nid
8450     format(1h0,2x,a8,1x,f5.1,2x,a1,5x,
     1          'TS12 MUST BE GREATER THAN ZERO')
         call prterr('E',1)
         imchn = 1
      endif

      if (imchn .eq. 1) return

      if (subtyp .eq.'D') then
         isupb(ksv) = 1
         go to 8490
      endif

8470  if (subtyp .eq. 'E') then
         isupb(ksv) = 2
         go to 8490
      endif

      isupb(ksv) = 3

8490  cks2(ksv) = temp(1)
      xcon = 2.0*frqbse/dtsvs
      as10(ksv) = xcon*temp(2) + 1.0
      as11(ksv) = xcon*temp(3) + 1.0
      as12(ksv) = xcon*temp(4) + 1.0
      ispcde(ksv) = 1                             !csw added 5/94

      return
      end