c
c   Dint – version 2.0  is licensed under the Apache License, Version 2.0 (the "License");
c   you may not use Dint – version 2.0 except in compliance with the License.
c   You may obtain a copy of the License at
c       http://www.apache.org/licenses/LICENSE-2.0
c   The license is also given in the LICENSE file.
c   Unless required by applicable law or agreed to in writing, software
c   distributed under the License is distributed on an "AS IS" BASIS,
c   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
c   See the License for the specific language governing permissions and limitations under the License.
c
c -------------------------------------------------------------------------------------------
c  Dint : Direct Nonadiabatic Trajectories A code for non-Born–Oppenheimer molecular dynamics
c
c  version 2.0
c
c  A. W. Jasper
c  Argonne National Laboratory
c
c  Rui Ming Zhang
c  Tsinghua University
c
c  and
c
c  D. G. Truhlar
c  University of Minnesota
c
c  copyright  2020
c  Donald G. Truhlar and Regents of the University of Minnesota
c----------------------------------------------------------------------------------------------

      subroutine ewkb2(ji,vi,mm,erotvib,rin,rout,nsurf,symb,rguess)

c This subroutine is specialized for the atom-diatom initial conditions.
c It computes the WKB energy for the rovibrational state (vi,ji).
c INPUT
c ji = initial rot state of diatom
c vi = initial vib state of the diatom
c mm = masses of the atoms
c OUTPUT
c erotvib = rivibrational energy for (vi,ji) state

      implicit none
      include 'param.f'

      integer arri,nsurf
      double precision mm(mnat),erotvib,xj,ji,vi
      character*2 symb(mnat)

c     local
      integer i,j,JMAX
      double precision rmin,emin,emax,xv,f,fmid,dx,rtbis_vib,etry,
     & rin,rout,rguess,etmp

      xj = ji

c      write(6,*)"aj in ewkb2"

c Need to bracket energy for (vi,ji) state
c     find minimum of diatom with rotation
      call diamin2(rmin,emin,xj,mm,nsurf,symb,rguess)
c     get asymptotic energy
      call diapot2(30.d0,emax,0.d0,mm,nsurf,symb)
c      write(6,*)"Minimum energy for diatom ",
c     &  " is ",emin*autoev," eV at ",rmin*autoang," A",xj
c      write(6,*)"Asym energy is ",emax*autoev," eV"
c      write(6,*)

c Now determine energy of (vi,ji) state
c     compute vibrational action at E = emax
      rin=0.5d0
      rout=30.d0
      call vwkb2(mm,emin,xj,xv,rin,rout,nsurf,symb)
      f = xv - vi
c      write(6,*)"vibrational action at emin = ",xv
c     compute vibrational action at E = emin
      rin=0.5d0
      rout=30.d0
      etmp=0.99d0*emax
      call vwkb2(mm,etmp,xj,xv,rin,rout,nsurf,symb)
      fmid = xv - dble(vi)
c      write(6,*)"vibrational action at 0.99 emax = ",xv

      if (f*fmid.ge.0.d0) then
          write(6,1000)
          stop
      end if
      if (f.lt.0.d0) then
          rtbis_vib=emin
          dx=etmp-emin
      else
          rtbis_vib=etmp
          dx=emin-etmp
      end if

      JMAX=100
      do 11 j = 1, JMAX
          dx=dx*0.5d0
          etry=rtbis_vib+dx
          rin=0.5d0
          rout=30.d0
          call vwkb2(mm,etry,xj,xv,rin,rout,nsurf,symb)
c          write(6,*)"trying...",etry*27.211d0
c          write(6,*)"vibrational action at etry = ",xv,vi
          fmid = xv - vi
          if (fmid.le.0.d0) rtbis_vib=etry
          if (abs(dx).lt.1.d-10.or.fmid.eq.0.d0) go to 12
   11 continue
      write(6,1010)
      stop
 1000 format(2x,'root must be bracketed in rtbis_vib')
 1010 format(2x,'Too many bisections in rtbis_vib')

   12 continue

      erotvib = rtbis_vib

      return

      end


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...PY6FRM
C...An interface from a six-fermion generator to include
C...parton showers and hadronization.

      SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)

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

C...Commonblocks.
      include 'inc/pyjets'
      include 'inc/pydat1'

C...Local arrays.
      DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)

C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
      IF(ICOM.EQ.0) THEN
        MSTU(28)=0
        CALL PYHEPC(2)
      ENDIF

C...Loop through entries and pick up all final fermions/antifermions.
      I1=0
      I2=0
      I3=0
      I4=0
      I5=0
      I6=0
      DO 100 I=1,N
      IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
      KFA=ABS(K(I,2))
      IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
        IF(K(I,2).GT.0) THEN
          IF(I1.EQ.0) THEN
            I1=I
          ELSEIF(I3.EQ.0) THEN
            I3=I
          ELSEIF(I5.EQ.0) THEN
            I5=I
          ELSE
            CALL PYERRM(16,'(PY6FRM:) more than three fermions')
          ENDIF
        ELSE
          IF(I2.EQ.0) THEN
            I2=I
          ELSEIF(I4.EQ.0) THEN
            I4=I
          ELSEIF(I6.EQ.0) THEN
            I6=I
          ELSE
            CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
          ENDIF
        ENDIF
      ENDIF
  100 CONTINUE

C...Check that event is arranged according to conventions.
      IF(I5.EQ.0.OR.I6.EQ.0) THEN
        CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
      ENDIF
      IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
        CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
      ENDIF

C...Check which fermion pairs are quarks and which leptons.
      IF(ABS(K(I1,2)).LT.10.AND.ABS(K(I2,2)).LT.10) THEN
        IQL12=1
      ELSEIF(ABS(K(I1,2)).GT.10.AND.ABS(K(I2,2)).GT.10) THEN
        IQL12=2
      ELSE
        CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
      ENDIF
      IF(ABS(K(I3,2)).LT.10.AND.ABS(K(I4,2)).LT.10) THEN
        IQL34=1
      ELSEIF(ABS(K(I3,2)).GT.10.AND.ABS(K(I4,2)).GT.10) THEN
        IQL34=2
      ELSE
        CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
      ENDIF
      IF(ABS(K(I5,2)).LT.10.AND.ABS(K(I6,2)).LT.10) THEN
        IQL56=1
      ELSEIF(ABS(K(I5,2)).GT.10.AND.ABS(K(I6,2)).GT.10) THEN
        IQL56=2
      ELSE
        CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
      ENDIF

C...Decide whether to allow or not photon radiation in showers.
      MSTJ(41)=2
      IF(IRAD.EQ.0) MSTJ(41)=1

C...Allow dipole pairings only among leptons and quarks separately.
      P12D=P12
      P13D=0D0
      IF(IQL34.EQ.IQL56) P13D=P13
      P21D=0D0
      IF(IQL12.EQ.IQL34) P21D=P21
      P23D=0D0
      IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
      P31D=0D0
      IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
      P32D=0D0
      IF(IQL12.EQ.IQL56) P32D=P32

C...Decide whether t+tbar.
      ITOP=0
      IF(PYR(0).LT.PTOP) THEN
        ITOP=1

C...If t+tbar: reconstruct t's.
        IT=N+1
        ITB=N+2
        DO 110 J=1,5
          K(IT,J)=0
          K(ITB,J)=0
          P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
          P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
          V(IT,J)=0D0
          V(ITB,J)=0D0
  110   CONTINUE
        K(IT,1)=1
        K(ITB,1)=1
        K(IT,2)=6
        K(ITB,2)=-6
        P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
     &  P(IT,3)**2))
        P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
     &  P(ITB,3)**2))
        N=N+2

C...If t+tbar: colour join t's and let them shower.
        IJOIN(1)=IT
        IJOIN(2)=ITB
        CALL PYJOIN(2,IJOIN)
        PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
     &  (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
        CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))

C...If t+tbar: pick up the t's after shower.
        ITNEW=IT
        ITBNEW=ITB
        DO 120 I=ITB+1,N
          IF(K(I,2).EQ.6) ITNEW=I
          IF(K(I,2).EQ.-6) ITBNEW=I
  120   CONTINUE

C...If t+tbar: loop over two top systems.
        DO 200 IT1=1,2
          IF(IT1.EQ.1) THEN
            ITO=IT
            ITN=ITNEW
            IBO=I1
            IW1=I3
            IW2=I4
          ELSE
            ITO=ITB
            ITN=ITBNEW
            IBO=I2
            IW1=I5
            IW2=I6
          ENDIF
          IF(ABS(K(IBO,2)).NE.5) CALL PYERRM(6,
     &    '(PY6FRM:) not b in t decay')

C...If t+tbar: find boost from original to new top frame.
          DO 130 J=1,3
            BETAO(J)=P(ITO,J)/P(ITO,4)
            BETAN(J)=P(ITN,J)/P(ITN,4)
  130     CONTINUE

C...If t+tbar: boost copy of b by t shower and connect it in colour.
          N=N+1
          IB=N
          K(IB,1)=3
          K(IB,2)=K(IBO,2)
          K(IB,3)=ITN
          DO 140 J=1,5
            P(IB,J)=P(IBO,J)
            V(IB,J)=0D0
  140     CONTINUE
          CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
          CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
          K(IB,4)=MSTU(5)*ITN
          K(IB,5)=MSTU(5)*ITN
          K(ITN,4)=K(ITN,4)+IB
          K(ITN,5)=K(ITN,5)+IB
          K(ITN,1)=K(ITN,1)+10
          K(IBO,1)=K(IBO,1)+10

C...If t+tbar: construct W recoiling against b.
          N=N+1
          IW=N
          DO 150 J=1,5
            K(IW,J)=0
            V(IW,J)=0D0
  150     CONTINUE
          K(IW,1)=1
          KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
          IF(ABS(KCHW).EQ.3) THEN
            K(IW,2)=SIGN(24,KCHW)
          ELSE
            CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
          ENDIF
          K(IW,3)=IW1

C...If t+tbar: construct W momentum, including boost by t shower.
          DO 160 J=1,4
            P(IW,J)=P(IW1,J)+P(IW2,J)
  160     CONTINUE
          P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
     &    P(IW,3)**2))
          CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
          CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))

C...If t+tbar: boost b and W to top rest frame.
          DO 170 J=1,3
            BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
  170     CONTINUE
          CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
          CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))

C...If t+tbar: let b shower and pick up modified W.
          PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
     &    (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
          CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
          DO 180 I=IW,N
            IF(ABS(K(I,2)).EQ.24) IWM=I
  180     CONTINUE

C...If t+tbar: take copy of W decay products.
          DO 190 J=1,5
            K(N+1,J)=K(IW1,J)
            P(N+1,J)=P(IW1,J)
            V(N+1,J)=V(IW1,J)
            K(N+2,J)=K(IW2,J)
            P(N+2,J)=P(IW2,J)
            V(N+2,J)=V(IW2,J)
  190     CONTINUE
          K(IW1,1)=K(IW1,1)+10
          K(IW2,1)=K(IW2,1)+10
          K(IWM,1)=K(IWM,1)+10
          K(IWM,4)=N+1
          K(IWM,5)=N+2
          K(N+1,3)=IWM
          K(N+2,3)=IWM
          IF(IT1.EQ.1) THEN
            I3=N+1
            I4=N+2
          ELSE
            I5=N+1
            I6=N+2
          ENDIF
          N=N+2

C...If t+tbar: boost W decay products, first by effects of t shower,
C...then by those of b shower. b and its shower simple boost back.
          CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
          CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
          CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
          CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
     &    -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
          CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
     &    P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
          CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
          CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
  200   CONTINUE
      ENDIF

C...Decide on dipole pairing.
      IP1=I1
      IP3=I3
      IP5=I5
      PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
      IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
        IP2=I2
        IP4=I4
        IP6=I6
      ELSEIF(PRN.LT.P12D+P13D) THEN
        IP2=I2
        IP4=I6
        IP6=I4
      ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
        IP2=I4
        IP4=I2
        IP6=I6
      ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
        IP2=I4
        IP4=I6
        IP6=I2
      ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
        IP2=I6
        IP4=I2
        IP6=I4
      ELSE
        IP2=I6
        IP4=I4
        IP6=I2
      ENDIF

C...Do colour joinings and parton showers
C...(except ones already made for t+tbar).
      IF(ITOP.EQ.0) THEN
        IF(IQL12.EQ.1) THEN
          IJOIN(1)=IP1
          IJOIN(2)=IP2
          CALL PYJOIN(2,IJOIN)
        ENDIF
        IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
          PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
     &    (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
          CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
        ENDIF
      ENDIF
      IF(IQL34.EQ.1) THEN
        IJOIN(1)=IP3
        IJOIN(2)=IP4
        CALL PYJOIN(2,IJOIN)
      ENDIF
      IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
        PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
     &  (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
        CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
      ENDIF
      IF(IQL56.EQ.1) THEN
        IJOIN(1)=IP5
        IJOIN(2)=IP6
        CALL PYJOIN(2,IJOIN)
      ENDIF
      IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
        PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
     &  (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
        CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
      ENDIF

C...Do fragmentation and decays. Possibly except tau decay.
      IF(ITAU.EQ.0) THEN
        NTAU=0
        DO 210 I=1,N
        IF(ABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
          NTAU=NTAU+1
          INTAU(NTAU)=I
          K(I,1)=11
        ENDIF
  210   CONTINUE
      ENDIF
      CALL PYEXEC
      IF(ITAU.EQ.0) THEN
        DO 220 I=1,NTAU
        K(INTAU(I),1)=1
  220   CONTINUE
      ENDIF

C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
      IF(ICOM.EQ.0) THEN
        MSTU(28)=0
        CALL PYHEPC(1)
      ENDIF

      END


      SUBROUTINE COMBNS(K,XLK,XL1,XL2,XL3,DRPR,ITEST)
C
      IMPLICIT REAL*8(A-H,O-Z)
C    *                                                            *
C
C    **************************************************************
C    *    COMBNS COMBINES ARRAYS FOR THE SIMULATION OF LINEARLY   *
C    *    VARYING DRAG PRESSURE FOR VERY LONG ELEMENTS.           *
C    *                                                            *
C    **************************************************************
C
      COMMON/COMSOL/ ZZ01(10),ZZ12(3,10),ZZ23(9,10),SZS01(10),SZS02(10)
     *              ,SZS11(3,10),SZS12(3,10),SZS13(3,10),SZS21(9,10)
     *              ,SZS22(9,10),SZS23(9,10),SZS24(9,10),SZS31(27,10)
     *              ,SZS32(27,10),SZS41(81,10)
C
      COMMON/COMSL1/ ZS101(2),ZS102(2),ZS111(6),ZS112(6),ZS113(6)
     *              ,ZS121(18),ZS122(18),ZS123(18),ZS124(18),ZS131(54)
     *              ,ZS132(54),ZS141(162),Z2S101(2),Z2S112(6)
     *              ,Z2S123(18),XLTEST
C
      COMMON/IPOOL1/ IDUM(19),LK(10),LLK(10)
C
      COMMON/RPOOL1/ RHOK(10),TIME,SA(3,3),FM1(3,3),ZLK(10),OMEG(3)
     *              ,ZLKP(10),ZLKDP(10),CMAT(3,3),GBAR(3,3),YBCM(3)
     *              ,ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
      COMMON/RPOOL2/ PO,SD(3),DAN(3,10),DBN(3,10),CFMT(3,3),DIY1(3)
     *              ,SD1(3),DT1,P1,AERO,DTO1,YIZK(3),PO1
C
      COMMON/VECTRS/ XSAT(3),XSATDT(3),AD(3)
C
C
      DATA FEET/3.28083333333333D3/
C
      DIMENSION XB(3),XI(3),SXSAT(3),SZZ12(3),SZZ23(9),SSZS11(3)
     *         ,SSZS12(3),SSZS13(3),SSZS21(9),SSZS22(9),SSZS23(9)
     *         ,SSZS24(9),SSZS31(27),SSZS32(27),SSZS41(81)
C
      IF(XLK.LT.XLTEST) RETURN
      IF(DRPR.EQ.0.0D0) RETURN
C
      IF(ITEST.EQ.2) GO TO 100
C
C     FIND DRAG PRESSURE AT ELEMENT TIP
C
C     FIND BODY POSITION AT ELEMENT TIP
C
      DO 10 I=1,3
      XB(I)=FCM(I,1)*XL1+FCM(I,2)*XL2+FCM(I,3)*XL3
      XB(I)=XB(I)+YIZK(I)
   10 CONTINUE
C
C
C     FIND INERTIAL POSITION OF ELEMENT TIP
C
      DO 20 I=1,3
      XI(I)=SA(I,1)*XB(1)+SA(I,2)*XB(2)+SA(I,3)*XB(3)
   20 CONTINUE
C
C     MODIFY POSITION VECTOR IN COMMON FOR AIRDRG
C
      DO 30 I=1,3
      SXSAT(I)=XSAT(I)
      XSAT(I)=XSAT(I)+XI(I)/FEET
   30 CONTINUE
      SP1=P1
C
      CALL AIRDRG(2)
C
      DELTP=(P1-DRPR)/DRPR
C
C     RESTORE XSAT AND P1 TO ORIGINAL VALUES
C
      DO 40 I=1,3
      XSAT(I)=SXSAT(I)
   40 CONTINUE
      P1=SP1
C
C     SAVE COMSOL ARRAYS
C
      SZZ01=ZZ01(K)
      SSZS01=SZS01(K)
      SSZS02=SZS02(K)
C
      DO 50 I=1,3
      SZZ12(I)=ZZ12(I,K)
      SSZS11(I)=SZS11(I,K)
      SSZS12(I)=SZS12(I,K)
      SSZS13(I)=SZS13(I,K)
   50 CONTINUE
C
      DO 51 I=1,9
      SZZ23(I)=ZZ23(I,K)
      SSZS21(I)=SZS21(I,K)
      SSZS22(I)=SZS22(I,K)
      SSZS23(I)=SZS23(I,K)
      SSZS24(I)=SZS24(I,K)
   51 CONTINUE
C
      DO 52 I=1,27
      SSZS31(I)=SZS31(I,K)
      SSZS32(I)=SZS32(I,K)
   52 CONTINUE
      DO 53 I=1,81
C
      SSZS41(I)=SZS41(I,K)
   53 CONTINUE
C
      L0=1
      LNK=0
      IF(LK(K).EQ.1) GO TO 55
      L0=2
      LNK=3
   55 CONTINUE
      L1=LNK
      L2=LNK*LNK
      L3=L1*L2
      L4=L1*L3
C
C     LOAD COMSOL ARRAYS WITH COMBINED ARRAYS
C
      ZZ01(K)=ZZ01(K)+DELTP*Z2S101(L0)
      SZS01(K)=SZS01(K)+DELTP*ZS101(L0)
      SZS02(K)=SZS02(K)+DELTP*ZS102(L0)
C
      DO 60 I=1,3
      I1=L1+I
      ZZ12(I,K)=ZZ12(I,K)+DELTP*Z2S112(I1)
      SZS11(I,K)=SZS11(I,K)+DELTP*ZS111(I1)
      SZS12(I,K)=SZS12(I,K)+DELTP*ZS112(I1)
      SZS13(I,K)=SZS13(I,K)+DELTP*ZS113(I1)
   60 CONTINUE
C
      DO 61 I=1,9
      I2=L2+I
      ZZ23(I,K)=ZZ23(I,K)+DELTP*Z2S123(I2)
      SZS21(I,K)=SZS21(I,K)+DELTP*ZS121(I2)
      SZS22(I,K)=SZS22(I,K)+DELTP*ZS122(I2)
      SZS23(I,K)=SZS23(I,K)+DELTP*ZS123(I2)
      SZS24(I,K)=SZS24(I,K)+DELTP*ZS124(I2)
   61 CONTINUE
C
      DO 62 I=1,27
      I3=L3+I
      SZS31(I,K)=SZS31(I,K)+DELTP*ZS131(I3)
      SZS32(I,K)=SZS32(I,K)+DELTP*ZS132(I3)
   62 CONTINUE
C
      DO 63 I=1,81
      I4=L4+I
      SZS41(I,K)=SZS41(I,K)+DELTP*ZS141(I4)
   63 CONTINUE
C
C     RETURN TO SOLAR FOR LINEARLY VARYING DRAG FORCE CALCULATION
C
      RETURN
C
  100 CONTINUE
C
C     RESTORE ORIGINAL ARRAYS TO COMSOL
C
      ZZ01(K)=SZZ01
      SZS01(K)=SSZS01
      SZS02(K)=SSZS02
C
      DO 110 I=1,3
      ZZ12(I,K)=SZZ12(I)
      SZS11(I,K)=SSZS11(I)
      SZS12(I,K)=SSZS12(I)
      SZS13(I,K)=SSZS13(I)
  110 CONTINUE
C
      DO 111 I=1,9
      ZZ23(I,K)=SZZ23(I)
      SZS21(I,K)=SSZS21(I)
      SZS22(I,K)=SSZS22(I)
      SZS23(I,K)=SSZS23(I)
      SZS24(I,K)=SSZS24(I)
  111 CONTINUE
C
      DO 112 I=1,27
      SZS31(I,K)=SSZS31(I)
      SZS32(I,K)=SSZS32(I)
  112 CONTINUE
C
      DO 113 I=1,81
      SZS41(I,K)=SSZS41(I)
  113 CONTINUE
C
C
      RETURN
      END


      module commeth
!     commeth
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Include file for array variables for hydrate variables.
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.30
!D2
!D2 Initial implementation: 06-Jun-02, Programmer: G. Zyvoloski
!D2
!D2 $Log:   /pvcs.config/fehm90/src/commeth.f_a  $
!D2
!***********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 N/A
!D3
!***********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 None
!D4
!***********************************************************************

      real*8, allocatable ::  denmethi(:)
      real*8, allocatable ::  denmethh(:)
      real*8, allocatable ::  denemethi(:)
      real*8, allocatable ::  denemethh(:)
      real*8, allocatable ::  pcpmeth(:)
      real*8, allocatable ::  pflowmeth(:)
      real*8, allocatable ::  phimeth(:)
      real*8, allocatable ::  phometh(:)
      real*8, allocatable ::  smeth(:)
      real*8, allocatable ::  someth(:)
      real*8, allocatable ::  tmeth(:)
      real*8, allocatable ::  tometh(:)
      real*8, allocatable ::  skmeth(:)
      real*8, allocatable ::  skmeth_tot(:)
      real*8, allocatable ::  skmethw(:)
      real*8, allocatable ::  qhmeth(:)
      real*8, allocatable ::  qhmethw(:)
      real*8, allocatable ::  eskmeth(:)
      real*8, allocatable ::  eflowmeth(:)
      real*8, allocatable ::  wellmeth(:)
      real*8, allocatable ::  rovfmeth(:)
      real*8, allocatable ::  envfmeth(:)
      real*8, allocatable ::  rolfmeth(:)
      real*8, allocatable ::  enlfmeth(:)
      real*8, allocatable ::  fracw(:)
      real*8, allocatable ::  fracwo(:)
      real*8, allocatable ::  qhflxmeth(:)

      real*8, allocatable ::  dpcp3(:)
      real*8, allocatable ::  dpcp4(:)
      real*8, allocatable ::  dpcpmeth2(:)
      real*8, allocatable ::  dtpameth(:)
      real*8, allocatable ::  dtpaemeth(:)

      integer, allocatable ::  kameth(:)

      real*8, allocatable ::  dmmf(:)
      real*8, allocatable ::  demf(:)
      real*8, allocatable ::  dilm(:)
      real*8, allocatable ::  divm(:)
      real*8, allocatable ::  deqm(:)
      real*8, allocatable ::  deqpm(:)

      real*8, allocatable ::  dmwf(:)
      real*8, allocatable ::  dewf(:)
      real*8, allocatable ::  dilw(:)
      real*8, allocatable ::  divw(:)
      real*8, allocatable ::  divg(:)
      real*8, allocatable ::  deqw(:)
      real*8, allocatable ::  deqpw(:)

      real*8, allocatable ::  denhydi(:)
      real*8, allocatable ::  denhydh(:)
      real*8, allocatable ::  denehydi(:)
      real*8, allocatable ::  denehydh(:)
      real*8, allocatable ::  frachyd(:)
      real*8, allocatable ::  frachydo(:)
      real*8, allocatable ::  fracgas(:)
      real*8, allocatable ::  fracgaso(:)
      real*8, allocatable ::  enlfhyd(:)
      real*8, allocatable ::  phihyd(:)
      real*8, allocatable ::  permhyd(:)
      real*8, allocatable ::  permhyd0(:)
      real*8, allocatable ::  dpermhyd4(:)
      real*8, allocatable ::  skhyd(:)
      real*8, allocatable ::  qhhyd(:)
      real*8, allocatable ::  skmhyd(:)
      real*8, allocatable ::  qhmhyd(:)
      real*8, allocatable ::  skwhyd(:)
      real*8, allocatable ::  qhwhyd(:)
      real*8, allocatable ::  dskhyd1(:)
      real*8, allocatable ::  dqhhyd1(:)
      real*8, allocatable ::  dskhyd2(:)
      real*8, allocatable ::  dqhhyd2(:)
      real*8, allocatable ::  dskhyd3(:)
      real*8, allocatable ::  dqhhyd3(:)
      real*8, allocatable ::  dskhyd4(:)
      real*8, allocatable ::  dqhhyd4(:)
      real*8, allocatable ::  dskmethw1(:)
      real*8, allocatable ::  dskmethw3(:)
      real*8, allocatable ::  dskmethw4(:)
      real*8, allocatable ::  dqm(:)
      real*8, allocatable ::  dqmt(:)
      real*8, allocatable ::  dqmh(:)
      real*8, allocatable ::  deqmh(:)
      real*8, allocatable ::  dqmw(:)
      real*8, allocatable ::  dqmhyd4(:)
      real*8, allocatable ::  dqd(:,:)
      real*8, allocatable ::  nhyd(:)
c      integer, allocatable ::  nhyd(:)
      integer, allocatable ::  ieoso(:)
      integer, allocatable ::  iceso(:)
      integer, allocatable ::  ihyd(:)
      integer, allocatable ::  ihydo(:)

      real*8, allocatable ::  dq3(:)
      real*8, allocatable ::  dq4(:)

      real*8, allocatable ::  rl_meth(:)
      real*8, allocatable ::  drl_meth3(:)
      real*8, allocatable ::  drl_meth4(:)
      real*8, allocatable ::  rl_h2o(:)
      real*8, allocatable ::  drl_h2o3(:)
      real*8, allocatable ::  drl_h2o4(:)
      real*8, allocatable ::  ahyd_coef(:)
c gaz 2005/August (related to general dissociation models)
      real*8, allocatable ::  skhyd_temp(:)
      real*8, allocatable ::  dskhydpf(:)
      real*8, allocatable ::  dskhydtf(:)
      real*8, allocatable ::  dskhydmf(:)
      real*8, allocatable ::  dskhydwf(:)
c hydrate dissociation (formation) model parameters
      integer max_hyd_model
      parameter (max_hyd_model = 100)
      integer, allocatable ::  idisst(:)
      integer, allocatable ::  idissp(:)
      real*8, allocatable ::  diss1f(:)
      real*8, allocatable ::  diss2f(:)
      real*8, allocatable ::  diss3f(:)
      real*8, allocatable ::  diss4f(:)
      real*8, allocatable ::  diss5f(:)
      real*8, allocatable ::  diss6f(:)
      real*8, allocatable ::  diss7f(:)
      real*8, allocatable ::  diss8f(:)
      real*8, allocatable ::  diss9f(:)
      real*8, allocatable ::  form1f(:)
      real*8, allocatable ::  form2f(:)
      real*8, allocatable ::  form3f(:)
      real*8, allocatable ::  form4f(:)
      real*8, allocatable ::  form5f(:)
      real*8, allocatable ::  form6f(:)
      real*8, allocatable ::  form7f(:)
      real*8, allocatable ::  form8f(:)
      real*8, allocatable ::  form9f(:)

      real*8, allocatable ::  a44i(:)
      real*8, allocatable ::  fracw_tot(:)
      real*8, allocatable ::  fracg_tot(:)

c tenma 2005/March
*     real*8, allocatable :: qhhyd_tot(:)
      real*8, allocatable :: qhh2o_tot(:)
      real*8, allocatable :: qhmeth_tot(:)
*     real*8, allocatable :: skhyd_tot(:)
      real*8, allocatable :: skh2o_tot(:)
c tenma 2005/April
      real*8, allocatable :: frac_mudw(:)
      real*8, allocatable :: poro_sand(:)
      real*8, allocatable :: poro_mud(:)
      real*8, allocatable :: z_sand(:)
      real*8, allocatable :: z_mud(:)
      real*8, allocatable :: permhyd_z(:)
      real*8, allocatable :: ka0_xy(:)
      real*8, allocatable :: perm_sand(:)
      real*8, allocatable :: perm_mud(:)
      real*8, allocatable ::  ahyd_coef_1(:)
c tenma 2005/06 => sakamoto model
      real*8, allocatable ::  frachyd_1(:)
      integer, allocatable ::  nhyd_2(:)
      real*8, allocatable :: nhyd_3(:)
      real*8, allocatable :: frachyd_max(:)

      real*8, allocatable :: fracg2(:)
      real*8, allocatable :: fracw2(:)
c
      real*8  ammeth0,aemeth0,ammeth,aemeth
      real*8  qmeth_in,qemeth_in,balmeth,balemeth
      real*8  qmeth,qemeth,qmethts,qemethts
      real*8  qmethts_in,qemethts_in
      real*8  aihyd

      real*8  amhyd0,aehyd0,amhyd,aehyd
      real*8  qhyd_in,qehyd_in,balhyd,balehyd
      real*8  qhyd,qehyd,qhydts,qehydts
      real*8  qhydts_in,qehydts_in

      real*8  amh2o0,aeh2o0,amh2o,aeh2o
      real*8  qh2o_in,qeh2o_in,balh2o,baleh2o
      real*8  qh2o,qeh2o,qh2ots,qeh2ots
      real*8  qh2ots_in,qeh2ots_in

      real*8 hdiss01,hdiss11,hdiss02,hdiss12
      real*8 da,oe,pe,le,me,ne,e_act1,e_act2,afhyd
      real*8 dar,oer,per,ler,mer,ner,e_act1r,e_act2r,afhydr

c    porh is pass-through of variable ps(i)
c    volh is pass-through of variable sx1(i)
      real*8 porh,volh,strd_meth,strd_meth0
      real*8 ratw,ratgas,rathyd,fracv,fracl
c    ptc1-ptc4 are patameters for the hydrate pt line
      integer imeth_pt
      real*8 ptc1,ptc2,ptc3,ptc4
      real*8 source_hyd_temp,ds1_tmp,ds2_tmp,ds3_tmp,ds4_tmp

      integer idof_meth, ihydfl, ishyd, ic_hyd, ic_hyd_tot, numhyd
      integer icmw,icmm,icmh
      integer ihyd_diss_type, ihyd_grow_type

      end module commeth


      SUBROUTINE ML5_0_HELAS_CALLS_AMPB_1(P,NHEL,H,IC)
C
C     Modules
C
      USE ML5_0_POLYNOMIAL_CONSTANTS
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=4)
      INTEGER    NCOMB
      PARAMETER (NCOMB=16)
      INTEGER NBORNAMPS
      PARAMETER (NBORNAMPS=3)
      INTEGER    NLOOPS, NLOOPGROUPS, NCTAMPS
      PARAMETER (NLOOPS=44, NLOOPGROUPS=28, NCTAMPS=85)
      INTEGER    NLOOPAMPS
      PARAMETER (NLOOPAMPS=129)
      INTEGER    NWAVEFUNCS,NLOOPWAVEFUNCS
      PARAMETER (NWAVEFUNCS=10,NLOOPWAVEFUNCS=93)
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
      REAL*16     MP__ZERO
      PARAMETER (MP__ZERO=0.0E0_16)
C     These are constants related to the split orders
      INTEGER    NSO, NSQUAREDSO, NAMPSO
      PARAMETER (NSO=1, NSQUAREDSO=1, NAMPSO=2)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL)
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      INTEGER H
C
C     LOCAL VARIABLES
C
      INTEGER I,J,K
      COMPLEX*16 COEFS(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)

      LOGICAL DUMMYFALSE
      DATA DUMMYFALSE/.FALSE./
C
C     GLOBAL VARIABLES
C
      INCLUDE 'coupl.inc'
      INCLUDE 'mp_coupl.inc'

      INTEGER HELOFFSET
      INTEGER GOODHEL(NCOMB)
      LOGICAL GOODAMP(NSQUAREDSO,NLOOPGROUPS)
      COMMON/ML5_0_FILTERS/GOODAMP,GOODHEL,HELOFFSET

      LOGICAL CHECKPHASE
      LOGICAL HELDOUBLECHECKED
      COMMON/ML5_0_INIT/CHECKPHASE, HELDOUBLECHECKED

      INTEGER SQSO_TARGET
      COMMON/ML5_0_SOCHOICE/SQSO_TARGET

      LOGICAL UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE,CT_REQ_SO_DONE
     $ ,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_SO_DONE
     $ ,CTCALL_REQ_SO_DONE,FILTER_SO
      COMMON/ML5_0_SO_REQS/UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE
     $ ,CT_REQ_SO_DONE,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE
     $ ,MP_LOOP_REQ_SO_DONE,CTCALL_REQ_SO_DONE,FILTER_SO

      INTEGER I_SO
      COMMON/ML5_0_I_SO/I_SO
      INTEGER I_LIB
      COMMON/ML5_0_I_LIB/I_LIB

      COMPLEX*16 AMP(NBORNAMPS)
      COMMON/ML5_0_AMPS/AMP
      COMPLEX*16 W(20,NWAVEFUNCS)
      COMMON/ML5_0_W/W

      COMPLEX*16 WL(MAXLWFSIZE,0:LOOPMAXCOEFS-1,MAXLWFSIZE,
     $ -1:NLOOPWAVEFUNCS)
      COMPLEX*16 PL(0:3,-1:NLOOPWAVEFUNCS)
      COMMON/ML5_0_WL/WL,PL

      COMPLEX*16 AMPL(3,NCTAMPS)
      COMMON/ML5_0_AMPL/AMPL

C
C     ----------
C     BEGIN CODE
C     ----------

C     The target squared split order contribution is already reached
C      if true.
      IF (FILTER_SO.AND.CT_REQ_SO_DONE) THEN
        GOTO 1001
      ENDIF

      CALL VXXXXX(P(0,1),ZERO,NHEL(1),-1*IC(1),W(1,1))
      CALL VXXXXX(P(0,2),ZERO,NHEL(2),-1*IC(2),W(1,2))
      CALL OXXXXX(P(0,3),MDL_MT,NHEL(3),+1*IC(3),W(1,3))
      CALL IXXXXX(P(0,4),MDL_MT,NHEL(4),-1*IC(4),W(1,4))
      CALL VVV1P0_1(W(1,1),W(1,2),GC_4,ZERO,ZERO,W(1,5))
C     Amplitude(s) for born diagram with ID 1
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),GC_5,AMP(1))
      CALL FFV1_1(W(1,3),W(1,1),GC_5,MDL_MT,MDL_WT,W(1,6))
C     Amplitude(s) for born diagram with ID 2
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),GC_5,AMP(2))
      CALL FFV1_2(W(1,4),W(1,1),GC_5,MDL_MT,MDL_WT,W(1,7))
C     Amplitude(s) for born diagram with ID 3
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),GC_5,AMP(3))
      CALL FFV1P0_3(W(1,4),W(1,3),GC_5,ZERO,ZERO,W(1,8))
C     Counter-term amplitude(s) for loop diagram number 4
      CALL R2_GG_1_R2_GG_2_0(W(1,5),W(1,8),R2_GGG_1,R2_GGG_2,AMPL(1,1))
C     Counter-term amplitude(s) for loop diagram number 5
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),R2_GQQ,AMPL(1,2))
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQB_1EPS,AMPL(2,3))
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQB_1EPS,AMPL(2,4))
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQB_1EPS,AMPL(2,5))
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQB_1EPS,AMPL(2,6))
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQB_1EPS,AMPL(2,7))
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQB_1EPS,AMPL(2,8))
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQG_1EPS,AMPL(2,9))
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQB,AMPL(1,10))
      CALL FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQT,AMPL(1,11))
      CALL FFV1_2(W(1,4),W(1,2),GC_5,MDL_MT,MDL_WT,W(1,9))
C     Counter-term amplitude(s) for loop diagram number 7
      CALL R2_QQ_1_R2_QQ_2_0(W(1,9),W(1,6),R2_QQQ,R2_QQT,AMPL(1,12))
      CALL R2_QQ_2_0(W(1,9),W(1,6),UV_TMASS_1EPS,AMPL(2,13))
      CALL R2_QQ_2_0(W(1,9),W(1,6),UV_TMASS,AMPL(1,14))
C     Counter-term amplitude(s) for loop diagram number 8
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),R2_GQQ,AMPL(1,15))
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQB_1EPS,AMPL(2,16))
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQB_1EPS,AMPL(2,17))
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQB_1EPS,AMPL(2,18))
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQB_1EPS,AMPL(2,19))
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQB_1EPS,AMPL(2,20))
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQB_1EPS,AMPL(2,21))
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQG_1EPS,AMPL(2,22))
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQB,AMPL(1,23))
      CALL FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQT,AMPL(1,24))
      CALL FFV1_1(W(1,3),W(1,2),GC_5,MDL_MT,MDL_WT,W(1,10))
C     Counter-term amplitude(s) for loop diagram number 10
      CALL R2_QQ_1_R2_QQ_2_0(W(1,7),W(1,10),R2_QQQ,R2_QQT,AMPL(1,25))
      CALL R2_QQ_2_0(W(1,7),W(1,10),UV_TMASS_1EPS,AMPL(2,26))
      CALL R2_QQ_2_0(W(1,7),W(1,10),UV_TMASS,AMPL(1,27))
C     Counter-term amplitude(s) for loop diagram number 11
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),R2_GQQ,AMPL(1,28))
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQB_1EPS,AMPL(2,29))
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQB_1EPS,AMPL(2,30))
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQB_1EPS,AMPL(2,31))
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQB_1EPS,AMPL(2,32))
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQB_1EPS,AMPL(2,33))
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQB_1EPS,AMPL(2,34))
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQG_1EPS,AMPL(2,35))
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQB,AMPL(1,36))
      CALL FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQT,AMPL(1,37))
C     Counter-term amplitude(s) for loop diagram number 13
      CALL FFV1_0(W(1,4),W(1,10),W(1,1),R2_GQQ,AMPL(1,38))
      CALL FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQB_1EPS,AMPL(2,39))
      CALL FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQB_1EPS,AMPL(2,40))
      CALL FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQB_1EPS,AMPL(2,41))
      CALL FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQB_1EPS,AMPL(2,42))
      CALL FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQB_1EPS,AMPL(2,43))
      CALL FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQB_1EPS,AMPL(2,44))
      CALL FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQG_1EPS,AMPL(2,45))
      CALL FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQB,AMPL(1,46))
      CALL FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQT,AMPL(1,47))
C     Counter-term amplitude(s) for loop diagram number 14
      CALL FFV1_0(W(1,9),W(1,3),W(1,1),R2_GQQ,AMPL(1,48))
      CALL FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQB_1EPS,AMPL(2,49))
      CALL FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQB_1EPS,AMPL(2,50))
      CALL FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQB_1EPS,AMPL(2,51))
      CALL FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQB_1EPS,AMPL(2,52))
      CALL FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQB_1EPS,AMPL(2,53))
      CALL FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQB_1EPS,AMPL(2,54))
      CALL FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQG_1EPS,AMPL(2,55))
      CALL FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQB,AMPL(1,56))
      CALL FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQT,AMPL(1,57))
C     Counter-term amplitude(s) for loop diagram number 17
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GG,AMPL(1,58))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,59))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,60))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,61))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,62))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,63))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,64))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GG_1EPS,AMPL(2,65))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB,AMPL(1,66))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GT,AMPL(1,67))
C     Counter-term amplitude(s) for loop diagram number 31
      CALL R2_GG_1_0(W(1,5),W(1,8),R2_GGQ,AMPL(1,68))
      CALL R2_GG_1_0(W(1,5),W(1,8),R2_GGQ,AMPL(1,69))
      CALL R2_GG_1_0(W(1,5),W(1,8),R2_GGQ,AMPL(1,70))
      CALL R2_GG_1_0(W(1,5),W(1,8),R2_GGQ,AMPL(1,71))
C     Counter-term amplitude(s) for loop diagram number 32
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,72))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,73))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,74))
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,75))
C     Counter-term amplitude(s) for loop diagram number 34
      CALL R2_GG_1_R2_GG_3_0(W(1,5),W(1,8),R2_GGQ,R2_GGB,AMPL(1,76))
C     Counter-term amplitude(s) for loop diagram number 35
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,77))
C     Counter-term amplitude(s) for loop diagram number 37
      CALL R2_GG_1_R2_GG_3_0(W(1,5),W(1,8),R2_GGQ,R2_GGT,AMPL(1,78))
C     Counter-term amplitude(s) for loop diagram number 38
      CALL VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,79))
C     At this point, all CT amps needed for (QCD=6), i.e. of split
C      order ID=1, are computed.
      IF(FILTER_SO.AND.SQSO_TARGET.EQ.1) GOTO 2000

      GOTO 1001
 2000 CONTINUE
      CT_REQ_SO_DONE=.TRUE.
 1001 CONTINUE
      END


      SUBROUTINE ML5_0_HELAS_CALLS_UVCT_1(P,NHEL,H,IC)
C
C     Modules
C
      USE ML5_0_POLYNOMIAL_CONSTANTS
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=5)
      INTEGER    NCOMB
      PARAMETER (NCOMB=48)
      INTEGER NBORNAMPS
      PARAMETER (NBORNAMPS=8)
      INTEGER    NLOOPS, NLOOPGROUPS, NCTAMPS
      PARAMETER (NLOOPS=144, NLOOPGROUPS=77, NCTAMPS=252)
      INTEGER    NLOOPAMPS
      PARAMETER (NLOOPAMPS=396)
      INTEGER    NWAVEFUNCS,NLOOPWAVEFUNCS
      PARAMETER (NWAVEFUNCS=28,NLOOPWAVEFUNCS=267)
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
      REAL*16     MP__ZERO
      PARAMETER (MP__ZERO=0.0E0_16)
C     These are constants related to the split orders
      INTEGER    NSO, NSQUAREDSO, NAMPSO
      PARAMETER (NSO=0, NSQUAREDSO=0, NAMPSO=0)
C
C     ARGUMENTS
C
      REAL*8 P(0:3,NEXTERNAL)
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      INTEGER H
C
C     LOCAL VARIABLES
C
      INTEGER I,J,K
      COMPLEX*16 COEFS(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)

      LOGICAL DUMMYFALSE
      DATA DUMMYFALSE/.FALSE./
C
C     GLOBAL VARIABLES
C
      INCLUDE 'coupl.inc'
      INCLUDE 'mp_coupl.inc'

      INTEGER HELOFFSET
      INTEGER GOODHEL(NCOMB)
      LOGICAL GOODAMP(NSQUAREDSO,NLOOPGROUPS)
      COMMON/ML5_0_FILTERS/GOODAMP,GOODHEL,HELOFFSET

      LOGICAL CHECKPHASE
      LOGICAL HELDOUBLECHECKED
      COMMON/ML5_0_INIT/CHECKPHASE, HELDOUBLECHECKED

      INTEGER SQSO_TARGET
      COMMON/ML5_0_SOCHOICE/SQSO_TARGET

      LOGICAL UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE,CT_REQ_SO_DONE
     $ ,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_SO_DONE
     $ ,CTCALL_REQ_SO_DONE,FILTER_SO
      COMMON/ML5_0_SO_REQS/UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE
     $ ,CT_REQ_SO_DONE,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE
     $ ,MP_LOOP_REQ_SO_DONE,CTCALL_REQ_SO_DONE,FILTER_SO

      INTEGER I_SO
      COMMON/ML5_0_I_SO/I_SO
      INTEGER I_LIB
      COMMON/ML5_0_I_LIB/I_LIB

      COMPLEX*16 AMP(NBORNAMPS)
      COMMON/ML5_0_AMPS/AMP
      COMPLEX*16 W(20,NWAVEFUNCS)
      COMMON/ML5_0_W/W

      COMPLEX*16 WL(MAXLWFSIZE,0:LOOPMAXCOEFS-1,MAXLWFSIZE,
     $ -1:NLOOPWAVEFUNCS)
      COMPLEX*16 PL(0:3,-1:NLOOPWAVEFUNCS)
      COMMON/ML5_0_WL/WL,PL

      COMPLEX*16 AMPL(3,NCTAMPS)
      COMMON/ML5_0_AMPL/AMPL

C
C     ----------
C     BEGIN CODE
C     ----------

C     The target squared split order contribution is already reached
C      if true.
      IF (FILTER_SO.AND.UVCT_REQ_SO_DONE) THEN
        GOTO 1001
      ENDIF

C     Amplitude(s) for UVCT diagram with ID 135
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),GC_5,AMPL(2,237))
      AMPL(2,237)=AMPL(2,237)*(4.0D0*UVWFCT_G_1_1EPS+2.0D0
     $ *UVWFCT_B_0_1EPS)
C     Amplitude(s) for UVCT diagram with ID 136
      CALL FFV1_0(W(1,5),W(1,7),W(1,6),GC_5,AMPL(1,238))
      AMPL(1,238)=AMPL(1,238)*(2.0D0*UVWFCT_G_2+1.0D0*UVWFCT_T_0+1.0D0
     $ *UVWFCT_B_0+2.0D0*UVWFCT_G_1)
C     Amplitude(s) for UVCT diagram with ID 137
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),GC_5,AMPL(2,239))
      AMPL(2,239)=AMPL(2,239)*(4.0D0*UVWFCT_G_1_1EPS+2.0D0
     $ *UVWFCT_B_0_1EPS)
C     Amplitude(s) for UVCT diagram with ID 138
      CALL FFV1_0(W(1,8),W(1,4),W(1,6),GC_5,AMPL(1,240))
      AMPL(1,240)=AMPL(1,240)*(2.0D0*UVWFCT_G_2+1.0D0*UVWFCT_T_0+1.0D0
     $ *UVWFCT_B_0+2.0D0*UVWFCT_G_1)
C     Amplitude(s) for UVCT diagram with ID 139
      CALL FFV2_0(W(1,10),W(1,9),W(1,3),GC_11,AMPL(2,241))
      AMPL(2,241)=AMPL(2,241)*(4.0D0*UVWFCT_G_1_1EPS+2.0D0
     $ *UVWFCT_B_0_1EPS)
C     Amplitude(s) for UVCT diagram with ID 140
      CALL FFV2_0(W(1,10),W(1,9),W(1,3),GC_11,AMPL(1,242))
      AMPL(1,242)=AMPL(1,242)*(2.0D0*UVWFCT_G_2+1.0D0*UVWFCT_T_0+1.0D0
     $ *UVWFCT_B_0+2.0D0*UVWFCT_G_1)
C     Amplitude(s) for UVCT diagram with ID 141
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),GC_5,AMPL(2,243))
      AMPL(2,243)=AMPL(2,243)*(4.0D0*UVWFCT_G_1_1EPS+2.0D0
     $ *UVWFCT_B_0_1EPS)
C     Amplitude(s) for UVCT diagram with ID 142
      CALL FFV1_0(W(1,8),W(1,9),W(1,2),GC_5,AMPL(1,244))
      AMPL(1,244)=AMPL(1,244)*(2.0D0*UVWFCT_G_2+1.0D0*UVWFCT_T_0+1.0D0
     $ *UVWFCT_B_0+2.0D0*UVWFCT_G_1)
C     Amplitude(s) for UVCT diagram with ID 143
      CALL FFV2_0(W(1,11),W(1,12),W(1,3),GC_11,AMPL(2,245))
      AMPL(2,245)=AMPL(2,245)*(4.0D0*UVWFCT_G_1_1EPS+2.0D0
     $ *UVWFCT_B_0_1EPS)
C     Amplitude(s) for UVCT diagram with ID 144
      CALL FFV2_0(W(1,11),W(1,12),W(1,3),GC_11,AMPL(1,246))
      AMPL(1,246)=AMPL(1,246)*(2.0D0*UVWFCT_G_2+1.0D0*UVWFCT_T_0+1.0D0
     $ *UVWFCT_B_0+2.0D0*UVWFCT_G_1)
C     Amplitude(s) for UVCT diagram with ID 145
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),GC_5,AMPL(2,247))
      AMPL(2,247)=AMPL(2,247)*(4.0D0*UVWFCT_G_1_1EPS+2.0D0
     $ *UVWFCT_B_0_1EPS)
C     Amplitude(s) for UVCT diagram with ID 146
      CALL FFV1_0(W(1,11),W(1,7),W(1,2),GC_5,AMPL(1,248))
      AMPL(1,248)=AMPL(1,248)*(2.0D0*UVWFCT_G_2+1.0D0*UVWFCT_T_0+1.0D0
     $ *UVWFCT_B_0+2.0D0*UVWFCT_G_1)
C     Amplitude(s) for UVCT diagram with ID 147
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),GC_5,AMPL(2,249))
      AMPL(2,249)=AMPL(2,249)*(4.0D0*UVWFCT_G_1_1EPS+2.0D0
     $ *UVWFCT_B_0_1EPS)
C     Amplitude(s) for UVCT diagram with ID 148
      CALL FFV1_0(W(1,8),W(1,12),W(1,1),GC_5,AMPL(1,250))
      AMPL(1,250)=AMPL(1,250)*(2.0D0*UVWFCT_G_2+1.0D0*UVWFCT_T_0+1.0D0
     $ *UVWFCT_B_0+2.0D0*UVWFCT_G_1)
C     Amplitude(s) for UVCT diagram with ID 149
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),GC_5,AMPL(2,251))
      AMPL(2,251)=AMPL(2,251)*(4.0D0*UVWFCT_G_1_1EPS+2.0D0
     $ *UVWFCT_B_0_1EPS)
C     Amplitude(s) for UVCT diagram with ID 150
      CALL FFV1_0(W(1,10),W(1,7),W(1,1),GC_5,AMPL(1,252))
      AMPL(1,252)=AMPL(1,252)*(2.0D0*UVWFCT_G_2+1.0D0*UVWFCT_T_0+1.0D0
     $ *UVWFCT_B_0+2.0D0*UVWFCT_G_1)

      GOTO 1001
 3000 CONTINUE
      UVCT_REQ_SO_DONE=.TRUE.
 1001 CONTINUE
      END