c --------------------------------------------------------------------
      real*8 function LQ_QBB(s,t1,ms1)

      implicit none

      real*8 Pi,Nc,Cf,alphas,fac
      real*8 s,t1,u1,ms1

      Pi = 4.D0*atan(1.D0)
      Nc = 3.D0
      Cf = 4.D0/3.D0
      alphas = 1.D0

      u1 = - s - t1

      fac = 1.D0/(64*Pi*Nc**2)

      LQ_QBB =
     +  + Nc*Cf*Pi**2*alphas**2 * (  - 64*ms1**2*s**(-3) + 64*s**(-4)*
     +    t1*u1 )

      LQ_QBB = fac * LQ_QBB

      end

c --------------------------------------------------------------------
      real*8 function LQ_QB1(s,t1,ms1,mu)

      implicit none

      real*8 Pi,Nc,Cf,Nf,alphas
      real*8 s,t1,u1,ms1,sca,mu
      real*8 conalp,consof,LQ_QBB

      Pi = 4.D0*atan(1.D0)
      Nc = 3.D0
      Cf = 4.D0/3.D0
      Nf = 6.D0
      alphas = 1.D0

      sca = (mu/ms1)**2

      u1 = - s - t1

c renormalization of coupling with light flavours
      conalp = alphas/2.D0/Pi * LQ_QBB(s,t1,ms1)
     &       * ( 11.D0/3.D0*Nc - 2.D0/3.D0 * (Nf-1.D0)) * log(sca)

      consof = -alphas*Cf/2.D0/Pi * LQ_QBB(s,t1,ms1)
     &       * ( - 2.D0 * log(-t1/ms1**2)
     &           - 2.D0 * log(-u1/ms1**2)
     &           + 3.D0                  ) * log(sca)

      LQ_QB1 = conalp + consof

      end

c --------------------------------------------------------------------
      real*8 function LQ_QB2(s,t1,s4,ms1,del,s4max,mu)

      implicit none

      real*8 Pi,Cf,alphas
      real*8 s,t1,s4,del,s4max,ms1,sca,mu
      real*8 dldel1,LQ_QBB

      Pi = 4.D0*atan(1.D0)
      Cf = 4.D0/3.D0
      alphas = 1.D0

      sca = (mu/ms1)**2

      dldel1 = log(s4max/ms1**2)
     &       - ( s4max - del )/s4

      LQ_QB2 = -alphas*Cf/2.D0/Pi * LQ_QBB(s,t1,ms1)
     &      * 4.D0*dldel1 * log(sca)

      end

c --------------------------------------------------------------------
      real*8 function LQ_QB3(s,t1,s4,ms1,mu)

      implicit none

      real*8 Pi,Nc,Cf,fac,alphas
      real*8 s,t1,u1,s4,ms1,sca,mu
      real*8 COLO1(9)

      Pi = 4.D0*atan(1.D0)
      Cf = 4.D0/3.D0
      Nc = 3.D0
      alphas = 1.D0

      sca = (mu/ms1)**2

      u1 = s4 - s - t1

      fac = s4 /(s4+ms1**2) /8.D0 /(16*Pi**2)**2 /Nc**2

      COLO1(9) = -log(sca)

      LQ_QB3 = 0.D0
      LQ_QB3 = LQ_QB3 + COLO1(9)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-4)*t1**(-1)*u1 + 1024*ms1**2*s**(-4)*t1*u1**(-1) + 4096
     +    *ms1**2*s**(-4)*t1*s4**(-1) - 4096*ms1**2*s**(-4)*t1**2*
     +    s4**(-2) - 2048*ms1**2*s**(-4) - 1024*ms1**2*s**(-3)*t1**(-2)
     +    *u1 + 1024*ms1**2*s**(-3)*t1**(-1) - 1024*ms1**2*s**(-3)*t1*
     +    u1**(-2) - 4096*ms1**2*s**(-3)*t1*s4**(-2) + 1024*ms1**2*
     +    s**(-3)*u1**(-1) - 2048*ms1**2*s**(-3)*s4**(-1) - 1024*ms1**2
     +    *s**(-2)*t1**(-2) - 1024*ms1**2*s**(-2)*u1**(-2) - 1024*
     +    ms1**4*s**(-3)*t1**(-2) + 2048*ms1**4*s**(-3)*t1**(-1)*
     +    s4**(-1) - 1024*ms1**4*s**(-3)*u1**(-2) + 2048*ms1**4*s**(-3)
     +    *u1**(-1)*s4**(-1) - 4096*ms1**4*s**(-3)*s4**(-2) + 1024*
     +    s**(-4)*t1**(-1)*u1**2 + 3072*s**(-4)*t1 + 1024*s**(-4)*t1**2
     +    *u1**(-1) - 4096*s**(-4)*t1**2*s4**(-1) - 1024*s**(-4)*u1 +
     +    1024*s**(-3)*t1**(-1)*u1 + 1024*s**(-3)*t1*u1**(-1) - 4096*
     +    s**(-3)*t1*s4**(-1) )

      LQ_QB3 = fac * LQ_QB3

      end

c --------------------------------------------------------------------
      real*8 function LQ_QBD(s,t1,s4,ms1,del,s4max)

      implicit none

      real*8 Pi,Nc,Cf,alphas,fac
      real*8 s,t1,u1,ms1,s4,del,s4max
      real*8 xw,COLO1(9),dldel1,dldel2
      real*8 m2(5)

      Pi = 4.D0*atan(1.D0)
      Nc = 3.D0
      Cf = 4.D0/3.D0
      alphas = 1.D0

      u1 = - s - t1
      xw = sqrt(1.D0-4.D0*ms1**2/s)

      m2(1) = s
      m2(2) = t1
      m2(3) = u1
      m2(4) = s4
      m2(5) = ms1**2

      call LOGAS_LQ(m2,COLO1)

      dldel1 = log(s4max/ms1**2)
     &       - ( s4max - del )/s4
      dldel2 = log(s4max/ms1**2)**2
     &       - 2.D0* ( s4max - del )/s4 * log(s4/ms1**2)

      fac = 1.D0/(64*Pi*Nc**2)

      LQ_QBD =
     +  + Nc*Cf**2*Pi*alphas**3*dldel1 * ( 128*ms1**2*s**(-3) + 128*
     +    s**(-4)*t1**2 + 128*s**(-3)*t1 )
      LQ_QBD = LQ_QBD + Nc*Cf**2*Pi*alphas**3*dldel2 * (  - 128*ms1**2*
     +    s**(-3) - 128*s**(-4)*t1**2 - 128*s**(-3)*t1 )
      LQ_QBD = LQ_QBD + COLO1(1)*Nc*Cf**2*Pi*alphas**3*dldel1 * ( -256*
     +    ms1**2*s**(-5)*t1**2*xw**(-1) - 256*ms1**2*s**(-4)*t1*
     +    xw**(-1) + 128*ms1**2*s**(-3)*xw**(-1) - 256*ms1**4*s**(-4)*
     +    xw**(-1) + 128*s**(-4)*t1**2*xw**(-1) + 128*s**(-3)*t1*
     +    xw**(-1) )
      LQ_QBD = LQ_QBD + COLO1(1)*Nc**2*Cf*Pi*alphas**3*dldel1 * ( 128*
     +    ms1**2*s**(-5)*t1**2*xw**(-1) + 128*ms1**2*s**(-4)*t1*
     +    xw**(-1) - 64*ms1**2*s**(-3)*xw**(-1) + 128*ms1**4*s**(-4)*
     +    xw**(-1) - 64*s**(-4)*t1**2*xw**(-1) - 64*s**(-3)*t1*xw**(-1)
     +     )
      LQ_QBD = LQ_QBD + COLO1(3)*Nc*Cf**2*Pi*alphas**3*dldel1 * ( -128*
     +    ms1**2*s**(-3) - 128*s**(-4)*t1**2 - 128*s**(-3)*t1 )
      LQ_QBD = LQ_QBD + COLO1(3)*Nc**2*Cf*Pi*alphas**3*dldel1 * ( 64*
     +    ms1**2*s**(-3) + 64*s**(-4)*t1**2 + 64*s**(-3)*t1 )
      LQ_QBD = LQ_QBD + COLO1(4)*Nc*Cf**2*Pi*alphas**3*dldel1 * ( -384*
     +    ms1**2*s**(-3) - 384*s**(-4)*t1**2 - 384*s**(-3)*t1 )
      LQ_QBD = LQ_QBD + COLO1(4)*Nc**2*Cf*Pi*alphas**3*dldel1 * ( 128*
     +    ms1**2*s**(-3) + 128*s**(-4)*t1**2 + 128*s**(-3)*t1 )
      LQ_QBD = LQ_QBD + COLO1(8)*Nc*Cf**2*Pi*alphas**3*dldel1 * ( 640*
     +    ms1**2*s**(-3) + 640*s**(-4)*t1**2 + 640*s**(-3)*t1 )
      LQ_QBD = LQ_QBD + COLO1(8)*Nc**2*Cf*Pi*alphas**3*dldel1 * ( -256*
     +    ms1**2*s**(-3) - 256*s**(-4)*t1**2 - 256*s**(-3)*t1 )

      LQ_QBD = fac * LQ_QBD

      end

c --------------------------------------------------------------------
      real*8 function LQ_QBV(s,t1,ms1,mt)

      implicit none

      real*8 Pi,Nc,Cf,Nf,alphas,fac,Nl
      real*8 s,t1,u1,ms1,mt
      real*8 ms12
      real*8 m2(2,6),softin(4)
      real*8 SK3B0A(5),SK3B0B(6),SK3B0C(2),SK3B0D(2,2),SK3BP(3)
      real*8 SK3C0A(8),SK3C0B(4),SK3C0C(5,2),SK3D0(7,2)
      real*8 SOF1(8)
      real*8 mur,dec,LQ_QBB

      Pi=4.D0*atan(1.D0)
      Nc = 3.D0
      Cf = 4.D0/3.D0
      Nf = 6.D0
      Nl = 1.D0
      alphas = 1.D0

      u1 = - s - t1
      fac = 1.D0/(64*Pi*Nc**2)

      m2(1,1) = s
      m2(1,2) = t1 + ms1**2
      m2(1,3) = u1 + ms1**2
      m2(1,4) = t1
      m2(1,5) = u1
      m2(2,1) = ms1**2
      m2(2,2) = 1.D0
      m2(2,3) = 1.D0
      m2(2,4) = 1.D0
      m2(2,5) = mt**2
      m2(2,6) = ms1**2

      call SCALAR_ARRAY_LQ_B(m2,SK3B0A,SK3B0B,SK3B0C,SK3B0D,SK3BP)
      call SCALAR_ARRAY_LQ_C(m2,SK3C0A,SK3C0B,SK3C0C,SK3D0)

c      write(99,*)'test1 ',m2

      softin(1) = s
      softin(2) = t1
      softin(3) = u1
      softin(4) = ms1**2

      call SOFT_ARRAY_LQ(softin,SOF1)

      mur = ms1

c decoupling of the heavy flavours from alpha_s
      dec = 2.D0*alphas/Pi * LQ_QBB(s,t1,ms1)*
     &      (  Nl/24.D0        * log(mur**2/ms1**2)
     &       + 1.D0/6.D0       * log(mur**2/mt**2)  )

      ms12 = ms1**2

      LQ_QBV =
     +  + Nc*Cf*Pi*alphas**3 * (  - 64./9.*Nf*ms1**2*s**(-3) - 64./9.*
     +    Nf*s**(-4)*t1**2 - 64./9.*Nf*s**(-3)*t1 + 32./9.*Nl*ms1**2*
     +    s**(-3) + 32./9.*Nl*s**(-4)*t1**2 + 32./9.*Nl*s**(-3)*t1 )
      LQ_QBV = LQ_QBV + Nc*Cf**2*Pi*alphas**3 * ( 64*ms1**2*s**(-3)+64*
     +    s**(-4)*t1**2 + 64*s**(-3)*t1 )
      LQ_QBV = LQ_QBV + Nc**2*Cf*Pi*alphas**3 * (  - 320./9.*ms1**2*
     +    s**(-3) - 320./9.*s**(-4)*t1**2 - 320./9.*s**(-3)*t1 )
      LQ_QBV = LQ_QBV + SK3B0A(2)*Nc*Cf*Pi*alphas**3 * ( -128./3.*mt**2
     +    *ms1**2*s**(-4) - 128./3.*mt**2*s**(-5)*t1**2 - 128./3.*mt**2
     +    *s**(-4)*t1 )
      LQ_QBV = LQ_QBV + SK3B0B(1)*Nc*Cf*Pi*alphas**3*( 64./3.*Nf*ms1**2
     +    *s**(-3) + 64./3.*Nf*s**(-4)*t1**2 + 64./3.*Nf*s**(-3)*t1 -
     +    64./3.*ms1**2*s**(-3) - 64./3.*s**(-4)*t1**2 - 64./3.*s**(-3)
     +    *t1 )
      LQ_QBV = LQ_QBV + SK3B0B(1)*Nc*Cf**2*Pi*alphas**3 * ( 96*ms1**2*
     +    s**(-3) + 96*s**(-4)*t1**2 + 96*s**(-3)*t1 )
      LQ_QBV = LQ_QBV + SK3B0B(1)*Nc**2*Cf*Pi*alphas**3 * ( 32*
     +    (s-4*ms12)**(-1)*s**(-3)*t1**2 + 32*(s-4*ms12)**(-1)*s**(-2)*
     +    t1 + 8*(s-4*ms12)**(-1)*s**(-1) - 256./3.*ms1**2*s**(-3) -
     +    256./3.*s**(-4)*t1**2 - 256./3.*s**(-3)*t1 - 8*s**(-2) )
      LQ_QBV = LQ_QBV + SK3B0B(2)*Nc*Cf*Pi*alphas**3 * (  - 64./3.*Nl*
     +    ms1**2*s**(-5)*t1**2 - 64./3.*Nl*ms1**2*s**(-4)*t1 + 16./3.*
     +    Nl*ms1**2*s**(-3) - 64./3.*Nl*ms1**4*s**(-4) + 16./3.*Nl*
     +    s**(-4)*t1**2 + 16./3.*Nl*s**(-3)*t1 )
      LQ_QBV = LQ_QBV + SK3B0B(2)*Nc*Cf**2*Pi*alphas**3 * ( 64*
     +    (s-4*ms12)**(-1)*s**(-3)*t1**2 + 64*(s-4*ms12)**(-1)*s**(-2)*
     +    t1 + 16*(s-4*ms12)**(-1)*s**(-1) + 64*ms1**2*s**(-3) + 64*
     +    s**(-4)*t1**2 + 64*s**(-3)*t1 - 16*s**(-2) )
      LQ_QBV = LQ_QBV + SK3B0B(2)*Nc**2*Cf*Pi*alphas**3 * (  - 32*
     +    (s-4*ms12)**(-1)*s**(-3)*t1**2 - 32*(s-4*ms12)**(-1)*s**(-2)*
     +    t1 - 8*(s-4*ms12)**(-1)*s**(-1) - 32*ms1**2*s**(-3) - 32*
     +    s**(-4)*t1**2 - 32*s**(-3)*t1 + 8*s**(-2) )
      LQ_QBV = LQ_QBV + SK3B0B(4)*Nc*Cf*Pi*alphas**3 * ( 128./3.*mt**2*
     +    ms1**2*s**(-4) + 128./3.*mt**2*s**(-5)*t1**2 + 128./3.*mt**2*
     +    s**(-4)*t1 + 64./3.*ms1**2*s**(-3) + 64./3.*s**(-4)*t1**2 +
     +    64./3.*s**(-3)*t1 )
      LQ_QBV = LQ_QBV + SK3B0C(1)*Nc*Cf**2*Pi*alphas**3 * (  - 64*
     +    (s-4*ms12)**(-1)*s**(-3)*t1**2 - 64*(s-4*ms12)**(-1)*s**(-2)*
     +    t1 - 16*(s-4*ms12)**(-1)*s**(-1) - 64*ms1**2*s**(-3) - 64*
     +    s**(-4)*t1**2 - 64*s**(-3)*t1 + 16*s**(-2) )
      LQ_QBV = LQ_QBV + SK3BP(1)*Nc*Cf**2*Pi*alphas**3 * ( -128*ms1**2*
     +    s**(-4)*t1**2 - 128*ms1**2*s**(-3)*t1 - 128*ms1**4*s**(-3) )
      LQ_QBV = LQ_QBV + SK3C0A(1)*Nc*Cf**2*Pi*alphas**3 * ( 64*ms1**2*
     +    s**(-2) + 64*s**(-3)*t1**2 + 192*s**(-2)*t1 + 64*s**(-1) )
      LQ_QBV = LQ_QBV + SK3C0A(1)*Nc**2*Cf*Pi*alphas**3 * ( -48*ms1**2*
     +    s**(-2) - 64*s**(-3)*t1**2 - 112*s**(-2)*t1 - 32*s**(-1) )
      LQ_QBV = LQ_QBV + SK3C0B(1)*Nc*Cf**2*Pi*alphas**3 * ( -128*ms1**2
     +    *s**(-4)*t1**2 - 128*ms1**2*s**(-3)*t1 + 64*ms1**2*s**(-2) -
     +    128*ms1**4*s**(-3) + 64*s**(-3)*t1**2 + 64*s**(-2)*t1 )
      LQ_QBV = LQ_QBV + SK3C0B(1)*Nc**2*Cf*Pi*alphas**3 * ( 64*ms1**2*
     +    s**(-4)*t1**2 + 64*ms1**2*s**(-3)*t1 - 32*ms1**2*s**(-2) + 64
     +    *ms1**4*s**(-3) - 32*s**(-3)*t1**2 - 32*s**(-2)*t1 )
      LQ_QBV = LQ_QBV + SK3C0B(2)*Nc*Cf**2*Pi*alphas**3 * ( -256*ms1**2
     +    *s**(-3)*t1 - 128*ms1**2*s**(-2) + 128*s**(-2)*t1 + 64*
     +    s**(-1) )
      LQ_QBV = LQ_QBV + SK3C0B(2)*Nc**2*Cf*Pi*alphas**3 * ( 16*
     +    (s-4*ms12)**(-1)*s**(-2)*t1**2 + 16*(s-4*ms12)**(-1)*s**(-1)*
     +    t1 + 4*(s-4*ms12)**(-1) + 96*ms1**2*s**(-3)*t1 + 32*ms1**2*
     +    s**(-2) - 48*s**(-3)*t1**2 - 96*s**(-2)*t1 - 36*s**(-1) )
      LQ_QBV = LQ_QBV + SK3C0C(1,1)*Nc*Cf**2*Pi*alphas**3 *(128*ms1**2*
     +    s**(-3)*t1 + 128*s**(-3)*t1**2 )
      LQ_QBV = LQ_QBV + SK3C0C(1,1)*Nc**2*Cf*Pi*alphas**3 * (  - 32*
     +    ms1**2*s**(-3)*t1 - 32*s**(-3)*t1**2 )
      LQ_QBV = LQ_QBV + SK3C0C(1,2)*Nc*Cf**2*Pi*alphas**3 *(128*ms1**2*
     +    s**(-3)*t1 + 128*ms1**2*s**(-2) - 128*s**(-3)*t1**2 - 256*
     +    s**(-2)*t1 - 128*s**(-1) )
      LQ_QBV = LQ_QBV + SK3C0C(1,2)*Nc**2*Cf*Pi*alphas**3 * (  - 64*
     +    ms1**2*s**(-3)*t1 - 64*ms1**2*s**(-2) + 64*s**(-3)*t1**2 +
     +    128*s**(-2)*t1 + 64*s**(-1) )
      LQ_QBV = LQ_QBV + SK3D0(1,1)*Nc*Cf**2*Pi*alphas**3 * ( 64*ms1**2*
     +    s**(-2)*t1 + 128*s**(-3)*t1**3 + 64*s**(-2)*t1**2 )
      LQ_QBV = LQ_QBV + SK3D0(1,1)*Nc**2*Cf*Pi*alphas**3 * ( -16*ms1**2
     +    *s**(-2)*t1 - 32*s**(-3)*t1**3 - 16*s**(-2)*t1**2 )
      LQ_QBV = LQ_QBV + SK3D0(1,2)*Nc*Cf**2*Pi*alphas**3 * ( 64 + 64*
     +    ms1**2*s**(-2)*t1 + 64*ms1**2*s**(-1) + 128*s**(-3)*t1**3 +
     +    320*s**(-2)*t1**2 + 256*s**(-1)*t1 )
      LQ_QBV = LQ_QBV + SK3D0(1,2)*Nc**2*Cf*Pi*alphas**3 * ( -32 - 32*
     +    ms1**2*s**(-2)*t1 - 32*ms1**2*s**(-1) - 64*s**(-3)*t1**3 -
     +    160*s**(-2)*t1**2 - 128*s**(-1)*t1 )
      LQ_QBV = LQ_QBV + SOF1(1)*Nc*Cf**2*Pi*alphas**3 * ( 512*ms1**2*
     +    s**(-4)*t1**2 + 512*ms1**2*s**(-3)*t1 - 256*ms1**2*s**(-2) +
     +    512*ms1**4*s**(-3) - 256*s**(-3)*t1**2 - 256*s**(-2)*t1 )
      LQ_QBV = LQ_QBV + SOF1(1)*Nc**2*Cf*Pi*alphas**3 * ( -256*ms1**2*
     +    s**(-4)*t1**2 - 256*ms1**2*s**(-3)*t1 + 128*ms1**2*s**(-2) -
     +    256*ms1**4*s**(-3) + 128*s**(-3)*t1**2 + 128*s**(-2)*t1 )
      LQ_QBV = LQ_QBV + SOF1(2)*Nc*Cf**2*Pi*alphas**3 * ( 256*ms1**2*
     +    s**(-4)*t1**2 + 256*ms1**2*s**(-3)*t1 + 256*ms1**4*s**(-3) )
      LQ_QBV = LQ_QBV + SOF1(3)*Nc*Cf**2*Pi*alphas**3 * ( 256*ms1**2*
     +    s**(-4)*t1**2 + 256*ms1**2*s**(-3)*t1 + 256*ms1**4*s**(-3) )
      LQ_QBV = LQ_QBV + SOF1(4)*Nc*Cf**2*Pi*alphas**3 * ( -512*ms1**2*
     +    s**(-3)*t1 - 512*ms1**2*s**(-2) - 512*s**(-4)*t1**3 - 1024*
     +    s**(-3)*t1**2 - 512*s**(-2)*t1 )
      LQ_QBV = LQ_QBV + SOF1(4)*Nc**2*Cf*Pi*alphas**3 * ( 256*ms1**2*
     +    s**(-3)*t1 + 256*ms1**2*s**(-2) + 256*s**(-4)*t1**3 + 512*
     +    s**(-3)*t1**2 + 256*s**(-2)*t1 )
      LQ_QBV = LQ_QBV + SOF1(5)*Nc*Cf**2*Pi*alphas**3 * ( -512*ms1**2*
     +    s**(-3)*t1 - 512*s**(-4)*t1**3 - 512*s**(-3)*t1**2 )
      LQ_QBV = LQ_QBV + SOF1(5)*Nc**2*Cf*Pi*alphas**3 * ( 128*ms1**2*
     +    s**(-3)*t1 + 128*s**(-4)*t1**3 + 128*s**(-3)*t1**2 )
      LQ_QBV = LQ_QBV + SOF1(6)*Nc*Cf**2*Pi*alphas**3 * ( -512*ms1**2*
     +    s**(-3)*t1 - 512*s**(-4)*t1**3 - 512*s**(-3)*t1**2 )
      LQ_QBV = LQ_QBV + SOF1(6)*Nc**2*Cf*Pi*alphas**3 * ( 128*ms1**2*
     +    s**(-3)*t1 + 128*s**(-4)*t1**3 + 128*s**(-3)*t1**2 )
      LQ_QBV = LQ_QBV + SOF1(7)*Nc*Cf**2*Pi*alphas**3 * ( -512*ms1**2*
     +    s**(-3)*t1 - 512*ms1**2*s**(-2) - 512*s**(-4)*t1**3 - 1024*
     +    s**(-3)*t1**2 - 512*s**(-2)*t1 )
      LQ_QBV = LQ_QBV + SOF1(7)*Nc**2*Cf*Pi*alphas**3 * ( 256*ms1**2*
     +    s**(-3)*t1 + 256*ms1**2*s**(-2) + 256*s**(-4)*t1**3 + 512*
     +    s**(-3)*t1**2 + 256*s**(-2)*t1 )
      LQ_QBV = LQ_QBV + SOF1(8)*Nc*Cf**2*Pi*alphas**3 * ( -256*ms1**2*
     +    s**(-2) - 256*s**(-3)*t1**2 - 256*s**(-2)*t1 )
      LQ_QBV = LQ_QBV + SOF1(8)*Nc**2*Cf*Pi*alphas**3 * ( 128*ms1**2*
     +    s**(-2) + 128*s**(-3)*t1**2 + 128*s**(-2)*t1 )

      LQ_QBV = fac * LQ_QBV  + dec

      end

c --------------------------------------------------------------------
      real*8 function LQ_QBH(s,t1,s4,ms1)

      implicit none

      real*8 Pi,Nc,Cf,alphas,fac
      real*8 s,t1,u1,ms1,s4
      real*8 hardin(5)
      real*8 ANG4(71),COLO1(9)

      Pi = 4.D0*atan(1.D0)
      Nc = 3.D0
      Cf = 4.D0/3.D0
      alphas = 1.D0

      u1 = s4 - s - t1
      fac = s4 /(s4+ms1**2) /8.D0 /(16*Pi**2)**2 /Nc**2

      hardin(1) = s
      hardin(2) = t1
      hardin(3) = u1
      hardin(4) = s4
      hardin(5) = ms1**2

      call LOGAS_LQ(hardin,COLO1)
      call ANGULAR_ARRAY_LQ(hardin,ANG4)

      LQ_QBH =
     +  + Nc*Cf**2*Pi**4*alphas**3 * ( 1024*ms1**2*s**(-4)*t1**(-1)*u1
     +     + 1024*ms1**2*s**(-4)*t1*u1**(-1) - 4096*ms1**2*s**(-4)*t1*
     +    s4**(-1) + 2048*ms1**2*s**(-4)*t1**2*s4**(-2) + 2048*ms1**2*
     +    s**(-4) - 1024*ms1**2*s**(-3)*t1**(-2)*u1 - 1024*ms1**2*
     +    s**(-3)*t1**(-1) - 1024*ms1**2*s**(-3)*t1*u1**(-2) + 2048*
     +    ms1**2*s**(-3)*t1*s4**(-2) - 1024*ms1**2*s**(-3)*u1**(-1) -
     +    1024*ms1**2*s**(-2)*t1**(-2) - 1024*ms1**2*s**(-2)*u1**(-2)
     +     - 1024*ms1**4*s**(-3)*t1**(-2) - 1024*ms1**4*s**(-3)*
     +    u1**(-2) + 2048*ms1**4*s**(-3)*s4**(-2) + 1024*s**(-4)*
     +    t1**(-1)*u1**2 + 1024*s**(-4)*t1 + 1024*s**(-4)*t1**2*
     +    u1**(-1) + 1024*s**(-4)*u1 + 1024*s**(-3)*t1**(-1)*u1 + 1024*
     +    s**(-3)*t1*u1**(-1) + 1024*s**(-3)*t1*s4**(-1) )
      LQ_QBH = LQ_QBH + ANG4(9)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**2*
     +    s**(-4) )
      LQ_QBH = LQ_QBH + ANG4(10)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-3) )
      LQ_QBH = LQ_QBH + ANG4(11)*Nc**2*Cf*Pi**4*alphas**3 * ( -1024*
     +    ms1**2*s**(-5)*s4*(t1+u1)**(-1) + 1024*ms1**2*s**(-5) )
      LQ_QBH = LQ_QBH + ANG4(12)*Nc*Cf**2*Pi**4*alphas**3 *(2048*ms1**2
     +    *s**(-4)*t1*s4**(-1) - 4096*ms1**2*s**(-4)*s4*(t1+u1)**(-1)
     +     + 2048*ms1**2*s**(-4) + 1024*ms1**2*s**(-3)*s4**(-1) - 1024*
     +    s**(-3)*t1*s4**(-1) + 512*s**(-3) - 512*s**(-2)*s4**(-1) )
      LQ_QBH = LQ_QBH + ANG4(12)*Nc**2*Cf*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-5)*t1*s4*(t1+u1)**(-1) - 1024*ms1**2*s**(-5)*t1 - 1024*
     +    ms1**2*s**(-4)*t1*s4**(-1) + 512*ms1**2*s**(-4)*s4*
     +    (t1+u1)**(-1) - 512*ms1**2*s**(-4) - 512*ms1**2*s**(-3)*
     +    s4**(-1) + 512*s**(-3)*t1*s4**(-1) - 256*s**(-3) + 256*
     +    s**(-2)*s4**(-1) )
      LQ_QBH = LQ_QBH + ANG4(13)*Nc**2*Cf*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-4) )
      LQ_QBH = LQ_QBH + ANG4(14)*Nc**2*Cf*Pi**4*alphas**3 *(2048*ms1**2
     +    *s**(-4)*u1 + 1024*ms1**2*s**(-3) )
      LQ_QBH = LQ_QBH + ANG4(15)*Nc**2*Cf*Pi**4*alphas**3 * (  - 1024*
     +    ms1**2*s**(-5)*s4*(t1+u1)**(-1) + 1024*ms1**2*s**(-5) )
      LQ_QBH = LQ_QBH + ANG4(16)*Nc*Cf**2*Pi**4*alphas**3 * (  - 4096*
     +    ms1**2*s**(-4)*s4*(t1+u1)**(-1) + 4096*ms1**2*s**(-4) )
      LQ_QBH = LQ_QBH + ANG4(16)*Nc**2*Cf*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-5)*t1*s4*(t1+u1)**(-1) - 1024*ms1**2*s**(-5)*t1 - 1024*
     +    ms1**2*s**(-4)*t1*s4**(-1) + 512*ms1**2*s**(-4)*s4*
     +    (t1+u1)**(-1) - 512*ms1**2*s**(-4) - 512*ms1**2*s**(-3)*
     +    s4**(-1) + 512*s**(-3)*t1*s4**(-1) - 256*s**(-3) + 256*
     +    s**(-2)*s4**(-1) )
      LQ_QBH = LQ_QBH + ANG4(36)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**4
     +    *s**(-3) )
      LQ_QBH = LQ_QBH + ANG4(37)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-3)*t1*s4**(-1) - 2048*ms1**2*s**(-3)*s4*(t1+u1)**(-1)
     +     + 2048*ms1**2*s**(-3) - 1024*ms1**2*s**(-2)*s4**(-1) + 2048*
     +    ms1**4*s**(-3)*s4**(-1) + 1024*s**(-3)*t1 - 1024*s**(-3)*u1
     +     - 512*s**(-2)*t1*s4**(-1) )
      LQ_QBH = LQ_QBH + ANG4(37)*Nc**2*Cf*Pi**4*alphas**3 *(512*ms1**2*
     +    s**(-4)*t1*s4*(t1+u1)**(-1) - 512*ms1**2*s**(-4)*t1 - 512*
     +    ms1**2*s**(-3)*t1*s4**(-1) + 512*ms1**2*s**(-3)*s4*
     +    (t1+u1)**(-1) - 768*ms1**2*s**(-3) + 512*ms1**2*s**(-2)*
     +    s4**(-1) - 1024*ms1**4*s**(-3)*s4**(-1) + 512*s**(-4)*t1**2*
     +    s4*(t1+u1)**(-1) - 512*s**(-4)*t1**2 - 768*s**(-3)*t1 + 512*
     +    s**(-3)*u1 + 256*s**(-2)*t1*s4**(-1) )
      LQ_QBH = LQ_QBH + ANG4(38)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-2) )
      LQ_QBH = LQ_QBH + ANG4(38)*Nc**2*Cf*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-4)*u1**2 + 1024*ms1**2*s**(-3)*u1 + 512*ms1**2*s**(-2)
     +     )
      LQ_QBH = LQ_QBH + ANG4(39)*Nc*Cf**2*Pi**4*alphas**3 *(4096*ms1**2
     +    *s**(-3)*t1*s4**(-1) - 2048*ms1**2*s**(-3)*s4*(t1+u1)**(-1)
     +     - 2048*ms1**2*s**(-3) + 2048*ms1**2*s**(-2)*s4**(-1) - 2048*
     +    s**(-2)*t1*s4**(-1) + 1024*s**(-2) - 1024*s**(-1)*s4**(-1) )
      LQ_QBH = LQ_QBH + ANG4(39)*Nc**2*Cf*Pi**4*alphas**3 *(512*ms1**2*
     +    s**(-4)*t1*s4*(t1+u1)**(-1) - 1536*ms1**2*s**(-4)*t1 + 1024*
     +    ms1**2*s**(-4)*t1**2*s4**(-1) + 1024*ms1**2*s**(-4)*u1 - 512*
     +    ms1**2*s**(-3)*t1*s4**(-1) + 512*ms1**2*s**(-3)*s4*
     +    (t1+u1)**(-1) + 1024*ms1**2*s**(-3) - 256*ms1**2*s**(-2)*
     +    s4**(-1) + 512*s**(-4)*t1**2*s4*(t1+u1)**(-1) - 512*s**(-4)*
     +    t1**2 - 512*s**(-3)*t1 + 512*s**(-3)*t1**2*s4**(-1) + 256*
     +    s**(-3)*u1 + 1280*s**(-2)*t1*s4**(-1) - 512*s**(-2) + 512*
     +    s**(-1)*s4**(-1) )
      LQ_QBH = LQ_QBH + ANG4(48)*Nc*Cf**2*Pi**4*alphas**3 * (  - 1024*
     +    ms1**2*s**(-2) - 512*s**(-3)*t1**2 - 512*s**(-3)*u1**2 - 512*
     +    s**(-2)*t1 - 512*s**(-2)*u1 )
      LQ_QBH = LQ_QBH + ANG4(48)*Nc**2*Cf*Pi**4*alphas**3 *(512*ms1**2*
     +    s**(-2) + 256*s**(-3)*t1**2 + 256*s**(-3)*u1**2 + 256*s**(-2)
     +    *t1 + 256*s**(-2)*u1 )
      LQ_QBH = LQ_QBH + ANG4(49)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-3)*t1*s4*(t1+u1)**(-1) - 2048*ms1**2*s**(-3)*t1 + 2048*
     +    s**(-4)*t1**3*s4*(t1+u1)**(-1) - 2048*s**(-4)*t1**3 + 1024*
     +    s**(-3)*t1**2*s4*(t1+u1)**(-1) - 2048*s**(-3)*t1**2 )
      LQ_QBH = LQ_QBH + ANG4(49)*Nc**2*Cf*Pi**4*alphas**3 * (  - 256*
     +    ms1**2*s**(-3)*t1*s4*(t1+u1)**(-1) + 512*ms1**2*s**(-3)*t1 -
     +    512*s**(-4)*t1**3*s4*(t1+u1)**(-1) + 512*s**(-4)*t1**3 - 256*
     +    s**(-3)*t1**2*s4*(t1+u1)**(-1) + 512*s**(-3)*t1**2 )
      LQ_QBH = LQ_QBH + ANG4(50)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-3)*t1*s4*(t1+u1)**(-1) - 1024*ms1**2*s**(-3)*t1 + 1024*
     +    ms1**2*s**(-3)*u1 - 1024*ms1**2*s**(-2) + 2048*s**(-4)*t1**3*
     +    s4*(t1+u1)**(-1) - 2048*s**(-4)*t1**3 + 2048*s**(-3)*t1*u1 -
     +    1024*s**(-3)*t1**2*s4*(t1+u1)**(-1) - 1024*s**(-3)*t1**2 -
     +    1024*s**(-3)*u1**2 + 1024*s**(-2)*t1 - 1024*s**(-2)*u1 )
      LQ_QBH = LQ_QBH + ANG4(50)*Nc**2*Cf*Pi**4*alphas**3 * (  - 512*
     +    ms1**2*s**(-3)*t1*s4*(t1+u1)**(-1) + 512*ms1**2*s**(-3)*t1 -
     +    512*ms1**2*s**(-3)*u1 + 512*ms1**2*s**(-2) - 1024*s**(-4)*
     +    t1**3*s4*(t1+u1)**(-1) + 1024*s**(-4)*t1**3 - 1024*s**(-3)*t1
     +    *u1 + 512*s**(-3)*t1**2*s4*(t1+u1)**(-1) + 512*s**(-3)*t1**2
     +     + 512*s**(-3)*u1**2 - 512*s**(-2)*t1 + 512*s**(-2)*u1 )
      LQ_QBH = LQ_QBH + ANG4(52)*Nc*Cf**2*Pi**4*alphas**3 *(512*ms1**2*
     +    s**(-1) )
      LQ_QBH = LQ_QBH + ANG4(54)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-3)*t1*s4*(t1+u1)**(-1) - 1024*ms1**2*s**(-3)*t1 - 1024*
     +    ms1**2*s**(-2)*t1*s4**(-1) + 512*ms1**2*s**(-2) - 1024*ms1**2
     +    *s**(-1)*s4**(-1) + 2048*s**(-4)*t1**3*s4*(t1+u1)**(-1) -
     +    2048*s**(-4)*t1**3 + 1024*s**(-3)*t1**2*s4*(t1+u1)**(-1) -
     +    512*s**(-3)*t1**2 - 2048*s**(-3)*t1**3*s4**(-1) + 512*s**(-3)
     +    *u1**2 + 2560*s**(-2)*t1 - 5120*s**(-2)*t1**2*s4**(-1) - 1024
     +    *s**(-2)*u1 - 4096*s**(-1)*t1*s4**(-1) + 1024*s**(-1) - 1024*
     +    s4**(-1) )
      LQ_QBH = LQ_QBH + ANG4(54)*Nc**2*Cf*Pi**4*alphas**3 * (  - 256*
     +    ms1**2*s**(-3)*t1*s4*(t1+u1)**(-1) + 256*ms1**2*s**(-3)*t1 +
     +    512*ms1**2*s**(-2)*t1*s4**(-1) - 256*ms1**2*s**(-2) + 512*
     +    ms1**2*s**(-1)*s4**(-1) - 512*s**(-4)*t1**3*s4*(t1+u1)**(-1)
     +     + 512*s**(-4)*t1**3 + 256*s**(-3)*t1*u1 - 256*s**(-3)*t1**2*
     +    s4*(t1+u1)**(-1) - 256*s**(-3)*t1**2 + 1024*s**(-3)*t1**3*
     +    s4**(-1) - 256*s**(-3)*u1**2 - 1280*s**(-2)*t1 + 2560*s**(-2)
     +    *t1**2*s4**(-1) + 512*s**(-2)*u1 + 2048*s**(-1)*t1*s4**(-1)
     +     - 512*s**(-1) + 512*s4**(-1) )
      LQ_QBH = LQ_QBH + ANG4(56)*Nc*Cf**2*Pi**4*alphas**3 *(512*ms1**2*
     +    s**(-1) )
      LQ_QBH = LQ_QBH + ANG4(58)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-3)*t1*s4*(t1+u1)**(-1) - 1024*ms1**2*s**(-3)*t1 - 1024*
     +    ms1**2*s**(-2)*t1*s4**(-1) + 512*ms1**2*s**(-2) + 2048*
     +    s**(-4)*t1**3*s4*(t1+u1)**(-1) - 2048*s**(-4)*t1**3 - 1024*
     +    s**(-3)*t1**2*s4*(t1+u1)**(-1) + 1536*s**(-3)*t1**2 - 2048*
     +    s**(-3)*t1**3*s4**(-1) + 512*s**(-3)*u1**2 + 1024*s**(-2)*t1
     +     - 1024*s**(-2)*t1**2*s4**(-1) + 512*s**(-2)*u1 )
      LQ_QBH = LQ_QBH + ANG4(58)*Nc**2*Cf*Pi**4*alphas**3 * (  - 512*
     +    ms1**2*s**(-3)*t1*s4*(t1+u1)**(-1) + 512*ms1**2*s**(-3)*t1 +
     +    256*ms1**2*s**(-2)*t1*s4**(-1) - 1024*s**(-4)*t1**3*s4*
     +    (t1+u1)**(-1) + 1024*s**(-4)*t1**3 - 256*s**(-3)*t1*u1 + 512*
     +    s**(-3)*t1**2*s4*(t1+u1)**(-1) - 256*s**(-3)*t1**2 + 512*
     +    s**(-3)*t1**3*s4**(-1) - 512*s**(-2)*t1 + 256*s**(-2)*t1**2*
     +    s4**(-1) )
      LQ_QBH = LQ_QBH + COLO1(9)*Nc*Cf**2*Pi**4*alphas**3 *(1024*ms1**2
     +    *s**(-4)*t1**(-1)*u1 + 1024*ms1**2*s**(-4)*t1*u1**(-1) + 4096
     +    *ms1**2*s**(-4)*t1*s4**(-1) - 4096*ms1**2*s**(-4)*t1**2*
     +    s4**(-2) - 2048*ms1**2*s**(-4) - 1024*ms1**2*s**(-3)*t1**(-2)
     +    *u1 + 1024*ms1**2*s**(-3)*t1**(-1) - 1024*ms1**2*s**(-3)*t1*
     +    u1**(-2) - 4096*ms1**2*s**(-3)*t1*s4**(-2) + 1024*ms1**2*
     +    s**(-3)*u1**(-1) - 2048*ms1**2*s**(-3)*s4**(-1) - 1024*ms1**2
     +    *s**(-2)*t1**(-2) - 1024*ms1**2*s**(-2)*u1**(-2) - 1024*
     +    ms1**4*s**(-3)*t1**(-2) + 2048*ms1**4*s**(-3)*t1**(-1)*
     +    s4**(-1) - 1024*ms1**4*s**(-3)*u1**(-2) + 2048*ms1**4*s**(-3)
     +    *u1**(-1)*s4**(-1) - 4096*ms1**4*s**(-3)*s4**(-2) + 1024*
     +    s**(-4)*t1**(-1)*u1**2 + 3072*s**(-4)*t1 + 1024*s**(-4)*t1**2
     +    *u1**(-1) - 4096*s**(-4)*t1**2*s4**(-1) - 1024*s**(-4)*u1 +
     +    1024*s**(-3)*t1**(-1)*u1 + 1024*s**(-3)*t1*u1**(-1) - 4096*
     +    s**(-3)*t1*s4**(-1) )

      LQ_QBH = fac * LQ_QBH

      end


        SUBROUTINE G_20(U0,V0,AGME,AG_20,NLEV)
        USE VAPHFB_PAR

        implicit real*8 (a-h,o-z)

        DIMENSION V0(NLEV,NLEV)
        DIMENSION U0(NLEV,NLEV)
        DIMENSION AGME(NLEV,NLEV)
        DIMENSION AG_20(NLEV,NLEV)
        DIMENSION AG_20AUX(NLEV,NLEV)
        DIMENSION AUX1(NLEV,NLEV),AUX2(NLEV,NLEV)
        DIMENSION AUX3(NLEV,NLEV),AUX4(NLEV,NLEV)

        call DGEMM ('t','n',NLEV,NLEV,NLEV,one,U0,NLEV,AGME,NLEV,zero,AUX1,NLEV)
        call DGEMM ('n','n',NLEV,NLEV,NLEV,one,AUX1,NLEV,U0,NLEV,zero,AUX3,NLEV)

        call DGEMM ('t','n',NLEV,NLEV,NLEV,one,V0,NLEV,AGME,NLEV,zero,AUX2,NLEV)
        call DGEMM ('n','n',NLEV,NLEV,NLEV,one,AUX2,NLEV,V0,NLEV,zero,AUX4,NLEV)

        do ii=1,NLEV
         do jj=1,NLEV
          AG_20AUX(jj,ii)=AUX3(jj,ii)-AUX4(jj,ii)
         end do
        end do

        do ii=1,NLEV
         do jj=1,NLEV
          AG_20(jj,ii)=0.5*(AG_20AUX(jj,ii)  -AG_20AUX(ii,jj))
         end do
        end do

        END SUBROUTINE
! .......................................
       SUBROUTINE F_20(U0,V0,AFME,AF_20,NLEV)
! .......................................
        USE VAPHFB_PAR
        implicit real*8 (a-h,o-z)

        DIMENSION V0(NLEV,NLEV)
        DIMENSION U0(NLEV,NLEV)
        DIMENSION AFME(NLEV,NLEV)
        DIMENSION AF_20(NLEV,NLEV)
        DIMENSION AF_20AUX(NLEV,NLEV)
        DIMENSION AUX1(NLEV,NLEV),AUX2(NLEV,NLEV)
        DIMENSION AUX3(NLEV,NLEV),AUX4(NLEV,NLEV)

        call DGEMM ('t','n',NLEV,NLEV,NLEV,one,          &
     &  U0,NLEV,AFME,NLEV,zero,AUX1,NLEV)
        call DGEMM ('n','n',NLEV,NLEV,NLEV,one,          &
     &  AUX1,NLEV,V0,NLEV,zero,AUX3,NLEV)

        call DGEMM ('t','t',NLEV,NLEV,NLEV,one,          &
     &  V0,NLEV,AFME,NLEV,zero,AUX2,NLEV)
        call DGEMM ('n','n',NLEV,NLEV,NLEV,one,          &
     &  AUX2,NLEV,U0,NLEV,zero,AUX4,NLEV)

        do ii=1,NLEV
	 do jj=1,NLEV
	  AF_20AUX(jj,ii)=AUX3(jj,ii)-AUX4(jj,ii)
	 end do
	end do

        do ii=1,NLEV
	 do jj=1,NLEV
	  AF_20(jj,ii)=0.5*(AF_20AUX(jj,ii) -AF_20AUX(ii,jj))
	 end do
	end do

        END SUBROUTINE


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This software is being released under a FreeBSD license
cc (see license.txt in this directory).
cc
c tweaked Alex Barnett to call FINUFFT 2/17/17
c dyn malloc; type 2 uses same input data fk0, other bugs 3/8/17
c     Single-prec version 9/24/18
c
c Compile with (multithreaded version):
c     gfortran nufft2dmany_demof.f dirft2df.f -o nufft2dmany_demof
c      ../lib/libfinufft.a -lstdc++ -lfftw3 -lfftw3_omp -lm -fopenmp
c
      program nufft2dmany_demo

      implicit none
c
      integer i,ier,iflag,j,k1,k2,mx,ms,mt,n1,n2,nj,nk,ndata,d
      real*4, allocatable :: xj(:),yj(:),sk(:),tk(:)
      real*4 err,pi,eps,salg,ealg,maxerr
      parameter (pi=3.141592653589793238462643383279502884197d0)
      complex*8, allocatable :: cj(:),cj0(:),cj1(:),fk0(:),fk1(:)
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
c
      ndata = 2
      n1 = 36
      n2 = 40
      ms = 32
      mt = 30
      nj = n1*n2
      nk = ms*mt

      maxerr = 0.0
c     first alloc everything
      allocate(xj(nj))
      allocate(yj(nj))
      allocate(fk0(nk*ndata))
      allocate(fk1(nk*ndata))
      allocate(cj (nj*ndata))
      allocate(cj0(nj*ndata))
      allocate(cj1(nj*ndata))
      do k1 = -n1/2, (n1-1)/2
         do k2 = -n2/2, (n2-1)/2
            j = (k2+n2/2+1) + (k1+n1/2)*n2
            xj(j) = pi*cos(-pi*k1/n1)
            yj(j) = pi*cos(-pi*k2/n2)
            do d = 0, ndata-1
                cj(j+d*nj) = cmplx(sin(pi*j/n1+d),cos(pi*j/n2+d))
            enddo
         enddo
      enddo
c
c     -----------------------
c     start tests
c     -----------------------
c
      iflag = 1
      print*,'Starting 2Dmany testing: ', ' nj =',nj, ' ms,mt =',ms,mt
      do i = 1,3
         if (i.eq.1) eps=1d-4
         if (i.eq.2) eps=1d-8
         if (i.eq.3) eps=1d-12
	 print*,' '
	 print*,' Requested precision eps =',eps
	 print*,' '
c
c     -----------------------
c     call 2D Type 1 method
c     -----------------------
c
         call finufft2d1many_f(ndata,nj,xj,yj,cj,iflag,
     &                         eps,ms,mt,fk1,ier)
         do d = 1, ndata
            call dirft2d1f(nj,xj,yj,cj(1+(d-1)*nj:d*nj),iflag,ms,mt,
     &                    fk0(1+(d-1)*nk:d*nk))
            call errcomp(fk0(1+(d-1)*nk:d*nk),fk1(1+(d-1)*nk:d*nk),
     &                   nk,err)
            maxerr = max(maxerr,err)
         enddo
         print *, ' max type 1 err = ',err
c
c     -----------------------
c      call 2D Type 2 method
c     -----------------------
         call finufft2d2many_f(ndata,nj,xj,yj,cj1,iflag,
     &                         eps,ms,mt,fk0,ier)
         do d = 1, ndata
            call dirft2d2f(nj,xj,yj,cj0(1+(d-1)*nj:d*nj),iflag,ms,mt,
     &                    fk0(1+(d-1)*nk:d*nk))
            call errcomp(cj0(1+(d-1)*nj:d*nj),cj1(1+(d-1)*nj:d*nj),
     &                   nj,err)
            maxerr = max(maxerr,err)
         enddo

         print *, ' max type 2 err = ',err

      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer k,n
      complex*8 fk0(n), fk1(n)
      real *4 salg,ealg,err
c
      ealg = 0d0
      salg = 0d0
      do k = 1, n
         ealg = ealg + cabs(fk1(k)-fk0(k))**2
         salg = salg + cabs(fk0(k))**2
      enddo
      err =sqrt(ealg/salg)
      return
      end


module gamblers

    implicit none
    integer :: kwalks, max_steps
    save

contains

    subroutine walk(n1in, n2in, p, verbose, nsteps, winner)

    implicit none
    integer, intent(in) :: n1in,n2in
    real(kind=8), intent(in) :: p
    logical, intent(in) :: verbose
    integer, intent(out) :: nsteps, winner

    ! local variables
    real(kind=8), allocatable :: r(:)
    integer :: nstep, n1, n2

    allocate(r(max_steps))
    call random_number(r)

    ! initialize n1 and n2 with input values
    ! need to change n1 and n2 internally during this walk but do not
    ! want to affect n1 and n2 in main program.
    n1 = n1in
    n2 = n2in

    open(unit=22, file='walk.txt', status='unknown')
    write(22,222) n1,n2
222 format(2i6)

    do nstep=1,max_steps
        if (r(nstep) <= p) then
            n1 = n1 + 1
            n2 = n2 - 1
        else
            n1 = n1 - 1
            n2 = n2 + 1
        endif
        write(22,222) n1,n2
        if (verbose) then
            print 601, nstep,r(nstep),n1,n2
601         format("In step ",i6, " r = ",f7.4, " and n1 = ",i6, " n2 = ",i6)
            endif
        if (min(n1,n2) == 0) then
            exit
            endif

        enddo

    nsteps = nstep  ! to return number of steps taken

    if (verbose) then
        print 602, nstep,n1,n2
602     format("Stopped after ",i6," steps with n1 = ",i6,", n2 = ",i6)
        endif

    if (n1 == 0) then
        winner = 2
    else if (n2 == 0) then
        winner = 1
    else
        winner = 0
    endif

    end subroutine walk

end module gamblers


program test_trig
  implicit none

  real :: SOLSIN, EFFDEC, SLB, HRANGL

  EFFDEC = 4.635570647466656e-310
  SLB = 0.685041785
  HRANGL = 1.28342795
  SOLSIN = 0.0

  SOLSIN = SIN(EFFDEC)*SIN(SLB)+COS(EFFDEC)*COS(SLB)*COS(HRANGL)

  write(*,*) SOLSIN

end program test_trig


      subroutine cilind(r,hmn,hmx,nh,nfi,dx,dy,dz,nlines,nbeg)
      dimension dx(2,nlines),dy(2,nlines),dz(2,nlines)
C *********************************************************
C  "nh+1" circles per "nfi"lines and "nfi" vertical lines.
C   the total number of lines is "(nh+2)*nfi".
C   ("nfi" - the number of lines per circle;"nh" - the number
C    of vertical line segments.)
C *********************************************************
      k=nbeg
      dh=(hmx-hmn)/nh
      dfi=2.*3.14159265/nfi
C.....gorizontal      circles.
      h=hmn
      nh1=nh+1
      do 1 j=1,nh1
      fi=0.
      do 2 i=1,nfi
      dy(1,k)=h
      dz(1,k)=r*cos(fi)
      dx(1,k)=r*sin(fi)
      fi=fi+dfi
      dy(2,k)=h
      dz(2,k)=r*cos(fi)
      dx(2,k)=r*sin(fi)
      k=k+1
2      continue
      h=h+dh
1      continue
C......vertical      lines.
      fi=0.
      do 3 i=1,nfi
      dy(1,k)=hmx
      dy(2,k)=hmn
      dz(1,k)=r*cos(fi)
      dz(2,k)=dz(1,k)
      dx(1,k)=r*sin(fi)
      dx(2,k)=dx(1,k)
      fi=fi+dfi
      k=k+1
3      continue
      return
      end


module module_solver
use module_triSolve
implicit none

contains
!====================================================================
!>Calculating velocity profile
!====================================================================
SUBROUTINE SOLVE_CP(U,ERROR,U1,VW,H,N,LD,MD,UD,D,YPAD,YHAD,ALPHA,DPDX,KIN_VIS,CONV_CRIT,MAX_ITER,OUTPUTFILE,NUM_CASE)
!SUBROUTINE SOLVE_CP(U,ERROR,U1,VW,H,N,LD,MD,UD,D,YPAD,YHAD,ALPHA,DPDX,KIN_VIS,CONV_CRIT,OUTPUTFILE,NUM_CASE)
	IMPLICIT NONE
	INTEGER :: I,J,K,ITERATIONS
	INTEGER,INTENT(IN):: N,NUM_CASE,MAX_ITER
	REAL(8),INTENT(IN):: YPAD(N),H,VW,YHAD(N),ALPHA,DPDX,CONV_CRIT
	REAL(8),INTENT(IN):: KIN_VIS
	REAL(8),INTENT(INOUT):: U(N)
	REAL(8)			  ::ERROR,U1(N),LD(1:N),MD(1:N),UD(1:N),D(1:N),LEN_ZERO(N),UTAU1,UTAU2,A1,A2,MIX_LEN(N)
	REAL(8)			  ::TKIN_VIS(1:N),TKIN_VISN(1:N),TKIN_VISS(1:N),A(1:N),B(1:N),U_AVG,YF(N-1)
	CHARACTER(len=15),INTENT(IN):: OUTPUTFILE
	open(33,file=OUTPUTFILE)

	ERROR=1.0D0
	U1=0.0d0
	YF(1)=0.0D0
	DO I=2,N-1
		YF(I)=YPAD(I)+ (YPAD(I)-YF(I-1)) !YPAD at the faces of the control volume
	END DO
	DO I= 2,N-1
		LEN_ZERO(I)=(0.21D0-(0.43D0*((1.0D0-(2.0D0*(YF(I)/H)))**4)) + (0.22D0*((1.0D0-(2.0D0*(YF(I))/H))**6)))*(H/2.0D0)
	END DO

	ITERATIONS=0 ! iterations for convergence
	Do
		IF(ERROR>CONV_CRIT .AND. ITERATIONS<MAX_ITER )THEN !convergence criteria
		!IF(ERROR>CONV_CRIT)THEN !convergence criteria
		!print *, ITERATIONS
		U1=0.0d0										!Iniatialise the array
		     IF (NUM_CASE<16) THEN
        		        UTAU1=DSQRT((dabs(U(2))/(YPAD(2)))*KIN_VIS)		!case 1 to 15
                     ELSE
				UTAU1=DSQRT((dabs(U(2)-U(1))/(YHAD(2)))*KIN_VIS)        !case 16 to 18, lower wall is moving
                     END IF
		UTAU2=DSQRT((dabs(U(N-1)-U(N))/(YHAD(N)))*KIN_VIS)

		A1=26.0d0*KIN_VIS/UTAU1 			!CORROESPONDS TO LOWER WALL
		A2=26.0d0*KIN_VIS/UTAU2				!CORROSPONDS TO UPPER WALL

		Do I=2,(N+1)/2
			MIX_LEN(I)=LEN_ZERO(I)*(1.0d0-DEXP(-YF(I)/A1))
			MIX_LEN(N-(I-1))=LEN_ZERO(N-(I-1))*(1.0d0-DEXP(-YF(I)/A2))
		END DO
		DO I=2,N-1
			TKIN_VISN(I)=(MIX_LEN(I)**2)*Dabs((U(I+1)-U(I))/(YHAD(I+1)))    !North faced Turbulent viscosity
			!print*,"TKIN_VISN=",TKIN_VISN(I)
			TKIN_VISS(I)=(MIX_LEN(I)**2)*abs((U(I)-U(I-1))/(YHAD(I)))	 !South faced Turbulent viscosity
			!print*,"TKIN_VISS=",TKIN_VISS(I)
			TKIN_VIS(I)=(TKIN_VISN(I)+TKIN_VISS(I))/2.0   !AVERAGE of North and South
		END DO
		DO I=2,N-1
			!A(I)= KIN_VIS + TKIN_VISN(I)
	                !B(I)= KIN_VIS + TKIN_VISN(I-1)
	                A(I)= KIN_VIS + TKIN_VIS(I)
	                B(I)= KIN_VIS + TKIN_VIS(I-1)

		END DO
		!Initialise thomas matrix
		LD=0.0d0;MD=0.0d0;UD=0.0d0

		DO I=2,N-1
			LD(I)=B(I)/YHAD(I)							!LD= lower diagonal of TDMA
			MD(I)=-((A(I)/YHAD(I+1))+(B(I)/YHAD(I)))	!MD= middle diagonal of TDMA
			UD(I)=A(I)/(YHAD(I+1))						!UP= Uppar diagonal of TDMA
		END DO
		MD(1)=1.0D0;MD(N)=1.0D0							!Boundary Conditions
		UD(1)=1.0D0;LD(N)=1.0D0;LD(1)=0.0D0;UD(N)=0.0D0 !!Boundary Condition
		IF (NUM_CASE<16) THEN
        		D(1)=0.0d0			!for case 1-15
		ELSE
		        D(1)=2.0D0*VW		!for 16-18 case
		END IF
		DO I=2,N-1
			D(I)=DPDX*((YPAD(I+1)-YPAD(I-1))/2.0d0)
		END DO
		IF (NUM_CASE<16) THEN
        		D(N)=2.0D0*VW		!for case 1-15
		ELSE
		        D(N)=0.0d0	        !for 16-18 case
                END IF

                call  triSolve(LD,MD,UD,D,U1,N)
                ERROR=0.0d0
		DO I=2,N-1
  			ERROR=ERROR+(U(I)-U1(I))**2
  		END DO
		ERROR=DSQRT(ERROR/DFLOAT(N-2))
		!print*,"Error=",ERROR
		U=U1
		ITERATIONS= ITERATIONS+1

		ELSE
      		       		EXIT
  		ENDIF

  	END DO
  	IF (ITERATIONS==MAX_ITER) THEN
          	PRINT *, "Convergence was not reached !"
       		PRINT *, "Calculations terminated after", MAX_ITER,"iterations."
  	ELSE
        	print*,"Total Number Iterations=",ITERATIONS
	END IF
	IF (NUM_CASE<16) THEN
        	UTAU1=SQRT((abs(U(2))/(YPAD(2)))*KIN_VIS)			!Case 1 to 15
	ELSE
	        UTAU1=DSQRT((dabs(U(2)-U(1))/(YHAD(2)))*KIN_VIS)                !Case 16 to 18
	END IF
	PRINT*,"UTAU1=",UTAU1
	UTAU2=SQRT((abs(U(N-1)-U(N))/(YHAD(N)))*KIN_VIS)
	PRINT*,"UTAU2=",UTAU2
	U_AVG=SUM(U(2:N-1))/DFLOAT(N-2)
	print*,"U Average=",ABS(U_AVG),"U Max=",MAXVAL(ABS(U))
	WRITE(33,*) "######################################################################"
	WRITE(33,*) "#Data for Case=",NUM_CASE
	WRITE(33,*) "#   ALPHA,             N,       ITERATIONS, VW,          UMAX ,       UAVG,           UTAU1,          UTAU2    "
	WRITE(33,"(A3,ES16.8,I8,I10,5ES16.8)") "#",ALPHA,N,ITERATIONS,VW,MAXVAL(ABS(U)),ABS(U_AVG),UTAU1,UTAU2
	WRITE(33,*) "######################################################################"
	PRINT *, "this is the val",MAXVAL(ABS(U))
	IF (NUM_CASE<16) THEN
        	WRITE(33,*) "# YPAD(I)/H,     U(I)/VW	"
	        WRITE(33,"(2ES16.8)")0.0D0,0.0D0 			!Case 1 to 15
	ELSE
	        WRITE(33,*) "# YPAD(I)/H,     U(I)/U_AVG	"
	        WRITE(33,"(2ES16.8)")0.0d0,VW/UTAU2 		        !Case 16 to 18
	END IF
	DO I=2,N-1
		IF (NUM_CASE<15) THEN
		        WRITE(33,"(2ES16.8)")YPAD(I)/H,U(I)/VW			!Case 1 to 15
		ELSE IF(NUM_CASE==15) THEN
		        WRITE(33,"(2ES16.8)")YPAD(I)/H,U(I)/(MAXVAL(ABS(U)))    !Case 15
		        !WRITE(33,"(2ES16.8)")YPAD(I)/H,U(I)/(1000.0)
		ELSE
		        WRITE(33,"(2ES16.8)")YPAD(I)/H,U(I)/U_AVG 		!Case 16 to 18
		END IF

	END DO

	IF (NUM_CASE<15) THEN
	        WRITE(33,"(2ES16.8)")1.0D0,1.0d0        !For Case 1 to 15
	ELSE
	        WRITE(33,"(2ES16.8)")1.0D0,0.0D0 	!For Case 16 to 18
	END IF
	CLOSE(33)
END SUBROUTINE

end module module_solver


module overlap_backend

    implicit none

    double precision, parameter :: zero = 0.0d0
    double precision, parameter :: half = 0.5d0
    double precision, parameter :: one = 1.0d0
    double precision, parameter :: two = 2.0d0

    ! Use this constant instead of global, because of compatibility with MNDO etc
    double precision, parameter :: AU_TO_EV = 27.21d0

    ! contains the factorials of i-1
    double precision, parameter :: fc(1:25) =&
        (/ 1.0d0,1.0d0, 2.0d0, 6.0d0, 24.0d0, &
        120.0d0, 720.0d0, 5040.0d0, 40320.0d0, 362880.0d0, &
        3628800.0d0, 39916800.0d0, 4.790016d+08, 6.2270208d+09, 8.71782912d+10, &
        1.307674368d+12, 2.092278989d+13, 3.55687428096d+14, 6.402373705728d+15, 1.21645100408832d+17, &
        2.43290200817664d+18, 5.109094217170944d+19, 1.12400072777760768d+21, 2.585201673888497664d+22, &
        6.2044840173323943936d+23 /)

    double precision, parameter :: logfc(1:25) = (/ 0.0d0, 0.0d0, 0.6931471805599d0,       &
        &  1.7917594692281d0,  3.1780538303479d0,  4.7874917427820d0, &
        &  6.5792512120101d0,  8.5251613610654d0, 10.6046029027453d0, &
        & 12.8018274800815d0, 15.1044125730755d0, 17.5023078458739d0, &
        & 19.9872144956619d0, 22.5521638531234d0, 25.1912211827387d0, &
        & 27.8992713838409d0, 30.6718601061763d0, 33.5050734501369d0, &
        & 36.3954452080331d0, 39.3398841871995d0, 42.3356164607535d0, &
        & 45.3801388984769d0, 48.4711813518352d0, 51.6066755677644d0, &
        & 54.7847293981123d0 /)

    !     define c coefficients for associate legendre polynomials.
    double precision, parameter::cc(1:21,1:3) = reshape ( (/   &
        8.0d0,   8.0d0,   4.0d0,  -4.0d0,  4.0d0,   &
        4.0d0, -12.0d0,  -6.0d0,  20.0d0,  5.0d0,   &
        3.0d0, -30.0d0, -10.0d0,  35.0d0,  7.0d0,   &
        15.0d0,   7.5d0, -70.0d0, -17.5d0, 63.0d0,  &
        10.5d0,                                     &
        0.0d0,   0.0d0,   0.0d0,  12.0d0,  0.0d0,   &
        0.0d0,  20.0d0,  30.0d0,   0.0d0,  0.0d0,   &
        -30.0d0,  70.0d0,  70.0d0,   0.0d0,  0.0d0, &
        -70.0d0, -105.d0, 210.0d0, 157.5d0,  0.0d0, &
        0.0d0,                                      &
        0.0d0,   0.0d0,   0.0d0,   0.0d0,  0.0d0,   &
        0.0d0,   0.0d0,   0.0d0,   0.0d0,  0.0d0,   &
        35.0d0,   0.0d0,   0.0d0,   0.0d0,  0.0d0,  &
        63.0d0, 157.5d0,   0.0d0,   0.0d0,  0.0d0,  &
        0.0d0/), (/ 21, 3 /) )

    double precision, save::A(15),B(15)

    ! Constants
    !     THE ARRAY B0(I) CONTAINS THE B INTEGRALS FOR ZERO ARGUMENT.
    double precision, parameter :: B0(1:15)= &
        &      (/ 2.0D0,0.0D0,0.666666666666667D0,0.0D0,0.4D0,0.0D0,       &
        &         0.285714285714286D0,0.0D0,0.222222222222222D0,0.0D0,     &
        &         0.181818181818182D0,0.0D0,0.153846153846154D0,0.0D0,     &
        &         0.133333333333333D0 /)

    !     define addresses for index pairs (00,10,20,30,40,50,60,70).
    integer,parameter:: iad(1:8)= (/ 1,2,4,7,11,16,22,29 /)

    !     define binomial coefficients (00,10,11,20,...,77).
    integer,parameter:: ibinom(1:36)= (/&
        &            1,1,1,1,2,1,1,3,3,1,1,4,6,4,1,1,5,10,10,5,1,          &
        &            1,6,15,20,15,6,1,1,7,21,35,35,21,7,1 /)
contains

function binomialcoefficient(m, n) result (biocoeff)

    integer, intent(in)::m,n
    double precision::biocoeff

    integer, parameter::size=30
    integer, save::bc(size,size)=0
    logical, save::initialized=.false.;

    integer::i,j,k

    if (.not.initialized) then
        do i=1,size
        bc(i,1)=one
        bc(i,2:size)=zero
        end do
        do i=2, size
        do j=2, i
        bc(i,j)=bc(i-1,j-1)+bc(i-1,j)
        end do
        end do

        initialized=.true.
    end if

    biocoeff=one*bc(m,n)

end function binomialcoefficient

function getslateroverlap(na, la, nb, lb, mm, zeta_a, zeta_b, rab) result (overlap)

    implicit none
    integer, intent(in)::na, la, nb, lb, mm
    double precision, intent(in)::zeta_a,zeta_b, rab
    double precision::overlap

    ! local variables
    integer, save::ntotal=-1
    double precision, save:: zeta_a_old=-1.0d99, zeta_b_old=-1.0d99
    double precision, save:: rab_old=-1.0d99
    double precision, parameter:: tolerance=1.d0-16

    logical::resetup

    if ((la.ge.na) .or. (lb.ge.nb)) then
        overlap=0.d0
        return
    end if
    resetup=.true.
    if (ntotal.eq. (na+nb)) then
        if (abs(rab_old/rab-1.d0)< tolerance) then
            if (abs(zeta_a_old/zeta_a-1.d0) < tolerance) then
                if (abs(zeta_b_old/zeta_b-1.d0) < tolerance) then
                    resetup=.false.
                end if
            end if
        end if
    end if

    if (resetup) then
        ntotal=(na+nb)
        rab_old=rab
        zeta_a_old=zeta_a
        zeta_b_old=zeta_b
        call setupslaterauxiliary(ntotal, zeta_a, zeta_b, rab)
    end if

    overlap=calculateoverlap (na,la,mm,nb,lb,zeta_a*rab,zeta_b*rab)

end function getslateroverlap

subroutine setupslaterauxiliary(n,sa,sb,rab)
    !     *
    !     calculation of auxiliary integrals for sto overlaps.
    !     *

    implicit double precision (a-h,o-z)
    implicit integer (i-n)

    !explicit type to satisfy pgi v8 compiler
    double precision betpow(17)

    ! *** initialization.
    alpha  = 0.5d0*rab*(sa+sb)
    beta   = 0.5d0*rab*(sa-sb)
    ! *** auxiliary a integrals for calculation of overlaps.
    c      = exp(-alpha)
    ralpha = 1.0d0/alpha
    a(1)   = c*ralpha
    do i=1,n
        a(i+1) = (a(i)*i+c)*ralpha
    end do
    ! *** auxiliary b integrals for calculation of overlaps.
    !     the code is valid only for n.le.14, i.e. for overlaps
    !     involving orbitals with main quantum numbers up to 7.
    !     branching depending on absolute value of the argument.
    absx   = abs(beta)
    !     zero argument.
    if(absx.lt.1.0d-06) then
        do i=1,n+1
            b(i) = b0(i)
        enddo
        return
    endif
    !     large argument.
    if((absx.gt.0.5d0 .and. n.le.5) .or.                              &
        &   (absx.gt.1.0d0 .and. n.le.7) .or.                              &
        &   (absx.gt.2.0d0 .and. n.le.10).or.                              &
        &    absx.gt.3.0d0) then
        expx   = exp(beta)
        expmx  = 1.0d0/expx
        rx     = 1.0d0/beta
        b(1)   = (expx-expmx)*rx
        do i=1,n
            expx   = -expx
            b(i+1)= (i*b(i)+expx-expmx)*rx
        enddo
        return
    endif
    !     small argument.
    if(absx.le.0.5d0) then
        last = 6
    else if(absx.le.1.0d0) then
        last = 7
    else if(absx.le.2.0d0) then
        last = 12
    else
        last = 15
    endif
    betpow(1) = 1.0d0
    do m=1,last
        betpow(m+1) = -beta*betpow(m)
    enddo
    do i=1,n+1
        y      = 0.0d0
        ma     = 1-mod(i,2)
        do m=ma,last,2
            y      = y+betpow(m+1)/(fc(m+1)*(m+i))
        enddo
        b(i)   = y*2.0d0
    enddo

    return
end subroutine setupslaterauxiliary

function calculateoverlap (na,la,mm,nb,lb,alpha,beta)
    !     *
    !     overlap integrals between slater type orbitals.
    !     *
    !     quantum numbers (na,la,mm) and (nb,lb,mm).
    !     na and nb must be positive and less than or equal to 7.
    !     la, lb and abs(mm) must be less than or equal to 5.
    !     further restrictions are la.le.na, lb.le.nb,
    !     mm.le.la, and mm.le.lb.
    !     *

    implicit double precision (a-h,o-z)
    implicit integer (i-n)

    ! *** initialization.
    m      = abs(mm)
    nab    = na+nb+1
    x      = 0.0d0
    ! *** find a and b integrals.
    !     p      = (alpha + beta)*0.5
    !     pt     = (alpha - beta)*0.5
    !     call aintgs(a,p,na+nb)
    !     call bintgs(b,pt,na+nb)
    ! *** section used for overlap integrals involving s functions.
    if((la.gt.0).or.(lb.gt.0)) go to 20
    iada   = iad(na+1)
    iadb   = iad(nb+1)
    do 10 i=0,na
    iba    = ibinom(iada+i)
    do 10 j=0,nb
    ibb    = iba*ibinom(iadb+j)
    if(mod(j,2).eq.1) ibb=-ibb
    ij     = i+j
    x      = x+ibb*a(nab-ij)*b(ij+1)
    10 continue
    ss     = x  * 0.5d0
    ss     = ss * sqrt( alpha**(2*na+1)*beta**(2*nb+1)/               &
        &                    (fc(2*na+1)*fc(2*nb+1)) )
    calculateoverlap = ss
    return
    ! *** section used for overlap integrals involving p functions.
    ! *** special case m=0, s-p(sigma), p(sigma)-s, p(sigma)-p(sigma).
    20 if(la.gt.1 .or. lb.gt.1) go to 320
    if(m.gt.0) go to 220
    iu     = mod(la,2)
    iv     = mod(lb,2)
    namu   = na-iu
    nbmv   = nb-iv
    iadna  = iad(namu+1)
    iadnb  = iad(nbmv+1)
    do 130 kc=0,iu
    ic     = nab-iu-iv+kc
    jc     = 1+kc
    do 130 kd=0,iv
    id     = ic+kd
    jd     = jc+kd
    do 130 ke=0,namu
    ibe    = ibinom(iadna+ke)
    ie     = id-ke
    je     = jd+ke
    do 130 kf=0,nbmv
    ibf    = ibe*ibinom(iadnb+kf)
    if(mod(kd+kf,2).eq.1) ibf=-ibf
    x      = x+ibf*a(ie-kf)*b(je+kf)
    130 continue
    ss     = x  * sqrt( (2*la+1)*(2*lb+1)*0.25d0 )
    !     compute overlap integral from reduced overlap integral.
    ss     = ss * sqrt( alpha**(2*na+1)*beta**(2*nb+1)/               &
        &                    (fc(2*na+1)*fc(2*nb+1)) )
    if(mod(lb,2).eq.1) ss=-ss
    calculateoverlap = ss
    return
    ! *** section used for overlap integrals involving p functions.
    ! *** special case la=lb=m=1, p(pi)-p(pi).
    220 iadna  = iad(na)
    iadnb  = iad(nb)
    do 230 ke=0,na-1
    ibe    = ibinom(iadna+ke)
    ie     = nab-ke
    je     = ke+1
    do 230 kf=0,nb-1
    ibf    = ibe*ibinom(iadnb+kf)
    if(mod(kf,2).eq.1) ibf=-ibf
    i      = ie-kf
    j      = je+kf
    x      = x+ibf*(a(i)*b(j)-a(i)*b(j+2)-a(i-2)*b(j)+a(i-2)*b(j+2))
    230 continue
    ss     = x  * 0.75d0
    !     compute overlap integral from reduced overlap integral.
    ss     = ss * sqrt( alpha**(2*na+1)*beta**(2*nb+1)/               &
        &                    (fc(2*na+1)*fc(2*nb+1)) )
    if(mod(lb+mm,2).eq.1) ss=-ss
    calculateoverlap = ss
    return
    ! *** section used for overlap integrals involving non-s functions.
    ! *** general case la.gt.1 or lb.gt.1, m.ge.0.
    320 lam    = la-m
    lbm    = lb-m
    iada   = iad(la+1)+m
    iadb   = iad(lb+1)+m
    iadm   = iad(m+1)
    iu1    = mod(lam,2)
    iv1    = mod(lbm,2)
    iuc    = 0
    do 340 iu=iu1,lam,2
    iuc    = iuc+1
    cu     = cc(iada,iuc)
    namu   = na-m-iu
    iadna  = iad(namu+1)
    iadu   = iad(iu+1)
    ivc    = 0
    do 340 iv=iv1,lbm,2
    ivc    = ivc+1
    nbmv   = nb-m-iv
    iadnb  = iad(nbmv+1)
    iadv   = iad(iv+1)
    sum    = 0.0d0
    do 330 kc=0,iu
    ibc    = ibinom(iadu+kc)
    ic     = nab-iu-iv+kc
    jc     = 1+kc
    do 330 kd=0,iv
    ibd    = ibc*ibinom(iadv+kd)
    id     = ic+kd
    jd     = jc+kd
    do 330 ke=0,namu
    ibe    = ibd*ibinom(iadna+ke)
    ie     = id-ke
    je     = jd+ke
    do 330 kf=0,nbmv
    ibf    = ibe*ibinom(iadnb+kf)
    iff    = ie-kf
    jff    = je+kf
    do 330 ka=0,m
    iba    = ibf*ibinom(iadm+ka)
    i      = iff-2*ka
    do 330 kb=0,m
    ibb    = iba*ibinom(iadm+kb)
    if(mod(ka+kb+kd+kf,2).eq.1) ibb=-ibb
    j      = jff+2*kb
    sum    = sum+ibb*a(i)*b(j)
    330 continue
    x      = x+sum*cu*cc(iadb,ivc)
    340 continue
    ss     = x*(fc(m+2)/8.0d0)**2* sqrt( (2*la+1)*fc(la-m+1)*         &
        &         (2*lb+1)*fc(lb-m+1)/(4.0d0*fc(la+m+1)*fc(lb+m+1)))
    !     compute overlap integral from reduced overlap integral.
    ss     = ss * sqrt( alpha**(2*na+1)*beta**(2*nb+1)/               &
        &                    (fc(2*na+1)*fc(2*nb+1)) )

    if(mod(lb+mm,2).eq.1) ss=-ss
    calculateoverlap = ss
    return
end function calculateoverlap

! Calculate the radial part of one-center two-electron integrals (slater-condon parameter).
function getslatercondonparameter(k,na,ea,nb,eb,nc,ec,nd,ed) result(slatercondon)

    ! Type of integral, can be equal to 0,1,2,3,4 in spd-basis
    integer, intent(in) :: k

    ! Principle quantum number of ao, electron 1
    integer, intent(in) :: na
    integer, intent(in) :: nb

    ! Principle quantum number of ao, electron 2
    integer, intent(in) :: nc
    integer, intent(in) :: nd

    ! Exponents of ao, electron 1
    double precision, intent(in) :: ea
    double precision, intent(in) :: eb

    ! Exponents of ao, electron 2
    double precision, intent(in) :: ec
    double precision, intent(in) :: ed

    ! The resulting Slater-Condon parameter
    double precision :: slatercondon

    ! Local variables
    integer :: nab, ncd, n, i, m, m1, m2
    double precision :: eab, ecd, e, c, s0, s1, s2, s3
    double precision :: aea, aeb, aec, aed, ae, a2, acd, aab

    aea    = log(ea)
    aeb    = log(eb)
    aec    = log(ec)
    aed    = log(ed)
    nab    = na+nb
    ncd    = nc+nd
    ecd    = ec+ed
    eab    = ea+eb
    e      = ecd+eab
    n      = nab+ncd
    ae     = log(e)
    a2     = log(two)
    acd    = log(ecd)
    aab    = log(eab)
    c      = exp(logfc(n)+na*aea+nb*aeb+nc*aec+nd*aed &
        +half*(aea+aeb+aec+aed)+a2*(n+2) &
        -half*(logfc(2*na+1)+logfc(2*nb+1)   &
        +logfc(2*nc+1)+logfc(2*nd+1))-ae*n)
    c      = c*au_to_ev
    s0     = one/e
    s1     = zero
    s2     = zero
    m      = ncd-k

    do i=1,m
    s0     = s0*e/ecd
    s1     = s1+s0*(binomialcoefficient(ncd-k,i)-binomialcoefficient(ncd+k+1,i))/binomialcoefficient(n,i)
    enddo

    m1     = m+1
    m2     = ncd+k+1

    do i=m1,m2
    s0     = s0*e/ecd
    s2     = s2+s0*binomialcoefficient(m2,i)/binomialcoefficient(n,i)
    enddo

    s3     = exp(ae*n-acd*m2-aab*(nab-k))/binomialcoefficient(n,m2)
    slatercondon = c*(s1-s2+s3)
    return
end function getslatercondonparameter

end module overlap_backend


SUBROUTINE SVBKSB(U,W,V,M,N,MP,NP,B,X)
common/nkr_max/nmax
real U(MP,NP),W(NP),V(NP,NP),B(MP),X(NP),TMP(NMAX)
DO J=1,N
	S=0.
	IF(W(J).NE.0.)THEN
		DO I=1,M
			S=S+U(I,J)*B(I)
		end do
		S=S/W(J)
	ENDIF
	TMP(J)=S
end do
DO J=1,N
	S=0.
	DO JJ=1,N
		S=S+V(J,JJ)*TMP(JJ)
	end do
	X(J)=S
end do
RETURN
END

SUBROUTINE SVDCMP(A,M,N,MP,NP,W,V)
common/nkr_max/nmax

real A(MP,NP),W(NP),V(NP,NP),RV1(NMAX)

G=0.0
SCALE=0.0
ANORM=0.0
DO I=1,N
	L=I+1
	RV1(I)=SCALE*G
	G=0.0
	S=0.0
	SCALE=0.0

	IF (I.LE.M) THEN
		do K=I,M
			SCALE=SCALE+ABS(A(K,I))
		end do
		IF (SCALE.NE.0.0) THEN
			DO K=I,M
				A(K,I)=A(K,I)/SCALE
				S=S+A(K,I)*A(K,I)
			end do
			F=A(I,I)
			G=-SIGN(SQRT(S),F)
			H=F*G-S
			A(I,I)=F-G
			IF (I.NE.N) THEN
				DO J=L,N
					S=0.0
					DO K=I,M
						S=S+A(K,I)*A(K,J)
					end do
					F=S/H
					DO K=I,M
						A(K,J)=A(K,J)+F*A(K,I)
					end do
				end do
			ENDIF

			DO K= I,M
			  A(K,I)=SCALE*A(K,I)
			end do
		ENDIF
	ENDIF

	W(I)=SCALE *G
	G=0.0
	S=0.0
	SCALE=0.0
	IF ((I.LE.M).AND.(I.NE.N)) THEN
		DO K=L,N
			SCALE=SCALE+ABS(A(I,K))
		end do
		IF (SCALE.NE.0.0) THEN
			DO K=L,N
				A(I,K)=A(I,K)/SCALE
				S=S+A(I,K)*A(I,K)
			end do
			F=A(I,L)
			G=-SIGN(SQRT(S),F)
			H=F*G-S
			A(I,L)=F-G
			DO K=L,N
				RV1(K)=A(I,K)/H
			end do
			IF (I.NE.M) THEN
			DO J=L,M
				S=0.0
				DO K=L,N
					S=S+A(J,K)*A(I,K)
				end do
				DO K=L,N
					A(J,K)=A(J,K)+S*RV1(K)
				end do
			end do
			ENDIF
			DO K=L,N
			A(I,K)=SCALE*A(I,K)
			end do
		ENDIF
	ENDIF
	ANORM=MAX(ANORM,(ABS(W(I))+ABS(RV1(I))))
end do

DO I=N,1,-1
	IF (I.LT.N) THEN
		IF (G.NE.0.0) THEN
			DO J=L,N
				V(J,I)=(A(I,J)/A(I,L))/G
			end do
			DO J=L,N
				S=0.0

				DO K=L,N
					S=S+A(I,K)*V(K,J)
				end do

				DO K=L,N
					V(K,J)=V(K,J)+S*V(K,I)
				end do

			end do
		ENDIF
		DO J=L,N
			V(I,J)=0.0
			V(J,I)=0.0
		end do
	ENDIF
	V(I,I)=1.0
	G=RV1(I)
	L=I
end do

DO I=N,1,-1
	L=I+1
	G=W(I)
	IF (I.LT.N) THEN
		DO J=L,N
			A(I,J)=0.0
		end do
	ENDIF
	IF (G.NE.0.0) THEN
		G=1.0/G
		IF (I.NE.N) THEN
			DO J=L,N
				S=0.0
				DO K=L,M
					S=S+A(K,I)*A(K,J)
				end do
				F=(S/A(I,I))*G
				DO K=I,M
					A(K,J)=A(K,J)+F*A(K,I)
				end do
			end do
		ENDIF
		DO J=I,M
			A(J,I)=A(J,I)*G
		end do
	ELSE
		DO J= I,M
			A(J,I)=0.0
		end do
	ENDIF
	A(I,I)=A(I,I)+1.0
end do

DO K=N,1,-1
	DO ITS=1,30
		DO L=K,1,-1
			NM=L-1
			IF ((ABS(RV1(L))+ANORM).EQ.ANORM)  GO TO 2
			IF ((ABS(W(NM))+ANORM).EQ.ANORM)  GO TO 1
		end do

1       C=0.0
		S=1.0
		DO I=L,K
			F=S*RV1(I)
			IF ((ABS(F)+ANORM).NE.ANORM) THEN
				G=W(I)
				H=SQRT(F*F+G*G)
				W(I)=H
				H=1.0/H
				C= (G*H)
				S=-(F*H)
				DO J=1,M
					Y=A(J,NM)
					Z=A(J,I)
					A(J,NM)=(Y*C)+(Z*S)
					A(J,I)=-(Y*S)+(Z*C)
				end do
			ENDIF
		end do

2       Z=W(K)
		IF (L.EQ.K) THEN
			IF (Z.LT.0.0) THEN
				W(K)=-Z
				DO J=1,N
					V(J,K)=-V(J,K)
				end do
			ENDIF
			GO TO 3
		ENDIF
		!         IF (ITS.EQ.30) PAUSE 'No convergence in 30 iterations'
		X=W(L)
		NM=K-1
		Y=W(NM)
		G=RV1(NM)
		H=RV1(K)
		F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.0*H*Y)
		G=SQRT(F*F+1.0)
		F=((X-Z)*(X+Z)+H*((Y/(F+SIGN(G,F)))-H))/X
		C=1.0
		S=1.0
		DO J=L,NM
			I=J+1
			G=RV1(I)
			Y=W(I)
			H=S*G
			G=C*G
			Z=SQRT(F*F+H*H)
			RV1(J)=Z
			C=F/Z
			S=H/Z
			F= (X*C)+(G*S)
			G=-(X*S)+(G*C)
			H=Y*S
			Y=Y*C
			DO NM=1,N
				X=V(NM,J)
				Z=V(NM,I)
				V(NM,J)= (X*C)+(Z*S)
				V(NM,I)=-(X*S)+(Z*C)
			end do
			Z=SQRT(F*F+H*H)
			W(J)=Z
			IF (Z.NE.0.0) THEN
				Z=1.0/Z
				C=F*Z
				S=H*Z
			ENDIF
			F= (C*G)+(S*Y)
			X=-(S*G)+(C*Y)
			DO NM=1,M
				Y=A(NM,J)
				Z=A(NM,I)
				A(NM,J)= (Y*C)+(Z*S)
				A(NM,I)=-(Y*S)+(Z*C)
			end do
		end do
		RV1(L)=0.0
		RV1(K)=F
		W(K)=X
	end do
3   CONTINUE
end do

RETURN
END


! scalar variance budget:

subroutine stat_varscalar(f,df,f0,df0,s2le)

use grid
implicit none
real f(dimx1_s:dimx2_s,dimy1_s:dimy2_s,nzm)
real df(dimx1_s:dimx2_s,dimy1_s:dimy2_s,nzm)
real s2le(nzm)
real f0(nzm),df0(nzm),coef
integer i,j,k
call averageXY_MPI(f,dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm,f0)
call averageXY_MPI(df,dimx1_s,dimx2_s,dimy1_s,dimy2_s,nzm,df0)
coef = 1./(dtn*nx*ny)
do k=1,nzm
 s2le(k)=0.
 do j=1,ny
  do i=1,nx
   s2le(k)=s2le(k)+(f(i,j,k)-f0(k))**2-(df(i,j,k)-df0(k))**2
  end do
 end do
 s2le(k)=s2le(k)*coef
end do

end


!===================================================================================
!================== SUBROUTINE NONLINEAR DERIVATIVE ================================
!===================================================================================

subroutine derive2css(Nx,Ny,Nh,alpha,nu,time,omegak,omegak_new,dt_omegak_old,dt_omegak_new)
implicit none

include "fftw3.f"

integer ( kind = 4 ) Nx,Ny,Nh, i, j
real ( kind = 8 ) time,alpha,nu,lambda,kx,ky,Lx,Ly
real ( kind = 8 ) ux(Nx,Ny),uy(Nx,Ny),domega_dx(Nx,Ny),domega_dy(Nx,Ny)
real ( kind = 8 ) ux_domega_dx(Nx,Ny),uy_domega_dy(Nx,Ny)
complex ( kind = 8 ) ukx(Nh,Ny),ukx_dum(Nh,Ny),uky(Nh,Ny),uky_dum(Nh,Ny),omegak_dum(Nh,Ny),omegak_dummy(Nh,Ny)
complex ( kind = 8 ) psik(Nh,Ny),omegak(Nh,Ny),i_kx_omegak(Nh,Ny),i_ky_omegak(Nh,Ny),omegak_new(Nh,Ny)
complex ( kind = 8 ) NLkx1(Nh,Ny),NLky1(Nh,Ny),NLk1(Nh,Ny),dt_omegak_old(Nh,Ny),dt_omegak_new(Nh,Ny)
real (kind=8), parameter :: pi = 3.1428

integer ( kind = 8 ) plan_forward,plan_backward

do i = 1,Nx/2+1
  do j = 1,Ny/2
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat(j-1)/Ly
     omegak_dummy(i,j) = omegak(i,j)
     if (i == 1 .and. j == 1) then
      psik(i,j) = (0.0d0,0.0d0)
      ukx(i,j) = (0.0d0,0.0d0)
      uky(i,j) = (0.0d0,0.0d0)
      else
      psik(i,j) = omegak_dummy(i,j)/( kx*kx + ky*ky +lambda)
      ukx(i,j) = + (0.0d0,1.0d0) * ky * psik(i,j)
      uky(i,j) = - (0.0d0,1.0d0) * kx * psik(i,j)
      endif
    ukx_dum(i,j) = ukx(i,j)
    uky_dum(i,j) = uky(i,j)
    omegak_dum(i,j) = (kx*kx + ky*ky) * psik(i,j)
    i_kx_omegak(i,j) = (0.0d0,1.0d0)*kx*omegak_dum(i,j)
    i_ky_omegak(i,j) = (0.0d0,1.0d0)*ky*omegak_dum(i,j)
  enddo
  do j = Ny/2+1,Ny
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly
    omegak_dummy(i,j) = omegak(i,j)
    psik(i,j) = omegak_dummy(i,j)/( kx*kx + ky*ky + lambda)
    ukx(i,j) = + (0.0d0,1.0d0) * ky * psik(i,j)
    uky(i,j) = - (0.0d0,1.0d0) * kx * psik(i,j)
    ukx_dum(i,j) = ukx(i,j)
    uky_dum(i,j) = uky(i,j)
    omegak_dum(i,j) = (kx*kx + ky*ky) * psik(i,j)
    i_kx_omegak(i,j) = (0.0d0,1.0d0)*kx*omegak_dum(i,j)
    i_ky_omegak(i,j) = (0.0d0,1.0d0)*ky*omegak_dum(i,j)
  enddo
enddo

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, ukx_dum, ux, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, uky_dum, uy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, i_kx_omegak, domega_dx, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

  call dfftw_plan_dft_c2r_2d_ (plan_backward, Nx, Ny, i_ky_omegak, domega_dy, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_backward)
  call dfftw_destroy_plan_ (plan_backward)

do i = 1,Nx
  do j = 1,Ny
    ux(i,j) = ux(i,j)/(dfloat(Nx)*dfloat(Ny))
    uy(i,j) = uy(i,j)/(dfloat(Nx)*dfloat(Ny))
    domega_dx(i,j) = domega_dx(i,j)/(dfloat(Nx)*dfloat(Ny))
    domega_dy(i,j) = domega_dy(i,j)/(dfloat(Nx)*dfloat(Ny))
    ux_domega_dx(i,j) = ux(i,j)*domega_dx(i,j)
    uy_domega_dy(i,j) = uy(i,j)*domega_dy(i,j)
  enddo
enddo

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, ux_domega_dx, NLkx1, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)
  call dfftw_destroy_plan_ (plan_forward)

  call dfftw_plan_dft_r2c_2d_ (plan_forward, Nx, Ny, uy_domega_dy, NLky1, FFTW_ESTIMATE)
  call dfftw_execute_ (plan_forward)
  call dfftw_destroy_plan_ (plan_forward)

do i = 1,Nx/2+1
  do j = 1,Ny/2
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat(j-1)/Ly
      ! De - Aliazing Technique...
      if (dsqrt(kx*kx + ky*ky) .ge. (dfloat(Nx+Ny)/2.0)/3.0 + 0) then
      NLkx1(i,j) = 0.0d0
      NLky1(i,j) = 0.0d0
      endif
  enddo
  do j = Ny/2+1,Ny
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly
      ! De - Aliazing Technique...
      if (dsqrt(kx*kx + ky*ky) .ge. (dfloat(Nx+Ny)/2.0)/3.0 + 0) then
      NLkx1(i,j) = 0.0d0
      NLky1(i,j) = 0.0d0
      endif
  enddo
enddo

do i = 1,Nx/2+1
  do j = 1,Ny/2
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat(j-1)/Ly
    NLk1(i,j) = alpha * ( NLkx1(i,j) + NLky1(i,j) )
    NLk1(i,j) = NLk1(i,j) + nu * (kx*kx + ky*ky)*omegak_dum(i,j)
  enddo
  do j = Ny/2+1,Ny
    kx = 2.0d0*pi*dfloat(i-1)/Lx
    ky = 2.0d0*pi*dfloat((j-1)-Ny)/Ly
    NLk1(i,j) = alpha * ( NLkx1(i,j) + NLky1(i,j) )
    NLk1(i,j) = NLk1(i,j) + nu * (kx*kx + ky*ky)*omegak_dum(i,j)
  enddo
enddo

do i = 1,Nx/2+1
  do j = 1,Ny
    dt_omegak_new(i,j) = -NLk1(i,j)
  enddo
enddo

return

end subroutine derive2css


!-----------------------------------------------------------------`
! Reacting Flows
! Project - 3, Water cavitation
! Rohit K S S Vuppala
! rvuppal@ncsu.edu
! 200211761
!-----------------------------------------------------------------

program main
implicit none

real(8) :: u0,t0,P0stag,pratio,Pback,vp0,yv0
real(8),allocatable :: X(:),S(:),Sm(:,:),rho(:),v(:,:),F(:,:),c(:),dudv(:,:,:),&
                      rhs(:,:)
real(8) :: h,y,res(3),res0(3)
integer :: i,j,nx,iflux,niter,iter,flag
real(8) :: Rvap,dt,leng,tol,pin
!----------
!PRIMITIVES ARE:
! Y-vapor, Pressure,Velocity
!CONSERVED :
!rho*Yv,rho,rho*u
!------------------

real(8),parameter :: r0 = 1000.0d0
real(8),parameter :: p0 = 101325.0d0
real(8),parameter :: k0 = 2.15d9
real(8),parameter :: n0=  7.15d0

flag = 0
tol  = 1d-6
niter = 10000000
!-------vapour realtion-----------
Rvap = 461.9d0
vp0  = 3169.0d0
!---------------------------------

nx   = 150
leng = 1.5d0
h    = leng/nx
iflux = 3     !1-Loui Stefan,2-LDFSS,3-Loui Stefan modified,4-LDFSS modified
dt = 1d-6

!---Input values---------------------------------------------

P0stag = 4.0d7
u0     = 10.0d0
t0     = 300.0d0
Pratio = 0.9d0
Pback  = Pratio*P0stag
yv0    = 1d-7
!----------------------------------------------------

allocate(S(0:nx+1))
allocate(X(0:nx+1))
allocate(rho(0:nx+1))
allocate(v(3,0:nx+1))
allocate(Sm(3,1:nx))
allocate(F(3,0:nx) )
allocate(c(0:nx+1) )
allocate(dudv(3,3,1:nx))
allocate(rhs(3,1:nx))

 do i=0,nx+1       !faces are from 0 to nx
    y = i*h
  X(i)= -h/2 + i*h

         S(i) = ((1.0d0+4.0d0*(y-0.5d0)**2))

 end do

open(file='grid.dat',unit=1)
do i=1,nx

   write(1,*) X(i),S(i)

enddo

close(1)
!--------initialise the values--------------------
call initial
!print*, v(:,1)
!stop
open(file='convergence.dat',unit=3)
print*,'------------------<<<<<<<<<Initialisation complete>>>>>>>>-----------------'
do iter=1,niter

	call therm
        !print*, c(2)
        call boundary
        call therm
! do i=0,nx+1
!    print*, c(i),v(:,i),rho(i)
! enddo
! stop
!        print*, c(0)
        call flux
        call source
        call update
        call therm
        call residual
       if(flag.eq.1) exit
       if(mod(iter,1000).eq.0) call solution
enddo
       call solution
contains
!-------------------------------------------------------------
subroutine solution

  open(file='solution.dat',unit=2,status = 'unknown')
  write(2,*) 'variables= "x","Vapour fraction","Pressure","Velocity","Density","Mach","Liquid Fraction"'
  do i=1,nx
     write(2,*) x(i),v(:,i),rho(i),v(3,i)/c(i),1.0-v(1,i)
  enddo
  close(2)
endsubroutine

!-----------------------------------------------------------
subroutine residual
integer :: i,j

    if(iter.eq.1) res0=res
    if(mod(iter,1000).eq.0) write(*,*) iter, res,abs(sum(res)/sum(res0))
    write(3,*) iter, res,abs(sum(res)/sum(res0))
    if(abs(sum(res)/sum(res0)).le.tol) flag =1
    !stop
   !call sleep(1)
endsubroutine
!-------------------------------------------------------------

function solver(a,b)
integer,parameter::n = 3
real(8)::a(n,n),s(n),b(n),x(n),r,rmax,smax,sum,z,solver(3)
integer::p(n), pk,i,j,k
!print*, iter
!print*, 'hi'

      do  i=1,n
         p(i) = i
         smax = 0.0d0
         do  j=1,n
            smax = max(smax,dabs(a(i,j)))
         enddo
         s(i) = smax
     enddo

      do  k=1,n-1
         rmax = 0.0d0
         do i=k,n
            r = dabs(a(p(i),k))/s(p(i))
            if (r .gt. rmax) then
               j = i
               rmax = r
            endif
      enddo

         pk = p(j)
         p(j) = p(k)
         p(k) = pk

         do i=k+1,n
            z = a(p(i),k)/a(p(k),k)
            a(p(i),k) = z
            do  j=k+1,n
               a(p(i),j) = a(p(i),j) - z*a(p(k),j)
            enddo
        enddo
      enddo

      do  k=1,n-1
         do  i=k+1,n
            b(p(i)) = b(p(i)) - a(p(i),k)*b(p(k))
         enddo
      enddo
      do i=n,1,-1
         sum = b(p(i))
         do j=i+1,n
            sum = sum - a(p(i),j)*x(j)
    enddo
         x(i) = sum/a(p(i),i)
    enddo
         solver = x

endfunction
!-------------------------------------------------------------
subroutine update
implicit none
real(8) :: rhov,rhol,pi,ci,yl,yv,rhoi,sint
real(8) :: drvdp,drldp,drdp,drdyv,dv(3)
real(8) :: a(3,3),b(3)
res = 0.0
!compute the jacobian solve and update
 do i=1,nx

    sint = 0.5d0*(S(i) + S(i-1))
    rhov = max(v(2,i),vp0)/(Rvap*t0)
    rhol = rhow(v(2,i))
      yv = v(1,i)
      yl = 1.0 - yv
      pi = v(2,i)
    rhoi = rho(i)

   drvdp = 1.0/(Rvap*t0)
   drldp = 1.0/(k0*(1.0d0 +(n0/k0)*(pi-p0))/(rhol))

    drdp = (rhoi**2)*(yv/((rhov**2)*(1.0/drvdp)) + yl/((rhol**2)*(1.0/drldp)))

   drdyv = -1.0*(rhoi**2)*(1.0d0/rhov - 1.0d0/rhol)

 dudv(:,:,i) = 0.0d0

 dudv(1,1,i) = rhoi  + yv*drdyv
 dudv(1,2,i) = drdp*yv
 dudv(1,3,i) = 0.0d0

 dudv(2,1,i) = drdyv
 dudv(2,2,i) = drdp
 dudv(2,3,i) = 0.0d0

 dudv(3,1,i) = v(3,i)*drdyv
 dudv(3,2,i) = drdp*v(3,i)
 dudv(3,3,i) = rhoi

      rhs(:,i) = sint*Sm(:,i) - (S(i)*F(:,i) - S(i-1)*F(:,i-1))/(h)
      res = res + rhs(:,i)**2
      a = sint/dt*dudv(:,:,i)
      b = rhs(:,i)
      !dv = 0.0d0
      dv = solver(a,b)

      !print*, dudv(1,:,i)
      !print*, dudv(2,:,i)      !stop
      !print*, dudv(3,:,i)
      !print*,dv(:)
      !print*,rhs(:,i),Sm(:,i)
      !print*, sint
     v(:,i) = v(:,i) +  dv
 enddo
 !stop
     !do i = 0,nx
        !print*, F(:,i)
     !enddo
     !stop
     res = sqrt(res)
endsubroutine
!-----------------------------------------------------------
subroutine boundary
implicit none
real(8) :: mi,yvi,pi,ui,rhoi,ci
real(8) :: yv,yl,rhov,rhol
integer :: j
! inlet condition
   v(1,0) = yv0
   v(3,0) = v(3,1)

      yv = v(1,0)

do j=1,1000
      v(2,0) = P0stag - 0.5d0*rho(0)*(v(3,0)**2)
      rhol = rhow(v(2,0))
      rhov = max(vp0,v(2,0))/(Rvap*t0)
      yl = 1.0 - yv
     rho(0)= 1.0/(yv/rhov+yl/rhol)
enddo
   c(0)   = sound(v(2,0),v(1,0),rho(0))

!print*, v(2,1)
!outlet condition

   mi = v(3,nx)/c(nx)

  if(mi<1.0) then
    v(2,nx+1) = Pback
 else if (mi>1.0) then
    v(2,nx+1) = v(2,nx)
 else
    print*, 'Incorrect Mach Number',mi,iter
    stop
 endif

    v(1,nx+1) = v(1,nx)
    v(3,nx+1) = v(3,nx)

endsubroutine
!-----------------------------------------------------------
subroutine source
implicit none
integer :: i
real(8) :: p,rhov,rhol,yl,yv,dp,eq,sint
real(8),parameter :: ctani = 1.0d0
real(8),parameter :: ktani = 5.0d0

    Sm = 0.0d0

do i=1,nx
   p = v(2,i)
 sint= (S(i)+S(i-1))*0.5d0
   if(p<vp0) then
!    print*, 'hi'
     rhov = max(p,vp0)/(Rvap*t0)
     rhol = rhow(p)

      dp = min(vp0-p,ktani*vp0)
      eq = sqrt(2.0/3.0*dp/rhol)

      yv = v(1,i)

      Sm(1,i) = ctani*dp*(1.0-yv)*rhov*eq
         !print*, Sm(:,i)
   endif
      Sm(3,i) = v(2,i)*(S(i)-S(i-1))/h/sint
enddo

endsubroutine
!-----------------------------------------------------------
subroutine initial
implicit none
integer :: i,j,n
real(8) :: dr,yl,yv,rhol,rhov

rho = r0
 yv =yv0

v(1,:) = yv
v(2,:) = P0stag
 do i=0,nx+1
    v(3,i) = u0/(S(i)/2.0)
 enddo
do j=1,1000
   dr =0.0d0
   do i=0,nx+1
      v(2,i) = P0stag - 0.5d0*rho(i)*(v(3,i)**2)
          dr = dr + dabs(rhow(v(2,i))-rho(i))
      rhol = rhow(v(2,i))
      rhov = max(vp0,v(2,i))/(Rvap*t0)
      yl = 1.0 - yv
     rho(i)= 1.0/(yv/rhov+yl/rhol)
!       print*, j
   enddo

   if(dr.le.1d-4) exit
enddo
  pin = v(2,0)
!print*, S
!stop
v(1,nx+1) = yv0
!v(2,nx+1) = Pback
!v(3,nx+1) = v(3,nx)

endsubroutine
!-----------------------------------------------------------
subroutine therm
implicit none
real(8) :: rhov,rhol,yv,yl,rhoi
real(8) :: pi,eq
integer :: i

do i = 0,nx+1

     yv = v(1,i)
     pi = v(2,i)
   rhov = max(pi,vp0)/(Rvap*t0)
   rhol = rhow(pi)

 yl = 1.0 - yv
      eq = yv/rhov + yl/rhol
   rhoi = 1.0/(eq)
   rho(i) = rhoi
     c(i) = sound(pi,yv,rhoi)
  !print*, pi
enddo
!stop
endsubroutine
!-----------------------------------------------------------
subroutine flux
implicit none
integer :: i,j
real(8) :: CVLp,CVLn,Dp,Dn,Dpi,Dni1,api,bi,bi1,ani1,machpi,machni1,machi,machi1, &
           Fci(3),Fci1(3),Pi(3),Pi1(3),CLSp,CLSn,CEp,CEn,M_1,Mp,Mn,delp
real(8) :: Pvmod(3),Pemod(3),c1
real(8) :: cint,ui,ui1,p_i,p_i1,rhoi,rhoi1

  Pemod =(/0.0d0,0.0d0,1.0d0/)

 if(iflux ==1) then  !unmodified Luoi stefen
   do i=0,nx

    cint = sqrt((rho(i)*(c(i)**2) + rho(i+1)*(c(i+1)**2))/(rho(i)+rho(i+1)))
     ui  = v(3,i)
     ui1 = v(3,i+1)
  machi  = ui/(cint)
  machi1 = ui1/(cint)
    rhoi = rho(i)
    rhoi1= rho(i+1)
      p_i = v(2,i)
      p_i1= v(2,i+1)

    api= 0.5d0*(1.0d0+sign(1.0d0,machi))
    ani1= 0.5d0*(1.0d0-sign(1.0d0,machi1))
     bi= -max(0.0d0,1.0d0-int(dabs(machi)))
    bi1= -max(0.0d0,1.0d0-int(dabs(machi1)))

    machpi= 0.25d0*(machi + 1.0d0)**2
   machni1=-0.25d0*(machi1- 1.0d0)**2
       Dpi=0.25d0*((machi+1.0)**2)*(2.0-machi)
      Dni1=0.25d0*((machi1-1.0)**2)*(2.0+machi1)

    CVLp = api*(1.0d0+bi)*machi - bi*machpi
    CVLn = ani1*(1.0d0+bi1)*machi1-bi1*machni1

    Dp   = api* (1.0+bi)-bi*Dpi
    Dn   = ani1*(1.0+bi1)-bi1*Dni1

    Fci = (/ v(1,i),1.0d0,ui    /)
    Fci1= (/ v(1,i+1),1.0d0,ui1 /)

    Pi  =(/0.0d0,0.0d0,p_i/)
    Pi1 =(/0.0d0,0.0d0,p_i1/)

    CLSp =max(0.0,CVLp+CVLn)
    CLSn =min(0.0,CVLp+CVLn)

  F(:,i)=(cint)*(rhoi*CLSp*Fci + rhoi1*CLSn*Fci1) + Dp*Pi + Dn*Pi1

    enddo
!stop
 elseif (iflux == 2) then !unmodified LDFSS
   do i=0,nx

    cint = sqrt((rho(i)*(c(i)**2) + rho(i+1)*(c(i+1)**2))/(rho(i)+rho(i+1)))
     ui  = v(3,i)
     ui1 = v(3,i+1)
  machi  = ui/(cint)
  machi1 = ui1/(cint)
    rhoi = rho(i)
    rhoi1= rho(i+1)
      p_i = v(2,i)
      p_i1= v(2,i+1)

    api= 0.5d0*(1.0d0+sign(1.0d0,machi))
    ani1= 0.5d0*(1.0d0-sign(1.0d0,machi1))
     bi= -max(0.0d0,1.0d0-int(dabs(machi)))
    bi1= -max(0.0d0,1.0d0-int(dabs(machi1)))

    machpi= 0.25d0*(machi + 1.0d0)**2
   machni1=-0.25d0*(machi1- 1.0d0)**2
       Dpi=0.25d0*((machi+1.0)**2)*(2.0-machi)
      Dni1=0.25d0*((machi1-1.0)**2)*(2.0+machi1)

    CVLp = api*(1.0d0+bi)*machi - bi*machpi
    CVLn = ani1*(1.0d0+bi1)*machi1-bi1*machni1

    Dp   = api* (1.0+bi)-bi*Dpi
    Dn   = ani1*(1.0+bi1)-bi1*Dni1

    Fci = (/ v(1,i),1.0d0,ui    /)
    Fci1= (/ v(1,i+1),1.0d0,ui1 /)

    Pi  =(/0.0d0,0.0d0,p_i/)
    Pi1 =(/0.0d0,0.0d0,p_i1/)
    M_1 = 0.25*bi*bi1*(sqrt(0.5*(machi**2+machi1**2))-1.0d0)**2
    delp= p_i-p_i1

     Mp= M_1*max(0.0,1.0-((delp/(p_i+p_i1))+(2.0*delp/p_i)))
     Mn= M_1*max(0.0,1.0+((delp/(p_i+p_i1))-(2.0*delp/p_i1)))

     CEp= CVLp - Mp
     CEn= CVLn + Mn

  F(:,i)=(cint)*(rhoi*CEp*Fci + rhoi1*CEn*Fci1) + Dp*Pi + Dn*Pi1

   !print*, Mn,CEn
   enddo
 elseif (iflux == 3) then !modified Loiu Stefan
   do i=0,nx

    cint = sqrt((rho(i)*(c(i)**2) + rho(i+1)*(c(i+1)**2))/(rho(i)+rho(i+1)))
     ui  = v(3,i)
     ui1 = v(3,i+1)
  machi  = ui/(cint)
  machi1 = ui1/(cint)
    rhoi = rho(i)
    rhoi1= rho(i+1)
      p_i = v(2,i)
      p_i1= v(2,i+1)
   !print*, cint
    api= 0.5d0*(1.0d0+sign(1.0d0,machi))
    ani1= 0.5d0*(1.0d0-sign(1.0d0,machi1))
     bi= -max(0.0d0,1.0d0-int(dabs(machi)))
    bi1= -max(0.0d0,1.0d0-int(dabs(machi1)))

    machpi= 0.25d0*(machi + 1.0d0)**2
   machni1=-0.25d0*(machi1- 1.0d0)**2
       Dpi=0.25d0*((machi+1.0)**2)*(2.0-machi)
      Dni1=0.25d0*((machi1-1.0)**2)*(2.0+machi1)

    CVLp = api*(1.0d0+bi)*machi - bi*machpi
    CVLn = ani1*(1.0d0+bi1)*machi1-bi1*machni1

    Dp   = api* (1.0+bi)-bi*Dpi
    Dn   = ani1*(1.0+bi1)-bi1*Dni1

    Fci = (/ v(1,i),1.0d0,ui    /)
    Fci1= (/ v(1,i+1),1.0d0,ui1 /)

    Pi  =(/0.0d0,0.0d0,p_i/)
    Pi1 =(/0.0d0,0.0d0,p_i1/)

    Pvmod = 0.5d0*(Pi+Pi1) +0.5d0*(Dp-Dn)*(Pi-Pi1) +0.5d0*Pemod*(rhoi+rhoi1)*(Dp+Dn-1.0d0)*(cint**2)

   CLSp =max(0.0,CVLp+CVLn)
   CLSn =min(0.0,CVLp+CVLn)

  F(:,i)=(cint)*(rhoi*CLSp*Fci + rhoi1*CLSn*Fci1) + Pvmod

  !print*, CLSP,CLSn    !print*, CLSP,CLSn
  ! print*, i,F(:,i)
   enddo
 elseif (iflux == 4) then !modified LDFSS
   do i=0,nx

     cint =sqrt((rho(i)*(c(i)**2) + rho(i+1)*(c(i+1)**2))/(rho(i)+rho(i+1)))
      ui  = v(3,i)
      ui1 = v(3,i+1)
   machi  = ui/(cint)
   machi1 = ui1/(cint)
     rhoi = rho(i)
     rhoi1= rho(i+1)
       p_i = v(2,i)
       p_i1= v(2,i+1)

     api= 0.5d0*(1.0d0+sign(1.0d0,machi))
     ani1= 0.5d0*(1.0d0-sign(1.0d0,machi1))
      bi= -max(0.0d0,1.0d0-int(dabs(machi)))
     bi1= -max(0.0d0,1.0d0-int(dabs(machi1)))

     machpi= 0.25d0*(machi + 1.0d0)**2
    machni1=-0.25d0*(machi1- 1.0d0)**2
        Dpi=0.25d0*((machi+1.0)**2)*(2.0-machi)
       Dni1=0.25d0*((machi1-1.0)**2)*(2.0+machi1)

     CVLp = api*(1.0d0+bi)*machi - bi*machpi
     CVLn = ani1*(1.0d0+bi1)*machi1-bi1*machni1

     Dp   = api* (1.0+bi)-bi*Dpi
     Dn   = ani1*(1.0+bi1)-bi1*Dni1

     Fci = (/ v(1,i),1.0d0,ui    /)
     Fci1= (/ v(1,i+1),1.0d0,ui1 /)

     Pi  =(/0.0d0,0.0d0,p_i/)
     Pi1 =(/0.0d0,0.0d0,p_i1/)
     M_1 = 0.25*bi*bi1*(sqrt(0.5*(machi**2+machi1**2))-1.0d0)**2
     delp= p_i-p_i1

       Mp= M_1*max(0.0,1.0-0.5d0*((delp+dabs(delp))/(rhoi*(cint)**2)))
       Mn= M_1*max(0.0,1.0+0.5d0*((delp-dabs(delp))/(rhoi1*(cint)**2)))

       CEp= CVLp - Mp
       CEn= CVLn + Mn
  Pvmod = 0.5d0*(Pi+Pi1) +0.5d0*(Dp-Dn)*(Pi-Pi1) +0.5d0*Pemod*(rhoi+rhoi1)*(Dp+Dn-1.0d0)*(cint**2)
      F(:,i)=(cint)*(rhoi*CEp*Fci + rhoi1*CEn*Fci1) + Pvmod
      !print*, Dp*Pi+Dn*Pi1
   !print*, i,F(:,i)
   !print*, Cep,Cen
   enddo
   !stop
 else
    print*, 'Incorrect flux flag selected'
 endif

endsubroutine
!-------------------------------------------------------------------------------
!Tait equation
function rhow(press)
 real(8) :: press,rhow
 real(8) :: a
 a = (1.0+n0/k0*(press-p0))
 rhow = r0*(a)**(1.0/n0)
 return
 endfunction rhow
!---------------------------------------------------------------------------------

function sound(p,yv,rhoi)
real(8) :: p,yv,rhoi,sound,yl
real(8) :: cv,cl,av,al,rhol,rhov

 rhol = rhow(p)
 rhov = max(p,vp0)/(Rvap*t0)

   yl = 1.0 - yv
   cv = sqrt(Rvap*t0)            ! 1/drhovdp
   cl = sqrt(k0*(1.0d0 +(n0/k0)*(p-p0))/(rhol))

   av = (rhoi-rhol)/(rhov-rhol)
   al = 1.0d0 - av

 sound = rhov*(cv**2)*rhol*(cl**2)/(rhoi*(av*rhol*(cl**2)+al*rhov*(cv**2)))

 sound = sqrt(sound)
 !print*, cv,cl,p,rhol
endfunction sound

end program


      subroutine derivs(ndim,ntraj,x,dv,pe)
      use model, only : R0

      implicit double precision (a-h, o-z)

      real*8, dimension(ndim,ntraj) :: x,dv
      real*8, dimension(ntraj) :: pe(ntraj)

      akt = 10d0
      akv = 1d0

      do i=1,ntraj
!        do j=1,ndim
         xcm = (x(1,i) + x(2,i) + x(3,i))/3d0

          dv(1,i) = akt*xcm/3d0 - akv*(x(2,i)-x(1,i)-R0) - &
                    (x(3,i)-x(1,i)-R0)*akv

          dv(2,i) = akt*xcm/3d0 + akv*(x(2,i)-x(1,i)-R0)  - &
                    (x(3,i)-x(2,i)-R0)*akv

          dv(3,i) = akt*xcm/3d0 + akv*(x(3,i)-x(2,i)-R0) + &
                    (x(3,i)-x(1,i)-R0)*akv

          pe(i) = akt*xcm**2/2d0 + akv*((x(2,i)-x(1,i)-R0)**2/2d0 + &
              (x(3,i)-x(2,i)-R0)**2/2d0 + (x(3,i)-x(1,i)-R0)**2/2d0) - &
              R0**2/6d0
!        enddo
      enddo

      return
      end subroutine


      SUBROUTINE ETALL(im,jm,tph0d,tlm0d,dlmd,dphd,HLAT,HLON,VLAT,VLON)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C                .      .    .                                       .
C SUBPROGRAM: ETALL         COMPUTE EARTH LATITUDE & LONIGTUDE OF
C                           ETA GRID POINTS
C   PRGMMR: ROGERS          ORG: W/NP22     DATE: 90-06-13
C
C ABSTRACT: COMPUTES THE EARTH LATITUDE AND LONGITUDE OF ETA GRID
C   POINTS (BOTH H AND V POINTS)
C
C PROGRAM HISTORY LOG:
C   90-06-13  E.ROGERS
C   98-06-09  M.BALDWIN - CONVERT TO 2-D CODE
C   01-01-03  T BLACK   - MODIFIED FOR MPI
C
C USAGE:    CALL ETALL(HLAT,HLON,VLAT,VLON)
C   INPUT ARGUMENT LIST:
C     NONE
C
C   OUTPUT ARGUMENT LIST:
C     HLAT     - LATITUDE OF H GRID POINTS IN RADIANS (NEG=S)
C     HLON     - LONGITUDE OF H GRID POINTS IN RADIANS (E)
C     VLAT     - LATITUDE OF V GRID POINTS IN RADIANS (NEG=S)
C     VLON     - LONGITUDE OF V GRID POINTS IN RADIANS (E)
C
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM RS/6000 SP
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
                             D I M E N S I O N
     & IDAT  (3)
C
     &,GLATH (IM,JM),GLONH (IM,JM),GLATV (IM,JM),GLONV (IM,JM)
C
        REAL HLAT(IM,JM),HLON(IM,JM),VLAT(IM,JM),VLON(IM,JM)
C-----------------------------------------------------------------------
C--------------LOGICAL FILE NAMES---------------------------------------
C-----------------------------------------------------------------------
                             D A T A
     &  LIST  /06/
C-----------------------------------------------------------------------
C--------------UNIVERSAL CONSTANTS--------------------------------------
C-----------------------------------------------------------------------
                             D A T A
     & PI/3.141592654/
C-----------------------------------------------------------------------
 1000 FORMAT(' I J=',2I4,' GLAT=',E12.5,' GLON=',E12.5,' ELAT=',E12.5
     &,' ELON=',E12.5,' WLON = ',E12.5)
C----------------------------------------------------------------------
C--------------DERIVED GEOMETRICAL CONSTANTS----------------------------
C----------------------------------------------------------------------
CC
	WBD=-(IM-1)*DLMD
	SBD=-(JM-1)/2*DPHD
      DTR = PI / 180.0
      TPH0 = TPH0D * DTR
      WB = WBD * DTR
      SB = SBD * DTR
      DLM = DLMD * DTR
      DPH = DPHD * DTR

	write(6,*) 'TPH0,WB,SB,DLM,DPH,DTR: ', TPH0,WB,SB,DLM,DPH,DTR

      TDLM = DLM + DLM
      TDPH = DPH + DPH
C
      STPH0 = SIN(TPH0)
      CTPH0 = COS(TPH0)
C
C-----------------------------------------------------------------------
C---COMPUTE GEOGRAPHIC LAT AND LONG OF ETA GRID POINTS (H & V POINTS)---
C-----------------------------------------------------------------------
      DO 200 J = 1,JM
C
         TLMH = WB - TDLM + MOD(J+1,2) * DLM
         TPHH = SB+(J-1)*DPH
         TLMV = WB - TDLM + MOD(J,2) * DLM
         TPHV = TPHH
         STPH = SIN(TPHH)
         CTPH = COS(TPHH)
         STPV = SIN(TPHV)
         CTPV = COS(TPHV)
C----------------------------------------------------------------------
C---------- COMPUTE EARTH LATITUDE/LONGITUDE OF H POINTS --------------
C----------------------------------------------------------------------
         DO 201 I = 1,IM
           TLMH = TLMH + TDLM
           SPHH = CTPH0 * STPH + STPH0 * CTPH * COS(TLMH)
           GLATH(I,J) = ASIN(SPHH)
           CLMH = CTPH * COS(TLMH) / (COS(GLATH(I,J)) * CTPH0)
     1               - TAN(GLATH(I,J)) * TAN(TPH0)
           IF(CLMH .GT. 1.) CLMH = 1.0
           IF(CLMH .LT. -1.) CLMH = -1.0
           FACTH = 1.
           IF(TLMH .GT. 0.) FACTH = -1.
C          WRITE(6,88888) I,J, CLMH
C8888      FORMAT(2X,2I6,1X,E12.5)
           GLONH(I,J) = -TLM0D * DTR + FACTH * ACOS(CLMH)
C          IF(I .EQ. 1) THEN
C           WRITE(LIST,99995) I,J,GLATH(I,J),GLONH(I,J)
C9995       FORMAT(2X,2(I6,1X),2(E12.5,1X))
C          END IF
C
C
           HLAT(I,J) = GLATH(I,J) / DTR
C           HLON(I,J) = 360.0 - GLONH(I,J) / DTR
	    HLON(I,J)= -GLONH(I,J)/DTR

           IF(HLON(I,J) .GT. 180.) HLON(I,J) = HLON(I,J) - 360.
           IF(HLON(I,J) .LT. -180.) HLON(I,J) = HLON(I,J) + 360.
  201    CONTINUE
C----------------------------------------------------------------------
C---------- COMPUTE EARTH LATITUDE/LONGITUDE OF V POINTS --------------
C----------------------------------------------------------------------
         DO 202 I = 1,IM
           TLMV = TLMV + TDLM
           SPHV = CTPH0 * STPV + STPH0 * CTPV * COS(TLMV)
           GLATV(I,J) = ASIN(SPHV)
           CLMV = CTPV * COS(TLMV) / (COS(GLATV(I,J)) * CTPH0)
     1          - TAN(GLATV(I,J)) * TAN(TPH0)
           IF(CLMV .GT. 1.) CLMV = 1.
           IF(CLMV .LT. -1.) CLMV = -1.
           FACTV = 1.
           IF(TLMV .GT. 0.) FACTV = -1.
           GLONV(I,J) = -TLM0D * DTR + FACTV * ACOS(CLMV)
C          IF(I.EQ.1) THEN
C           WRITE(LIST,99995) I,J,GLATV(I,J),GLONV(I,J)
C          END IF
C
C    CONVERT INTO DEGREES AND EAST LONGITUDE
C
           VLAT(I,J) = GLATV(I,J) / DTR
C           VLON(I,J) = 360.0 - GLONV(I,J) / DTR
           VLON(I,J) = -GLONV(I,J) / DTR
           IF(VLON(I,J) .GT. 180.) VLON(I,J) = VLON(I,J) - 360.
           IF(VLON(I,J) .LT. -180.) VLON(I,J) = VLON(I,J) + 360.
  202    CONTINUE
  200 CONTINUE
C
C     DO 210 J = 1,JM
C         WRITE(LIST,88888) J,HLAT(1,J),HLON(1,J),VLAT(1,J),VLON(1,J)
C8888    FORMAT(2X,I5,1X,4(E12.5,1X))
C      END IF
C 210 CONTINUE
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

       subroutine vecrot_rotlat(IM,JM,TPH0D,TLM0D,VLAT,VLON,DRAY,CRAY)

C  SUBPROGRAM: ROTLLE        ROTATE WINDS ON LAT/LONG GRID TO E-GRID
C   PRGMMR: T.BLACK         ORG: W/NP22     DATE: ??-??-??
C
C ABSTRACT: ROTATES WINDS ON THE LAT/LONG GRID TO THE ETA MODEL GRID
C               (same angles can be used to do reverse function)
C
C PROGRAM HISTORY LOG:
C   ??-??-??  T.BLACK
C   98-06-08  M.BALDWIN - CONVERT TO 2-D CODE
C   01-01-03  T BLACK - MODIFIED FOR MPI
C
C   INPUT ARGUMENT LIST:
C     VLAT     - LATITUDE OF E-GRID V POINTS (DEGREES)
C     VLON     - LONGITUDE OF E-GRID V POINTS (DEGREES)
C
C   OUTPUT ARGUMENT LIST:
C     DRAY     - ROTATION COSINE
C     CRAY     - ROTATION SINE
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C   MACHINE:  IBM RS/6000 SP
C
C***
C*** ROTATE THE LAT-LON WINDS TO/FROM THE E-GRID
C***
C
C    N O T E : INPUT LAT/LONG MUST BE CONVERTED TO RADIANS !!!
C
C----------------------------------------------------------------------
        parameter(D2RAD=1.745329E-2)

                         D I M E N S I O N
     1 VLAT(IM,JM),VLON(IM,JM)
     2,CRAY(IM,JM),DRAY(IM,JM)
C----------------------------------------------------------------------

        ERPHI0=TPH0D*D2RAD

        if (TLM0D .lt. 0) then
        ERLAM0=(TLM0D+360.)*D2RAD
        else
        ERLAM0=TLM0D*D2RAD
        endif

      SPHI0 = SIN(ERPHI0)
      CPHI0 = COS(ERPHI0)
C

	write(6,*) 'TPH0D, TLM0D: ', TPH0D, TLM0D
	write(6,*) 'IM,JM: ', IM,JM

      DO J = 1, JM
      DO I = 1, IM

!mp DANGEROUS TEST (which had no impact)
!	if (VLON(I,J) .lt. 0) VLON(I,J)=VLON(I,J)+360.

        TLAT = VLAT(I,J) * D2RAD
        TLON = VLON(I,J) * D2RAD
        RELM = TLON - ERLAM0
        SRLM = SIN(RELM)
        CRLM = COS(RELM)
        SPH = SIN(TLAT)
        CPH = COS(TLAT)
        CC = CPH * CRLM
        TPH = ASIN(CPHI0 * SPH - SPHI0 * CC)
        RCTPH = 1.0 / COS(TPH)
        CRAY(I,J) = SPHI0 * SRLM * RCTPH
        DRAY(I,J) = (CPHI0 * CPH + SPHI0 * SPH * CRLM) * RCTPH

	if (J .eq. JM) then
	write(6,*) 'I,RELM,CRAY,DRAY: ',I,RELM,CRAY(I,J),DRAY(I,J)
	endif

      ENDDO
      ENDDO
	  end subroutine vecrot_rotlat

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc

	subroutine vecrot_rotlat_new(IM,JM,TPH0D,TLM0D,VLAT,VLON,
     &                     COSALP,SINALP)

       REAL:: VLAT(IM,JM),VLON(IM,JM),COSALP(IM,JM),SINALP(IM,JM)

      PI =3.141592654
      D2R=PI/180.
      R2D=1./D2R
C-----------------------------------------------------------------------
C***
C***  READY TO COMPUTE ROTATION ANGLES.
C***
C***  FORMULAS USE GEODETIC LONGITUDES POSITIVE WEST
C***  SO NEGATE LONGITUDES FROM ETALL (VLON AND VLONI)
C***  AND THE CENTRAL LONGITUDES OF THE GRIDS
C***  SINCE THEY ARRIVE HERE AS NEGATIVE WEST.

!mp	is this sufficiently general?  assumption made that all will be west?

C***
      ERLAM0=-TLM0D*D2R
      ERPHI0=TPH0D*D2R
      ERL0_OUT=ERLAM0/D2R
      CPHI0_OUT=COS(ERPHI0)
      SPHI0_OUT=SIN(ERPHI0)
C***
C***  COMPUTE EARTH ROTATION ANGLES FOR WINDS RELATIVE TO BOTH
C***  THE INPUT AND OUTPUT GRIDS ON THE OUTPUT GRID POINTS.
C***
      DO J=1,JM
      DO I=1,IM
        X=CPHI0_OUT*COS(VLAT(I,J)*D2R)*COS((-VLON(I,J)-ERL0_OUT)*D2R)
     1   +SPHI0_OUT*SIN(VLAT(I,J)*D2R)
        Y=-COS(VLAT(I,J)*D2R)*SIN((-VLON(I,J)-ERL0_OUT)*D2R)
        TVLON=ATAN(Y/X)
        IF(X.LT.0.)TVLON=TVLON+PI
        ARG=SPHI0_OUT*SIN(TVLON)/COS(VLAT(I,J)*D2R)
        ARG=AMIN1(ARG,1.)
        ARG=AMAX1(ARG,-1.)
	ALPHA=ASIN(ARG)
	COSALP(I,J)=COS(ALPHA)
	SINALP(I,J)=SIN(ALPHA)
C
	if (J .eq. JM) then
	write(6,*) 'I,COSALP,SINALP: ',I,COSALP(I,J),SINALP(I,J)
	endif
      ENDDO
      ENDDO

	  end subroutine vecrot_rotlat_new


*
*     program voigts
**
**
*      real    rnewvoigt
*   10 print *,'a,v?'
*        read(*,*), a,v
*        h=rnewvoigt(a,v)
*        print *, a,v,h
*      goto 10
*      end
*
*
*
*
      REAL FUNCTION newVOIGT(A,V)
* Champion Voigt routine in speed and accuracy test by BE+NP 97-11-18
C
C  VOIGT FUNCTION CALCULATION: HUMLICEK'S APPROXIMATION
* The results are normalized to an area of 1/sqrt(pi).
C
      IMPLICIT NONE
      COMPLEX*8 TAV,UAV,W4,V4
      REAL*8    SAV,AA,VV
      REAL      A,V
C
cc      if (A.lt.1.e-8) then
cc        newvoigt=exp(-v*v)
cc      else
      AA=A
      VV=abs(V)
      TAV=CMPLX(AA,-VV)
      SAV=VV+AA
      UAV=TAV*TAV
      IF(SAV.GE.15.D0) THEN
        W4=TAV*0.5641896D0/(0.5D0+UAV)
      ELSE IF(SAV.GE.5.5D0) THEN
        W4=TAV*(1.410474D0+UAV*0.5641896D0)/(0.75D0+UAV*(3.D0+UAV))
      ELSE IF(AA.GE.0.195D0*VV-0.176D0) THEN
        W4=(16.4955D0+TAV*(20.20933D0+TAV*(11.96482D0+
     &     TAV*(3.778987D0+TAV*0.5642236D0))))/(16.4955D0+
     &     TAV*(38.82363D0+TAV*(39.27121D0+TAV*(21.69274D0+
     &     TAV*(6.699398D0+TAV)))))
      ELSE
        W4=TAV*(36183.31D0-UAV*(3321.9905D0-UAV*(1540.787D0-
     &     UAV*(219.0313D0-UAV*(35.76683D0-UAV*(1.320522D0-
     &     UAV*0.56419D0))))))
        V4=(32066.6D0-UAV*(24322.84D0-UAV*(9022.228D0-
     &     UAV*(2186.181D0-UAV*(364.2191D0-
     &     UAV*(61.57037D0-UAV*(1.841439D0-UAV)))))))
        W4=EXP(UAV)-W4/V4
      END IF
      newVOIGT=REAL(W4)
cc      endif
C
      RETURN
      END
*


	SUBROUTINE PD_SUML ( z1, z2, th1, th2, thp1, thp2, cape, cins )
C************************************************************************
C* PD_SUML  ( Z1, Z2, th1, th2, thp1, thp2, cape, cins )		*
C*									*
C* This routine determines positive (CAPE) and negative (CINS) area by	*
C* a trapezoidal approximation.						*
C*									*
C* The area is computed based on 4 cases:				*
C*	1) The entire layer is positive					*
C*	2) The bottom of the layer is positive, top is negative		*
C*	3) The top of the layer is positive, bottom is negative		*
C*	4) The entire layer is negative					*
C*									*
C* For cases 2 & 3 above, the equilibrium level will be determined,	*
C* and the fractional area will be computed.				*
C*									*
C* Input parameters:							*
C* 	Z1		REAL		Z bottom			*
C*	Z2		REAL		Z top				*
C* 	TH1		REAL		Theta (environment) bottom	*
C*	TH2		REAL		Theta (environment) top		*
C* 	THP1		REAL		Theta (parcel) bottom		*
C*	THP2		REAL		Theta (parcel) top		*
C*									*
C* Input and Output parameters:						*
C* 	CAPE		REAL		CAPE value in layer		*
C* 	CINS		REAL		CINS value in layer		*
C*									*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'

	capetmp = 0.
	cinstmp = 0.

	dttop = thp2 - th2
	dtbot = thp1 - th1

	dz = z2 - z1

	IF ( ( dtbot .ge. 0 ) .and. ( dttop .ge. 0 ) ) THEN
C
C*          CASE I . . . bottom and top positive - add in contribution.
C
	    capetmp = ( dttop + dtbot ) * dz / ( th2 + th1 )
	ELSE IF ( dtbot .gt. 0 ) THEN
C
C*          CASE II . . . bottom positive, top negative - hit an
C*          equilibrium level (not necessarily HTEQ, yet); take
C*          partial layer.
C
	    ratio = dtbot / ( dtbot - dttop)
	    zeq = z1 + ( dz * ratio )
	    teq = th1 + ( ( th2 - th1 ) * ratio )
	    capetmp = dtbot * ( zeq - z1 ) / ( th1 + teq )
	    cinstmp = dttop * ( z2 - zeq ) / ( th2 + teq )
	ELSE IF ( dttop .gt. 0 ) THEN
C
C*          CASE III . . . bottom negative, top positive - hit a level
C*          of free convection, ZFC (not necessarily the first);
C*          take partial layer.
C
	    IF (dttop .lt. 0) write(*,*) 'oops'
	    ratio = dttop / ( dttop - dtbot )
            zfc  = z2 - ( dz * ratio )
            tfc  = th2 - ( ( th2 - th1 ) * ratio )
            capetmp = dttop * ( z2 - zfc ) / ( tfc + th2 )
	    cinstmp = dtbot * ( zfc - z1 ) / ( tfc + th1 )
	ELSE
C
C*	    CASE IV . . . . bottom and top negative - CINS
C
	    cinstmp = ( dttop + dtbot ) * dz / ( th2 + th1 )
	END IF
C
	IF ( capetmp .gt. 0 ) THEN
	    cape = cape + (capetmp * GRAVTY )
	END IF
C
	IF ( cinstmp .lt. 0 ) THEN
	    cins = cins + (cinstmp * GRAVTY )
	END IF

	RETURN
	END


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_rot2_turnover
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine uses the generators for three Givens rotations represented
! by 3 real numbers: the real and imaginary parts of a complex cosine
! and a scrictly real sine and performs a turnover.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  Q1, Q2, Q3       REAL(8) arrays of dimension (2)
!                    generators for givens rotations
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_rot2_turnover(Q1,Q2,Q3)

  implicit none

  ! input variables
  real(8), intent(inout) :: Q1(2), Q2(2), Q3(2)

  ! compute variables
  real(8) :: nrm
  real(8) :: a, b
  real(8) :: c1, s1
  real(8) :: c2, s2
  real(8) :: c3, s3
  real(8) :: c4, s4
  real(8) :: c5, s5
  real(8) :: c6, s6

  ! set local variables
  c1 = Q1(1)
  s1 = Q1(2)
  c2 = Q2(1)
  s2 = Q2(2)
  c3 = Q3(1)
  s3 = Q3(2)

  ! compute first rotation
  a = s1*c3 + c1*c2*s3
  b = s2*s3
  call d_rot2_vec2gen(a,b,c4,s4,nrm)

  ! compute second rotation
  a = c1*c3 - s1*c2*s3
  b = nrm
  call d_rot2_unitvec2gen(a,b,c5,s5)

  ! compute third rotation
  ! s5 == 0
  a = c1*s2*s4 + c2*c4
  if (s5.EQ.0d0) then
    b = c5*c1*c4*s2
  ! all other cases
  else
    b = s1*s2/s5
  end if
  call d_rot2_unitvec2gen(a,b,c6,s6)

  ! set output
  Q1(1) = c5
  Q1(2) = s5
  Q2(1) = c6
  Q2(2) = s6
  Q3(1) = c4
  Q3(2) = s4

end subroutine d_rot2_turnover


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2007 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine cross_split(node1,node2,nodem,nelem,lakon,kon,ipkon,
     &     nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &     nodef,idirf,df,cp,r,physcon,numf,set,mi,ider,ttime,time,
     &     iaxial)
!
!     A cross split element(zeta calculation according to Idel'chik)
!     Written by Yavor Dobrev
!     For an explanation of the parameters see tee.f
!
      implicit none
!
      logical identity
!
      character*8 lakon(*)
      character*81 set(*)
!
      integer
     &nelem,nactdog(0:3,*),node1,node2,nodem,numf,kon(*),ipkon(*),
     &ielprop(*),nodef(*),idirf(*),iflag,inv,mi(2),nodem1,nelem1,
     &ichan_num,ider,icase,iaxial,index
!
      real*8 prop(*),v(0:mi(2),*),xflow,f,df(*),kappa,R,Tt1,Tt2,pt1,
     &pt2,cp,physcon(*),km1,kp1,kdkm1,pt2pt1,pt1pt2,pt2pt1_crit,
     &tdkp1,A,A1,A2,calc_residual_cross_split,dh1,dh2,alpha,xflow1,
     &xflow2,zeta_fac,A_s,Ts0,pspt0,pspt2,M1,M2,Ts2,ttime,time
!
      index=ielprop(nelem)
!
      if(iflag.eq.0) then
         identity=.true.
         if(nactdog(2,node1).ne.0)then
            identity=.false.
         elseif(nactdog(2,node2).ne.0)then
            identity=.false.
         elseif(nactdog(1,nodem).ne.0)then
            identity=.false.
         endif
!
      elseif(iflag.eq.1)then
!
         kappa=(cp/(cp-R))
         kp1=kappa+1d0
         km1=kappa-1d0
         kdkm1=kappa/km1
         tdkp1=2.d0/kp1
!
         if(nelem.eq.nint(prop(index+2))) then
            A=prop(index+5)
         elseif(nelem.eq.nint(prop(index+3)))then
            A=prop(index+6)
         elseif(nelem.eq.nint(prop(index+4)))then
            A=prop(index+6)
         endif
!
         pt1=v(2,node1)
         pt2=v(2,node2)
!
         if(pt1.ge.pt2) then
            inv=1
            Tt1=v(0,node1)-physcon(1)
            Tt2=v(0,node2)-physcon(1)
         else
            inv=-1
            pt1=v(2,node2)
            pt2=v(2,node1)
            Tt1=v(0,node2)-physcon(1)
            Tt2=v(0,node1)-physcon(1)
         endif
!
         pt1pt2=pt1/pt2
         pt2pt1=1/pt1pt2
!
         pt2pt1_crit=tdkp1**kdkm1
!
         if(pt2pt1.gt.pt2pt1_crit) then
            xflow=inv*pt1*A*dsqrt(2.d0*kdkm1*pt2pt1**(2.d0/kappa)
     &           *(1.d0-pt2pt1**(1.d0/kdkm1))/r)/dsqrt(Tt1)
         else
            xflow=inv*pt1*A*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/
     &           dsqrt(Tt1)
         endif
!
      elseif(iflag.eq.2)then
!
         numf=6
!
         kappa=(cp/(cp-R))
!
!     setting icase (always adiabatic)
!
         icase=0;
!
!        Inlet conditions are the same for both branches
!
!        Determining the previous element as
!        the incoming mass flow is defined there
         nelem1=nint(prop(index+1))
         nodem1=kon(ipkon(nelem1)+2)
!
!        Inlet conditions
         pt1=v(2,node1)
         Tt1=v(0,node1)-physcon(1)
         xflow1=v(1,nodem1)*iaxial
         A1=prop(index+5)
         dh1=prop(index+9)
!
!        Set the node numbers for the degrees of freedom
         nodef(1)=node1
         nodef(2)=node1
         nodef(3)=nodem1
         nodef(4)=nodem
         nodef(5)=node2
         nodef(6)=node2
!
         idirf(1)=2
         idirf(2)=0
         idirf(3)=1
         idirf(4)=1
         idirf(5)=2
         idirf(6)=0
!
         if(nelem.eq.nint(prop(index+2))) then
            ichan_num=1
!
            Tt2=v(0,node2)
            xflow2=v(1,nodem)*iaxial
            pt2=v(2,node2)
            A2=A1
            A_s=prop(index+6)
            dh2=dh1
            alpha=0
            zeta_fac=prop(index+11)
!
         elseif(nelem.eq.nint(prop(index+3))) then
            ichan_num=2
!
            Tt2=v(0,node2)
            xflow2=v(1,nodem)*iaxial
            pt2=v(2,node2)
            A2=prop(index+6)
            dh2=prop(index+10)
            alpha=prop(index+7)
            zeta_fac=prop(index+12)
!
         elseif(nelem.eq.nint(prop(index+4))) then
            ichan_num=3
!
            Tt2=v(0,node2)
            xflow2=v(1,nodem)*iaxial
            pt2=v(2,node2)
            A1=prop(index+5)
            A2=prop(index+6)
            dh2=prop(index+10)
            alpha=prop(index+8)
            zeta_fac=prop(index+12)
!
         endif
!
         if(ider.eq.0)then
!           Residual
            f=calc_residual_cross_split(pt1,Tt1,xflow1,xflow2,pt2,
     &    Tt2,ichan_num,A1,A2,A_s,dh1,dh2,alpha,zeta_fac,
     &    kappa,R,ider,iflag)
         else
!           Derivatives
            call calc_ider_cross_split(df,pt1,Tt1,xflow1,xflow2,pt2,
     &    Tt2,ichan_num,A1,A2,A_s,dh1,dh2,alpha,zeta_fac,
     &    kappa,R,ider,iflag)
         endif
!
      elseif(iflag.eq.3) then
!
         kappa=(cp/(cp-R))
!
!         setting icase (always adiabatic)
!
         icase=0;
!
!        Inlet conditions are the same for both branches
!
!        Determining the previous element as
!        the incoming mass flow is defined there
!
         nelem1=nint(prop(index+1))
         nodem1=kon(ipkon(nelem1)+2)
!
!        Inlet conditions
!
         pt1=v(2,node1)
         Tt1=v(0,node1)-physcon(1)
         xflow1=v(1,nodem1)*iaxial
         A1=prop(index+5)
         dh1=prop(index+9)
!
         if(nelem.eq.nint(prop(index+2))) then
            ichan_num=1
!
            Tt2=v(0,node2)
            xflow2=v(1,nodem)*iaxial
            pt2=v(2,node2)
            A2=A1
            A_s=prop(index+6)
            dh2=dh1
            alpha=0
            zeta_fac=prop(index+11)
!
         elseif(nelem.eq.nint(prop(index+3))) then
            ichan_num=2
!
            Tt2=v(0,node2)
            xflow2=v(1,nodem)*iaxial
            pt2=v(2,node2)
            A2=prop(index+6)
            dh2=prop(index+10)
            alpha=prop(index+7)
            zeta_fac=prop(index+12)
!
         elseif(nelem.eq.nint(prop(index+4))) then
            ichan_num=3
!
            Tt2=v(0,node2)
            xflow2=v(1,nodem)*iaxial
            pt2=v(2,node2)
            A1=prop(index+5)
            A2=prop(index+6)
            dh2=prop(index+10)
            alpha=prop(index+8)
            zeta_fac=prop(index+12)
!
         endif
!
!        Write the main information about the element
!
!        Flow velocity at inlet
         call ts_calc(xflow1,Tt1,pt1,kappa,r,A1,Ts0,icase)
         pspt0=(Ts0/Tt1)**(kappa/(kappa-1))
!        Calculate Mach numbers
         call machpi(M1,pspt0,kappa,R)
         call ts_calc(xflow2,Tt2,pt2,kappa,r,A2,Ts2,icase)
!        Pressure ratio
         pspt2=(Ts2/Tt2)**(kappa/(kappa-1))
         call machpi(M2,pspt2,kappa,R)
!
         write(1,*) ''
         write(1,55) ' from node ',node1,
     &        ' to node ', node2,':   air massflow rate= ',xflow
!
         write(1,56)'       Inlet node ',node1,':    Tt1= ',Tt1,
     &        ', Ts1= ',Ts0,', Pt1= ',Pt1,
     &        ', M1= ',M1
         write(1,*)'             Element ',nelem,lakon(nelem)
     &        ,', Branch ',ichan_num
!
 55      format(1x,a,i6,a,i6,a,e11.4,a)
 56      format(1x,a,i6,a,e11.4,a,e11.4,a,e11.4,a,e11.4)
!
!     Set ider to calculate the residual
         ider=0
!
!     Calculate the element one last time with enabled output
         f=calc_residual_cross_split(pt1,Tt1,xflow1,xflow2,pt2,
     &        Tt2,ichan_num,A1,A2,A_s,dh1,dh2,alpha,zeta_fac,
     &        kappa,R,ider,iflag)
!
         write(1,56)'      Outlet node ',node2,':   Tt2= ',Tt2,
     &        ' , Ts2= ',Ts2,' , Pt2= ',Pt2,
     &        ', M2= ',M2
!
      endif
!
      xflow=xflow/iaxial
      df(3)=df(3)*iaxial
      df(4)=df(4)*iaxial
!
      return
      end