c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c
c ... file isfvpec.f
c
c     this file includes documentation and code for
c     subroutine isfvpec          i
c
c ... files which must be loaded with isfvpec.f
c
c     sphcom.f, hrfft.f, vhsec.f,shaec.f
c
c
c     subroutine isfvpec(nlat,nlon,isym,nt,sf,vp,idv,jdv,as,bs,av,bv,
c    +                   mdb,ndb,wvhsec,lvhsec,work,lwork,ierror)
c
c     given the scalar spherical harmonic coefficients as,bs precomputed
C*PL*ERROR* Comment line too long
c     by shaec for the scalar stream function sf and av,bv precomputed by
C*PL*ERROR* Comment line too long
c     shaec for the scalar velocity potenital vp, subroutine isfvpec computes
c     the vector field (v,w) corresponding to sf and vp.  w is the east
C*PL*ERROR* Comment line too long
c     longitudinal and v is the colatitudinal component of the vector field.
C*PL*ERROR* Comment line too long
c     (v,w) is expressed in terms of sf,vp by the helmholtz relations (in
c     mathematical spherical coordinates):
c
c          v = -1/sin(theta)*d(vp)/dlambda + d(st)/dtheta
c
c          w =  1/sin(theta)*d(st)/dlambda + d(vp)/dtheta
c
c     required legendre functions are recomputed rather than stored as
c     they are in subroutine isfvpes.  v(i,j) and w(i,j) are given at
c     colatitude
c
c            theta(i) = (i-1)*pi/(nlat-1)
c
c     and east longitude
c
c            lambda(j) = (j-1)*2*pi/nlon
c
c     on the sphere (pi=4.0*atan(1.0)).
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater than
c            3.  the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c
c     isym   a parameter which determines whether the vector field is
c            computed on the full or half sphere as follows:
c
c      = 0
c
c            the symmetries/antsymmetries described in isym=1,2 below
c            do not exist in sf,vp about the equator.  in this case v
c            and w are not necessarily symmetric or antisymmetric about
c            equator.  v and w are computed on the entire sphere.
c            i.e., in arrays sf(i,j),vp(i,j) for i=1,...,nlat and
c            j=1,...,nlon.
c
c      = 1
c
c            vp is antisymmetric and sf is symmetric about the equator.
c            in this case v is symmetric and w antisymmetric about
c            the equator and are computed for the northern hemisphere
c            only.  i.e., if nlat is odd the v(i,j),w(i,j) are computed
c            for i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is
c            even then v(i,j),w(i,j) are computed for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c      = 2
c
c            vp is symmetric and sf is antisymmetric about the equator.
c            in this case v is antisymmetric and w symmetric about
c            the equator and are computed for the northern hemisphere
c            only.  i.e., if nlat is odd the v(i,j),w(i,j) are computed
c            for i=1,...,(nlat+1)/2 and for j=1,...,nlon.  if nlat is
c            even then v(i,j),w(i,j) are computed for i=1,...,nlat/2
c            and j=1,...,nlon.
c
c     nt     nt is the number of scalar and vector fields.  some
C*PL*ERROR* Comment line too long
c            computational efficiency is obtained for multiple fields. arrays
C*PL*ERROR* Comment line too long
c            can be three dimensional corresponding to an indexed multiple
c            vector field.  in this case multiple vector synthesis will
c            be performed to compute (v,w) for each field.  the
c            third index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt = 1.  the
c            description of the remaining parameters is simplified by
C*PL*ERROR* Comment line too long
c            assuming that nt=1 or that all the arrays are two dimensional.
c
c     idv    the first dimension of the arrays v,w as it appears in
c            the program that calls isfvpec. if isym = 0 then idv
c            must be at least nlat.  if isym = 1 or 2 and nlat is
c            even then idv must be at least nlat/2. if isym = 1 or 2
c            and nlat is odd then idv must be at least (nlat+1)/2.
c
c     jdv    the second dimension of the arrays v,w as it appears in
c            the program that calls isfvpec. jdv must be at least nlon.
c
c     as,bs  two or three dimensional arrays (see input parameter nt)
c            that contain the spherical harmonic coefficients of
c            the scalar field sf as computed by subroutine shaec.
c
c     av,bv  two or three dimensional arrays (see input parameter nt)
c            that contain the spherical harmonic coefficients of
c            the scalar field vp as computed by subroutine shaec.
c
c     mdb    the first dimension of the arrays as,bs,av,bv as it
c            appears in the program that calls isfvpec. mdb must be at
c            least min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndb    the second dimension of the arrays as,bs,av,bv as it
c            appears in the program that calls isfvpec. ndb must be at
c            least nlat.
c
c     wvhsec an array which must be initialized by subroutine vhseci.
c            once initialized, wvhsec can be used repeatedly by isfvpec
c            as long as nlon and nlat remain unchanged.  wvhsec must
c            not bel altered between calls of isfvpec.
c
c
c     lvhsec the dimension of the array wvhsec as it appears in the
c            program that calls isfvpec. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhsec must be at least
c
c
c               4*nlat*l2+3*max0(l1-2,0)*(nlat+nlat-l1-1)+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls isfvpec. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2                    if nlat is even or
c               l2 = (nlat+1)/2                if nlat is odd
c
c            if isym = 0 then lwork must be at least
c
c               nlat*(2*nt*nlon+max0(6*l2,nlon)+4*l1*nt+1)
c
c            if isym = 1 or 2 then lwork must be at least
c
c               l2*(2*nt*nlon+max0(6*nlat,nlon))+nlat*(4*l1*nt+1)
c
c     **************************************************************
c
c     output parameters
c
c    v,w    two or three dimensional arrays (see input parameter nt)
c           that contains the vector field corresponding to the stream
c           function sf and velocity potential vp whose coefficients,
c           as,bs (for sf) and av,bv (for vp), were precomputed by
c           subroutine shaec.  v(i,j) and w(i,j) are given at the
c           colatitude point
c
c                theta(i) = (i-1)*pi/(nlat-1)
c
c           and longitude point
c
c                lambda(j) = (j-1)*2*pi/nlon
c
C*PL*ERROR* Comment line too long
c           the index ranges are defined above at the input parameter isym.
c
c
c    ierror = 0  no errors
c           = 1  error in the specification of nlat
c           = 2  error in the specification of nlon
c           = 3  error in the specification of isym
c           = 4  error in the specification of nt
c           = 5  error in the specification of idv
c           = 6  error in the specification of jdv
c           = 7  error in the specification of mdb
c           = 8  error in the specification of ndb
c           = 9  error in the specification of lvhsec
c           = 10 error in the specification of lwork
c **********************************************************************
c
      SUBROUTINE DISFVPEC(NLAT,NLON,ISYM,NT,V,W,IDV,JDV,AS,BS,AV,BV,MDB,
     +                   NDB,WVHSEC,LVHSEC,WORK,LWORK,IERROR)
      IMPLICIT NONE
      INTEGER NLAT,NLON,ISYM,NT,IDV,JDV,MDB,NDB,LVHSEC,LWORK,IERROR
      DOUBLE PRECISION V(IDV,JDV,NT),W(IDV,JDV,NT)
      DOUBLE PRECISION AS(MDB,NDB,NT),BS(MDB,NDB,NT)
      DOUBLE PRECISION AV(MDB,NDB,NT),BV(MDB,NDB,NT)
      DOUBLE PRECISION WVHSEC(LVHSEC),WORK(LWORK)
      INTEGER MMAX,L1,L2,LZZ1,LABC,MN,IS,LWK,IWK,LWMIN
      INTEGER IBR,IBI,ICR,ICI
c
c     check input parameters
c
      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      L2 = (NLAT+1)/2
      IF ((ISYM.EQ.0.AND.IDV.LT.NLAT) .OR.
     +    (ISYM.GT.0.AND.IDV.LT.L2)) RETURN
      IERROR = 6
      IF (JDV.LT.NLON) RETURN
      IERROR = 7
      L1 = MIN0(NLAT, (NLON+1)/2)
      IF (MDB.LT.MIN0(NLAT, (NLON+2)/2)) RETURN
      IERROR = 8
      IF (NDB.LT.NLAT) RETURN
      IERROR = 9
      LZZ1 = 2*NLAT*L2
      LABC = 3* (MAX0(L1-2,0)* (NLAT+NLAT-L1-1))/2
      IF (LVHSEC.LT.2* (LZZ1+LABC)+NLON+15) RETURN
      IERROR = 10
      IF (ISYM.EQ.0) THEN
          LWMIN = NLAT* (2*NT*NLON+MAX0(6*L2,NLON)+4*L1*NT+1)
      ELSE
          LWMIN = L2* (2*NT*NLON+MAX0(6*NLAT,NLON)) + NLAT* (4*L1*NT+1)
      END IF
      IF (LWORK.LT.LWMIN) RETURN
c
c     set first dimension for br,bi,cr,ci (as requried by vhsec)
c
      MMAX = MIN0(NLAT, (NLON+1)/2)
      MN = MMAX*NLAT*NT
      IERROR = 0
c
c     set work space pointers
c
      IBR = 1
      IBI = IBR + MN
      ICR = IBI + MN
      ICI = ICR + MN
      IS = ICI + MN
      IWK = IS + NLAT
      LWK = LWORK - 4*MN - NLAT
      CALL DISFVPEC1(NLAT,NLON,ISYM,NT,V,W,IDV,JDV,AS,BS,AV,BV,MDB,NDB,
     +              WORK(IBR),WORK(IBI),WORK(ICR),WORK(ICI),L1,WORK(IS),
     +              WVHSEC,LVHSEC,WORK(IWK),LWK,IERROR)
      RETURN
      END

      SUBROUTINE DISFVPEC1(NLAT,NLON,ISYM,NT,V,W,IDV,JDV,AS,BS,AV,BV,
     +                     MDB,NDB,BR,BI,CR,CI,MAB,FNN,WVHSEC,LVHSEC,
     +                     WK,LWK,IERROR)
      IMPLICIT NONE
      INTEGER NLAT,NLON,ISYM,NT,IDV,JDV,MDB,NDB,MAB,LVHSEC,LWK,IERROR
      DOUBLE PRECISION V(IDV,JDV,NT),W(IDV,JDV,NT)
      DOUBLE PRECISION AS(MDB,NDB,NT),BS(MDB,NDB,NT)
      DOUBLE PRECISION AV(MDB,NDB,NT),BV(MDB,NDB,NT)
      DOUBLE PRECISION BR(MAB,NLAT,NT),BI(MAB,NLAT,NT)
      DOUBLE PRECISION CR(MAB,NLAT,NT),CI(MAB,NLAT,NT)
      DOUBLE PRECISION WVHSEC(LVHSEC),WK(LWK),FNN(NLAT)
      INTEGER N,M,MMAX,K,ITYP
c
c     set coefficient multiplyers
c
      DO N = 2,NLAT
          FNN(N) = -SQRT(DBLE(N* (N-1)))
      END DO
      MMAX = MIN0(NLAT, (NLON+1)/2)
c
c     compute (v,w) coefficients from as,bs,av,bv
c
      DO K = 1,NT
          DO N = 1,NLAT
              DO M = 1,MAB
                  BR(M,N,K) = 0.0D0
                  BI(M,N,K) = 0.0D0
                  CR(M,N,K) = 0.0D0
                  CI(M,N,K) = 0.0D0
              END DO
          END DO
c
c     compute m=0 coefficients
c
          DO N = 2,NLAT
              BR(1,N,K) = -FNN(N)*AV(1,N,K)
              BI(1,N,K) = -FNN(N)*BV(1,N,K)
              CR(1,N,K) = FNN(N)*AS(1,N,K)
              CI(1,N,K) = FNN(N)*BS(1,N,K)
          END DO
c
c     compute m>0 coefficients using vector spherepack value for mmax
c
          DO M = 2,MMAX
              DO N = M,NLAT
                  BR(M,N,K) = -FNN(N)*AV(M,N,K)
                  BI(M,N,K) = -FNN(N)*BV(M,N,K)
                  CR(M,N,K) = FNN(N)*AS(M,N,K)
                  CI(M,N,K) = FNN(N)*BS(M,N,K)
              END DO
          END DO
      END DO
c
c     synthesize br,bi,cr,ci into (v,w)
c
      IF (ISYM.EQ.0) THEN
          ITYP = 0
      ELSE IF (ISYM.EQ.1) THEN
          ITYP = 3
      ELSE IF (ISYM.EQ.2) THEN
          ITYP = 6
      END IF
      CALL DVHSEC(NLAT,NLON,ITYP,NT,V,W,IDV,JDV,BR,BI,CR,CI,MAB,NLAT,
     +           WVHSEC,LVHSEC,WK,LWK,IERROR)
      RETURN
      END


      subroutine CG(a,d,x,xo,n)
      integer n
      real*8 a(n,n),d(n,1),x(n,1),xo(n,1),xstore(n,1)
      real*8 p(n,1),c,r(n,1),rT(1,n),pT(1,n),top(1,1),bottom(1,1)
      real*8 roT(1,n),test,ro(n,1),beta(1,1),rstore,test1(n,1)

   10 r=d-matmul(A,xo)
      rstore=maxval(r)
      p=r
      if (abs(maxval(r)).lt.1E-16) then
      x=xo
      return
      endif
      do i=1,1000
c      write(*,*) maxval(r)
      call matrixtrans(p,pT,n,1)
      call matrixtrans(r,rT,n,1)

c      write(*,*) 'before top'
      top=matmul(rT,r)
c      write(*,*) 'before bottom'
      bottom=matmul(pT,matmul(a,p))
c      write(*,*) bottom

      c=top(1,1)/bottom(1,1)
c      write(*,*) c

      x=xo+c*p
      ro=r
      roT=rT
      xo=x
c      write(*,*) 'before r'
      r=ro-c*matmul(A,p)
      if (c.eq.0) then
      test1=x-xstore
      test=abs(maxval(test1))
c      write(*,*) test
      if (abs(maxval(d-matmul(a,x))).ge.abs(rstore)) then

c      write(*,*) maxval(abs(d-matmul(a,x)))
      return
      endif
      if (test.le.1.E-8) then
      return
      endif
      xstore=x
c      write(*,*) maxval(abs(d-matmul(a,x))),rstore

      goto 10

      endif

      if (maxval(r).lt.1E-16)then
      return
      endif

      call matrixtrans(r,rT,n,1)
c      write(*,*) 'before beta'
      beta=matmul(rT,r)/matmul(roT,ro)
      p=r+beta*p
      enddo

      end


module leastsquare
implicit none

contains

subroutine zls(Ao,bo,mtr,pr,x)
    !Solves equation A*x=b in Least Square sense, using complex variables
    !mtr=0 sends A and b to lapack. This system is solved in Least Square sense.
    !mtr=1 sends A^dagger*A and A^dagger*b to lapack. This system is solved exact.
    !mtr=2 sends A to lapack for SVD. Construct explicitly Least Square solution.
    !mtr=3 sends A to lapack for SVD. Construct explicitly Least Square solution, but truncate modes with small singular values.
    implicit none
    complex(kind=16),intent(in) :: Ao(:,:),bo(:)
    integer,intent(in) :: mtr
    integer,intent(in) :: pr
    complex(kind=16)   :: x(:)
    !internal
    integer :: i,N,M,p,r,mo
    complex(kind=16),allocatable :: A(:,:),b(:),k(:,:),g(:)
    complex(kind=16),allocatable :: u(:,:),v(:,:)
    real(kind=16),allocatable :: s(:)
    real(kind=16) :: alpha

    N=size(Ao,1)
    M=size(Ao,2)
    p=min(N,M)
    allocate(A(N,M),b(N))
    b=bo !copy
    A=Ao !copy
    ! Let Lapack solve equation: A*x=b in LS sense
    if(mtr==0) then
       ! solves A*x=b using QR or LQ factorization. Full rank is assumed.
       call zgelswrapper(A,b,pr)
       ! solves A*x=b using Singular Value Decomposition SVD (only double precision implemented).
       !call zgelsswrapper(A,b)
       ! solves A*x=b using Singular Value Decomposition SVD with Divide and Conquer (only double precision implemented)
       !call zgelsdwrapper(A,b)
    ! Let Lapack exactly solve normal equation: A^dagger*A*x=A^dagger*b
    elseif(mtr==1) then
       allocate(k(M,M),g(M))
       k=matmul(conjg(transpose(A)),A)
       g=matmul(conjg(transpose(A)),b)
       ! solves k*x=g using QR or LQ factorization. Full rank is assumed.
       call zgelswrapper(k,g,pr)
       ! solves A*x=b using Singular Value Decomposition SVD (only double precision implemented).
       !call zgelsswrapper(k,g)
       ! solves A*x=b using Singular Value Decomposition SVD with Divide and Conquer (only double precision implemented)
       !call zgelsdwrapper(k,g)
       b(1:M)=g
       deallocate(k,g)
    ! Explicit SVD
    elseif(mtr==2 .or. mtr==3) then
       allocate(u(N,N),s(p),v(M,M))
       ! computes the singular value decomposition of a complex matrix using Divide and Conquer. (only double precision implemented)
       call zgesddwrapper(A,u,s,v,pr)
       write(90,'(a)') "SVD's singular values: s_i and s_i/s_1"
       do i=1,p
          write(90,'(2E13.5)') s(i),s(i)/s(1)
       enddo
       write(*,*)
       if(pr==64) then
          r=minloc(abs(s-s(1)*0.5q0*10**(-15q0)),1)
       elseif(pr==128) then
          r=minloc(abs(s-s(1)*0.5q0*10**(-30q0)),1)
       else
          stop "precision not supported"
       endif
       write(90,'(I4,a)') r," is estimated SVD rank."
       write(90,'(E15.5,a)') s(1)/s(r)," is estimated condition number"
       if(mtr==2) then
          mo=r
       ! Explicit SVD and use singular values s(i)/s(1)>alpha
       elseif(mtr==3) then
          !This is just an example value.
          alpha=10**(-4q0)
          mo=minloc(abs(s-s(1)*alpha),1)
       endif
       write(90,'(I4,a,I4)') mo," SVD modes used for solution, out of",min(M,N)
       ! construct solution here
       allocate(g(M))
       g=cmplx(0q0,0q0,kind=16)
       do i=1,mo
          g=g+1q0/s(i)*dot_product(u(:,i),b)*v(:,i)
       enddo
       b(1:M)=g
       deallocate(g)
       deallocate(u,s,v)
    else
       stop "wrong mtr value"
    endif
    x=b(1:M)
    deallocate(A,b)
end subroutine

subroutine zgesddwrapper(A,u,s,v,pr)
    ! Preforms SVD factorization of matrix A in precision pr
    implicit none
    complex(kind=16),intent(in) :: A(:,:)
    complex(kind=16),intent(out) :: u(:,:),v(:,:)
    real(kind=16),intent(out) :: s(:)
    integer,intent(in) :: pr
    !internal
    integer :: N,M,p
    integer :: lwork,lrwork,info
    integer,allocatable :: iwork(:)
    !double precison
    complex(kind=8),allocatable :: Ad(:,:)
    complex(kind=8),allocatable :: ud(:,:),vd(:,:)
    real(kind=8),allocatable :: sd(:)
    complex(kind=8),allocatable :: workd(:)
    real(kind=8),allocatable :: rworkd(:)

    N=size(A,1)
    M=size(A,2)
    p=min(N,M)

    if(pr==64) then  !double precision
       allocate(Ad(N,M),ud(N,N),sd(p),vd(M,M))
       Ad=A
       !call lapack routine
       lwork=2*min(N,M)*min(N,M)+2*min(N,M)+max(N,M)
       lrwork=min(N,M)*max(5*min(N,M)+7,2*max(N,M)+2*min(N,M)+1)
       allocate(workd(lwork),rworkd(lrwork),iwork(8*p))
       lwork=-1
       call zgesdd('A',N,M,Ad,N,sd,ud,N,vd,M,workd,lwork,rworkd,iwork,info)
       if(info<0) then
          stop "SVD factorization had wrong input"
       elseif(info>0) then
          stop "SVD factorization did not converge"
       endif
       lwork=int(real(workd(1)))  !optimal lwork
       deallocate(workd)
       allocate(workd(lwork))
       call zgesdd('A',N,M,Ad,N,sd,ud,N,vd,M,workd,lwork,rworkd,iwork,info)
       deallocate(workd,rworkd,iwork)
       vd=transpose(conjg(vd)) !transform v so not equal to v^dagger
       u=ud
       s=sd
       v=vd
       deallocate(Ad,ud,sd,vd)
    elseif(pr==128) then !quad precision
       stop "Precison not supported yet."
    else
       stop "Precision not supported"
    endif
end subroutine

subroutine zgelswrapper(A,b,pr)
    !solves overdetermined or underdetermined complex linear systems, assuming full rank of matrix A.
    !Accepts double (pr=64) and quad (pr=128)  precision.
    implicit none
    complex(kind=16),intent(in) :: A(:,:)
    complex(kind=16),intent(inout) :: b(:)
    integer,intent(in) :: pr
    integer :: N,M
    !lapack
    integer :: lwork
    complex(kind=16),allocatable :: work(:)
    integer :: info
    !double precision variables
    complex(kind=8),allocatable :: workd(:)
    complex(kind=8),allocatable :: Ad(:,:),bd(:)
    N=size(A,1)
    M=size(A,2)
    if(N<M) stop "N should be bigger or equal to M"
    allocate(work(2*M))
    lwork=-1
    if(pr==64) then
       allocate(Ad(N,M),bd(N),workd(2*M))
       Ad=A
       bd=b
       call zgels('N',N,M,1,Ad,N,bd,N,workd,lwork,info)
       if(info .ne. 0) stop "least square routine do not work properly"
       lwork=ceiling(real(workd(1))) !get optimal lwork
       deallocate(workd)
       if(lwork < 2*M ) stop "lwork is simply too low. Increase lwork in lapace routine."
       allocate(workd(lwork))
       call zgels('N',N,M,1,Ad,N,bd,N,workd,lwork,info)
       b=bd ! convert solution to quad precision variable
       deallocate(Ad,bd,workd)
    elseif(pr==128) then
       call zgelsquad('N',N,M,1,A,N,b,N,work,lwork,info)
       if(info .ne. 0) stop "least square routine do not work properly"
       lwork=ceiling(real(work(1))) !get optimal lwork
       deallocate(work)
       if(lwork < 2*M ) stop "lwork is simply too low. Increase lwork in lapace routine."
       allocate(work(lwork))
       call zgelsquad('N',N,M,1,A,N,b,N,work,lwork,info)
    else
       stop "Lapack's zgels can only handle dbl or quad"
    endif
    if(info<0) then
        stop "an argument with illegal value."
    elseif(info>0) then
       write(90,*) "Matrix A does not have full rank, which is assumed. LS-solution could not be computed"
    endif
    deallocate(work)
    !b(1:M) is the solution
end subroutine

subroutine zgelsswrapper(A,b)
    !compute the minimum norm solution to complex linear least squares problem
    implicit none
    complex(kind=16),intent(inout) :: A(:,:),b(:)
    integer :: N,M
    complex(kind=8),allocatable :: Ad(:,:),bd(:)
    !lapack
    integer :: rank !effective rank of matrix A
    integer :: lwork,lrwork
    integer :: info
    complex(kind=8),allocatable :: work(:)
    real(kind=8),allocatable :: s(:)
    real(kind=8) :: rcond
    real(kind=8),allocatable :: rwork(:)
    N=size(A,1)
    M=size(A,2)
    allocate(Ad(N,M),bd(N))
    Ad=A
    bd=b
    if(N<M) stop "N should be bigger than or equal to M"
    lwork=-1
    lrwork=max(5*M-4,1)
    allocate(s(M))
    allocate(rwork(lrwork))
    allocate(work(2*(2*N+M))) !twice times minimum, unnecessary big ??
    ! parameter to determine effective rank of A.
    ! singular values s_i <= rcond*s_1 are treated as zero.
    ! If rcond < 0, machine precision is used instead.
    rcond=-1d0
    call ZGELSS(N,M,1,Ad,N,bd,N,s,rcond,rank,work,lwork,rwork,info)
    if(info .ne. 0) stop "least square routine do not work properly"
    lwork=ceiling(real(work(1))) !get optimal lwork
    deallocate(work)
    if(lwork < 2*N+M ) stop "lwork is simply too low. Increase lwork in lapack routine."
    allocate(work(lwork))
    call ZGELSS(N,M,1,Ad,N,bd,N,s,rcond,rank,work,lwork,rwork,info) !bd(1:M) contains solution
    if(info<0) then
        stop "an argument with illegal value."
    elseif(info>0) then
        write(90,*) "least square algorithm failed to converge."
    endif
    write(90,*) " "
    write(90,'(A,E12.4)') "Condition number: ",s(1)/s(M)
    write(90,'(A,I3,A,I3,A)') "Effective rank of matrix:",rank," (",min(M,N)," for full rank)"
    deallocate(s,work,rwork)
    b=bd !convert from double to quad precision
    deallocate(Ad,bd)
end subroutine

subroutine zgelsdwrapper(A,b)
    !compute the minimum norm solution to complex linear least squares problem
    implicit none
    complex(kind=16),intent(inout) :: A(:,:),b(:)
    integer :: N,M
    complex(kind=8),allocatable :: Ad(:,:),bd(:)
    !lapack
    integer :: rank !effective rank of matrix A
    integer :: lwork,lrwork,liwork
    integer :: info
    complex(kind=8),allocatable :: work(:)
    real(kind=8),allocatable :: s(:)
    real(kind=8) :: rcond
    real(kind=8),allocatable :: rwork(:)
    integer,allocatable :: iwork(:)
    integer :: NLVL,SMLSIZ

    N=size(A,1)
    M=size(A,2)
    allocate(Ad(N,M),bd(N))
    Ad=A
    bd=b
    if(N<M) stop "N should be bigger than or equal to M"
    SMLSIZ=25 !normal value according to netlib.org
    NLVL = MAX( 0, INT( log(1d0*M/(SMLSIZ+1))/log(2d0) ) + 1 )
    lwork=-1
    lrwork=max(5*M-4,1)
    liwork = max(1, 3*M*NLVL + 11*M)
    allocate(s(M))
    allocate(work(2*(2*N+M))) !twice times minimum, unnecessary big ??
    allocate(rwork(lrwork))
    allocate(iwork(liwork))
    rcond=-1  !parameter to determine effective rank of A
    call ZGELSD(N,M,1,Ad,N,bd,N,s,rcond,rank,work,lwork,rwork,iwork,info)
    if(info .ne. 0) stop "least square routine do not work properly"
    lwork=ceiling(real(work(1))) !get optimal lwork
    lrwork=ceiling(real(rwork(1)))
    liwork=iwork(1)
    deallocate(work,rwork,iwork)

    if(lwork < 2*M+M ) stop "lwork is simply too low. Increase lwork in lapack routine."
    if(lrwork <= 1 ) stop "lrwork is simply too low. Increase lrwork in lapack routine."
    if(liwork <= 1 ) stop "liwork is simply too low. Increase liwork in lapack routine."
    allocate(work(lwork),rwork(lrwork),iwork(liwork))
    call ZGELSD(N,M,1,Ad,N,bd,N,s,rcond,rank,work,lwork,rwork,iwork,info) !bd(1:M) contains solution
    if(info<0) then
        stop "an argument with illegal value."
    elseif(info>0) then
        write(90,*) "least square algorithm failed to converge."
    endif
    write(90,*) " "
    write(90,'(A,E12.4)') "Condition number: ",s(1)/s(M)
    write(90,'(A,I3,A,I3,A)') "Effective rank of matrix:",rank," (",min(M,N)," for full rank)"
    deallocate(s,work,rwork,iwork)
    b=bd !convert from double to quad precision
    deallocate(Ad,bd)
end subroutine

end module


      SUBROUTINE TERMSS (NNODE,GPTH,EPNORM,EGPDT,IORDER,MMN,BTERMS)
C
C     SINGLE PRECISION ROUTINE TO CALCULATE B-MATRIX TERMS
C     FOR ELEMENTS  QUAD4, QUAD8 AND TRIA6.
C
C     THE INPUT FLAG LETS THE SUBROUTINE SWITCH BETWEEN QUAD4,
C     QUAD8 AND TRIA6 VERSIONS
C
C     ELEMENT TYPE FLAG (LTYPFL) = 1  FOR QUAD4,
C                                = 2  FOR TRIA6 (NOT AVAILABLE),
C                                = 3  FOR QUAD8 (NOT AVAILABLE).
C
C     THE OUTPUT CONSISTS OF THE DETERMINANT OF THE JACOBIAN
C     (DETJ), SHAPE FUNCTIONS AND THEIR DERIVATIVES. THE OUTPUT
C     PARAMETER, BADJAC, IS AN INTERNAL LOGICAL FLAG TO THE CALLING
C     ROUTINE INDICATING THAT THE JACOBIAN IS NOT CORRECT.
C     PART OF THE INPUT IS PASSED TO THIS SUBROUTINE THROUGH THE
C     INTERNAL COMMON BLOCK  /COMJAC/.
C
      LOGICAL          BADJAC
      INTEGER          MMN(1),LTYPFL,IORDER(1),INDEX(3,3)
      REAL             EGPDT(4,1),EPNORM(4,1)
      REAL             XI,ETA,ZETA,DETJ,SHP(8),JACOB(3,3),DSHPX(8),
     1                 DSHPE(8),DSHP(16),TSHP(8),TDSHP(16),BTERMS(1),
     2                 DUM,TEMP,EPS,TIE(9),TJ(3,3),VN(3),CJAC,GPTH(1),
     3                 TH,GRIDC(3,8)
      COMMON /COMJAC/  XI,ETA,ZETA,DETJ,BADJAC,LTYPFL
      COMMON /CJACOB/  CJAC(19)
      EQUIVALENCE      (DSHPX(1),DSHP(1)), (DSHPE(1),DSHP(9) )
      EQUIVALENCE      (VN(1)   ,CJAC(8)), (TIE(1)  ,CJAC(11))
      EQUIVALENCE      (TH      ,CJAC(1))
C
      EPS = 1.0E-15
      BADJAC = .FALSE.
C
      GO TO (10,30,20), LTYPFL
C
C     QUAD4 VERSION
C
   10 NGP = 4
      CALL Q4SHPS (XI,ETA,SHP,DSHP)
      GO TO 40
C
C     QUAD8 VERSION
C
   20 NGP = 8
      GO TO 40
C
C     TRIA6 VERSION
C
   30 NGP = 6
C
   40 DO 50 I = 1,NGP
      TSHP (I  ) = SHP(I)
      TDSHP(I  ) = DSHP(I)
   50 TDSHP(I+8) = DSHP(I+NGP)
      DO 60 I = 1,NGP
      IO = IORDER(I)
      SHP (I  ) = TSHP(IO)
      DSHP(I  ) = TDSHP(IO)
   60 DSHP(I+8) = TDSHP(IO+8)
C
      TH = 0.0
      DO 70 I = 1,NNODE
      TH = TH + GPTH(I)*SHP(I)
      DO 70 J = 1,3
      J1 = J + 1
      GRIDC(J,I) = EGPDT(J1,I) + ZETA*GPTH(I)*EPNORM(J1,I)*0.5
   70 CONTINUE
C
      DO 80 I = 1,2
      II = (I-1)*8
      DO 80 J = 1,3
      TJ(I,J) = 0.0
      DO 80 K = 1,NNODE
      TJ(I,J) = TJ(I,J) + DSHP(K+II)*GRIDC(J,K)
   80 CONTINUE
C
      DO 90 I = 1,3
      TJ(3,I) = 0.0
      DO 90 J = 1,NNODE
   90 TJ(3,I) = TJ(3,I) + 0.5*GPTH(J)*SHP(J)*EPNORM(I+1,J)
C
      DO 100 I = 1,3
      DO 100 J = 1,3
      IF (ABS(TJ(I,J)) .LT. EPS) TJ(I,J) = 0.0
  100 CONTINUE
C
C     SET UP THE TRANSFORMATION FROM THIS INTEGRATION POINT C.S.
C     TO THE ELEMENT C.S.  TIE
C
      VN(1) = TJ(1,2)*TJ(2,3) - TJ(2,2)*TJ(1,3)
      VN(2) = TJ(2,1)*TJ(1,3) - TJ(1,1)*TJ(2,3)
      VN(3) = TJ(1,1)*TJ(2,2) - TJ(2,1)*TJ(1,2)
C
      TEMP = SQRT(VN(1)*VN(1) + VN(2)*VN(2) + VN(3)*VN(3))
C
      TIE(7) = VN(1)/TEMP
      TIE(8) = VN(2)/TEMP
      TIE(9) = VN(3)/TEMP
C
      TEMP = SQRT(TIE(8)*TIE(8) + TIE(9)*TIE(9))
C
      TIE(1) = TIE(9)/TEMP
      TIE(2) = 0.0
      TIE(3) =-TIE(7)/TEMP
C
      TIE(4) = TIE(8)*TIE(3)
      TIE(5) = TEMP
      TIE(6) =-TIE(1)*TIE(8)
C
      CALL INVERS (3,TJ,3,DUM,0,DETJ,ISING,INDEX)
C
C
C     NOTE - THE INVERSE OF JACOBIAN HAS BEEN STORED IN TJ
C            UPON RETURN FROM INVERS.
C
      IF (ISING.EQ.1 .AND. DETJ.GT.0.0) GO TO 110
      BADJAC = .TRUE.
      GO TO 150
C
  110 CONTINUE
C
      DO 120 I = 1,3
      II = (I-1)*3
      DO 120 J = 1,3
      JACOB(I,J) = 0.0
      DO 120 K = 1,3
      IK = II + K
  120 JACOB(I,J) = JACOB(I,J) + TIE(IK)*TJ(K,J)
C
C     MULTIPLY THE INVERSE OF THE JACOBIAN BY THE TRANSPOSE
C     OF THE ARRAY CONTAINING DERIVATIVES OF THE SHAPE FUNCTIONS
C     TO GET THE TERMS USED IN THE ASSEMBLY OF THE B MATRIX.
C     NOTE THAT THE LAST ROW CONTAINS THE SHAPE FUNCTION VALUES.
C
      NODE3 = NNODE*3
      DO 130 I = 1,NNODE
  130 BTERMS(NODE3+I) = SHP(I)*JACOB(3,3)
C
      DO 140 I = 1,3
      II = (I-1)*NNODE
      DO 140 J = 1,NNODE
      IJ = II + J
      BTERMS(IJ) = 0.0
      DO 140 K = 1,2
      IK = (K-1)*8
  140 BTERMS(IJ) = BTERMS(IJ) + JACOB(I,K)*DSHP(IK+J)
  150 RETURN
      END


IF (deficitOnTopLayers / 1000 .LE. 0.0) THEN
	diffusionLimitedEvaporation = 8.3 * 1000
ELSE
	IF (deficitOnTopLayers / 1000 .LE. 25.0) THEN
		diffusionLimitedEvaporation = (2 * soilDiffusionConstant * soilDiffusionConstant / (deficitOnTopLayers / 1000)) * 1000
	ELSE
		diffusionLimitedEvaporation = 0
ENDIF


!	Multinomial third moments.  Covariance of product and single term.
!	density contains weights.
!	meanth contains means.
!	mean2th contains means of products.
!	quadpoint contains points.

function mcubth(density,meanth,mean2th,quadpoint)
implicit none
real(kind=8),intent(in)::density(:),meanth(:),mean2th(:,:),quadpoint(:,:)
real(kind=8)::mcubth(size(meanth),size(meanth),size(meanth))
!	Counts blocks, columns, rows, and quadrature points.
integer::block,col,row,quad
mcubth=0.0_8
do row=1,size(meanth)
	do col=1,row
		do block=1,size(meanth)
			do quad=1,size(density)
				mcubth(row,col,block)=mcubth(row,col,block)+&
					(quadpoint(row,quad)*quadpoint(col,quad)-mean2th(row,col))*&
					(quadpoint(block,quad)-meanth(block))*&
					density(quad)
			end do
		end do
	end do
end do
return

end function mcubth


Module EffPotFunctions

Use Control
Use Mathematics
! Use Model_Data_MSSM
Use Settings

! squared masses lesser than MIN_MASS are set to zero
Real(dp), parameter :: MIN_MASS = 1.0_dp
! for squared masses lesser than SMALL_MASS expansions are made
Real(dp), parameter :: SMALL_MASS = 1.0_dp
!Real(dp) :: hstep_pn=0.1_dp, hstep_sa=0.001_dp

 Real(dp) :: epsD = 1E-8_dp, epsM = 1.0E-8_dp, epsMnull = 1.0E-10_dp

 Interface SmallD
  Module Procedure SmallDR, SmallDC
 End Interface

 Interface SmallM
  Module Procedure SmallMR, SmallMC, SmallMR2, SmallMC2
 End Interface

  Interface VerySmallM
  Module Procedure VerySmallMR, VerySmallMC, VerySmallMR2, VerySmallMC2
 End Interface

Contains

! Function h(x,Q) for 1-loop effective potential
! following S.P. Martin, arXiv:hep-ph/0111209v2
! "Two-loop effective potential for a general renormalizable theory
! and softly broken supersymmetry"

Logical Function VerySmallMR(x,y,z,Q)
Implicit None
Real(dp), Intent(in) :: x,y,z
Real(dp), Intent(in) :: Q
If (Max(Max(Abs(x),Abs(y)),Abs(z)).le.epsMnull) Then
 VerySmallMR = .True.
Else If ((Abs(x)/Max(Q,Max(Abs(y),Abs(z)))).le.epsMnull) Then
 VerySmallMR = .True.
Else
 VerySmallMR = .False.
End if
End Function VerySmallMR

Logical Function VerySmallMC(x,y,z,Q)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Real(dp), Intent(in) :: Q
If (Max(Max(Abs(x),Abs(y)),Abs(z)).le.epsMnull) Then
 VerySmallMC = .True.
Else If ((Abs(x)/Max(Q,Max(Abs(y),Abs(z)))).lt.epsMnull) Then
 VerySmallMC = .True.
Else
 VerySmallMC = .False.
End if
End Function VerySmallMC

Logical Function VerySmallMR2(x,y)
Implicit None
Real(dp), Intent(in) :: x,y
If (Max(Abs(x),Abs(y)).le.epsMnull) Then
 VerySmallMR2 = .True.
Else If (Abs(x/y).le.epsMnull) Then
 VerySmallMR2 = .True.
Else
 VerySmallMR2 = .False.
End if
End Function VerySmallMR2

Logical Function VerySmallMC2(x,y)
Implicit None
Complex(dp), Intent(in) :: x,y
If (Max(Abs(x),Abs(y)).le.epsMnull) Then
 VerySmallMC2 = .True.
Else If (Abs(x/y).le.epsMnull) Then
 VerySmallMC2 = .True.
Else
 VerySmallMC2 = .False.
End if
End Function VerySmallMC2

recursive Complex(dp) Function I_SMartin_ex(x_in,y_in,z_in,Q2) result(res)
Implicit None
! x_in,y_in,z_in are supposed to be squared masses
! symmetric under interchange of any two of these
Real(dp),Intent(in) :: x_in,y_in,z_in,Q2
Integer :: ncontrol
Complex(dp) :: x,y,z,tempI
x = x_in
y = y_in
z = z_in
res = Cmplx(0._dp,0._dp)
ncontrol = 0

If (Q2.le.0._dp) Then
  write(*,*) 'invalid renormalization scale!'
  return
end if

Call SortArguments3C(x,y,z) ! sort x<=y<=z

If (VerySmallM(x,y,z,Q2)) Then ! x=0
!  Write(*,*) x
  If (VerySmallM(y,z,z,Q2)) Then ! y=0 (z >= y holds)
    If (VerySmallM(z,z,z,Q2)) then ! z=0
      res = ZeroC ! I(0,0,0)
      ncontrol = ncontrol +1
    Else ! z!=0
         ! I(0,0,z)
         res = -0.5_dp*z*(log(z/Q2))**2 &
         & + 2*z*log(z/Q2)-2.5_dp*z-pi**2*z/6._dp
         ncontrol = ncontrol +1
!       res = 0._dp
    End If
  Else ! y != 0
    If (VerySmallM(Abs(y-z),Abs(z))) Then ! y=z
	 ! I(0,y,y)
         res = -y*(zlog(y/Q2))**2+4._dp*y*zlog(y/Q2)-5._dp*y
         ncontrol = ncontrol +1
! res = 0._dp
    Else ! z != y
          ! I(0,y,z)
	res = (z-y)*(CLi2_mod(y/z)-log(z/y)*log((z-y)/Q2) &
	& +0.5_dp*(log(z/Q2))**2-pi**2/6._dp)  &
	& -2.5_dp*(z+y)+2*y*log(y/Q2)+2*z*log(z/Q2) &
	& -z*log(z/Q2)*log(y/Q2)
	ncontrol = ncontrol +1
! res = 0._dp
    End If
  End If
Else If (SmallM(x,y,z,Q2)) then ! x small
  If (SmallM(y,z,z,Q2)) then ! y small (z >= y holds)

      ! I(eps1,eps2,z)
      tempI = I_SMartin_ex(0._dp,0._dp,Real(z,dp),Q2)
      res = tempI + x/z*(-z-tempI + J_SMartin_1x(Real(z,dp),Q2)*(3._dp-zlog(x/Q2))) &  !! SWITCH 2
      & + y/z*(-z-tempI + J_SMartin_1x(Real(z,dp),Q2)*(3._dp-log(y/Q2))) &
      & + x*y/z**2*(-2._dp*tempI+4._dp*J_SMartin_1x(Real(z,dp),Q2) - 2.*z &
      & - (z+J_SMartin_1x(Real(z,dp),Q2))*(log(x/Q2)+log(y/Q2))+z*log(x/Q2)*log(y/Q2))
      ncontrol = ncontrol +1

  else ! y large (implies z also large)
    If (SmallD(y,z)) then ! y=z (large)
      ! I(eps,y,y)
      res = 2._dp
      res = 2._dp*J_SMartin_1x(Real(y,dp),Q2) - 2._dp*y &
      & - J_SMartin_2x(Real(y,dp),Real(y,dp),Q2)/y &
      & + x*(4._dp+J_SMartin_2x(Real(y,dp),Real(y,dp),Q2)/(2._dp*y**2) &  !! SWITCH 1
      & + 3._dp/y*J_SMartin_1x(Real(y,dp),Q2) &
      & -(1._dp+J_SMartin_1x(Real(y,dp),Q2)/y)*log(x/Q2))
      ncontrol = ncontrol +1

    else ! y != z
      ! I(eps,y,z)
      tempI = I_SMartin_ex(0._dp,Real(y,dp),Real(z,dp),Q2)
      res = tempI + x*(-(y+z)*tempI-2.*J_SMartin_2x(Real(y,dp),Real(z,dp),Q2) &  !! SWITCH 3
      & +3._dp*y*J_SMartin_1x(Real(y,dp),Q2) + 3.*z*J_SMartin_1x(Real(z,dp),Q2) &
      & -z*J_SMartin_1x(Real(y,dp),Q2)-y*J_SMartin_1x(Real(z,dp),Q2) - (y+z)**2 &
      & + (y-z)*(J_SMartin_1x(Real(z,dp),Q2)-J_SMartin_1x(Real(y,dp),Q2))*log(x))/(y-z)**2
      ncontrol = ncontrol +1
    end if
  end if

else ! x large

  ! most general case
  ! I(x,y,z)
  res = Cmplx(0._dp,0._dp)
  res=res + 0.5_dp*(x-y-z)*log(y/Q2)*log(z/Q2)
  res=res + 0.5_dp*(y-x-z)*log(x/Q2)*log(z/Q2)
  res=res + 0.5_dp*(z-x-y)*log(x/Q2)*log(y/Q2)
  res=res + 2._dp*x*log(x/Q2)
  res=res + 2._dp*y*log(y/Q2)
  res=res + 2._dp*z*log(z/Q2)
  res=res - 2.5_dp*(x+y+z)
  res=res - 0.5*XiFunction(x,y,z)
  ncontrol = ncontrol +1

end if

! end of all ifs

! control variable against sloppy programming
if (ncontrol.gt.1) then
  write(*,*) 'in I_SMartin_ex more than one case applies. sloppy programming!'
end if
End Function I_SMartin_ex

Complex(dp) Function I_SMartinC(x,y,z,Q2)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Real(dp), Intent(in) :: Q2
I_SMartinC = I_SMartin(Real(x,dp),Real(y,dp),Real(z,dp),Q2)
End Function

Complex(dp) Function h_SMartin(m2,Q2)
Implicit None
Complex(dp) :: z
Real(dp),Intent(in) :: m2,Q2
! input: squared mass m2, squared renormalization scale Q2.
If (Q2.le.0._dp) Then
  write(*,*) 'invalid renormalization scale!'
  return
end if
z = CMPLX(m2,0._dp)
If (abs(m2).le.MIN_MASS) Then
   h_SMartin = 0._dp
Else
   h_SMartin = 0.25_dp * (m2**2) * (log(z/Q2)-1.5_dp)
End If
End Function h_SMartin

Real(dp) Function DumbDiff2(func,x,k1,k2,h)
! finite difference method
Implicit None
Real(dp),external :: func
Integer,intent(in) :: k1,k2
Real(dp), Intent(in) :: x(2),h
Real(dp) :: res
if (k1.eq.k2) then
 DumbDiff2 = (func1D(x(k1)-h)-2._dp*func1D(x(k1))+func1D(x(k1)+h))/(h**2.)
else
 res = func((/x(1)+h,x(2)+h/))
 res = res-func((/x(1)+h,x(2)-h/))
 res = res-func((/x(1)-h,x(2)+h/))
 res = res+func((/x(1)-h,x(2)-h/))
 res = res/(4._dp*h**2)
 DumbDiff2=res
end if
Contains
Real(dp) function func1D(y)
Real(dp),Intent(in) :: y
Real(dp) :: ytemp(2)
ytemp=x
ytemp(k1)=y
func1D = func(ytemp)
end function
End function

Real(dp) function partialDiff(func,x,k,n,h)
! wrapper function to calculate the partial derivative of func w.r.t. to k-th variable
! evaluated at the n-dim. point x, with stepsize h.
Implicit None
Integer,Intent(in) :: n,k
Real(dp),External :: func
Real(dp),Intent(in) :: x(n),h
Real(dp) :: xtemp(n)
partialDiff=DumbDiff(func_k,x(k),h)
  Contains
  Real(dp) function func_k(y)
  Implicit None
  Real(dp) :: y
  xtemp = x
  xtemp(k)=y
  func_k = func(xtemp)
  End function
End function

Real(dp) Function DumbDiff(f,x,h)
implicit none
Real(dp),intent(in) :: x,h
real(dp),external :: f
DumbDiff = (-f(x+2*h)+8*f(x+h)-8*f(x-h)+f(x-2*h))/(12.*h)
end function

Real(dp) Function dfridr(func,x,h,err,iout)
! algorithm based on
! Ridders, C.J.F. 1982,
! Advances in Engineering Software
! vol. 4, no. 2, pp. 75–76.

! Returns the derivative of a function func at a point x
! by Ridders' method of polynomial extrapolation.
! The value h is input as an estimated initial stepsize; it need not be small, but rather should
! be an increment in x over which func changes substantially.
! An estimate of the error in the derivative is returned as err.
! Parameters: Stepsize is decreased by CON at each iteration. Max size of tableau is set by NTAB. Return when error is SAFE worse than the best so far.
Implicit None
INTEGER, parameter :: NTAB=40
! original: CON=1.4
Real(dp), parameter :: CON=1.4_dp,CON2=CON*CON,BIG=1.D30,safe=20.0_dp
REAL(dp),Intent(in) :: h,x
Real(dp) :: err_int
Real(dp),Intent(out) :: err
Real(dp), EXTERNAL :: func
INTEGER i,j
INTEGER,Intent(out) :: iout
REAL(dp) :: errt,fac,hh,a(NTAB,NTAB)
if (h.eq.0.) write(*,*) 'h must be nonzero in dfridr'
hh=h
a(1,1)=(func(x+hh)-func(x-hh))/(2._dp*hh)
dfridr = a(1,1) ! the zero-th order solution
err_int=BIG
iout=2
do i=2,NTAB
! Successive columns in the Neville tableau will go to smaller
! stepsizes and higher orders of extrapolation.
  hh=hh/CON
  a(1,i)=(func(x+hh)-func(x-hh))/(2._dp*hh)
  ! Try new, smaller stepsize.
  fac=CON2
  do j=2,i
    ! Compute extrapolations of various orders, requiring no new
    ! function evaluations.
    a(j,i)=(a(j-1,i)*fac-a(j-1,i-1))/(fac-1._dp)
    fac=CON2*fac
    errt=max(abs(a(j,i)-a(j-1,i)),abs(a(j,i)-a(j-1,i-1)))
    ! The error strategy is to compare each new extrapolation to one order lower, both at
    ! the present stepsize and the previous one.
    if (errt.le.err_int) then
    ! If error is decreased, save the improved answer.
       err_int=errt
      dfridr=a(j,i)
    endif
  enddo
  if(abs(a(i,i)-a(i-1,i-1)).ge.SAFE*err_int) then
  iout=2*i
  exit
  end if
  ! If higher order is worse by a signicant factor SAFE, then quit early.
enddo
err=err_int
END function

! Subroutine dfridrMulDimDummy(dfunc,d,x,h,err,der)
! EXTERNAL :: dfunc
! Integer, Intent(in) :: d
! Real(dp), Intent(out) :: der(d), err
! REAL(dp),Intent(in) :: h,x
! INTEGER, parameter :: NTAB=40
! Real(dp), parameter :: CON=1.4_dp,CON2=CON*CON,BIG=1.D30,SAFE=20.0_dp
! Real(dp) :: err_int, fm(d),  fp(d)
! INTEGER :: i,j
! Real(dp), Allocatable :: a(:,:,:)
! REAL(dp) :: errt,fac,hh
!
! Allocate( a(d,NTAB,NTAB) )
!
!
! Write(*,*) "a"
! der = 0._dp
! End subroutine dfridrMulDimDummy

Subroutine dfridrMulDim(dfunc,d,x,h,err,der)
! algorithm based on
! Ridders, C.J.F. 1982,
! Advances in Engineering Software
! vol. 4, no. 2, pp. 75–76.

! Returns the derivative of a function func at a point x
! by Ridders' method of polynomial extrapolation.
! The value h is input as an estimated initial stepsize; it need not be small, but rather should
! be an increment in x over which func changes substantially.
! An estimate of the error in the derivative is returned as err.
! Parameters: Stepsize is decreased by CON at each iteration. Max size of tableau is set by NTAB. Return when error is SAFE worse than the best so far.
Implicit None
EXTERNAL :: dfunc
INTEGER, parameter :: NTAB=40
! original: CON=1.4
Integer, Intent(in) :: d
Real(dp), Intent(out) :: der(d)
Real(dp), parameter :: CON=1.4_dp,CON2=CON*CON,BIG=1.D30,safe=20.0_dp
REAL(dp),Intent(in) :: h,x
Real(dp) :: err_int, fm(d),  fp(d)
Real(dp),Intent(out) :: err
INTEGER :: i,j
Real(dp), Allocatable :: a(:,:,:)
REAL(dp) :: errt,fac,hh

Allocate( a(d,NTAB,NTAB) )

if (h.eq.0.) write(*,*) 'h must be nonzero in dfridr'
hh=h
Call dfunc(x+hh,fp)
Call dfunc(x-hh,fm)
a(:,1,1)=(fp-fm)/(2._dp*hh)
der = a(:,1,1) ! the zero-th order solution
err_int=BIG
do i=2,NTAB
! Successive columns in the Neville tableau will go to smaller
! stepsizes and higher orders of extrapolation.
  hh=hh/CON
Call dfunc(x+hh,fp)
Call dfunc(x-hh,fm)
  a(:,1,i)=(fp-fm)/(2._dp*hh)
  ! Try new, smaller stepsize.
  fac=CON2
  do j=2,i
    ! Compute extrapolations of various orders, requiring no new
    ! function evaluations.
    a(:,j,i)=(a(:,j-1,i)*fac-a(:,j-1,i-1))/(fac-1._dp)
    fac=CON2*fac
    errt=max(maxval(abs(a(:,j,i)-a(:,j-1,i))),maxval(abs(a(:,j,i)-a(:,j-1,i-1))))
    ! The error strategy is to compare each new extrapolation to one order lower, both at
    ! the present stepsize and the previous one.
    if (errt.le.err_int) then
    ! If error is decreased, save the improved answer.
       err_int=errt
      der=a(:,j,i)
    endif
  enddo
  if(maxval(abs(a(:,i,i)-a(:,i-1,i-1))).ge.SAFE*err_int) then
  exit
  end if
  ! If higher order is worse by a signicant factor SAFE, then quit early.
enddo
err=err_int
Deallocate(a)
END Subroutine

Real(dp) FUNCTION D2FRIDRMIXED(FUNC,X,Y,HX,HY,ERR)
IMPLICIT NONE
INTEGER NTAB
Real(dp) :: ERR,HX,HY,X,Y,FUNC,CON,CON2,BIG,SAFE
PARAMETER(CON=1.4_dp,CON2=CON*CON,BIG=1.0E+30_dp,NTAB=40,safe=20.0_dp)
EXTERNAL FUNC
INTEGER I,J
Real(dp) :: ERRT,FAC,HHX,HHY,A(NTAB,NTAB)
! IF(HX.EQ.0.0_dp) PAUSE 'HX MUST BE NONZERO IN DFRIDR'
! IF(HY.EQ.0.0_dp) PAUSE 'HY MUST BE NONZERO IN DFRIDR'
HHX=HX
HHY=HY
A(1,1)=(FUNC(X+HHX,Y+HHY)-FUNC(X+HHX,Y-HHY) &
& -FUNC(X-HHX,Y+HHY)+FUNC(X-HHX,Y-HHY))/(4*HHX*HHY)
ERR=BIG
DO I=2,NTAB
HHX=HHX/CON
HHY=HHY/CON
A(1,I)=(FUNC(X+HHX,Y+HHY)-FUNC(X+HHX,Y-HHY) &
& -FUNC(X-HHX,Y+HHY)+FUNC(X-HHX,Y-HHY))/(4.0_dp*HHX*HHY)
FAC=CON2
DO J=2,I
A(J,I)=(A(J-1,I)*FAC-A(J-1,I-1))/(FAC-1.0_dp)
FAC=CON2*FAC
ERRT=MAX1(ABS(A(J,I)-A(J-1,I)),ABS(A(J,I)-A(J-1,I-1)))
IF (ERRT.LE.ERR) THEN
ERR=ERRT
D2FRIDRMIXED=A(J,I)
ENDIF
ENDDO
IF(ABS(A(I,I)-A(I-1,I-1)).GE.SAFE*ERR) RETURN
ENDDO
RETURN
END function

Real(dp) FUNCTION D2FRIDR(FUNC,X,H,ERR)
IMPLICIT NONE
INTEGER NTAB
Real(dp) :: ERR,H,X,FUNC,CON,CON2,BIG,SAFE
PARAMETER(CON=1.4_dp,CON2=CON*CON,BIG=1.0E+30_dp,NTAB=40,safe=20.0_dp)
EXTERNAL FUNC
INTEGER I,J
Real(dp) :: ERRT,FAC,HH,A(NTAB,NTAB)

! Write(*,*) "X", X, H

! IF(H.EQ.0.0_dp) PAUSE 'H MUST BE NONZERO IN DFRIDR'
HH=H
A(1,1)=(FUNC(X+HH)-2.0_dp*FUNC(X)+FUNC(X-HH))/(HH**2.0_dp)
ERR=BIG
DO I=2,NTAB
HH=HH/CON
! Write(*,*) "X", X, HH
A(1,I)=(FUNC(X+HH)-2.0_dp*FUNC(X)+FUNC(X-HH))/(HH**2.0_dp)
! Write(*,*) "end"
FAC=CON2
DO J=2,I
A(J,I)=(A(J-1,I)*FAC-A(J-1,I-1))/(FAC-1.0_dp)
FAC=CON2*FAC
ERRT=MAX1(ABS(A(J,I)-A(J-1,I)),ABS(A(J,I)-A(J-1,I-1)))
IF (ERRT.LE.ERR) THEN
ERR=ERRT
D2FRIDR=A(J,I)
ENDIF
ENDDO
IF(ABS(A(I,I)-A(I-1,I-1)).GE.SAFE*ERR) RETURN
ENDDO
RETURN
END function

Subroutine D2FRIDRMIXEDmuldim(dFUNC,D,X,Y,HX,HY,ERR,der)
IMPLICIT NONE
EXTERNAL dFUNC
Integer, Intent(in) :: d
Real(dp), Intent(out) :: der(d)
Real(dp) :: ERR,HX,HY,X,Y,FUNC,CON,CON2,BIG,SAFE
Real(dp) :: fxpyp(d), fxpym(d), fxmyp(d), fxmym(d)
INTEGER, Parameter :: NTAB=40
PARAMETER(CON=1.4_dp,CON2=CON*CON,BIG=1.0E+30_dp,safe=20.0_dp)
Integer :: I,J
Real(dp) :: ERRT,FAC,HHX,HHY
Real(dp), Allocatable :: a(:,:,:)

Allocate( a(d,NTAB,NTAB) )

! IF(HX.EQ.0.0_dp) PAUSE 'HX MUST BE NONZERO IN DFRIDR'
! IF(HY.EQ.0.0_dp) PAUSE 'HY MUST BE NONZERO IN DFRIDR'
HHX=HX
HHY=HY

Call dFUNC(X+HHX,Y+HHY,fxpyp)
Call dFUNC(X+HHX,Y-HHY,fxpym)
Call dFUNC(X-HHX,Y+HHY,fxmyp)
Call dFUNC(X-HHX,Y-HHY,fxmym)

A(:,1,1)=(fxpyp-fxpym -fxmyp+fxmym)/(4*HHX*HHY)
ERR=BIG
DO I=2,NTAB
HHX=HHX/CON
HHY=HHY/CON

Call dFUNC(X+HHX,Y+HHY,fxpyp)
Call dFUNC(X+HHX,Y-HHY,fxpym)
Call dFUNC(X-HHX,Y+HHY,fxmyp)
Call dFUNC(X-HHX,Y-HHY,fxmym)

A(:,1,I)=(fxpyp-fxpym -fxmyp+fxmym)/(4.0_dp*HHX*HHY)
FAC=CON2
DO J=2,I
A(:,J,I)=(A(:,J-1,I)*FAC-A(:,J-1,I-1))/(FAC-1.0_dp)
FAC=CON2*FAC
ERRT=MAX1(MaxVal(ABS(A(:,J,I)-A(:,J-1,I))),MaxVal(ABS(A(:,J,I)-A(:,J-1,I-1))))
IF (ERRT.LE.ERR) THEN
ERR=ERRT
der=A(:,J,I)
ENDIF
ENDDO
IF(MaxVal(ABS(A(:,I,I)-A(:,I-1,I-1))).GE.SAFE*ERR) Exit
ENDDO

Deallocate(a)

END Subroutine

Subroutine D2FRIDRmuldim(dFUNC,d,X,H,ERR,der)
IMPLICIT NONE
EXTERNAL dFUNC
INTEGER, Parameter :: NTAB=40
Integer, Intent(in) :: d
Real(dp), Intent(out) :: der(d)
Real(dp) :: ERR,H,X,FUNC,CON,CON2,BIG,SAFE
PARAMETER(CON=1.4_dp,CON2=CON*CON,BIG=1.0E+30_dp,safe=20.0_dp)
INTEGER I,J
Real(dp) :: ERRT,FAC,HH, fn(d), f(d),fp(d)
Real(dp), Allocatable :: a(:,:,:)

Allocate( a(d,NTAB,NTAB) )
! Write(*,*) "X", X, H

! IF(H.EQ.0.0_dp) PAUSE 'H MUST BE NONZERO IN DFRIDR'
HH=H

Call dFunc(x+hh,fp)
Call dFunc(x,f)
Call dFunc(x-hh,fn)

A(:,1,1)=(fp-2.0_dp*f+fn)/(HH**2.0_dp)
ERR=BIG
DO I=2,NTAB
HH=HH/CON

Call dFunc(x+hh,fp)
Call dFunc(x,f)
Call dFunc(x-hh,fn)

A(:,1,I)=(fp-2.0_dp*f+fn)/(HH**2.0_dp)
! Write(*,*) "end"
FAC=CON2
DO J=2,I
A(:,J,I)=(A(:,J-1,I)*FAC-A(:,J-1,I-1))/(FAC-1.0_dp)
FAC=CON2*FAC
ERRT=MAX1(MaxVal(ABS(A(:,J,I)-A(:,J-1,I))),MaxVal(ABS(A(:,J,I)-A(:,J-1,I-1))))
IF (ERRT.LE.ERR) THEN
ERR=ERRT
der=A(:,J,I)
ENDIF
ENDDO
IF(MaxVal(ABS(A(:,I,I)-A(:,I-1,I-1))).GE.SAFE*ERR) RETURN
ENDDO
Deallocate(a)
END Subroutine

Real(dp) function partialDiff_Ridders(func,x,k,n,err,h,iout)
! wrapper function to calculate the partial derivative of func w.r.t. to k-th variable
! evaluated at the n-dim. point x, starting with stepsize h.
! returns error estimate err
Implicit None
Integer,Intent(in) :: n,k
Integer :: iout
Real(dp),External :: func
Real(dp),Intent(in) :: x(n), h
Real(dp),Intent(out) :: err
Real(dp) :: xtemp(n)

partialDiff_Ridders=dfridr(func_k,x(k),Min(1._dp,hstep_pn*x(k)),err,iout)
! partialDiff_Ridders=dfridr(func_k,x(k),hstep_pn*x(k),err,iout)
  Contains
  Real(dp) function func_k(y)
  ! projects out other components
  Implicit None
  Real(dp) :: y
  xtemp = x
  xtemp(k)=y
  func_k = func(xtemp)
  End function
End function

function partialDiff_RiddersMulDim(func,d,x,k,n,err)
! wrapper function to calculate the partial derivative of func w.r.t. to k-th variable
! evaluated at the n-dim. point x, starting with stepsize h.
! returns error estimate err
Implicit None
External :: func
Integer,Intent(in) :: n,k,d
Integer :: iout
Real(dp) :: partialDiff_RiddersMulDim(d)
Real(dp) :: test(d)
Real(dp),Intent(in) :: x(n)
Real(dp),Intent(out) :: err
Real(dp) :: xtemp(n),hrel(n)

! hrel(1) = hstep_sa_vd
! hrel(2) = hstep_sa_vu

! Write(*,*) x
Call dfridrMulDim(func_k,d,x(k),Min(1._dp,hstep_sa*x(k)),err,test)
! Call dfridrMulDim(func_k,d,x(k),hstep_sa*x(k),err,test)
partialDiff_RiddersMulDim = test
! dfridrMulDim(dfunc,d,x,h,err,der)

  Contains

  subroutine func_k(y,out)
  ! projects out other components
  Implicit None
  Real(dp),Intent(in) :: y
  Real(dp),Intent(out) :: out(d)
  xtemp = x
  xtemp(k)=y
  Call func(xtemp,out)
!   func_k1 = func(xtemp)
  End subroutine

End function

function partialDiffXY_RiddersMulDim(func,d,x,k1,k2,n,err)
! wrapper function to calculate second partial derivative w.r.t. k1-th variable, then k2-th
! evaluated at n-dim. point x
! applies partialDiff_Ridders twice
Implicit None
External :: func
Integer,Intent(in) :: n,k1,k2,d
Real(dp) :: partialDiffXY_RiddersMulDim(d)
Integer :: itemp=0,i1
Real(dp),Intent(in) :: x(n)
Real(dp),Intent(out) :: err
Real(dp) :: xtemp(n), hrel(n)

! hrel(1) = hstep_sa_vd
! hrel(2) = hstep_sa_vu

If (k1.eq.k2) Then
!  Call D2FRIDRmuldim(func_k1,d,x(k1),hstep_sa*x(k1),err,partialDiffXY_RiddersMulDim)
!  Call D2FRIDRmuldim(func_k1,d,x(k1),hstep_sa,err,partialDiffXY_RiddersMulDim)
 Call D2FRIDRmuldim(func_k1,d,x(k1),Min(1._dp,x(k1)*hstep_sa),err,partialDiffXY_RiddersMulDim)
Else
!  Call D2FRIDRMIXEDmuldim(func_k1k2,d,x(k2),x(k1),hstep_sa*x(k2), hstep_sa*x(k1),err,partialDiffXY_RiddersMulDim)
!  Call D2FRIDRMIXEDmuldim(func_k1k2,d,x(k2),x(k1),hstep_sa, hstep_sa,err,partialDiffXY_RiddersMulDim)
Call D2FRIDRMIXEDmuldim(func_k1k2,d,x(k2),x(k1),Min(1._dp,hstep_sa*x(k2)), Min(1._dp, hstep_sa*x(k1)),err,partialDiffXY_RiddersMulDim)
end if

Contains

  subroutine func_k1(y,out)
  ! projects out other components
  Implicit None
  Real(dp),Intent(in) :: y
  Real(dp),Intent(out) :: out(d)
  xtemp = x
  xtemp(k1)=y
  Call func(xtemp,out)
!   func_k1 = func(xtemp)
  End subroutine

  subroutine func_k1k2(y1,y2,out)
  ! projects out other components
  Implicit None
  Real(dp),Intent(in) :: y1,y2
  Real(dp),Intent(out) :: out(d)
  xtemp = x
  xtemp(k2)=y1
  xtemp(k1)=y2
  Call func(xtemp,out)
!   func_k1k2 = func(xtemp)
  End subroutine

End function

Subroutine ScanEffPot(func,func2,x0,y0,hx,hy,N)
Implicit none
Real(dp),External :: func,func2
Real(dp),Intent(in) :: x0,y0,hx,hy
Integer,intent(in) :: N
Real(dp) :: x,y,dx,dy
Integer :: i,j
open(394729,file="scaneffpot.out",status="replace")
open(394728,file="scaneffpot2L.out",status="replace")
write(394729,*) x0,y0,func((/x0,y0/))
write(394728,*) x0,y0,func2((/x0,y0/))
dx=(hx)/(N-1)
dy=(hy)/(N-1)
do i=-N+2,N
 do j=-N+2,N
  x=x0+(i-1)*dx
  y=y0+(j-1)*dy
  write(394729,*) x,y,func((/x,y/))
  write(394728,*) x,y,func2((/x,y/))
 end do
end do
close(394729)
close(394728)
End subroutine

Real(dp) function partialDiffXY_Ridders(func,x,k1,k2,n,err,h,iout)
! wrapper function to calculate second partial derivative w.r.t. k1-th variable, then k2-th
! evaluated at n-dim. point x
! applies partialDiff_Ridders twice
Implicit None
Integer,Intent(in) :: n,k1,k2
Integer :: itemp=0,i1,iout
Real(dp),External :: func
Real(dp),Intent(in) :: x(n),h
Real(dp),Intent(out) :: err
Real(dp) :: xtemp(n),hrel(n)
iout=0

! hrel(1) = hstep_sa_vd
! hrel(2) = hstep_sa_vu

! ! partialDiffXY_Ridders = partialDiff_Ridders(funcD1p,x,k2,n,err,h,i1)
If (k1.eq.k2) Then
!  write(*,*) k1,k2
! partialDiffXY_Ridders = D2FRIDR(func_k1,x(k1),hstep_pn*x(k1),err)
! partialDiffXY_Ridders = D2FRIDR(func_k1,x(k1),hstep_pn,err)
partialDiffXY_Ridders = D2FRIDR(func_k1,x(k1),Min(1._dp,hstep_pn*x(k1)),err)
Else
partialDiffXY_Ridders = D2FRIDRMIXED(func_k1k2,x(k2),x(k1),Min(1._dp,hstep_pn*x(k2)), Min(1._dp,hstep_pn*x(k1)),err)
! partialDiffXY_Ridders = D2FRIDRMIXED(func_k1k2,x(k2),x(k1),hstep_pn, hstep_pn,err)
! partialDiffXY_Ridders = D2FRIDRMIXED(func_k1k2,x(k2),x(k1),hstep_pn*x(k2), hstep_pn*x(k1),err)
end if

Contains
  Real(dp) function funcD1p(x)
  Implicit None
  Real(dp) :: x(n)
  funcD1p = partialDiff_Ridders(func,x,k1,n,err,h,itemp)
  iout = iout + itemp
  End function

  Real(dp) function func_k1(y)
  ! projects out other components
  Implicit None
  Real(dp) :: y
  xtemp = x
  xtemp(k1)=y
  func_k1 = func(xtemp)
  End function

  Real(dp) function func_k1k2(y1,y2)
  ! projects out other components
  Implicit None
  Real(dp) :: y1,y2
  xtemp = x
  xtemp(k2)=y1
  xtemp(k1)=y2
  func_k1k2 = func(xtemp)
  End function

End function

Real(dp) function partialDiffXY_Ridders2(func,x,k1,k2,n,err,h,iout)
! wrapper function to calculate second partial derivative w.r.t. k1-th variable, then k2-th
! evaluated at n-dim. point x
! applies partialDiff_Ridders twice
Implicit None
Integer,Intent(in) :: n,k1,k2
Integer :: itemp=0,i1,iout
Real(dp),External :: func
Real(dp),Intent(in) :: x(n),h(2)
Real(dp),Intent(out) :: err
iout=0
partialDiffXY_Ridders2 = partialDiff_Ridders(funcD1p,x,k2,n,err,h(k2),i1)
Contains
  Real(dp) function funcD1p(x)
  Implicit None
  Real(dp) :: x(n)
  funcD1p = partialDiff_Ridders(func,x,k1,n,err,h(k1),itemp)
  iout = iout + itemp
  End function
End function

!! These two-loop integral functions J(x),J(x,y),I(x,y,z) are taken from
!! Stephen P. Martin, arXiv:hep-ph/111209v2, 29 Mar 2002
!! FERMILAB-Pub-01/348-T

Real(dp) Function J_SMartin_1x(x,Q2)
Implicit None
! x is supposed to be a squared mass
Real(dp),Intent(in) :: x,Q2
If (Q2.le.0._dp) Then
  write(*,*) 'invalid renormalization scale!'
  return
end if
If (VerySmallM(x,Q2)) Then
   J_SMartin_1x = 0._dp
Else
   J_SMartin_1x = (x)*(zlog(Cmplx(x/Q2,0._dp,dp))-1._dp)
End If

! J_SMartin_1x = 0._dp

End Function J_SMartin_1x

Real(dp) Function J_SMartin_2x(x,y,Q2)
Implicit None
! x,y are supposed to be squared masses
! symmetric x <-> y
Real(dp),Intent(in) :: x,y,Q2
If (Q2.le.0._dp) Then
  write(*,*) 'invalid renormalization scale!'
  return
end if
If (VerySmallM(x,y,y,Q2).or.(VerySmallM(y,x,x,Q2))) Then
 J_SMartin_2x = 0
Else
 J_SMartin_2x = J_SMartin_1x(x,Q2)*J_SMartin_1x(y,Q2)
End if

! J_SMartin_2x = 0._dp

End Function J_SMartin_2x

Complex(dp) Function RFunction(x,y,z)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Complex(dp) :: temp
temp = x**2+y**2+z**2-2._dp*x*y-2._dp*x*z-2._dp*y*z
RFunction = sqrt(temp)
! If (temp.lt.0._dp) Then
!   RFunction = Cmplx(0.,+sqrt(-temp),dp)
! Else
!   RFunction = Cmplx(sqrt(temp),0.,dp)
! End If
End Function RFunction

Complex(dp) Function I_SMartin(x_in,y_in,z_in,Q2)
Implicit None
! x_in,y_in,z_in are supposed to be squared masses
! symmetric under interchange of any two of these
Real(dp),Intent(in) :: x_in,y_in,z_in,Q2
Complex(dp) :: res,x,y,z
x = x_in
y = y_in
z = z_in
If (Q2.le.0._dp) Then
  write(*,*) 'invalid renormalization scale!'
  return
end if
Call SortArguments3C(x,y,z) ! sort x<=y<=z

If (SmallM(x,y,z,Q2)) Then
 I_SMartin = I_SMartin_ex(x_in,y_in,z_in,Q2)

! !  ! I(0,y,z)
! !  If (SmallM(y,x,z,Q2)) Then
! !   If (SmallM(z,y,x,Q2)) Then
! !    I_SMartin = ZeroC ! I(0,0,0)=0
! !   Else
! !    I_SMartin = -0.5_dp*z*(log(z/Q2))**2 &
! !       & + 2*z*log(z/Q2)-2.5_dp*z-pi**2*z/6._dp
! !    ! I(0,0,z)
! !   End If
! !  Else If (SmallD(z,y)) Then
! !   ! I(0,y,y)
! ! !   Write(*,*) Real(x,dp),Real(y,dp),Real(z,dp)
! !   I_SMartin = -y*(zlog(y/Q2))**2+4._dp*y*zlog(y/Q2)-5._dp*y
! ! ! I_SMartin = 0.
! !  Else
! ! !   Write(*,*) Real(x,dp),Real(y,dp),Real(z,dp)
! !   ! I(0,y,z), z>y
! !   I_SMartin = (z-y)*(CLi2_mod(y/z)-log(z/y)*log((z-y)/Q2) &
! !   & +0.5_dp*(log(z/Q2))**2-pi**2/6._dp)  &
! !   & -2.5_dp*(z+y)+2*y*log(y/Q2)+2*z*log(z/Q2) &
! !   & -z*log(z/Q2)*log(y/Q2)
! ! ! I_SMartin =0
! !  End If

! I_SMartin = 0._dp

Else ! I(x,y,z) general case

res = Cmplx(0._dp,0._dp)
res=res + 0.5_dp*(x-y-z)*zlog(y/Q2)*zlog(z/Q2)
res=res + 0.5_dp*(y-x-z)*zlog(x/Q2)*zlog(z/Q2)
res=res + 0.5_dp*(z-x-y)*zlog(x/Q2)*zlog(y/Q2)
res=res + 2._dp*x*zlog(x/Q2)
res=res + 2._dp*y*zlog(y/Q2)
res=res + 2._dp*z*zlog(z/Q2)
res=res - 2.5_dp*(x+y+z)
res=res - 0.5_dp*XiFunction(x,y,z)

! res = 0._dp

I_SMartin = res

End If

! I_SMartin = 0._dp

End Function I_SMartin

Complex(dp) Function XiFunction(x0,y0,z0)
Implicit None
Complex(dp), Intent(in) :: x0,y0,z0
Complex(dp) :: x,y,z
Complex(dp) :: res,R
x=x0
y=y0
z=z0
Call SortArguments3C(x,y,z)
R=Rfunction(x,y,z)
res = Cmplx(0.,0.,dp)
res = res + 2._dp*log((z+x-y-R)/(2._dp*z))*log((z+y-x-R)/(2._dp*z))
res = res - log(x/z)*log(y/z)
res = res - 2._dp*CLi2_mod((z+x-y-R)/(2._dp*z))
res = res - 2._dp*CLi2_mod((z+y-x-R)/(2._dp*z))
res = res + (pi**2)/3._dp
res = R*res
XiFunction = res
End Function XiFunction

!! sorts three real arguments a,b,c from small to large
!! and returns them
Subroutine SortArguments3(a,b,c)
Implicit None
Real(dp), Intent(inout) :: a,b,c
Real(dp) :: x,y,z
x=a ! assume a is smallest
y=b
z=c
If (b.le.a) Then
 x=b
 y=a
 z=c
End If
If (c.le.x) Then
 x=c
 y=a
 z=b
End If
! compare last two elements
If (z.le.y) Then
 a=x ! output
 b=z
 c=y
Else
 a=x !output
 b=y
 c=z
End If
End Subroutine SortArguments3

!! sorts three complex arguments a,b,c from small to large
!! and returns them
Subroutine SortArguments3C(a,b,c)
Implicit None
Complex(dp), Intent(inout) :: a,b,c
Complex(dp) :: x,y,z
x=a ! assume a is smallest
y=b
z=c
If (Abs(b).le.Abs(a)) Then
 x=b
 y=a
 z=c
End If
If (Abs(c).le.Abs(x)) Then
 x=c
 y=a
 z=b
End If
! compare last two elements
If (Abs(z).le.Abs(y)) Then
 a=x ! output
 b=z
 c=y
Else
 a=x !output
 b=y
 c=z
End If
End Subroutine SortArguments3C

 Complex(DP) Function CLI2_mod(Z)
 !--------------------------------------------------------------
 !     routine for the complex dilogarithm function
 !--------------------------------------------------------------
 Implicit None
  !-------
  ! input
  !-------
  Complex(DP), Intent(in) :: Z

  !-----------------
  ! local variables
  !-----------------
  Complex(DP) :: sumC, cy, cz, cz2, CLI2
  Real(dp) :: rz, iz, az
  Integer :: i1, jsgn, ipi12
  !---------------------------------------------
  ! Bernulli numbers / (2 n + 1)!
  !---------------------------------------------
  Real(dp), Parameter :: bf(20) = (/ - 1._dp/4._dp, + 1._dp/36._dp        &
       & , - 1._dp/36.e2_dp, + 1._dp/21168.e1_dp,  - 1._dp/108864.e2_dp   &
       & , + 1._dp/52690176.e1_dp,  - 691._dp/16999766784.e3_dp           &
       & , + 1._dp/1120863744.e3_dp,  - 3617._dp/18140058832896.e4_dp     &
       & , + 43867._dp/97072790126247936.e3_dp                            &
       & , - 174611._dp/168600109166641152.e5_dp                          &
       & , + 77683._dp/32432530090601152512.e4_dp                         &
       & , - 236364091._dp/4234560341829359173632.e7_dp                   &
       & , + 657931._dp/5025632054039239458816.e6_dp                      &
       & , - 3392780147._dp/109890470493622010006470656.e7_dp             &
       & , +172.3168255201_dp/2355349904102724211909.3102313472e6_dp      &
       & , -770.9321041217_dp/4428491985594062112714.2791446528e8_dp      &
       & ,  4.1576356446138997196178996207752266734882541595116e-29_dp    &
       & , -9.9621484882846221031940067024558388498548600173945e-31_dp    &
       & ,  2.3940344248961653005211679878937495629342791569329e-32_dp    &
       & /)

  rz = Real(z,dp)
  iz = Aimag(z)
  az = Sqrt(rz**2 + iz**2)
  !------------------
  ! special cases
  !------------------
  If (iz.Eq.0._dp) Then
    If (rz.gt.1._dp) Then
    CLi2_mod = Cmplx( Li2(rz), -pi*log(rz),dp)
    Else
    CLi2_mod = Cmplx( Li2(rz), 0.,dp)
    End If
   Return
  Else If (az.Lt.Epsilon(1._dp)) Then
   CLi2_mod = z
   Return
  End If
  !-----------------------------------------------------
  ! transformation to |z|<1, Re(z)<=0.5
  !-----------------------------------------------------
  If (rz.Le.0.5_dp) Then
   If (az.Gt.1._dp) Then
    cy = -0.5_dp * Log(-z)**2
    cz = - Log(1._dp - 1._dp / z)
    jsgn = -1
    ipi12 = -2
   Else !  (az.le.1._dp)
    cy = 0
    cz = - Log(1._dp - z)
    jsgn = 1
    ipi12 = 0
   End If
  Else ! rz.gt.0.5_dp
   If (az.Le.Sqrt(2*rz)) Then
    cz = - Log(z)
    cy = cz * Log(1._dp - z)
    jsgn = -1
    ipi12 = 2
   Else ! (az.gt.Sqrt(2*rz))
    cy = -0.5_dp * Log(-z)**2
    cz = - Log(1._dp - 1._dp / z)
    jsgn = -1
    ipi12 = -2
   End If
  End If
  !--------------------------------------------
  ! the dilogarithm
  !--------------------------------------------
  cz2 = cz**2
  sumC = cz2 * bf(20)
  Do i1=3,19
   sumC = cz2 * ( sumC + bf(22-i1) )
  End Do
  ! watch the powers of z
  sumC = cz + cz2 * (bf(1) + cz * (bf(2) + sumC))
  If (jsgn.Eq.1) Then
   CLi2 = sumC + cy
  Else
   CLi2 = - sumC + cy
  End If
  If (ipi12.Ne.0) Cli2 = Cli2 + ipi12 * pi2o12

  CLI2_mod = CLI2
 End Function CLI2_mod

!--------------------------------------------
! 2-Loop functions for different contributions
!
!--------------------------------------------

  !--------------------------------------------
  ! three scalars, two cubic couplings
  !--------------------------------------------
Complex(dp) Function Fep_SSS(x,y,z,Q2)
Implicit None
Real(dp), Intent(in) :: x,y,z,Q2
 Fep_SSS = -I_SMartin(x,y,z,Q2)
End Function Fep_SSS

  !--------------------------------------------
  ! two scalars, one quartic couplings
  !--------------------------------------------
Complex(dp) Function Fep_SS(x,y,Q2)
Implicit None
Real(dp), Intent(in) :: x,y,Q2
 Fep_SS = J_SMartin_2x(x,y,Q2)
End Function Fep_SS

  !--------------------------------------------
  ! one scalar, two fermions, two cubic couplings
  !--------------------------------------------
Complex(dp) Function Fep_FFS(x,y,z,Q2)
Implicit None
Real(dp), Intent(in) :: x,y,z,Q2
Complex(dp) :: res
res=Cmplx(0.,0.,dp)
res=res+J_SMartin_2x(x,y,Q2)-J_SMartin_2x(x,z,Q2)-J_SMartin_2x(y,z,Q2)
res=res+(x+y-z)*I_SMartin(x,y,z,Q2)
Fep_FFS=res
End Function Fep_FFS

  !--------------------------------------------
  ! like FFS, with mass insertion
  !--------------------------------------------
Complex(dp) Function Fep_FFSbar(x,y,z,Q2)
Implicit None
Real(dp), Intent(in) :: x,y,z,Q2
Fep_FFSbar=2*I_SMartin(x,y,z,Q2)
End Function Fep_FFSbar

  !--------------------------------------------
  ! two scalars, one vector, two cubic couplings
  !--------------------------------------------
Complex(dp) Function Fep_SSV(x,y,z,Q2)
Implicit None
Real(dp), Intent(in) :: x,y,z,Q2
Complex(dp) :: res
res=Cmplx(0.,0.,dp)

If (SmallM(z,x,y,Q2)) Then
  ! f_SSV(x,y,0) special case
 res=res+(x+y)**2+3._dp*(x+y)*I_SMartin(x,y,0._dp,Q2)
 res=res+3._dp*J_SMartin_2x(x,y,Q2)
 res=res-2._dp*x*J_SMartin_1x(x,Q2)
 res=res-2._dp*y*J_SMartin_1x(y,Q2)
Else
  ! f_SSV(x,y,z) general case
res = (-x**2-y**2-z**2+2._dp*(x*y+x*z+y*z))*I_SMartin(x,y,z,Q2)
res = res+I_SMartin(0._dp,x,y,Q2)*((x-y)**2)
res = res+(y-x-z)*J_SMartin_2x(x,z,Q2)+(x-y-z)*J_SMartin_2x(y,z,Q2)
res = res + z*J_SMartin_2x(x,y,Q2)
res = res/z
res = res+2._dp*(x+y-z/3._dp)*J_SMartin_1x(z,Q2)
End If

Fep_SSV = res
End Function Fep_SSV

  !--------------------------------------------
  ! one scalar, one vector, one quartic coupling
  !--------------------------------------------
Complex(dp) Function Fep_VS(x,y,Q2)
Implicit None
Real(dp), Intent(in) :: x,y,Q2
 Fep_VS = 3._dp*J_SMartin_2x(x,y,Q2)
End Function Fep_VS

  !--------------------------------------------
  ! one scalar, two vectors, two cubic couplings
  !--------------------------------------------
Complex(dp) Function Fep_VVS(x,y,z,Q2)
Implicit None
Real(dp), Intent(in) :: x,y,z,Q2
Real(dp) :: xt
Complex(dp) :: res
res=Cmplx(0.,0.,dp)
If (SmallM(x,y,z,Q2)) Then
 If (SmallM(y,x,z,Q2)) Then
  ! f_VSS(0,0,z)
  res=-3._dp*I_SMartin(0._dp,0._dp,z,Q2)
  res=res+1.5_dp*J_SMartin_1x(z,Q2)-0.25_dp*z
  Fep_VVS=res
  return
 Else
  xt=y
 End If
Else ! x>0
 If (SmallM(y,x,z,Q2)) Then
  xt=x
 Else ! x>0 and y>0 general case
   ! f_VSS(x,y,z)
 res=(-x**2-y**2-z**2)
 res=res-10._dp*x*y+2._dp*x*z+2._dp*y*z
 res=res*I_SMartin(x,y,z,Q2)
 res=res+(x-z)**2*I_SMartin(0._dp,x,z,Q2)
 res=res+(y-z)**2*I_SMartin( 0._dp,y,z,Q2)
 res=res-z**2*I_SMartin(0._dp,0._dp,z,Q2)
 res=res+(z-x-y)*J_SMartin_2x(x,y,Q2)
 res=res+y*J_SMartin_2x(x,z,Q2)
 res=res+z*J_SMartin_2x(y,z,Q2)
 res=res/(4._dp*x*y)
 res=res+0.5_dp*J_SMartin_1x(x,Q2)
 res=res+0.5_dp*J_SMartin_1x(y,Q2)
 Fep_VVS=res
 Return
 End If
End If
! case f_VSS(xt,0,z) with xt=x or y
res=xt/4._dp+0.5_dp*z
res=res-0.75_dp*z/xt*I_SMartin(0._dp,0._dp,z,Q2)
res=res+(0.75_dp*z/xt-9._dp/4._dp)*I_SMartin(0._dp,xt,z,Q2)
res=res+0.75_dp/xt*J_SMartin_2x(xt,z,Q2)
Fep_VVS=res
End Function Fep_VVS

  !--------------------------------------------
  ! two fermions, one vector, two cubic couplings
  !--------------------------------------------
Complex(dp) Function Fep_FFV(x,y,z,Q2)
Implicit None
Real(dp), Intent(in) :: x,y,z,Q2
Complex(dp) :: res
res=Cmplx(0.,0.,dp)
If (SmallM(z,x,y,Q2)) Then
 ! f_FFV(x,y,0)
 res=-(x+y)**2
 res=res+2._dp*x*J_SMartin_1x(x,Q2)
 res=res+2._dp*y*J_SMartin_1x(y,Q2)
 Fep_FFV=res
 Return
Else
 ! f_FFV(x,y,z) general case
 res=x**2+y**2-2._dp*z**2
 res=res-2._dp*x*y+x*z+y*z
 res=res*I_SMartin(x,y,z,Q2)
 res=res-(x-y)**2*I_SMartin(0._dp,x,y,Q2)
 res=res+(x-y-2._dp*z)*J_SMartin_2x(x,z,Q2)
 res=res+(y-x-2._dp*z)*J_SMartin_2x(y,z,Q2)
 res=res+2._dp*z*J_SMartin_2x(x,y,Q2)
 res=res/z
 res=res+2._dp*(-x-y+z/3._dp)*J_SMartin_1x(z,Q2)
 Fep_FFV=res
 Return
End If
End Function Fep_FFV

  !--------------------------------------------
  ! like FFV with mass insertion
  !--------------------------------------------
Complex(dp) Function Fep_FFVbar(x,y,z,Q2)
Implicit None
Real(dp), Intent(in) :: x,y,z,Q2
 Fep_FFVbar=6._dp*I_SMartin(x,y,z,Q2)
End Function Fep_FFVbar

  !--------------------------------------------
  ! sum of three diagrams:
  ! two vectors, one quartic coupling
  ! + three vectors, two cubic couplings
  ! + one vector, two ghosts, two cubic couplings
  !--------------------------------------------
Complex(dp) Function Fep_gauge(a,b,c,Q2)
Implicit None
Real(dp), Intent(in) :: a,b,c,Q2
Real(dp) :: x,y,z
 Complex(dp) :: res
 res=Cmplx(0.,0.,dp)
x=a
y=b
z=c
Call SortArguments3(x,y,z)
If (SmallM(x,y,z,Q2)) Then
 If (SmallM(y,x,z,Q2)) Then
  If (SmallM(z,y,x,Q2)) Then
   res=0._dp
  Else
  ! f_gauge(0,0,z)
  res=13*z*I_SMartin(0._dp,0._dp,z,Q2)
  res=res-71._dp/6._dp*z*J_SMartin_1x(z,Q2)
  res=res+19._dp/4._dp*z**2
  End If
 Else
 ! f_gauge(0,y,z)
 res=43._dp*z**2*y+43._dp*z*y**2-7._dp*z**3-7._dp*y**3
 res=res*I_SMartin(0._dp,z,y,Q2)
 res=res+(2._dp*y+7._dp*z)*z**2*I_SMartin(0._dp,0._dp,z,Q2)
 res=res+(2._dp*z+7._dp*y)*y**2*I_SMartin(0._dp,0._dp,y,Q2)
 res=res+(34*z*y-7*z**2-7*y**2)*J_SMartin_2x(z,y,Q2)
 res=res/(4._dp*z*y)
 res=res+3*z**2+3*y**2+5.5_dp*z*y
 res=res-25._dp/3._dp*z*J_SMartin_1x(z,Q2)
 res=res-25._dp/3._dp*y*J_SMartin_1x(y,Q2)
 res=res+5*y*J_SMartin_1x(z,Q2)
 res=res+5*z*J_SMartin_1x(y,Q2)
 End If
Else
! f_gauge(x,y,z) general case
 res=fgauge_aux(x,y,z,Q2)
 res=res+fgauge_aux(y,x,z,Q2)
 res=res+fgauge_aux(z,y,x,Q2)
End If

Fep_gauge=res
End Function Fep_gauge

Complex(dp) Function fgauge_aux(x,y,z,Q2)
 Real(dp), Intent(in) :: x,y,z,Q2
 Complex(dp) :: res
 res=Cmplx(0.,0.,dp)
 res=-x**4-8*x**3*(y+z)+32*x**2*y*z+18*y**2*z**2
 res=res*I_SMartin(x,y,z,Q2)
 res=res+(y-z)**2*(y**2+10*y*z+z**2)*I_SMartin(0._dp,y,z,Q2)
 res=res+x**2*(2*y*z-x**2)*I_SMartin(0._dp,0._dp,x,Q2)
 res=res+(x**2-9*(y**2+z**2-x*y-x*z)+14*y*z)*x*J_SMartin_2x(y,z,Q2)
 res=res+(22*(y+z)-40*x/3._dp)*x*y*z*J_SMartin_1x(x,Q2)
 res=res/(4._dp*x*y*z)
 fgauge_aux=res
End Function fgauge_aux

Logical Function SmallDC(x,y)
Implicit None
Complex(dp), Intent(in) :: x,y
If (Max(Abs(x),Abs(y)).lt.epsD) Then
 SmallDC = .True.
Else If ((Abs(x-y)/Max(Abs(x),Abs(y))).le.epsD) Then
 SmallDC = .True.
Else
 SmallDC = .False.
End if
End Function SmallDC

Logical Function SmallDR(x,y)
Implicit None
Real(dp), Intent(in) :: x,y
If (Max(Abs(x),Abs(y)).lt.epsD) Then
 SmallDR = .True.
Else If ((Abs(x-y)/Max(Abs(x),Abs(y))).le.epsD) Then
 SmallDR = .True.
Else
 SmallDR = .False.
End if
End Function SmallDR

Logical Function SmallMR(x,y,z,Q)
Implicit None
Real(dp), Intent(in) :: x,y,z
Real(dp), Intent(in) :: Q
If (Max(Max(Abs(x),Abs(y)),Abs(z)).le.epsM) Then
 SmallMR = .True.
Else If ((Abs(x)/Max(Q,Max(Abs(y),Abs(z)))).le.epsM) Then
 SmallMR = .True.
Else
 SmallMR = .False.
End if
End Function SmallMR

Logical Function SmallMC(x,y,z,Q)
Implicit None
Complex(dp), Intent(in) :: x,y,z
Real(dp), Intent(in) :: Q
If (Max(Max(Abs(x),Abs(y)),Abs(z)).le.epsM) Then
 SmallMC = .True.
Else If ((Abs(x)/Max(Q,Max(Abs(y),Abs(z)))).lt.epsM) Then
 SmallMC = .True.
Else
 SmallMC = .False.
End if
End Function SmallMC

Logical Function SmallMR2(x,y)
Implicit None
Real(dp), Intent(in) :: x,y
If (Max(Abs(x),Abs(y)).le.epsM) Then
 SmallMR2 = .True.
Else If (Abs(x/y).le.epsM) Then
 SmallMR2 = .True.
Else
 SmallMR2 = .False.
End if
End Function SmallMR2

Logical Function SmallMC2(x,y)
Implicit None
Complex(dp), Intent(in) :: x,y
If (Max(Abs(x),Abs(y)).le.epsM) Then
 SmallMC2 = .True.
Else If (Abs(x/y).le.epsM) Then
 SmallMC2 = .True.
Else
 SmallMC2 = .False.
End if
End Function SmallMC2

End Module EffPotFunctions


      subroutine matevl(xv,yv,zv,xpl,ypl,zpl,vx,vy,vz)
C...01/09/78
      common /gftrg2/bitx,bity,t(4,4)
      r=sqrt(vx**2+vy**2)
      t(1,1)=-vy/r
      t(1,2)=vx/r
      t(1,3)=0
      r=sqrt(vx**2+vy**2+vz**2)
      t(3,1)=vx/r
      t(3,2)=vy/r
      t(3,3)=vz/r
      t(2,1)=t(3,2)*t(1,3)-t(1,2)*t(3,3)
      t(2,2)=-t(3,1)*t(1,3)+t(1,1)*t(3,3)
      t(2,3)=t(3,1)*t(1,2)-t(1,1)*t(3,2)
      do 4 i=1,2
    4 t(i,4)=-t(i,1)*xv-t(i,2)*yv-t(i,3)*zv
      t(3,4)=-t(3,1)*xpl-t(3,2)*ypl-t(3,3)*zpl
      r=t(3,1)*xv+t(3,2)*yv+t(3,3)*zv+t(3,4)
      t(3,1)=t(3,1)/r
      t(3,2)=t(3,2)/r
      t(3,3)=t(3,3)/r
      t(3,4)=t(3,4)/r
      t(4,1)=-t(3,1)
      t(4,2)=-t(3,2)
      t(4,3)=-t(3,3)
      t(4,4)=1.0-t(3,4)
      return
      end


C FUNCTION DETERM.F
C
C SOURCE
C   BEVINGTON, PAGE 294.
C
C PURPOSE
C   CALCULATE THE DETERMINANT OF A SQUARE MATRIX
C
C USAGE
C   DET = DETERM (ARRAY, NORDER)
C
C DESCRIPTION OF PARAMETERS
C   ARRAY  - MATRIX
C   NORDER - ORDER OF DETERMINANT (DEGREE OF MATRIX)
C
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C   NONE
C
C COMMENTS
C   THIS SUBPROGRAM DESTROYS THE INPUT MATRIX ARRAY
C   DIMENSION STATEMENT VALID FOR NORDER UP TO 10
C
	FUNCTION DETERM (ARRAY,NORDER)
	DOUBLE PRECISION ARRAY,SAVE
	DIMENSION ARRAY(10,10)
C
10	DETERM=1.
11	DO 50 K=1,NORDER
C
C INTERCHANGE COLUMNS IF DIAGONAL ELEMENT IS ZERO
C
	IF (ARRAY(K,K)) 41,21,41
21	DO 23 J=K,NORDER
	IF (ARRAY(K,J)) 31,23,31
23	CONTINUE
	DETERM=0.
	GOTO 60
31	DO 34 I=K,NORDER
	SAVE=ARRAY(I,J)
	ARRAY(I,J)=ARRAY(I,K)
34	ARRAY(I,K)=SAVE
	DETERM=-DETERM
C
C SUBTRACT ROW K FROM LOWER ROWS TO GET DIAGONAL MATRIX
C
41	DETERM=DETERM*ARRAY(K,K)
	IF (K-NORDER) 43,50,50
43	K1=K+1
	DO 46 I=K1,NORDER
	DO 46 J=K1,NORDER
46	ARRAY(I,J)=ARRAY(I,J)-ARRAY(I,K)*ARRAY(K,J)/ARRAY(K,K)
50	CONTINUE
60	RETURN
	END


SUBROUTINE p85(input_file,output_file)
!-------------------------------------------------------------------------
! Program 8.5 Plane or axisymmetric consolidation analysis using 4-node
!             rectangular quadrilaterals. Mesh numbered in x(r)- or y(z)-
!             direction. Implicit time integration using the "theta"
!             method. No global matrix assembly. Diagonal
!             preconditioner conjugate gradient solver
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::cg_iters,cg_limit,fixed_freedoms,i,iel,j,k,nci,ndim=2,nels,neq, &
   nip=4,nlen,nn,nod=4,npri,np_types,nres,nstep,ntime,nxe,nye
 REAL(iwp)::alpha,beta,cg_tol,det,dtim,one=1.0_iwp,penalty=1.0e20_iwp,    &
   theta,time,up,zero=0.0_iwp
 LOGICAL::cg_converged
 CHARACTER(LEN=15)::argv,dir,element='quadrilateral',type_2d
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g_num(:,:),node(:),num(:)
 REAL(iwp),ALLOCATABLE::coord(:,:),d(:),der(:,:),deriv(:,:),              &
   diag_precon(:),fun(:),gc(:),g_coord(:,:),jac(:,:),kay(:,:),kc(:,:),    &
   loads(:),ntn(:,:),p(:),mm(:,:),points(:,:),prop(:,:),r(:),store(:),    &
   storka(:,:,:),storkb(:,:,:),u(:),value(:),weights(:),x(:),xnew(:),     &
   x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)type_2d,dir,nxe,nye,cg_tol,cg_limit,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 neq=nn
 WRITE(11,'(a,i5,a)')" There are",neq," equations"
 ALLOCATE(points(nip,ndim),weights(nip),kay(ndim,ndim),coord(nod,ndim),   &
   fun(nod),jac(ndim,ndim),g_coord(ndim,nn),der(ndim,nod),deriv(ndim,nod),&
   mm(nod,nod),g_num(nod,nels),kc(nod,nod),ntn(nod,nod),num(nod),         &
   storka(nod,nod,nels),storkb(nod,nod,nels),etype(nels),x_coords(nxe+1), &
   y_coords(nye+1),prop(ndim,np_types),loads(0:neq),diag_precon(0:neq),   &
   u(0:neq),d(0:neq),p(0:neq),x(0:neq),r(0:neq),xnew(0:neq),gc(ndim))
 READ(10,*)prop
 etype=1
 IF(np_types>1)read(10,*)etype
 READ(10,*)x_coords,y_coords
 READ(10,*)dtim,nstep,theta,npri,nres,ntime
!---------------loop the elements to set up element data------------------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,dir)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 CALL sample(element,points,weights)
 diag_precon=zero
 gc=one
!----------element matrix integration, storage and preconditioner------
 elements_2: DO iel=1,nels
   kay=zero
   DO i=1,ndim
     kay(i,i)=prop(i,etype(iel))
   END DO
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   kc=zero
   mm=zero
   gauss_pts: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     IF(type_2d=='axisymmetric')gc=MATMUL(fun,coord)
     kc=kc+MATMUL(MATMUL(TRANSPOSE(deriv),kay),deriv)*det*weights(i)*gc(1)
     CALL cross_product(fun,fun,ntn)
     mm=mm+ntn*det*weights(i)*gc(1)
   END DO gauss_pts
   storka(:,:,iel)=mm+kc*theta*dtim
   storkb(:,:,iel)=mm-kc*(one-theta)*dtim
   DO k=1,nod
     diag_precon(num(k))=diag_precon(num(k))+storka(k,k,iel)
   END DO
 END DO elements_2
!-----------------------specify initial and boundary values---------------
 READ(10,*)loads(1:)
 loads(0)=zero
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms),                   &
            store(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
   diag_precon(node)=diag_precon(node)+penalty
   store=diag_precon(node)
 END IF
 diag_precon(1:)=one/diag_precon(1:)
 diag_precon(0)=zero
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/a,i3,a)')"    Time      Pressure (node",nres,")  cg iters"
 WRITE(11,'(2e12.4)')0.0,loads(nres)
 timesteps: DO j=1,nstep
   time=j*dtim
   u=zero
   elements_3 : DO iel=1,nels
     num=g_num(:,iel)
     kc=storkb(:,:,iel)
     u(num)=u(num)+MATMUL(kc,loads(num))
   END DO elements_3
   u(0)=zero
   r=u
   IF(fixed_freedoms/=0)r(node)=store*value
   d=diag_precon*r
   p=d
   x=zero
   cg_iters=0
!-----------------------pcg equation solution-----------------------------
   pcg: DO
     cg_iters=cg_iters+1
     u=zero
      elements_4: DO iel=1,nels
        num=g_num(:,iel)
        kc=storka(:,:,iel)
        u(num)=u(num)+MATMUL(kc,p(num))
      END DO elements_4
      IF(fixed_freedoms/=0)u(node)=p(node)*store
      up=DOT_PRODUCT(r,d)
      alpha=up/DOT_PRODUCT(p,u)
      xnew=x+p*alpha
      r=r-u*alpha
      d=diag_precon*r
      beta=DOT_PRODUCT(r,d)/up
      p=d+p*beta
      CALL checon(xnew,x,cg_tol,cg_converged)
      IF(cg_converged.OR.cg_iters==cg_limit)EXIT
   END DO pcg
   loads=xnew
   IF(nod==4.AND.j==ntime)THEN
     READ(10,*)nci
     CALL contour(loads,g_coord,g_num,nci,argv,nlen,13)
   END IF
   IF(j/npri*npri==j)                                                      &
     WRITE(11,'(2e12.4,7x,i5)')time,loads(nres),cg_iters
 END DO timesteps

END SUBROUTINE p85


module blendmod
!$$$   module documentation block
!                .      .    .                                       .
! module:    blendmod        blend function module
!   prgmmr: parrish          org: np22                date: 2012-11-26
!
! abstract: contains routines needed for polynomial blending function.  This
!            function is defined over the interval 0<=x<=1, with value 0 at
!            x=0, and value 1 at x=1. The order parameter iord defines the
!            order of continuity of the function at the endpoints.
!            For n=0, the blend function = x for 0 <= x <=1, and =1 for x>1, =0 for x<0.
!            In this case, the function is continuous, but the derivatives are discontinuous.
!            For n>0, the function and its first n derivatives are continuous at x=0 and x=1.
!            See the comments in subroutine blend for more details.  Subroutine
!            blend was originally written by Jim Purser.
!
! program history log:
!   2012-11-26  parrish
!
! subroutines included:
!  init_blend
!  blend_f
!  blend_df
!  blend

   use kinds, only: r_kind,i_kind

   implicit none

! set default to private
   private
! set subroutines to public
   public :: init_blend
   public :: blend_f
   public :: blend_df
   public :: blend
! set passed variables to public

   integer(i_kind) mm,iblend(0:40)
   real(r_kind) x0,dxx,dnorm

   contains

   subroutine init_blend(xbegin,xend,iord,ierror)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    init_blend
!   prgmmr: parrish          org: np22                date: 2012-11-26
!
! abstract: initialize private module variables so routines blend_f and blend_df generate the
!            appropriate blend function and 1st derivative for blend function order iord
!            and transition range xbegin to xend.  Note that xbegin can be greater
!            than xend, but xbegin==xend is not allowed.
!
! program history log:
!   2012-11-26  parrish - initial documentation
!
!   input argument list:
!     xbegin - beginning of blend function interval (  blend_f(xbegin)=0 )
!     xend   - end of blend function interval ( blend_f(xend)=1 )
!     iord   - order of blend function
!     ierror - error return:  =0 for successful return, /=0 only if xbegin==xend.
!               NOTE:  xbegin > xend is allowed.
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$

     use constants, only: half,one
     implicit none

     integer(i_kind),intent(in):: iord
     real(r_kind),intent(in):: xbegin,xend
     integer(i_kind),intent(inout):: ierror

     real(r_kind) x1,xmid,y,dy

!      ierror = 0 for normal return, /=0 if xend=xbegin

     if(xend==xbegin) then
        ierror=1
        return
     end if
     mm=iord
     x0=xbegin
     x1=xend
     dxx=one/(x1-x0)
     call blend(mm,iblend)
     xmid=x0+half*(x1-x0)
     dnorm=one
     call blend_df(xmid,y,dy)
     dnorm=one/dy

   end subroutine init_blend

   subroutine blend_f(x_in,y)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    blend_f
!   prgmmr: parrish          org: np22                date: 2012-11-26
!
! abstract:  for input value x_in, return blend function value y, where 0 <=y < =1.
!           Before calling blend_f, make sure that init_blend has been called
!           for the desired values of x where the blend function transitions
!           from 0 to 1.
!
! program history log:
!   2012-11-26  parrish - initial documentation
!
!   input argument list:
!     x_in   - input argument value
!
!   output argument list:
!     y      - output value  blend_f(x_in)
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$

     use constants, only: zero,one
     implicit none

     real(r_kind),intent(in):: x_in
     real(r_kind),intent(out):: y
     real(r_kind) x
     integer(i_kind) j

     x=(x_in-x0)*dxx
     if(x < zero) then
        y=zero
     elseif(x > one) then
        y=one
     else
        y=iblend(mm)
        do j=mm-1,0,-1
           y=x*y+iblend(j)
        end do
        y=y*x**(mm+1)
     end if

   end subroutine blend_f

   subroutine blend_df(x_in,y,dy)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    blend_df
!   prgmmr: parrish          org: np22                date: 2012-11-26
!
! abstract:  for input value x_in, return blend function in y and 1st derivative
!             of blend function in dy.
!           Before calling blend_df, make sure that init_blend has been called
!           for the desired values of x where the blend function transitions
!           from 0 to 1.
!
! program history log:
!   2012-11-26  parrish - initial documentation
!
!   input argument list:
!     x_in   - input argument value
!
!   output argument list:
!     y      - output value of blend function for input value x_in.
!     dy     - output value of derivative of blend function for input value x_in.
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$

     use constants, only: zero,one
     implicit none

     real(r_kind),intent(in):: x_in
     real(r_kind),intent(out):: y,dy
     real(r_kind) x
     integer(i_kind) j

     x=(x_in-x0)*dxx
     if(x < zero) then
        y=zero ; dy=zero
     elseif(x > one) then
        y=one ; dy=zero
     else
        dy=zero
        y=iblend(mm)
        do j=mm-1,0,-1
           dy=x*dy+y
           y=x*y+iblend(j)
        end do
        dy=((mm+one)*y+x*dy)*x**mm
        y=y*x**(mm+1)
     end if
     dy=dy*dnorm

end subroutine blend_df

subroutine blend(n,iblend)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    blend
!   prgmmr: purser           org: w/nmc22     date:1998
!
! abstract: put coefficients for n+1,..,2n+1, into iblend(0),..
!           iblend(n)
!
! program history log:
!   2004-05-13  kleist  documentation
!   2008-04-23  safford - rm unused uses
!   2012-11-26  parrish - move from prewgt.f90 to this module.
!
!   input argument list:
!     n      - number of powers to blend
!
!   output argument list:
!     iblend - blended coefficients
!
! remarks: put the coefficients for powers n+1,..,2n+1, into iblend(0),
!          ..iblend(n),for the "blending polynomial" of continuity-
!          degree n in the interval [0,1].  For example, with n=1, the
!          blending polynomial has up to 1st derivatives continuous
!          with y(0)=0, y(1)=1, y'(0)=y'(1)=0, when y(x)=3x^2-2x^3.
!          Hence iblend={3,-2}
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$
  use kinds, only: i_kind
  implicit none

! Declare passed variables
  integer(i_kind)               ,intent(in   ) :: n
  integer(i_kind),dimension(0:n),intent(  out) :: iblend

! Declare local parameters
  integer(i_kind),parameter:: nn=12

! Declare local variables
  integer(i_kind) np,i,j,ib
  integer(i_kind),dimension(0:nn):: ipascal(0:nn)

  if(n>nn)stop
  np=n+1
  do i=0,n
    ipascal(i)=0
  enddo

  ipascal(0)=1
  do i=0,n
     do j=i,1,-1
        ipascal(j)=ipascal(j)-ipascal(j-1)
     enddo
  enddo

  ib=1
  do i=1,n
     ib=(ib*2*(2*i+1))/i
  enddo
  do j=0,n
     iblend(j)=(ib*ipascal(j))/(np+j)
  enddo

  return
end subroutine blend

end module blendmod


program arreglos
implicit none
!real, dimension(3) :: v
!integer, dimension(3) :: m
!cmplex, dimension (2) :: z

real, dimension(1:3) :: v
integer, dimension(1:3) :: m
complex, dimension(1:2) :: z

real, dimension(2,2) :: v1
integer, dimension(2,2) :: m1
complex, dimension(2,2) :: z1

!real, dimension(1:2,1:2) :: v1
!integer, dimension(1:2,1:2) :: m1
!cmplex, dimension(1:2,1:2) :: z1

v(1)=2.45
v(2)=6.45
v(3)=12.45

m(1)=45
m(2)=25
m(3)=70

z(1)=cmplx(v(1),m(1))
z(2)=cmplx(v(2),m(2))

print*,"El vector v es:"
print*,v
print*,"----------------------------------------------------"
print*,"El vector m es:"
print*,m
print*,"----------------------------------------------------"
print*,"El vector z es:"
print*,z

v1(1,1)=2.1
v1(1,2)=6.45
v1(2,1)=7.45
v1(2,2)=15.45

m1(1,1)=2
m1(1,2)=6
m1(2,1)=7
m1(2,2)=15

z1(1,1)=cmplx(v1(1,1),m1(2,1))
z1(1,2)=cmplx(v1(2,1),m1(1,2))
z1(2,1)=cmplx(v1(2,1),m1(1,2))
z1(2,2)=cmplx(v1(1,2),m1(2,1))

print*,"----------------------------------------------------"
print*,"La matriz v1 es:"
print*,v1
print*,"----------------------------------------------------"
print*,"La matriz m1 es:"
print*,m1
print*,"----------------------------------------------------"
print*,"La matriz z1 es:"
print*,z1
pause
end program arreglos


      SUBROUTINE fleg(x,pl,nl)
      INTEGER nl
      REAL x,pl(nl)
      INTEGER j
      REAL d,f1,f2,twox
      pl(1)=1.
      pl(2)=x
      if(nl.gt.2) then
        twox=2.*x
        f2=x
        d=1.
        do 11 j=3,nl
          f1=d
          f2=f2+twox
          d=d+1.
          pl(j)=(f2*pl(j-1)-f1*pl(j-2))/d
11      continue
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/fleg.for


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C       Written by: Anshuk Attri
C
C       Contact: contact@anshukattri.in
C       Website: www.anshukattri.in/research
C       GITHUB: github.com/aa-tree/
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

        SUBROUTINE GAUSS_GET_COEFF(COEFF, G_COEFF)

C
C       COEFF   INPUT, CHARACTER
C
C
C
C
C
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
        IMPLICIT NONE
        INCLUDE 'common.dat'

        CHARACTER*(*) COEFF
        REAL*8 G_COEFF(10,9)

        IF(COEFF .EQ. 'b') THEN

C
C       Return b_jk coefficients for Gauss Jackson.
C       Source: Matthew M. Berry and Liam M. Healy, Implementation of
C       Gauss-Jackson Integration for Orbit Propagation,
C       The Journal of the Astronautical Sciences, Vol. 52, No. 3,
C       July–September 2004, pp. 331–357
C

C
C       Index has a bias of 5 so G(-4,-4) will be G(1,1)
C

C       (-4,-4)
        G_COEFF(1,1)= 19087.0D0/89600.0D0

C       (-3,-4)
        G_COEFF(2,1)= 8183.0D0/1036800.0D0

C       (-2,-4)
        G_COEFF(3,1)= 425.0D0/290304.0D0

C       (-1,-4)
        G_COEFF(4,1)= 7.0D0/12800.0D0

C       (0,-4)
        G_COEFF(5,1)= -2497.0D0/7257600.0D0

C       (1,-4)
        G_COEFF(6,1)= 2497.0D0/7257600.0D0

C       (2,-4)
        G_COEFF(7,1)= -7.0D0/12800.0D0

C       (3,-4)
        G_COEFF(8,1)=425.0D0/290304.0D0

C       (4,-4)
        G_COEFF(9,1)= -8183.0D0/1036800.0D0

C       (5,-4)
        G_COEFF(10,1)= 25713.0D0/89600.0D0

C       (-4,-3)
        G_COEFF(1,2)= -427487.0D0/725760.0D0

C       (-3,-3)
        G_COEFF(2,2)=57251.0D0/403200.0D0

C       (-2,-3)
        G_COEFF(3,2)=76453.0D0/3628800.0D0

C       (-1,-3)
        G_COEFF(4,2)=-23173.0D0/3628800.0D0

C       (0,-3)
        G_COEFF(5,2)=1469.0D0/403200.0D0

C       (1,-3)
        G_COEFF(6,2)=-2497.0D0/725760.0D0

C       (2,-3)
        G_COEFF(7,2)=19109.0D0/3628800.0D0

C       (3,-3)
        G_COEFF(8,2)=-5533.0D0/403200.0D0

C       (4,-3)
        G_COEFF(9,2)=263077.0D0/3628800.0D0

C       (5,-3)
        G_COEFF(10,2)=-9401029.0D0/3628800.0D0

C       (-4,-2)
        G_COEFF(1,3)=3498217.0D0/3628800.0D0

C       (-3,-2)
        G_COEFF(2,3)=-1106377.0D0/3628800.0D0

C       (-2,-2)
        G_COEFF(3,3)=5143.0D0/57600.0D0

C       (-1,-2)
        G_COEFF(4,3)=29579.0D0/725760.0D0

C       (0,-2)
        G_COEFF(5,3)=-68119.0D0/3628800.0D0

C       (1,-2)
        G_COEFF(6,3)=6463.0D0/403200.0D0

C       (2,-2)
        G_COEFF(7,3)=-83927.0D0/3628800.0D0

C       (3,-2)
        G_COEFF(8,3)=210359.0D0/3628800.0D0

C       (4,-2)
        G_COEFF(9,3)=24019.0D0/80640.0D0

C       (5,-2)
        G_COEFF(10,3)=5393233.0D0/5393233.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       (-4,-1)
        G_COEFF(1,4)=-500327.0D0/403200.0D0

C       (-3,-1)
        G_COEFF(2,4)=218483.0D0/725760.0D0

C       (-2,-1)
        G_COEFF(3,4)=-660127.0D0/3628800.0D0

C       (-1,-1)
        G_COEFF(4,4)= 2497.0D0/57600.0D0

C       (0,-1)
        G_COEFF(5,4)= 252769.0D0/3628800.0D0

C       (1,-1)
        G_COEFF(6,4)= -172993.0D0/3628800.0D0

C       (2,-1)
        G_COEFF(7,4)= 4997.0D0/80640.0D0

C       (3,-1)
        G_COEFF(8,4)= -530177.0D0/3628800.0D0

C       (4,-1)
        G_COEFF(9,4)= 2616161.0D0/3628800.0D0

C       (5,-1)
        G_COEFF(10,4)= -9839609.0D0/403200.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       (-4,0)
        G_COEFF(1,5)= 6467.0D0/5670.0D0

C       (-3,0)
        G_COEFF(2,5)=-69.0D0/280.0D0

C       (-2,0)
        G_COEFF(3,5)= 661.0D0/5670.0D0

C       (-1,0)
        G_COEFF(4,5)= -2563.0D0/22680.0D0

C       (0,0)
        G_COEFF(5,5)= 0.0D0

C       (1,0)
        G_COEFF(6,5)= 2563.0D0/22680.0D0

C       (2,0)
        G_COEFF(7,5)= -661.0D0/5670.0D0

C       (3,0)
        G_COEFF(8,5)=69.0D0/280.0D0

C       (4,0)
        G_COEFF(9,5)= -6467.0D0/5670.0D0

C       (5,0)
        G_COEFF(10,5)= 167287.0D0/4536.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       (-4,1)
        G_COEFF(1,6)= -2616161.0D0/3628800.0D0

C       (-3,1)
        G_COEFF(2,6)= 530177.0D0/3628800.0D0

C       (-2,1)
        G_COEFF(3,6)= -4997.0D0/80640.0D0

C       (-1,1)
        G_COEFF(4,6)= 172993.0D0/3628800.0D0

C       (0,1)
        G_COEFF(5,6)= -252769.0D0/3628800.0D0

C       (1,1)
        G_COEFF(6,6)= -2497.0D0/57600.0D0

C       (2,1)
        G_COEFF(7,6)= 660127.0D0/3628800.0D0

C       (3,1)
        G_COEFF(8,6)= -218483.0D0/725760.0D0

C       (4,1)
        G_COEFF(9,6)= 500327.0D0/403200.0D0

C       (5,1)
        G_COEFF(9,6)= 135352319.0D0/3628800.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC
C       (-4,2)
        G_COEFF(1,7)= 24019.0D0/80640.0D0

C       (-3,2)
        G_COEFF(2,7)=-210359.0D0/3628800.0D0

C       (-2,2)
        G_COEFF(3,7)=83927.0D0/3628800.0D0

C       (-1,2)
        G_COEFF(4,7)=-6463.0D0/403200.0D0

C       (0,2)
        G_COEFF(5,7)=68119.0D0/3628800.0D0

C       (1,2)
        G_COEFF(6,7)=-29579.0D0/725760.0D0

C       (2,2)
        G_COEFF(7,7)=-5143.0D0/57600.0D0

C       (3,2)
        G_COEFF(8,7)=1106377.0D0/3628800.0D0

C       (4,2)
        G_COEFF(9,7)=-3498217.0D0/3628800.0D0

C       (5,2)
        G_COEFF(10,7)=10219841.0D0/403200.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC

C       (-4,3)
        G_COEFF(1,8)=-263077.0D0/3628800.0D0

C       (-3,3)
        G_COEFF(2,8)=5533.0D0/403200.0D0

C       (-2,3)
        G_COEFF(3,8)=-19109.0D0/3628800.0D0

C       (-1,3)
        G_COEFF(4,8)=2497.0D0/725760.0D0

C       (0,3)
        G_COEFF(5,8)=-1469.0D0/403200.0D0

C       (1,3)
        G_COEFF(6,8)=23173.0D0/3628800.0D0

C       (2,3)
        G_COEFF(7,8)=-76453.0D0/3628800.0D0

C       (3,3)
        G_COEFF(8,8)= -57251.0D0/403200.0D0

C       (4,3)
        G_COEFF(9,8)= 427487.0D0/725760.0D0

C       (5,3)
        G_COEFF(10,8)= -40987771.0D0/3628800.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC

C       (-4,4)
        G_COEFF(1,9)=8183.0D0/1036800.0D0

C       (-3,4)
        G_COEFF(2 ,9)= -425.0D0/290304.0D0

C       (-2,4)
        G_COEFF(3 ,9)=7.0D0/12800.0D0

C       (-1,4)
        G_COEFF(4 ,9)=-2497.0D0/7257600.0D0

C       (0,4)
        G_COEFF(5 ,9)=2497.0D0/7257600.0D0

C       (1,4)
        G_COEFF(6 ,9)=7.0D0/12800.0D0

C       (2,4)
        G_COEFF(7 ,9)= 425.0D0/290304.0D0

C       (3,4)
        G_COEFF(8,9)=-8183.0D0/1036800.0D0

C       (4,4)
        G_COEFF(9,9)=-19087.0D0/89600.0D0

C       (5,4)
        G_COEFF(10,9)=3288521.0D0/1036800.0D0

        END IF
C
C       Return a_jk coefficients for Gauss Jackson.
C       Source: Matthew M. Berry and Liam M. Healy, Implementation of
C       Gauss-Jackson Integration for Orbit Propagation,
C       The Journal of the Astronautical Sciences, Vol. 52, No. 3,
C       July–September 2004, pp. 331–357
C

C
C       Index has a bias of 5 so G(-4,-4) will be G(1,1)
C

        IF(COEFF .EQ. 'a') THEN

C
C       Return a_jk coefficients for Gauss Jackson.
C       Source:
C

C
C       Index has a bias of 5 so G(-4,-4) will be G(1,1)
C

C       (-4,-4)
        G_COEFF(1,1)= 3250433.0D0/53222400.0D0

C       (-3,-4)
        G_COEFF(2,1)= -330157.0D0/159667200.0D0

C       (-2,-4)
        G_COEFF(3,1)= 45911.0D0/159667200.0D0

C       (-1,-4)
        G_COEFF(4,1)= -3499.0D0/53222400.0D0

C       (0,-4)
        G_COEFF(5,1)= 317.0D0/22809600.0D0

C       (1,-4)
        G_COEFF(6,1)= 317.0D0/22809600.0D0

C       (2,-4)
        G_COEFF(7,1)= -3499.0D0/53222400.0D0

C       (3,-4)
        G_COEFF(8,1)= 45911.0D0/159667200.0D0

C       (4,-4)
        G_COEFF(9,1)= -330157.0D0/159667200.0D0

C       (5,-4)
        G_COEFF(10,1)= 3250433.0D0/53222400.0D0

C       (-4,-3)
        G_COEFF(1,2)= -572741.0D0/5702400.0D0

C       (-3,-3)
        G_COEFF(2,2)= 530113.0D0/6652800.0D0

C       (-2,-3)
        G_COEFF(3,2)= -185839.0D0/39916800.0D0

C       (-1,-3)
        G_COEFF(4,2)= 4387.0D0/4989600.0D0

C       (0,-3)
        G_COEFF(5,2)= -2539.0D0/13305600.0D0

C       (1,-3)
        G_COEFF(6,2)= -317.0D0/2851200.0D0

C       (2,-3)
        G_COEFF(7,2)= 24173.0D0/39916800.0D0

C       (3,-3)
        G_COEFF(8,2)= -1261.0D0/475200.0D0

C       (4,-3)
        G_COEFF(9,2)= 754331.0D0/39916800.0D0

C       (5,-3)
        G_COEFF(10,2)= -11011481.0D0/19958400.0D0

C       (-4,-2)
        G_COEFF(1,3)= -8701681.0D0/39916800.0D0

C       (-3,-2)
        G_COEFF(2,3)= -1106377.0D0/3628800.0D0

C       (-2,-2)
        G_COEFF(3,3)= 171137.0D0/1900800.0D0

C       (-1,-2)
        G_COEFF(4,3)= -35039.0D0/4989600.0D0

C       (0,-2)
        G_COEFF(5,3)= 55067.0D0/39916800.0D0

C       (1,-2)
        G_COEFF(6,3)= 2059.0D0/6652800.0D0

C       (2,-2)
        G_COEFF(7,3)= -98911.0D0/39916800.0D0

C       (3,-2)
        G_COEFF(8,3)= 109343.0D0/9979200.0D0

C       (4,-2)
        G_COEFF(9,3)= -1025779.0D0/13305600.0D0

C       (5,-2)
        G_COEFF(10,3)= 6322573.0D0/2851200.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC

C       (-4,-1)
        G_COEFF(1,4)= 4026311.0D0/13305600.0D0

C       (-3,-1)
        G_COEFF(2,4)= -27631.0D0/623700.0D0

C       (-2,-1)
        G_COEFF(3,4)= 73643.0D0/39916800.0D0

C       (-1,-1)
        G_COEFF(4,4)= 90817.0D0/950400.0D0

C       (0,-1)
        G_COEFF(5,4)= -326911.0D0/39916800.0D0

C       (1,-1)
        G_COEFF(6,4)= 2117.0D0/9979200.0D0

C       (2,-1)
        G_COEFF(7,4)= 77597.0D0/13305600.0D0

C       (3,-1)
        G_COEFF(8,4)= -531521.0D0/19958400.0D0

C       (4,-1)
        G_COEFF(9,4)= 531521.0D0/39916800.0D0

C       (5,-1)
        G_COEFF(10,4)= -8660609.0D0/1663200.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC

C       (-4,0)
        G_COEFF(1,5)= -917039.0D0/3193344.0D0

C       (-3,0)
        G_COEFF(2,5)= 44773.0D0/1064448.0D0

C       (-2,0)
        G_COEFF(3,5)= -25775.0D0/3193344.0D0

C       (-1,0)
        G_COEFF(4,5)= -20561.0D0/3193344.0D0

C       (0,0)
        G_COEFF(5,5)= 14797.0D0/152064.0D0

C       (1,0)
        G_COEFF(6,5)= -20561.0D0/3193344.0D0

C       (2,0)
        G_COEFF(7,5)= 25775.0D0/3193344.0D0

C       (3,0)
        G_COEFF(8,5)= 44773.0D0/1064448.0D0

C       (4,0)
        G_COEFF(9,5)= -917039.0D0/3193344.0D0

C       (5,0)
        G_COEFF(10,5)= 25162927.0D0/3193344.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC

C       (-4,1)
        G_COEFF(1,6)= 7370669.0D0/39916800.0D0

C       (-3,1)
        G_COEFF(2,6)= -531521.0D0/19958400.0D0

C       (-2,1)
        G_COEFF(3,6)= 77597.0D0/13305600.0D0

C       (-1,1)
        G_COEFF(4,6)= 2117.0D0/9979200.0D0

C       (0,1)
        G_COEFF(5,6)= -326911.0D0/39916800.0D0

C       (1,1)
        G_COEFF(6,6)= 90817.0D0/950400.0D0

C       (2,1)
        G_COEFF(7,6)= 73643.0D0/39916800.0D0

C       (3,1)
        G_COEFF(8,6)= -27631.0D0/623700.0D0

C       (4,1)
        G_COEFF(9,6)= 4026311.0D0/13305600.0D0

C       (5,1)
        G_COEFF(9,6)= -159314453.0D0/19958400.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC

C       (-4,2)
        G_COEFF(1,7)= -1025779.0D0/13305600.0D0

C       (-3,2)
        G_COEFF(2,7)= 109343.0D0/9979200.0D0

C       (-2,2)
        G_COEFF(3,7)= -98911.0D0/39916800.0D0

C       (-1,2)
        G_COEFF(4,7)= 2059.0D0/6652800.0D0

C       (0,2)
        G_COEFF(5,7)= 55067.0D0/39916800.0D0

C       (1,2)
        G_COEFF(6,7)= -35039.0D0/4989600.0D0

C       (2,2)
        G_COEFF(7,7)= 171137.0D0/1900800.0D0

C       (3,2)
        G_COEFF(8,7)= 518887.0D0/19958400.0D0

C       (4,2)
        G_COEFF(9,7)= -8701681.0D0/39916800.0D0

C       (5,2)
        G_COEFF(10,7)= 18071351.0D0/3326400.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC

C       (-4,3)
        G_COEFF(1,8)= 754331.0D0/39916800.0D0

C       (-3,3)
        G_COEFF(2,8)= -1261.0D0/475200.0D0

C       (-2,3)
        G_COEFF(3,8)= 24173.0D0/39916800.0D0

C       (-1,3)
        G_COEFF(4,8)= -317.0D0/2851200.0D0

C       (0,3)
        G_COEFF(5,8)= -2539.0D0/13305600.0D0

C       (1,3)
        G_COEFF(6,8)= 4387.0D0/4989600.0D0

C       (2,3)
        G_COEFF(7,8)= -185839.0D0/39916800.0D0

C       (3,3)
        G_COEFF(8,8)= 530113.0D0/6652800.0D0

C       (4,3)
        G_COEFF(9,8)= 572741.0D0/5702400.0D0

C       (5,3)
        G_COEFF(10,8)= -24115843.0D0/9979200.0D0

CCCCCCCCCCCCCCCCCCCCCCCCCCCC

C       (-4,4)
        G_COEFF(1,9)= -330157.0D0/159667200.0D0

C       (-3,4)
        G_COEFF(2 ,9)= 45911.0D0/159667200.0D0

C       (-2,4)
        G_COEFF(3 ,9)= -3499.0D0/53222400.0D0

C       (-1,4)
        G_COEFF(4 ,9)= 317.0D0/22809600.0D0

C       (0,4)
        G_COEFF(5 ,9)= 317.0D0/22809600.0D0

C       (1,4)
        G_COEFF(6 ,9)= -3499.0D0/53222400.0D0

C       (2,4)
        G_COEFF(7 ,9)= 45911.0D0/159667200.0D0

C       (3,4)
        G_COEFF(8,9)= -330157.0D0/159667200.0D0

C       (4,4)
        G_COEFF(9,9)= 3250433.0D0/53222400.0D0

C       (5,4)
        G_COEFF(10,9)= 103798439.0D0/159667200.0D0

        END IF

        RETURN
        END SUBROUTINE