      SUBROUTINE ML5_0_MP_COMPUTE_LOOP_COEFS(PS,ANSDP)
C
C     Generated by MadGraph5_aMC@NLO v. %(version)s, %(date)s
C     By the MadGraph5_aMC@NLO Development Team
C     Visit launchpad.net/madgraph5 and amcatnlo.web.cern.ch
C
C     Returns amplitude squared summed/avg over colors
C     and helicities for the point in phase space P(0:3,NEXTERNAL)
C     and external lines W(0:6,NEXTERNAL)
C
C     Process: g g > t t~ [ virt = QCD ]
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      CHARACTER*64 PARAMFILENAME
      PARAMETER ( PARAMFILENAME='MadLoopParams.dat')
      INTEGER NBORNAMPS
      PARAMETER (NBORNAMPS=3)
      INTEGER    NLOOPS, NLOOPGROUPS, NCTAMPS
      PARAMETER (NLOOPS=44, NLOOPGROUPS=26, NCTAMPS=85)
      INTEGER    NLOOPAMPS
      PARAMETER (NLOOPAMPS=129)
      INTEGER    NCOLORROWS
      PARAMETER (NCOLORROWS=NLOOPAMPS)
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=4)
      INTEGER    NWAVEFUNCS,NLOOPWAVEFUNCS
      PARAMETER (NWAVEFUNCS=10,NLOOPWAVEFUNCS=93)
      INTEGER MAXLWFSIZE
      PARAMETER (MAXLWFSIZE=4)
      INTEGER LOOPMAXCOEFS, VERTEXMAXCOEFS
      PARAMETER (LOOPMAXCOEFS=35, VERTEXMAXCOEFS=5)
      INTEGER    NCOMB
      PARAMETER (NCOMB=16)
      REAL*16    ZERO
      PARAMETER (ZERO=0E0_16)
      COMPLEX*32 IMAG1
      PARAMETER (IMAG1=(0E0_16,1E0_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*16 PS(0:3,NEXTERNAL)
      REAL*8 ANSDP(3,0:NSQUAREDSO)
C
C     LOCAL VARIABLES
C
      LOGICAL DPW_COPIED
      INTEGER I,J,K,H,HEL_MULT,ITEMP
      REAL*16 TEMP2
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      REAL*16 P(0:3,NEXTERNAL)
      DATA IC/NEXTERNAL*1/
      REAL*16 ANS(3,0:NSQUAREDSO)
      COMPLEX*32 COEFS(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)
      COMPLEX*32 CFTOT
C
C     FUNCTIONS
C
      INTEGER ML5_0_ML5SOINDEX_FOR_BORN_AMP
      INTEGER ML5_0_ML5SOINDEX_FOR_LOOP_AMP
      INTEGER ML5_0_ML5SQSOINDEX
C
C     GLOBAL VARIABLES
C
      INCLUDE 'mp_coupl_same_name.inc'

      LOGICAL CHECKPHASE, HELDOUBLECHECKED
      COMMON/ML5_0_INIT/CHECKPHASE, HELDOUBLECHECKED

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

      INTEGER HELPICKED
      COMMON/ML5_0_HELCHOICE/HELPICKED

      INTEGER USERHEL
      COMMON/ML5_0_USERCHOICE/USERHEL

      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_S
     $ O_DONE,CTCALL_REQ_SO_DONE,FILTER_SO

      COMPLEX*32 AMP(NBORNAMPS)
      COMMON/ML5_0_MP_AMPS/AMP
      COMPLEX*16 DP_AMP(NBORNAMPS)
      COMMON/ML5_0_AMPS/DP_AMP
      COMPLEX*32 W(20,NWAVEFUNCS)
      COMMON/ML5_0_MP_W/W

      COMPLEX*16 DPW(20,NWAVEFUNCS)
      COMMON/ML5_0_W/DPW

      COMPLEX*32 WL(MAXLWFSIZE,0:LOOPMAXCOEFS-1,MAXLWFSIZE,0:NLOOPWAVEF
     $ UNCS)
      COMPLEX*32 PL(0:3,0:NLOOPWAVEFUNCS)
      COMMON/ML5_0_MP_WL/WL,PL

      COMPLEX*32 LOOPCOEFS(0:LOOPMAXCOEFS-1,NSQUAREDSO,NLOOPGROUPS)
      COMMON/ML5_0_MP_LCOEFS/LOOPCOEFS

      COMPLEX*32 AMPL(3,NCTAMPS)
      COMMON/ML5_0_MP_AMPL/AMPL

      INTEGER CF_D(NCOLORROWS,NBORNAMPS)
      INTEGER CF_N(NCOLORROWS,NBORNAMPS)
      COMMON/ML5_0_CF/CF_D,CF_N

      INTEGER HELC(NEXTERNAL,NCOMB)
      COMMON/ML5_0_HELCONFIGS/HELC

      LOGICAL MP_DONE_ONCE
      COMMON/ML5_0_MP_DONE_ONCE/MP_DONE_ONCE

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

C     To be on the safe side, we always update the MP params here.
C     It can be redundant as this routine can be called a couple of
C      times for the same PS point during the stability checks.
C     But it is really not time consuming and I would rather be safe.
      CALL MP_UPDATE_AS_PARAM()

      MP_DONE_ONCE = .TRUE.

C     AS A SAFETY MEASURE WE FIRST COPY HERE THE PS POINT
      DO I=1,NEXTERNAL
        DO J=0,3
          P(J,I)=PS(J,I)
        ENDDO
      ENDDO

      DO I=0,3
        PL(I,0)=(ZERO,ZERO)
      ENDDO
      DO I=1,MAXLWFSIZE
        DO J=0,LOOPMAXCOEFS-1
          DO K=1,MAXLWFSIZE
            IF(I.EQ.K.AND.J.EQ.0) THEN
              WL(I,J,K,0)=(1.0E0_16,ZERO)
            ELSE
              WL(I,J,K,0)=(ZERO,ZERO)
            ENDIF
          ENDDO
        ENDDO
      ENDDO

      DO K=1, 3
        DO I=1,NCTAMPS
          AMPL(K,I)=(ZERO,ZERO)
        ENDDO
      ENDDO

      DO I=1, NBORNAMPS
        DP_AMP(I) = (0.0D0,0.0D0)
        AMP(I) = (ZERO, ZERO)
      ENDDO

      DO I=1,NLOOPGROUPS
        DO J=0,LOOPMAXCOEFS-1
          DO K=1,NSQUAREDSO
            LOOPCOEFS(J,K,I)=(ZERO,ZERO)
          ENDDO
        ENDDO
      ENDDO

      DO K=1,3
        DO J=0,NSQUAREDSO
          ANSDP(K,J)=0.0D0
          ANS(K,J)=ZERO
        ENDDO
      ENDDO

      DPW_COPIED = .FALSE.
      DO H=1,NCOMB
        IF ((HELPICKED.EQ.H).OR.((HELPICKED.EQ.-1).AND.(CHECKPHASE.OR.(
     $   .NOT.HELDOUBLECHECKED).OR.(GOODHEL(H).GT.-HELOFFSET.AND.GOODHE
     $   L(H).NE.0)))) THEN
          DO I=1,NEXTERNAL
            NHEL(I)=HELC(I,H)
          ENDDO

          MP_UVCT_REQ_SO_DONE=.FALSE.
          MP_CT_REQ_SO_DONE=.FALSE.
          MP_LOOP_REQ_SO_DONE=.FALSE.

          IF (.NOT.CHECKPHASE.AND.HELDOUBLECHECKED.AND.HELPICKED.EQ.
     $     -1) THEN
            HEL_MULT=GOODHEL(H)
          ELSE
            HEL_MULT=1
          ENDIF

          CALL MP_VXXXXX(P(0,1),ZERO,NHEL(1),-1*IC(1),W(1,1))
          CALL MP_VXXXXX(P(0,2),ZERO,NHEL(2),-1*IC(2),W(1,2))
          CALL MP_OXXXXX(P(0,3),MDL_MT,NHEL(3),+1*IC(3),W(1,3))
          CALL MP_IXXXXX(P(0,4),MDL_MT,NHEL(4),-1*IC(4),W(1,4))
          CALL MP_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 MP_FFV1_0(W(1,4),W(1,3),W(1,5),GC_5,AMP(1))
          CALL MP_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 MP_FFV1_0(W(1,4),W(1,6),W(1,2),GC_5,AMP(2))
          CALL MP_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 MP_FFV1_0(W(1,7),W(1,3),W(1,2),GC_5,AMP(3))
          CALL MP_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 MP_R2_GG_1_0(W(1,5),W(1,8),R2_GGQ,AMPL(1,1))
          CALL MP_R2_GG_1_0(W(1,5),W(1,8),R2_GGQ,AMPL(1,2))
          CALL MP_R2_GG_1_0(W(1,5),W(1,8),R2_GGQ,AMPL(1,3))
          CALL MP_R2_GG_1_0(W(1,5),W(1,8),R2_GGQ,AMPL(1,4))
C         Counter-term amplitude(s) for loop diagram number 5
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,5))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,6))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,7))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,8))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB,AMPL(1,9))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,10))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GT,AMPL(1,11))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GB_1EPS,AMPL(2,12))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),UV_3GG_1EPS,AMPL(2,13))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,14))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,15))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,16))
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,17))
C         Counter-term amplitude(s) for loop diagram number 7
          CALL MP_R2_GG_1_R2_GG_3_0(W(1,5),W(1,8),R2_GGQ,R2_GGB,AMPL(1
     $     ,18))
C         Counter-term amplitude(s) for loop diagram number 8
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GQ,AMPL(1,19))
C         Counter-term amplitude(s) for loop diagram number 10
          CALL MP_R2_GG_1_R2_GG_3_0(W(1,5),W(1,8),R2_GGQ,R2_GGT,AMPL(1
     $     ,20))
C         Counter-term amplitude(s) for loop diagram number 11
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,21))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,22))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,23))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,24))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQB,AMPL(1,25))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,26))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQT,AMPL(1,27))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQQ_1EPS,AMPL(2,28))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),UV_GQQG_1EPS,AMPL(2,29))
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),R2_GQQ,AMPL(1,30))
          CALL MP_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 13
          CALL MP_R2_QQ_1_R2_QQ_2_0(W(1,9),W(1,6),R2_QQQ,R2_QQT,AMPL(1
     $     ,31))
          CALL MP_R2_QQ_2_0(W(1,9),W(1,6),UV_TMASS,AMPL(1,32))
          CALL MP_R2_QQ_2_0(W(1,9),W(1,6),UV_TMASS_1EPS,AMPL(2,33))
C         Counter-term amplitude(s) for loop diagram number 14
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQQ_1EPS,AMPL(2,34))
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQQ_1EPS,AMPL(2,35))
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQQ_1EPS,AMPL(2,36))
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQQ_1EPS,AMPL(2,37))
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQB,AMPL(1,38))
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQQ_1EPS,AMPL(2,39))
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQT,AMPL(1,40))
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQQ_1EPS,AMPL(2,41))
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),UV_GQQG_1EPS,AMPL(2,42))
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),R2_GQQ,AMPL(1,43))
          CALL MP_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 16
          CALL MP_R2_QQ_1_R2_QQ_2_0(W(1,7),W(1,10),R2_QQQ,R2_QQT
     $     ,AMPL(1,44))
          CALL MP_R2_QQ_2_0(W(1,7),W(1,10),UV_TMASS,AMPL(1,45))
          CALL MP_R2_QQ_2_0(W(1,7),W(1,10),UV_TMASS_1EPS,AMPL(2,46))
C         Counter-term amplitude(s) for loop diagram number 17
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQQ_1EPS,AMPL(2,47))
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQQ_1EPS,AMPL(2,48))
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQQ_1EPS,AMPL(2,49))
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQQ_1EPS,AMPL(2,50))
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQB,AMPL(1,51))
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQQ_1EPS,AMPL(2,52))
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQT,AMPL(1,53))
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQQ_1EPS,AMPL(2,54))
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),UV_GQQG_1EPS,AMPL(2,55))
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),R2_GQQ,AMPL(1,56))
C         Counter-term amplitude(s) for loop diagram number 19
          CALL MP_FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQQ_1EPS,AMPL(2,57))
          CALL MP_FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQQ_1EPS,AMPL(2,58))
          CALL MP_FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQQ_1EPS,AMPL(2,59))
          CALL MP_FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQQ_1EPS,AMPL(2,60))
          CALL MP_FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQB,AMPL(1,61))
          CALL MP_FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQQ_1EPS,AMPL(2,62))
          CALL MP_FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQT,AMPL(1,63))
          CALL MP_FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQQ_1EPS,AMPL(2,64))
          CALL MP_FFV1_0(W(1,4),W(1,10),W(1,1),UV_GQQG_1EPS,AMPL(2,65))
          CALL MP_FFV1_0(W(1,4),W(1,10),W(1,1),R2_GQQ,AMPL(1,66))
C         Counter-term amplitude(s) for loop diagram number 20
          CALL MP_FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQQ_1EPS,AMPL(2,67))
          CALL MP_FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQQ_1EPS,AMPL(2,68))
          CALL MP_FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQQ_1EPS,AMPL(2,69))
          CALL MP_FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQQ_1EPS,AMPL(2,70))
          CALL MP_FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQB,AMPL(1,71))
          CALL MP_FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQQ_1EPS,AMPL(2,72))
          CALL MP_FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQT,AMPL(1,73))
          CALL MP_FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQQ_1EPS,AMPL(2,74))
          CALL MP_FFV1_0(W(1,9),W(1,3),W(1,1),UV_GQQG_1EPS,AMPL(2,75))
          CALL MP_FFV1_0(W(1,9),W(1,3),W(1,1),R2_GQQ,AMPL(1,76))
C         Counter-term amplitude(s) for loop diagram number 22
          CALL MP_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 32
          CALL MP_R2_GG_1_R2_GG_2_0(W(1,5),W(1,8),R2_GGG_1,R2_GGG_2
     $     ,AMPL(1,78))
C         Counter-term amplitude(s) for loop diagram number 33
          CALL MP_VVV1_0(W(1,1),W(1,2),W(1,8),R2_3GG,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
 2000     CONTINUE
          MP_CT_REQ_SO_DONE=.TRUE.

C         Amplitude(s) for UVCT diagram with ID 40
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),GC_5,AMPL(1,80))
          AMPL(1,80)=AMPL(1,80)*(2.0D0*UVWFCT_G_2+2.0D0*UVWFCT_G_1
     $     +2.0D0*UVWFCT_T_0)
C         Amplitude(s) for UVCT diagram with ID 41
          CALL MP_FFV1_0(W(1,4),W(1,3),W(1,5),GC_5,AMPL(2,81))
          AMPL(2,81)=AMPL(2,81)*(2.0D0*UVWFCT_B_0_1EPS+4.0D0*UVWFCT_G_2
     $     _1EPS)
C         Amplitude(s) for UVCT diagram with ID 42
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),GC_5,AMPL(1,82))
          AMPL(1,82)=AMPL(1,82)*(2.0D0*UVWFCT_G_2+2.0D0*UVWFCT_G_1
     $     +2.0D0*UVWFCT_T_0)
C         Amplitude(s) for UVCT diagram with ID 43
          CALL MP_FFV1_0(W(1,4),W(1,6),W(1,2),GC_5,AMPL(2,83))
          AMPL(2,83)=AMPL(2,83)*(2.0D0*UVWFCT_B_0_1EPS+4.0D0*UVWFCT_G_2
     $     _1EPS)
C         Amplitude(s) for UVCT diagram with ID 44
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),GC_5,AMPL(1,84))
          AMPL(1,84)=AMPL(1,84)*(2.0D0*UVWFCT_G_2+2.0D0*UVWFCT_G_1
     $     +2.0D0*UVWFCT_T_0)
C         Amplitude(s) for UVCT diagram with ID 45
          CALL MP_FFV1_0(W(1,7),W(1,3),W(1,2),GC_5,AMPL(2,85))
          AMPL(2,85)=AMPL(2,85)*(2.0D0*UVWFCT_B_0_1EPS+4.0D0*UVWFCT_G_2
     $     _1EPS)
C         At this point, all UVCT amps needed for (QCD=6), i.e. of
C          split order ID=1, are computed.
          IF(FILTER_SO.AND.SQSO_TARGET.EQ.1) GOTO 3000
 3000     CONTINUE
          MP_UVCT_REQ_SO_DONE=.TRUE.

          DO I=1,NCTAMPS
            DO J=1,NBORNAMPS
              CFTOT=CMPLX(CF_N(I,J)/REAL(ABS(CF_D(I,J)),KIND=16)
     $         ,0.0E0_16,KIND=16)
              IF(CF_D(I,J).LT.0) CFTOT=CFTOT*IMAG1
              ITEMP = ML5_0_ML5SQSOINDEX(ML5_0_ML5SOINDEX_FOR_LOOP_AMP(
     $         I),ML5_0_ML5SOINDEX_FOR_BORN_AMP(J))
              IF (.NOT.FILTER_SO.OR.SQSO_TARGET.EQ.ITEMP) THEN
                DO K=1,3
                  TEMP2 = HEL_MULT*2.0E0_16*REAL(CFTOT*AMPL(K,I)
     $             *CONJG(AMP(J)),KIND=16)
                  ANS(K,ITEMP)=ANS(K,ITEMP)+TEMP2
                  ANS(K,0)=ANS(K,0)+TEMP2
                ENDDO
              ENDIF
            ENDDO
          ENDDO

C         Coefficient construction for loop diagram with ID 4
          CALL MP_FFV1L2_1(PL(0,0),W(1,5),GC_5,ZERO,ZERO,PL(0,1),COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,1))
          CALL MP_FFV1L2_1(PL(0,1),W(1,8),GC_5,ZERO,ZERO,PL(0,2),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,1),4,COEFS,4,4,WL(1,0,1
     $     ,2))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,2),2,4,1,1,4,86,H)
C         Coefficient construction for loop diagram with ID 5
          CALL MP_FFV1L1_2(PL(0,0),W(1,1),GC_5,ZERO,ZERO,PL(0,3),COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,3))
          CALL MP_FFV1L1_2(PL(0,3),W(1,2),GC_5,ZERO,ZERO,PL(0,4),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,3),4,COEFS,4,4,WL(1,0,1
     $     ,4))
          CALL MP_FFV1L1_2(PL(0,4),W(1,8),GC_5,ZERO,ZERO,PL(0,5),COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,4),4,COEFS,4,4,WL(1,0,1
     $     ,5))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,5),3,4,2,1,4,87,H)
C         Coefficient construction for loop diagram with ID 6
          CALL MP_FFV1L2_1(PL(0,0),W(1,1),GC_5,ZERO,ZERO,PL(0,6),COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,6))
          CALL MP_FFV1L2_1(PL(0,6),W(1,2),GC_5,ZERO,ZERO,PL(0,7),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,6),4,COEFS,4,4,WL(1,0,1
     $     ,7))
          CALL MP_FFV1L2_1(PL(0,7),W(1,8),GC_5,ZERO,ZERO,PL(0,8),COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,7),4,COEFS,4,4,WL(1,0,1
     $     ,8))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,8),3,4,2,1,4,88,H)
C         Coefficient construction for loop diagram with ID 7
          CALL MP_FFV1L2_1(PL(0,0),W(1,5),GC_5,MDL_MB,ZERO,PL(0,9)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,9))
          CALL MP_FFV1L2_1(PL(0,9),W(1,8),GC_5,MDL_MB,ZERO,PL(0,10)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,9),4,COEFS,4,4,WL(1,0,1
     $     ,10))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,10),2,4,3,1,1,89,H)
C         Coefficient construction for loop diagram with ID 8
          CALL MP_FFV1L1_2(PL(0,0),W(1,1),GC_5,MDL_MB,ZERO,PL(0,11)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,11))
          CALL MP_FFV1L1_2(PL(0,11),W(1,2),GC_5,MDL_MB,ZERO,PL(0,12)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,11),4,COEFS,4,4,WL(1,0
     $     ,1,12))
          CALL MP_FFV1L1_2(PL(0,12),W(1,8),GC_5,MDL_MB,ZERO,PL(0,13)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,12),4,COEFS,4,4,WL(1,0
     $     ,1,13))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,13),3,4,4,1,1,90,H)
C         Coefficient construction for loop diagram with ID 9
          CALL MP_FFV1L2_1(PL(0,0),W(1,1),GC_5,MDL_MB,ZERO,PL(0,14)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,14))
          CALL MP_FFV1L2_1(PL(0,14),W(1,2),GC_5,MDL_MB,ZERO,PL(0,15)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,14),4,COEFS,4,4,WL(1,0
     $     ,1,15))
          CALL MP_FFV1L2_1(PL(0,15),W(1,8),GC_5,MDL_MB,ZERO,PL(0,16)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,15),4,COEFS,4,4,WL(1,0
     $     ,1,16))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,16),3,4,4,1,1,91,H)
C         Coefficient construction for loop diagram with ID 10
          CALL MP_FFV1L2_1(PL(0,0),W(1,5),GC_5,MDL_MT,MDL_WT,PL(0,17)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,17))
          CALL MP_FFV1L2_1(PL(0,17),W(1,8),GC_5,MDL_MT,MDL_WT,PL(0,18)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,17),4,COEFS,4,4,WL(1,0
     $     ,1,18))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,18),2,4,5,1,1,92,H)
C         Coefficient construction for loop diagram with ID 11
          CALL MP_FFV1L1P0_3(PL(0,0),W(1,3),GC_5,ZERO,ZERO,PL(0,19)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,19))
          CALL MP_FFV1L3_2(PL(0,19),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,20)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,19),4,COEFS,4,4,WL(1,0
     $     ,1,20))
          CALL MP_FFV1L1_2(PL(0,20),W(1,5),GC_5,MDL_MT,MDL_WT,PL(0,21)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,20),4,COEFS,4,4,WL(1,0
     $     ,1,21))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,21),2,4,6,1,1,93,H)
C         Coefficient construction for loop diagram with ID 12
          CALL MP_FFV1L3_1(PL(0,0),W(1,3),GC_5,MDL_MT,MDL_WT,PL(0,22)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,22))
          CALL MP_FFV1L2P0_3(PL(0,22),W(1,4),GC_5,ZERO,ZERO,PL(0,23)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,22),4,COEFS,4,4,WL(1,0
     $     ,1,23))
          CALL MP_VVV1L2P0_1(PL(0,23),W(1,5),GC_4,ZERO,ZERO,PL(0,24)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,23),4,COEFS,4,4,WL(1,0
     $     ,1,24))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,24),2,4,7,1,1,94,H)
C         Coefficient construction for loop diagram with ID 13
          CALL MP_FFV1L1P0_3(PL(0,0),W(1,6),GC_5,ZERO,ZERO,PL(0,25)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,25))
          CALL MP_FFV1L3_2(PL(0,25),W(1,9),GC_5,MDL_MT,MDL_WT,PL(0,26)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,25),4,COEFS,4,4,WL(1,0
     $     ,1,26))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,26),1,4,8,1,1,95,H)
C         Coefficient construction for loop diagram with ID 14
          CALL MP_FFV1L2_1(PL(0,0),W(1,2),GC_5,MDL_MT,MDL_WT,PL(0,27)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,27))
          CALL MP_FFV1L2P0_3(PL(0,27),W(1,4),GC_5,ZERO,ZERO,PL(0,28)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,27),4,COEFS,4,4,WL(1,0
     $     ,1,28))
          CALL MP_FFV1L3_1(PL(0,28),W(1,6),GC_5,MDL_MT,MDL_WT,PL(0,29)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,28),4,COEFS,4,4,WL(1,0
     $     ,1,29))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,29),2,4,9,1,1,96,H)
C         Coefficient construction for loop diagram with ID 15
          CALL MP_VVV1L2P0_1(PL(0,0),W(1,2),GC_4,ZERO,ZERO,PL(0,30)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,30))
          CALL MP_FFV1L3_2(PL(0,30),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,31)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,30),4,COEFS,4,4,WL(1,0
     $     ,1,31))
          CALL MP_FFV1L1P0_3(PL(0,31),W(1,6),GC_5,ZERO,ZERO,PL(0,32)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_0(WL(1,0,1,31),4,COEFS,4,4,WL(1,0
     $     ,1,32))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,32),2,4,10,1,1,97,H)
C         Coefficient construction for loop diagram with ID 16
          CALL MP_FFV1L1P0_3(PL(0,0),W(1,10),GC_5,ZERO,ZERO,PL(0,33)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,33))
          CALL MP_FFV1L3_2(PL(0,33),W(1,7),GC_5,MDL_MT,MDL_WT,PL(0,34)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,33),4,COEFS,4,4,WL(1,0
     $     ,1,34))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,34),1,4,11,1,1,98,H)
C         Coefficient construction for loop diagram with ID 17
          CALL MP_FFV1L1_2(PL(0,0),W(1,2),GC_5,MDL_MT,MDL_WT,PL(0,35)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,35))
          CALL MP_FFV1L1P0_3(PL(0,35),W(1,3),GC_5,ZERO,ZERO,PL(0,36)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,35),4,COEFS,4,4,WL(1,0
     $     ,1,36))
          CALL MP_FFV1L3_2(PL(0,36),W(1,7),GC_5,MDL_MT,MDL_WT,PL(0,37)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,36),4,COEFS,4,4,WL(1,0
     $     ,1,37))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,37),2,4,12,1,1,99,H)
C         Coefficient construction for loop diagram with ID 18
          CALL MP_FFV1L3_1(PL(0,30),W(1,3),GC_5,MDL_MT,MDL_WT,PL(0,38)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,30),4,COEFS,4,4,WL(1,0
     $     ,1,38))
          CALL MP_FFV1L2P0_3(PL(0,38),W(1,7),GC_5,ZERO,ZERO,PL(0,39)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_0(WL(1,0,1,38),4,COEFS,4,4,WL(1,0
     $     ,1,39))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,39),2,4,13,1,1,100
     $     ,H)
C         Coefficient construction for loop diagram with ID 19
          CALL MP_FFV1L2_1(PL(0,0),W(1,1),GC_5,MDL_MT,MDL_WT,PL(0,40)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,40))
          CALL MP_FFV1L2P0_3(PL(0,40),W(1,4),GC_5,ZERO,ZERO,PL(0,41)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,40),4,COEFS,4,4,WL(1,0
     $     ,1,41))
          CALL MP_FFV1L3_1(PL(0,41),W(1,10),GC_5,MDL_MT,MDL_WT,PL(0
     $     ,42),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,41),4,COEFS,4,4,WL(1,0
     $     ,1,42))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,42),2,4,14,1,1,101
     $     ,H)
C         Coefficient construction for loop diagram with ID 20
          CALL MP_FFV1L1_2(PL(0,0),W(1,1),GC_5,MDL_MT,MDL_WT,PL(0,43)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,43))
          CALL MP_FFV1L1P0_3(PL(0,43),W(1,3),GC_5,ZERO,ZERO,PL(0,44)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,43),4,COEFS,4,4,WL(1,0
     $     ,1,44))
          CALL MP_FFV1L3_2(PL(0,44),W(1,9),GC_5,MDL_MT,MDL_WT,PL(0,45)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,44),4,COEFS,4,4,WL(1,0
     $     ,1,45))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,45),2,4,15,1,1,102
     $     ,H)
C         Coefficient construction for loop diagram with ID 21
          CALL MP_FFV1L1_2(PL(0,43),W(1,2),GC_5,MDL_MT,MDL_WT,PL(0,46)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,43),4,COEFS,4,4,WL(1,0
     $     ,1,46))
          CALL MP_FFV1L1P0_3(PL(0,46),W(1,3),GC_5,ZERO,ZERO,PL(0,47)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_0(WL(1,0,1,46),4,COEFS,4,4,WL(1,0
     $     ,1,47))
          CALL MP_FFV1L3_2(PL(0,47),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,48)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,47),4,COEFS,4,4,WL(1,0
     $     ,1,48))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,48),3,4,16,1,1,103
     $     ,H)
C         Coefficient construction for loop diagram with ID 22
          CALL MP_FFV1L1_2(PL(0,46),W(1,8),GC_5,MDL_MT,MDL_WT,PL(0,49)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,46),4,COEFS,4,4,WL(1,0
     $     ,1,49))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,49),3,4,17,1,1,104
     $     ,H)
C         Coefficient construction for loop diagram with ID 23
          CALL MP_FFV1L2_1(PL(0,40),W(1,2),GC_5,MDL_MT,MDL_WT,PL(0,50)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,40),4,COEFS,4,4,WL(1,0
     $     ,1,50))
          CALL MP_FFV1L2_1(PL(0,50),W(1,8),GC_5,MDL_MT,MDL_WT,PL(0,51)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,50),4,COEFS,4,4,WL(1,0
     $     ,1,51))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,51),3,4,17,1,1,105
     $     ,H)
C         Coefficient construction for loop diagram with ID 24
          CALL MP_FFV1L2P0_3(PL(0,50),W(1,4),GC_5,ZERO,ZERO,PL(0,52)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_0(WL(1,0,1,50),4,COEFS,4,4,WL(1,0
     $     ,1,52))
          CALL MP_FFV1L3_1(PL(0,52),W(1,3),GC_5,MDL_MT,MDL_WT,PL(0,53)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,52),4,COEFS,4,4,WL(1,0
     $     ,1,53))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,53),3,4,18,1,1,106
     $     ,H)
C         Coefficient construction for loop diagram with ID 25
          CALL MP_VVV1L2P0_1(PL(0,44),W(1,2),GC_4,ZERO,ZERO,PL(0,54)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,44),4,COEFS,4,4,WL(1,0
     $     ,1,54))
          CALL MP_FFV1L3_2(PL(0,54),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,55)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,54),4,COEFS,4,4,WL(1,0
     $     ,1,55))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,55),3,4,19,1,1,107
     $     ,H)
C         Coefficient construction for loop diagram with ID 26
          CALL MP_VVV1L2P0_1(PL(0,0),W(1,1),GC_4,ZERO,ZERO,PL(0,56)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,56))
          CALL MP_FFV1L3_2(PL(0,56),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,57)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,56),4,COEFS,4,4,WL(1,0
     $     ,1,57))
          CALL MP_FFV1L1P0_3(PL(0,57),W(1,10),GC_5,ZERO,ZERO,PL(0,58)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_0(WL(1,0,1,57),4,COEFS,4,4,WL(1,0
     $     ,1,58))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,58),2,4,20,1,1,108
     $     ,H)
C         Coefficient construction for loop diagram with ID 27
          CALL MP_FFV1L3_1(PL(0,56),W(1,3),GC_5,MDL_MT,MDL_WT,PL(0,59)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,56),4,COEFS,4,4,WL(1,0
     $     ,1,59))
          CALL MP_FFV1L2P0_3(PL(0,59),W(1,9),GC_5,ZERO,ZERO,PL(0,60)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_0(WL(1,0,1,59),4,COEFS,4,4,WL(1,0
     $     ,1,60))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,60),2,4,21,1,1,109
     $     ,H)
C         Coefficient construction for loop diagram with ID 28
          CALL MP_FFV1L2_1(PL(0,59),W(1,2),GC_5,MDL_MT,MDL_WT,PL(0,61)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,59),4,COEFS,4,4,WL(1,0
     $     ,1,61))
          CALL MP_FFV1L2P0_3(PL(0,61),W(1,4),GC_5,ZERO,ZERO,PL(0,62)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_3_0(WL(1,0,1,61),4,COEFS,4,4,WL(1,0
     $     ,1,62))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,62),3,4,22,1,1,110
     $     ,H)
C         Coefficient construction for loop diagram with ID 29
          CALL MP_VVVV1L2P0_1(PL(0,23),W(1,1),W(1,2),GC_6,ZERO,ZERO
     $     ,PL(0,63),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,23),4,COEFS,4,4,WL(1,0
     $     ,1,63))
          CALL MP_VVVV3L2P0_1(PL(0,23),W(1,1),W(1,2),GC_6,ZERO,ZERO
     $     ,PL(0,64),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,23),4,COEFS,4,4,WL(1,0
     $     ,1,64))
          CALL MP_VVVV4L2P0_1(PL(0,23),W(1,1),W(1,2),GC_6,ZERO,ZERO
     $     ,PL(0,65),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,23),4,COEFS,4,4,WL(1,0
     $     ,1,65))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,63),1,4,7,1,1,111,H)
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,64),1,4,7,1,1,112,H)
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,65),1,4,7,1,1,113,H)
C         Coefficient construction for loop diagram with ID 30
          CALL MP_VVV1L2P0_1(PL(0,56),W(1,2),GC_4,ZERO,ZERO,PL(0,66)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,56),4,COEFS,4,4,WL(1,0
     $     ,1,66))
          CALL MP_FFV1L3_2(PL(0,66),W(1,4),GC_5,MDL_MT,MDL_WT,PL(0,67)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,66),4,COEFS,4,4,WL(1,0
     $     ,1,67))
          CALL MP_FFV1L1P0_3(PL(0,67),W(1,3),GC_5,ZERO,ZERO,PL(0,68)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_3_0(WL(1,0,1,67),4,COEFS,4,4,WL(1,0
     $     ,1,68))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,68),3,4,23,1,1,114
     $     ,H)
C         Coefficient construction for loop diagram with ID 31
          CALL MP_FFV1L3_1(PL(0,66),W(1,3),GC_5,MDL_MT,MDL_WT,PL(0,69)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,66),4,COEFS,4,4,WL(1,0
     $     ,1,69))
          CALL MP_FFV1L2P0_3(PL(0,69),W(1,4),GC_5,ZERO,ZERO,PL(0,70)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_3_0(WL(1,0,1,69),4,COEFS,4,4,WL(1,0
     $     ,1,70))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,70),3,4,24,1,1,115
     $     ,H)
C         Coefficient construction for loop diagram with ID 32
          CALL MP_VVV1L2P0_1(PL(0,0),W(1,5),GC_4,ZERO,ZERO,PL(0,71)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,71))
          CALL MP_VVV1L2P0_1(PL(0,71),W(1,8),GC_4,ZERO,ZERO,PL(0,72)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,71),4,COEFS,4,4,WL(1,0
     $     ,1,72))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,72),2,4,1,2,1,116,H)
C         Coefficient construction for loop diagram with ID 33
          CALL MP_VVV1L2P0_1(PL(0,66),W(1,8),GC_4,ZERO,ZERO,PL(0,73)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,66),4,COEFS,4,4,WL(1,0
     $     ,1,73))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,73),3,4,2,1,1,117,H)
C         Coefficient construction for loop diagram with ID 34
          CALL MP_VVVV1L2P0_1(PL(0,56),W(1,8),W(1,2),GC_6,ZERO,ZERO
     $     ,PL(0,74),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,56),4,COEFS,4,4,WL(1,0
     $     ,1,74))
          CALL MP_VVVV3L2P0_1(PL(0,56),W(1,8),W(1,2),GC_6,ZERO,ZERO
     $     ,PL(0,75),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,56),4,COEFS,4,4,WL(1,0
     $     ,1,75))
          CALL MP_VVVV4L2P0_1(PL(0,56),W(1,8),W(1,2),GC_6,ZERO,ZERO
     $     ,PL(0,76),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,56),4,COEFS,4,4,WL(1,0
     $     ,1,76))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,74),1,4,25,2,1,118
     $     ,H)
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,75),1,4,25,2,1,119
     $     ,H)
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,76),1,4,25,2,1,120
     $     ,H)
C         Coefficient construction for loop diagram with ID 35
          CALL MP_VVVV1L2P0_1(PL(0,30),W(1,8),W(1,1),GC_6,ZERO,ZERO
     $     ,PL(0,77),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,30),4,COEFS,4,4,WL(1,0
     $     ,1,77))
          CALL MP_VVVV3L2P0_1(PL(0,30),W(1,8),W(1,1),GC_6,ZERO,ZERO
     $     ,PL(0,78),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,30),4,COEFS,4,4,WL(1,0
     $     ,1,78))
          CALL MP_VVVV4L2P0_1(PL(0,30),W(1,8),W(1,1),GC_6,ZERO,ZERO
     $     ,PL(0,79),COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_0(WL(1,0,1,30),4,COEFS,4,4,WL(1,0
     $     ,1,79))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,77),1,4,26,2,1,121
     $     ,H)
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,78),1,4,26,2,1,122
     $     ,H)
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,79),1,4,26,2,1,123
     $     ,H)
C         Coefficient construction for loop diagram with ID 36
          CALL MP_VVVV1L2P0_1(PL(0,0),W(1,1),W(1,2),GC_6,ZERO,ZERO
     $     ,PL(0,80),COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,80))
          CALL MP_VVVV3L2P0_1(PL(0,0),W(1,1),W(1,2),GC_6,ZERO,ZERO
     $     ,PL(0,81),COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,81))
          CALL MP_VVVV4L2P0_1(PL(0,0),W(1,1),W(1,2),GC_6,ZERO,ZERO
     $     ,PL(0,82),COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_0(WL(1,0,1,0),4,COEFS,4,4,WL(1,0,1
     $     ,82))
          CALL MP_VVV1L2P0_1(PL(0,80),W(1,8),GC_4,ZERO,ZERO,PL(0,83)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,80),4,COEFS,4,4,WL(1,0
     $     ,1,83))
          CALL MP_VVV1L2P0_1(PL(0,81),W(1,8),GC_4,ZERO,ZERO,PL(0,84)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,81),4,COEFS,4,4,WL(1,0
     $     ,1,84))
          CALL MP_VVV1L2P0_1(PL(0,82),W(1,8),GC_4,ZERO,ZERO,PL(0,85)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,82),4,COEFS,4,4,WL(1,0
     $     ,1,85))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,83),1,4,1,2,1,124,H)
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,84),1,4,1,2,1,125,H)
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,85),1,4,1,2,1,126,H)
C         Coefficient construction for loop diagram with ID 37
          CALL MP_GHGHGL2_1(PL(0,0),W(1,5),GC_4,ZERO,ZERO,PL(0,86)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),1,COEFS,1,1,WL(1,0,1
     $     ,86))
          CALL MP_GHGHGL2_1(PL(0,86),W(1,8),GC_4,ZERO,ZERO,PL(0,87)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,86),1,COEFS,1,1,WL(1,0
     $     ,1,87))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,87),2,1,1,1,1,127,H)
C         Coefficient construction for loop diagram with ID 38
          CALL MP_GHGHGL1_2(PL(0,0),W(1,1),GC_4,ZERO,ZERO,PL(0,88)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),1,COEFS,1,1,WL(1,0,1
     $     ,88))
          CALL MP_GHGHGL1_2(PL(0,88),W(1,2),GC_4,ZERO,ZERO,PL(0,89)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,88),1,COEFS,1,1,WL(1,0
     $     ,1,89))
          CALL MP_GHGHGL1_2(PL(0,89),W(1,8),GC_4,ZERO,ZERO,PL(0,90)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,89),1,COEFS,1,1,WL(1,0
     $     ,1,90))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,90),3,1,2,1,1,128,H)
C         Coefficient construction for loop diagram with ID 39
          CALL MP_GHGHGL2_1(PL(0,0),W(1,1),GC_4,ZERO,ZERO,PL(0,91)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_0_1(WL(1,0,1,0),1,COEFS,1,1,WL(1,0,1
     $     ,91))
          CALL MP_GHGHGL2_1(PL(0,91),W(1,2),GC_4,ZERO,ZERO,PL(0,92)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_1_1(WL(1,0,1,91),1,COEFS,1,1,WL(1,0
     $     ,1,92))
          CALL MP_GHGHGL2_1(PL(0,92),W(1,8),GC_4,ZERO,ZERO,PL(0,93)
     $     ,COEFS)
          CALL MP_ML5_0_UPDATE_WL_2_1(WL(1,0,1,92),1,COEFS,1,1,WL(1,0
     $     ,1,93))
          CALL MP_ML5_0_CREATE_LOOP_COEFS(WL(1,0,1,93),3,1,2,1,1,129,H)
C         At this point, all loop coefficients needed for (QCD=6),
C          i.e. of split order ID=1, are computed.
          IF(FILTER_SO.AND.SQSO_TARGET.EQ.1) GOTO 4000
 4000     CONTINUE
          MP_LOOP_REQ_SO_DONE=.TRUE.

C         Copy the qp wfs to the dp ones as they are used to setup the
C          CT calls.
C         This needs to be done once since only the momenta of these
C          WF matters.
          IF(.NOT.DPW_COPIED) THEN
            DO I=1,NWAVEFUNCS
              DO J=1,MAXLWFSIZE+4
                DPW(J,I)=DBLE(W(J,I))
              ENDDO
            ENDDO
            DPW_COPIED=.TRUE.
          ENDIF

        ENDIF
      ENDDO

      DO I=1,3
        DO J=0,NSQUAREDSO
          ANSDP(I,J)=ANS(I,J)
        ENDDO
      ENDDO

C     Grouping of loop diagrams now done directly when creating the
C      LOOPCOEFS.

      END


MODULE traadv_mus
  USE oce
  USE trc_oce
  USE dom_oce
  USE trd_oce
  USE trdtra
  USE sbcrnf
  USE diaptr
  USE diaar5
  USE iom
  USE in_out_manager
  USE lib_mpp
  USE lbclnk
  USE lib_fortran
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: tra_adv_mus
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: upsmsk
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: xind
  LOGICAL :: l_trd
  LOGICAL :: l_ptr
  LOGICAL :: l_hst
  CONTAINS
  SUBROUTINE tra_adv_mus(kt, kit000, cdtype, p2dt, pun, pvn, pwn, ptb, pta, kjpt, ld_msc_ups)
    INTEGER, INTENT(IN   ) :: kt
    INTEGER, INTENT(IN   ) :: kit000
    CHARACTER(LEN = 3), INTENT(IN   ) :: cdtype
    INTEGER, INTENT(IN   ) :: kjpt
    LOGICAL, INTENT(IN   ) :: ld_msc_ups
    REAL(KIND = wp), INTENT(IN   ) :: p2dt
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pun, pvn, pwn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(IN   ) :: ptb
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(INOUT) :: pta
    INTEGER :: ji, jj, jk, jn
    INTEGER :: ierr
    REAL(KIND = wp) :: zu, z0u, zzwx, zw, zalpha
    REAL(KIND = wp) :: zv, z0v, zzwy, z0w
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zwx, zslpx
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zwy, zslpy
    IF (kt == kit000) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) 'tra_adv : MUSCL advection scheme on ', cdtype
      IF (lwp) WRITE(numout, FMT = *) '        : mixed up-stream           ', ld_msc_ups
      IF (lwp) WRITE(numout, FMT = *) '~~~~~~~'
      IF (lwp) WRITE(numout, FMT = *)
      ALLOCATE(xind(jpi, jpj, jpk), STAT = ierr)
      !$ACC KERNELS
      xind(:, :, :) = 1._wp
      !$ACC END KERNELS
      IF (ld_msc_ups) THEN
        ALLOCATE(upsmsk(jpi, jpj), STAT = ierr)
        !$ACC KERNELS
        upsmsk(:, :) = 0._wp
        DO jk = 1, jpkm1
          xind(:, :, jk) = 1._wp - MAX(rnfmsk(:, :) * rnfmsk_z(jk), upsmsk(:, :)) * tmask(:, :, jk)
        END DO
        !$ACC END KERNELS
      END IF
    END IF
    l_trd = .FALSE.
    l_hst = .FALSE.
    l_ptr = .FALSE.
    IF ((cdtype == 'TRA' .AND. l_trdtra) .OR. (cdtype == 'TRC' .AND. l_trdtrc)) l_trd = .TRUE.
    IF (cdtype == 'TRA' .AND. ln_diaptr) l_ptr = .TRUE.
    IF (cdtype == 'TRA' .AND. (iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. iom_use("uadv_salttr") .OR. iom_use("vadv_salttr"))) l_hst = .TRUE.
    DO jn = 1, kjpt
      !$ACC KERNELS
      zwx(:, :, jpk) = 0._wp
      zwy(:, :, jpk) = 0._wp
      DO jk = 1, jpkm1
        DO jj = 1, jpjm1
          DO ji = 1, jpim1
            zwx(ji, jj, jk) = umask(ji, jj, jk) * (ptb(ji + 1, jj, jk, jn) - ptb(ji, jj, jk, jn))
            zwy(ji, jj, jk) = vmask(ji, jj, jk) * (ptb(ji, jj + 1, jk, jn) - ptb(ji, jj, jk, jn))
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk_multi(zwx, 'U', - 1., zwy, 'V', - 1.)
      !$ACC KERNELS
      zslpx(:, :, jpk) = 0._wp
      zslpy(:, :, jpk) = 0._wp
      DO jk = 1, jpkm1
        DO jj = 2, jpj
          DO ji = 2, jpi
            zslpx(ji, jj, jk) = (zwx(ji, jj, jk) + zwx(ji - 1, jj, jk)) * (0.25 + SIGN(0.25, zwx(ji, jj, jk) * zwx(ji - 1, jj, jk)))
            zslpy(ji, jj, jk) = (zwy(ji, jj, jk) + zwy(ji, jj - 1, jk)) * (0.25 + SIGN(0.25, zwy(ji, jj, jk) * zwy(ji, jj - 1, jk)))
          END DO
        END DO
      END DO
      DO jk = 1, jpkm1
        DO jj = 2, jpj
          DO ji = 2, jpi
            zslpx(ji, jj, jk) = SIGN(1., zslpx(ji, jj, jk)) * MIN(ABS(zslpx(ji, jj, jk)), 2. * ABS(zwx(ji - 1, jj, jk)), 2. * ABS(zwx(ji, jj, jk)))
            zslpy(ji, jj, jk) = SIGN(1., zslpy(ji, jj, jk)) * MIN(ABS(zslpy(ji, jj, jk)), 2. * ABS(zwy(ji, jj - 1, jk)), 2. * ABS(zwy(ji, jj, jk)))
          END DO
        END DO
      END DO
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            z0u = SIGN(0.5, pun(ji, jj, jk))
            zalpha = 0.5 - z0u
            zu = z0u - 0.5 * pun(ji, jj, jk) * p2dt * r1_e1e2u(ji, jj) / e3u_n(ji, jj, jk)
            zzwx = ptb(ji + 1, jj, jk, jn) + xind(ji, jj, jk) * zu * zslpx(ji + 1, jj, jk)
            zzwy = ptb(ji, jj, jk, jn) + xind(ji, jj, jk) * zu * zslpx(ji, jj, jk)
            zwx(ji, jj, jk) = pun(ji, jj, jk) * (zalpha * zzwx + (1. - zalpha) * zzwy)
            z0v = SIGN(0.5, pvn(ji, jj, jk))
            zalpha = 0.5 - z0v
            zv = z0v - 0.5 * pvn(ji, jj, jk) * p2dt * r1_e1e2v(ji, jj) / e3v_n(ji, jj, jk)
            zzwx = ptb(ji, jj + 1, jk, jn) + xind(ji, jj, jk) * zv * zslpy(ji, jj + 1, jk)
            zzwy = ptb(ji, jj, jk, jn) + xind(ji, jj, jk) * zv * zslpy(ji, jj, jk)
            zwy(ji, jj, jk) = pvn(ji, jj, jk) * (zalpha * zzwx + (1. - zalpha) * zzwy)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk_multi(zwx, 'U', - 1., zwy, 'V', - 1.)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            pta(ji, jj, jk, jn) = pta(ji, jj, jk, jn) - (zwx(ji, jj, jk) - zwx(ji - 1, jj, jk) + zwy(ji, jj, jk) - zwy(ji, jj - 1, jk)) * r1_e1e2t(ji, jj) / e3t_n(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (l_trd) THEN
        CALL trd_tra(kt, cdtype, jn, jptra_xad, zwx, pun, ptb(:, :, :, jn))
        CALL trd_tra(kt, cdtype, jn, jptra_yad, zwy, pvn, ptb(:, :, :, jn))
      END IF
      IF (l_ptr) CALL dia_ptr_hst(jn, 'adv', zwy(:, :, :))
      IF (l_hst) CALL dia_ar5_hst(jn, 'adv', zwx(:, :, :), zwy(:, :, :))
      !$ACC KERNELS
      zwx(:, :, 1) = 0._wp
      zwx(:, :, jpk) = 0._wp
      DO jk = 2, jpkm1
        zwx(:, :, jk) = tmask(:, :, jk) * (ptb(:, :, jk - 1, jn) - ptb(:, :, jk, jn))
      END DO
      zslpx(:, :, 1) = 0._wp
      DO jk = 2, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zslpx(ji, jj, jk) = (zwx(ji, jj, jk) + zwx(ji, jj, jk + 1)) * (0.25 + SIGN(0.25, zwx(ji, jj, jk) * zwx(ji, jj, jk + 1)))
          END DO
        END DO
      END DO
      DO jk = 2, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zslpx(ji, jj, jk) = SIGN(1., zslpx(ji, jj, jk)) * MIN(ABS(zslpx(ji, jj, jk)), 2. * ABS(zwx(ji, jj, jk + 1)), 2. * ABS(zwx(ji, jj, jk)))
          END DO
        END DO
      END DO
      DO jk = 1, jpk - 2
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            z0w = SIGN(0.5, pwn(ji, jj, jk + 1))
            zalpha = 0.5 + z0w
            zw = z0w - 0.5 * pwn(ji, jj, jk + 1) * p2dt * r1_e1e2t(ji, jj) / e3w_n(ji, jj, jk + 1)
            zzwx = ptb(ji, jj, jk + 1, jn) + xind(ji, jj, jk) * zw * zslpx(ji, jj, jk + 1)
            zzwy = ptb(ji, jj, jk, jn) + xind(ji, jj, jk) * zw * zslpx(ji, jj, jk)
            zwx(ji, jj, jk + 1) = pwn(ji, jj, jk + 1) * (zalpha * zzwx + (1. - zalpha) * zzwy) * wmask(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (ln_linssh) THEN
        IF (ln_isfcav) THEN
          !$ACC KERNELS
          DO jj = 1, jpj
            DO ji = 1, jpi
              zwx(ji, jj, mikt(ji, jj)) = pwn(ji, jj, mikt(ji, jj)) * ptb(ji, jj, mikt(ji, jj), jn)
            END DO
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          zwx(:, :, 1) = pwn(:, :, 1) * ptb(:, :, 1, jn)
          !$ACC END KERNELS
        END IF
      END IF
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            pta(ji, jj, jk, jn) = pta(ji, jj, jk, jn) - (zwx(ji, jj, jk) - zwx(ji, jj, jk + 1)) * r1_e1e2t(ji, jj) / e3t_n(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (l_trd) CALL trd_tra(kt, cdtype, jn, jptra_zad, zwx, pwn, ptb(:, :, :, jn))
    END DO
  END SUBROUTINE tra_adv_mus
END MODULE traadv_mus


c     ****************************************************************
c     *                                                              *
c     *                    f-90 data modules:                        *
c     *                     elem_block_data                          *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 9/15/2019 rhd              *
c     *                                                              *
c     *     define the data structures for element data stored       *
c     *     in blocks                                                *
c     *                                                              *
c     ****************************************************************
c
c
c
      module elem_block_data
c     ----------------------
c
c
c      strategies:
c
c         for older data structures
c         because some f90 compilers cannot properly build code to
c         use the "allocated" intrinsic functions on all types of
c         data types, we keep separate allocatable integer vectors
c         to indicate which blocks are actually allocated for this
c         analysis.
c
c         compilers can now handle allocatable types as rows of
c         user-defeined types
c
        type :: blocks_ptr_type
          double precision, dimension(:), pointer :: ptr
        end type
c
        type :: blocks_allocatable_type
          double precision, dimension(:), allocatable :: vector
        end type
c
        type :: array_blocks_ptr_type
          double precision, dimension(:,:), pointer :: ptr
        end type
c
        type :: int_blocks_ptr_type
              integer, dimension(:,:), pointer :: ptr
        end type
c
c                cdest, edest indexes for blocks
c               --------------------------------
c
        type (int_blocks_ptr_type), save, dimension(:),
     &         allocatable :: cdest_blocks, edest_blocks
        integer, dimension (:), allocatable, save :: cdest_blk_list,
     &                                               edest_blk_list
c
c                global vectors of element stress data
c               --------------------------------------
c
        type (blocks_ptr_type), save, dimension(:),
     &         allocatable :: urcs_n_blocks, urcs_n1_blocks
        integer, dimension (:), allocatable, save :: urcs_blk_list
c
c                global vectors of element strain data
c               --------------------------------------
c
        type (blocks_ptr_type), save, dimension(:),
     &         allocatable :: eps_n_blocks, eps_n1_blocks
        integer, dimension (:), allocatable, save :: eps_blk_list

      type :: dgradnisblks
        double precision, allocatable, dimension(:,:) ::
     &                    W_plastic_nis_block
      end type
      type(dgradnisblks), save, allocatable,
     &                            dimension(:) :: initial_state_data

c
c               element rotation matrices at Gauss points for finite
c               strains
c               ----------------------------------------------------
c
        type (blocks_ptr_type), save, dimension(:),
     &         allocatable :: rot_n_blocks, rot_n1_blocks
        integer, dimension (:), allocatable, save :: rot_blk_list
c
c               material dependent element history data in blocks
c               -------------------------------------------------
c
        type (blocks_ptr_type), save, dimension(:),
     &         allocatable :: history_blocks, history1_blocks
        integer, dimension (:), allocatable, save :: history_blk_list
c
c               material dependent [D] at each integration point in element
c               block form. internalley we call [D] "cep".
c               store 21 terms of symmetric part. for cohesive, store
c               symmetric part of 3x3
c               ----------------------------------------------------------
c
        type (blocks_allocatable_type), save, dimension(:),
     &         allocatable :: cep_blocks
        integer, dimension (:), allocatable, save :: cep_blk_list
c
c               number of gauss points for elements in blocks
c               ---------------------------------------------
c
        integer, dimension (:), allocatable, save :: gausspts_blk_list
c
c                global vectors of element volumes
c               ----------------------------------
c
        type (blocks_ptr_type), save, dimension(:),
     &         allocatable :: element_vol_blocks
c
c               element mass matrices
c               ---------------------
c
        type (array_blocks_ptr_type), save, dimension(:),
     &         allocatable :: mass_blocks
c
c               element stiffness
c               -----------------
c
        type (array_blocks_ptr_type), save, dimension(:),
     &         allocatable :: estiff_blocks
c
c               element internal forces
c               -----------------------
c
        type (array_blocks_ptr_type), save, dimension(:),
     &         allocatable :: einfvec_blocks
c
c               solid-interface connections for nonlocal
c               ----------------------------------------
c
      type :: interface_solid_connections
        integer,  allocatable, dimension(:,:) :: list
      end type
      type(interface_solid_connections), save, allocatable,
     &           dimension(:) :: solid_interface_lists
c
c
c               nonlocal material state variables.
c               ---------------------------------
c
c               created for analyses with interface-cohesive elements.
c               values computed by material models for solids to be
c               shared with cohesive material models
c
c
      logical, dimension (:), allocatable, save :: nonlocal_flags
      type :: vec_nonlocal
      double precision,
     &    allocatable, dimension(:) ::state_values
      end type
      type(vec_nonlocal), save, allocatable,
     &     dimension(:) :: nonlocal_data_n, nonlocal_data_n1
c
        intrinsic allocated
c
      end module


c Copyright (c) 2014-2015 The Regents of the University of California.
c All Rights Reserved.
c
c Portions of the code Copyright (c) 2009-2011 Open Source Medical
c Software Corporation, University of California, San Diego.
c
c Portions of the code Copyright (c) 2000-2007, Stanford University,
c     Rensselaer Polytechnic Institute, Kenneth E. Jansen,
c     Charles A. Taylor.
c
c  See SimVascular Acknowledgements file for additional
c  contributors to the source code.
c
c  Redistribution and use in source and binary forms, with or without
c  modification, are permitted provided that the following conditions
c  are met:
c
c  Redistributions of source code must retain the above copyright notice,
c  this list of conditions and the following disclaimer.
c  Redistributions in binary form must reproduce the above copyright
c  notice, this list of conditions and the following disclaimer in the
c  documentation and/or other materials provided with the distribution.
c  Neither the name of the Stanford University or Rensselaer Polytechnic
c  Institute nor the names of its contributors may be used to endorse or
c  promote products derived from this software without specific prior
c  written permission.
c
c  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
c  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
c  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
c  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
c  COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
c  INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
c  BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
c  OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
c  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
c  OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF
c  THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
c  DAMAGE.
c
c

!*******************************************
!      ramg Interface
!      Interface for libLES
!*******************************************
      subroutine ramg_interface(
     &           colm,rowp,lhsK,lhsP,flowDiag,
     &           mcgR,mcgZ,
     &           ilwork,BC,iBC,iper
     &           )
c$$$      use ramg_data
      include "global.h"
      include "mpif.h"
      include "common_blocks/workfc.h"
      include "common_blocks/conpar.h"
      include "common_blocks/fronts.h"
      include "common_blocks/genpar.h"
C
C     Argument variables
      REAL*8 flowDiag
      integer,intent(in),dimension(nshg+1)             :: colm
      integer,intent(in),dimension(nnz_tot)            :: rowp
      real(kind=8),intent(in),dimension(9,nnz_tot)     :: lhsK
      real(kind=8),intent(in),dimension(4,nnz_tot)     :: lhsP
      real(kind=8),intent(in),dimension(nshg)          :: mcgR
      real(kind=8),intent(inout),dimension(nshg)       :: mcgZ
      integer, intent(in), dimension(nlwork)           :: ilwork
      integer, intent(in),dimension(nshg)              :: iBC,iper
      real(kind=8),intent(in),dimension(nshg,ndofBC)   :: BC

          mcgZ = mcgR
          write (*,*) myrank,' preconditioning ppe'
      end subroutine ramg_interface


!
!  Copyright 2019-2020 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.
!
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120-------130
module calc_jxyz_plusu_sub

  implicit none

  private
  public :: calc_jxyz_plusu

contains

  subroutine calc_jxyz_plusu(pp,ppg,system,alx,aly,alz,lx,ly,lz,nl,mx,my,mz,ml,hx,hy,hz,al0,matrix_A0)
    use salmon_global,only : natom,kion,iperiodic
    use structures,only : s_pp_info,s_pp_grid,s_dft_system
    implicit none
    type(s_pp_info) :: pp
    type(s_pp_grid) :: ppg
    type(s_dft_system),intent(in) :: system
    real(8),intent(in) :: alx,aly,alz
    integer,intent(in) :: nl,ml
    integer,intent(in) :: lx(nl),ly(nl),lz(nl)
    integer,intent(in) :: mx(ml),my(ml),mz(ml)
    real(8),intent(in) :: hx,hy,hz
    real(8),intent(in),optional :: al0(3,3),matrix_A0(3,3)
    integer :: a,i,ik,ix,iy,iz,j
    integer :: nc1,nc2,nc3
    real(8) :: tmpx,tmpy,tmpz
    real(8) :: r,x,y,z,u,v,w
    real(8) :: rshift(3),matrix_a(3,3),rr(3),al(3,3)

    matrix_a = 0.0d0
    matrix_a(1,1) = 1.0d0
    matrix_a(2,2) = 1.0d0
    matrix_a(3,3) = 1.0d0
    if ( present(matrix_A0) ) matrix_a = matrix_A0

    al = 0.0d0
    al(1,1) = alx
    al(2,2) = aly
    al(3,3) = alz
    if ( present(al0) ) al = al0

    if( iperiodic == 0 )then
      nc1=0
      nc2=0
      nc3=0
    else if( iperiodic == 3 )then
      r=maxval( pp%rps_ao )
      nc1=nint(r/alx); if ( nc1*alx < r ) nc1=nc1+1
      nc2=nint(r/aly); if ( nc2*aly < r ) nc2=nc2+1
      nc3=nint(r/alz); if ( nc3*alz < r ) nc3=nc3+1
    end if

    if( iperiodic == 0 )then
      if( mod(lx(nl)-lx(1)+1,2) == 1 )then
        rshift(1)=0.0d0
      else
        rshift(1)=-0.5d0*Hx
      end if
      if( mod(ly(nl)-ly(1)+1,2) == 1 )then
        rshift(2)=0.0d0
      else
        rshift(2)=-0.5d0*Hy
      end if
      if( mod(lz(nl)-lz(1)+1,2) == 1 )then
        rshift(3)=0.0d0
      else
        rshift(3)=-0.5d0*Hz
      end if
    else if( iperiodic == 3 )then
      rshift(1)=-Hx
      rshift(2)=-Hy
      rshift(3)=-Hz
    end if

    do a=1,natom
      ik=kion(a)
      j=0
      do ix=-nc1,nc1
      do iy=-nc2,nc2
      do iz=-nc3,nc3
        rr(1) = ix*al(1,1) + iy*al(1,2) + iz*al(1,3)
        rr(2) = ix*al(2,1) + iy*al(2,2) + iz*al(2,3)
        rr(3) = ix*al(3,1) + iy*al(3,2) + iz*al(3,3)
        tmpx = system%Rion(1,a)+ rr(1)
        tmpy = system%Rion(2,a)+ rr(2)
        tmpz = system%Rion(3,a)+ rr(3)
        do i=1,ml
          u = mx(i)*hx + rshift(1)
          v = my(i)*hy + rshift(2)
          w = mz(i)*hz + rshift(3)
          rr(1) = u*matrix_a(1,1) + v*matrix_a(1,2) + w*matrix_a(1,3)
          rr(2) = u*matrix_a(2,1) + v*matrix_a(2,2) + w*matrix_a(2,3)
          rr(3) = u*matrix_a(3,1) + v*matrix_a(3,2) + w*matrix_a(3,3)
          x = rr(1) - tmpx
          y = rr(2) - tmpy
          z = rr(3) - tmpz
          r = sqrt(x*x+y*y+z*z)
          if( r < pp%rps_ao(ik) )then
            j=j+1
            if( j <= ppg%nps_ao )then
              ppg%jxyz_ao(1,j,a)=mx(i)
              ppg%jxyz_ao(2,j,a)=my(i)
              ppg%jxyz_ao(3,j,a)=mz(i)
              ppg%jxx_ao( j,a)=ix
              ppg%jyy_ao( j,a)=iy
              ppg%jzz_ao( j,a)=iz
              ppg%rxyz_ao(1,j,a) = x
              ppg%rxyz_ao(2,j,a) = y
              ppg%rxyz_ao(3,j,a) = z
            else

            end if
          end if
        end do
      end do
      end do
      end do
      ppg%mps_ao(a)=j
    end do

  end subroutine calc_jxyz_plusu

end module calc_jxyz_plusu_sub


c
c
c     ##############################################################
c     ##  COPYRIGHT (C) 2010 by Chuanjie Wu & Jay William Ponder  ##
c     ##                   All Rights Reserved                    ##
c     ##############################################################
c
c     #################################################################
c     ##                                                             ##
c     ##  program torsfit  --  fit torsional force field parameters  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "torsfit" refines torsional force field parameters based on
c     a quantum mechanical potential surface and analytical gradient
c
c
      program torsfit
      implicit none
      include 'sizes.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      integer i,length
      integer torbnd(10)
      logical exist,query
      character*120 record
      character*120 string
      character*120 xyzfile
c
c
c     get the Cartesian coordinates and connectivity info
c
      call initial
      call getxyz
      xyzfile = filename
      length = leng
c
c     get structure and vibrational data from Gaussian output
c
      call getkey
      call mechanic
c
c     choose the first torsion based on the center bond atoms
c
      do i = 1, 10
         torbnd(i) = 0
      end do
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=10,end=10)  torbnd(1),torbnd(2)
         query = .false.
      end if
   10 continue
      if (query) then
         do while (torbnd(1).eq.0 .or. torbnd(2).eq.0)
            write (iout,20)
   20       format (/,' Enter Central Atoms of the 1st Torsion : ',$)
            read (input,*,err=30,end=30)  torbnd(1),torbnd(2)
   30       continue
         end do
      end if
c
c     choose the second torsion based on the center bond atoms
c
      query = .true.
      call nextarg (string,exist)
      if (exist) then
         read (string,*,err=40,end=40)  torbnd(3),torbnd(4)
         query = .false.
      end if
   40 continue
      if (query) then
         write(iout,50)
   50    format (/,' Enter Central Atoms of the 2nd Torsion',
     &              ' [Optional, <CR>=None] : ',$)
         read (input,60,err=70,end=70)  record
   60    format (a120)
         read (record,*,err=70,end=70)  torbnd(3),torbnd(4)
   70    continue
      end if
c
c     fit the torsional parameters based on potential surface
c
      call fittors (torbnd)
c
c     perform any final tasks before program exit
c
      call final
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine fittors  --  torsional parameter refinement  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "fittors" refines torsion parameters based on a quantum
c     mechanical optimized energy surface
c
c
      subroutine fittors (torbnd)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'atmtyp.i'
      include 'files.i'
      include 'inform.i'
      include 'iounit.i'
      include 'keys.i'
      include 'ktorsn.i'
      include 'kgeoms.i'
      include 'math.i'
      include 'output.i'
      include 'potent.i'
      include 'qmstuf.i'
      include 'scales.i'
      include 'tors.i'
      include 'usage.i'
      integer maxfit,maxconf
      parameter (maxfit=12)
      parameter (maxconf=500)
      integer i,j,k,ii,jj,kk
      integer ia,ib,ic,id
      integer ita,itb,itc,itd
      integer itmpa,itmpb,otfix
      integer ntorfit,ntorcrs
      integer nconf,size
      integer oldleng,oldnkey
      integer istep,maxstep
      integer nvxx,ivxx
      integer ikey,nvar
      integer freeunit
      integer trimtext
      integer torbnd(*)
      integer ctorid(maxfit)
      integer ftorid(maxfit)
      integer tflg(maxfit)
      integer torcrs(4,maxfit)
      integer cflg(9*maxfit)
      integer refconf(maxconf)
      real*8 tmpa,tmpb,tv,vcon
      real*8 eqmmin,emmmin
      real*8 rms,zrms,avedl
      real*8 minimum,grdmin
      real*8 energy,geometry
      real*8 vxx(6*maxfit)
      real*8 vxxl(6*maxfit)
      real*8 eqm(maxconf)
      real*8 emm(maxconf)
      real*8 erqm(maxconf)
      real*8 ermm(maxconf)
      real*8 delte(maxconf)
      real*8 fwt(maxconf)
      real*8 torf(maxconf)
      real*8, allocatable :: xx(:)
      real*8 tord(6*maxfit,6*maxfit)
      real*8 mata(6*maxfit,6*maxfit)
      real*8 ftv(maxconf,maxfit)
      real*8 rftv(maxconf,maxfit)
      real*8 coeff(maxconf,6*maxfit)
      real*8 ctv(maxconf,9*maxfit)
      logical done
      logical vflg(6,maxfit)
      logical confvisited(maxconf)
      character*4 pa,pb,pc,pd
      character*16 kft(maxfit)
      character*16 kct(9*maxfit)
      character*120 record
      character*120 keyfile
      character*120 oldfilename
      character*120, allocatable :: oldkeyline(:)
      external torfit1
      external optsave
c
c
c     set initial values
c
      ntorfit = 0
      ntorcrs = 0
      otfix = ntfix
      istep = 0
      tv = 0.0d0
      vcon = 0.5d0
      do i = 1, maxfit
         ftorid(i) = 0
         tflg(i) = 0
         do j = 1, 6
            vflg(j,i) = .false.
         end do
      end do
      do i = 1, 6*maxfit
         vxx(i) = 0.0d0
         vxxl(i) = 0.1d0
         avedl = 0.0d0
         do j = 1, 6*maxfit
            tord(i,j) = 0.0d0
         end do
      end do
      do i = 1, 9*maxfit
         cflg(i) = 0
      end do
      do i = 1, maxconf
         fwt(i) = 1.0d0
         torf(i) = 0.0d0
         confvisited(i) = .false.
      end do
      do i = 1, maxconf
         do j = 1, 6*maxfit
            coeff(i,j) = 0.0d0
         end do
         refconf = 0
      end do
      grdmin = 0.01
      if (torbnd(1) .gt. torbnd(2)) then
         itmpa = torbnd(1)
         torbnd(1) = torbnd(2)
         torbnd(2) = itmpa
      end if
c
c     perform dynamic allocation of some local arrays
c
      allocate (oldkeyline(nkey))
c
c     store the information from the keyfile
c
      oldfilename = filename
      oldleng = leng
      oldnkey = nkey
      do i = 1, nkey
         oldkeyline(i) = keyline(i)
      end do
c
c     check all the torsions cross the two center bond atoms
c
      write (iout,10)
   10 format (/,' Torsions Crossing the Central Bond :',/)
      do i = 1, ntors
         ia = itors(1,i)
         ib = itors(2,i)
         ic = itors(3,i)
         id = itors(4,i)
         itmpa = ib
         itmpb = ic
         if (itmpa .gt. itmpb) then
            j = itmpa
            itmpa = itmpb
            itmpb = j
         end if
         if ((torbnd(1).eq.itmpa .and. torbnd(2).eq.itmpb) .or.
     &       (torbnd(3).eq.itmpa .and. torbnd(4).eq.itmpb)) then
            ntorcrs = ntorcrs + 1
            torcrs(1,ntorcrs) = ia
            torcrs(2,ntorcrs) = ib
            torcrs(3,ntorcrs) = ic
            torcrs(4,ntorcrs) = id
            ctorid(ntorcrs) = i
            write (iout,20)  ntorcrs,ia,name(ia),ib,name(ib),
     &                       ic,name(ic),id,name(id)
   20       format (' Torsion',i5,' :',3x,4(i6,'-',a3))
         end if
      end do
c
c     choose the specific torsions for fitting
c
      write (iout,30)
   30 format (/,' Choose Torsions for Fitting from Above List :  ',$)
      read (input,40,err=50,end=50)  record
   40 format (a120)
   50 continue
      read (record,*,err=60,end=60)  (ftorid(i),i=1,ntorcrs)
   60 continue
c
c     count the torsions to be fitted
c
      do i = 1, ntorcrs
         if (ftorid(i) .gt. 0)  ntorfit = ntorfit + 1
      end do
c
c     get the number of conformations for fitting
c
      write (iout,70)
   70 format (/,' Enter Total Number of Conformations :  ',$)
      read (input,*,err=80,end=80)  nconf
   80 continue
c
c     read the QM coordinates and conformations energies
c
      do i = 1, nconf
         call readgau
         write (iout,90)  i
   90    format (/ ,' Finished Reading Conformation',i4)
         do j = 1, n
            x(j) = gx(j)
            y(j) = gy(j)
            z(j) = gz(j)
         end do
         call makeref (i)
         eqm(i) = egau
      end do
c
c     calculate the relative QM conformational energies
c
      eqmmin = eqm(1)
      do i = 2, nconf
         if (eqm(i) .lt. eqmmin)  eqmmin = eqm(i)
      end do
      write (iout,100)
  100 format ()
      do i = 1, nconf
         erqm(i) = eqm(i) - eqmmin
         write (iout,110)  i,erqm(i)
  110    format (' Relative Conformational Energy (QM)',i8,f12.4,
     &              ' Kcal/mole')
      end do
c
c     get fitting torsion type (atom classes)
c
      do i = 1, ntorfit
         j = ftorid(i)
         k = ctorid(j)
         ia = itors(1,k)
         ib = itors(2,k)
         ic = itors(3,k)
         id = itors(4,k)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (itb .le. itc) then
            kft(i) = pa//pb//pc//pd
         else
            kft(i) = pd//pc//pb//pa
         end if
      end do
c
c     get all the cross torsion types
c
      do i = 1, ntorcrs
         k = ctorid(i)
         ia = itors(1,k)
         ib = itors(2,k)
         ic = itors(3,k)
         id = itors(4,k)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         size = 4
         call numeral (ita,pa,size)
         call numeral (itb,pb,size)
         call numeral (itc,pc,size)
         call numeral (itd,pd,size)
         if (itb .le. itc) then
            kct(i) = pa//pb//pc//pd
         else
            kct(i) = pd//pc//pb//pa
         end if
      end do
c
c     initialize the torsion and geometry restrain parameters
c
      write (iout,120)
  120 format (/,' Initial Torsional Parameters:',/)
      nvxx = 0
      do i = 1, ntorfit
         j = ftorid(i)
         k = ctorid(j)
         done = .false.
         tflg(i) = 0
         ia = itors(1,k)
         ib = itors(2,k)
         ic = itors(3,k)
         id = itors(4,k)
         ita = class(ia)
         itb = class(ib)
         itc = class(ic)
         itd = class(id)
         write (iout,130)  ita,itb,itc,itd,tors1(1,k),tors2(1,k),
     &                     tors3(1,k),tors4(1,k),tors5(1,k),tors6(1,k)
  130    format (' torsion ',4i4,6f8.3)
         do ii = 1, i-1
            jj = ftorid(ii)
            kk = ctorid(jj)
            if (kft(i) .eq. kft(ii)) then
               done = .true.
               tflg(i) = ii
               goto 150
            end if
         end do
         do ii = 1, ntorcrs
            if (kct(ii).eq.kft(i) .and. ii.ne.j)  cflg(ii) = j
         end do
         if (abs(tors1(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors1(1,k)
            vflg(1,i) = .true.
         end if
         tors1(1,k) = 0.0d0
         tors1(2,k) = 0.0d0
         if (abs(tors2(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors2(1,k)
            vflg(2,i) = .true.
         end if
         tors2(1,k) = 0.0d0
         tors2(2,k) = 180.0d0
         if (abs(tors3(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors3(1,k)
            vflg(3,i) = .true.
         end if
         tors3(1,k) = 0.0d0
         tors3(2,k) = 0.0d0
         if (abs(tors4(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors4(1,k)
            vflg(4,i) = .true.
         end if
         tors4(1,k) = 0.0d0
         tors4(2,k) = 180.0d0
         if (abs(tors5(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors5(1,k)
            vflg(5,i) = .true.
         end if
         tors5(1,k) = 0.0d0
         tors5(2,k) = 0.0d0
         if (abs(tors6(1,k)) .gt. 0.0d0) then
            nvxx = nvxx +1
            vxx(nvxx) = tors6(1,k)
            vflg(6,i) = .true.
         end if
         tors6(1,k) = 0.0d0
         tors6(2,k) = 180.0d0
         ntfix = ntfix+1
         itfix(1,ntfix) = ia
         itfix(2,ntfix) = ib
         itfix(3,ntfix) = ic
         itfix(4,ntfix) = id
         tfix(1,ntfix) = 5.0d0
         write (iout,140)  ia,ib,ic,id
  140    format (' Fixed Torsion',3x,4i6)
  150    continue
      end do
c
c     print torsion flags (check duplicated torsion types)
c
      do i = 1, ntorfit
         write (iout,160)  i,tflg(i)
  160    format (/,' Fitting Torsion Number',i5,5x,'Flag',i5)
         do j = 1, 6
            write (iout,170)  i,j,vflg(j,i)
  170       format (' Variable',2i4,5x,'Variable Flag',l5)
         end do
      end do
c
c     print torsion flags for all the torsions across the bond
c
      write (iout,180)
  180 format (/,' All the Torsions Across the Bond :')
      do i = 1, ntorcrs
         k = ctorid(i)
         if (cflg(i) .gt. 0) then
            tors1(1,k) = 0.0d0
            tors2(1,k) = 0.0d0
            tors3(1,k) = 0.0d0
            tors4(1,k) = 0.0d0
            tors5(1,k) = 0.0d0
            tors6(1,k) = 0.0d0
         end if
         write (iout,190)  i,cflg(i)
  190    format (' Fitting Torsion Number',i5,5x,'Flag',i5)
      end do
c
c     add one constant variable
c
      nvxx = nvxx + 1
      vxx(nvxx) = vcon
c
c     get initial energy difference
c
      do i = 1, nconf
         call getref (i)
         kk = 0
         do j = 1, ntorfit
            k = ftorid(j)
            ia = torcrs(1,k)
            ib = torcrs(2,k)
            ic = torcrs(3,k)
            id = torcrs(4,k)
            ftv(i,j) = geometry (ia,ib,ic,id)
            write (iout,200)  i,j,ftv(i,j)
  200       format (' Fitting Torsion Value',2i5,f12.4)
            if (tflg(j) .eq. 0) then
               kk = kk+1
               tfix(2,otfix+kk) = ftv(i,j)
               tfix(3,otfix+kk) = tfix(2,otfix+kk)
            end if
         end do
         do k = 1, ntorcrs
            ia = torcrs(1,k)
            ib = torcrs(2,k)
            ic = torcrs(3,k)
            id = torcrs(4,k)
            ctv(i,k) = geometry (ia,ib,ic,id)
         end do
c
c     perform dynamic allocation of some local arrays
c
         allocate (xx(3*nuse))
c
c     scale the coordinates of each active atom
c
         nvar = 0
         do j = 1, n
            if (use(j)) then
               nvar = nvar + 1
               scale(nvar) = 12.0d0
               xx(nvar) = x(j) * scale(nvar)
               nvar = nvar + 1
               scale(nvar) = 12.0d0
               xx(nvar) = y(j) * scale(nvar)
               nvar = nvar + 1
               scale(nvar) = 12.0d0
               xx(nvar) = z(j) * scale(nvar)
            end if
         end do
c
c     make the call to the optimization routine
c
         write (iout,210)  i
  210    format (/,' Minimizing Structure',i6)
         coordtype = 'CARTESIAN'
         use_geom = .true.
         grdmin = 0.01d0
         iwrite = 0
         iprint = 0
         call lbfgs (nvar,xx,minimum,grdmin,torfit1,optsave)
c
c     unscale the final coordinates for active atoms
c
         nvar = 0
         do j = 1, n
            if (use(j)) then
               nvar = nvar + 1
               x(j) = xx(nvar) / scale(nvar)
               nvar = nvar + 1
               y(j) = xx(nvar) / scale(nvar)
               nvar = nvar + 1
               z(j) = xx(nvar) / scale(nvar)
            end if
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (xx)
c
c     set the energy value for the current minimum
c
         emm(i) = energy ()
      end do
c
c     calculate relative value for each torsional angle
c
      do i = 1, nconf
         do j = 1, ntorfit
            rftv(i,j) = ftv(i,j) - ftv(i,1)
         end do
      end do
c
c     calculate the relative MM energies
c
      emmmin = emm(1)
      do i = 2, nconf
         if (emm(i) .lt. emmmin)  emmmin = emm(i)
      end do
c
c     calculate the energy difference and RMS
c
      rms = 0.0d0
      zrms = 0.0d0
      write (iout,220)
  220 format ()
      do i = 1, nconf
         ermm (i) = emm(i) - emmmin
         delte (i) = erqm (i) - ermm(i)
         rms = rms + delte(i)*delte(i)
         write (iout,230)  i,ermm(i)
  230    format (' Relative Conformational Energy (MM)',i8,f12.4,
     &              ' Kcal/mole')
      end do
      rms = sqrt(rms/dble(nconf))
      zrms = rms
      write (iout,240)  rms
  240 format (/,' Energy RMS Difference :',8x,f12.4)
c
c     calculate the weights
c
c     do i = 1, nconf
c        do j = 1, nconf
c           if (.not. confvisited(j)) then
c              tmpa = ftv(j,1)
c              itmpa = j
c              confvisited(j) = .true.
c              goto 241
c           end if
c        end do
c 241    continue
c        do j = 1, nconf
c           if (ftv(j,1).lt.tmpa .and. .not.confvisited(j)) then
c              confvisited(itmpa) = .false.
c              itmpa = j
c              tmpa = ftv(j,1)
c           end if
c        end do
c        refconf(itmpa) = i
c        confvisited(itmpa) = .true.
c        write (iout,242)  itmpa,refconf(itmpa)
c 242    format (i8,' <===> ',i8)
c     end do
      if (nconf .gt. 1 .and. torbnd(3) .eq. 0) then
         if ((ftv(nconf,1)+180.0d0) .lt. 1.0d0
     &           .and. ftv(nconf-1,1) .gt. 0.0d0)
     &       ftv(nconf,1) = 180.0d0
         tmpa = erqm(2) - erqm(1)
         tmpb = (ftv(2,1)-ftv(1,1)) / radian
         fwt(1) = 1.0d0 / sqrt(1.0d0+(tmpa/tmpb)**2)
         if (nconf .gt. 2) then
            do i = 2, nconf-1
               tmpa = erqm(i+1) - erqm(i-1)
               tmpb = (ftv(i+1,1) - ftv(i-1,1))/radian
               fwt(i) = 1.0d0 / sqrt(1.0d0+(tmpa/tmpb)**2)
            end do
         end if
         tmpa = erqm(nconf) - erqm(nconf-1)
         tmpb = (ftv(nconf,1) - ftv(nconf-1,1))/radian
         fwt(nconf) = 1.0d0 / sqrt(1.0d0+(tmpa/tmpb)**2)
      end if
      write (iout,250)
  250 format ()
      do i = 1, nconf
         write (iout,260)  i,fwt(i)
  260    format (' Conformation',i5,5x,'Weight',f8.4)
      end do
c
c     set initial values for torsions to be fitted
c
      ivxx = 0
      do i = 1, ntorfit
         j = ftorid(i)
         k = ctorid(j)
         do ii = 1, 6
            if (vflg(ii,i) .and. tflg(i).eq.0) then
               ivxx = ivxx + 1
               if (ii .eq. 1) then
                  tors1(1,k) = vxx(ivxx)
               else if (ii .eq. 2) then
                  tors2(1,k) = vxx(ivxx)
               else if (ii .eq. 3) then
                  tors3(1,k) = vxx(ivxx)
               else if (ii .eq. 4) then
                  tors4(1,k) = vxx(ivxx)
               else if (ii .eq. 5) then
                  tors5(1,k) = vxx(ivxx)
               else if (ii .eq. 6) then
                  tors6(1,k) = vxx(ivxx)
               end if
               do jj = 1, ntorfit
                  kk = ctorid(ftorid(jj))
                  if (tflg(jj) .eq. i) then
                     if (ii .eq. 1) then
                        tors1(1,kk) = vxx(ivxx)
                     else if (ii .eq. 2) then
                        tors2(1,kk) = vxx(ivxx)
                     else if (ii .eq. 3) then
                        tors3(1,kk) = vxx(ivxx)
                     else if (ii .eq. 4) then
                        tors4(1,kk) = vxx(ivxx)
                     else if (ii .eq. 5) then
                        tors5(1,kk) = vxx(ivxx)
                     else if (ii .eq. 6) then
                        tors6(1,kk) = vxx(ivxx)
                     end if
                  end if
               end do
            end if
         end do
         ivxx = ivxx + 1
         vcon = vxx(ivxx)
      end do
c
c     fitting the torsion parameters
c
      write (iout,270)
  270 format ()
      maxstep = 1
      avedl = 0.5d0
      do while (avedl.gt.0.1d0 .and. istep.lt.maxstep)
         do i = 1, nconf
            ivxx = 0
            torf(i) = 0.0d0
            do j = 1, ntorfit
               jj = ftorid(j)
               kk = ctorid(jj)
               ia = itors(1,kk)
               ib = itors(2,kk)
               ic = itors(3,kk)
               id = itors(4,kk)
               ita = class(ia)
               itb = class(ib)
               itc = class(ic)
               itd = class(id)
               tv = ftv(i,j) / radian
               tmpa = tors1(1,kk)*(1+cos(tv))
     &                    + tors2(1,kk)*(1-cos(2*tv))
     &                    + tors3(1,kk)*(1+cos(3*tv))
     &                    + tors4(1,kk)*(1-cos(4*tv))
     &                    + tors5(1,kk)*(1+cos(5*tv))
     &                    + tors6(1,kk)*(1-cos(6*tv))
               torf(i) = torf(i) + 0.5*tmpa
               do ii = 1, 6
                  if (vflg(ii,j) .and. tflg(j).eq.0) then
                     ivxx = ivxx +1
                     coeff(i,ivxx) = 0.5*(1+(-1)**(ii+1)
     &                                  *cos(dble(ii)*tv))
                     do k = 1, ntorcrs
                        if (cflg(k).gt.0 .and. cflg(k).eq.jj) then
                           coeff(i,ivxx) = coeff(i,ivxx)
     &                                     +0.5*(1+(-1)**(ii+1)
     &                               *cos(dble(ii)*ctv(i,k)/radian))
                        end if
                     end do
                     write (iout,280)  i,ivxx,coeff(i,ivxx)
  280                format (' Derivative :',5x,2i4,f8.4)
                  end if
               end do
            end do
            torf(i) = torf(i) + vcon - delte(i)
            ivxx = ivxx + 1
            coeff(i,ivxx) = 1.0d0
            write (iout,290)  i,torf(i)
  290       format (' Energy Difference :',i8,f12.4)
         end do
c
c     set matrix elements for matrix A
c
         do i = 1, nvxx
            do j = 1, nvxx
               tord(i,j) = 0.0d0
               do k = 1, nconf
                  tord(i,j) = tord(i,j) + coeff(k,i)*coeff(k,j)*fwt(k)
               end do
            end do
         end do
c
c     print the matrix A elements
c
         write (iout,300)  nvxx
  300    format (/,' Total Variable Number ',i8)
         write (iout,310)
  310    format (/,' Matrix A Elements :')
         do i = 1, nvxx
            do j = 1, nvxx
               mata(i,j) = tord(i,j)
            end do
            write (iout,320)  (mata(i,j),j=1,nvxx)
  320       format (1x,5f12.4)
         end do
c
c     multiply vector: Yi * Coeff * Weight
c
         do i = 1, nvxx
            torf(i) = 0.0d0
            do j = 1, nconf
               torf(i) = torf(i) + delte(j)*fwt(j)*coeff(j,i)
            end do
         end do
         do i = 1, nvxx
            mata(i,nvxx+1) = torf(i)
         end do
c
c     solve the linear equations via Gauss-Jordan elimination
c
         call gaussjordan (nvxx,mata)
c
c     get new torsion force constants
c
         do i = 1, nvxx
            vxx(i) = mata(i,nvxx+1)
         end do
         ivxx = 0
         do i = 1, ntorfit
            j = ftorid(i)
            k = ctorid(j)
            do ii = 1, 6
               if (vflg(ii,i) .and. tflg(i).eq.0) then
                  ivxx = ivxx + 1
                  if (ii .eq. 1) then
                     tors1(1,k) = vxx(ivxx)
                  else if (ii .eq. 2) then
                     tors2(1,k) = vxx(ivxx)
                  else if (ii .eq. 3) then
                     tors3(1,k) = vxx(ivxx)
                  else if (ii .eq. 4) then
                     tors4(1,k) = vxx(ivxx)
                  else if (ii .eq. 5) then
                     tors5(1,k) = vxx(ivxx)
                  else if (ii .eq. 6) then
                     tors6(1,k) = vxx(ivxx)
                  end if
                  do jj = 1, ntorcrs
                     kk = ctorid(jj)
                     if (cflg(j).gt.0 .and. cflg(jj).eq.j) then
                        if (ii .eq. 1) then
                           tors1(1,kk) = vxx(ivxx)
                        else if (ii .eq. 2) then
                           tors2(1,kk) = vxx(ivxx)
                        else if (ii .eq. 3) then
                           tors3(1,kk) = vxx(ivxx)
                        else if (ii .eq. 4) then
                           tors4(1,kk) = vxx(ivxx)
                        else if (ii .eq. 5) then
                           tors5(1,kk) = vxx(ivxx)
                        else if (ii .eq. 6) then
                           tors6(1,kk) = vxx(ivxx)
                        end if
                     end if
                  end do
               end if
            end do
            ivxx = ivxx + 1
            vcon = vxx(ivxx)
         end do
         istep = istep + 1
      end do
c
c     validate the fitted results
c
      write (iout,330)
  330 format ()
      do i = 1, nconf
         call getref (i)
         kk = 0
         do j = 1, ntorfit
            k = ftorid(j)
            ia = torcrs(1,k)
            ib = torcrs(2,k)
            ic = torcrs(3,k)
            id = torcrs(4,k)
            ftv(i,j) = geometry (ia,ib,ic,id)
            if (tflg(j) .eq. 0) then
               kk = kk + 1
               tfix(2,otfix+kk) = ftv(i,j)
               tfix(3,otfix+kk) = tfix(2,otfix+kk)
            end if
         end do
c
c     perform dynamic allocation of some local arrays
c
         allocate (xx(3*nuse))
c
c     scale the coordinates of each active atom
c
         nvar = 0
         do j = 1, n
            if (use(j)) then
               nvar = nvar + 1
               xx(nvar) = x(j) * scale(nvar)
               nvar = nvar + 1
               xx(nvar) = y(j) * scale(nvar)
               nvar = nvar + 1
               xx(nvar) = z(j) * scale(nvar)
            end if
         end do
c
c     make the call to the optimization routine
c
         write (iout,340)  i
  340    format (' Minimizing Structure',i5,2x,'with New Parameters')
         coordtype = 'CARTESIAN'
         call lbfgs (nvar,xx,minimum,grdmin,torfit1,optsave)
c
c     unscale the final coordinates for active atoms
c
         nvar = 0
         do j = 1, n
            if (use(j)) then
               nvar = nvar + 1
               x(j) = xx(nvar) / scale(nvar)
               nvar = nvar + 1
               y(j) = xx(nvar) / scale(nvar)
               nvar = nvar + 1
               z(j) = xx(nvar) / scale(nvar)
            end if
         end do
c
c     perform deallocation of some local arrays
c
         deallocate (xx)
c
c     set the energy value for the current minimum
c
         emm(i) = energy ()
      end do
c
c     calculate the relative MM energies
c
      emmmin = emm(1)
      do i = 2, nconf
         if (emm(i) .lt. emmmin)  emmmin = emm(i)
      end do
c
c     calculate the energy difference and RMS
c
      rms = 0.0d0
      write (iout,350)
  350 format ()
      do i = 1, nconf
         ermm (i) = emm(i) - emmmin
         delte (i) = erqm (i) - ermm(i)
         rms = rms + delte(i)*delte(i)
         write (iout,360)  i,ermm(i)
  360    format (' Relative Conformational Energy (MM)',i8,f12.4,
     &              ' Kcal/mole')
      end do
      rms = sqrt(rms/dble(nconf))
      write (iout,370)  rms
  370 format (/,' Energy RMS With Fitting Parmeters :',8x,f12.4)
      if (rms .gt. zrms ) then
         write (iout,380)  zrms
  380    format (/,' Annihilating the Torsions is Preferable',
     &           /,' Final RMS :',f12.6,' Kcal/mole',/)
      end if
c
c     output keyfile information with the fitted parameters
c
      filename = oldfilename
      leng = oldleng
      nkey = oldnkey
      do i = 1, nkey
         keyline(i) = oldkeyline(i)
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (oldkeyline)
c
c     output some definitions and parameters to a keyfile
c
      ikey = freeunit ()
      keyfile = filename(1:leng)//'.key'
      call version (keyfile,'new')
      open (unit=ikey,file=keyfile,status='new')
c
c     copy the contents of any previously existing keyfile
c
      do i = 1, nkey
         record = keyline(i)
         size = trimtext (record)
         write (ikey,390)  record(1:size)
  390    format (a)
      end do
c
c     list the valence parameters
c
      write (ikey,400)
  400 format (/,'#',/,'# Results of Valence Parameter Fitting',
     &        /,'#',/)
      write (iout,410)
  410 format (/,' Optimized Torsional Parameters:',/)
      do i = 1, ntorfit
         if (tflg(i) .eq. 0) then
            j = ftorid(i)
            k = ctorid(j)
            ia = itors(1,k)
            ib = itors(2,k)
            ic = itors(3,k)
            id = itors(4,k)
            ita = class(ia)
            itb = class(ib)
            itc = class(ic)
            itd = class(id)
            if (rms .gt. zrms) then
               tors1(1,k) = 0.0d0
               tors2(1,k) = 0.0d0
               tors3(1,k) = 0.0d0
            end if
            write (iout,420)  ita,itb,itc,itd,tors1(1,k),
     &                        tors2(1,k),tors3(1,k)
  420       format (' torsion ',4i4,f8.3,' 0.0 1 ',f8.3,
     &                 ' 180.0 2 ',f8.3,' 0.0 3')
            write (ikey,430)  ita,itb,itc,itd,tors1(1,k),
     &                        tors2(1,k),tors3(1,k)
  430       format (' torsion ',4i4,f8.3,' 0.0 1 ',f8.3,
     &                 ' 180.0 2 ',f8.3,' 0.0 3')
         end if
      end do
      close (unit=ikey)
      return
      end
c
c
c     ############################################################
c     ##                                                        ##
c     ##  subroutine gaussjordan  --  Gauss-Jordan elimination  ##
c     ##                                                        ##
c     ############################################################
c
c
c     "gaussjordan" solves a system of linear equations by using
c     the method of Gaussian elimination with partial pivoting
c
c
      subroutine gaussjordan (n,a)
      implicit none
      include 'iounit.i'
      integer maxfit
      parameter (maxfit=12)
      integer i,j,k,l,n
      real*8 t,av
      real*8 a(6*maxfit,*)
c
c
c     perform the Gaussian elimination procedure
c
      do k = 1, n-1
         av = 0.0d0
         do i = k, n
            if (abs(a(i,k)) .gt. abs(av)) then
               av = a(i,k)
               l = i
            end if
         end do
         if (abs(av) .lt. 1.0d-8) then
            write (iout,10)
   10       format (/,' GAUSSJORDAN  --  Singular Coefficient Matrix')
            call fatal
         end if
         if (l .ne. k) then
            do j = k, n+1
               t = a(k,j)
               a(k,j) = a(l,j)
               a(l,j) = t
            end do
         end if
         av = 1.0d0 / av
         do j = k+1, n+1
            a(k,j) = a(k,j) * av
            do i = k+1, n
               a(i,j) = a(i,j) - a(i,k)*a(k,j)
            end do
         end do
      end do
      a(n,n+1) = a(n,n+1) / a(n,n)
      do k = 1, n-1
         i = n - k
         av = 0.0d0
         do j = i+1, n
            av = av + a(i,j)*a(j,n+1)
         end do
         a(i,n+1) = a(i,n+1) - av
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  function torfit1  --  energy and gradient for minimize  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "torfit1" is a service routine that computes the energy and
c     gradient for a low storage BFGS optimization in Cartesian
c     coordinate space
c
c
      function torfit1 (xx,g)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'scales.i'
      include 'usage.i'
      integer i,nvar
      real*8 torfit1,e
      real*8 energy,eps
      real*8 xx(*)
      real*8 g(*)
      real*8, allocatable :: derivs(:,:)
      logical analytic
      external energy
c
c
c     use either analytical or numerical gradients
c
      analytic = .true.
      eps = 0.00001d0
c
c     translate optimization parameters to atomic coordinates
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            x(i) = xx(nvar) / scale(nvar)
            nvar = nvar + 1
            y(i) = xx(nvar) / scale(nvar)
            nvar = nvar + 1
            z(i) = xx(nvar) / scale(nvar)
         end if
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (derivs(3,n))
c
c     compute and store the energy and gradient
c
      if (analytic) then
         call gradient (e,derivs)
      else
         e = energy ()
         call numgrad (energy,derivs,eps)
      end if
      torfit1 = e
c
c     store Cartesian gradient as optimization gradient
c
      nvar = 0
      do i = 1, n
         if (use(i)) then
            nvar = nvar + 1
            g(nvar) = derivs(1,i) / scale(nvar)
            nvar = nvar + 1
            g(nvar) = derivs(2,i) / scale(nvar)
            nvar = nvar + 1
            g(nvar) = derivs(3,i) / scale(nvar)
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (derivs)
      return
      end


!>    @brief AD wrapper routine to compute the derivative pressure (but not the original pressure itself!)
!>    @param[in] init flag: 0-init, 1-normal setup
!>    @param[in] ismpl local sample index
!>    @details
!>    parallelisation wrapper for pressure computation
SUBROUTINE g_head2pres(init, ismpl)
  USE arrays
  USE mod_genrl
  USE mod_linfos
  USE mod_OMP_TOOLS
  IMPLICIT NONE
  integer :: ismpl
  INCLUDE 'OMP_TOOLS.inc'
  INTEGER init

  IF (linfos(3) .GE. 2) WRITE(*, '(A,I1,A)') '  ... g_pressure (init=',init, ')'
#ifdef head_base
! save original pressure
  CALL dcopy(i0*j0*k0,pres(1,1,1,ismpl),1,x(1,1,1,ismpl),1)
!
#ifdef fOMP
!$OMP parallel num_threads(Tlevel_1)
!$      call omp_binding(ismpl)
#endif
!
  CALL g_omp_head2pres(init, ismpl)
!
#ifdef fOMP
!$OMP end parallel
#endif
!
! restore original pressure
  CALL dcopy(i0*j0*k0,x(1,1,1,ismpl),1,pres(1,1,1,ismpl),1)
#endif
  RETURN
END SUBROUTINE g_head2pres