      SUBROUTINE DT_GETSPT(Pp1i,Ifpr1,Ifp1,Pp2i,Ifpr2,Ifp2,Pt1i,Ifta1,
     &                     Ift1,Pt2i,Ifta2,Ift2,Am1,Idch1,Am2,Idch2,
     &                     Idchai,Irej)

C***********************************************************************
C This version dated 12.12.94 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION Am1 , am1n , Am2 , am2n , amp1 , amp2 , amt1 ,
     &                 amt2 , b33p , b33t , cfe1 , cfe2 , diff ,
     &                 DT_RNDM , dum , ech , es , hpsp , hpst , p1
      DOUBLE PRECISION p2 , pp1 , Pp1i , pp2 , Pp2i , pt1 , Pt1i , pt2 ,
     &                 Pt2i , ptoch , ptotf , ptoti , ptotp1 , ptotp2 ,
     &                 ptott1 , ptott2 , PYMASS , redu , sfe1 , sfe2
      DOUBLE PRECISION TINY10 , TINY3 , TINY5 , xmp1 , xmp2 , xmt1 ,
     &                 xmt2 , ZERO
      INTEGER i , ic , Idch1 , Idch2 , Idchai , idum , Ifp1 , Ifp2 ,
     &        Ifpr1 , Ifpr2 , Ift1 , Ift2 , Ifta1 , Ifta2 , Irej ,
     &        irej1 , irej2 , jmshl , mode
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)

C various options for treatment of partons (DTUNUC 1.x)
C (chain recombination, Cronin,..)
      INCLUDE 'inc/dtchai'
C flags for input different options
      INCLUDE 'inc/dtflg1'
C flags for diffractive interactions (DTUNUC 1.x)
      INCLUDE 'inc/dtflg3'

      DIMENSION pp1(4) , Pp1i(4) , pp2(4) , Pp2i(4) , pt1(4) , Pt1i(4) ,
     &          pt2(4) , Pt2i(4) , p1(4) , p2(4) , Ifp1(2) , Ifp2(2) ,
     &          Ift1(2) , Ift2(2) , ptoti(4) , ptotf(4) , diff(4)

      ic = 0
      Irej = 0
C     B33P = 4.0D0
C     B33T = 4.0D0
C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
      redu = 1.0D0
C     B33P = 3.5D0
C     B33T = 3.5D0
      b33p = 4.0D0
      b33t = 4.0D0
      IF ( IDIff.NE.0 ) THEN
         b33p = 16.0D0
         b33t = 16.0D0
      END IF

      DO i = 1 , 4
         ptoti(i) = Pp1i(i) + Pp2i(i) + Pt1i(i) + Pt2i(i)
         pp1(i) = Pp1i(i)
         pp2(i) = Pp2i(i)
         pt1(i) = Pt1i(i)
         pt2(i) = Pt2i(i)
      END DO
C get initial chain masses
      ptoch = SQRT((pp1(1)+pt1(1))**2+(pp1(2)+pt1(2))**2+(pp1(3)+pt1(3))
     &        **2)
      ech = pp1(4) + pt1(4)
      Am1 = (ech+ptoch)*(ech-ptoch)
      ptoch = SQRT((pp2(1)+pt2(1))**2+(pp2(2)+pt2(2))**2+(pp2(3)+pt2(3))
     &        **2)
      ech = pp2(4) + pt2(4)
      Am2 = (ech+ptoch)*(ech-ptoch)
      IF ( (Am1.LT.0.0D0) .OR. (Am2.LT.0.0D0) ) THEN

         IF ( IOUlev(1).GT.0 .AND. LPRi.GT.4 )
     &         WRITE (LOUt,'(1X,A,2G10.3)')
     &         'GETSPT: too small chain masses 1' , Am1 , Am2

         Irej = 1
         GOTO 99999
      END IF
      Am1 = SQRT(Am1)
      Am2 = SQRT(Am2)
      am1n = ZERO
      am2n = ZERO

      mode = 0
C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
C        MODE = 0
C      ELSE
C         MODE = 1
C         IF (AM1.LT.0.6) THEN
C            B33P = 10.0D0
C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
CC           B33P = 4.0D0
C         ENDIF
C         IF (AM2.LT.0.6) THEN
C            B33T = 10.0D0
C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
CC           B33T = 4.0D0
C         ENDIF
C      ENDIF

C check chain masses for very low mass chains
C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
C    &            AM1,DUM,-IDCH1,IREJ1)
C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
C    &            AM2,DUM,-IDCH2,IREJ2)
C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
C        B33P = 20.0D0
C        B33T = 20.0D0
C     ENDIF

      jmshl = IMShl

 100  ic = ic + 1
      IF ( MOD(ic,15).EQ.0 ) b33p = 2.0D0*b33p
      IF ( MOD(ic,15).EQ.0 ) b33t = 2.0D0*b33t
      IF ( MOD(ic,18).EQ.0 ) redu = 0.0D0
C     IF (MOD(IC,19).EQ.0) JMSHL = 0
      IF ( MOD(ic,20).NE.0 ) THEN
C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
C        RETURN
C        GOTO 9999
C     ENDIF

C get transverse momentum
         IF ( LINtpt ) THEN
            es = -2.0D0/(b33p**2)
     &           *LOG(ABS(DT_RNDM(Am1)*DT_RNDM(Am2))+TINY10)
            hpsp = SQRT(es*es+2.0D0*es*0.94D0)
            hpsp = hpsp*redu
            es = -2.0D0/(b33t**2)
     &           *LOG(ABS(DT_RNDM(Am1)*DT_RNDM(Am2))+TINY10)
            hpst = SQRT(es*es+2.0D0*es*0.94D0)
            hpst = hpst*redu
         ELSE
            hpsp = ZERO
            hpst = ZERO
         END IF
         CALL DT_DSFECF(sfe1,cfe1)
         CALL DT_DSFECF(sfe2,cfe2)
         IF ( mode.EQ.0 ) THEN
            pp1(1) = Pp1i(1) + hpsp*cfe1
            pp1(2) = Pp1i(2) + hpsp*sfe1
            pp2(1) = Pp2i(1) - hpsp*cfe1
            pp2(2) = Pp2i(2) - hpsp*sfe1
            pt1(1) = Pt1i(1) + hpst*cfe2
            pt1(2) = Pt1i(2) + hpst*sfe2
            pt2(1) = Pt2i(1) - hpst*cfe2
            pt2(2) = Pt2i(2) - hpst*sfe2
         ELSE
            pp1(1) = Pp1i(1) + hpsp*cfe1
            pp1(2) = Pp1i(2) + hpsp*sfe1
            pt1(1) = Pt1i(1) - hpsp*cfe1
            pt1(2) = Pt1i(2) - hpsp*sfe1
            pp2(1) = Pp2i(1) + hpst*cfe2
            pp2(2) = Pp2i(2) + hpst*sfe2
            pt2(1) = Pt2i(1) - hpst*cfe2
            pt2(2) = Pt2i(2) - hpst*sfe2
         END IF

C put partons on mass shell
         xmp1 = 0.0D0
         xmt1 = 0.0D0
         IF ( jmshl.EQ.1 ) THEN

            xmp1 = PYMASS(Ifpr1)
            xmt1 = PYMASS(Ifta1)

         END IF
         CALL DT_MASHEL(pp1,pt1,xmp1,xmt1,p1,p2,irej1)
         IF ( irej1.NE.0 ) GOTO 100
         DO i = 1 , 4
            ptotf(i) = p1(i) + p2(i)
            pp1(i) = p1(i)
            pt1(i) = p2(i)
         END DO
         xmp2 = 0.0D0
         xmt2 = 0.0D0
         IF ( jmshl.EQ.1 ) THEN

            xmp2 = PYMASS(Ifpr2)
            xmt2 = PYMASS(Ifta2)

         END IF
         CALL DT_MASHEL(pp2,pt2,xmp2,xmt2,p1,p2,irej1)
         IF ( irej1.NE.0 ) GOTO 100
         DO i = 1 , 4
            ptotf(i) = ptotf(i) + p1(i) + p2(i)
            pp2(i) = p1(i)
            pt2(i) = p2(i)
         END DO

C check consistency
         DO i = 1 , 4
            diff(i) = ptoti(i) - ptotf(i)
         END DO
         IF ( (ABS(diff(1)).GT.TINY5) .OR. (ABS(diff(2)).GT.TINY5) .OR.
     &        (ABS(diff(3)).GT.TINY5) .OR. (ABS(diff(4)).GT.TINY5) )
     &        THEN

            IF ( LPRi.GT.4 ) WRITE (LOUt,'(1X,A,4G10.3)')
     &            'GETSPT: inconsistencies ' , diff
            Irej = 1
            GOTO 99999
         END IF
         ptotp1 = SQRT(pp1(1)**2+pp1(2)**2+pp1(3)**2)
         amp1 = SQRT(ABS((pp1(4)-ptotp1)*(pp1(4)+ptotp1)))
         ptotp2 = SQRT(pp2(1)**2+pp2(2)**2+pp2(3)**2)
         amp2 = SQRT(ABS((pp2(4)-ptotp2)*(pp2(4)+ptotp2)))
         ptott1 = SQRT(pt1(1)**2+pt1(2)**2+pt1(3)**2)
         amt1 = SQRT(ABS((pt1(4)-ptott1)*(pt1(4)+ptott1)))
         ptott2 = SQRT(pt2(1)**2+pt2(2)**2+pt2(3)**2)
         amt2 = SQRT(ABS((pt2(4)-ptott2)*(pt2(4)+ptott2)))
         IF ( (ABS(amp1-xmp1).GT.TINY3) .OR. (ABS(amp2-xmp2).GT.TINY3)
     &        .OR. (ABS(amt1-xmt1).GT.TINY3) .OR.
     &        (ABS(amt2-xmt2).GT.TINY3) ) THEN

            IF ( LPRi.GT.4 ) WRITE (LOUt,'(1X,A,2(4G10.3,/))')
     &            'GETSPT: inconsistent masses' , amp1 , xmp1 , amp2 ,
     &           xmp2 , amt1 , xmt1 , amt2 , xmt2
C sr 22.11.00: commented. It should only have inconsistent masses for
C ultrahigh energies due to rounding problems
C        GOTO 9999
         END IF

C get chain masses
         ptoch = SQRT((pp1(1)+pt1(1))**2+(pp1(2)+pt1(2))
     &           **2+(pp1(3)+pt1(3))**2)
         ech = pp1(4) + pt1(4)
         am1n = (ech+ptoch)*(ech-ptoch)
         ptoch = SQRT((pp2(1)+pt2(1))**2+(pp2(2)+pt2(2))
     &           **2+(pp2(3)+pt2(3))**2)
         ech = pp2(4) + pt2(4)
         am2n = (ech+ptoch)*(ech-ptoch)
         IF ( (am1n.LT.0.0D0) .OR. (am2n.LT.0.0D0) ) THEN

            IF ( IOUlev(1).GT.0 .AND. LPRi.GT.4 )
     &            WRITE (LOUt,'(1X,A,2G10.3)')
     &            'GETSPT: too small chain masses 2' , am1n , am2n
            GOTO 100
         END IF
         am1n = SQRT(am1n)
         am2n = SQRT(am2n)

C check chain masses for very low mass chains
         CALL DT_CH2RES(Ifp1(1),Ifp1(2),Ift1(1),Ift1(2),idum,idum,am1n,
     &                  dum,-Idch1,irej1)
         IF ( irej1.NE.0 ) GOTO 100
         CALL DT_CH2RES(Ifp2(1),Ifp2(2),Ift2(1),Ift2(2),idum,idum,am2n,
     &                  dum,-Idch2,irej2)
         IF ( irej2.NE.0 ) GOTO 100
      END IF

      IF ( am1n.GT.ZERO ) THEN
         Am1 = am1n
         Am2 = am2n
      END IF
      DO i = 1 , 4
         Pp1i(i) = pp1(i)
         Pp2i(i) = pp2(i)
         Pt1i(i) = pt1(i)
         Pt2i(i) = pt2(i)
      END DO

99999 END SUBROUTINE


!----------------------------------------------------------------------------------------------
! MODULE: read_all
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date June, 2017
!
!> @brief Contains subroutines for reading data from a variety of quantum chemistry formats.
!> @details
!----------------------------------------------------------------------------------------------
module read_all_mod
    use global_defs
    use molden_read_mod
    use turbomole_read_mod
    use molpro_output_read_mod
    implicit none

    private
    public :: read_geom
    public :: read_basis
    public :: read_mo
    public :: read_cis

contains

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: read_geom
    !> @brief Read geometry and list of atoms.
    !----------------------------------------------------------------------------------------------
    subroutine read_geom(dformat, path, geom, atom_symbol, atom_number)
        use element_mod
        character(len=*), intent(in) :: dformat
        character(len=*), intent(in) :: path
        real(dp), allocatable :: geom(:)
        character(len=2), allocatable, optional :: atom_symbol(:)
        integer, allocatable, optional :: atom_number(:)
        character(len=2), allocatable :: tsymbol(:)
        integer, allocatable :: tnumber(:)

        select case(dformat(:6))
        case('turbom')
            call turbomole_read_geom(path, geom, tsymbol)
            tnumber = element_s2z(tsymbol)
        case('molden')
            call molden_read_geom(path, geom, tsymbol, tnumber)
        case('molpro')
            call molpro_output_read_geom(path, geom, tsymbol, tnumber)
        case default
            write(stderr, *) 'Error in read_geom subroutine.'
            write(stderr, *) 'Input format not implemented: '//trim(adjustl(dformat))
        end select

        if (present(atom_symbol)) atom_symbol = tsymbol
        if (present(atom_number)) atom_number = tnumber
    end subroutine read_geom

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: read_basis
    !> @brief Read basis set information.
    !----------------------------------------------------------------------------------------------
    subroutine read_basis(dformat, path, basis)
        use basis_set_mod, only : basis_set
        character(len=*), intent(in) :: dformat
        character(len=*), intent(in) :: path
        type(basis_set), intent(inout) :: basis

        select case(dformat(:6))
        case('turbom')
            call turbomole_read_basis(path, basis)
        case('molden')
            select case(dformat)
            case('molden_orca')
                call molden_read_basis(path, basis, 3)
            case default
                call molden_read_basis(path, basis, 1)
            end select
        case('molpro')
            call molpro_output_read_basis(path, basis)
        case default
            write(stderr, *) 'Error in read_basis subroutine.'
            write(stderr, *) 'Input format not implemented: '//trim(adjustl(dformat))
            stop
        end select

        call basis%check_init()
    end subroutine read_basis

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: read_mo
    !> @brief Read molecular orbitals.
    !----------------------------------------------------------------------------------------------
    subroutine read_mo(dformat, path, mos, bs)
        use molecular_orbitals_mod, only : molecular_orbitals
        use basis_set_mod, only : basis_set
        character(len=*), intent(in) :: dformat
        character(len=*), intent(in) :: path
        type(molecular_orbitals) :: mos
        type(basis_set), intent(in), optional :: bs

        select case(dformat(:6))
        case('turbom')
            call turbomole_read_mo(path, mos)
        case('molden')
            select case(dformat)
            case('molden_tm2molden')
                if (.not. present(bs)) then
                    write(stderr, *) 'Error, read_mo called for tm2molden without passing bs.'
                    stop
                end if
                call molden_read_mo(path, mos, bs, 1)
            case('molden_cfour')
                if (.not. present(bs)) then
                    write(stderr, *) 'Error, read_mo called for cfour without passing bs.'
                    stop
                end if
                call molden_read_mo(path, mos, bs, 2)
            case('molden_orca')
                call molden_read_mo(path, mos, bs, 3)
            case default
                call molden_read_mo(path, mos)
            end select
        case('molpro_output')
            call molpro_output_read_mo(path, mos)
        case default
            write(stderr, *) 'Error in read_mo subroutine.'
            write(stderr, *) 'Input format not implemented: '//trim(adjustl(dformat))
        end select

        !< @todo add check for proper mos initialization
    end subroutine read_mo

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: read_cis
    !> @brief Read CIS wave function coefficients.
    !> @todo Add CIS type to hold relevant arrays.
    !> @todo Code cleaning
    !> @todo Orthogonalization for unrestricted wave functions?
    !----------------------------------------------------------------------------------------------
    subroutine read_cis(dformat, path, wfa, wfb, occ_mo, act_mo, cisa, cisb, occ_num, norm, orthog)
        use occupation_mod
        use wf_norm_mod
        use orthog_mod
        character(len=*), intent(in) :: dformat
        character(len=*), intent(in) :: path
        real(dp), allocatable, optional :: wfa(:, :)
        real(dp), allocatable, optional :: wfb(:, :)
        logical, allocatable, optional :: occ_mo(:, :)
        logical, allocatable, optional :: act_mo(:, :)
        real(dp), allocatable, optional :: cisa(:, :, :)
        real(dp), allocatable, optional :: cisb(:, :, :)
        type(occupation_numbers), optional :: occ_num
        logical, optional :: norm
        logical, optional :: orthog
        real(dp), allocatable :: twfa(:, :)
        real(dp), allocatable :: twfb(:, :)
        logical, allocatable :: tocc_mo(:, :)
        logical, allocatable :: tact_mo(:, :)
        type(occupation_numbers) :: on
        integer :: nex, rhf
        logical :: tnorm
        logical :: torthog

        tnorm = .true.
        if (present(norm)) tnorm = norm
        torthog = .true.
        if (present(orthog)) torthog = orthog

        select case(dformat)
        case('turbomole')
            call turbomole_read_cis(path, twfa, twfb, tocc_mo, tact_mo)
        case default
            write(stderr, *) 'Error in read_cis subroutine.'
            write(stderr, *) 'Input format not implemented: '//trim(adjustl(dformat))
        end select

        if (tnorm) call wfab_normalize(allocated(twfb), twfa, twfb)
        !---- Bad for unrestricted
        if (torthog) then
            call orthog_lowdin(twfa)
            if (allocated(twfb)) call orthog_lowdin(twfa)
        end if
        !----
        rhf = 1
        if (allocated(twfb)) rhf = 2
        call occ_mask_to_nums(rhf, tocc_mo, tact_mo, on)
        nex = size(twfa, 2)

        if (present(wfa) .and. allocated(twfa)) wfa = twfa
        if (present(wfb) .and. allocated(twfb)) wfb = twfb
        if (present(occ_mo) .and. allocated(tocc_mo)) occ_mo = tocc_mo
        if (present(act_mo) .and. allocated(tact_mo)) act_mo = tact_mo
        if (present(cisa) .and. allocated(twfa)) cisa = reshape(twfa, [on%av(1), on%ao(1), nex])
        if (present(cisb) .and. allocated(twfb)) cisb = reshape(twfb, [on%av(2), on%ao(2), nex])
        if (present(occ_num)) occ_num = on
    end subroutine read_cis

end module read_all_mod


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYDOCU
C...Handles the documentation of the process in MSTI and PARI,
C...and also computes cross-sections based on accumulated statistics.

      SUBROUTINE PYDOCU

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Commonblocks.
      include 'inc/pyjets'
      include 'inc/pydat1'
      include 'inc/pypars'
      include 'inc/pysubs'
      include 'inc/pyint1'
      include 'inc/pyint2'
      include 'inc/pyint5'

C...Calculate Monte Carlo estimates of cross-sections.
      ISUB=MINT(1)
      IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
      NGEN(0,3)=NGEN(0,3)+1
      XSEC(0,3)=0D0
      DO 100 I=1,500
        IF(I.EQ.96.OR.I.EQ.97) THEN
          XSEC(I,3)=0D0
        ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
     &    I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
          XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
     &    DBLE(NGEN(96,2)))
        ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
          XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
     &    DBLE(NGEN(96,2)))
        ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
          XSEC(I,3)=0D0
        ELSEIF(NGEN(I,2).EQ.0) THEN
          XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
     &    DBLE(NGEN(0,2)))
        ELSE
          XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
     &    DBLE(NGEN(I,2)))
        ENDIF
        XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
  100 CONTINUE

C...Rescale to known low-pT cross-section for standard QCD processes.
      IF(MSUB(95).EQ.1) THEN
        XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
     &  XSEC(68,3)+XSEC(95,3)
        XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
        IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
          FAC=XSECW/XSECH
          XSEC(11,3)=FAC*XSEC(11,3)
          XSEC(12,3)=FAC*XSEC(12,3)
          XSEC(13,3)=FAC*XSEC(13,3)
          XSEC(28,3)=FAC*XSEC(28,3)
          XSEC(53,3)=FAC*XSEC(53,3)
          XSEC(68,3)=FAC*XSEC(68,3)
          XSEC(95,3)=FAC*XSEC(95,3)
          XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
        ENDIF
      ENDIF

C...Save information for gamma-p and gamma-gamma.
      IF(MINT(121).GT.1) THEN
        IGA=MINT(122)
        CALL PYSAVE(2,IGA)
        CALL PYSAVE(5,0)
      ENDIF

C...Reset information on hard interaction.
      DO 110 J=1,200
        MSTI(J)=0
        PARI(J)=0D0
  110 CONTINUE

C...Copy integer valued information from MINT into MSTI.
      DO 120 J=1,32
        MSTI(J)=MINT(J)
  120 CONTINUE
      IF(MINT(121).GT.1) MSTI(9)=MINT(122)

C...Store cross-section variables in PARI.
      PARI(1)=XSEC(0,3)
      PARI(2)=XSEC(0,3)/MINT(5)
      PARI(7)=VINT(97)
      PARI(9)=VINT(99)
      PARI(10)=VINT(100)
      VINT(98)=VINT(98)+VINT(100)
      IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)

C...Store kinematics variables in PARI.
      PARI(11)=VINT(1)
      PARI(12)=VINT(2)
      IF(ISUB.NE.95) THEN
        DO 130 J=13,26
          PARI(J)=VINT(30+J)
  130   CONTINUE
        PARI(29)=VINT(39)
        PARI(30)=VINT(40)
        PARI(31)=VINT(141)
        PARI(32)=VINT(142)
        PARI(33)=VINT(41)
        PARI(34)=VINT(42)
        PARI(35)=PARI(33)-PARI(34)
        PARI(36)=VINT(21)
        PARI(37)=VINT(22)
        PARI(38)=VINT(26)
        PARI(39)=VINT(157)
        PARI(40)=VINT(158)
        PARI(41)=VINT(23)
        PARI(42)=2D0*VINT(47)/VINT(1)
      ENDIF

C...Store information on scattered partons in PARI.
      IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
        DO 140 IS=7,8
          I=MINT(IS)
          PARI(36+IS)=P(I,3)/VINT(1)
          PARI(38+IS)=P(I,4)/VINT(1)
          PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
          PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
     &    SQRT(PR),1D20)),P(I,3))
          PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
          PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
     &    SQRT(PR),1D20)),P(I,3))
          PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
          PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
          PARI(48+IS)=PYANGL(P(I,1),P(I,2))
  140   CONTINUE
      ENDIF

C...Store sum up transverse and longitudinal momenta.
      PARI(65)=2D0*PARI(17)
      IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
        DO 150 I=MSTP(126)+1,N
          IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
          PT=SQRT(P(I,1)**2+P(I,2)**2)
          PARI(69)=PARI(69)+PT
          IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
          IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
  150   CONTINUE
        PARI(67)=PARI(68)
        PARI(71)=VINT(151)
        PARI(72)=VINT(152)
        PARI(73)=VINT(151)
        PARI(74)=VINT(152)
      ELSE
        PARI(66)=PARI(65)
        PARI(69)=PARI(65)
      ENDIF

C...Store various other pieces of information into PARI.
      PARI(61)=VINT(148)
      PARI(75)=VINT(155)
      PARI(76)=VINT(156)
      PARI(77)=VINT(159)
      PARI(78)=VINT(160)
      PARI(81)=VINT(138)

C...Store information on lepton -> lepton + gamma in PYGAGA.
      MSTI(71)=MINT(141)
      MSTI(72)=MINT(142)
      PARI(101)=VINT(301)
      PARI(102)=VINT(302)
      DO 160 I=103,114
        PARI(I)=VINT(I+202)
  160 CONTINUE

C...Set information for PYTABU.
      IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
        MSTU(161)=MINT(21)
        MSTU(162)=0
      ELSEIF(ISET(ISUB).EQ.5) THEN
        MSTU(161)=MINT(23)
        MSTU(162)=0
      ELSE
        MSTU(161)=MINT(21)
        MSTU(162)=MINT(22)
      ENDIF

      RETURN
      END


c*************************************************************************
c                            DISCARD.F
c*************************************************************************
c This subroutine checks to see if a partical should be discarded because
c of its position or becuase it becomes unbound
c
c             Input:
c                 time          ==>  current time (real scalar)
c                 dt            ==>  time step  (real scalar)
c                 nbod          ==>  number of massive bodies (int scalar)
c                 ntp            ==>  number of massive bodies (int scalar)
c                 mass          ==>  mass of bodies (real array)
c                 xh,yh,zh      ==>   position in helio coord
c                                    (real arrays)
c                 vxh,vyh,vzh   ==>   pl vel in helio coord
c                                    (real arrays)
c                 xht,yht,zht    ==>   part position in helio coord
c                                      (real arrays)
c                 vxht,vyht,vzht ==>   velocity in helio coord
c                                        (real arrays)
c                 rmin,rmax      ==>  maximum and min distance from Sun
c                                     if <0  then don't check
c                                        (real scalar)
c                 rmaxu          ==>  maximum distance from Sun in not bound
c                                     if <0  then don't check
c                                        (real scalar)
c                  qmin          ==> Smallest perihelion distance
c                                      if <0  then don't check
c                                          (real scalar)
c                 lclose        ==> .true. --> discard particle if it gets
c                                    too close to a planet. Read in that
c                                    distance in io_init_pl
c                                      (logical*2 scalar)
c                 rplsq         ==>  min distance^2 that a tp can get from pl
c                                    (real array)
c                 istat           ==>  status of the test paricles
c                                      (2d  integer array)
c                                      istat(i,1) = 0 ==> active:  = 1 not
c                 rstat           ==>  status of the test paricles
c                                      (2d  real array)
c                                      rstat(i,1) closest approach to a planet
c
c             Output:
c                 istat           ==>  status of the test paricles
c                                      (2d  integer array)
c                                      istat(i,1) = 1 if discarded
c                                      istat(i,2) = -2  -> a<0 & r_helio>rmaxu
c	                               istat(i,2) = -3     r_helio>rmax
c	                               istat(i,2) = -4     q<qmin
c	                               istat(i,2) =  1     r_helio<rmin
c	                               istat(i,2) =  n    too close to planet n
c                 rstat           ==>  status of the test paricles
c                                      (2d  real array)
c                                      rstat(i,2) closest approach to a planet
c                                          as determined by encounter routines.
c
c             Output:
c                 istat           ==>  status of the test paricles
c                                      (2d  integer array)
c                                      istat(i,1) = 1 if discarded
c	                               istat(i,2) =  n    too close to planet n
c                 rstat           ==>  status of the test paricles
c                                      (2d  real array)
c                                      rstat(i,1) time of discard.
c
c Remarks:
c Authors:  Hal Levison
c Date:    3/2/93
c Last revision: 1/20/97

      subroutine discard(time,dt,nbod,ntp,mass,xh,yh,zh,vxh,
     &     vyh,vzh,xht,yht,zht,vxht,vyht,vzht,rmin,rmax,rmaxu,
     &     qmin,lclose,rplsq,istat,rstat)

      include '../swift.inc'

c...  Inputs:
      integer nbod,ntp
      real*8 mass(nbod),xh(nbod),yh(nbod),zh(nbod),time,rplsq(NPLMAX)
      real*8 vxh(nbod),vyh(nbod),vzh(nbod)
      real*8 xht(ntp),yht(ntp),zht(ntp)
      real*8 vxht(ntp),vyht(ntp),vzht(ntp)
      real*8 rmin,rmax,rmaxu,dt,qmin
      logical*2 lclose

c...  Input and Output
      integer istat(NTPMAX,NSTAT)
      real*8 rstat(NTPMAX,NSTATR)

c...  Internals
      real*8 xb(NPLMAX),yb(NPLMAX),zb(NPLMAX)
      real*8 vxb(NPLMAX),vyb(NPLMAX),vzb(NPLMAX)
      real*8 xbt(NTPMAX),ybt(NTPMAX),zbt(NTPMAX)
      real*8 vxbt(NTPMAX),vybt(NTPMAX),vzbt(NTPMAX),msys

c-----
c...  Executable code

      if( (rmin.ge.0.0) .or. (rmax.ge.0.0) .or. (rmaxu.ge.0.0) ) then
         call coord_h2b(nbod,mass,xh,yh,zh,vxh,vyh,vzh,
     &        xb,yb,zb,vxb,vyb,vzb,msys)
         call coord_h2b_tp(ntp,xht,yht,zht,vxht,vyht,vzht,
     &        xb(1),yb(1),zb(1),vxb(1),vyb(1),vzb(1),
     &        xbt,ybt,zbt,vxbt,vybt,vzbt)
         call discard_sun(time,ntp,msys,xht,yht,zht,xbt,ybt,zbt,
     &       vxbt,vybt,vzbt,rmin,rmax,rmaxu,istat,rstat)
      endif

      if(qmin.ge.0.0) then
         call discard_peri(time,ntp,xht,yht,zht,vxht,vyht,vzht,
     &        qmin,istat,rstat,nbod,mass,xh,yh,zh,vxh,vyh,vzh)
      endif

      if(lclose) then
         call discard_pl(time,dt,nbod,ntp,mass,xh,yh,zh,vxh,vyh,vzh,
     &       xht,yht,zht,vxht,vyht,vzht,rplsq,istat,rstat)
      endif

      return
      end    ! discard.f
c-----------------------------------------------------------------------


      SUBROUTINE DHC (P,PA,PB,XI,NAT,IF,IM,IL,JF,JM,JL,
     1NORBS,DENER)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION P(*), PA(*), PB(*)
      DIMENSION XI(3,*),NFIRST(2),NMIDLE(2),NLAST(2),NAT(*)
C***********************************************************************
C
C  DHC CALCULATES THE ENERGY CONTRIBUTIONS FROM THOSE PAIRS OF ATOMS
C         THAT HAVE BEEN MOVED BY SUBROUTINE DERIV.
C
C***********************************************************************
      COMMON /KEYWRD/ KEYWRD
     1       /ONELEC/ USS(107),UPP(107),UDD(107)
      COMMON /EULER / TVEC(3,3), ID
      COMMON /NUMCAL/ NUMCAL
      CHARACTER*80 KEYWRD
      LOGICAL UHF
      DIMENSION H(171), SHMAT(9,9), F(171),
     1          WJ(100), E1B(10), E2A(10), WK(100), W(100)
      DATA ICALCN /0/
      IF( ICALCN.NE.NUMCAL) THEN
         ICALCN=NUMCAL
         WLIM=4.D0
         IF(ID.EQ.0)WLIM=0.D0
         UHF=(INDEX(KEYWRD,'UHF') .NE. 0)
      ENDIF
      NFIRST(1)=1
      NMIDLE(1)=IM-IF+1
      NLAST(1)=IL-IF+1
      NFIRST(2)=NLAST(1)+1
      NMIDLE(2)=NFIRST(2)+JM-JF
      NLAST(2)=NFIRST(2)+JL-JF
      LINEAR=(NLAST(2)*(NLAST(2)+1))/2
      DO 10 I=1,LINEAR
         F(I)=0.D0
   10 H(I)=0.0D00
      DO 20 I=1,LINEAR
   20 F(I)=H(I)
      JA=NFIRST(2)
      JB=NLAST(2)
      JC=NMIDLE(2)
      IA=NFIRST(1)
      IB=NLAST(1)
      IC=NMIDLE(1)
      JT=JB*(JB+1)/2
      J=2
      I=1
      NJ=NAT(2)
      NI=NAT(1)
      CALL H1ELEC(NI,NJ,XI(1,1),XI(1,2),SHMAT)
      IF(NAT(1).EQ.102.OR.NAT(2).EQ.102) THEN
         K=(JB*(JB+1))/2
         DO 30 J=1,K
   30    H(J)=0.D0
      ELSE
         J1=0
         DO 40 J=JA,JB
            JJ=J*(J-1)/2
            J1=J1+1
            I1=0
            DO 40 I=IA,IB
               JJ=JJ+1
               I1=I1+1
               H(JJ)=SHMAT(I1,J1)
               F(JJ)=SHMAT(I1,J1)
   40    CONTINUE
      ENDIF
      KR=1
      IF(ID.EQ.0)THEN
         CALL ROTATE (NJ,NI,XI(1,2),XI(1,1),W(KR),KR,E2A,E1B,ENUCLR,100.
     1D0)
      ELSE
         CALL SOLROT (NJ,NI,XI(1,2),XI(1,1),WJ,WK,KR,E2A,E1B,ENUCLR,100.
     1D0)
      ENDIF
      IF(WJ(1).LT.WLIM)THEN
         DO 50 I=1,KR-1
   50    WK(I)=0.D0
      ENDIF
C
C    * ENUCLR IS SUMMED OVER CORE-CORE REPULSION INTEGRALS.
C
      I2=0
      DO 60 I1=IA,IC
         II=I1*(I1-1)/2+IA-1
         DO 60 J1=IA,I1
            II=II+1
            I2=I2+1
            H(II)=H(II)+E1B(I2)
   60 F(II)=F(II)+E1B(I2)
      DO  70 I1=IC+1,IB
         II=(I1*(I1+1))/2
         F(II)=F(II)+E1B(1)
   70 H(II)=H(II)+E1B(1)
      I2=0
      DO 80 I1=JA,JC
         II=I1*(I1-1)/2+JA-1
         DO 80 J1=JA,I1
            II=II+1
            I2=I2+1
            H(II)=H(II)+E2A(I2)
   80 F(II)=F(II)+E2A(I2)
      DO 90 I1=JC+1,JB
         II=(I1*(I1+1))/2
         F(II)=F(II)+E2A(1)
   90 H(II)=H(II)+E2A(1)
      CALL FOCK2D(F,P,PA,W, WJ, WK,2,NFIRST,NMIDLE,NLAST)
      EE=HELECT(NLAST(2),PA,H,F)
      IF( UHF ) THEN
         DO 100 I=1,LINEAR
  100    F(I)=H(I)
         CALL FOCK2D(F,P,PB,W, WJ, WK,2,NFIRST,NMIDLE,NLAST)
         EE=EE+HELECT(NLAST(2),PB,H,F)
      ELSE
         EE=EE*2.D0
      ENDIF
      DENER=EE+ENUCLR
      RETURN
C
      END


C$Procedure      CKFROT ( C-kernel, find rotation )

      SUBROUTINE CKFROT ( INST, ET, ROTATE, REF, FOUND )

C$ Abstract
C
C     Find the rotation from a C-kernel Id to the native
C     frame at the time requested.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     CK
C
C$ Keywords
C
C     POINTING
C
C$ Declarations

      IMPLICIT NONE
      INTEGER               INST
      DOUBLE PRECISION      ET
      DOUBLE PRECISION      ROTATE  ( 3, 3 )
      INTEGER               REF
      LOGICAL               FOUND

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     INST       I   NAIF instrument ID.
C     ET         I   Epoch measured in seconds past J2000.
C     ROTATE     O   rotation from CK platform to frame REF.
C     REF        O   Reference frame.
C     FOUND      O   True when requested pointing is available.
C
C$ Detailed_Input
C
C     INST       is the unique NAIF integer ID for the spacecraft
C                instrument for which data is being requested.
C
C     ET         is the epoch for which the state rotation
C                is desired. ET should be given in seconds past the
C                epoch of J2000.
C
C
C$ Detailed_Output
C
C     ROTATE     is a rotation matrix that converts
C                positions relative to the input frame (given by INST)
C                to positions relative to the frame REF.
C
C                Thus, if a state S has components x,y,z,dx,dy,dz
C                in the frame of INST, frame, then S has components
C                x', y', z', dx', dy', dz' in frame REF.
C
C                     [  x' ]     [           ] [  x ]
C                     |  y' |  =  |   ROTATE  | |  y |
C                     [  z' ]     [           ] [  z ]
C
C
C     REF        is the id-code reference frame to which ROTATE will
C                transform states.
C
C     FOUND      is true if a record was found to satisfy the pointing
C                request.  FOUND will be false otherwise.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If a C-kernel file is not loaded using CKLPF prior to calling
C         this routine, an error is signalled by a routine that this
C         routine calls.
C
C
C$ Files
C
C     CKFROT searches through files loaded by CKLPF to locate a segment
C     that can satisfy the request for position rotation
C     for instrument INST at time ET.  You must load a C-kernel
C     file using CKLPF before calling this routine.
C
C$ Particulars
C
C     CKFROT searches through files loaded by CKLPF to satisfy a
C     pointing request. Last-loaded files are searched first, and
C     individual files are searched in backwards order, giving
C     priority to segments that were added to a file later than the
C     others. CKFROT considers only those segments that contain
C     angular velocity data.
C
C     The search ends when a segment is found that can give pointing
C     for the specified instrument at the request time.
C
C$ Examples
C
C     None.
C
C$ Restrictions
C
C     A C-kernel file should have been loaded by CKLPF.
C
C     In addition it is helpful to load a CK-info file into the
C     Kernel pool.  This file should have the following variables
C     defined.
C
C       CK_<INST>_SCLK = SCLK idcode that yields SCLK mapping for INST.
C       CK_<INST>_SPK  = SPK idcode  that yields ephemeris for INST.
C
C     where <INST> is the integer string corresponding to INST.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.2.0, 17-FEB-2000 (WLT)
C
C        The routine now checks to make sure convert ET to TICKS
C        and that at least one C-kernel is loaded before trying
C        to look up the transformation.  Also the routine now calls
C        SCE2C instead of SCE2T.
C
C-    SPICELIB Version 1.0.0, 03-MAR-1999 (WLT)
C
C-&

C$ Index_Entries
C
C     get instrument frame rotation and reference frame
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN
      LOGICAL               FAILED
      LOGICAL               ZZSCLK

C
C     Local parameters
C
C        NDC        is the number of double precision components in an
C                   unpacked C-kernel segment descriptor.
C
C        NIC        is the number of integer components in an unpacked
C                   C-kernel segment descriptor.
C
C        NC         is the number of components in a packed C-kernel
C                   descriptor.  All DAF summaries have this formulaic
C                   relationship between the number of its integer and
C                   double precision components and the number of packed
C                   components.
C
C        IDLEN      is the length of the C-kernel segment identifier.
C                   All DAF names have this formulaic relationship
C                   between the number of summary components and
C                   the length of the name (You will notice that
C                   a name and a summary have the same length in bytes.)
C

      INTEGER               NDC
      PARAMETER           ( NDC = 2 )

      INTEGER               NIC
      PARAMETER           ( NIC = 6 )

      INTEGER               NC
      PARAMETER           ( NC = NDC + ( NIC + 1 )/2 )

      INTEGER               IDLEN
      PARAMETER           ( IDLEN = NC * 8 )

C
C     Local variables
C
      INTEGER               HANDLE
      INTEGER               ICD      ( NIC  )
      INTEGER               SCLKID

      DOUBLE PRECISION      AV       ( 3    )
      DOUBLE PRECISION      CLKOUT
      DOUBLE PRECISION      DESCR    ( NC   )
      DOUBLE PRECISION      DCD      ( NDC  )
      DOUBLE PRECISION      ROT      ( 3, 3 )
      DOUBLE PRECISION      TIME
      DOUBLE PRECISION      TOL

      CHARACTER*(IDLEN)     SEGID

      LOGICAL               NEEDAV
      LOGICAL               SFND
      LOGICAL               PFND
      LOGICAL               HAVE
C
C     Set FOUND to FALSE right now in case we end up
C     returning before doing any work.
C
      FOUND = .FALSE.
      REF   =  0

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'CKFROT' )
      END IF

C
C     We don't need angular velocity data.
C     Assume the segment won't be found until it really is.
C
      NEEDAV = .FALSE.
      TOL    =  0.0D0

C
C     Begin a search for this instrument and time, and get the first
C     applicable segment.
C
      CALL CKHAVE ( HAVE )
      CALL CKMETA ( INST,  'SCLK', SCLKID )

      IF ( .NOT. HAVE ) THEN
         CALL CHKOUT ( 'CKFROT' )
         RETURN
      ELSE IF ( .NOT. ZZSCLK ( INST, SCLKID ) ) THEN
         CALL CHKOUT ( 'CKFROT' )
         RETURN
      END IF

      CALL SCE2C  ( SCLKID, ET,            TIME   )
      CALL CKBSS  ( INST,   TIME,   TOL,   NEEDAV )
      CALL CKSNS  ( HANDLE, DESCR,  SEGID, SFND   )

C
C     Keep trying candidate segments until a segment can produce a
C     pointing instance within the specified time tolerance of the
C     input time.
C
C     Check FAILED to prevent an infinite loop if an error is detected
C     by a SPICELIB routine and the error handling is not set to abort.
C
      DO WHILE ( ( SFND ) .AND. ( .NOT. FAILED () ) )

         CALL CKPFS ( HANDLE, DESCR, TIME,   TOL, NEEDAV,
     .                ROT,    AV,    CLKOUT, PFND          )

         IF ( PFND ) THEN
C
C           Found one. Fetch the ID code of the reference frame
C           from the descriptor.
C
            CALL DAFUS  ( DESCR, NDC, NIC, DCD, ICD )
            REF   =  ICD( 2 )
            FOUND = .TRUE.
C
C           We now have the rotation matrix from
C           REF to INS. We invert ROT to get the rotation
C           from INST to REF.
C
            CALL XPOSE ( ROT, ROTATE )

            CALL CHKOUT ( 'CKFROT' )
            RETURN

         END IF

         CALL CKSNS ( HANDLE, DESCR, SEGID, SFND )

      END DO

      CALL CHKOUT ( 'CKFROT' )
      RETURN
      END


*
*     ------------------------------------------------------------------
*	O R T H
*
*     ------------------------------------------------------------------
*
      SUBROUTINE orth
*
*	Determine the orthogonality between initial and final state
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (NWD=128)
      POINTER(QNOC,NOCCSH(1)),(QNELCSH,NELCSH(8,1)),
     :       (QNOCORB,NOCORB(8,1)),(QJ1,J1QNRD(15,1))
      POINTER(QIAJCMP,IAJCMP(1)),(QLJCOMP,LJCOMP(1)),
     :       (QNJCOMP,NJCOMP(1)),(QIAJCLD,IAJCLD(1)),
     :       (QLJCLSD,LJCLSD(1))
      COMMON /NDIMS/ QNOC,QNELCSH,QNOCORB,QJ1,NCFG
      COMMON /NON30/ QIAJCMP,QNJCOMP,QLJCOMP,QIAJCLD,QLJCLSD,MAXORB
      POINTER (QIORTH,IORTH(1))
      COMMON/OVRLAP/MU,NU,MUP,NUP,NONORT,NOVLPS,IROWMU,IROWNU,ICOLMU,
     1 ICOLNU,NORTH,IORDER,NCALLS,LMU,LNU,LMUP,LNUP,JMU,JNU,JMUP,JNUP,
     2 QIORTH

      COMMON /NOR/NCOM,NCLOSI,NCLOSF,NORBI,NORBF,IWAR
*
*   SET UP OF IORTH VECTOR
*   THE COMMON SET (NCOM) IS ASSUMED TO BE ORTHOGONAL TO BOTH
*   NORBI AND NORBF SETS
*
      IF (NORBI .EQ. 0) RETURN
      M1 = NORBI*NORBF
      DO 70 I = 1,M1
      IORTH(I) = 0
   70 CONTINUE
      NORTH = 0
*
*  | 1....NCOM | NCOM1.....NOR1 | NOR11.....NOR2|
*  |   NCOM    |     NORBI      |     NORBF     |
*  |   <= NWD  |     <= NWD     |     <=NWD     |
*
*  THIS LIMITATION IS LINKED TO THE DIMENSION OF BUFFER(NWD) IN
*  ANALYSE SUBROUTINE, where <= stands for LESS THAN or EQUAL.
*
      NCOM1 = NCOM+1
      NOR1  = NCOM + NORBI
      NOR11 = NOR1 + 1
      NOR2  = NOR1 + NORBF
      DO 78 J = NCOM1,NOR1
      DO 79 I = NOR11,NOR2
         IJ = NORBF*(J-NCOM1) + I - NOR1
         IF (LJCOMP(I) .EQ. LJCOMP(J)) THEN
            NORTH = NORTH + 1
            IORTH(IJ) = 1
         ENDIF
   79 CONTINUE
   78 CONTINUE
      RETURN
      END


! KGEN-generated Fortran source file
!
! Filename    : rrlw_kg02.f90
! Generated at: 2015-07-06 23:28:44
! KGEN version: 0.4.13

    MODULE rrlw_kg02
        USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check
        USE shr_kind_mod, ONLY: r8 => shr_kind_r8
        !      use parkind ,only : jpim, jprb
        IMPLICIT NONE
        !-----------------------------------------------------------------
        ! rrtmg_lw ORIGINAL abs. coefficients for interval 2
        ! band 2:  250-500 cm-1 (low - h2o; high - h2o)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefao: real
        !fracrefbo: real
        ! kao     : real
        ! kbo     : real
        ! selfrefo: real
        ! forrefo : real
        !-----------------------------------------------------------------
        !-----------------------------------------------------------------
        ! rrtmg_lw COMBINED abs. coefficients for interval 2
        ! band 2:  250-500 cm-1 (low - h2o; high - h2o)
        !
        ! Initial version:  JJMorcrette, ECMWF, jul1998
        ! Revised: MJIacono, AER, jun2006
        !-----------------------------------------------------------------
        !
        !  name     type     purpose
        !  ----   : ----   : ---------------------------------------------
        !fracrefa : real
        !fracrefb : real
        ! ka      : real
        ! kb      : real
        ! absa    : real
        ! absb    : real
        ! selfref : real
        ! forref  : real
        !
        ! refparam: real
        !-----------------------------------------------------------------
        INTEGER, parameter :: ng2  = 12
        REAL(KIND=r8) :: fracrefa(ng2)
        REAL(KIND=r8) :: fracrefb(ng2)
        REAL(KIND=r8) :: absa(65,ng2)
        REAL(KIND=r8) :: absb(235,ng2)
        REAL(KIND=r8) :: selfref(10,ng2)
        REAL(KIND=r8) :: forref(4,ng2)
        PUBLIC kgen_read_externs_rrlw_kg02
    CONTAINS

    ! write subroutines

    ! module extern variables

    SUBROUTINE kgen_read_externs_rrlw_kg02(kgen_unit)
        INTEGER, INTENT(IN) :: kgen_unit
        READ(UNIT=kgen_unit) fracrefa
        READ(UNIT=kgen_unit) fracrefb
        READ(UNIT=kgen_unit) absa
        READ(UNIT=kgen_unit) absb
        READ(UNIT=kgen_unit) selfref
        READ(UNIT=kgen_unit) forref
    END SUBROUTINE kgen_read_externs_rrlw_kg02

    END MODULE rrlw_kg02


!
!  Copyright 2017-2019 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!-----------------------------------------------------------------------------------------
module salmon_xc
  use builtin_pz, only: exc_cor_pz
  use builtin_pz_sp, only: exc_cor_pz_sp
  use builtin_pzm, only: exc_cor_pzm
  use builtin_pbe, only: exc_cor_pbe
  use builtin_tbmbj, only: exc_cor_tbmbj
#ifdef SALMON_USE_LIBXC
  use xc_f90_types_m
  use xc_f90_lib_m
#endif

  implicit none

! List of Exchange Correlation Functionals
  integer, parameter :: salmon_xctype_none  = 0
  integer, parameter :: salmon_xctype_pz    = 1
  integer, parameter :: salmon_xctype_pzm   = 2
  integer, parameter :: salmon_xctype_pbe   = 3
  integer, parameter :: salmon_xctype_tbmbj = 4
  integer, parameter :: salmon_xctype_tpss  = 5
  integer, parameter :: salmon_xctype_vs98  = 6
#ifdef SALMON_USE_LIBXC
  integer, parameter :: salmon_xctype_libxc = 101
#endif

  type xc_functional
    integer :: xctype(3)
    integer :: ispin
    real(8) :: cval
    logical :: use_gradient
    logical :: use_laplacian
    logical :: use_kinetic_energy
    logical :: use_current
#ifdef SALMON_USE_LIBXC
    type(xc_f90_pointer_t) :: func(3)
    type(xc_f90_pointer_t) :: info(3)
#endif
  end type

contains

  subroutine print_xc_info()
    implicit none
    integer :: vmajor, vminor, vmicro

#ifdef SALMON_USE_LIBXC
    call xc_f90_version(vmajor, vminor, vmicro)
    print '(2X,A,1X,I1,".",I1,".",I1)', "Libxc: [enabled]", vmajor, vminor, vmicro
#else
    print '(2X,A)', "Libxc: [disabled]"
#endif
    return
  end subroutine print_xc_info

  subroutine init_xc(xc, ispin, cval, xcname, xname, cname)
    implicit none
    type(xc_functional), intent(inout) :: xc
    integer, intent(in)                :: ispin
    real(8), intent(in)                :: cval
    character(*), intent(in), optional :: xcname
    character(*), intent(in), optional :: xname
    character(*), intent(in), optional :: cname

    ! Initialization of xc variable
    xc%xctype(1:3) = salmon_xctype_none
    xc%ispin = ispin
    xc%cval = cval
    xc%use_gradient = .false.
    xc%use_laplacian = .false.
    xc%use_kinetic_energy = .false.
    xc%use_current = .false.

    ! Exchange correlation
    if (present(xcname) .and. (len_trim(xcname) > 0)) then
      call setup_xcfunc(xcname)
    end if

    ! Exchange only
    if (present(xname) .and. (len_trim(xname) > 0)) then
      call setup_xfunc(xname)
    end if

    ! Correlation only
    if (present(cname) .and. (len_trim(cname) > 0)) then
      call setup_cfunc(cname)
    end if

    return

  contains

    subroutine setup_xcfunc(name)
      use salmon_global, only: iperiodic, domain_parallel
      use inputoutput, only: stop_by_bad_input2
      implicit none
      character(*), intent(in) :: name

#ifdef SALMON_USE_LIBXC
      ! Libxc prefix is used...
      if (lower(name(1:6)) == 'libxc:') then
        xc%xctype(1) = salmon_xctype_libxc
        call init_libxc(name(7:), 1)
        return
      end if
#endif

      select case(lower(name))
      case('none')

        print '(A, A)', "Error! Exchange functional is not specified!"
        stop

        return

      case ('pz')
        xc%xctype(1) = salmon_xctype_pz
        return

      case ('pzm')
        if(iperiodic==0) then
          call stop_by_bad_input2('iperiodic=0','xc=pzm')
        else if(domain_parallel=='y')then
          call stop_by_bad_input2('iperiodic=3','domain_parallel=y','xc=pzm')
        end if

        xc%xctype(1) = salmon_xctype_pzm
        return

      case ('pbe')
        if(iperiodic==0) then
          call stop_by_bad_input2('iperiodic=0','xc=pbe')
        else if(domain_parallel=='y')then
          call stop_by_bad_input2('iperiodic=3','domain_parallel=y','xc=pbe')
        end if

        xc%xctype(1) = salmon_xctype_pbe
        xc%use_gradient = .true.
        return

      case ('tbmbj')
        if(iperiodic==0) then
          call stop_by_bad_input2('iperiodic=0','xc=tbmbj')
        else if(domain_parallel=='y')then
          call stop_by_bad_input2('iperiodic=3','domain_parallel=y','xc=tbmbj')
        end if

        xc%xctype(1) = salmon_xctype_tbmbj
        xc%use_gradient = .true.
        xc%use_laplacian = .true.
        xc%use_kinetic_energy = .true.
        xc%use_current = .true.
        return

      case ('bj_pw')
        if(iperiodic==0) then
          call stop_by_bad_input2('iperiodic=0','xc=bj_pw')
        else if(domain_parallel=='y')then
          call stop_by_bad_input2('iperiodic=3','domain_parallel=y','xc=bj_pw')
        end if

        xc%xctype(1) = salmon_xctype_tbmbj; xc%cval = 1d0
        xc%use_gradient = .true.
        xc%use_laplacian = .true.
        xc%use_kinetic_energy = .true.
        xc%use_current = .true.
        return

      case ('tpss')
        if(iperiodic==0) then
          call stop_by_bad_input2('iperiodic=0','xc=tpss')
        else if(domain_parallel=='y')then
          call stop_by_bad_input2('iperiodic=3','domain_parallel=y','xc=tpss')
        end if

        xc%xctype(1) = salmon_xctype_tpss
        xc%use_gradient = .true.
        xc%use_laplacian = .true.
        xc%use_kinetic_energy = .true.
        xc%use_current = .true.
        return

      case ('vs98')
        if(iperiodic==0) then
          call stop_by_bad_input2('iperiodic=0','xc=vs98')
        else if(domain_parallel=='y')then
          call stop_by_bad_input2('iperiodic=3','domain_parallel=y','xc=vs98')
        end if

        xc%xctype(1) = salmon_xctype_vs98
        xc%use_gradient = .true.
        xc%use_laplacian = .true.
        xc%use_kinetic_energy = .true.
        xc%use_current = .true.
        return

      ! Please insert additional functional here:
      ! e.g.
      ! case ('additional_functional')
      !   initialization_process_of_functional
      !   return

#ifdef SALMON_USE_LIBXC
      case('libxc_pz')
        xc%xctype(2) = salmon_xctype_libxc
        xc%xctype(3) = salmon_xctype_libxc
        call init_libxc('LDA_X', 2)
        call init_libxc('LDA_C_PZ', 3)
        return

      case('libxc_pzm')
        xc%xctype(2) = salmon_xctype_libxc
        xc%xctype(3) = salmon_xctype_libxc
        call init_libxc('LDA_X', 2)
        call init_libxc('LDA_C_PZ_MOD', 3)
        return

      case('libxc_pbe')
        xc%xctype(2) = salmon_xctype_libxc
        xc%xctype(3) = salmon_xctype_libxc
        call init_libxc('GGA_X_PBE', 2)
        call init_libxc('GGA_C_PBE', 3)
        return
#endif

      case default

        print '(A, A)', "Error! Undefined exchange functional:", trim(name)
        stop

      end select
      return
    end subroutine

    subroutine setup_xfunc(name)
      implicit none
      character(*), intent(in) :: name

#ifdef SALMON_USE_LIBXC
      if (lower(name(1:6)) == 'libxc:') then
        xc%xctype(2) = salmon_xctype_libxc
        call init_libxc(name(7:), 2)
        return
      end if
#endif

      select case(name)
      case('none')
        ! xc%xctype(2) = salmon_xctype_none ! default
        return

      ! Please insert additional functional here:
      ! e.g.
      ! case ('additional_functional')
      !   initialization_process_of_functional
      !   return

      case default

        print '(A, A)', "Error! Undefined exchange functional:", trim(name)
        stop

      end select
      return
    end subroutine

    subroutine setup_cfunc(name)
      implicit none
      character(*), intent(in) :: name

#ifdef SALMON_USE_LIBXC
      if (lower(name(1:6)) == 'libxc:') then
        xc%xctype(3) = salmon_xctype_libxc
        call init_libxc(name(7:), 3)
        return
      end if
#endif

      select case(name)
      case('none')
        ! xc%xctype(3) = salmon_xctype_none ! default
        return

      ! Please insert additional functional here:
      ! e.g.
      ! case ('additional_functional')
      !   initialization_process_of_functional
      !   return

      case default

        print '(A, A)', "Undefined correlation functional:", trim(name)
        stop

      end select
      return
    end subroutine

#ifdef SALMON_USE_LIBXC
    subroutine init_libxc(libxc_name, ii)
      implicit none
      character(*), intent(in) :: libxc_name
      integer, intent(in) :: ii
      integer ::  ixc

      ixc = xc_f90_functional_get_number(trim(libxc_name))

      if (ixc <= 0) then
        print '(A, A)', "Undefined libxc functional:", trim(libxc_name)
        stop
      end if

      if (ispin > 0) then
        print '(A)', "Spin polarized is not available"
        stop
      end if

      call xc_f90_func_init( &
        & xc%func(ii), xc%info(ii), ixc, XC_UNPOLARIZED &
        & )

      select case(xc_f90_info_family(xc%info(ii)))
      case (XC_FAMILY_LDA)
      case (XC_FAMILY_GGA)
        xc%use_gradient = .true.
      case ( XC_FAMILY_MGGA)
        xc%use_gradient = .true.
        xc%use_laplacian = .true.
        xc%use_kinetic_energy = .true.
      case (XC_FAMILY_HYB_GGA, XC_FAMILY_HYB_MGGA)
        print '(A, A)', "Hybrid is not available:", trim(libxc_name)
        stop
      case default
        print '(A, A)', "Unknown Family:", trim(libxc_name)
        stop
      end select

      return
    end subroutine init_libxc
#endif

  end subroutine init_xc

  subroutine finalize_xc(xc)
    implicit none
    type(xc_functional), intent(inout) :: xc

#ifdef SALMON_USE_LIBXC
    if (xc%xctype(1) == salmon_xctype_libxc) call xc_f90_func_end(xc%func(1))
    if (xc%xctype(2) == salmon_xctype_libxc) call xc_f90_func_end(xc%func(2))
    if (xc%xctype(3) == salmon_xctype_libxc) call xc_f90_func_end(xc%func(3))
#endif

    return
  end subroutine

  subroutine calc_xc(xc, rho, rho_s, exc, eexc, vxc, vxc_s, &
      & grho, grho_s, rlrho, rlrho_s, tau, tau_s, rj, rj_s, &
      & rho_nlcc, &
      & nd, ifdx, ifdy, ifdz, nabx, naby, nabz)
!      & nd, ifdx, ifdy, ifdz, nabx, naby, nabz, Hxyz, aLxyz)
    implicit none
    type(xc_functional), intent(in) :: xc
    real(8), intent(in), optional :: rho(:, :, :) ! ispin = 0
    real(8), intent(in), optional :: rho_s(:, :, :, :) ! ispin = 1
    real(8), intent(out), optional :: exc(:, :, :) ! epsilon_xc[rho]
    real(8), intent(out), optional :: eexc(:, :, :) ! rho * epsilon_xc[rho]
    real(8), intent(out), optional :: vxc(:, :, :) ! v_xc[rho] for ispin=0
    real(8), intent(out), optional :: vxc_s(:, :, :, :) ! v_xc[rho] ispin=1
    !real(8), intent(out), optional :: gvxc(:, :, :) ! v_xc[rho] for ispin=0
    !real(8), intent(out), optional :: gvxc_s(:, :, :, :) ! v_xc[rho] ispin=1
    real(8), intent(in), optional :: grho(:, :, :, :)
    real(8), intent(in), optional :: grho_s(:, :, :, :, :) ! ispin = 1
    real(8), intent(in), optional :: rlrho(:, :, :)
    real(8), intent(in), optional :: rlrho_s(:, :, :, :) ! ispin = 1
    real(8), intent(in), optional :: rj(:, :, :, :)
    real(8), intent(in), optional :: rj_s(:, :, :, :) ! ispin = 1
    real(8), intent(in), optional :: tau(:, :, :)
    real(8), intent(in), optional :: tau_s(:, :, :, :) ! ispin = 1

    real(8), intent(in), optional :: rho_nlcc(:, :, :)

    !===============================================================
    ! NOTE:
    !   The following section (finite difference table) is required
    !   in the GGA/mGGA functionals which is originally used by ARTED subroutine.
    ! TODO:
    !   Prepare more simplified solution to call the built-in GGA/mGGA functionals
    integer, intent(in), optional :: nd
    integer, intent(in), optional :: ifdx(:, :)
    integer, intent(in), optional :: ifdy(:, :)
    integer, intent(in), optional :: ifdz(:, :)
    real(8), intent(in), optional :: nabx(:)
    real(8), intent(in), optional :: naby(:)
    real(8), intent(in), optional :: nabz(:)
    ! real(8), intent(in), optional :: Hxyz
    ! real(8), intent(in), optional :: aLxyz
    !===============================================================

    integer :: nx, ny, nz, nl

    ! Detect size of 3-dimensional grid
    if (xc%ispin == 0) then
      nx = ubound(rho, 1) - lbound(rho, 1) + 1;
      ny = ubound(rho, 2) - lbound(rho, 2) + 1;
      nz = ubound(rho, 3) - lbound(rho, 3) + 1;
    else
      nx = ubound(rho_s, 1) - lbound(rho_s, 1) + 1;
      ny = ubound(rho_s, 2) - lbound(rho_s, 2) + 1;
      nz = ubound(rho_s, 3) - lbound(rho_s, 3) + 1;
    end if
    nl = nx * ny * nz

    ! Initialize output variables
    if (present(exc)) exc = 0d0
    if (present(eexc)) eexc = 0d0
    if (present(vxc)) vxc = 0d0
    if (present(vxc_s)) vxc_s = 0d0

    ! Exchange-Correlation
    select case (xc%xctype(1))
    case(salmon_xctype_pz)
      call exec_builtin_pz()
    case(salmon_xctype_pzm)
      call exec_builtin_pzm()
    case(salmon_xctype_pbe)
      call exec_builtin_pbe()
    case(salmon_xctype_tbmbj)
      call exec_builtin_tbmbj()
#ifdef SALMON_USE_LIBXC
    case(salmon_xctype_libxc)
      call exec_libxc(1)
#endif
    end select

    ! Exchange Only
    select case (xc%xctype(2))
#ifdef SALMON_USE_LIBXC
    case(salmon_xctype_libxc)
      call exec_libxc(2)
#endif
    end select

    ! Correlation Only
    select case (xc%xctype(3))
#ifdef SALMON_USE_LIBXC
    case(salmon_xctype_libxc)
      call exec_libxc(3)
#endif
    end select

    return

  contains

    subroutine exec_builtin_pz()
      implicit none
      real(8) :: rho_s_1d(nl)
      real(8) :: rho_s_sp_1d(nl,2)
      real(8) :: exc_1d(nl)
      real(8) :: eexc_1d(nl)
      real(8) :: vexc_1d(nl)
      real(8) :: vexc_sp_1d(nl,2)

      if (xc%ispin == 0) then
        rho_s_1d = reshape(rho, (/nl/)) * 0.5
      else if (xc%ispin == 1) then
        rho_s_sp_1d = reshape(rho_s, (/nl,2/))
      end if

#ifndef SALMON_DEBUG_NEGLECT_NLCC
      if (present(rho_nlcc)) then
        rho_s_1d = rho_s_1d + reshape(rho_nlcc, (/nl/)) * 0.5
      endif
#endif

      if (xc%ispin == 0) then
        call exc_cor_pz(nl, rho_s_1d, exc_1d, eexc_1d, vexc_1d)
      else if (xc%ispin == 1) then
        call exc_cor_pz_sp(nl, rho_s_sp_1d, exc_1d, eexc_1d, vexc_sp_1d)
      end if

      if (xc%ispin == 0) then
        if (present(vxc)) then
           vxc = vxc + reshape(vexc_1d, (/nx, ny, nz/))
        endif
      else if(xc%ispin == 1) then
        if (present(vxc_s)) then
           vxc_s = vxc_s + reshape(vexc_sp_1d, (/nx, ny, nz,2/))
        endif
      end if

      if (present(exc)) then
         exc = exc + reshape(exc_1d, (/nx, ny, nz/))
      endif

      if (present(eexc)) then
         eexc = eexc + reshape(eexc_1d, (/nx, ny, nz/))
      endif

      return
    end subroutine exec_builtin_pz

    subroutine exec_builtin_pzm()
      implicit none
      real(8) :: rho_s_1d(nl)
      real(8) :: exc_1d(nl)
      real(8) :: eexc_1d(nl)
      real(8) :: vexc_1d(nl)

      rho_s_1d = reshape(rho, (/nl/)) * 0.5

#ifndef SALMON_DEBUG_NEGLECT_NLCC
      if (present(rho_nlcc)) then
        rho_s_1d = rho_s_1d + reshape(rho_nlcc, (/nl/)) * 0.5
      endif
#endif

      call exc_cor_pzm(nl, rho_s_1d, exc_1d, eexc_1d, vexc_1d)

      if (present(vxc)) then
         vxc = vxc + reshape(vexc_1d, (/nx, ny, nz/))
      endif

      if (present(exc)) then
         exc = exc + reshape(exc_1d, (/nx, ny, nz/))
      endif

      if (present(eexc)) then
         eexc = eexc + reshape(eexc_1d, (/nx, ny, nz/))
      endif

      return
    end subroutine exec_builtin_pzm

    subroutine exec_builtin_pbe()
      implicit none
      real(8) :: rho_1d(nl)
      real(8) :: grho_s_1d(nl, 3)
      real(8) :: exc_1d(nl)
      real(8) :: eexc_1d(nl)
      real(8) :: vexc_1d(nl)

      rho_1d = reshape(rho, (/nl/))
      grho_s_1d = reshape(grho(:, :, :, :), (/nl, 3/)) * 0.5

      call exc_cor_pbe(nl, rho_1d, grho_s_1d, exc_1d, eexc_1d, vexc_1d, &
      & nd, ifdx, ifdy, ifdz, nabx, naby, nabz)

      if (present(vxc)) then
         vxc = vxc + reshape(vexc_1d, (/nx, ny, nz/))
      endif

      if (present(exc)) then
         exc = exc + reshape(exc_1d, (/nx, ny, nz/))
      endif

      if (present(eexc)) then
         eexc = eexc + reshape(eexc_1d, (/nx, ny, nz/))
      endif

      return
    end subroutine exec_builtin_pbe

    subroutine exec_builtin_tbmbj()
      implicit none
      real(8) :: rho_1d(nl)
      real(8) :: rho_s_1d(nl)
      real(8) :: grho_s_1d(nl, 3)
      real(8) :: rlrho_s_1d(nl)
      real(8) :: tau_s_1d(nl)
      real(8) :: j_s_1d(nl, 3)
      real(8) :: eexc_1d(nl)
      real(8) :: vexc_1d(nl)

      rho_1d = reshape(rho, (/nl/))
      rho_s_1d = rho_1d * 0.5
#ifndef SALMON_DEBUG_NEGLECT_NLCC
      if (present(rho_nlcc)) then
        rho_s_1d = rho_s_1d + reshape(rho_nlcc, (/nl/)) * 0.5
      endif
#endif

      grho_s_1d = reshape(grho(:, :, :, :), (/nl, 3/)) * 0.5
      rlrho_s_1d = reshape(rlrho(:, :, :), (/nl/)) * 0.5
      tau_s_1d = reshape(tau(:, :, :), (/nl/)) * 0.5
      j_s_1d = reshape(rj(:, :, :, :), (/nl, 3/)) * 0.5

      !call exc_cor_tbmbj(nl, rho_1d, rho_s_1d,  grho_s_1d, rlrho_s_1d, tau_s_1d, j_s_1d, xc%cval, eexc_1d, vexc_1d, Hxyz, aLxyz)
      call exc_cor_tbmbj(nl, rho_1d, rho_s_1d,  grho_s_1d, rlrho_s_1d, tau_s_1d, j_s_1d, xc%cval, eexc_1d, vexc_1d)

      if (present(vxc)) then
        vxc = vxc + reshape(vexc_1d, (/nx, ny, nz/))
      endif

      if (present(exc)) then
        ! NOTE: Take care for "zero-division error"
        exc = exc + reshape(eexc_1d, (/nx, ny, nz/)) / rho
      endif

      if (present(eexc)) then
        eexc = eexc + reshape(eexc_1d, (/nx, ny, nz/))
      endif

      return
    end subroutine exec_builtin_tbmbj

#ifdef SALMON_USE_LIBXC
    subroutine exec_libxc(ii)
      implicit none
      integer, intent(in) :: ii
      ! character(256) :: name

      real(8) :: rho_1d(nl), grho_1d(nl, 3)
      real(8) :: sigma_1d(nl), rlrho_1d(nl), tau_1d(nl)
      real(8) :: exc_tmp_1d(nl), vxc_tmp_1d(nl)
      real(8) :: gvxc_tmp_1d(nl), lvxc_tmp_1d(nl), tvxc_tmp_1d(nl)

      rho_1d = reshape(rho, (/nl/))
      if (present(rho_nlcc)) then
        rho_1d = rho_1d + reshape(rho_nlcc, (/nl/))
      end if

      if (xc%use_gradient) then
        sigma_1d = reshape( &
          & grho(:,:,:,1)**2+grho(:,:,:,2)**2+grho(:,:,:,3)**2, (/nl/) &
          & )
      end if

      if (xc%use_laplacian) then
        rlrho_1d = reshape(rlrho, (/nl/))
      end if

      if (xc%use_kinetic_energy) then
        tau_1d = reshape(tau, (/nl/))
      end if

      select case (xc_f90_info_family(xc%info(ii)))
      case(XC_FAMILY_LDA)
        call xc_f90_lda_exc_vxc( &
          & xc%func(ii), nl, rho_1d(1), &
          & exc_tmp_1d(1), vxc_tmp_1d(1) &
          & )

      case(XC_FAMILY_GGA)
        call xc_f90_gga_exc_vxc( &
          & xc%func(ii), nl, rho_1d(1), sigma_1d(1), &
          & exc_tmp_1d(1), vxc_tmp_1d(1), gvxc_tmp_1d(1) &
          & )

      case(XC_FAMILY_MGGA)
        call xc_f90_mgga_exc_vxc( &
          & xc%func(ii), nl, rho_1d(1), sigma_1d(1), rlrho_1d(1), tau_1d(1), &
          & exc_tmp_1d(1), vxc_tmp_1d(1), &
          & gvxc_tmp_1d(1), lvxc_tmp_1d(1), tvxc_tmp_1d(1))
      end select

      if (present(exc)) then
        exc = exc + reshape(exc_tmp_1d, (/nx, ny, nz/))
      endif

      if (present(eexc)) then
        eexc = eexc + reshape(exc_tmp_1d, (/nx, ny, nz/)) * rho
      endif

      if (present(vxc)) then
         vxc = vxc + reshape(vxc_tmp_1d, (/nx, ny, nz/))
      endif

      return
    end subroutine exec_libxc
#endif

  end subroutine calc_xc

  function lower(s) result(lower_s)
     implicit none
     character(*), intent(in) :: s
     character(len(s)) :: lower_s
     integer :: i

     do i = 1, len(s)
       if (('A' <= s(i:i)) .and. (s(i:i) <= 'Z')) then
         lower_s(i:i) = char(ichar(s(i:i)) + 32)
       else
         lower_s(i:i) = s(i:i)
       end if
     end do

     return
   end function lower

end module


module SimintFortran
    use iso_c_binding
    implicit none

    type, bind(C) :: c_simint_shell
      integer(C_INT) :: am
      integer(C_INT) :: nprim
      real(C_DOUBLE) :: x
      real(C_DOUBLE) :: y
      real(C_DOUBLE) :: z
      type(C_PTR) :: alpha
      type(C_PTR) :: coef
      integer(C_SIZE_T) :: memsize
      type(C_PTR) :: ptr
    end type c_simint_shell

    type, bind(C) :: c_simint_multi_shellpair
      integer(C_INT) :: am1
      integer(C_INT) :: am2
      integer(C_INT) :: nprim
      integer(C_INT) :: nshell12
      integer(C_INT) :: nshell12_clip
      type(C_PTR) :: nprim12
      type(C_PTR) :: AB_x
      type(C_PTR) :: AB_y
      type(C_PTR) :: AB_z
      type(C_PTR) :: x
      type(C_PTR) :: y
      type(C_PTR) :: z
      type(C_PTR) :: PA_x
      type(C_PTR) :: PA_y
      type(C_PTR) :: PA_z
      type(C_PTR) :: PB_x
      type(C_PTR) :: PB_y
      type(C_PTR) :: PB_z
      type(C_PTR) :: alpha

#if SIMINT_OSTEI_MAXDER > 0
        type(C_PTR) :: alpha2
        type(C_PTR) :: beta2
#endif

      type(C_PTR) :: prefac
      type(C_PTR) :: screen
      real(C_DOUBLE) :: screen_max
      integer(C_SIZE_T) :: memsize
      type(C_PTR) :: ptr
    end type

  interface

    subroutine simint_init() bind(C, name="simint_init")
    end subroutine

    subroutine simint_finalize() bind(C, name="simint_finalize")
    end subroutine

    subroutine c_simint_initialize_shell(G) bind(C, name="simint_initialize_shell")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: G
    end subroutine

    subroutine c_simint_initialize_shells(n, G) bind(C, name="simint_initialize_shells")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: G
      integer(C_INT), intent(in), value :: n
    end subroutine

    subroutine c_simint_allocate_shell(nprim, G) bind(C, name="simint_allocate_shell")
      use iso_c_binding
      implicit none
      integer(C_INT), intent(in), value :: nprim
      type(C_PTR), intent(in), value :: G
    end subroutine

    subroutine c_simint_free_shell(G) bind(C, name="simint_free_shell")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: G
    end subroutine

    subroutine c_simint_free_shells(n, G) bind(C, name="simint_free_shells")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: G
      integer(C_INT), intent(in), value :: n
    end subroutine

    subroutine c_simint_normalize_shells(n, G) bind(C, name="simint_normalize_shells")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: G
      integer(C_INT), intent(in), value :: n
    end subroutine

    subroutine c_simint_copy_shell(src, dest) bind(C, name="simint_copy_shell")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: src, dest
    end subroutine

    subroutine c_simint_create_shell(nprim, am, &
               x, y, z, alpha, coef, G) bind(C, name="simint_create_shell")
      use iso_c_binding
      implicit none
      integer(C_INT), intent(in), value :: nprim, am
      real(C_DOUBLE), intent(in), value :: x, y, z
      type(C_PTR), intent(in), value :: alpha, coef, G
    end subroutine

    subroutine c_simint_create_zero_shell(G) bind(C, name="simint_create_zero_shell")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: G
    end subroutine

    subroutine c_simint_initialize_multi_shellpair(P) &
               bind(C, name="simint_initialize_multi_shellpair")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: P
    end subroutine

    subroutine c_simint_initialize_multi_shellpairs(n, P) bind(C, name="simint_initialize_multi_shellpairs")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: P
      integer(C_INT), intent(in), value :: n
    end subroutine

    subroutine c_simint_free_multi_shellpair(P) &
               bind(C, name="simint_free_multi_shellpair")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: P
    end subroutine

    subroutine c_simint_free_multi_shellpairs(n, P) bind(C, name="simint_free_multi_shellpairs")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: P
      integer(C_INT), intent(in), value :: n
    end subroutine

    subroutine c_simint_create_multi_shellpair( &
               na, A, nb, B, P, screen_method) &
               bind(C, name="simint_create_multi_shellpair")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: A, B
      type(C_PTR), intent(in), value :: P
      integer(C_INT), intent(in), value :: na, nb, screen_method
    end subroutine

    subroutine c_simint_create_multi_shellpair2( &
               npair, AB, P, screen_method) &
               bind(C, name="simint_create_multi_shellpair2")

      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: AB, P
      integer(C_INT), intent(in), value :: npair, screen_method
    end subroutine

    function c_simint_compute_eri(P, Q, screen_tol, work, integrals) &
             result(res) bind(C, name="simint_compute_eri")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: P, Q, work, integrals
      real(C_DOUBLE), intent(in), value :: screen_tol
      integer(C_INT) :: res
    end function

    function c_simint_compute_eri_deriv(deriv, P, Q, screen_tol, work, integrals) &
             result(res) bind(C, name="simint_compute_eri_deriv")
      use iso_c_binding
      implicit none
      integer(C_INT), intent(in), value :: deriv
      type(C_PTR), intent(in), value :: P, Q, work, integrals
      real(C_DOUBLE), intent(in), value :: screen_tol
      integer(C_INT) :: res
    end function

    function c_simint_eri_worksize(derorder, maxam) &
             result(res) bind(C, name="simint_eri_worksize")
      use iso_c_binding
      implicit none
      integer(C_INT), intent(in), value :: derorder, maxam
      integer(C_SIZE_T) :: res
    end function

    function c_simint_eri_workmem(derorder, maxam) &
             result(res) bind(C, name="simint_eri_workmem")
      use iso_c_binding
      implicit none
      integer(C_INT), intent(in), value :: derorder, maxam
      integer(C_SIZE_T) :: res
    end function

    function c_simint_compute_overlap(P, Q, integrals) &
             result(res) bind(C, name="simint_compute_overlap")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: P, Q, integrals
      integer(C_INT) :: res
    end function

    function c_simint_compute_ke(P, Q, integrals) &
             result(res) bind(C, name="simint_compute_ke")
      use iso_c_binding
      implicit none
      type(C_PTR), intent(in), value :: P, Q, integrals
      integer(C_INT) :: res
    end function

    function c_simint_compute_potential(n, nuc_charge, X, Y, Z, P, Q,&
         integrals) &
         result(res) bind(C, name="simint_compute_potential")
      use iso_c_binding
      implicit none
      integer(C_INT), intent(in), value :: n
      type(C_PTR), intent(in), value :: nuc_charge, X, Y, Z,P, Q, integrals
      integer(C_INT) :: res
    end function

  end interface

  contains

    subroutine simint_initialize_shell(G)
      implicit none
      type(c_simint_shell), intent(inout), target :: G

      call c_simint_initialize_shell(C_LOC(G))
    end subroutine

    subroutine simint_initialize_shells(n, G)
      implicit none
      integer, intent(in) :: n
      type(c_simint_shell), intent(inout), target :: G(n)

      call c_simint_initialize_shells(INT(n, C_INT), C_LOC(G))
    end subroutine

    subroutine simint_allocate_shell(nprim, G)
      implicit none
      integer :: nprim
      type(c_simint_shell), intent(inout), target :: G

      call c_simint_allocate_shell(INT(nprim, C_INT), C_LOC(G))
    end subroutine

    subroutine simint_free_shell(G)
      implicit none
      type(c_simint_shell), intent(inout), target :: G

      call c_simint_free_shell(C_LOC(G))
    end subroutine

    subroutine simint_free_shells(n, G)
      implicit none
      integer, intent(in) :: n
      type(c_simint_shell), intent(inout), target :: G(n)

      call c_simint_free_shells(INT(n, C_INT), C_LOC(G))
    end subroutine

    subroutine simint_normalize_shells(n, G)
      implicit none
      integer, intent(in) :: n
      type(c_simint_shell), intent(inout), target :: G(n)

      call c_simint_normalize_shells(INT(n, C_INT), C_LOC(G))
    end subroutine

    subroutine simint_copy_shell(src, dest)
      implicit none
      type(c_simint_shell), intent(in), target :: src
      type(c_simint_shell), intent(out), target :: dest

      call c_simint_copy_shell(C_LOC(src), C_LOC(dest))
    end subroutine

    subroutine simint_create_shell(nprim, am, &
               x, y, z, alpha, coef, G)
      implicit none
      integer, intent(in) :: nprim, am
      double precision, intent(in) :: x, y, z
      double precision, intent(in), target :: alpha(nprim), coef(nprim)
      type(c_simint_shell), intent(inout), target :: G

      call c_simint_create_shell(INT(nprim, C_INT), &
                                 INT(am, C_INT), &
                                 REAL(x, C_DOUBLE), &
                                 REAL(y, C_DOUBLE), &
                                 REAL(z, C_DOUBLE), &
                                 C_LOC(alpha), &
                                 C_LOC(coef), &
                                 C_LOC(G))

    end subroutine

    subroutine simint_create_zero_shell(G)
      implicit none
      type(c_simint_shell), intent(inout), target :: G

      call c_simint_create_zero_shell(C_LOC(G))
    end subroutine

    subroutine simint_initialize_multi_shellpair(P)
      implicit none
      type(c_simint_multi_shellpair), intent(inout), target :: P

      call c_simint_initialize_multi_shellpair(C_LOC(P))
    end subroutine

    subroutine simint_initialize_multi_shellpairs(n, P)
      implicit none
      integer, intent(in) :: n
      type(c_simint_multi_shellpair), intent(inout), target :: P(n)

      call c_simint_initialize_multi_shellpairs(INT(n, C_INT), C_LOC(P))
    end subroutine

    subroutine simint_free_multi_shellpair(P)
      implicit none
      type(c_simint_multi_shellpair), intent(inout), target :: P

      call c_simint_free_multi_shellpair(C_LOC(P))
    end subroutine

    subroutine simint_free_multi_shellpairs(n, P)
      implicit none
      integer, intent(in) :: n
      type(c_simint_multi_shellpair), intent(inout), target :: P(n)

      call c_simint_free_multi_shellpairs(INT(n, C_INT), C_LOC(P))
    end subroutine

    subroutine simint_create_multi_shellpair( &
               na, A, nb, B, P, screen_method)
      implicit none
      integer, intent(in) :: na, nb, screen_method
      type(c_simint_multi_shellpair), intent(inout), target :: P
      type(c_simint_shell), intent(in), target :: A(na), B(nb)

      call c_simint_create_multi_shellpair(INT(na, C_INT), &
                                           C_LOC(A), &
                                           INT(nb, C_INT), &
                                           C_LOC(B), &
                                           C_LOC(P), &
                                           INT(screen_method, C_INT))

    end subroutine

    subroutine simint_create_multi_shellpair2( &
               npair, AB, P, screen_method)
      implicit none
      integer, intent(in) :: npair, screen_method
      type(c_simint_shell), intent(in), target :: AB(npair)
      type(c_simint_multi_shellpair), intent(inout), target :: P

      call c_simint_create_multi_shellpair2(INT(npair, C_INT), &
                                            C_LOC(AB), C_LOC(P), &
                                            INT(screen_method, C_INT))
    end subroutine

    function simint_compute_eri(P, Q, screen_tol, work, integrals) &
             result(res)
      implicit none

      type(c_simint_multi_shellpair), intent(in), target :: P, Q
      double precision, intent(inout), target :: work(*), integrals(*)
      real(C_DOUBLE), intent(in) :: screen_tol
      integer :: res
      integer(C_INT) :: res2

      res2 = c_simint_compute_eri(C_LOC(P), C_LOC(Q), &
                                  REAL(screen_tol, C_DOUBLE), &
                                  C_LOC(work), C_LOC(integrals))
      res = INT(res2)
    end function

    function simint_compute_eri_deriv(deriv, P, Q, screen_tol, work, integrals) &
             result(res)
      implicit none

      integer(C_INT), intent(in), value :: deriv
      type(c_simint_multi_shellpair), intent(in), target :: P, Q
      double precision, intent(inout), target :: work(*), integrals(*)
      real(C_DOUBLE), intent(in) :: screen_tol
      integer :: res
      integer(C_INT) :: res2

      res2 = c_simint_compute_eri_deriv(INT(deriv, C_INT), C_LOC(P), C_LOC(Q), &
                                  REAL(screen_tol, C_DOUBLE), &
                                  C_LOC(work), C_LOC(integrals))
      res = INT(res2)
    end function

    function simint_eri_worksize(derorder, maxam) result(res)
      implicit none
      integer, intent(in) :: derorder, maxam
      integer :: res
      integer(C_INT) :: res2

      res2 = c_simint_eri_worksize(INT(derorder, C_INT), INT(maxam, C_INT))
      res = INT(res2)
    end function

    function simint_eri_workmem(derorder, maxam) result(res)
      implicit none
      integer, intent(in) :: derorder, maxam
      integer :: res
      integer(C_INT) :: res2

      res2 = c_simint_eri_workmem(INT(derorder, C_INT), INT(maxam, C_INT))
      res = INT(res2)
    end function

    function simint_compute_overlap(P, Q, integrals) &
             result(res)
      implicit none

      type(c_simint_shell), intent(in), target :: P, Q
      double precision, intent(inout), target :: integrals(*)
      integer :: res
      integer(C_INT) :: res2

      res2 = c_simint_compute_overlap(C_LOC(P), C_LOC(Q), &
                                  C_LOC(integrals))
      res = INT(res2)
    end function

    function simint_compute_ke(P, Q, integrals) &
             result(res)
      implicit none

      type(c_simint_shell), intent(in), target :: P, Q
      double precision, intent(inout), target :: integrals(*)
      integer :: res
      integer(C_INT) :: res2

      res2 = c_simint_compute_ke(C_LOC(P), C_LOC(Q), &
                                  C_LOC(integrals))
      res = INT(res2)
    end function

    function simint_compute_potential(n, nuc_charge, X, Y, Z, P, Q,&
         integrals) &
         result(res)
      implicit none

      integer, intent(in) :: n
      type(c_simint_shell), intent(in), target :: P, Q
      double precision, intent(inout), target :: integrals(*)
      double precision, intent(in), target :: X(n), &
           Y(n), Z(n), nuc_charge(n)
      integer :: res
      integer(C_INT) :: res2
      res2 = c_simint_compute_potential( INT(n, C_INT), &
           C_LOC(nuc_charge), C_LOC(X), &
           C_LOC(Y), C_LOC(Z), C_LOC(P), C_LOC(Q), C_LOC(integrals))
      res = INT(res2)
    end function

end module


      subroutine chdxgr(delxi,dlxmx0,fdri0,fdrr0,iodb,jordlm,jreac,
     $ kord,nodbmx,nordmx,nordr,noutpt,nrct,nrctmx,nrd1mx,nsscmx,
     $ scalim,scfcr,sscrew,qriinf,rirec0,rrelr0,ureac)
c
c     This subroutine chooses a step size and order according to the
c     Gear accuracy criterion, examining the r vector and its
c     associated finite differences. Subroutine chdxgz.f performs
c     the same function for the z vector and its associated finite
c     differences.
c
c     This subroutine is called by:
c
c       EQ6/path.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c
c     Principal output:
c
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nodbmx,nrctmx,nordmx,nrd1mx,nsscmx
c
      integer noutpt
c
      integer iodb(nodbmx),jreac(nrctmx)
c
      integer jordlm,kord,nordr,nrct
c
      logical qriinf
c
      character(len=24) ureac(nrctmx)
c
      real(8) fdri0(nrd1mx),fdrr0(nrd1mx,nrctmx),rrelr0(nrctmx),
     $ sscrew(nsscmx)
c
      real(8) delxi,dlxmx0,rirec0,scalim,scfcr
c
c-----------------------------------------------------------------------
c
c     Local variable declarations with global dimensions.
c
      integer isv_nordmx
c
      SAVE isv_nordmx
c
      integer, dimension(:), allocatable :: kkk
c
      SAVE kkk
c
      character(len=24), dimension(:), allocatable :: uscal
c
      SAVE uscal
c
      real(8), dimension(:), allocatable :: scmax,scraw
c
      SAVE scmax,scraw
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,ip1,j2,j3,k,nrc
c
      integer ilnobl
c
      character*24 uinv,urel,uzt,uzn
c
      real(8) adx,delchg,dlxii,fctr,fctrmn,relchg,rxx0,xip1
c
c-----------------------------------------------------------------------
c
      data uinv /'Inverse rate            '/,
     $     urel /'Relative rate           '/
c
c-----------------------------------------------------------------------
c
c     Allocate or reallocate local work arrays as needed.
c
      if (.not.ALLOCATED(kkk)) then
c
c       Local work arrays are not allocated. Zero the saved
c       array size variables. Note that only one array is tested
c       to see if it is allocated. It is assumed that all local
c       work arrays are either allocated or not.
c
        isv_nordmx = 0
      else
c
c       Local work arrays are allocated. Check to see if any of the
c       array size variables have changed. If so, deallocate
c       the corresponding local work arrays and zero the corresponding
c       saved size variables.
c
        if (nordmx .ne. isv_nordmx) then
          DEALLOCATE(kkk,uscal,scmax,scraw)
          isv_nordmx = 0
        endif
      endif
c
c     At this point, the saved array size values are zero if the
c     corresponding arrays need to be allocated.
c
      if (isv_nordmx .eq. 0) then
        ALLOCATE(kkk(0:nordmx))
        ALLOCATE(uscal(0:nordmx))
        ALLOCATE(scmax(0:nordmx),scraw(0:nordmx))
        isv_nordmx = nordmx
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Zero the contents of the local work arrays.
c
      do k = 1,nordmx
        kkk(k) = 0
      enddo
c
      do k = 1,nordmx
        uscal(k) = ' '
      enddo
c
      do k = 1,nordmx
        scmax(k) = 0.
        scraw(k) = 0.
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (kord .le. 0) then
        nordr = 0
        scfcr= dlxmx0/delxi
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Set up the regular choice of orders. Here i is the order, which
c     technically runs from 0 to jordlm. Here jordlm + 1 is the hidden
c     extra order, which is used to constrain the error in using order
c     jordlm.
c
      do i = 0,jordlm
        scmax(i) = 0.
        scraw(i) = 0.
      enddo
c
c     For i = 0, take delxi = dlxmx0. This keeps delxi greater
c     than or equal to dlxmx0, except within searches, as for phase
c     boundaries.
c
      scmax(0) = dlxmx0/delxi
      scraw(0) = scmax(0)
      kkk(0) = 0
      uscal(0) = 'None'
c
c     Process the higher orders.
c
      do i = 1,jordlm
        ip1 = i + 1
        dlxii = delxi**(ip1)
        fctrmn = 1.e+38
        kkk(i) = 0
        uscal(i) = 'None'
c
c       Get results based on the inverse rate.
c
        if (.not.qriinf) then
          rxx0 = rirec0
          if (rxx0 .ne. 0.) then
            adx = abs(fdri0(ip1))
            delchg = adx*dlxii
            relchg = delchg/rxx0
            if (relchg .ne. 0.) then
              fctr = sscrew(3)/relchg
              if (fctr .lt. fctrmn) then
                fctrmn = fctr
                uscal(i)(1:24) = uinv(1:24)
                kkk(i) = 0
              endif
            endif
          endif
        endif
c
c       Get results based on relative rates.
c
        do nrc = 1,nrct
          if (jreac(nrc).eq.0 .or. jreac(nrc).eq.-1)  then
            rxx0 = abs(rrelr0(nrc))
            if (rxx0 .ne. 0.) then
              adx = abs(fdrr0(ip1,nrc))
              delchg = adx*dlxii
              if (delchg .ne. 0.) then
                fctr = sscrew(3)/delchg
                if (fctr .lt. fctrmn) then
                  fctrmn = fctr
                  uscal(i)(1:24) = urel(1:24)
                  kkk(i) = nrc
                endif
              endif
            endif
          endif
        enddo
c
        xip1 = ip1
        scmax(i) = fctrmn**(1./xip1)
        scraw(i) = scmax(i)
        if (scmax(i) .gt. scalim) scmax(i) = scalim
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (iodb(5) .ge. 2) then
        write (noutpt,1000)
 1000   format(/' --- Order and Scale Factor Data (chdxgr) ---',/)
        do i = 0,jordlm
          uzt = uscal(i)
          nrc = kkk(i)
          if (uzt(1:24) .eq. urel(1:24)) then
            uzn = ureac(nrc)
          else
            uzn = ' '
          endif
c
          write (noutpt,1010) i,scmax(i),scraw(i)
 1010     format('   Order= ',i2,', scale= ',f10.5,', raw scale= ',
     $    f10.5)
          j2 = ilnobl(uzt)
          j3 = ilnobl(uzn)
          if (j3 .gt. 0) then
            write (noutpt,1020) uzt(1:j2),uzn(1:j3)
 1020       format(5x,'Constrained by ',a,1x,a)
          else
            write (noutpt,1030) uzt(1:j2)
 1030       format(5x,'Constrained by ',a)
          endif
        enddo
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Choose the order that gives the highest scale factor.
c
      scfcr = scmax(0)
      nordr = 0
      do i = 1,jordlm
        if (scmax(i) .gt. scfcr) then
          scfcr = scmax(i)
          nordr = i
        endif
      enddo
c
  999 continue
      end