      subroutine m0dcf(mtrep,mf,mt,d,v,miso,mdc,mclvd,m0,mw,axis,
     1           plunge,azimuth,strike,dip,slip,pcdc,pcclvd,pciso)
c
c ...... decompose moment tensor into various representations
c
c     input parameters -
c
c         mtrep - moment tensor representation
c                 = 0 for spherical coordinates (r,d,p)
c                   ( Up, Away, South )
c                 = 1 for cartesian coordinates (x,y,z)
c                   ( North, East, Down )
c                 = 2 for f1,...,f6 notation
c
c         mf or mt - components of moment tensor
c                 | mrr mrd mrp |    | mxx mxy mxz |    | f1 f2 f3 |
c                 | mdr mdd mdp | or | myx myy myz | or | f2 f4 f5 |
c                 | mpr mpd mpp |    | mzx mzy mzz |    | f3 f5 f6 |
c
c              NOTE:
c                   f1 = mrr =  mzz
c                   f2 = mdd =  mxx
c                   f3 = mpp =  myy
c                   f4 = mrd =  mxz
c                   f5 = mrp = -myz
c                   f6 = mdp = -mxy
c
c     output parameters -
c
c         d       - eigenvalues
c         v       - principal eigenvectors
c         miso    - isotropic moment tensor
c         mdc     - double-couple moment tensor
c         mclvd   - compensated linear vector dipole moment tensor
c         m0      - scalar seismic moment
c         axis    - component axis ( P, N, T )
c         plunge  - principle eigenvector plunge
c                   (degrees below horizontal)
c         azimuth - principle eigenvector azimuth
c                   (degrees clockwise from North)
c         strike  - strike of fault plane
c                   (degrees clockwise from North)
c         dip     - dip of fault plane
c                   (degrees below horizontal)
c         slip    - slip of fault plane
c                   (degrees from horizontal)
c         pciso   - percent isotropic source
c         pcdc    - percent double-couple source
c         pcclvd  - percent CLVD source
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      character*1 axis(3)
      real*8 mt(3,3),d(3),v(3,3),miso(3,3),mdc(3,3),mclvd(3,3),m0,mw
      real*8 plunge(3),azimuth(3),strike(3),dip(3),slip(3)
      real*8 pcdc,pcclvd,a(3,3),p(3),t(3),mf(6)
      n=3
      np=3
      rad2deg=180.0/3.1415
      deg2rad=1./rad2deg
c
      call mtsrce(mtrep,mf,mt,a)
c     do 666 j=1,3
c     write(*,*) (a(j,i),i=1,3)
c666  continue
      call mdcmp(a,n,np,v,d,miso,mdc,mclvd)
      call pcnts(d,pcdc,pcclvd)
      call plaz(d,v,plunge,azimuth,axis)
      call m0find(d,m0)
c
c ...... calculate percentage of DC, CLVD & Iso in source
c
      pcdc=pcdc/100.d0
      pcclvd=pcclvd/100.d0
      pciso=dabs(miso(1,1))/m0
      pcsum=pcdc+pcclvd+pciso
      pcdc=100.d0*pcdc/pcsum
      pcclvd=100.d0*pcclvd/pcsum
      pciso=100.d0*pciso/pcsum
c
c ...... compute moment magnitude
c
      mw=dlog10(m0)/1.5-10.7
c
      call ptfind(v,axis,p,t)
      call fpsol(p,t,strike,dip,slip)
c
c      write(*,*) ' '
c      write(*,'(a,1p3e12.2)') 'eigenvalues = ',(d(i),i=1,n)
c      write(*,*) ' '
c      write(*,'(a,1p3e12.2)') 'eigenvector = ',(v(1,i),i=1,n)
c      write(*,'(a,1p3e12.2)') 'eigenvector = ',(v(2,i),i=1,n)
c      write(*,'(a,1p3e12.2)') 'eigenvector = ',(v(3,i),i=1,n)
c      write(*,*) ' '
c      write(*,'(a,1p3e12.2)') 'miso        = ',(miso(1,i),i=1,n)
c      write(*,'(a,1p3e12.2)') 'miso        = ',(miso(2,i),i=1,n)
c      write(*,'(a,1p3e12.2)') 'miso        = ',(miso(3,i),i=1,n)
c      write(*,*) ' '
c      write(*,'(a,1p3e12.2)') 'mdc         = ',(mdc(1,i),i=1,n)
c      write(*,'(a,1p3e12.2)') 'mdc         = ',(mdc(2,i),i=1,n)
c      write(*,'(a,1p3e12.2)') 'mdc         = ',(mdc(3,i),i=1,n)
c      write(*,*) ' '
c      write(*,'(a,1p3e12.2)') 'mclvd       = ',(mclvd(1,i),i=1,n)
c      write(*,'(a,1p3e12.2)') 'mclvd       = ',(mclvd(2,i),i=1,n)
c      write(*,'(a,1p3e12.2)') 'mclvd       = ',(mclvd(3,i),i=1,n)
c      write(*,*) ' '
c      write(*,*) ' '
c      write(*,'(a,1pe10.2)') 'Scalar Moment    = ',m0
c      write(*,*) ' '
c      write(*,'(a,  f10.2)') 'Moment Magnitude = ',mw
c      write(*,*) ' '
c      write(*,'(a,7x,a1,2(9x,a1))') 'Axis             = ',
c     1         (axis(i),i=1,n)
c      write(*,*) ' '
c      write(*,'(a,3f10.2)') 'Plunge           = ',(plunge(i),i=1,n)
c      write(*,*) ' '
c      write(*,'(a,3f10.2)') 'Azimuth          = ',(azimuth(i),i=1,n)
c      write(*,*) ' '
c      write(*,*) ' '
c      write(*,'(2a)')       'Plane            = ',
c     1           '      P1        P2'
c      write(*,*) ' '
c      write(*,'(a,2f10.2)') 'Strike           = ',(strike(i),i=1,n-1)
c      write(*,*) ' '
c      write(*,'(a,2f10.2)') 'Dip              = ',(dip(i),i=1,n-1)
c      write(*,*) ' '
c      write(*,'(a,2f10.2)') 'Slip             = ',(slip(i),i=1,n-1)
c      write(*,*) ' '
c      write(*,*) ' '
c      write(*,*)            'Source Composition     Percent'
c      write(*,*) ' '
c      write(*,'(a, f10.2)') 'Isotropic        = ',pciso
c      write(*,*) ' '
c      write(*,'(a, f10.2)') 'Double-Couple    = ',pcdc
c      write(*,*) ' '
c      write(*,'(a, f10.2)') 'CLVD             = ',pcclvd
c      write(*,*) ' '
c
      return
      end

      subroutine pcnts(d,pcdc,pcclvd)
c
c ...... calculate percentages of double-couple, CLVD & iso
c        in seismic source
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      real*8 d(3),dd(3)
      do 1 i=1,3
      dd(i)=dabs(d(i))
    1 continue
      do 3 i=1,3
      do 2 j=i,3
      if(dd(j).lt.dd(i)) then
        temp=dd(i)
        dd(i)=dd(j)
        dd(j)=temp
      endif
    2 continue
    3 continue
      eps=dd(1)/dd(3)
      pcdc=100.d0*(1.d0-2.d0*eps)
      pcclvd=200.d0*eps
      return
      end

      subroutine m0find(d,m0)
c
c ...... find scalar moment M0
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      real*8 d(3),m0
      emin=d(1)
      emax=d(1)
      do 1 i=2,3
      if(d(i).lt.emin) emin=d(i)
      if(d(i).gt.emax) emax=d(i)
    1 continue
      m0=(dabs(emin)+dabs(emax))/2.d0
      return
      end

      subroutine ptfind(v,axis,p,t)
c
c ...... find P & T vectors
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      real*8 v(3,3),p(3),t(3)
      character*1 axis(3),pch,tch
      pch='P'
      tch='T'
      do 3 i=1,3
      if(axis(i).eq.pch) then
        do 1 j=1,3
        p(j)=v(j,i)
    1   continue
      elseif(axis(i).eq.tch) then
        do 2 j=1,3
        t(j)=v(j,i)
    2   continue
      endif
    3 continue
      return
      end

      subroutine mtsrce(mtrep,mf,mt,a)
c
c ...... set up appropriate moment tensor components from input
c        moment tensor representation
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      real*8 mf(6),mt(3,3),a(3,3)
      if(mtrep.eq.0) then
        a(1,1)= mt(2,2)
        a(1,2)=-mt(2,3)
        a(1,3)= mt(2,1)
        a(2,1)=-mt(2,3)
        a(2,2)= mt(3,3)
        a(2,3)=-mt(3,1)
        a(3,1)= mt(2,1)
        a(3,2)=-mt(3,1)
        a(3,3)= mt(1,1)
      elseif(mtrep.eq.1) then
        a(1,1)=mt(1,1)
        a(1,2)=mt(1,2)
        a(1,3)=mt(1,3)
        a(2,1)=mt(1,2)
        a(2,2)=mt(2,2)
        a(2,3)=mt(2,3)
        a(3,1)=mt(1,3)
        a(3,2)=mt(2,3)
        a(3,3)=mt(3,3)
      else
        a(1,1)= mf(2)
        a(1,2)=-mf(6)
        a(1,3)= mf(4)
        a(2,1)=-mf(6)
        a(2,2)= mf(3)
        a(2,3)=-mf(5)
        a(3,1)= mf(4)
        a(3,2)=-mf(5)
        a(3,3)= mf(1)
      endif
      return
      end

      subroutine fpsol(p,t,strike,dip,slip)
c
c ...... calculate strike, dip & slip of fault planes
c        from the P & T vectors
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      real*8 p(3),t(3),strike(2),dip(2),slip(2)
      real*8 u(2,3),nu(2,3),lambda
      real*8 rad2deg, deg2rad
      integer*4 idarg(2)

      rad2deg=180.0/3.1415
      deg2rad=1./rad2deg

      con=1.d0/dsqrt(2.d0)
      do 1 i=1,3
      u(1,i)=con*(t(i)+p(i))
      nu(1,i)=con*(t(i)-p(i))
      u(2,i)=con*(t(i)-p(i))
      nu(2,i)=con*(t(i)+p(i))
    1 continue
c      write(*,11) (p(i),i=1,3)
c   11 format(1h ,'P-vector = ',3f10.6)
c      write(*,12) (t(i),i=1,3)
c   12 format(1h ,'T-vector = ',3f10.6)
      idarg(1)=0
      idarg(2)=0
      do 2 i=1,2
      dip(i)=rad2deg*dacos(-nu(i,3))
      if((nu(i,1).eq.0.d0).and.(nu(i,2).eq.0.d0)) then
        strike(i)=0.d0
      else
        strike(i)=rad2deg*datan2(-nu(i,1),nu(i,2))
      endif
    2 continue
      do 3 i=1,2
      sstr=dsin(deg2rad*strike(i))
      cstr=dcos(deg2rad*strike(i))
      sdip=dsin(deg2rad*dip(i))
      cdip=dcos(deg2rad*dip(i))
      if(dabs(sdip).gt.0.d0) then
        lambda=rad2deg*dasin(-u(i,3)/dsin(deg2rad*dip(i)))
      else
        arg1=1.d0
        arg2=u(i,3)
        arg=dsign(arg1,arg2)
        if(arg.lt.0.d0) then
          lambda=180.d0
        else
          lambda=0.d0
        endif
      endif
      slambda=dsin(deg2rad*lambda)
      cdsl=cdip*slambda
      if(dabs(sstr).gt.dabs(cstr)) then
        clambda=(u(i,2)+cdsl*cstr)/sstr
      else
        clambda=(u(i,1)-cdsl*sstr)/cstr
      endif
      if((slambda.eq.0.d0).and.(clambda.eq.0.d0)) then
        slip(i)=0.d0
      else
        slip(i)=rad2deg*datan2(slambda,clambda)
      endif
      if(dip(i).gt.90.d0) then
        dip(i)=180.d0-dip(i)
        strike(i)=strike(i)+180.d0
        slip(i)=360.d0-slip(i)
      endif
      if(strike(i).lt.0.d0) strike(i)=strike(i)+360.d0
      if(slip(i).ge.180.d0) slip(i)=slip(i)-360.d0
    3 continue
      return
      end

      subroutine plaz(d,v,plunge,azimuth,axis)
c
c ...... calculate plunge & azimuth of eigenvectors
c        in degrees
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      real*8 d(3),v(3,3),plunge(3),azimuth(3)
      character*1 axis(3)
      do 1 i=1,3
      if(v(3,i).lt.0.) then
	v(1,i)=-v(1,i)
	v(2,i)=-v(2,i)
	v(3,i)=-v(3,i)
      endif
    1 continue
      do 2 i=1,3
      if((v(2,i).eq.0.d0).and.(v(1,i).eq.0.d0)) then
        azimuth(i)=0.d0
      else
        azimuth(i)=datan2(v(2,i),v(1,i))
      endif
      if(azimuth(i).lt.0.) azimuth(i)=azimuth(i)+360.0
      r=dsqrt(v(1,i)*v(1,i)+v(2,i)*v(2,i))
      if((v(3,i).eq.0.d0).and.(r.eq.0.d0)) then
        plunge(i)=0.d0
      else
        plunge(i)=datan2(v(3,i),r)
      endif
    2 continue
      axis(1)='N'
      if(d(2).gt.d(3)) then
        axis(2)='T'
        axis(3)='P'
      else
        axis(2)='P'
        axis(3)='T'
      endif
      return
      end

      subroutine mdcmp(mij,n,np,v,d,miso,mdc,mclvd)
c
c ...... calculate components of an arbitrary moment tensor
c
      implicit real*8 (a-h,m,o-z)
      implicit integer*4 (i-l,n)
      real*8 mij(np,np),miso(np,np),mdc(np,np),mclvd(np,np)
      real*8 a(3,3),v(3,3),d(3)
      real*8 a1a1(3,3),a2a2(3,3),a3a3(3,3)
      do 2 i=1,n
      do 1 j=1,n
      a(i,j)=mij(i,j)
    1 continue
    2 continue
      trace=a(1,1)+a(2,2)+a(3,3)
      tr3=trace/3.0d0
      do 3 i=1,n
      a(i,i)=a(i,i)-tr3
    3 continue
      do 5 i=1,n
      do 4 j=1,n
      if(i.eq.j) then
        miso(i,j)=tr3
      else
        miso(i,j)=0.d0
      endif
    4 continue
    5 continue
      call jacobi(a,n,np,d,v,nrot)
c      write(*,*) 'jacobi - nrot = ',nrot
      call eigsrt(d,v,n,np)
      f=-d(1)/d(3)
      c=d(3)*(1.d0-2.d0*f)
      call dyadic(v,3,3,c,n,np,a3a3)
      c=-c
      call dyadic(v,2,2,c,n,np,a2a2)
      call matsum(a3a3,a2a2,n,np,mdc)
      c=2.d0*d(3)*f
      call dyadic(v,3,3,c,n,np,a3a3)
      c=-d(3)*f
      call dyadic(v,2,2,c,n,np,a2a2)
      call dyadic(v,1,1,c,n,np,a1a1)
      call matsum(a3a3,a2a2,n,np,mclvd)
      call matsum(mclvd,a1a1,n,np,mclvd)
      return
      end

      subroutine dyadic(v,n1,n2,c,n,np,d)
c
c ...... calculate dyadic of eigenvectors v(i,n1)*v(j,n2)
c        scaled by c
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      real*8 v(np,np),d(np,np)
      do 2 i=1,n
      do 1 j=1,n
      d(i,j)=v(i,n1)*v(j,n2)*c
    1 continue
    2 continue
      return
      end

      subroutine matsum(a,b,n,np,c)
c
c ...... calculate matrix sum c = a + b
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      real*8 a(np,np),b(np,np),c(np,np)
      do 2 i=1,n
      do 1 j=1,n
      c(i,j)=a(i,j)+b(i,j)
    1 continue
    2 continue
      return
      end

      subroutine rotate(v,n,np,a,b)
c
c ...... rotate matrix
c                     T
c        b = v * a * v
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      real*8 v(np,np),a(np,np),b(np,np),c(3,3)
      do 3 i=1,n
      do 2 j=1,n
      sum=0.d0
      do 1 k=1,n
      sum=sum+a(i,k)*v(j,k)
    1 continue
      c(i,j)=sum
    2 continue
    3 continue
      do 6 i=1,n
      do 5 j=1,n
      sum=0.d0
      do 4 k=1,n
      sum=sum+v(i,k)*c(k,j)
    4 continue
      b(i,j)=sum
    5 continue
    6 continue
      return
      end

      subroutine jacobi(a,n,np,d,v,nrot)
c
c ...... Computes all eigenvalues and eigenvectors of a real
c        symmetric matrix A, which is of size N by N, stored
c        in a physical np by np array.  On output, elements
c        of A above the diagonal are destroyed.  D returns
c        the eigenvalues of A in its first N elements.  V is
c        a matrix with the same logical and physical dimensions
c        as A whose columns contain, on output, the normalized
c        eigenvectors of A.  NROT returns the number of Jacobi
c        rotations which were required.
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      parameter (nmax=100)
      real*8 a(np,np),d(np),v(np,np),b(nmax),z(nmax)
      do 12 ip=1,n
        do 11 iq=1,n
          v(ip,iq)=0.d0
   11   continue
        v(ip,ip)=1.d0
   12 continue
      do 13 ip=1,n
        b(ip)=a(ip,ip)
        d(ip)=b(ip)
        z(ip)=0.d0
   13 continue
      nrot=0
      do 24 i=1,500
        sm=0.d0
        do 15 ip=1,n-1
          do 14 iq=ip+1,n
            sm=sm+dabs(a(ip,iq))
   14     continue
   15   continue
        if(sm.eq.0.d0) return
        if(i.lt.1) then
          thresh=0.2d0*sm/dble(n**2)
        else
          thresh=0.d0
        endif
        do 22 ip=1,n-1
          do 21 iq=ip+1,n
            g=100.d0*dabs(a(ip,iq))
            if((i.gt.4).and.(dabs(d(ip))+g.eq.dabs(d(ip)))
     1        .and.(dabs(d(iq))+g.eq.dabs(d(iq)))) then
              a(ip,iq)=0.d0
            elseif(dabs(a(ip,iq)).gt.thresh) then
              h=d(iq)-d(ip)
              if(dabs(h)+g.eq.dabs(h)) then
                t=a(ip,iq)/h
              else
                theta=0.5d0*h/a(ip,iq)
                t=1.d0/(dabs(theta)+dsqrt(1.d0+theta**2))
                if(theta.lt.0.d0) t=-t
              endif
              c=1.d0/dsqrt(1.d0+t**2)
              s=t*c
              tau=s/(1.d0+c)
              h=t*a(ip,iq)
              z(ip)=z(ip)-h
              z(iq)=z(iq)+h
              d(ip)=d(ip)-h
              d(iq)=d(iq)+h
              a(ip,iq)=0.d0
              do 16 j=1,ip-1
                g=a(j,ip)
                h=a(j,iq)
                a(j,ip)=g-s*(h+g*tau)
                a(j,iq)=h+s*(g-h*tau)
   16         continue
              do 17 j=ip+1,iq-1
                g=a(ip,j)
                h=a(j,iq)
                a(ip,j)=g-s*(h+g*tau)
                a(j,iq)=h+s*(g-h*tau)
   17         continue
              do 18 j=iq+1,n
                g=a(ip,j)
                h=a(iq,j)
                a(ip,j)=g-s*(h+g*tau)
                a(iq,j)=h+s*(g-h*tau)
   18         continue
              do 19 j=1,n
                g=v(j,ip)
                h=v(j,iq)
                v(j,ip)=g-s*(h+g*tau)
                v(j,iq)=h+s*(g-h*tau)
   19         continue
            nrot=nrot+1
            endif
   21     continue
   22   continue
        do 23 ip=1,n
          b(ip)=b(ip)+z(ip)
          d(ip)=b(ip)
          z(ip)=0.d0
   23   continue
   24 continue
      return
      end

      subroutine eigsrt(d,v,n,np)
c
c ...... Given the eigenvalues D and eigenvectors V as output from
c        JACOBI, this routine sorts the eigenvalues into increasing
c        absolute order and rearranges the columns of V
c        correspondingly.  The mothod is straight insertion.
c
      implicit real*8 (a-h,o-z)
      implicit integer*4 (i-n)
      real*8 d(np),v(np,np)
      do 13 i=1,n-1
        k=i
        p=d(i)
        do 11 j=i+1,n
          if(dabs(d(j)).lt.dabs(p)) then
            k=j
            p=d(j)
          endif
   11   continue
        if(k.ne.i) then
          d(k)=d(i)
          d(i)=p
          do 12 j=1,n
            p=v(j,i)
            v(j,i)=v(j,k)
            v(j,k)=p
   12     continue
        endif
   13 continue
      return
      end


c===============================================================
c This is an example of fresnel zone function
c Replace this program with a new one as you like
c For each Distance program determinates width of zode using
c exact definition: abs(d - d') < Lambda/x_zone, so for each
c Distance you need to call program once,
c===============================================================
      SUBROUTINE FUNCT(Lambda,TotalDistance,Distance,Step,Value,Iyes)
      implicit none
      include "tomo.h"
      include "line.h"
      real*8    TotalDistance, Distance, PhaseWidth,Wwexp
      real*8    Lambda,Step,Value,dis,dw,dwc,ar1(2),ar2(2)
      integer*4 Iyes,i,i1,j1,flag
c   The equation used here is courtesy of Jesper Spetzler of
c   Utrecht University, Netherlands 2001
c
c   The purpose of this subroutine is to calculate the width of
c   the first Fresnel zone for both phase and group waves. This
c   formula is actually for phase, but the group fresnel zone
c   width is approximated by making it equal to the phase
c   fresnel zone width. It is not neccessary to specify whether
c   these are Rayleigh or Love waves, only that you input the
c   correct slowness for period and wave type.
c========================================================================
c INPUT PARAMETERS:
c
c   TotalDistance - distance from the source to the receiver, (rad);
c   Distance      - distance from the source to the point, (rad);
c   Step          - size of grid cell for integration (rad);
c
c  OUTPUT PARAMETERS:
c
c   Value         - value of amplitude in fresnel zone;
c   Iyes          - =1, inside zone, =0 - outside;
c========================================================================
c  WORKING VARIABLES:
c   Lambda        - wavelength in (rad);
c   PhaseWidth    - half width of the fresnel zone (phase), (rad);

c   R is the Earth's Radius = 6371.0 (km).

      Value=0.0d0
      Wwexp=wexp*drad

c   This is the actual formula with group fresnel zone width being
c   mostly proportional to the phase and so it is treated as such.

      PhaseWidth=0.0d0
      do i=1,90
          dw=(i-1)*Step
          dwc=dcos(dw)
          ar1(1)=dacos(dwc*dcos(Distance))
          ar1(2)=2.0d0*dpi-ar1(1)
          ar2(1)=dacos(dwc*dcos(TotalDistance-Distance))
          ar2(2)=2.0d0*dpi-ar2(1)
          flag=0
          do i1=1,2
          do j1=1,2
             dis=ar1(i1)+ar2(j1)
             if(DABS(TotalDistance-dis).le.Lambda/x_zone) then
                PhaseWidth=i*Step-Step/2.0d0
                flag=1
             endif
          enddo
          enddo
      if(flag.eq.0) goto 1
      enddo
c   The minimum amount for the fresnel phase width, is
c   Lambda/4, so that we don't end up with infintesimally
c   small fresnel zones which are not physically realized.
  1   Iyes=0
      if(PhaseWidth.gt.Step/4.0d0) then
cxx      if(PhaseWidth.lt.Lambda/4.0d0) PhaseWidth=Lambda/4.0d0
         if(PhaseWidth.lt.Wwexp) PhaseWidth=Wwexp
         Iyes=1
         Value=1.0d0/(PhaseWidth*2.0d0)
      endif
      return
      end


! corfun.f90
! Time correlation function, directly and by FFT
PROGRAM corfun

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  ! Define underlying process by generalized Langevin equation
  ! with memory function expressed as a decaying exponential function
  ! See G Ciccotti and JP Ryckaert Mol Phys 40 141 (1980)
  ! and AD Baczewski and SD Bond J Chem Phys 139 044107 (2013)

  ! We assume that the program is linked with the FFTW library (version 3)
  ! but it could easily be adapted to use a different library
  ! With older FFT routines it was necessary to transform a number of points = exact power of 2
  ! which, for us, would mean nstep = 2**j (for integer j) and fft_len=2*nstep
  ! This is no longer true, so we do not restrict nstep in this way,
  ! but the transform should be more efficient if nstep happens to take such values
  ! Advantage can be taken of the fact that the data is real, but for clarity
  ! we just use the complex FFT with imaginary parts of the data set to zero

  USE, INTRINSIC :: iso_fortran_env, ONLY : input_unit, output_unit, error_unit, iostat_end, iostat_eor
  USE, INTRINSIC :: iso_c_binding
  USE               maths_module,    ONLY : random_normal

  IMPLICIT NONE
  INCLUDE 'fftw3.f03'

  REAL :: m     ! Memory function coefficients
  REAL :: kappa ! Memory function decay rates
  REAL :: s     ! GLE auxiliary variables
  REAL :: delta ! Time step
  REAL :: vt    ! Velocity at time t

  REAL,    DIMENSION(:), ALLOCATABLE :: v     ! Stored velocities (nstep)
  REAL,    DIMENSION(:), ALLOCATABLE :: v0    ! Stored velocity origins (n0)
  INTEGER, DIMENSION(:), ALLOCATABLE :: t0    ! Times of origins (n0)
  REAL,    DIMENSION(:), ALLOCATABLE :: c     ! Velocity correlation function (direct method) (0:nt)
  REAL,    DIMENSION(:), ALLOCATABLE :: c_fft ! Velocity correlation function (FFT method) (0:nt)
  REAL,    DIMENSION(:), ALLOCATABLE :: n     ! Normalizing function (0:nt)

  INTEGER :: nt              ! Number of timesteps to correlate
  INTEGER :: nstep           ! Number of timesteps in run
  INTEGER :: nequil          ! Number of equilibration timesteps
  INTEGER :: n0              ! Number of time origins to store
  INTEGER :: origin_interval ! Interval for time origins
  INTEGER :: dt              ! Time difference
  INTEGER :: t               ! Time (equivalent to step number in file)

  LOGICAL :: full
  INTEGER :: k, mk, nk
  INTEGER :: unit, ioerr
  REAL    :: temperature, stddev, x, e, b, d
  REAL    :: cpu_1, cpu_2, cpu_3, cpu_4

  INTEGER(C_INT)                                       :: fft_len  ! the number of points for FFT
  COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(:), ALLOCATABLE :: fft_inp  ! data to be transformed (0:fft_len-1)
  COMPLEX(C_DOUBLE_COMPLEX), DIMENSION(:), ALLOCATABLE :: fft_out  ! data to be transformed (0:fft_len-1)
  TYPE(C_PTR)                                          :: fft_plan ! plan needed for FFTW

  ! Taylor series coefficients
  REAL, PARAMETER :: b1 = 2.0, b2 = -2.0,     b3 = 4.0/3.0, b4 = -2.0/3.0  ! b = 1.0 - EXP(-2.0*x)
  REAL, PARAMETER :: d1 = 1.0, d2 = -1.0/2.0, d3 = 1.0/6.0, d4 = -1.0/24.0 ! d = 1.0 - EXP(-x)

  NAMELIST /nml/ nt, origin_interval, nstep, nequil, delta, temperature

  WRITE( unit=output_unit, fmt='(a)' ) 'corfun'
  WRITE( unit=output_unit, fmt='(a)' ) 'Illustrates methods for calculating time correlation functions'
  WRITE( unit=output_unit, fmt='(a)' ) 'using synthetic data from a generalized Langevin equation'

  CALL RANDOM_SEED () ! Initialize random number generator

  ! Example default values
  ! Agreement (to numerical precision) of direct and FFT methods is expected if origin_interval=1
  nt              = 1000  ! Max time for correlation function
  origin_interval = 1     ! This could reasonably be increased to 10 or 20 to improve efficiency
  nstep           = 2**20 ! Number of steps, about a million for example
  nequil          = 10000 ! Number of equilibration timesteps
  delta           = 0.01  ! Timestep for simulation
  temperature     = 1.0   ! Temperature for simulation

  ! Namelist from standard input
  READ ( unit=input_unit, nml=nml, iostat=ioerr )
  IF ( ioerr /= 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a,i15)') 'Error reading namelist nml from standard input', ioerr
     IF ( ioerr == iostat_eor ) WRITE ( unit=error_unit, fmt='(a)') 'End of record'
     IF ( ioerr == iostat_end ) WRITE ( unit=error_unit, fmt='(a)') 'End of file'
     STOP 'Error in corfun'
  END IF

  n0 = nt / origin_interval + 1
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of steps in run = ',    nstep
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Equilibration steps = ',       nequil
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Max correlation time nt = ',   nt
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Origin interval = ',           origin_interval
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of time origins n0 = ', n0
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Time step delta = ',           delta
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Temperature = ',               temperature

  ALLOCATE ( v(nstep), v0(n0), t0(n0) )
  ALLOCATE ( c(0:nt), c_fft(0:nt), n(0:nt) )
  fft_len = 2*nstep ! Actual length of FFT data
  ALLOCATE ( fft_inp(0:fft_len-1), fft_out(0:fft_len-1) )

  ! The memory function model is defined here
  ! Values used by Baczewski and Bond in their example are
  ! (m,kappa)
  ! (1.0,1.0)  (underdamped)
  ! (0.5,2.0)  (critically damped)
  ! (0.25,4.0) (overdamped)
  m     = 1.0
  kappa = 1.0
  WRITE ( unit=output_unit, fmt='(a,t40,*(f15.6))' ) 'm = ',     m
  WRITE ( unit=output_unit, fmt='(a,t40,*(f15.6))' ) 'kappa = ', kappa

  ! Coefficients used in algorithm
  x = delta*kappa
  e = EXP(-x) ! theta in B&B paper
  IF ( x > 0.0001 ) THEN
     b = 1.0 - EXP(-2.0*x)
     d = 1.0 - EXP(-x)
  ELSE  ! Taylor expansions for low x
     b = x * ( b1 + x * ( b2 + x * ( b3 + x * b4 ) ) )
     d = x * ( d1 + x * ( d2 + x * ( d3 + x * d4 ) ) )
  END IF
  b      = SQRT ( b )
  b      = b * SQRT ( kappa/2.0 ) ! alpha in B&B paper
  stddev = SQRT(2.0*temperature)

  ! Data generation
  CALL CPU_TIME ( cpu_1 )

  ! Initial values
  vt = 0.0
  s  = 0.0

  DO t = -nequil, nstep ! Loop over steps including an equilibration period

     ! Velocity Verlet type algorithm for vt and auxiliary variable s
     vt = vt + 0.5 * delta * s
     s  = e * s - d * m * vt + b * SQRT(m) * random_normal ( 0.0, stddev )
     vt = vt + 0.5*delta*s

     IF ( t > 0 ) v(t) = vt ! Store velocities, after equilibration

  END DO ! End loop over steps including an equilibration period

  CALL CPU_TIME ( cpu_2 )
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'CPU time to generate data = ', cpu_2-cpu_1

  ! Data analysis (direct method)

  c(:) = 0.0
  n(:) = 0.0
  mk   = 0 ! Storage location of time origin
  full = .FALSE.

  DO t = 1, nstep ! Main loop correlating data

     IF ( MOD(t-1,origin_interval) == 0 ) THEN
        mk = mk + 1
        IF ( mk > n0 ) THEN
           full = .TRUE.
           mk = mk - n0 ! Overwrite older values
        END IF
        t0(mk) = t    ! Store time origins
        v0(mk) = v(t) ! Store velocity at time origins
     END IF

     IF ( full ) THEN
        nk = n0 ! Correlate with all stored time origins
     ELSE
        nk = mk ! Correlate with those stored so far
     END IF

     DO k = 1, nk ! Loop over time origins

        dt = t - t0(k)

        IF ( dt >= 0 .AND. dt <= nt ) THEN ! Check that dt is in range
           c(dt) = c(dt) + v(t) * v0(k) ! Increment correlation function
           n(dt) = n(dt) + 1.0          ! Increment normalizing factor
        END IF ! End check that dt is in range

     END DO ! End loop over time origins

  END DO ! End main loop correlating data

  IF ( ANY ( n(:) < 0.5 ) ) THEN ! should never happen
     WRITE ( unit=error_unit, fmt='(a)') 'Normalization array error'
     STOP 'Error in corfun'
  END IF

  c(:) = c(:) / n(:) ! Normalise by number of increments

  CALL CPU_TIME ( cpu_3 )
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'CPU time for direct method = ', cpu_3-cpu_2

  ! Data analysis (FFT method)

  ! Prepare data for FFT
  fft_inp            = CMPLX(0.0) ! Fill input array with zeros
  fft_inp(0:nstep-1) = CMPLX(v)   ! Put data into first part (real only)

  ! Forward FFT
  fft_plan = fftw_plan_dft_1d ( fft_len, fft_inp, fft_out, FFTW_FORWARD, FFTW_ESTIMATE) ! Set up plan
  CALL fftw_execute_dft ( fft_plan, fft_inp, fft_out )                                  ! Execute FFT
  CALL fftw_destroy_plan ( fft_plan )                                                   ! Release plan

  fft_out = fft_out * CONJG ( fft_out ) ! Square modulus

  ! Reverse FFT
  fft_plan = fftw_plan_dft_1d ( fft_len, fft_out, fft_inp, FFTW_BACKWARD, FFTW_ESTIMATE) ! Set up plan
  CALL fftw_execute_dft ( fft_plan, fft_out, fft_inp )                                   ! Execute FFT
  CALL fftw_destroy_plan ( fft_plan )                                                    ! Release plan

  fft_inp = fft_inp / REAL ( fft_len ) ! Normalization factor associated with FFT itself

  n(:) = [ ( nstep-t, t = 0, nt ) ] ! Normalization factors associated with number of time origins
  IF ( ANY ( n(:) < 0.5 ) ) THEN ! should never happen
     WRITE ( unit=error_unit, fmt='(a)') 'Normalization array error'
     STOP 'Error in corfun'
  END IF
  c_fft   = REAL ( fft_inp(0:nt) ) / n(:) ! Apply normalization associated with number of time origins

  CALL CPU_TIME ( cpu_4 )
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'CPU time for FFT method = ', cpu_4-cpu_3

  WRITE ( unit=output_unit, fmt='(a)' ) 'Output to corfun.out'

  OPEN ( newunit=unit, file='corfun.out', status='replace', iostat=ioerr )
  IF ( ioerr /= 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a,i15)') 'Error opening file', ioerr
     STOP 'Error in corfun'
  END IF

  DO t = 0, nt
     WRITE ( unit=unit, fmt='(i10,3f15.8)' ) t, c(t), c_fft(t), c_exact(t*delta)
  END DO

  CLOSE(unit=unit)

  DEALLOCATE ( v, v0, t0, c, c_fft, n )
  DEALLOCATE ( fft_inp, fft_out )

CONTAINS

  FUNCTION c_exact ( t ) RESULT ( c )
    IMPLICIT NONE
    REAL             :: c ! Returns analytically known correlation function, for
    REAL, INTENT(in) :: t ! given time

    ! See AD Baczewski and SD Bond J Chem Phys 139 044107 (2013)
    ! In general the exact correlation function may be obtained from the inverse Laplace transform
    ! C(s) = (kT/m) * 1 / ( s + M(s) ) where both C(t) and M(t) are sums of exponentials in t
    ! M(s) = sum_p m_p*kappa_p / (s+kappa_p) p = 1..Np (note amplitude mp*kappa_p)
    ! C(s) = sum_p c_p / (s+k_p) p = 1..Np+1
    ! The coefficients c_p and k_p may be determined in terms of the m_p and kappa_p
    ! by solving an equation of order Np+1 and using partial fractions
    ! Here we just do this for the simplest case Np=1
    ! Agreement with the simulated function is only expected to within statistical error

    REAL :: del, omega, kp, km, cp, cm

    IF ( kappa > 4.0 * m ) THEN  ! Real roots

       del = SQRT ( 0.25*kappa**2 - m*kappa )
       kp  = 0.5*kappa + del
       km  = 0.5*kappa - del
       cp  = -km/(kp-km)
       cm  =  kp/(kp-km)
       c   = cp*EXP(-kp*t) + cm*EXP(-km*t)

    ELSE ! Complex roots

       omega = SQRT ( m*kappa - 0.25*kappa**2 )
       c     = EXP(-0.5*kappa*t) * ( COS(omega*t) + (0.5*kappa/omega)*SIN(omega*t) )

    END IF

  END FUNCTION c_exact

END PROGRAM corfun


! from http://www.cs.rpi.edu/~szymansk/OOF90/F90_Objects.html

      module fft1r_module
      integer, save, private :: saved_indx = -1
      integer, dimension(:), allocatable, save, private :: mixup
      complex, dimension(:), allocatable, save, private :: sct
      contains
         subroutine fft1r_init(indx)
! initialization call
         integer, intent(in) :: indx
         integer :: nx, nxh, ierr, isign=0
! allocate f and t: old, ugly fft requires them as arguments
         real, dimension(2**indx) :: f
         complex, dimension(2**(indx-1)) :: t
         if (indx.lt.0) then
            print *,'indx must be non-negative'
            stop
         endif
         nx = 2**indx ; nxh = nx/2 ; saved_indx = indx
         if (allocated(mixup)) deallocate(mixup)
         if (allocated(sct)) deallocate(sct)
         allocate(mixup(nxh),sct(nxh),stat=ierr)
         if (ierr.ne.0) then
            print *,'allocation error'
            stop
         endif
! call old, ugly but fast fft here
!         call lib_fft1r(f,t,isign,mixup,sct,saved_indx,nx,nxh)
         end subroutine fft1r_init
!
         subroutine fft1r_end
! deallocate internal data
         saved_indx = -1
         deallocate(mixup,sct)
         end subroutine fft1r_end
!
         subroutine fft1r(f,isign)
         real, dimension(:), intent(inout) :: f
         integer, intent(in) :: isign
         integer :: nx, nxh
         complex, dimension(size(f)/2) :: t
         nx = size(f) ; nxh = nx/2
! do nothing if isign is invalid
         if (isign.eq.0) return
         if (saved_indx.lt.0) then
            print *,'fft tables not initialized!'
            stop
         endif
! call old, ugly but fast fft here
!         call lib_fft1r(f,t,isign,mixup,sct,saved_indx,nx,nxh)
         end subroutine fft1r
      end module fft1r_module

      program main
      use fft1r_module
      implicit none
      integer :: indx, nx, i
      real, dimension(:), allocatable :: f
! write prompt without linefeed
!      write (6,'(a)',advance='no') 'enter indx: '
! obtain indx from input device
!      read (5,*) indx
       indx=4
! allocate array f
      nx = 2**indx
      allocate(f(nx))
! initialize data using array constructor
      f = (/(i,i=1,nx)/)
! initialize fft
      call fft1r_init(indx)
! call fft
      call fft1r(f,-1)
! terminate fft
      call fft1r_end
      print *, "OK"
      end


       SUBROUTINE variat_eig_full(n, h, eigfun, pf, qf, rf,
     1   eigenv)
       USE stel_kinds
       USE ballooning_data
       IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
       INTEGER,INTENT(IN) :: n
       REAL(rprec), INTENT(IN) :: h
       REAL(rprec), DIMENSION(n), INTENT(IN):: eigfun, qf,
     1  rf, pf
       REAL(rprec), INTENT(OUT) :: eigenv
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
       INTEGER :: istat
       REAL(rprec), DIMENSION(:), ALLOCATABLE :: INTr, INTq,
     1   INTp, coef, dery
       REAL(rprec) :: frac,frac1
!-----------------------------------------------
       ALLOCATE (intr(n), INTq(n), INTp(n), coef(n), dery(n),
     1           stat=istat)
       IF (istat .ne. 0) STOP 'Allocation error in variat_eig_full'

       frac = 2._dp/(3*h)
       frac1= 1._dp/(12*h)

       IF(tsymm.eq.0)then
         dery(1) = 0
         dery(2)=frac*(eigfun(3)-eigfun(1))
     1                 -frac1*(eigfun(4)-eigfun(2))
       ELSE
         dery(1)=frac*eigfun(2)-frac1*eigfun(3)
         dery(2)=frac*eigfun(3)-frac1*eigfun(4)
       ENDIF
       dery(3:n-2)=frac*(eigfun(4:n-1)-eigfun(2:n-3))
     1  -frac1*(eigfun(5:n)-eigfun(1:n-4))
       dery(n-1)=-frac*eigfun(n-2)-frac1*eigfun(n-3)
       dery(n)=-frac*eigfun(n-1)-frac1*eigfun(n-2)

       INTp=pf*(dery**2)
       INTr=rf*(eigfun**2)
       INTq=qf*(eigfun**2)

       coef=1
       coef(1)=0.354166666667_dp                                        ! USE 4-th oder alternative extended Simpson rule
       coef(2)=1.229166666667_dp                                        ! Numerical Recipes, Chapter 4, page 108
       coef(3)=0.895833333333_dp
       coef(4)=1.020833333333_dp
       coef(n:n-3:-1)=coef(1:4)
!       coef(1)=.5_dp                                                    ! 2-nd order extended trapezoidal rule can be chosen
!       coef(n)=.5_dp                                                    ! commenting the previous lines and uncommenting these

       INTp=coef*intp
       INTr=coef*intr
       INTq=coef*intq

       eigenv=(SUM(intp)-(SUM(intq)))/SUM(intr)

       DEALLOCATE (intr, INTq, INTp, coef, dery)

       END SUBROUTINE variat_eig_full


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!   SOLVER : BICGSTAB (d'après TEMPLATES)           11.02.97
!
!   Utilise ILU0 & ILUTP
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

PROGRAM TEST_BICGSTAB

    IMPLICIT REAL*8(A-H,O-Z)

    parameter(N = 100, NELEM = 5000, iwk= 10000)

    double precision ::  A(NELEM)

    integer :: IA(N+1), JA(NELEM)

    double precision :: ALU(iwk)
    integer :: JLU(iwk), JU(N)

    double precision :: B(N),X(N)
    integer :: iw(2*N)

    double precision :: r(N),r2(N),p(N),p2(N),s(N),s2(N),t(N),v(N)
    integer :: iperm(2*N)
    double precision :: xref(N)

    integer :: ierr

    ierr = 0

    ! Chargement de la matrice A et du vecteur b ---------
    CALL loadmat(A, IA, JA, b, xref, ierr)

    ! Paramètres du solver -------------------------------
    epsilon = 1.0D-8
    it_max  = 800
    iflag   = 2
    ierr    = 0

    ! Paramètres du préconditionneur ---------------------
    droptol = 0.0
    lfil    = 40
    permtol = 0.1
    mbloc   = N

    IF(iflag.EQ.1) THEN
        CALL ilu0(n, a, ja, ia, alu, jlu, ju, iw, ierr)
    ENDIF
    IF(iflag.EQ.2) THEN
        CALL ilutp(n, a, ja, ia, lfil, droptol, permtol, mbloc, alu,   &
                   jlu, ju, iwk, r, iw, iperm, ierr)
    ENDIF
    WRITE(*,*)ierr

    ! Appel de la sous-routine BICGSTAB -----------------

    CALL BICGSTAB(N, x, b, A, IA, JA, ALU, JLU, JU,    &
                  epsilon, it_max, r, r2, p, p2, s, s2, t, v,   &
                  IFLAG, ierr)

    ! Permutation de la solution (si pivotage employé) --

    IF(IFLAG.EQ.2) THEN
        DO i=1,N
            r(i)=x(iperm(n+i))
        END DO
        DO i=1,N
            x(i)=r(i)
        END DO
    ENDIF

    ! Sauvegarde du résultat vers MATLAB ----------------

    OPEN (UNIT = 1, FILE = 's_gmres.m', STATUS = 'UNKNOWN')
    DO i = 1, N
        WRITE(1,*) 'x(', i, ')=', x(i), ';'
    END DO
    CLOSE (UNIT = 1)

    ! Visualisation de la solution ----------------------

    WRITE(*,*)
    WRITE(*,*)' <ENTER> pour voir la solution'
    READ(*,*)

    CALL VectAff2(N, x, xref)

END PROGRAM TEST_BICGSTAB


c=======================================================================
c
c     subroutine ALLOCRB
c
c     Risk Budgeting allocation strategy
c     (Multi-Volatility-constrained)
c
c     Max[ w'*rho - k*w'*Q*w]
c      s.t.
c     sqrt[w'*cov_i*w] <= sigma(i)  (i-th risk budgeting constraint)
c     C*w <= b                      (general linear constraints)
c     Cinf <= w <= Csup             (lower/upper bounds)
c
c        w   : portfolio weights
c        Q   : covariance matrix
c        rho : assets performance
c
c-----------------------------------------------------------------------
      SUBROUTINE allocrb ( n, cov, Q, kappa, rho,
     &                     neq, nin, ccst, bcst,
     &                     cinf, csup, nbc, class, sigma,
     &                     iwork, dwork, wopt, lambda, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : portfolio size                                  integer
c       cov    : covariance matrix (n*n)                          double
c       Q      : matrix (n*n)                                     double
c       kappa  : risk aversion coefficient                        double
c       rho    : expected returns vector (n)                      double
c       neq    : number equality constraints                     integer
c       nin    : number inequality constraints                   integer
c       ccst   : matrix of constraints (n*(neq+nin))              double
c       bcst   : vector initial of constraints (neq+nin)          double
c       cinf   : lower bound (n)                                  double
c       csup   : upper bound (n)                                  double
c       nbc    : number of risk budgeting constraints (>=1)      integer
c       class  : block definition (n)                            integer
c       sigma  : volatilities budgets constraints (nbc)           double
c
c     WORKSPACE
c       iwork  : 2*nbc + 5*n + neq + 2*nin + 12                  integer
c       dwork  : nbc*(nbc+21)/2 +
c                n*(8*n+20+2*neq+2*nin)+4*neq+6*nin+14            double
c     OUTPUT
c       wopt   : optimal portfolio (n)                            double
c       lambda : optimal lambda (nbc)                             double
c       info   : diagnostic argument                             integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin, nbc
      INTEGER class(*)
      DOUBLE PRECISION kappa
      DOUBLE PRECISION cov(*), Q(*), rho(*), cinf(*), csup(*),
     &                 ccst(n,*), bcst(*), wopt(*), sigma(*), lambda(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, j, npk, totitr, totsim, ncst, infoBFGS, test,
     &        infot, izero
      INTEGER piwbf, pisim, pinfo, pin, pineq, pinin, piclass, piqp,
     &        pydual, pbinf, pbsup, pgrad, pwbf, pdsim,
     &        pdcov, pdrho, pdcinf, pdcsup, pdsigma, pdc, pdb,
     &        pdcov1, pdQ, pdkappa, pdqp, pdlagr, pdccs, pdbcs
      DOUBLE PRECISION funct, epsbfg, tmp, scal
      DOUBLE PRECISION INFINI, MINFINI, ZERO, EPS, ONE, COEF
      PARAMETER (INFINI=1.E+15,ZERO=0.E0,EPS=1.E-30,ONE=1E0,COEF=-0.5E0)
      PARAMETER (MINFINI = -1.E10)
c
c     external subroutines
      EXTERNAL simrb, simext, testsdp, OVTMCV, IVX, YV, bfgsmvol,
     &         checklinbox, initfeas, IVI
c
c     intrinsic functions
c
c-----------------------------------------------------------------------
c
c
c     initializations
      info = 0          ! diagnostic argument
      ncst = neq + nin  ! number total of constrains
      izero = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piwbf = 1
c     piwbf : pointer for BFGSMVOL who needs (2*nbc + 1)
c     so (2*nbc + 1)
      pisim  = piwbf + (2*nbc + 1)
c     pisim : pointer for simulator SIMRB (5*n + neq + 2*nin + 11)
c     so (2*nbc + 5*n + neq + 2*nin + 12)
      pinfo = pisim
c     pinfo : pointer for info (errors of simul), so 1 more
      pin   = pinfo + ( 1 )
c     pin   : pointer for value of n, so 1 more
      pineq = pin + ( 1 )
c     pineq : pointer for value of neq, so 1 more
      pinin = pineq + ( 1 )
c     pinin : pointer for value of nin, so 1 more
      piclass = pinin + ( 1 )
c     piclass: pointer for value of class, so n more
      piqp = piclass + ( n )
c     piqp : pointer for SIMRB
c
c     Total size of dwork array = 2*nbc + 5*n + neq + 2*nin + 12
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pydual = 1
c     pydual: pointer for initial value of ydual (nbc)
c     so (nbc)
      pbinf = pydual + ( nbc )
c     pbinf : pointer for inferior bounds binf (nbc)
c     so (2*nbc)
      pbsup = pbinf + ( nbc )
c     pbsup : pointer for superior bounds bsup (nbc)
c     so (3*nbc)
      pgrad = pbsup + ( nbc )
c     pgrad : pointer for gradient at solution (nbc)
c     so (4*nbc)
      pwbf = pgrad + ( nbc )
c     pwbf  : pointer for BFGSMVOL ( nbc*(nbc+11)/2 )
c     so ( nbc*(nbc+19)/2 )
      pdsim = pwbf + ( nbc*(nbc+11)/2 )
c     pdsim  : pointer for the simulator SIMRB
c             n*(7*n+20+2*neq+2*nin)+4*neq+6*nin+14+nbc
c     so
      pdcov   = pdsim
c     pdcov : pointer for cov. matrix (n*n)
      pdQ     = pdcov + ( n*n )
c     pdQ   : pointer for Q matrix (n*n)
      pdkappa = pdQ + ( n*n )
c     pdcov : pointer for kappa (1)
      pdrho   = pdkappa + ( 1 )
c     pdrho : pointer for expected returns (n)
      pdcinf  = pdrho + ( n )
c     pdcinf : pointer for lower bounds (n)
      pdcsup  = pdcinf + ( n )
c     pdcsup : pointer for upper bounds (n)
      pdsigma = pdcsup + ( n )
c     pdsigma : pointer for risk budget constraint (nbc)
      pdc     = pdsigma + ( nbc )
c     pdc : pointer for matrix constraint (n*(neq + nin))
      pdb     = pdc + ( n*(neq + nin) )
c     pdb : pointer for vector constraint (neq + nin)
      pdqp    = pdb + ( neq + nin )
c     pdqp : pointer for QP (SIMRB), (n*n + 6*n + 2*nin)
      pdlagr  = pdqp + ( n*n + 6*n + 2*nin )
c     pdlagr : pointer for QP parameter (2*n*n + 3*n + neq + nin)
      pdcov1  = pdlagr + ( 2*n*n + 3*n + neq + nin )
c     pdcov1  : temporary cov. matrix ( n*n )
      pdccs = pdcov1 + ( n*n )
c     needs n*(neq+nin+1)
      pdbcs = pdccs + n*(neq+nin+1)
c     needs neq+nin+1
c
c     Total size of dwork array = 4*nbc + ( nbc*(nbc+11)/2 )
c                               + n*(7*n+20+2*neq+2*nin)+4*neq+6*nin+14+nbc (SIMRB)
c                               + n*n + n*(neq+nin+1) + neq+nin+1
c           = nbc*(nbc+21)/2 + n*(8*n+21+3*neq+3*nin)+5*neq+7*nin+15
c
c-----------------------------------------------------------------------
c
c      TODO - test if classes are not all null
c
c-----------------------------------------------------
c     satisfiability conditions (well-defined problem)
c-----------------------------------------------------
c
c     matrices are SDP ?
      CALL testsdp (n, cov, iwork(pisim), dwork(pdsim), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'TESTSDP COV ', info
c      close(unit=1)

      CALL YV ( n*n, Q, dwork(pdQ) )
      IF (kappa .LT. EPS) CALL YV ( n*n, cov, dwork(pdQ) )
      CALL testsdp (n, dwork(pdQ), iwork(pisim), dwork(pdsim), info)
      IF (info .NE. 0) THEN
         info = -109
         RETURN
      ENDIF

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'TESTSDP Q ', info
c      close(unit=1)

c
c     problem initialization and feasibility check
      CALL initfeas ( n, cinf, csup, neq, nin, ccst, bcst,
     &                iwork(pisim), dwork(pdsim), wopt, info)
      IF (info .EQ. 1111) THEN
        info = -100
        RETURN
      ENDIF

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'INITFEAS 1 ', info
c      close(unit=1)

c
c------------------------------------------------------------
c     construction of work vectors (communication with simrb)
c------------------------------------------------------------
c
c     initialization
      CALL IVX ( nbc, dwork(pydual), ONE )   ! dual
      CALL IVX ( nbc, dwork(pbinf), ZERO )   ! lower bounds
      CALL IVX ( nbc, dwork(pbsup), INFINI ) ! upper bounds
c
c     construct of iwork (communication with simrb)
      iwork(pinfo) = 0       ! diagnostic argument
      iwork(pin)   = n       ! number of asset(s)
      iwork(pineq) = neq     ! number of eq. constraint(s)
      iwork(pinin) = nin     ! number of ineq. constraint(s)
      CALL YVI ( n, class, iwork(piclass) ) ! cov. matrix partition
c
c     construct dwork (communication with simrb)
      CALL YV(n*n, cov, dwork(pdcov))     ! cov. matrix
      CALL YV(n*n, Q, dwork(pdQ))         ! Q matrix
      CALL YV(n, rho, dwork(pdrho))       ! rho
      dwork(pdkappa) = kappa              ! kappa coef.
      CALL YV(n, cinf, dwork(pdcinf))     ! lower bounds
      CALL YV(n, csup, dwork(pdcsup))     ! upper bounds
      CALL YV(nbc, sigma, dwork(pdsigma)) ! risk budget(s)
c
c     case rho(1) = rho(2) = ... = rho(n)
      tmp = rho(1)
      test = 0
      DO i = 2,n
       IF (ABS(tmp - rho(i)) .GT. EPS) THEN
        test = 1
       ENDIF
      ENDDO
      IF (test .EQ. 0) THEN
        dwork(pdrho + 1) = dwork(pdrho + 1)
     &                     + 1.E-4*(MAX(dwork(pdrho + 1),1.E-6))
      ENDIF
c
c     case ncst <> 0 (neq=0, nin=0)
      IF (ncst .NE. 0) THEN
        CALL YM(n, ncst, ccst, dwork(pdc))  ! constraint matrix
        CALL YV(ncst, bcst, dwork(pdb))     ! constraint vector
      ENDIF
c
c-------------------------------------------------------------------
c     Non Linear optimization (BFGS)
c-------------------------------------------------------------------
      epsbfg = 1.E-10   ! precision stop test BFGS
      CALL bfgsmvol ( simrb, simext, nbc, dwork(pydual), epsbfg,
     &                dwork(pbinf), dwork(pbsup),
     &                iwork(piwbf), dwork(pwbf),
     &                funct, dwork(pgrad), totitr, totsim, info)

      CALL YV(nbc, dwork(pydual), lambda) ! ydual -> lambda
      infoBFGS = info ! BFGS diagnostic argument

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'BFGSMVOL ', infoBFGS
c      close(unit=1)

c
c-------------------------------------------------
c     Optimize with optimal dual solution (lambda)
c-------------------------------------------------
c
      CALL IMX ( n, n, dwork(pdcov), ZERO ) ! initialize pdcov
c
c     construct cov. matrix with optimal dual solution
      DO i = 1,nbc
         CALL IVI(n, iwork(piwbf), izero) ! initialize piwbf
c
c        dimension of block i
         npk = 0
         DO j = 1,n
            IF (class(j) .EQ. i) THEN
               npk = npk + 1
               iwork(piwbf + npk - 1) = j
            ENDIF
         ENDDO
         IF (npk .GT. 1) THEN
c
c           initialize temporary cov. matrix
            CALL IMX ( npk, npk, dwork(pdcov1), ZERO )
c
c           extract block i
            CALL YMCPI ( n, cov, npk, iwork(piwbf), dwork(pdcov1), info)
c
c           product lambda(i)*cov(i)
            CALL PMX (npk, npk, dwork(pdcov1), lambda(i), dwork(pdcov1))
c
c           sub-block -> cov. matrix
            CALL YMCPIR (npk, dwork(pdcov1), n, iwork(piwbf),
     &                   dwork(pdcov), info)
         ENDIF
      ENDDO
c
c     product kappa*Q -> pdcov2
      CALL PMX(n, n, Q, kappa, dwork(pdcov1))
c
c     kappa*Q + Sum(Cov_i)
      CALL SM(n, n, dwork(pdcov), dwork(pdcov1), dwork(pdcov))
c
c     linear part: l(i) = -0.5*rho(i)
      scal = -2.
      CALL PVX ( n, rho, COEF, dwork(pdrho) )
c
c     case rho(1) = rho(2) = ... = rho(n)
      tmp = rho(1)
      test = 0
      DO i = 2,n
       IF (ABS(tmp - rho(i)) .GT. EPS) THEN
        test = 1
       ENDIF
      ENDDO
      IF (test .EQ. 0) THEN
        dwork(pdrho + 1) = dwork(pdrho + 1)
     &                     + 1.E-4*(MAX(dwork(pdrho + 1),1.E-6))
      ENDIF
c
c     problem initialization and feasibility check
      CALL initfeas ( n, cinf, csup, neq, nin, ccst, bcst,
     &                iwork(piqp), dwork(pdqp), wopt, info)
      IF (info .EQ. 1111) THEN
        info = -100
        RETURN
      ENDIF

c     open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'INITFEAS 2', info
c      close(unit=1)

c
c     quadratic solver QP
      CALL qp ( n, dwork(pdcov), dwork(pdrho), neq, nin,
     &          dwork(pdc), dwork(pdb), cinf, csup,
     &          iwork(piqp), dwork(pdqp),
     &          dwork(pdlagr), wopt, info )

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'QUAPRO ', info
c      close(unit=1)

c
c----------------------------------------------------------------------
c     test if the ith-volatility budget constraint is too high/small
c     (budget constraint not attainable) -> info = 111/110
c----------------------------------------------------------------------
c
      IF (info .NE. 1001) THEN
        DO i = 1,nbc
            IF (ABS(lambda(i)) .LT. 1.E-15) THEN
                info = 111
            ENDIF
            IF (ABS(lambda(i)) .GT. 1.E+15) THEN
                info = 110
            ENDIF
        ENDDO
      ENDIF
c
c     checking non-emptiness of linear constraints
c      CALL checklinbox ( n, wopt,
c     &                   neq, nin, ccst, bcst, cinf, csup,
c     &                   dwork(pwbf), infot)
c      IF (infot .LT. 0) THEN
c        info = infot
c        RETURN
c      ENDIF

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'CHECKLINBOX ', info
c      close(unit=1)

c
c     construct cov. matrix with optimal dual solution
      DO i = 1,nbc
         DO j = 1,n
            iwork(piwbf + i - 1) = 0
         ENDDO
c
c        dimension of the i-th block
         npk = 0
         DO j = 1,n
            IF (class(j) .EQ. i) THEN
               npk = npk + 1
               iwork(piwbf + npk - 1) = j
            ENDIF
         ENDDO

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'TEST 1', info
c      close(unit=1)

         IF (npk .GT. 1) THEN
c
c           initialize temporary cov. matrix
            CALL IMX ( npk, npk, dwork(pdcov1), ZERO )
            CALL IMX ( n, n, dwork(pdcov), ZERO )

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'TEST 2', info
c      close(unit=1)

c
c           extracting the i-th block
            CALL YMCPI(n, cov, npk, iwork(piwbf), dwork(pdcov1), infot)

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'TEST 3', info
c      close(unit=1)

c
c           sub-block -> cov. matrix
            CALL YMCPIR (npk, dwork(pdcov1), n, iwork(piwbf),
     &                   dwork(pdcov), infot)

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'TEST 4', info
c      close(unit=1)

c
c           optimal portfolio volatility: sqrt[wopt'*Cov*wopt]
            CALL OVTMCV(n, dwork(pdcov), wopt, scal)
            scal = SQRT(scal)
            IF (scal .GT. (sigma(i)+1.E-6)) THEN
                info = -120
                RETURN
            ENDIF
         ENDIF
      ENDDO

c      open(unit=1,file='NUMXallocRiskBudgeting.txt',status='unknown')
c      write(1, *) 'TEST 5', info
c      close(unit=1)

c
c     BFGS diagnostic
      IF ((infoBFGS .NE. 0) .AND. (info .EQ. 0)) THEN
        info = infoBFGS
      ENDIF
      RETURN
      END


      Function UxcCA(rho_tmp,Uxc2)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DATA CEX/-1.969490099D0/
      DATA ONE/1.0D0/,HALF/0.5D0/,THALF/1.5D0/
      DATA ZERO/0.0D0/,THRD/0.333333333333333D0/
      DATA TFT/0.75D0/,TWO/2.0D0/
      DATA RC/0.02258D0/,EPS/1.0D-20/
C-----------------------------------------------------------------------
C
      RH3=max(rho_tmp,1.d-16)

C.
C. KOHN-SHAM EXCHANGE
C. CEPERLEY-ALDER / RPA CORRELATION
C.
      DATA GAMMA,BETA1,BETA2 /-0.2846d0, 1.0529d0, 0.3334d0/
      DATA A,B,C,D /0.0622d0,-0.096d0,0.0040d0,-0.0232d0 /
      DATA PI /3.141592654D0/
      DATA BETA11,BETA22 /1.228383333D0,0.44453333333D0/
      DATA B1,C1,D1 /-0.11673333D0,0.0026666667D0,-0.0168D0/
C
700   RHO=RH3
      RH3=RH3**THRD
      RS=(PI*RHO/TFT)**(-THRD)
      IF(RS .GE. ONE) THEN
       ROOTRS=SQRT(RS)
       VC=GAMMA*(ONE+BETA11*ROOTRS+BETA22*RS)
     *    /(ONE+BETA1*ROOTRS+BETA2*RS)**2
       EC=GAMMA/(ONE+BETA1*ROOTRS+BETA2*RS)
      ELSE
       XLNRS=LOG(RS)
       VC=A*XLNRS+B1+C1*RS*XLNRS+D1*RS
       EC=A*XLNRS+B+C*RS*XLNRS+D*RS
      END IF
      VEXCOR=CEX*RH3+VC
      Uxc2=(TFT*CEX*RH3+EC)/TWO
      UxcCA=VEXCOR/TWO
      RETURN
      END


c====================================================================================
c
c  Synthetic Seismogram code for complete synthetics using spectral technique
c    for Moment Tensor and Point Force sources in flat layered media
c
c    Funded by Treaty Verification Program, Lawrence Livermore National Lab
c
c    George Randall, Dept. of Geological Sciences, University of South Carolina
c           ger@tigger.seis.scarolina.edu
c    Steve Taylor, Los Alamos National Lab
c           taylor@beta.lanl.gov
c
c        based on
c       "Seismic Wave Propagation in Stratified Media" B.L.N. Kennett,
c        Cambridge University Press, 1983
c
c    Many useful discussions with and testing by
c    Chuck Ammon, Harley Benz, and Bill Walter
c    are gratefully acknowledged.
c
c
c====================================================================================
c
c  Version 1.0   February  1  1993
c
      subroutine srcvec( m, p, isrc  )
         integer m, isrc
         complex p
c
c     compute the upward and downward p and s waves from a
c     symmetric moment tensor source, for integer angular order m
c     and slowness p, for source isrc, (4.64) kennett
c
c     fix sign of +1 and -1 terms give results consistent with crfl and others
c
      include 'kennet.inc'
c
c     su,sv,sw,sp,ss,st are the components of the jump in
c     the displacement - stress vector
c     from kennett (1983) (4.59 - 4.60)
c
      complex su,sv,sw,sp,ss,st,i,zero
      data i,zero/(0.,1.),(0.,0.)/
c
c     calculate up and downgoing P,SV,SH at source (4.64) kennett
c
      if ( m .eq. 0 ) then
         su = mzz(isrc)/(rhos*alfas*alfas)
         ss = p*( .5*(mxx(isrc)+myy(isrc))
     *         - mzz(isrc)*(1. - 2.*betas*betas/(alfas*alfas)))
         pup0(isrc) = i*(mds21*ss - nds11*su)
         svup0(isrc) = i*(mds22*ss - nds12*su)
         pdn0(isrc) = i*(mus21*ss - nus11*su)
         svdn0(isrc) = i*(mus22*ss - nus12*su)
         shup0(isrc) = zero
         shdn0(isrc) = zero
       endif
      if ( m .eq. 1 ) then
         sv = -( mxz(isrc) - i*myz(isrc) )/(2.*rhos*betas*betas)
         sw = -(-myz(isrc) - i*mxz(isrc) )/(2.*rhos*betas*betas)
         pupp1(isrc) =-i*nds21*sv
         svupp1(isrc) =-i*nds22*sv
         pdnp1(isrc) =-i*nus21*sv
         svdnp1(isrc) =-i*nus22*sv
         shupp1(isrc) =-i*ndssh*sw
         shdnp1(isrc) =-i*nussh*sw
       endif
      if ( m .eq. -1 ) then
         sv = -(-mxz(isrc) - i*myz(isrc) )/(2.*rhos*betas*betas)
         sw = -( myz(isrc) - i*mxz(isrc) )/(2.*rhos*betas*betas)
         pupm1(isrc) = -i*nds21*sv
         svupm1(isrc) = -i*nds22*sv
         pdnm1(isrc) = -i*nus21*sv
         svdnm1(isrc) = -i*nus22*sv
         shupm1(isrc) = -i*ndssh*sw
         shdnm1(isrc) = -i*nussh*sw
       endif
      if ( m .eq. 2 ) then
         ss = .25*p*( myy(isrc) - mxx(isrc) + 2.*i*mxy(isrc) )
         st = .25*p*( i*(mxx(isrc) - myy(isrc)) + 2.*mxy(isrc) )
         pupp2(isrc) = i*mds21*ss
         svupp2(isrc) = i*mds22*ss
         pdnp2(isrc) = i*mus21*ss
         svdnp2(isrc) = i*mus22*ss
         shupp2(isrc) = i*mdssh*st
         shdnp2(isrc) = i*mussh*st
       endif
      if ( m .eq. -2 ) then
         ss = .25*p*( myy(isrc) - mxx(isrc) - 2.*i*mxy(isrc) )
         st = .25*p*( -i*(mxx(isrc) - myy(isrc)) + 2.*mxy(isrc) )
         pupm2(isrc) = i*mds21*ss
         svupm2(isrc) = i*mds22*ss
         pdnm2(isrc) = i*mus21*ss
         svdnm2(isrc) = i*mus22*ss
         shupm2(isrc) = i*mdssh*st
         shdnm2(isrc) = i*mussh*st
       endif
      return
      end


module top
implicit none
contains
recursive function f(x) result(m)
  integer :: n, m, x(:),y(size(x)), fst
  fst = x(1)
  if (fst == 1) then
    m = 0
  else
    y(1:fst) = x(fst:1:-1)
    y(fst+1:) = x(fst+1:)
    m = 1 + f(y)
  end if
end function

recursive function perms(x) result(p)
integer, pointer     :: p(:,:), q(:,:)
integer              :: x(:), n, k, i
n = size(x)
if (n == 1) then
  allocate(p(1,1))
  p(1,:) = x
else
  q => perms(x(2:n))
  k = ubound(q,1)
  allocate(p(k*n,n))
  p = 0
  do i = 1,n
    p(1+k*(i-1):k*i,1:i-1) = q(:,1:i-1)
    p(1+k*(i-1):k*i,i) = x(1)
    p(1+k*(i-1):k*i,i+1:) = q(:,i:)
  end do
end if
end function
end module

program topswort
use top
implicit none
integer :: x(10)
integer, pointer  :: p(:,:)
integer :: i, j, m

forall(i=1:10)
  x(i) = i
end forall

do i = 1,10
  p=>perms(x(1:i))
  m = 0
  do j = 1, ubound(p,1)
    m = max(m, f(p(j,:)))
  end do
  print "(i3,a,i3)", i,": ",m
end do
end program


      SUBROUTINE TORDRS
C
C     THIS SUBROUTINE COMPUTES THE STIFFNESS MATRIX AND THE MASS MATRIX
C     FOR AN AXI-SYMMETRIC TORDIDAL THIN SHELL RING
C
C     SINGLE PRECISION VERSION
C
C     THIS ROUTINE USES SUBROUTINES ROMBSK  DMATRX
C
C
C*****
C
C                        ECPT FOR THE TOROIDAL RING
C
C                                                       TYPE
C ECPT( 1) ELEMENT IDENTIFICATION                         I
C ECPT( 2) SCALAR INDEX NO. FOR GRID POINT A              I
C ECPT( 3) SCALAR INDEX NO. FOR GRID POINT B              I
C ECPT( 4) ANGLE OF CURVATURE AT GRID POINT A             R
C ECPT( 5) ANGLE OF CURVATURE AT GRID POINT B(NOT USED)   R
C ECPT( 6) MATERIAL ORIENTATION (NOT USED)                R
C ECPT( 7) MATERIAL IDENTIFICATION                        I
C ECPT( 8) MEMBRANE THICKNESS                             R
C ECPT( 9) FLEXURE THICKNESS                              R
C ECPT(10) COOR. SYS. ID. FOR GRID POINT A                I
C ECPT(11) X-COOR. OF GRID POINT A (IN BASIC COOR.)       R
C ECPT(12) Y-COOR. OF GRID POINT A (IN BASIC COOR.)       R
C ECPT(13) Z-COOR. OF GRID POINT A (IN BASIC COOR.)       R
C ECPT(14) COOR. SYS. ID. FOR GRID POINT B                I
C ECPT(15) X-COOR. OF GRID POINT B (IN BASIC COOR.)       R
C ECPT(16) Y-COOR. OF GRID POINT B (IN BASIC COOR.)       R
C ECPT(17) Z-COOR. OF GRID POINT B (IN BASIC COOR.)       R
C ECPT(18) EL. TEMPERATURE FOR MATERIAL PROPERTIES        R
C
C*****
C
      DOUBLE PRECISION CONSTD
      DIMENSION  IECPT(18),        ICS(2)
      DIMENSION
     X   AM(144),GAMBQF(72),GAMBQM(48),EE(4),AK(144),GAMRS(144),AKI(36),
     X ECPT(9),DELINT(66),D(144),R(2),Z(2),KOUT(144),GAMBQ(144)
      REAL KOUT,AKM(36),MOUT(144)
      INTEGER  DICT (9),ELID,ESTID
      LOGICAL  NOGO,HEAT
C
C
      COMMON /CONDAD/ CONSTD(5)
C
      COMMON   /MATIN/
     1                   MATIDC        ,MATFLG
     2,                  ELTEMP        ,STRESS
     3,                  SINTH         ,COSTH
      COMMON   /MATOUT/
     1                   E(3)          ,ANU(3)
     2,                  RHO           ,G(3)
     3,                  ALF(3)        ,TZERO,    GSUBE
      COMMON  /SYSTEM/ KSYSTM(55),HEAT
C
      COMMON  /EMGPRM/ DUM(15), ISMB(3),IPREC,NOGO,IHEAT
      COMMON  /EMGDIC/ IDM, LDICT,NGRIDS, ELID,ESTID
C
      COMMON  /EMGEST/ IDEL,IGP(2),ALPH(2),OM,MATID,TM,TF,ICS1,
     X                 R1,D1,Z1,ICS2,R2,D2,Z2,TEMPE
C
      EQUIVALENCE (DICT5,DICT(5))
      EQUIVALENCE (IECPT(1),ECPT(1),IDEL)
      EQUIVALENCE ( CONSTD(2) , TWOPI  )
      EQUIVALENCE ( CONSTD(4) , DEGRAD )
      EQUIVALENCE        (A1, ALPH(1)), (A2, ALPH(2))
      EQUIVALENCE        (GAMBQF(1), GAMBQ(1))
      EQUIVALENCE        (GAMBQM(1), GAMBQ(73))
      EQUIVALENCE        (DELINT(1), GAMBQ(1))
      EQUIVALENCE        (GAMRS(1),  GAMBQ(1))
C
C
C ----------------------------------------------------------------------
C
C     SET UP THE DICT ARRAY
C
      IPR= IPREC
      DICT(1) = ESTID
      DICT(3) = 12
      DICT(4) = 63
      ICS(1)= IECPT(10)
      ICS(2)= IECPT(14)
      R(1) = R1
      R(2) = R2
      Z(1) = Z1
      Z(2) = Z2
C
C
C TEST THE VALIDITY OF THE GRID POINT COORDINATES
C
      IF (R1 .LT. 0. .OR. R2 .LT. 0.) GO TO 7770
      IF (D1 .NE. 0. .OR. D2 .NE. 0.) GO TO 7770
C
C
C DETERMINE IF ELEMENT IS A TOROIDAL, CONICAL OR CYLINDRICAL RING
C
      ITORD = 0
      IF (ABS(A1-A2) .LE. 1.E-6) ITORD =1
      IF (ITORD .EQ. 1 .AND.ABS(A1 - 90.) .LE. 1.E-5) ITORD=-1
C
C
C COMPUTE THE ELEMENT COORDINATES
C
      A1 = A1 * DEGRAD
      A2 = A2 * DEGRAD
      PHIB = A2 - A1
      SINA1 = SIN(A1)
      COSA1 = COS(A1)
      SINA2 = SIN(A2)
      COSA2 = COS(A2)
C
      IF (ITORD .NE. 0) GO TO 100
C
C FOR THE TOROIDAL RING
C
      RP = SQRT((R2-R1)**2  + (Z2-Z1)**2)/(2.*SIN(PHIB/2.))
      S  = PHIB * RP
      GO TO 110
C
C  FOR THE CONICAL OR CYLINDRICAL RING
C
  100 RP = 0.
      S = SQRT((R2-R1)**2 + (Z2-Z1)**2)
C
C  COMPUTE THE BASIC AND REQUIRED INTEGRALS
C
C  SET UP THE ARRAY OF CONSTANTS FOR ROMBER INTEGRATION ROUTINE
C
  110 D(21) = 0.
      D(22) = RP
      D(23) = R1
      D(24) = COSA1
      D(25) = SINA1
C
C COMPUTE CONSTANTS NEEDED FOR INTEGRAL CALCULATIONS
C
      D(30) = R1 - RP * SINA1
      D(31) = RP * COSA1
      D(32) = RP * SINA1
      D(33) = COSA1 ** 2
      D(34) = SINA1 * COSA1
      D(35) = SINA1 ** 2
      D(36) = 0.5 - D(35)
C
C START LOOP  FOR CALCULATIONS OF INTEGRALS
C
      DO  260 JP1=1,11
      J = JP1 - 1
      K = (J * 6) + 1
      DJP1 = JP1
C
C TEST FOR ELEMENT SHAPE
C
      IF (ITORD) 240,120,170
C
C THE TOROIDAL RING BASIC INTEGRALS WILL BE COMPUTED IN
C LOCATIONS D(1),...,D(6)
C
  120 D(20) = (RP** JP1)
C
C COMPUTE I(J,1)
C
      D(1) = D(20) * (PHIB ** JP1) / DJP1
C
C COMPUTE I(J,2)
C
      D(2) = (PHIB**(JP1+1))/ (DJP1 + 1.)
      D(10)= 1.
      DO  130 I=1,20
      IP = JP1 + 2 * I + 1
      D(11) = 2 * I + 1
      D(10)= D(10)*D(11)*(D(11)-1.)
      D(12)= (-1.)**I * PHIB**IP/((DJP1+D(11))*D(10))
      D(13)= ABS(D(12)/D(2))
      D(2) = D(2)+ D(12)
      IF (D(13) .LE. 1.E-10) GO TO 140
  130 CONTINUE
      GO TO 7780
  140 D(2) = D(20)*D(2)
C
C COMPUTE I(J,3)
C
      D(3) = (PHIB ** JP1) / DJP1
      D(10) = 1.
      DO 150 I=1,20
      IP = JP1 + 2 * I
      D(11) = 2 * I
      D(10) = D(10)*D(11)*(D(11)-1.)
      D(12) = (-1.)**I  * PHIB**IP/((DJP1+D(11)) *D(10))
      D(13) = ABS(D(12)/D(3))
      D(3)  =  D(3) + D(12)
      IF (D(13).LE. 1.E-10) GO TO 160
  150 CONTINUE
      GO TO 7780
  160 CONTINUE
      D(3) = D(20) * D(3)
      D(26) = DJP1
C
C COMPUTE I(J,4)
C
      CALL ROMBSK( PHIB,D(10),IP,D(4),1,D(21))
      IF (IP .GE. 15) CALL MESAGE (30,26,IDEL)
      D(4) = D(20) * D(4)
C
C COMPUTE I(J,5)
C
      CALL ROMBSK (PHIB,D(10),IP,D(5),2,D(21))
      IF (IP .GE. 15) CALL MESAGE (30,26,IDEL)
      D(5) = D(20) * D(5)
C
C COMPUTE I(J,6)
C
      CALL ROMBSK (PHIB,D(10),IP,D(6),3,D(21))
      IF (IP .GE. 15) CALL MESAGE (30,26,IDEL)
      D(6) = D(20) * D(6)
C
C THE TOROIDAL RING REQUIRED INTEGRALS
C
      DELINT(K  ) = D(30) * D(1) + D(31) * D(2) + D(32) * D(3)
      DELINT(K+1) = COSA1 * D(2) + SINA1 * D(3)
      DELINT(K+2) = D(33) * D(4) + D(34) * D(5) + D(35) * D(6)
      DELINT(K+3) = COSA1 * D(3) - SINA1 * D(2)
      DELINT(K+4) = D(34) * (D(6)-D(4))  + D(36) * D(5)
      DELINT(K+5) = D(33) * D(6) - D(34) * D(5) + D(35) * D(4)
      GO TO 250
C
C THE CONICAL RING BASIC INTEGRALS WILL BE COMPUTED IN
C LOCATIONS D(1) AND D(2)
C
C
C COMPUTE I(J,1)
C
  170 D(1) = (S **JP1)/DJP1
      IF (J-1) 180,190,200
C
C   COMPUTE  I(0,2)
C
  180 D(2) = ALOG((R1 + S*COSA1)/R1)/COSA1
      GO TO 230
C
C    COMPUTE I(1,2)
C
  190 D(2) = (S-(R1/COSA1)*ALOG((R1+S*COSA1)/R1))/COSA1
      GO TO 230
C
C    COMPUTE I(J,2) WHERE J .GT.1
C
  200 D(2) =1./DJP1
      D(10)=  -S*COSA1/R1
      DO  210 I= 1,1000
      D(11) = JP1 + I
      D(12) = (D(10) ** I) / D(11)
      D(2) = D(2) + D(12)
      IF (D(12).LT. 1.E-4) GO TO 220
  210 CONTINUE
      GO TO 7780
  220 D(2)=  ((S**JP1)/R1)* D(2)
C
C THE CONICAL RING REQUIRED INTEGRALS
C
  230 DELINT(K  ) = R1*D(1) + COSA1*(S**(JP1+1)/(DJP1+1.))
      DELINT(K+1) = SINA1 * D(1)
      DELINT(K+2) = D(35) * D(2)
      DELINT(K+3) = COSA1 * D(1)
      DELINT(K+4) = D(34) * D(2)
      DELINT(K+5) = D(33) * D(2)
      GO TO 250
C
C THE CYLINDRICAL RING BASIC INTEGRALS WILL BE COMPUTED IN
C LOCATIONS D(1) AND D(2)
C
C
C COMPUTE I(J,1)
C
  240 D(1) = (S**JP1)/DJP1
C
C COMPUTE I(J,2)
C
      D(2) = D(1) / R1
C
C THE CYLINDRICAL RING REQUIRED INTEGRALS
C
      DELINT(K  ) =  R1*D(1) + COSA1*(S**(JP1+1)/(DJP1+1.))
      DELINT(K+1) = SINA1 * D(1)
      DELINT(K+2) = D(35) * D(2)
      DELINT(K+3) = 0.
      DELINT(K+4) = 0.
      DELINT(K+5) = 0.
C
  250 CONTINUE
C
  260 CONTINUE
C
C   IF STIFFNESS MATRIX NOT REQUIRED  GO TO MASS ROUTINE
C
C
C
C LOCATE THE MATERIAL PROPERTIES IN THE MAT1 OR MAT3 TABLE
C
      MATIDC = MATID
      MATFLG = 7
      ELTEMP = TEMPE
      CALL MAT(IDEL)
C
C
C SET MATERIAL PROPERTIES IN LOCAL VARIABLES
C
      EP = E(1)
      ET = E(2)
      VPT= ANU(1)
      VTP= VPT * ET / EP
      DEL = 1. - VPT*VTP
      DICT5 = G SUBE
C
C
C GENERATE THE ELASTIC CONSTANTS MATRIX(2X2)
C
      EE(1) = EP / DEL
      EE(2) = ET * VPT / DEL
      EE(3) = EE(2)
      EE(4) = ET / DEL
C
C
C FORM THE STIFFNESS MATRIX IN FIELD COORDINATES
C
C COMPUTE CONSTANTS NEEDED IN DMATRX SUBROUTINE
C
      D(1) = EP / ET
      D(7) = 0.
      IF (ITORD .EQ. 0) D(7) = 1./RP
      D(2) = D(1) * D(7)
      D(3) = D(2) * D(7)
      D(4) = VPT * D(7)
      D(5) =(EP * TM / (D(1) - VPT**2)) * TWOPI
      D(6) = (EP*TF**3)/(12.*(D(1)-VPT**2))*TWOPI
C
C CALL THE DMATRIX SUBROUTINE TO COMPUTE THE STIFFNESS MATRIX (10X10)
C
C NOTE THE DOUBLE SUBSCRIPTING USED IN DMATRIX SUBROUTINE IS
C COMPATIBLE WITH THE CALLING PROGRAM. THE DELINT ARRAY OF INTEGRALS
C IS A (11X6) SINGLY SUBSCRIPTED ARRAY (STORED ROWWISE) IN THE CALLING
C PROGRAM AND IT IS A (6X11) DOUBLY SUBSCRIPTED ARRAY (STORED
C COLUMNWISE) IN DMATRX ROUTINE.
C
      IF (ISMB(1) .EQ.  0) GO TO 270
      CALL DMATRS(AK(1),VPT,D(1),D(2),D(3),D(4),D(5),D(6),DELINT(1))
  270 IF (ISMB(2) .EQ. 0)  GO TO 279
      DO 275 I=1,100
  275 AM(I) = 0.
      AM(  1) = DELINT( 1)
      AM(  2) = DELINT( 7)
      AM(  3) = DELINT(13)
      AM(  4) = DELINT(19)
      AM( 11) = DELINT( 7)
      AM( 12) = DELINT(13)
      AM( 13) = DELINT(19)
      AM( 14) = DELINT(25)
      AM( 21) = DELINT(13)
      AM( 22) = DELINT(19)
      AM( 23) = DELINT(25)
      AM( 24) = DELINT(31)
      AM( 31) = DELINT(19)
      AM( 32) = DELINT(25)
      AM( 33) = DELINT(31)
      AM( 34) = DELINT(37)
      AM( 45) = DELINT( 1)
      AM( 46) = DELINT( 7)
      AM( 47) = DELINT(13)
      AM( 48) = DELINT(19)
      AM( 49) = DELINT(25)
      AM( 50) = DELINT(31)
      AM( 55) = DELINT( 7)
      AM( 56) = DELINT(13)
      AM( 57) = DELINT(19)
      AM( 58) = DELINT(25)
      AM( 59) = DELINT(31)
      AM( 60) = DELINT(37)
      AM( 65) = DELINT(13)
      AM( 66) = DELINT(19)
      AM( 67) = DELINT(25)
      AM( 68) = DELINT(31)
      AM( 69) = DELINT(37)
      AM( 70) = DELINT(43)
      AM( 75) = DELINT(19)
      AM( 76) = DELINT(25)
      AM( 77) = DELINT(31)
      AM( 78) = DELINT(37)
      AM( 79) = DELINT(43)
      AM( 80) = DELINT(49)
      AM( 85) = DELINT(25)
      AM( 86) = DELINT(31)
      AM( 87) = DELINT(37)
      AM( 88) = DELINT(43)
      AM( 89) = DELINT(49)
      AM( 90) = DELINT(55)
      AM( 95) = DELINT(31)
      AM( 96) = DELINT(37)
      AM( 97) = DELINT(43)
      AM( 98) = DELINT(49)
      AM( 99) = DELINT(55)
      AM(100) = DELINT(61)
C
      D(1) = TWO PI * RHO * TM
      DO  278  I=1,100
  278 AM(I)= D(1) * AM(I)
  279 CONTINUE
C
C
C
C FORM THE TRANSFORMATION MATRIX(10X12) FROM FIELD COORDINATES TO GRID
C POINT DEGREES OF FREEDOM
C
      DO 280 I=1,72
  280 GAMBQF(I)=0.
      D(1) = S
      D(2) = S ** 2
      D(3) = S ** 3
      D(4) = S ** 4
      D(5) = S ** 5
      GAMBQF(3) = 1.
      GAMBQF(16)= 1.
      GAMBQF(30)= .5
      GAMBQF(39)=-10./D(3)
      GAMBQF(40)= -6./D(2)
      GAMBQF(42)= -1.5/D(1)
      GAMBQF(45) = -GAMBQF(39)
      GAMBQF(46) = -4./D(2)
      GAMBQF(48) =  .5/D(1)
      GAMBQF(51) = 15./D(4)
      GAMBQF(52) =  8./D(3)
      GAMBQF(54) = 1.5/D(2)
      GAMBQF(57) = -GAMBQF(51)
      GAMBQF(58) =  7./D(3)
      GAMBQF(60) = -1./D(2)
      GAMBQF(63) = -6./D(5)
      GAMBQF(64) = -3./D(4)
      GAMBQF(66) = -.5/D(3)
      GAMBQF(69) = -GAMBQF(63)
      GAMBQF(70) =  GAMBQF(64)
      GAMBQF(72) = -GAMBQF(66)
      DO 290 I=1,48
  290 GAMBQM(I) = 0.
      GAMBQM(1) = 1.
      GAMBQM(17)= 1.
      GAMBQM(25)=  -3./D(2)
      GAMBQM(29) = -2./D(1)
      GAMBQM(31)= -GAMBQM(25)
      GAMBQM(35) = -1./D(1)
      GAMBQM(37) = 2./D(3)
      GAMBQM(41) = 1./D(2)
      GAMBQM(43) = -GAMBQM(37)
      GAMBQM(47) =  GAMBQM(41)
C
C
C TRANSFORM THE STIFFNESS MATRIX TO GRID POINT DEGREES OF FREEDOM
C
      IF(ISMB(1).EQ. 0) GO TO 295
      CALL GMMATS(GAMBQ(1),10,12,1, AK(1),10,10,0,  D(1))
      CALL GMMATS(D(1),12,10,0,GAMBQ(1),10,12,0, AK(1))
  295 IF (ISMB(2).EQ.0)  GO TO 299
C     REARRANGE GAMBQ FOR MASS MATRIX CALCULATIONS
      DO 296 I=1,72
296   D(I+48) = GAMBQ(I)
      DO 297 I=1,48
297   D(I) = GAMBQ(I+72)
      DO 298 I=1,120
 298  GAMBQ(I)=D(I)
      CALL GMMATS(GAMBQ(1),10,12,1, AM(1),10,10,0, D(1))
      CALL GMMATS (D(1),12,10,0 ,GAMBQ(1),10,12,0, AM(1))
C
  299 CONTINUE
C
C
C FORM THE TRANSFORMATION MATRIX (12X12) FROM ELEMENT TO BASIC
C COORDINATES
C
      DO 300 I=1,144
  300 GAMRS(I)=0.
      GAMRS( 1) =  COSA1
      GAMRS( 3) = -SINA1
      GAMRS(25) =  SINA1
      GAMRS(27) =  COSA1
      GAMRS(40) = -1.
      GAMRS(53) =  1.
      GAMRS(66) =  1.
      GAMRS(79) =  COSA2
      GAMRS(81) = -SINA2
      GAMRS(103)=  SINA2
      GAMRS(105)=  COSA2
      GAMRS(118) = -1.
      GAMRS(131) = 1.
      GAMRS(144) = 1.
C
C
C TRANSFORM THE STIFFNESS MATRIX FROM ELEMENT TO BASIC COORDINATES
C
      IF (ISMB(1).EQ.0)  GO TO 310
      CALL GMMATS (GAMRS(1),12,12,1,  AK(1),12,12,0,  D(1))
      CALL GMMATS (D(1),12,12,0,  GAMRS(1),12,12,0,  AK(1))
  310 IF (ISMB(2) .EQ.0)  GO TO 315
      CALL GMMATS (GAMRS(1),12,12,1, AM(1),12,12,0, D(1))
      CALL GMMATS (D(1),12,12,0, GAMRS(1),12,12,0, AM(1))
  315 CONTINUE
C
C
C LOCATE THE TRANSFORMATION MATRICES FROM BASIC TO LOCAL COORDINATES
C FOR THE TWO GRID POINTS AND EXPAND TO (6X6)
C THE TWO MATRICES WILL BE STORED IN D(1),...,D(36) AND D(37),...,D(72)
C RESPECTIVELY
C
      DO 320 I =1,72
  320 D(I) = 0.
      DO 350 I =1,2
      IF (ICS(I).EQ. 0) GO TO 350
      K = 36 * (I - 1)
      CALL TRANSS(ICS(I),D(73))
      DO 340 J=1,3
      KK = K + 6 * (J-1) + 1
      KL = 3 * (J-1) + 73
      KJ = K + 6 * (J+2) + J + 3
      D(KK  ) = D(KL  )
      D(KK+1) = D(KL+1)
      D(KK+2) = D(KL+2)
      D(KJ) = 1.
  340 CONTINUE
  350 CONTINUE
C
C  DIVIDE THE STIFFNESS MATRIX INTO 4 SUBMATRICES WHICH CAN THEN BE
C  TRANSFORMED FROM BASIC TO LOCAL COORDINATES THEN REINSERTED IN THE
C  STIFFNESS MATRIX IN INCREASING SIL ORDER
C
      DO 500 IP =1,2
      IPP = IP
      IF (IGP(1) .LT. IGP(2)) GO TO 400
      IPP = 3 - IP
  400 IR = 72 * (IPP-1)
      IAPP = 36* (IPP-1) +1
      DO 490 JI=1,2
      I= JI
      IF (IP .EQ. IPP ) GO TO 405
      I = 3-JI
C
C   PLACE THE APPROPRIATE SUBMATRIX INTO A (6X6) MATRIX
C
  405 IC =  6 *(I-1)
      K  = 0
      DO  410 II=1,6
      KL = IR + 12 *(II-1) +IC
      DO 410  IJ =1,6
      K = K+1
      KK = KL+ IJ
      AKI(K) = AK(KK)
      AKM(K) = AM(KK)
  410 CONTINUE
C
C   TRANSFORM FROM BASIC TO LOCAL  COORDINATES
C
      IF (ICS(IPP) .EQ. 0) GO TO 430
      IF (ISMB(1) .EQ. 0 ) GO TO 425
      CALL GMMATS (D(IAPP),6,6,1, AKI(1),6,6,0,  D(73))
      DO  420 J=1,36
  420 AKI(J)= D(J+72)
  425 IF (ISMB(2) .EQ. 0) GO TO 430
      CALL  GMMATS (D(IAPP),6,6,1, AKM(1),6,6,0, D(73))
      DO 428 J=1,36
  428 AKM(I) = D(J+72)
C
  430 IF (ICS(I) .EQ. 0) GO TO 450
      IAI =  36*(I-1) +1
      IF (ISMB(1) .EQ. 0) GO TO 445
      CALL GMMATS(AKI(1),6,6,0, D(IAI),6,6,0, D(73))
      DO 440 J=1,36
  440 AKI(J) =  D(J+72)
  445 IF (ISMB(2) .EQ. 0) GO TO 450
      CALL GMMATS(AKM(1),6,6,0, D(IAI),6,6,0, D(73))
      DO 448 J=1,36
  448 AKM(J) =D(J+72)
C
C    REINSERT INTO OVERALL STIFFNESS MATRIX ACCORDING TO INCREASING SIL
C
  450 DO 460 II = 1,6
      DO 460 JJ = 1,6
      KI = (II-1)*6 + JJ
      IOUT=  (IP-1)* 72 + (JI-1)*6  + (II-1)*12 + JJ
      KOUT(IOUT) = AKI(KI)
  460 MOUT(IOUT) = AKM(KI)
  490 CONTINUE
  500 CONTINUE
C
C     OUTPUT THE MATRIX BY EMGOUT
C
      DICT(2) = 1
      IF (ISMB(1) .EQ.0) GO TO 550
      CALL EMGOUT(KOUT,KOUT,144,1,DICT,1,IPR)
C
  550 IF (ISMB(2) .EQ.0) GO TO 600
      CALL EMGOUT(MOUT,MOUT,144,1,DICT,2,IPR)
C
  600 RETURN
C
C
C
C  SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO ACCUMULATE
C
 7770 CALL MESAGE (30,37,IDEL)
 7777 NOGO = .TRUE.
      RETURN
 7780 CALL MESAGE(30,26,IDEL)
      GO TO 7777
C
      END


      double complex function qlI3(p1,p2,p3,m1,m2,m3,mu2,ep)
      implicit none
      double precision p1,p2,p3,m1,m2,m3,mu2
      integer ep
C     pi=p(i)^2, i=1,2,3 are the four-momentum squared of the external lines
C     mi=m(i)^2, i=1,2,3,are the squares of the masses of the internal lines
C     mu2 is the square of the scale mu
C     ep=-2,-1,0 chooses the coefficient in the Laurent series.

      double precision psq(3),msq(3)
      double precision p1o,p2o,p3o,m1o,m2o,m3o,mu2o,scalefac,newmu2
      double complex Ival(-2:0)
      integer epdum
      logical qlzero
      data p1o,p2o,p3o,m1o,m2o,m3o,mu2o/7*-1d0/
      save Ival,p1o,p2o,p3o,m1o,m2o,m3o,mu2o
!$omp threadprivate(Ival,p1o,p2o,p3o,m1o,m2o,m3o,mu2o)

C--If we have already calculated, use the saved value
C--else setup the arrays
      if    ((p1 .eq. p1o)
     . .and. (p2 .eq. p2o)
     . .and. (p3 .eq. p3o)
     . .and. (m1 .eq. m1o)
     . .and. (m2 .eq. m2o)
     . .and. (m3 .eq. m3o)
     . .and. (mu2 .eq. mu2o)) then
      qlI3=Ival(ep)
      return
      else
C---recalculate
      p1o=p1
      p2o=p2
      p3o=p3
      m1o=m1
      m2o=m2
      m3o=m3
      mu2o=mu2
      endif

      scalefac=max(abs(m1),abs(m2),abs(m3),abs(p1),abs(p2),abs(p3))

      msq(1)=m1/scalefac
      msq(2)=m2/scalefac
      msq(3)=m3/scalefac
      psq(1)=p1/scalefac
      psq(2)=p2/scalefac
      psq(3)=p3/scalefac
      newmu2=mu2/scalefac
C----sort msq in ascending order (and reorder psq correspondingly)
      call qltrisort(psq,msq)

C----If internal masses all qlzero, reorder abs(psq) in ascending order
      if    (qlzero(abs(msq(1)))
     . .and. qlzero(abs(msq(2)))
     . .and. qlzero(abs(msq(3)))) then
      call qlsnglsort(3,psq)
      endif

C-----calculate value of integral
      call qlI3sub(msq,psq,newmu2,Ival)

C---apply the rescaling to the integral
      do epdum=-2,0
      Ival(epdum)=Ival(epdum)/scalefac
      enddo

      qlI3=Ival(ep)

      return
      end


c     DRDLASUM
c>> 1994-10-19 DRDLASUM Krogh  Changes to use M77CON
c>> 1994-07-14 DRDLASUM CLL
c>> 1992-05-07 CLL
c>> 1992-04-28 DRDLASUM Replaced '1' in format.
c>> 1987-12-09 DRDLASUM Lawson  Initial Code.
c--D replaces "?": DR?LASUM, ?LASUM
c     Demonstration program for evaluation of a Laguerre series.
c     ------------------------------------------------------------------
      integer j
      double precision x,a(0:6),y,w,dif,reldif,pn(6)
      data a / 7.2d0, -43.2d0, 108.0d0, -144.0d0,
     *         108.0d0, -43.2d0, 7.2d0 /
      data pn / 0.1d0, 0.3d0, 1.0d0, 3.0d0, 10.0d0, 30.0d0 /
c     ------------------------------------------------------------------
      print '(1x,3x,a1,12x,a1,14x,a3,9x,a6/)','x','y','dif','reldif'
      do 10 j = 1,6
        x = pn(j)
        call dlasum (x, 6, a, y)
        w = 0.01d0 * (x**6)
        dif = y - w
        reldif = dif / w
        print '(1x,f6.2,3x,g15.8,2(3x,g10.3))',x,y,dif,reldif
   10 continue
      end


include "remap_1d_grid2grid.f90"

subroutine remap_3d_grid2grid(x1min, x1max, x1grid, y1min, y1max, y1grid, z1min, z1max, z1grid &
  , x2min, x2max, x2grid, y2min, y2max, y2grid, z2min, z2max, z2grid, xpixlen, ypixlen, zpixlen, f1, f2)

  ! Remaps field 1 onto field 2 using exact weights.
  !
  ! Parameters
  ! ----------
  ! x1min : float
  !   Minimum x in grid 1.
  ! x1max : float
  !   Maximum x in grid 1.
  ! x1grid : int
  !   Number of grid points in grid 1 along x.
  ! y1min : float
  !   Minimum y in grid 1.
  ! y1max : float
  !   Maximum y in grid 1.
  ! y1grid : int
  !   Number of grid points in grid 1 along y.
  ! z1min : float
  !   Minimum z in grid 1.
  ! z1max : float
  !   Maximum z in grid 1.
  ! z1grid : int
  !   Number of grid points in grid 1 along z.
  ! x2min : float
  !   Minimum x in grid 2.
  ! x2max : float
  !   Maximum x in grid 2.
  ! x2grid : int
  !   Number of grid points in grid 2 along x.
  ! y2min : float
  !   Minimum y in grid 2.
  ! y2max : float
  !   Maximum y in grid 2.
  ! y2grid : int
  !   Number of grid points in grid 2 along y.
  ! z2min : float
  !   Minimum z in grid 2.
  ! z2max : float
  !   Maximum z in grid 2.
  ! z2grid : int
  !   Number of grid points in grid 2 along z.
  ! xpixlen : int
  !   Length of pixel mapping indices and weights along x.
  ! ypixlen : int
  !   Length of pixel mapping indices and weights along y.
  ! zpixlen : int
  !   Length of pixel mapping indices and weights along z.
  ! f1 : array
  !   Values on grid 1.
  !
  ! Returns
  ! -------
  ! f2 : array
  !   Remapped field 1 onto field 2.

  implicit none

  ! Parameter declarations

  integer, parameter :: dp = kind(1.d0)

  integer, intent(in) :: x1grid, y1grid, z1grid, x2grid, y2grid, z2grid, xpixlen, ypixlen, zpixlen
  real(kind=dp), intent(in) :: x1min, x1max, x2min, x2max
  real(kind=dp), intent(in) :: y1min, y1max, y2min, y2max
  real(kind=dp), intent(in) :: z1min, z1max, z2min, z2max
  real(kind=dp), intent(in) :: f1(x1grid*y1grid*z1grid)
  real(kind=dp), intent(out) :: f2(x2grid*y2grid*z2grid)
  real(kind=dp) :: xweights(xpixlen), yweights(ypixlen), zweights(zpixlen)
  integer :: xpix(xpixlen), ypix(ypixlen), zpix(zpixlen), pix(xpixlen*ypixlen*zpixlen), i, j, k
  integer :: xwhich2pix, ywhich2pix, zwhich2pix, ii, jj, i1, j1, k1

  ! Function

  do i = 1, x2grid

    xwhich2pix = i-1
    call remap_1d_grid2grid_pixel(x1min, x1max, x1grid, x2min, x2max, x2grid, xwhich2pix, xpixlen, xpix, xweights)

    do j = 1, y2grid

      ywhich2pix = j-1
      call remap_1d_grid2grid_pixel(y1min, y1max, y1grid, y2min, y2max, y2grid, ywhich2pix, ypixlen, ypix, yweights)

      do k = 1, z2grid

        zwhich2pix = k-1
        call remap_1d_grid2grid_pixel(z1min, z1max, z1grid, z2min, z2max, z2grid, zwhich2pix, zpixlen, zpix, zweights)

        call pix1dto3d(xpix, ypix, zpix, xpixlen, ypixlen, zpixlen, y1grid, z1grid, pix)

        ii = zwhich2pix + z2grid*(ywhich2pix + y2grid*xwhich2pix) + 1
        f2(ii) = 0.

        jj = 1

        do i1 = 1, xpixlen
          do j1 = 1, ypixlen
            do k1 = 1, zpixlen

              if (pix(jj) .NE. -1) then
                f2(ii) = f2(ii) + xweights(i1)*yweights(j1)*zweights(k1)*f1(pix(jj)+1)
              end if

              jj = jj + 1

            end do
          end do
        end do

      end do
    end do
  end do

end subroutine remap_3d_grid2grid


      subroutine areb1(th0,thf,g,th02,thf2)
C     subroutine    areb1     01/04/76
      th01=th0*0.01745329
      thf1=thf*0.01745329
      p=0.
      th=th0
      th1=th01
   15 if(th-90.) 106,107,108
  106 z5=sin(th1)*g/cos(th1)
      th2=atan(z5)/0.01745329
      go to 115
  107 th2=90.
      go to 115
  108 if(th-180.) 109,110,111
  109 t1=3.141593-th1
      z5=sin(t1)*g/cos(t1)
      th2=180.-atan(z5)/0.01745329
      go to 115
  110 th2=180.
      go to 115
  111 if(th-270.) 112,113,114
  112 t1=th1-3.141593
      z5=sin(t1)*g/cos(t1)
      th2=180.+atan(z5)/0.01745329
      go to 115
  113 th2=270.
      go to 115
  114 t1=6.28318531-th1
      z5=sin(t1)*g/cos(t1)
      th2=360.-atan(z5)/0.01745329
  115 if(p) 3,116,117
  116 th02=th2
      th=thf
      th1=thf1
      p=1.
      go to 15
  117 thf2=th2
    3 return
      end


      SUBROUTINE DHETR (NA,NB,NC,L,M,N,LOW,IGH,A,B,C,ORT)
      INTEGER NA,NB,NC,L,M,N,LOW,IGH
      DOUBLE PRECISION A(NA,N),B(NB,M),C(NC,N),ORT(N)
C
C     *** PURPOSE:
C
C     GIVEN A REAL GENERAL MATRIX A, DHETR REDUCES A SUBMATRIX
C     OF A IN ROWS AND COLUMNS LOW THROUGH IGH TO UPPER HESSENBERG
C     FORM BY ORTHOGONAL SIMILARITY TRANSFORMATIONS.  THESE
C     ORTHOGONAL TRANSFORMATIONS ARE FURTHER ACCUMULATED INTO ROWS
C     LOW THROUGH IGH OF AN N X M MATRIX B AND COLUMNS LOW
C     THROUGH IGH OF AN L X N MATRIX C BY PREMULTIPLICATION AND
C     POSTMULTIPLICATION, RESPECTIVELY.
C
C     THE CODE IS ADAPTED FROM THE EISPACK SUBROUTINE ORTHES
C     AND THE ORTHES DOCUMENTATION MAY BE CONSULTED FOR FURTHER
C     NUMERICAL DETAILS CONCERNING HOUSEHOLDER TRANSFORMATIONS.
C
C     ON ENTRY:
C
C        NA,NB,NC INTEGERS
C                 THE LEADING OR ROW DIMENSIONS OF THE ARRAYS
C                 A, B, AND C, RESPECTIVELY, AS DECLARED IN THE
C                 MAIN CALLING PROGRAM.
C
C        L        INTEGER
C                 NUMBER OF ROWS OF C.
C
C        M        INTEGER
C                 NUMBER OF COLUMNS OF B.
C
C        N        INTEGER
C                 ORDER OF A AND NUMBER OF ROWS OF B AND COLUMNS OF C.
C
C        LOW,IGH  INTEGERS
C                 INTEGERS DETERMINED BY THE BALANCING SUBROUTINE
C                 BALANC.  IF BALANC HAS NOT BEEN USED, SET  LOW = 1
C                 AND  IGH = N.
C
C        A        DOUBLE PRECISION(NA,N)
C                 AN N X N REAL GENERAL MATRIX TO BE REDUCED TO
C                 UPPER HESSENBERG FORM.
C
C        B        DOUBLE PRECISION(NB,M)
C                 AN N X M REAL MATRIX.
C
C        C        DOUBLE PRECISION(NC,N)
C                 AN L X N REAL MATRIX.
C
C     ON RETURN:
C
C        A        AN UPPER HESSENBERG MATRIX SIMILAR TO (VIA AN
C                 ORTHOGONAL MATRIX CONSISTING OF A SEQUENCE OF
C                 HOUSEHOLDER TRANSFORMATIONS) THE ORIGINAL MATRIX A;
C                 FURTHER INFORMATION CONCERNING THE ORTHOGONAL
C                 TRANSFORMATIONS USED IN THE REDUCTION IS CONTAINED
C                 IN THE ELEMENTS BELOW THE FIRST SUBDIAGONAL; SEE
C                 ORTHES DOCUMENTATION FOR DETAILS.
C
C        B        THE ORIGINAL B MATRIX PREMULTIPLIED BY THE
C                 TRANSPOSE OF THE ORTHOGONAL TRANSFORMATION USED TO
C                 REDUCE A.
C
C        C        THE ORIGINAL C MATRIX POSTMULTIPLIED BY THE ORTHOGONAL
C                 TRANSFORMATION USED TO REDUCE A.
C
C        ORT      DOUBLE PRECISION(N)
C                 A WORK VECTOR CONTAINING INFORMATION ABOUT THE
C                 ORTHOGONAL TRANSFORMATIONS; SEE ORTHES DOCUMENTATION
C                 FOR DETAILS.
C
C     THIS VERSION DATED JULY 1980.
C     ALAN J. LAUB, UNIVERSITY OF SOUTHERN CALIFORNIA.
C
C     SUBROUTINES AND FUNCTIONS CALLED:
C
C     NONE
C
C     INTERNAL VARIABLES:
C
      INTEGER I,II,J,JJ,K,KP1,KPN,LA
      DOUBLE PRECISION F,G,H,SCALE
C
C     FORTRAN FUNCTIONS CALLED:
C
      DOUBLE PRECISION DABS,DSIGN,DSQRT
C
      LA = IGH-1
      KP1 = LOW+1
      IF (LA .LT. KP1) GO TO 170
      DO 160 K = KP1,LA
         H = 0.0D0
         ORT(K) = 0.0D0
         SCALE = 0.0D0
C
C        SCALE COLUMN
C
         DO 10 I = K,IGH
              SCALE = SCALE+DABS(A(I,K-1))
   10    CONTINUE
         IF (SCALE .EQ. 0.0D0) GO TO 150
         KPN = K+IGH
         DO 20 II = K,IGH
              I = KPN-II
              ORT(I) = A(I,K-1)/SCALE
              H = H+ORT(I)*ORT(I)
   20    CONTINUE
         G = -DSIGN(DSQRT(H),ORT(K))
         H = H-ORT(K)*G
         ORT(K) = ORT(K)-G
C
C        FORM  (I-(U*TRANSPOSE(U))/H)*A
C
         DO 50 J = K,N
              F = 0.0D0
              DO 30 II = K,IGH
                   I = KPN-II
                   F = F+ORT(I)*A(I,J)
   30         CONTINUE
              F = F/H
              DO 40 I = K,IGH
                   A(I,J) = A(I,J)-F*ORT(I)
   40         CONTINUE
   50    CONTINUE
C
C        FORM  (I-(U*TRANSPOSE(U))/H)*B
C
         DO 80 J = 1,M
              F = 0.0D0
              DO 60 II = K,IGH
                   I = KPN-II
                   F = F+ORT(I)*B(I,J)
   60         CONTINUE
              F = F/H
              DO 70 I = K,IGH
                   B(I,J) = B(I,J)-F*ORT(I)
   70         CONTINUE
   80    CONTINUE
C
C        FORM  (I-(U*TRANSPOSE(U))/H)*A*(I-(U*TRANSPOSE(U))/H)
C
         DO 110 I = 1,IGH
              F = 0.0D0
              DO 90 JJ = K,IGH
                   J = KPN-JJ
                   F = F+ORT(J)*A(I,J)
   90         CONTINUE
              F = F/H
              DO 100 J = K,IGH
                   A(I,J) = A(I,J)-F*ORT(J)
  100         CONTINUE
  110    CONTINUE
C
C        FORM  C*(I-(U*TRANSPOSE(U))/H)
C
         DO 140 I = 1,L
              F = 0.0D0
              DO 120 JJ = K,IGH
                   J = KPN-JJ
                   F = F+ORT(J)*C(I,J)
  120         CONTINUE
              F = F/H
              DO 130 J = K,IGH
                   C(I,J) = C(I,J)-F*ORT(J)
  130         CONTINUE
  140    CONTINUE
         ORT(K) = SCALE*ORT(K)
         A(K,K-1) = SCALE*G
  150    CONTINUE
  160 CONTINUE
  170 CONTINUE
      RETURN
      END


      SUBROUTINE PHO_GAUSET(Ax,Bx,Nx,Z,W)
C********************************************************************
C
C     N-point gauss zeros and weights for the interval (AX,BX) are
C           stored in  arrays Z and W respectively.
C
C*********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION alpha , Ax , beta , Bx , delta , W , win ,
     &                 wtemp , Z , zcntr
      INTEGER in , j , jd96 , jmid , jp , jtab , k , m , n , nd96 , Nx
      SAVE

      INCLUDE 'inc/pogdat'
      DIMENSION Z(Nx) , W(Nx)

      alpha = 0.5D+00*(Bx+Ax)
      beta = 0.5D+00*(Bx-Ax)
      n = Nx

C  the N=1 case:
      IF ( n.EQ.1 ) THEN
         Z(1) = alpha
         W(1) = Bx - Ax
         RETURN

C  the Gauss cases:
      ELSE IF ( (n.GT.16) .OR. (n.LE.1) ) THEN
         IF ( n.NE.20 ) THEN
            IF ( n.NE.24 ) THEN
               IF ( n.NE.32 ) THEN
                  IF ( n.NE.40 ) THEN
                     IF ( n.NE.48 ) THEN
                        IF ( n.NE.64 ) THEN
                           IF ( n.NE.80 ) THEN

C  the extended Gauss cases:
                              IF ( n.NE.96 ) THEN

C  jump to center of intervall intrgration:
                               IF ( (n/96)*96.EQ.n ) THEN

C  get ND96 times chained 96 Gauss point array

                               CALL PHO_GAUDAT
C  print out message
C     -extract real points
                               k = KTAb(96)
                               nd96 = n/96
                               DO j = 1 , 48
C       extract values from big array
                               jtab = k - 1 + j
                               wtemp = beta*A(jtab)
                               delta = beta*X(jtab)
                               wtemp = wtemp/nd96
                               delta = delta/nd96
                               DO jd96 = 0 , nd96 - 1
                               zcntr = (alpha-beta)
     &                            + beta*DBLE(2*jd96+1)/DBLE(nd96)
C         store them backward
                               Z(j+jd96*96) = zcntr - delta
                               W(j+jd96*96) = wtemp
C         store them forward
                               jp = 96 + 1 - j
                               Z(jp+jd96*96) = zcntr + delta
                               W(jp+jd96*96) = wtemp
                               END DO
                               END DO
                               RETURN
                               ELSE

C  the center of intervall cases:
C  put in constant weight and equally spaced central points
                               n = ABS(n)
                               DO in = 1 , n
                               win = (Bx-Ax)/DBLE(n)
                               Z(in) = Ax + (DBLE(in)-.5D+00)*win
                               W(in) = win
                               END DO
                               GOTO 99999
                               END IF
                              END IF
                           END IF
                        END IF
                     END IF
                  END IF
               END IF
            END IF
         END IF
      END IF

C  get Gauss point array

      CALL PHO_GAUDAT
C  extract real points
      k = KTAb(n)
      m = n/2
      DO j = 1 , m
C       extract values from big array
         jtab = k - 1 + j
         wtemp = beta*A(jtab)
         delta = beta*X(jtab)
C       store them backward
         Z(j) = alpha - delta
         W(j) = wtemp
C       store them forward
         jp = n + 1 - j
         Z(jp) = alpha + delta
         W(jp) = wtemp
      END DO
C     store central point (odd N)
      IF ( (n-m-m).EQ.0 ) RETURN
      Z(m+1) = alpha
      jmid = k + m
      W(m+1) = beta*A(jmid)

99999 END SUBROUTINE


      subroutine segang(x1,y1,x2,y2,a,step,ind)
C...01/09/78
      if(abs(x1-x2).gt.step/2) goto 2
      ind=1
      i1=x1/step
      x=step*i1
      if(x2.le.x) goto 6
      x=x+step
      if(x2.lt.x) goto 5
    6 a=y1+(y2-y1)*(x-x1)/(x2-x1)
      go to 5
    2 ind=0
      a=(y2-y1)/(x2-x1)
    5 return
      end


      SUBROUTINE GAUSEL (MAX, N, A, NR, B, IERR)
C
C   PURPOSE:
C      Solve a set of linear equations, AX=B, by the method of Gaussian
C      elimination.  The constant matrices A and B are of dimension
C      n x n and n x r.  No information is returned on the pivotal
C      strategy or the value of the determinant of A.
C
C   Subroutines employed by GAUSEL: None
C   Subroutines employing GAUSEL: EXPADE
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(N,N),B(MAX,NR)
      NM1 = N-1
      IF (NM1 .EQ. 0) GO TO 140
C
C     FIND LARGEST REMAINING ELEMENT IN I-TH COLUMN FOR PIVOT
C
      DO 100 I=1,NM1
         BIG = 0.
         DO 20 K=I,N
            TERM = DABS(A(K,I))
            IF (TERM - BIG) 20,20,10
  10        BIG = TERM
            L = K
  20     CONTINUE
         IF (BIG) 40,30,40
  40     IF (I-L) 50,80,50
C
C     PIVOT ROWS OF A AND B
C
  50     CONTINUE
         DO 60 J=1,N
            TEMP = A(I,J)
            A(I,J) = A(L,J)
            A(L,J) = TEMP
  60     CONTINUE
         DO 70 J=1,NR
            TEMP = B(I,J)
            B(I,J) = B(L,J)
            B(L,J) = TEMP
  70     CONTINUE
  80     CONTINUE
C
C     STORE PIVOT AND PERFORM COLUMN OPERATIONS ON A AND B
C
         IP1 = I+1
         DO 100 II=IP1,N
            A(II,I) = A(II,I)/A(I,I)
            X3 = A(II,I)
            DO 90 K=IP1,N
               A(II,K) = A(II,K) - X3*A(I,K)
  90        CONTINUE
            DO 100 K=1,NR
               B(II,K) = B(II,K) - X3*B(I,K)
 100  CONTINUE
C
C     PERFORM BACK SUBSTITUTION
C
      DO 110 IC=1,NR
         B(N,IC) = B(N,IC)/A(N,N)
 110  CONTINUE
      DO 130 KK=1,NM1
         I = N-KK
         IP1 = I+1
         DO 130 J=1,NR
            SUM = B(I,J)
            DO 120 K=IP1,N
               SUM = SUM - A(I,K)*B(K,J)
 120        CONTINUE
            B(I,J) = SUM/A(I,I)
 130  CONTINUE
      RETURN
 140  CONTINUE
      IF (A(1,1) .EQ. 0.) GO TO 30
      DO 150 J=1,NR
         B(1,J) = B(1,J)/A(1,1)
 150  CONTINUE
      RETURN
  30     IERR = 2
      RETURN
      END