Module MathematicsQP

! here we collect mathematical routines using multi precision software

! load modules
Use Control
! load modules

! interfaces
 Interface EigenSystemQP
  Module Procedure ComplexEigenSystem_DP, RealEigenSystem_DP   &
      & , ComplexEigenSystem_QP, RealEigenSystem_QP            &
      & , ComplexEigenSystem_DP1
 End Interface
! interfaces

! private variables
 Real(dp), Parameter, Private :: MinimalPrecision = 1.e-25_dp
 Private :: ComplexEigenSystem_DP, RealEigenSystem_DP   &
      & , ComplexEigenSystem_QP, RealEigenSystem_QP,Tred2a_QP &
      & , ComplexEigenSystem_DP1, Tqli_QP, Pythag_QP    &
      & , HTRIBK_QP, HTRIDI_QP
! private variables

 Real(qp), Private :: Zero=0._qp, One=1._qp, PointTwo=0.2_qp, PointFive=0.5_qp &
    &  , Hundred=1.e2_qp
 Complex(qp), Private :: IOne = (0._qp,1._qp)

Contains

 Real(qp) Function ArgQP(z)
 Implicit None

 Complex(qp), Intent(in) :: z
 Real(qp) :: x,y

  If (Abs(z).Eq.Zero) Then
   ArgQP = Zero
  Else
   x = Real(z)
   y = Aimag(z)

   ArgQP = Atan2(y,x)
  Endif

 End Function ArgQP

 Subroutine ComplexEigenSystem_DP(Matrix, EigenValues, EigenVectors, kont, test)
 !---------------------------------------------------------------------
 ! Subroutine for diagonalization of complex hermitian matrices, based on the
 ! Householder algorithm. Is a portation of  EISCH1 to F90
 ! Input:
 !  Matrix ..... n times n matrix
 ! Output
 !  EigenValues ..... n sorted EigenValues: |m_1| < |m_2| < .. < |m_n|
 !  EigenVectors .... n times n matrix with the eigenvectors
 ! written by Werner Porod, 10.11.2000
 ! 19.07.02: adapting to multi precision
 !---------------------------------------------------------------------
 Implicit None
  !-------
  ! input
  !-------
  Complex(dp), Intent(in) :: Matrix(:,:)
  !--------
  ! output
  !--------
  Integer, Intent(inout) :: kont
  Complex(dp), Intent(out) :: EigenVectors(:,:)
  Real(dp), Intent(out) :: EigenValues(:), test(:)

  !-----------------
  ! local variables
  !-----------------
  Integer :: i1,N1,N2,N3, i2, i3, i4, nrot
  Real(qp) :: AbsAi
  Real(qp), Allocatable :: AR(:,:),AI(:,:), WR(:), ZR(:,:),  WORK(:) &
          & , ZR_in(:,:), testR(:,:), Ar2(:,:), Ai2(:,:)
  Complex(qp), Allocatable ::  ctest(:,:), Rot(:,:)

  Iname = Iname + 1
  NameOfUnit(Iname) = 'ComplexEigenSystem_DP'

  kont = 0

  N1 = Size(Matrix, Dim=1)
  N2 = Size(EigenValues)
  N3 = Size(EigenVectors, Dim=1)
  If ((N1.Ne.N2).Or.(N1.Ne.N3)) Then
   Write (ErrCan,*) 'Error in Subroutine '//NameOfUnit(Iname)
   Write (ErrCan,*) 'Dimensions to not match: ',N1,N2,N3
   If (ErrorLevel.Ge.-1) Call TerminateProgram
   kont = -1001
   Call AddError(1001)
   Return
  End If

  Allocate(AR(N1,N1))
  Allocate(AI(N1,N1))

  AbsAi = Zero
  AR = Real( Matrix, qp)
  Ai = Aimag( Matrix )
  AbsAi = Sum( Abs( Ai ) )

  !--------------------------------------------------------------------------
  ! check first whether the matrix is really complex
  ! if not, I use the only real diagonalization because it is more accurate
  !--------------------------------------------------------------------------
  If (AbsAi .Eq. Zero) Then ! real matrix
   Allocate(WR(N1))
   Allocate(Work(N1))
   Allocate(ZR_in(N1,N1))
   Allocate(testR(N1,N1))
   Do i1=1,N1
    Do i2=1,N1
     ZR_in(i1,i2) = AR(i1,i2)
     AR(i1,i2) = Zero
    End Do
    wr(i1) = Zero
   End Do
   Call JacobiQP(ZR_in, n1, n1, wr, ar, nrot)

   Do n2=1,n1-1
    Do n3=n2+1,n1
     If (Abs(wr(n2)).Gt.Abs(wr(n3))) Then
      work(1) = wr(n2)
      wr(n2) = wr(n3)
      wr(n3) = work(1)
      Do i1=1,n1
       work(1) = ar(i1,n2)
       ar(i1,n2) = ar(i1,n3)
       ar(i1,n3) = work(1)
      End Do
     End If
    End Do
   End Do

   Do i1=1,N1
    EigenValues(i1) = WR(i1)
    Do i2=1,n2
     EigenVectors(i1,i2) = AR(i2,i1)
    End Do
   End Do
   ! now  a test

   ZR_in = Real( Matrix, qp )

   test = 0._dp
   Do i1=1,n1
    Do i2=1,n1
     testR(i1,i2) = Zero
     Do i3=1,n1
      Do i4=1,n1
       testR(i1,i2) = testR(i1,i2) &
          & + Ar(i3,i1)* ZR_in(i3,i4) *  Ar(i4,i2)
      End Do
     End Do
     If (i1.Eq.i2) Then
      If ( test(1).Lt.Abs( testR(i1,i2) ) ) test(1) = Abs( testR(i1,i2) )
     Else
      If ( test(2).Lt.Abs( testR(i1,i2) ) ) test(2) = Abs( testR(i1,i2) )
     End If
    End Do
   End Do

   If (test(1).Gt.0._dp) Then
    If ( (test(2)/test(1)).Gt.MinimalPrecision) Then
     kont = -1002
     Call AddError(1002)
    End If
   End If

   Deallocate( testR )

  Else ! complex matrix

   Allocate(ZR(2*N1,2*N1))
   Allocate(ZR_in(2*N1,2*N1))
   Allocate(WR(2*N1))
   Allocate(Work(2*N1))
   Allocate(CTest(N1,N1))
   Allocate(Rot(N1,N1))
   Allocate(ar2(N1,N1))
   Allocate(ai2(N1,N1))

   Do i1=1,n1
    Do i2=1,n1
     Ar2(i1,i2) = Zero
     Ai2(i1,i2) = Zero
     Do i3=1,n1
      Ar2(i1,i2) = ar2(i1,i2) + ar(i3,i1)*ar(i3,i2) + ai(i3,i1)*ai(i3,i2)
      Ai2(i1,i2) = ai2(i1,i2) + ar(i3,i1)*ai(i3,i2) - ai(i3,i1)*ar(i3,i2)
     End Do
    End Do
   End Do

   ZR_in(1:N1,1:N1) = AR2
   ZR_in(N1+1:2*N1,N1+1:2*N1) = AR2
   ZR_in(N1+1:2*N1,1:N1) = AI2
   Do i1=1,n1
    Do i2=1,n1
     ZR_in(i1,N1+i2) = - AI2(i1,i2)
    End Do
   End Do

   Call JacobiQP(ZR_in, 2*n1, 2*n1, wr, zr, nrot)

   Do n2=1,2*n1-1
    Do n3=n2+1,2*n1
     If (wr(n2).Gt.wr(n3)) Then
      work(1) = wr(n2)
      wr(n2) = wr(n3)
      wr(n3) = work(1)
      work = zr(:,n2)
      zr(:,n2) = zr(:,n3)
      zr(:,n3) = work
     End If
    End Do
   End Do

   Do i1=1,n1
    eigenvalues(i1) = Sqrt( wr(2*i1-1) )
    Do i2=1,n1
     eigenvectors(i1,i2) =  zr(i2,2*i1-1) - Ione * zr(n1+i2,2*i1-1)
     rot(i2,i1) =  zr(i2,2*i1-1) + IOne * zr(n1+i2,2*i1-1)
    End Do
   End Do

   test = 0._dp
   Do i1=1,n1
    Do i2=1,n1
     Ctest(i1,i2) = Zero
     Do i3=1,n1
      Do i4=1,n1
       Ctest(i1,i2) = Ctest(i1,i2) &
          & + Conjg( rot(i3,i1) )* (ar2(i3,i4)+Ione*ai2(i3,i4)) * rot(i4,i2)
      End Do
     End Do
     If (i1.Eq.i2) Then
      If ( test(1).Lt.Abs( Ctest(i1,i2) ) ) test(1) = Abs( Ctest(i1,i2) )
     Else
      If ( test(2).Lt.Abs( Ctest(i1,i2) ) ) test(2) = Abs( Ctest(i1,i2) )
     End If
    End Do
   End Do

   If (test(1).Gt.0._dp) Then
    If ( (test(2)/test(1)).Gt.MinimalPrecision) Then
     kont = -1002
     Call AddError(1002)
    End If
   End If

   Deallocate(ZR, Ctest, Rot, ar2, ai2)

  End If ! decision whether real or complex matrix

  Deallocate(AR,AI,WR,Work, ZR_in)

  Iname = Iname - 1

 End Subroutine ComplexEigenSystem_DP

 Subroutine ComplexEigenSystem_QP(Matrix, EigenValues, EigenVectors, kont)
 !---------------------------------------------------------------------
 ! Subroutine for diagonalization of complex hermitian matrices, based on the
 ! Householder algorithm. Is a portation of  EISCH1 to F90
 ! Input:
 !  Matrix ..... n times n matrix
 ! Output
 !  EigenValues ..... n sorted EigenValues: |m_1| < |m_2| < .. < |m_n|
 !  EigenVectors .... n times n matrix with the eigenvectors
 ! written by Werner Porod, 10.11.2000
 ! 19.07.02: adapting to multi precision
 !---------------------------------------------------------------------
 Implicit None
  !-------
  ! input
  !-------
  Complex(qp), Intent(in) :: Matrix(:,:)
  !--------
  ! output
  !--------
  Complex(qp), Intent(out) :: EigenVectors(:,:)
  Real(qp), Intent(out) :: EigenValues(:)
  Integer, Intent(inout) :: kont

  !-----------------
  ! local variables
  !-----------------
  Integer :: i1,N1,N2,N3, i2, i3, i4, nrot
  Real(qp) :: AbsAi, AbsTest
  Real(qp), Allocatable :: AR(:,:),AI(:,:), WR(:), ZR(:,:),  WORK(:) &
          & , ZR_in(:,:), testR(:,:)
  Complex(qp), Allocatable ::  test(:,:)

  Iname = Iname + 1
  NameOfUnit(Iname) = 'ComplexEigenSystem_QP'

  kont = 0

  N1 = Size(Matrix, Dim=1)
  N2 = Size(EigenValues)
  N3 = Size(EigenVectors, Dim=1)
  If ((N1.Ne.N2).Or.(N1.Ne.N3)) Then
   Write (ErrCan,*) 'Error in Subroutine '//NameOfUnit(Iname)
   Write (ErrCan,*) 'Dimensions to not match: ',N1,N2,N3
   If (ErrorLevel.Ge.-1) Call TerminateProgram
   kont = -1003
   Call AddError(1003)
   Return
  End If

  Allocate(AR(N1,N1))
  Allocate(AI(N1,N1))
  Allocate(Test(N1,N1))

  AbsAi = Zero
  AR = Real( Matrix, qp)
  Ai = Aimag( Matrix )
  AbsAi = Sum( Abs( Ai ) )

  !--------------------------------------------------------------------------
  ! check first whether the matrix is really complex
  ! if not, I use the only real diagonalization because it is more accurate
  !--------------------------------------------------------------------------
  If (AbsAi .Eq. Zero) Then ! real matrix

   Allocate(WR(N1))
   Allocate(Work(N1))
   Allocate(ZR_in(N1,N1))
   Allocate(testR(N1,N1))
   ZR_in = AR
   Call JacobiQP(ZR_in, n1, n1, wr, ar, nrot)

   Do n2=1,n1-1
    Do n3=n2+1,n1
     If (Abs(wr(n2)).Gt.Abs(wr(n3))) Then
      work(1) = wr(n2)
      wr(n2) = wr(n3)
      wr(n3) = work(1)
      work = ar(:,n2)
      ar(:,n2) = ar(:,n3)
      ar(:,n3) = work
     End If
    End Do
   End Do

   EigenValues = WR
   Do i1=1,N1
    Do i2=1,n2
     EigenVectors(i1,i2) = AR(i2,i1)
    End Do
   End Do

   Do i1=1,n1
    Do i2=1,n1
     testR(i1,i2) = Zero
     Do i3=1,n1
      Do i4=1,n1
       testR(i1,i2) = testR(i1,i2) &
          & + Ar(i3,i1)* ZR_in(i3,i4) *  AR(i4,i2)
      End Do
     End Do
     AbsTest = absTest + Abs( testR(i1,i2) )
    End Do
   End Do
   AbsTest = AbsTest / EigenValues(n1)
   If (Abstest.Gt.1.e-36) Then
     Write(ErrCan,*) "Problem for real diagonlization in"//NameOfUnit(Iname)
     Write(ErrCan,*) "relative precision is ",AbsTest
     Write(ErrCan,*) " "
     kont = -1004
     Call AddError(1004)
   End If

   Deallocate( testR )
  Else ! complex matrix

   Allocate(ZR(2*N1,2*N1))
   Allocate(ZR_in(2*N1,2*N1))
   Allocate(WR(2*N1))
   Allocate(Work(2*N1))

   ZR_in(1:N1,1:N1) = AR
   ZR_in(N1+1:2*N1,N1+1:2*N1) = AR
   ZR_in(N1+1:2*N1,1:N1) = AI
   Do i1=1,n1
    Do i2=1,n1
     ZR_in(i1,N1+i2) = - AI(i1,i2)
    End Do
   End Do

   Call JacobiQP(ZR_in, 2*n1, 2*n1, wr, zr, nrot)

   Do n2=1,2*n1-1
    Do n3=n2+1,2*n1
     If (wr(n2).Gt.wr(n3)) Then
      work(1) = wr(n2)
      wr(n2) = wr(n3)
      wr(n3) = work(1)
      work = zr(:,n2)
      zr(:,n2) = zr(:,n3)
      zr(:,n3) = work
     End If
    End Do
   End Do

   Do i1=1,n1
    eigenvalues(i1) = wr(2*i1-1)
    Do i2=1,n1
     eigenvectors(i1,i2) =  zr(i2,2*i1-1) - IOne * zr(n1+i2,2*i1-1)
    End Do
   End Do

   Do i1=2,n1
    Do i2=1,i1-1
     work(1) = eigenvectors(i1,i2)
     eigenvectors(i1,i2) = eigenvectors(i2,i1)
     eigenvectors(i2,i1) = work(1)
    End Do
   End Do

   Do i1=1,n1
    Do i2=1,n1
     test(i1,i2) = Zero
     Do i3=1,n1
      Do i4=1,n1
       test(i1,i2) = test(i1,i2) &
          & + Eigenvectors(i1,i3)* Matrix(i3,i4)* Conjg( EigenVectors(i2,i4))
      End Do
     End Do
    End Do
   End Do

   Deallocate(ZR)

  End If ! decision whether real or complex matrix

  Deallocate(AR,AI,WR,Work, ZR_in)

  Iname = Iname - 1

 End Subroutine ComplexEigenSystem_QP

 Subroutine ComplexEigenSystem_DP1(Matrix, EigenValues, EigenVectors, kont, test, ii)
 !---------------------------------------------------------------------
 ! Subroutine for diagonalization of complex hermitian matrices, based on the
 ! Householder algorithm. Is a portation of  EISCH1 to F90
 ! Input:
 !  Matrix ..... n times n matrix
 ! Output
 !  EigenValues ..... n sorted EigenValues: |m_1| < |m_2| < .. < |m_n|
 !  EigenVectors .... n times n matrix with the eigenvectors
 ! written by Werner Porod, 10.11.2000
 !---------------------------------------------------------------------
 Implicit None
  !-------
  ! input
  !-------
  Complex(Dp), Intent(in) :: Matrix(:,:)
  !--------
  ! output
  !--------
  Complex(Dp), Intent(out) :: EigenVectors(:,:)
  Real(Dp), Intent(out) :: EigenValues(:), test(:)
  Integer, Intent(in) :: ii
  Integer, Intent(inout) :: kont

  !-----------------
  ! local variables
  !-----------------
  Integer :: N1,N2,N3
  Real(qp), Allocatable :: AR(:,:),AI(:,:), WR(:), ZR(:,:),  WORK(:)  &
    & , work2(:,:), ZI(:,:)
  Complex(qp), Allocatable :: Ctest(:,:), Ctest2(:,:), CtestA(:,:)
  Logical :: l_complex = .False.

  Iname = Iname + 1
  NameOfUnit(Iname) = 'ComplexEigenSystem_DP1'

  If (ii.Eq.1) Write(*,*) "ComplexEigenSystem_DP1"
  N1 = Size(Matrix, Dim=1)
  N2 = Size(EigenValues)
  N3 = Size(EigenVectors, Dim=1)
  If ((N1.Ne.N2).Or.(N1.Ne.N3)) Then
   Write(ErrCan,*) 'Error in Subroutine '//NameOfUnit(Iname)
   Write(ErrCan,*) 'Dimensions to not match: ',N1,N2,N3
   If (ErrorLevel.Ge.-1) Call TerminateProgram
   kont = -13
   Call AddError(13)
   Iname = Iname - 1
   Return
  End If

  If (Is_NaN(Real(Matrix,dp)).or.Is_NaN(Aimag(Matrix))) Then !
   Write(ErrCan,*) 'Error in Subroutine '//NameOfUnit(Iname)
   Write(ErrCan,*) 'matrix contains NaN'
   If (ErrorLevel.Ge.-1) Call TerminateProgram
   kont = -31
   Call AddError(31)
   Iname = Iname - 1
   Return
  End If

  Allocate(AR(N1,N1))
  Allocate(AI(N1,N1))
  Allocate(Ctest(N1,N1))
  Allocate(Ctest2(N1,N1))
  Allocate(CtestA(N1,N1))

  AR = Real( Matrix,qp )
  AI = Aimag( Matrix )

  Eigenvectors = ZeroC
  Eigenvalues = 0._dp
  test = 0._dp
  !--------------------------------------------------------------------------
  ! check first whether the matrix is really complex
  ! if not, I use the only real diagonalization because it is more accurate
  !--------------------------------------------------------------------------
  If (Maxval( Abs(AI) ).Eq.0._qp) Then ! real matrix

   Allocate(WR(N1))
   Allocate(Work(N1))

   Call Tred2A_QP(AR, WR, Work)
   Call TQLi_QP(WR,WORK,AR,kont)

   Do n2=1,n1-1
    Do n3=n2+1,n1
     If (wr(n2).Gt.wr(n3)) Then
      work(1) = wr(n2)
      wr(n2) = wr(n3)
      wr(n3) = work(1)
      work = ar(:,n2)
      ar(:,n2) = ar(:,n3)
      ar(:,n3) = work
     End If
    End Do
   End Do

   EigenValues = WR
   Ctest = Ar
   EigenVectors = Transpose(AR)

  Else ! complex matrix
   l_complex = .True.

   Allocate(ZR(N1,N1))
   Allocate(ZI(N1,N1))
   Allocate(WR(N1))
   Allocate(Work(N1))
   Allocate(Work2(2,N1))

   Call HTRIDI_QP(AR, AI, WR, Work, WORK2)
   ZR = 0._qp
   Do n2=1,n1
    ZR(n2,n2) = 1._qp
   End Do
   Call TQLi_QP(WR,WORK,ZR,kont)
   If(KONT/=0) Then
    Iname = Iname - 1
    Deallocate(AR,AI,WR,Work,Ctest)
    Deallocate(ZR, zi, work2)
    Return
   End If
   Call HTRIBK_QP(AR, AI, WORK2, ZR, ZI)

   Do n2=1,n1-1
    Do n3=n2+1,n1
     If (wr(n2).Gt.wr(n3)) Then
      work(1) = wr(n2)
      wr(n2) = wr(n3)
      wr(n3) = work(1)
      work = zr(:,n2)
      zr(:,n2) = zr(:,n3)
      zr(:,n3) = work
      work = zi(:,n2)
      zi(:,n2) = zi(:,n3)
      zi(:,n3) = work
     End If
    End Do
   End Do

   eigenvalues = wr
   eigenvectors = Cmplx(zr,zi, dp)

   Ctest = Cmplx(zr,zi, qp)
   CtestA = Transpose(Ctest)
   CtestA = Conjg(CtestA)
   Eigenvectors = CtestA

   Deallocate(ZR, zi, work2)

  End If ! decision whether real or complex matrix

  !----------------------------------
  ! test of diagonalisation
  !----------------------------------
  Ctest2 = Matmul(Matrix, Ctest )
  ! Ctest^\dagger = Transpose(Cmplx(zr,-zi, qp))
  Ctest = Matmul( CtestA, Ctest2 )

  test = 0._qp
  Do n2=1,n1
   Do n3=1,n1
    If (n2.Eq.n3) Then
     test(1) = Max(test(1), Abs( Ctest(n2,n3) ) )
    Else
     test(2) = Max(test(2), Abs( Ctest(n2,n3) ) )
    End If
   End Do
  End Do
  If (test(1).Gt.0._dp) Then
   If (l_complex) Then
    If ( (test(2)/test(1)).Gt.1.e5_qp*MinimalPrecision) then
     kont = -14
     Call AddError(14)
    End If
   Else
    If ( (test(2)/test(1)).Gt.MinimalPrecision) then
     kont = -14
     Call AddError(14)
    End If
   End If
  End If

  Deallocate(AR,AI,WR,Work,Ctest,Ctest2,CtestA)

  Iname = Iname - 1

 End Subroutine ComplexEigenSystem_DP1

 Subroutine JacobiQP(a,n,np,d,v,nrot)
 Implicit None
  Integer :: n, np, nrot
  Real(qp) :: a(np,np),d(np),v(np,np)
  Integer, Parameter :: NMAX=500
  Integer :: i, ip, iq, j
  Real(qp) :: c, g, h, s, sm, t, tau, theta, tresh, b(NMAX), z(NMAX)

  Do ip=1,n
    Do iq=1,n
      v(ip,iq)=Zero
    End Do
    v(ip,ip)=One
  End Do
  Do ip=1,n
    b(ip)=a(ip,ip)
    d(ip)=b(ip)
    z(ip)=Zero
  End Do
  nrot=0
  Do i=1,50
    sm=Zero
    Do ip=1,n-1
      Do iq=ip+1,n
       sm=sm+Abs(a(ip,iq))
      End Do
    End Do
    If(sm.Eq.Zero)Return
    If(i.Lt.4)Then
      tresh=PointTwo*sm/n**2
    Else
      tresh=Zero
    Endif
    Do ip=1,n-1
     Do iq=ip+1,n
      g=Hundred*Abs(a(ip,iq))
      If(       (i.Gt.4).And.(Abs(d(ip))+g.Eq.Abs(d(ip)))   &
        & .And.(Abs(d(iq))+g.Eq.Abs(d(iq))))Then
        a(ip,iq)=Zero
      Else If(Abs(a(ip,iq)).Gt.tresh)Then
        h=d(iq)-d(ip)
        If(Abs(h)+g.Eq.Abs(h))Then
          t=a(ip,iq)/h
        Else
         theta=PointFive*h/a(ip,iq)
         t=One/(Abs(theta)+Sqrt(One+theta**2))
         If(theta.Lt.Zero)t=-t
        Endif
        c=One/Sqrt(One+t**2)
        s=t*c
        tau=s/(One+c)
        h=t*a(ip,iq)
        z(ip)=z(ip)-h
        z(iq)=z(iq)+h
        d(ip)=d(ip)-h
        d(iq)=d(iq)+h
        a(ip,iq)=Zero
        Do j=1,ip-1
          g=a(j,ip)
          h=a(j,iq)
          a(j,ip)=g-s*(h+g*tau)
          a(j,iq)=h+s*(g-h*tau)
        End Do
        Do j=ip+1,iq-1
          g=a(ip,j)
          h=a(j,iq)
          a(ip,j)=g-s*(h+g*tau)
          a(j,iq)=h+s*(g-h*tau)
        End Do
        Do j=iq+1,n
          g=a(ip,j)
          h=a(iq,j)
          a(ip,j)=g-s*(h+g*tau)
          a(iq,j)=h+s*(g-h*tau)
        End Do
        Do j=1,n
          g=v(j,ip)
          h=v(j,iq)
          v(j,ip)=g-s*(h+g*tau)
          v(j,iq)=h+s*(g-h*tau)
        End Do
        nrot=nrot+1
      Endif
     End Do
    End Do
    Do ip=1,n
      b(ip)=b(ip)+z(ip)
      d(ip)=b(ip)
      z(ip)=Zero
    End Do
  End Do
  Write(ErrCan,*) 'too many iterations in JacobiQP'

 End Subroutine JacobiQP

 Function Pythag_QP(a,b)
  Implicit None
  Real(qp), Intent(IN) :: a,b
  Real(qp) :: Pythag_QP
  Real(qp) :: absa, absb
  absa=Abs(a)
  absb=Abs(b)

  If (absa > absb) Then
    Pythag_QP=absa*Sqrt(One+(absb/absa)**2)
  Else
    If (absb == Zero) Then
      Pythag_QP= Zero
    Else
      Pythag_QP=absb*Sqrt(One+(absa/absb)**2)
    End If
  End If
 End Function Pythag_QP

 Function outerprod_QP(a,b)
  Real(qp), Dimension(:), Intent(IN) :: a,b
  Real(qp), Dimension(Size(a),Size(b)) :: outerprod_QP
   outerprod_QP = Spread(a,dim=2,ncopies=Size(b))  &
               & * Spread(b,dim=1,ncopies=Size(a))
 End Function outerprod_QP

 Subroutine RealEigenSystem_DP(Matrix,EigenValues,EigenVectors,kont, test)
 !---------------------------------------------------------------------
 ! Subroutine for diagonalization of real symmetric matrices, based on the
 ! Householder algorithm. Is a portation of  EISRS1 to F90
 ! Input:
 !  Matrix ..... n times n matrix
 ! Output
 !  EigenValues ..... n sorted EigenValues: |m_1| < |m_2| < .. < |m_n|
 !  EigenVectors .... n times n matrix with the eigenvectors
 ! written by Werner Porod, 11.11.2000
 !---------------------------------------------------------------------
 Implicit None
  Real(dp), Intent(in) :: Matrix(:,:)
  Real(dp), Intent(out) :: EigenVectors(:,:), EigenValues(:), test(2)
  Integer, Intent(inout) :: kont

  Integer :: N1,N2,N3, i1, i2, i3, i4, n4
  Real(qp), Allocatable :: AR(:,:), WR(:), WORK(:), testR(:,:), work2(:,:)

  Iname = Iname + 1
  NameOfUnit(Iname) = 'RealEigenSystem_DP'

  kont = 0

  N1 = Size(Matrix, Dim=1)
  N2 = Size(EigenValues)
  N3 = Size(EigenVectors, Dim=1)
  If ((N1.Ne.N2).Or.(N1.Ne.N3)) Then
   Write (ErrCan,*) 'Error in Subroutine '//NameOfUnit(Iname)
   Write (ErrCan,*) 'Dimensions to not match: ',N1,N2,N3
   If (ErrorLevel.Ge.-1) Call TerminateProgram
   kont = -1005
   Call AddError(1005)
   Return
  End If

  Allocate(AR(N1,N1))
  Allocate(testR(N1,N1))
  Allocate(WR(N1))
  Allocate(Work(N1))
  Allocate(Work2(N1,N1))

  Wr = Zero
  Work = Zero
  AR = Zero
  AR = Real( Matrix, qp )

  Call Tred2A_QP(AR, WR, Work)
  Call TQLi_QP(WR,WORK,AR,kont)

  Do n2=1,n1-1
   Do n3=n2+1,n1
    If (wr(n2).Gt.wr(n3)) Then
     work(1) = wr(n2)
     wr(n2) = wr(n3)
     wr(n3) = work(1)
     Do n4=1,n1
      work(n4) = ar(n4,n2)
      ar(n4,n2) = ar(n4,n3)
      ar(n4,n3) = work(n4)
     End Do
    End If
   End Do
  End Do

  Do n2=1,n1
   EigenValues(n2) = WR(n2)
   Do n3=1,n1
    EigenVectors(n2,n3) = AR(n3,n2)
   End Do
  End Do

  work2 = Real( Matrix, qp)

   test = 0._dp
   Do i1=1,n1
    Do i2=1,n1
     testR(i1,i2) = Zero
     Do i3=1,n1
      Do i4=1,n1
       testR(i1,i2) = testR(i1,i2) &
          & + ar(i3,i1)* work2(i3,i4) *  ar(i4,i2)
      End Do
     End Do
     If (i1.Eq.i2) Then
      If ( test(1).Lt.Abs( testR(i1,i2) ) ) test(1) = Abs( testR(i1,i2) )
     Else
      If ( test(2).Lt.Abs( testR(i1,i2) ) ) test(2) = Abs( testR(i1,i2) )
     End If
    End Do
   End Do

  If (test(1).Gt.0._dp) Then
   If ( (test(2)/test(1)).Gt.MinimalPrecision) Then
    kont = -1006
    Call AddError(1006)
   End If
  End If

  Deallocate(AR,WR,Work,testR,work2)

  Iname = Iname - 1

 End Subroutine RealEigenSystem_DP

 Subroutine RealEigenSystem_QP(Matrix,EigenValues,EigenVectors,kont)
 !---------------------------------------------------------------------
 ! Subroutine for diagonalization of real symmetric matrices, based on the
 ! Householder algorithm. Is a portation of  EISRS1 to F90
 ! Input:
 !  Matrix ..... n times n matrix
 ! Output
 !  EigenValues ..... n sorted EigenValues: |m_1| < |m_2| < .. < |m_n|
 !  EigenVectors .... n times n matrix with the eigenvectors
 ! written by Werner Porod, 11.11.2000
 !---------------------------------------------------------------------
 Implicit None
  Real(qp), Intent(in) :: Matrix(:,:)
  Real(qp), Intent(out) :: EigenVectors(:,:), EigenValues(:)
  Integer, Intent(inout) :: kont

  Integer :: N1,N2,N3, nrot
  Real(qp), Allocatable :: AR(:,:), WR(:), WORK(:,:)

  Iname = Iname + 1
  NameOfUnit(Iname) = 'RealEigenSystem_QP'

  kont = 0

  N1 = Size(Matrix, Dim=1)
  N2 = Size(EigenValues)
  N3 = Size(EigenVectors, Dim=1)
  If ((N1.Ne.N2).Or.(N1.Ne.N3)) Then
   Write (ErrCan,*) 'Error in Subroutine '//NameOfUnit(Iname)
   Write (ErrCan,*) 'Dimensions to not match: ',N1,N2,N3
   If (ErrorLevel.Ge.-1) Call TerminateProgram
   kont = -1007
   Call AddError(1007)
   Return
  End If

  Allocate(AR(N1,N1))
  Allocate(WR(N1))
  Allocate(Work(N1,N1))

  Work = Matrix

  Call JacobiQP(Work, n1, n1, wr, ar, nrot)

  Do n2=1,n1-1
   Do n3=n2+1,n1
    If (wr(n2).Gt.wr(n3)) Then
     work(1,1) = wr(n2)
     wr(n2) = wr(n3)
     wr(n3) = work(1,1)
     work(:,1) = ar(:,n2)
     ar(:,n2) = ar(:,n3)
     ar(:,n3) = work(:,1)
    End If
   End Do
  End Do

  EigenValues = WR
  EigenVectors = Transpose(AR)

  Deallocate(AR,WR,Work)

  Iname = Iname - 1

 End Subroutine RealEigenSystem_QP

 Subroutine tred2A_QP(a,d,e,novectors)

 Implicit None
  Real(qp), Dimension(:,:), Intent(INOUT) :: a
  Real(qp), Dimension(:), Intent(OUT) :: d, e
  Logical, Optional, Intent(IN) :: novectors

  Integer :: i, j, l, n
  Real(qp) :: f, g, h, hh, scale
  Real(qp), Dimension(Size(a,1)) :: gg
  Logical, Save :: yesvec=.True.

  n = Size(a,1)

  If ((n.Ne.Size(a,2)).Or.(n.Ne.Size(d)).Or.(n.Ne.Size(e)) ) Then
   Write(ErrCan,*) "Error in tred2A_QP",n,Size(a,2),Size(d),Size(e)
   If (ErrorLevel.Gt.-2) Call TerminateProgram
  End If

  If (Present(novectors)) yesvec=.Not. novectors

  Do i=n,2,-1
    l=i-1
    h=0.0_qp
    If (l > 1) Then
      scale=Sum(Abs(a(i,1:l)))
      If (scale == 0._qp) Then
        e(i)=a(i,l)
      Else
        a(i,1:l)=a(i,1:l)/scale
        h=Sum(a(i,1:l)**2)
        f=a(i,l)
        g=-Sign(Sqrt(h),f)
        e(i)=scale*g
        h=h-f*g
        a(i,l)=f-g
        If (yesvec) a(1:l,i)=a(i,1:l)/h
        Do j=1,l
          e(j)=(Dot_product(a(j,1:j),a(i,1:j)) &
          +Dot_product(a(j+1:l,j),a(i,j+1:l)))/h
        End Do
        f=Dot_product(e(1:l),a(i,1:l))
        hh=f/(h+h)
        e(1:l)=e(1:l)-hh*a(i,1:l)
        Do j=1,l
          a(j,1:j)=a(j,1:j)-a(i,j)*e(1:j)-e(j)*a(i,1:j)
        End Do
      End If
    Else
      e(i)=a(i,l)
    End If
    d(i)=h
  End Do

  If (yesvec) d(1)=0.0_qp
  e(1)=0.0_qp
  Do i=1,n
    If (yesvec) Then
      l=i-1
      If (d(i) /= 0.0_qp) Then
        gg(1:l)=Matmul(a(i,1:l),a(1:l,1:l))
        a(1:l,1:l)=a(1:l,1:l)-outerprod_QP(a(1:l,i),gg(1:l))
      End If
      d(i)=a(i,i)
      a(i,i)=1.0_qp
      If (i.Gt.1) Then
       a(i,1:l)=0.0_qp
       a(1:l,i)=0.0_qp
      End If
    Else
      d(i)=a(i,i)
    End If
  End Do

 End Subroutine tred2A_QP

 Subroutine tqli_QP(d,e,z,kont)

 Implicit None
  Integer, Intent(inout) :: kont
  Real(qp), Dimension(:), Intent(INOUT) :: d,e
  Real(qp), Dimension(:,:), Optional, Intent(INOUT) :: z
  Integer :: i,iter,l,m,n
  Real(qp) :: b,c,dd,f,g,p,r,s
  Real(qp), Dimension(Size(e)) :: ff

  n = Size(d)
  kont = 0
  If (n.Ne.Size(e)) Then
   Write(ErrCan,*) "Error in tqli_QP",n,Size(e)
   If (ErrorLevel.Gt.-2) Call TerminateProgram
   kont = -17
   Call AddError(17)
  End If

  If (Present(z)) Then
   If ((n.Ne.Size(z,dim=1)).Or.(n.Ne.Size(z,dim=2)) ) Then
    Write(ErrCan,*) "Error in tqli_QP",n,Size(z,dim=1),Size(z,dim=2)
    If (ErrorLevel.Gt.-2) Call TerminateProgram
    kont = -17
    Call AddError(17)
   End If
  End If

  e(:)=Eoshift(e(:),1)

  Do l=1,n
    iter=0
    iterate: Do
      Do m=l,n-1
        dd=Abs(d(m))+Abs(d(m+1))
        If (Abs(e(m))+dd == dd) Exit
      End Do
      If (m == l) Exit iterate
      If (iter == 30) Then
       Write(ErrCan,*) "Problem in tqli_QP, too many iterations"
       kont = -18
       Call AddError(18)
       Return
      End If
      iter=iter+1
      g=(d(l+1)-d(l))/(2.0_qp*e(l))
      r=pythag_qp(g,1.0_qp)
      g=d(m)-d(l)+e(l)/(g+Sign(r,g))
      s=1.0_qp
      c=1.0_qp
      p=0.0_qp
      Do i=m-1,l,-1
        f=s*e(i)
        b=c*e(i)
        r=pythag_QP(f,g)
        e(i+1)=r
        If (r == 0.0_qp) Then
          d(i+1)=d(i+1)-p
          e(m)=0.0_qp
          Cycle iterate
        End If
        s=f/r
        c=g/r
        g=d(i+1)-p
        r=(d(i)-g)*s+2.0_qp*c*b
        p=s*r
        d(i+1)=g+p
        g=c*r-b
        If (Present(z)) Then
          ff(1:n)=z(1:n,i+1)
          z(1:n,i+1)=s*z(1:n,i)+c*ff(1:n)
          z(1:n,i)=c*z(1:n,i)-s*ff(1:n)
        End If
      End Do
      d(l)=d(l)-p
      e(l)=g
      e(m)=0.0_qp
    End Do iterate
  End Do

 End Subroutine tqli_QP

  Subroutine HTRIBK_QP(AR, AI, TAU, ZR, ZI)
  Implicit None
   Real(qp) :: AR(:,:), AI(:,:), TAU(:,:), ZR(:,:), ZI(:,:)

   Integer :: n, m, k, j, i, l
   Real(qp) :: s, si, h

   n = Size(ar,2)
   m = Size(zr,2)

   Do K = 1, N
    Do J = 1, M
      ZI(K,J) = - ZR(K,J) * TAU(2,K)
      ZR(K,J) = ZR(K,J) * TAU(1,K)
    Enddo
   Enddo
   If (N == 1) Return
  Do I = 2, N
    L = I - 1
    H = AI(I,I)
    If (H == 0._qp) Cycle
    Do J = 1, M
      S = 0._qp
      SI = 0._qp
      Do K = 1, L
        S = S + AR(I,K) * ZR(K,J) - AI(I,K) * ZI(K,J)
        SI = SI + AR(I,K) * ZI(K,J) + AI(I,K) * ZR(K,J)
      Enddo
      S = S / H
      SI = SI / H
      Do K = 1, L
        ZR(K,J) = ZR(K,J) - S * AR(I,K) - SI * AI(I,K)
        ZI(K,J) = ZI(K,J) - SI * AR(I,K) + S * AI(I,K)
      Enddo
    Enddo
  End Do

  End Subroutine HTRIBK_QP

  Subroutine HTRIDI_QP(AR, AI, D, E, TAU)
  Implicit None
   Real(qp) :: AR(:,:), AI(:,:), D(:), E(:), TAU(:,:)

   Integer :: n, i, ii, l, k, j, jp1
   Real(qp) :: scalei, h, g, f, si, hh, fi, gi

   n = Size(ar,2)

   TAU(1,N) = 1._qp
   TAU(2,N) = 0._qp
   Do I = 1, N
    D(I) = AR(I,I)
   End Do

   Do II = 1, N
    I = N + 1 - II
    L = I - 1
    H = 0._qp
    SCALEI = 0._qp
    If (L < 1) GO TO 130
    Do K = 1, L
      SCALEI = SCALEI + Abs(AR(I,K)) + Abs(AI(I,K))
    Enddo
    If (SCALEI /= 0._qp) GO TO 140
    TAU(1,L) = 1._qp
    TAU(2,L) = 0._qp
  130 E(I) = 0._qp
    GO TO 290
  140 Do K = 1, L
      AR(I,K) = AR(I,K) / SCALEI
      AI(I,K) = AI(I,K) / SCALEI
      H = H + AR(I,K) * AR(I,K) + AI(I,K) * AI(I,K)
    Enddo
    G = Sqrt(H)
    E(I) = SCALEI * G
    F = Abs(Cmplx(AR(I,L),AI(I,L),qp))
    If (F == 0._qp) GO TO 160
    TAU(1,L) = (AI(I,L) * TAU(2,I) - AR(I,L) * TAU(1,I)) / F
    SI = (AR(I,L) * TAU(2,I) + AI(I,L) * TAU(1,I)) / F
    H = H + F * G
    G = 1._qp + G / F
    AR(I,L) = G * AR(I,L)
    AI(I,L) = G * AI(I,L)
    If (L == 1) GO TO 270
    GO TO 170
  160 TAU(1,L) = -TAU(1,I)
    SI = TAU(2,I)
    AR(I,L) = G
  170 F = 0._qp
    Do J = 1, L
      G = 0._qp
      GI = 0._qp
      Do K = 1, J
        G = G + AR(J,K) * AR(I,K) + AI(J,K) * AI(I,K)
        GI = GI - AR(J,K) * AI(I,K) + AI(J,K) * AR(I,K)
      Enddo
      JP1 = J + 1
      If (L < JP1) GO TO 220
      Do K = JP1, L
        G = G + AR(K,J) * AR(I,K) - AI(K,J) * AI(I,K)
        GI = GI - AR(K,J) * AI(I,K) - AI(K,J) * AR(I,K)
      Enddo
  220 E(J) = G / H
      TAU(2,J) = GI / H
      F = F + E(J) * AR(I,J) - TAU(2,J) * AI(I,J)
    Enddo
    HH = F / (H + H)
    Do J = 1, L
      F = AR(I,J)
      G = E(J) - HH * F
      E(J) = G
      FI = -AI(I,J)
      GI = TAU(2,J) - HH * FI
      TAU(2,J) = -GI
      Do K = 1, J
        AR(J,K) = AR(J,K) - F * E(K) - G * AR(I,K) &
          + FI * TAU(2,K) + GI * AI(I,K)
        AI(J,K) = AI(J,K) - F * TAU(2,K) - G * AI(I,K) &
          - FI * E(K) - GI * AR(I,K)
      Enddo
    Enddo
  270 Do K = 1, L
      AR(I,K) = SCALEI * AR(I,K)
      AI(I,K) = SCALEI * AI(I,K)
    Enddo
    TAU(2,L) = -SI
  290 HH = D(I)
    D(I) = AR(I,I)
    AR(I,I) = HH
    AI(I,I) = SCALEI * SCALEI * H
  Enddo
  Return

  End Subroutine HTRIDI_QP

End Module MathematicsQP


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: sintf1.f,v 1.1 2010/02/23 01:10:43 rtoy Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE SINTF1(N,INC,X,WSAVE,XH,WORK,IER)
      REAL       X(INC,*)       ,WSAVE(*)   ,XH(*)
      DOUBLE PRECISION           DSUM
      IER = 0
      IF (N-2) 200,102,103
  102 SSQRT3 = 1./SQRT(3.)
      XHOLD = SSQRT3*(X(1,1)+X(1,2))
      X(1,2) = SSQRT3*(X(1,1)-X(1,2))
      X(1,1) = XHOLD
      GO TO 200
  103 NP1 = N+1
      NS2 = N/2
      DO 104 K=1,NS2
         KC = NP1-K
         T1 = X(1,K)-X(1,KC)
         T2 = WSAVE(K)*(X(1,K)+X(1,KC))
         XH(K+1) = T1+T2
         XH(KC+1) = T2-T1
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) GO TO 124
      XH(NS2+2) = 4.*X(1,NS2+1)
  124 XH(1) = 0.
      LNXH = NP1
      LNSV = NP1 + INT(LOG(REAL(NP1))) + 4
      LNWK = NP1
C
      CALL RFFT1F(NP1,1,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,
     1            LNWK,IER1)
      IF (IER1 .NE. 0) THEN
        IER = 20
        CALL XERFFT ('SINTF1',-5)
        GO TO 200
      ENDIF
C
      IF(MOD(NP1,2) .NE. 0) GO TO 30
      XH(NP1) = XH(NP1)+XH(NP1)
   30 SFNP1 = 1./FLOAT(NP1)
         X(1,1) = .5*XH(1)
         DSUM = X(1,1)
      DO 105 I=3,N,2
            X(1,I-1) = .5*XH(I)
            DSUM = DSUM+.5*XH(I-1)
            X(1,I) = DSUM
  105 CONTINUE
      IF (MODN .NE. 0) GO TO 200
      X(1,N) = .5*XH(N+1)
  200 RETURN
      END


!##############################################################################
! PROGRAM Arithmetics
!
! ## Basic mathematical calculations
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program Arithmetics

    ! declaration of variables
    implicit none
    real*8 :: a, b, c, d

    ! executable code
    a = 6d0
    b = 2.5d0
    c = exp(b) + a**2*sqrt(b)
    d = max(a,b)*sign(b, a)/mod(9d0,5d0) + abs(c)

    write(*, '(4f10.4)')a,b,c,d

end program


C	*****************************************************************
C	*	Compute a 2-body orbit                                  *
C	*****************************************************************

        PROGRAM ORBITS
	IMPLICIT NONE

	INTEGER*4 I
	INTEGER J
	INTEGER ILUN,OLUN
	REAL*8  R0(3),R1(3)
	REAL*8	F0(3),F1(3),A0(3),A1(3)
	REAL*8	V0(3),V1(3)
	INTEGER*4  N
	REAL*8  M0,M1
	REAL*8  DT
	REAL*8	G,Q

	DATA G /6.67384E-11/
	DATA Q /1E06/
	DATA ILUN,OLUN /5,6/
	COMMON /CONSTS/ G

 800    FORMAT (A5,F10.0,A5,F10.0,A5,F10.0)
 801    FORMAT (i6,2(3(X,F18.8)))
 802	FORMAT (A6,2(3(X,A18)))

 900	FORMAT (3(X,F10.0))
 901	FORMAT (X,F10.0)
 902	FORMAT (X,F10.0,X,I10)

C	Read first body position
	READ (ILUN,900) (R0(I),I=1,3)

C	Read first body velocity
	READ (ILUN,900) (V0(I),I=1,3)

C	Read first body mass
	READ (ILUN,901) M0

C	Read second body position
	READ (ILUN,900) (R1(I),I=1,3)

C	Read second body velocity
	READ (ILUN,900) (V1(I),I=1,3)

C	Read second body mass
	READ (ILUN,901) M1

C	Read time interval and number of steps
	READ (ILUN,902) DT,N

	WRITE(OLUN,802) ' NUM ','X0','Y0','Z0','X1','Y1','Z1'

	DO I=1,N
	    CALL GRAVF(R0,M0,R1,M1,F0)
	    CALL VECINV(F0,F1)
	    CALL VECMUL(F0,1/M0,A0)
	    CALL VECMUL(F1,1/M1,A1)
	    DO J=1,3
	        V0(J) = V0(J) + A0(J) * DT
	        V1(J) = V1(J) + A1(J) * DT
		R0(J) = R0(J) + V0(J) * DT
		R1(J) = R1(J) + V1(J) * DT
	    ENDDO
	    WRITE(OLUN,801) I,(R0(J)/Q,J=1,3),(R1(J)/Q,J=1,3)
	ENDDO
	END

C	*****************************************************************
C	* Compute the gravitational force vector between to objects     *
C	*****************************************************************
	SUBROUTINE GRAVF(A, AM, B, BM, F)
	IMPLICIT NONE

	REAL*8	A(3),B(3),AM,BM,F(3)
	REAL*8	R,COEF
	REAL*8	V(3)
	REAL*8	G
	REAL*8 	MODUL

	COMMON /CONSTS/ G

	CALL VECSUB(A,B,V)

	R = MODUL(V)
	COEF = -1*G*AM / R**3
	COEF = COEF * BM
	CALL VECMUL(V,COEF,F)
	RETURN
	END


cc Copyright (C) 2009: Zydrunas Gimbutas and Hong Xiao
cc Contact: Zydrunas Gimbutas <gimbutas@cims.nyu.edu>
cc          Hong Xiao <hxiao@ucdavis.edu>
cc
cc This software is being released under a modified FreeBSD license
cc (see COPYING in home directory).
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c       Orthogonal polynomials on the standard triangle
c
c       (0,2/sqrt(3)), (-1,-1/sqrt(3)), (1,-1/sqrt(3))
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c       This file contains a set of subroutines for the handling
c       of the evaluation of orthogonal polynomials on the standard
c       triangle.  It contains 2 user-callable subroutines.
c
c   ortho2eva - evaluates at the user-supplied point z
c       a collection of polynomials (of x,y) orthogonal on the
c       standard triangle
c
c   ortho2eva3 - evaluates at the user-supplied point z a collection
c       of polynomials (of x,y) orthogonal on the standard triangle,
c       together with their derivatives with respect to x and y.

c
c
      subroutine ortho2eva(mmax,z,pols,w)
c
c     This subroutine evaluates at the user-supplied point z
c     a collection of polynomials (of x,y) orthogonal on the
c     standard triangle.
c
c     The "standard" triangle is the triangle with the
c     vertices
c
c     (0,2/sqrt(3)), (-1,-1/sqrt(3)), (1,-1/sqrt(3)).       (1)
c
c     The polynomials evaluated by this subroutine are all
c     orthogonal polynomials up to order mmax, arranged in the
c     increasing order.
c
c     This subroutine is based on the Koornwinder's representation
c     of the orthogonal polynomials on the right triangle
c
c     (-1,-1), (-1,1), (1,-1)                                       (2)
c
c     given by
c
c     K_mn(x,y) = P_m ((2*x+1+y)/(1-y)) ((1-y)/2)^m P_n^{2m+1,0} (y)
c
c     where P_m are the Legendre polynomials or order m
c     and P_n^{2m+1,0} are the Jacobi polynomials of order n with
c     the parameters alpha=2*m+1 and beta=0.
c
c                   Input parameters:
c
c  mmax - the maximum order to which the polynomials are to be evaluated;
c  z - the location in R^2 where the polynomials are to be evaluated;
c       normally, expected to be inside (including boundary) the
c       standard triangle (1) above.
c  w - the work array. must be at least mmax+1+(mmax+1)**2 long
c
c                   Output parameters:
c
c  pols - the orthogonal polynomials evaluated at the point z
c       ( (mmax+1)*(mmax+2)/2 of them things)
c
c       . . . allocate memory for the work arrays
c
      implicit real *8 (a-h,o-z)
      dimension z(2), pols(1), w(1)
      data init/1/
      save
c
        if( init .eq. 1 ) then
        c0=1/sqrt(3.0d0)*sqrt(sqrt(3.0d0))
        c1=sqrt(2.0d0)*sqrt(sqrt(3.0d0))
        c2=sqrt(2.0d0)*sqrt(sqrt(3.0d0))
        init=0
        endif
c
        if( mmax .eq. 0 ) then
        pols(1)=c0
        return
        endif
c
        if( mmax .eq. 1 ) then
        pols(1)=c0
        pols(2)=z(1)*c1
        pols(3)=z(2)*c2
        return
        endif
c
      iw1=1
      iw2=iw1+mmax+1
      iw3=iw2+(mmax+1)**2
      call ortho2eva0(mmax,z,pols,w(iw1),w(iw2))
      return
      end
c
c
c
c
c
      subroutine ortho2eva0(mmax,z,pols,f1,f2)
c
c     evaluate the orthonormal polynomials on the triangle
c
      implicit real *8 (a-h,o-z)
      dimension z(2), pols(1), f1(1), f2(1)
      data init/1/
      save
c
      if( init.eq.1 ) then
         zero=0
         sqrt2=dsqrt(2.0d0)
         sqrt3=dsqrt(3.0d0)
         init=0
         r11=-1.0d0/3.0d0
         r12=-1.0d0/sqrt3
         r21=1.0d0/9.0d0*(-sqrt3)*sqrt3
         r22=1.0d0/9.0d0*(6.0d0)*sqrt3
      endif
c
      a=z(1)
      b=z(2)
c
c     ... map the standard triangle to the right
c     triangle with the vertices (-1,-1), (1,-1), (-1,1)
c
      x=r11+r12*b+a
      y=r21+r22*b
c
c     ... evaluate the Koornwinder's polynomials
c     the via three terms recursion
c
      par1=(2*x+1+y)/2
      par2=(1-y)/2
      call klegeypols(par1,par2,mmax,f1)
      do 1200 m=0,mmax
         par1=2*m+1
         call kjacopols(y,par1,zero,(mmax-m),f2(1+m*(mmax+1)))
 1200 continue

      kk=0
      do 2200 m=0,mmax
         do 2000 n=0,m
         kk=kk+1
c
c     ... evaluate the polynomial (m-n, n)
c
         pols(kk)=f1(m-n+1)*f2(n+1+(m-n)*(mmax+1))
c
c     ... and normalize it
c
         scale=dsqrt((1.0d0+(m-n)+n)*(1.0d0+(m-n)+(m-n))/sqrt3)
cccc         scale=1
         pols(kk)=pols(kk)*scale
 2000	 continue
 2200 continue
      return
      end
c
c
c
c
c
      subroutine ortho2eva3(mmax,z,pols,dersx,dersy,w)
c
c     This subroutine evaluates at the user-supplied point z
c     a collection of polynomials (of x,y) orthogonal on the
c     standard triangle, together with their derivatives with
c     respect to x and y.
c
c     The "standard" triangle is the triangle with the
c     vertices
c
c     (0,2/sqrt(3)), (-1,-1/sqrt(3), (1,-1/sqrt(3)).       (1)
c
c     The polynomials evaluated by this subroutine are all
c     orthogonal polynomials up to order mmax, arranged in the
c     increasing order.
c
c     This subroutine is based on the Koornwinder's representation
c     of the orthogonal polynomials on the right triangle
c
c     (-1,-1), (-1,1), (1,-1)                                       (2)
c
c     given by
c
c     K_mn(x,y) = P_m ((2*x+1+y)/(1-y)) ((1-y)/2)^m P_n^{2m+1,0} (y)
c
c     where P_m are the Legendre polynomials or order m
c     and P_n^{2m+1,0} are the Jacobi polynomials of order n with
c     the parameters alpha=2*m+1 and beta=0.
c
c                   Input parameters:
c
c  mmax - the maximum order to which the polynomials are to be evaluated;
c  z - the location in R^2 where the polynomials are to be evaluated;
c       normally, expected to be inside (including boundary) the
c       standard triangle (1) above.
c  w - the work array. must be at least mmax+1+(mmax+1)**2 long
c
c                   Output parameters:
c
c  pols - the orthogonal polynomials evaluated at the point z
c       ( (mmax+1)*(mmax+2)/2 of them things)
c  dersx - the derivatives with respect to x of the polynomials
c       returned in array pols
c  dersy - the derivatives with respect to y of the polynomials
c       returned in array pols
c
c       . . . allocate memory for the work arrays
c
      implicit real *8 (a-h,o-z)
      dimension z(2),pols(1),dersx(1),dersy(1),w(1)
      data init/1/
      save
c
        if( init .eq. 1 ) then
        c0=1/sqrt(3.0d0)*sqrt(sqrt(3.0d0))
        c1=sqrt(2.0d0)*sqrt(sqrt(3.0d0))
        c2=sqrt(2.0d0)*sqrt(sqrt(3.0d0))
        init=0
        endif
c
        if( mmax .eq. 0 ) then
        pols(1)=c0
        dersx(1)=0
        dersy(1)=0
        return
        endif
c
        if( mmax .eq. 1 ) then
        pols(1)=c0
        pols(2)=z(1)*c1
        pols(3)=z(2)*c2
        dersx(1)=0
        dersx(2)=c1
        dersx(3)=0
        dersy(1)=0
        dersy(2)=0
        dersy(3)=c2
        return
        endif
c
      iw1=1
      iw2=iw1+mmax+1
      iw3=iw2+(mmax+1)**2
      iw4=iw3+mmax+1
      iw5=iw4+mmax+1
      iw6=iw5+(mmax+1)**2
      iw7=iw6+(mmax+1)**2
      call ortho2eva30(mmax,z,pols,dersx,dersy,
     $     w(iw1),w(iw2),w(iw3),w(iw4),w(iw5),w(iw6))
      return
      end
c
c
c
c
c
      subroutine ortho2eva30(mmax,z,pols,dersx,dersy,
     $     f1,f2,f3,f4,f5,f6)
c
c     evaluate the orthonormal polynomials on the triangle,
c     together with their derivatives with respect to x and y.
c
      implicit real *8 (a-h,o-z)
      dimension z(2), pols(1), dersx(1), dersy(1)
      dimension f1(1), f2(1)
      dimension f3(1), f4(1), f5(1), f6(1)
      data init/1/
      save
c
      if( init.eq.1 ) then
         zero=0
         sqrt2=dsqrt(2.0d0)
         sqrt3=dsqrt(3.0d0)
         init=0
         r11=-1.0d0/3.0d0
         r12=-1.0d0/sqrt3
         r21=1.0d0/9.0d0*(-sqrt3)*sqrt3
         r22=1.0d0/9.0d0*(6.0d0)*sqrt3
      endif
c
      x=z(1)
      y=z(2)
c
c     ... map the standard triangle to the right
c     triangle with the vertices (-1,-1), (1,-1), (-1,1)
c
      a=r11+r12*y+x
      b=r21+r22*y

c
c     ... evaluate the Koornwinder's polynomials
c     the via three terms recursion
c
      par1=(2*a+1+b)/2
      par2=(1-b)/2
      call klegeypols3(par1,par2,mmax,f1,f3,f4)

      do 1200 m=0,mmax
         par1=2*m+1
         call kjacopols2(
     $        b,par1,zero,(mmax-m),f2(1+m*(mmax+1)),f5(1+m*(mmax+1)))
 1200 continue

      kk=0
      do 2200 m=0,mmax
         do 2000 n=0,m
         kk=kk+1
c
c     ... evaluate the polynomial (m-n, n), and their derivatives
c     with respect to x,y
c
         pols(kk)=f1(m-n+1)*f2(n+1+(m-n)*(mmax+1))
c
         dersx(kk)=
     $        f3(m-n+1)*f2(n+1+(m-n)*(mmax+1))
c
         dersy(kk)=
     $        f1(m-n+1)*f5(n+1+(m-n)*(mmax+1))*r22 +
     $        f3(m-n+1)*f2(n+1+(m-n)*(mmax+1))*(r12+r22/2) +
     $        f4(m-n+1)*f2(n+1+(m-n)*(mmax+1))*(-r22/2)

c
c     ... and normalize it
c
         scale=dsqrt((1.0d0+(m-n)+n)*(1.0d0+(m-n)+(m-n))/sqrt3)
cccc         scale=1
         pols(kk)=pols(kk)*scale
         dersx(kk)=dersx(kk)*scale
         dersy(kk)=dersy(kk)*scale
 2000	 continue
 2200 continue

      return
      end
c
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c        this is the end of the debugging code and the beginning
c        of the evaluation of scaled Legendre polynomials
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
        subroutine klegeypols(x,y,n,pols)
        implicit real *8 (a-h,o-z)
        dimension pols(1)
c
c       evaluate a sequence of scaled Legendre polynomials
c       P_n(x/y) y^n, with the parameter y \in [0..1]
c
c       ...
c
        pkm1=1
        pk=x
c
        pk=1
        pkp1=x
c
c
c        if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        if(n .eq. 0) return
c
        pols(2)=x
        return
 1200 continue
c
        pols(1)=1
        pols(2)=x
c
c       n is greater than 2. conduct recursion
c
        do 2000 k=1,n-1
c
        pkm1=pk
        pk=pkp1
        pkp1=( (2*k+1)*x*pk-k*pkm1*y**2 )/(k+1)
        pols(k+2)=pkp1
 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine klegeypols3(x,y,n,pols,dersx,dersy)
        implicit real *8 (a-h,o-z)
        dimension pols(1),dersx(1),dersy(1)
c
c     evaluate a sequence of scaled Legendre polynomials P_n(x/y) y^n,
c     with the parameter y \in [0..1], together with their derivatives
c     with respect to the parameters x and y.
c
c       ... if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        dersx(1)=0
        dersy(1)=0
        if(n .eq. 0) return
c
        pols(2)=x
        dersx(2)=1
        dersy(2)=0
        return
 1200 continue
c
c       n is greater than 1. conduct recursion
c
        pols(1)=1
        dersx(1)=0
        dersy(1)=0
        pols(2)=x
        dersx(2)=1
        dersy(2)=0
c
        pkm1=1
        pk=x
        dkm1=0
        dk=1
        ykm1=0
        yk=0
c
        pk=1
        pkp1=x
        dk=0
        dkp1=1
        yk=0
        ykp1=0
c
        do 2000 k=1,n-1
c
        pkm1=pk
        pk=pkp1
        dkm1=dk
        dk=dkp1
        ykm1=yk
        yk=ykp1
c
        pkp1=( (2*k+1)*x*pk-k*pkm1*y*y )/(k+1)
        dkp1=( (2*k+1)*(x*dk+pk)-k*dkm1*y*y )/(k+1)
        ykp1=( (2*k+1)*(x*yk)-k*(pkm1*2*y+ykm1*y*y) )/(k+1)
        pols(k+2)=pkp1
        dersx(k+2)=dkp1
        dersy(k+2)=ykp1
 2000 continue
c
        return
        end
c
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c        this is the end of the debugging code and the beginning
c        of the evaluation of Jacobi polynomials
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
        subroutine kjacopols(x,a,b,n,pols)
        implicit real *8 (a-h,o-z)
        dimension pols(1)
c
c       evaluates a bunch of Jacobi polynomials
c       at the user-provided point x
c
c       ... if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        if(n .eq. 0) return
c
        pols(2)=(a/2-b/2)+(1+a/2+b/2)*x
        return
 1200 continue
c
        pols(1)=1
        pols(2)=(a/2-b/2)+(1+a/2+b/2)*x
c
c       n is greater than 2. conduct recursion
c
        pkm1=1
        pk=(a/2-b/2)+(1+a/2+b/2)*x
        pk=1
        pkp1=(a/2-b/2)+(1+a/2+b/2)*x
c
        do 2000 k=2,n
c
        pkm1=pk
        pk=pkp1
        alpha=(2*k+a+b-1)*(a**2-b**2+(2*k+a+b-2)*(2*k+a+b)*x)
        beta=2*(k+a-1)*(k+b-1)*(2*k+a+b)
        pkp1=(alpha*pk-beta*pkm1)/(2*k*(k+a+b)*(2*k+a+b-2))
        pols(k+1)=pkp1
 2000 continue
c
        return
        end
c
c
c
c
c
        subroutine kjacopols2(x,a,b,n,pols,ders)
        implicit real *8 (a-h,o-z)
        dimension pols(1), ders(1)
c
c       evaluates a bunch of Jacobi polynomials (together
c       with their derivatives) at the user-provided point x
c
c       ... if n=0 or n=1 - exit
c
        if(n .ge. 2) goto 1200
        pols(1)=1
        ders(1)=0
        if(n .eq. 0) return
c
        pols(2)=(a/2-b/2)+(1+a/2+b/2)*x
        ders(2)=(1+a/2+b/2)
        return
 1200 continue
c
        pols(1)=1
        ders(1)=0
        pols(2)=(a/2-b/2)+(1+a/2+b/2)*x
        ders(2)=(1+a/2+b/2)
c
c       n is greater than 2. conduct recursion
c
        pkm1=1
        dkm1=0
        pk=(a/2-b/2)+(1+a/2+b/2)*x
        dk=(1+a/2+b/2)
c
        pk=1
        dk=0
        pkp1=(a/2-b/2)+(1+a/2+b/2)*x
        dkp1=(1+a/2+b/2)
c
        do 2000 k=2,n
c
        pkm1=pk
        pk=pkp1
        dkm1=dk
        dk=dkp1
        alpha1=(2*k+a+b-1)*(a**2-b**2)
        alpha2=(2*k+a+b-1)*((2*k+a+b-2)*(2*k+a+b))
        beta=2*(k+a-1)*(k+b-1)*(2*k+a+b)
        gamma=(2*k*(k+a+b)*(2*k+a+b-2))
        pkp1=((alpha1+alpha2*x)*pk-beta*pkm1)/gamma
        dkp1=((alpha1+alpha2*x)*dk-beta*dkm1+alpha2*pk)/gamma
        pols(k+1)=pkp1
        ders(k+1)=dkp1
 2000 continue
c
        return
        end


c---------------------------------------------------------------------
c---------------------------------------------------------------------

       subroutine y_solve

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c this function performs the solution of the approximate factorization
c step in the y-direction for all five matrix components
c simultaneously. The Thomas algorithm is employed to solve the
c systems for the y-lines. Boundary conditions are non-periodic
c---------------------------------------------------------------------

       include 'header.h'
       include 'mpinpb.h'

       integer i, j, k, stage, ip, kp, n, isize, jend, ksize, j1, j2,
     >         buffer_size, c, m, p, jstart, error,
     >         requests(2), statuses(MPI_STATUS_SIZE, 2)
       double precision  r1, r2, d, e, s(5), sm1, sm2,
     >                   fac1, fac2

c---------------------------------------------------------------------
c now do a sweep on a layer-by-layer basis, i.e. sweeping through cells
c on this node in the direction of increasing i for the forward sweep,
c and after that reversing the direction for the backsubstitution
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c                          FORWARD ELIMINATION
c---------------------------------------------------------------------
       do    stage = 1, ncells
          c      = slice(2,stage)

          jstart = 0
          jend   = cell_size(2,c)-1

          isize     = cell_size(1,c)
          ksize     = cell_size(3,c)
          ip        = cell_coord(1,c)-1
          kp        = cell_coord(3,c)-1

          buffer_size = (isize-start(1,c)-end(1,c)) *
     >                  (ksize-start(3,c)-end(3,c))

          if ( stage .ne. 1) then

c---------------------------------------------------------------------
c            if this is not the first processor in this row of cells,
c            receive data from predecessor containing the right hand
c            sides and the upper diagonal elements of the previous two rows
c---------------------------------------------------------------------

             call mpi_irecv(in_buffer, 22*buffer_size,
     >                      dp_type, predecessor(2),
     >                      DEFAULT_TAG, comm_solve,
     >                      requests(1), error)

c---------------------------------------------------------------------
c            communication has already been started.
c            compute the left hand side while waiting for the msg
c---------------------------------------------------------------------
             call lhsy(c)

c---------------------------------------------------------------------
c            wait for pending communication to complete
c            This waits on the current receive and on the send
c            from the previous stage. They always come in pairs.
c---------------------------------------------------------------------
             call mpi_waitall(2, requests, statuses, error)

c---------------------------------------------------------------------
c            unpack the buffer
c---------------------------------------------------------------------
             j  = jstart
             j1 = jstart + 1
             n = 0
c---------------------------------------------------------------------
c            create a running pointer
c---------------------------------------------------------------------
             p = 0
             do    k = start(3,c), ksize-end(3,c)-1
                do    i = start(1,c), isize-end(1,c)-1
                   lhs(i,j,k,n+2,c) = lhs(i,j,k,n+2,c) -
     >                       in_buffer(p+1) * lhs(i,j,k,n+1,c)
                   lhs(i,j,k,n+3,c) = lhs(i,j,k,n+3,c) -
     >                       in_buffer(p+2) * lhs(i,j,k,n+1,c)
                   do    m = 1, 3
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                       in_buffer(p+2+m) * lhs(i,j,k,n+1,c)
                   end do
                   d            = in_buffer(p+6)
                   e            = in_buffer(p+7)
                   do    m = 1, 3
                      s(m) = in_buffer(p+7+m)
                   end do
                   r1 = lhs(i,j,k,n+2,c)
                   lhs(i,j,k,n+3,c) = lhs(i,j,k,n+3,c) - d * r1
                   lhs(i,j,k,n+4,c) = lhs(i,j,k,n+4,c) - e * r1
                   do    m = 1, 3
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) - s(m) * r1
                   end do
                   r2 = lhs(i,j1,k,n+1,c)
                   lhs(i,j1,k,n+2,c) = lhs(i,j1,k,n+2,c) - d * r2
                   lhs(i,j1,k,n+3,c) = lhs(i,j1,k,n+3,c) - e * r2
                   do    m = 1, 3
                      rhs(i,j1,k,m,c) = rhs(i,j1,k,m,c) - s(m) * r2
                   end do
                   p = p + 10
                end do
             end do

             do    m = 4, 5
                n = (m-3)*5
                do    k = start(3,c), ksize-end(3,c)-1
                   do    i = start(1,c), isize-end(1,c)-1
                      lhs(i,j,k,n+2,c) = lhs(i,j,k,n+2,c) -
     >                          in_buffer(p+1) * lhs(i,j,k,n+1,c)
                      lhs(i,j,k,n+3,c) = lhs(i,j,k,n+3,c) -
     >                          in_buffer(p+2) * lhs(i,j,k,n+1,c)
                      rhs(i,j,k,m,c)   = rhs(i,j,k,m,c) -
     >                          in_buffer(p+3) * lhs(i,j,k,n+1,c)
                      d                = in_buffer(p+4)
                      e                = in_buffer(p+5)
                      s(m)             = in_buffer(p+6)
                      r1 = lhs(i,j,k,n+2,c)
                      lhs(i,j,k,n+3,c) = lhs(i,j,k,n+3,c) - d * r1
                      lhs(i,j,k,n+4,c) = lhs(i,j,k,n+4,c) - e * r1
                      rhs(i,j,k,m,c)   = rhs(i,j,k,m,c) - s(m) * r1
                      r2 = lhs(i,j1,k,n+1,c)
                      lhs(i,j1,k,n+2,c) = lhs(i,j1,k,n+2,c) - d * r2
                      lhs(i,j1,k,n+3,c) = lhs(i,j1,k,n+3,c) - e * r2
                      rhs(i,j1,k,m,c)   = rhs(i,j1,k,m,c) - s(m) * r2
                      p = p + 6
                   end do
                end do
             end do

          else

c---------------------------------------------------------------------
c            if this IS the first cell, we still compute the lhs
c---------------------------------------------------------------------
             call lhsy(c)
          endif

c---------------------------------------------------------------------
c         perform the Thomas algorithm; first, FORWARD ELIMINATION
c---------------------------------------------------------------------
          n = 0

          do    k = start(3,c), ksize-end(3,c)-1
             do    j = jstart, jend-2
                do    i = start(1,c), isize-end(1,c)-1
                   j1 = j  + 1
                   j2 = j  + 2
                   fac1               = 1.d0/lhs(i,j,k,n+3,c)
                   lhs(i,j,k,n+4,c)   = fac1*lhs(i,j,k,n+4,c)
                   lhs(i,j,k,n+5,c)   = fac1*lhs(i,j,k,n+5,c)
                   do    m = 1, 3
                      rhs(i,j,k,m,c) = fac1*rhs(i,j,k,m,c)
                   end do
                   lhs(i,j1,k,n+3,c) = lhs(i,j1,k,n+3,c) -
     >                         lhs(i,j1,k,n+2,c)*lhs(i,j,k,n+4,c)
                   lhs(i,j1,k,n+4,c) = lhs(i,j1,k,n+4,c) -
     >                         lhs(i,j1,k,n+2,c)*lhs(i,j,k,n+5,c)
                   do    m = 1, 3
                      rhs(i,j1,k,m,c) = rhs(i,j1,k,m,c) -
     >                         lhs(i,j1,k,n+2,c)*rhs(i,j,k,m,c)
                   end do
                   lhs(i,j2,k,n+2,c) = lhs(i,j2,k,n+2,c) -
     >                         lhs(i,j2,k,n+1,c)*lhs(i,j,k,n+4,c)
                   lhs(i,j2,k,n+3,c) = lhs(i,j2,k,n+3,c) -
     >                         lhs(i,j2,k,n+1,c)*lhs(i,j,k,n+5,c)
                   do    m = 1, 3
                      rhs(i,j2,k,m,c) = rhs(i,j2,k,m,c) -
     >                         lhs(i,j2,k,n+1,c)*rhs(i,j,k,m,c)
                   end do
                end do
             end do
          end do

c---------------------------------------------------------------------
c         The last two rows in this grid block are a bit different,
c         since they do not have two more rows available for the
c         elimination of off-diagonal entries
c---------------------------------------------------------------------

          j  = jend - 1
          j1 = jend
          do    k = start(3,c), ksize-end(3,c)-1
             do    i = start(1,c), isize-end(1,c)-1
                fac1               = 1.d0/lhs(i,j,k,n+3,c)
                lhs(i,j,k,n+4,c)   = fac1*lhs(i,j,k,n+4,c)
                lhs(i,j,k,n+5,c)   = fac1*lhs(i,j,k,n+5,c)
                do    m = 1, 3
                   rhs(i,j,k,m,c) = fac1*rhs(i,j,k,m,c)
                end do
                lhs(i,j1,k,n+3,c) = lhs(i,j1,k,n+3,c) -
     >                      lhs(i,j1,k,n+2,c)*lhs(i,j,k,n+4,c)
                lhs(i,j1,k,n+4,c) = lhs(i,j1,k,n+4,c) -
     >                      lhs(i,j1,k,n+2,c)*lhs(i,j,k,n+5,c)
                do    m = 1, 3
                   rhs(i,j1,k,m,c) = rhs(i,j1,k,m,c) -
     >                      lhs(i,j1,k,n+2,c)*rhs(i,j,k,m,c)
                end do
c---------------------------------------------------------------------
c               scale the last row immediately (some of this is
c               overkill in case this is the last cell)
c---------------------------------------------------------------------
                fac2               = 1.d0/lhs(i,j1,k,n+3,c)
                lhs(i,j1,k,n+4,c) = fac2*lhs(i,j1,k,n+4,c)
                lhs(i,j1,k,n+5,c) = fac2*lhs(i,j1,k,n+5,c)
                do    m = 1, 3
                   rhs(i,j1,k,m,c) = fac2*rhs(i,j1,k,m,c)
                end do
             end do
          end do

c---------------------------------------------------------------------
c         do the u+c and the u-c factors
c---------------------------------------------------------------------
          do    m = 4, 5
             n = (m-3)*5
             do    k = start(3,c), ksize-end(3,c)-1
                do    j = jstart, jend-2
                   do    i = start(1,c), isize-end(1,c)-1
                   j1 = j  + 1
                   j2 = j  + 2
                   fac1               = 1.d0/lhs(i,j,k,n+3,c)
                   lhs(i,j,k,n+4,c)   = fac1*lhs(i,j,k,n+4,c)
                   lhs(i,j,k,n+5,c)   = fac1*lhs(i,j,k,n+5,c)
                   rhs(i,j,k,m,c) = fac1*rhs(i,j,k,m,c)
                   lhs(i,j1,k,n+3,c) = lhs(i,j1,k,n+3,c) -
     >                         lhs(i,j1,k,n+2,c)*lhs(i,j,k,n+4,c)
                   lhs(i,j1,k,n+4,c) = lhs(i,j1,k,n+4,c) -
     >                         lhs(i,j1,k,n+2,c)*lhs(i,j,k,n+5,c)
                   rhs(i,j1,k,m,c) = rhs(i,j1,k,m,c) -
     >                         lhs(i,j1,k,n+2,c)*rhs(i,j,k,m,c)
                   lhs(i,j2,k,n+2,c) = lhs(i,j2,k,n+2,c) -
     >                         lhs(i,j2,k,n+1,c)*lhs(i,j,k,n+4,c)
                   lhs(i,j2,k,n+3,c) = lhs(i,j2,k,n+3,c) -
     >                         lhs(i,j2,k,n+1,c)*lhs(i,j,k,n+5,c)
                   rhs(i,j2,k,m,c) = rhs(i,j2,k,m,c) -
     >                         lhs(i,j2,k,n+1,c)*rhs(i,j,k,m,c)
                end do
             end do
          end do

c---------------------------------------------------------------------
c            And again the last two rows separately
c---------------------------------------------------------------------
             j  = jend - 1
             j1 = jend
             do    k = start(3,c), ksize-end(3,c)-1
                do    i = start(1,c), isize-end(1,c)-1
                fac1               = 1.d0/lhs(i,j,k,n+3,c)
                lhs(i,j,k,n+4,c)   = fac1*lhs(i,j,k,n+4,c)
                lhs(i,j,k,n+5,c)   = fac1*lhs(i,j,k,n+5,c)
                rhs(i,j,k,m,c)     = fac1*rhs(i,j,k,m,c)
                lhs(i,j1,k,n+3,c) = lhs(i,j1,k,n+3,c) -
     >                      lhs(i,j1,k,n+2,c)*lhs(i,j,k,n+4,c)
                lhs(i,j1,k,n+4,c) = lhs(i,j1,k,n+4,c) -
     >                      lhs(i,j1,k,n+2,c)*lhs(i,j,k,n+5,c)
                rhs(i,j1,k,m,c)   = rhs(i,j1,k,m,c) -
     >                      lhs(i,j1,k,n+2,c)*rhs(i,j,k,m,c)
c---------------------------------------------------------------------
c               Scale the last row immediately (some of this is overkill
c               if this is the last cell)
c---------------------------------------------------------------------
                fac2               = 1.d0/lhs(i,j1,k,n+3,c)
                lhs(i,j1,k,n+4,c) = fac2*lhs(i,j1,k,n+4,c)
                lhs(i,j1,k,n+5,c) = fac2*lhs(i,j1,k,n+5,c)
                rhs(i,j1,k,m,c)   = fac2*rhs(i,j1,k,m,c)

             end do
          end do
       end do

c---------------------------------------------------------------------
c         send information to the next processor, except when this
c         is the last grid block;
c---------------------------------------------------------------------

          if (stage .ne. ncells) then

c---------------------------------------------------------------------
c            create a running pointer for the send buffer
c---------------------------------------------------------------------
             p = 0
             n = 0
             do    k = start(3,c), ksize-end(3,c)-1
                do    i = start(1,c), isize-end(1,c)-1
                   do    j = jend-1, jend
                      out_buffer(p+1) = lhs(i,j,k,n+4,c)
                      out_buffer(p+2) = lhs(i,j,k,n+5,c)
                      do    m = 1, 3
                         out_buffer(p+2+m) = rhs(i,j,k,m,c)
                      end do
                      p = p+5
                   end do
                end do
             end do

             do    m = 4, 5
                n = (m-3)*5
                do    k = start(3,c), ksize-end(3,c)-1
                   do    i = start(1,c), isize-end(1,c)-1
                      do    j = jend-1, jend
                         out_buffer(p+1) = lhs(i,j,k,n+4,c)
                         out_buffer(p+2) = lhs(i,j,k,n+5,c)
                         out_buffer(p+3) = rhs(i,j,k,m,c)
                         p = p + 3
                      end do
                   end do
                end do
             end do

c---------------------------------------------------------------------
c            pack and send the buffer
c---------------------------------------------------------------------
             call mpi_isend(out_buffer, 22*buffer_size,
     >                     dp_type, successor(2),
     >                     DEFAULT_TAG, comm_solve,
     >                     requests(2), error)

          endif
       end do

c---------------------------------------------------------------------
c      now go in the reverse direction
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c                         BACKSUBSTITUTION
c---------------------------------------------------------------------
       do    stage = ncells, 1, -1
          c = slice(2,stage)

          jstart = 0
          jend   = cell_size(2,c)-1

          isize = cell_size(1,c)
          ksize = cell_size(3,c)
          ip    = cell_coord(1,c)-1
          kp    = cell_coord(3,c)-1

          buffer_size = (isize-start(1,c)-end(1,c)) *
     >                  (ksize-start(3,c)-end(3,c))

          if (stage .ne. ncells) then

c---------------------------------------------------------------------
c            if this is not the starting cell in this row of cells,
c            wait for a message to be received, containing the
c            solution of the previous two stations
c---------------------------------------------------------------------

             call mpi_irecv(in_buffer, 10*buffer_size,
     >                      dp_type, successor(2),
     >                      DEFAULT_TAG, comm_solve,
     >                      requests(1), error)

c---------------------------------------------------------------------
c            communication has already been started
c            while waiting, do the block-diagonal inversion for the
c            cell that was just finished
c---------------------------------------------------------------------

             call pinvr(slice(2,stage+1))

c---------------------------------------------------------------------
c            wait for pending communication to complete
c---------------------------------------------------------------------
             call mpi_waitall(2, requests, statuses, error)

c---------------------------------------------------------------------
c            unpack the buffer for the first three factors
c---------------------------------------------------------------------
             n = 0
             p = 0
             j  = jend
             j1 = j - 1
             do    m = 1, 3
                do   k = start(3,c), ksize-end(3,c)-1
                   do   i = start(1,c), isize-end(1,c)-1
                      sm1 = in_buffer(p+1)
                      sm2 = in_buffer(p+2)
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                        lhs(i,j,k,n+4,c)*sm1 -
     >                        lhs(i,j,k,n+5,c)*sm2
                      rhs(i,j1,k,m,c) = rhs(i,j1,k,m,c) -
     >                        lhs(i,j1,k,n+4,c) * rhs(i,j,k,m,c) -
     >                        lhs(i,j1,k,n+5,c) * sm1
                      p = p + 2
                   end do
                end do
             end do

c---------------------------------------------------------------------
c            now unpack the buffer for the remaining two factors
c---------------------------------------------------------------------
             do    m = 4, 5
                n = (m-3)*5
                do   k = start(3,c), ksize-end(3,c)-1
                   do   i = start(1,c), isize-end(1,c)-1
                      sm1 = in_buffer(p+1)
                      sm2 = in_buffer(p+2)
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                        lhs(i,j,k,n+4,c)*sm1 -
     >                        lhs(i,j,k,n+5,c)*sm2
                      rhs(i,j1,k,m,c) = rhs(i,j1,k,m,c) -
     >                        lhs(i,j1,k,n+4,c) * rhs(i,j,k,m,c) -
     >                        lhs(i,j1,k,n+5,c) * sm1
                      p = p + 2
                   end do
                end do
             end do

          else
c---------------------------------------------------------------------
c            now we know this is the first grid block on the back sweep,
c            so we don't need a message to start the substitution.
c---------------------------------------------------------------------

             j  = jend - 1
             j1 = jend
             n = 0
             do   m = 1, 3
                do   k = start(3,c), ksize-end(3,c)-1
                   do   i = start(1,c), isize-end(1,c)-1
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                             lhs(i,j,k,n+4,c)*rhs(i,j1,k,m,c)
                   end do
                end do
             end do

             do    m = 4, 5
                n = (m-3)*5
                do   k = start(3,c), ksize-end(3,c)-1
                   do   i = start(1,c), isize-end(1,c)-1
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                             lhs(i,j,k,n+4,c)*rhs(i,j1,k,m,c)
                   end do
                end do
             end do
          endif

c---------------------------------------------------------------------
c         Whether or not this is the last processor, we always have
c         to complete the back-substitution
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c         The first three factors
c---------------------------------------------------------------------
          n = 0
          do   m = 1, 3
             do   k = start(3,c), ksize-end(3,c)-1
                do   j = jend-2, jstart, -1
                   do    i = start(1,c), isize-end(1,c)-1
                      j1 = j  + 1
                      j2 = j  + 2
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                          lhs(i,j,k,n+4,c)*rhs(i,j1,k,m,c) -
     >                          lhs(i,j,k,n+5,c)*rhs(i,j2,k,m,c)
                   end do
                end do
             end do
          end do

c---------------------------------------------------------------------
c         And the remaining two
c---------------------------------------------------------------------
          do    m = 4, 5
             n = (m-3)*5
             do   k = start(3,c), ksize-end(3,c)-1
                do   j = jend-2, jstart, -1
                   do    i = start(1,c), isize-end(1,c)-1
                      j1 = j  + 1
                      j2 = j1 + 1
                      rhs(i,j,k,m,c) = rhs(i,j,k,m,c) -
     >                          lhs(i,j,k,n+4,c)*rhs(i,j1,k,m,c) -
     >                          lhs(i,j,k,n+5,c)*rhs(i,j2,k,m,c)
                   end do
                end do
             end do
          end do

c---------------------------------------------------------------------
c         send on information to the previous processor, if needed
c---------------------------------------------------------------------
          if (stage .ne.  1) then
             j  = jstart
             j1 = jstart + 1
             p = 0
             do    m = 1, 5
                do    k = start(3,c), ksize-end(3,c)-1
                   do    i = start(1,c), isize-end(1,c)-1
                      out_buffer(p+1) = rhs(i,j,k,m,c)
                      out_buffer(p+2) = rhs(i,j1,k,m,c)
                      p = p + 2
                   end do
                end do
             end do

c---------------------------------------------------------------------
c            pack and send the buffer
c---------------------------------------------------------------------

             call mpi_isend(out_buffer, 10*buffer_size,
     >                     dp_type, predecessor(2),
     >                     DEFAULT_TAG, comm_solve,
     >                     requests(2), error)

          endif

c---------------------------------------------------------------------
c         If this was the last stage, do the block-diagonal inversion
c---------------------------------------------------------------------
          if (stage .eq. 1) call pinvr(c)

       end do

       return
       end


!***********************************************************************
!                                                                      *
      REAL(KIND(0.0D0)) FUNCTION RINTI (J, K, MODE)
!                                                                      *
!   The value of this  function is the one-electron integral I (J,K)   *
!   for  orbitals  J, K. The analytical expression for this quantity   *
!   is given as  eq (9) in  I P Grant, B J McKenzie, P H Norrington,   *
!   D F Mayers, and N C Pyper,  Computer  Phys Commun 21 (1980) 211 .  *
!                                                                      *
!   Call(s) to: [LIB92]: DPBDT, QUAD.                                  *
!                                                                      *
!   Written by Farid A Parpia, at Oxford  Last revision: 06 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:50:23   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE DEBUG_C
      USE DEF_C,           ONLY: C
      USE GRID_C
      USE NPOT_C,          ONLY: ZZ
      USE ORB_C
      USE TATB_C,          ONLY: TA, TB, MTP
      USE WAVE_C,          ONLY: MF,PF,QF
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE dpbdt_I
      USE quad_I
      IMPLICIT NONE
!-----------------------------------------------
!   G l o b a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J
      INTEGER  :: K
      INTEGER, INTENT(IN) :: MODE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I
      REAL(DOUBLE) :: PIECE1, PIECE2, PIECE3, PIECE4
!-----------------------------------------------
!
!   Stop if orbitals J and K have different kappa values
!
      IF (NAK(J) /= NAK(K)) THEN
         WRITE (*, 300) NP(J), NH(J), NP(K), NH(K)
         STOP
      ENDIF
!
      MTP = MAX(MF(J),MF(K))
!
!   Kinetic energy contribution
!
!   Piece involving derivatives
!
      CALL DPBDT (K)
      TA(1) = 0.D0
      DO I = 2, MTP
         TA(I) = QF(I,J)*TA(I) - PF(I,J)*TB(I)
      END DO
      CALL QUAD (PIECE1)
      PIECE1 = C*PIECE1/H
!
!   Pieces not involving derivatives
!
      TA(1) = 0.D0
      DO I = 2, MTP
         TA(I) = RP(I)*QF(I,J)*QF(I,K)
      END DO
      CALL QUAD (PIECE2)
      PIECE2 = -2.D0*C*C*PIECE2
!
      TA(1) = 0.D0
      DO I = 2, MTP
         TA(I) = RPOR(I)*(PF(I,J)*QF(I,K) + QF(I,J)*PF(I,K))
      END DO
      CALL QUAD (PIECE3)
      PIECE3 = PIECE3*C*DBLE(NAK(K))
!
!   Contribution from nuclear potential only if MODE is 0
!
      IF (MODE == 0) THEN
!
         TA(1) = 0.D0
         DO I = 2, MTP
            TA(I) = RPOR(I)*ZZ(I)*(PF(I,J)*PF(I,K) + QF(I,J)*QF(I,K))
         END DO
         CALL QUAD (PIECE4)
         PIECE4 = -PIECE4
!
      ELSE
         PIECE4 = 0.D0
      ENDIF
!
      RINTI = PIECE1 + PIECE2 + PIECE3 + PIECE4
!
!   Debug printout
!
      IF (MODE==0 .AND. LDBPR(4)) WRITE (99, 301) NP(J), NH(J), NP(K), NH(K), &
         RINTI
      IF (MODE/=0 .AND. LDBPR(5)) WRITE (99, 302) NP(J), NH(J), NP(K), NH(K), &
         RINTI
!
      RETURN
!
  300 FORMAT('RINTI: Attempt to calculate I(',1I2,1A2,',',1I2,1A2,')')
  301 FORMAT(/,' I (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12,/)
  302 FORMAT(/,' K (',1I2,1A2,',',1I2,1A2,') = ',1P,D19.12,/)
      RETURN
!
      END FUNCTION RINTI


Program run_hypot

use, intrinsic :: iso_fortran_env, only : wp=>REAL64,INT64
use perf, only : sysclock2ms
Implicit None

integer :: N, Nrun, ios
character(16) :: argv
real(wp) :: Rhypot

call random_init(.false., .false.)

N = 1000
call get_command_argument(1,argv, status=ios); if(ios==0) read(argv,*) N

Nrun = 10
call get_command_argument(2,argv, status=ios); if(ios==0) read(argv,*) Nrun

Rhypot = benchhypot(N,Nrun)

print '(A,I10,A,F7.5)', 'sqrt(a**2 + b**2) / hypot(a,b).  N=',N,'  time ratio: ',Rhypot

contains

real(wp) function benchhypot(N,Nrun)
integer :: i
integer(int64) :: tic,toc,tmin1,tmin2

integer,intent(in) :: N, Nrun
real(wp) :: A(N), B(N), Rhypot(Nrun), Thypot,Trsq
! volatile tells compiler that value is unpredictable, don't unroll, etc.
real(wp),volatile :: C(N),D(N)

tmin1=huge(0_int64)
tmin2=huge(0_int64)

! priming
call system_clock(tic)
C = hypot(A,B)
call system_clock(toc)

main: do i = 1, Nrun
  call random_number(A)
  call random_number(B)

  call system_clock(tic)
    C = hypot(A,B)
  call system_clock(toc)
  if (toc-tic<tmin1) tmin1=toc-tic

  Thypot = sysclock2ms(tmin1)
!-----------
  call system_clock(tic)
    D = sqrt(A**2 + B**2)
  call system_clock(toc)
  if (toc-tic<tmin2) tmin2=toc-tic

  Trsq = sysclock2ms(tmin2)

  Rhypot(i) = Trsq / Thypot

enddo main

benchhypot = sum(Rhypot) / Nrun

end function benchhypot

End Program


! Задание 2.3 в учебнике

program ex_2_3
    implicit none

        integer                 :: Out = 0, In = 0, positives = 0, size = 0
        integer, parameter      :: R_ = 4
        logical, allocatable    :: mask(:)
        real(R_), allocatable   :: values(:)
        character(*), parameter :: input_file = "../data/input.txt", &
                                   output_file = "output.txt"

        open (file=input_file, newunit=In)
            read(In, *) size
            allocate(values(size))
            read(In, *) values(:)
        close (In)

        mask = values >= 0
        positives = count(mask)

        open (file=output_file, newunit=Out)
            write(Out, *) positives
        close (Out)

end program ex_2_3


! Copyright (c) 2015, NVIDIA CORPORATION. All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!  * Redistributions of source code must retain the above copyright
!    notice, this list of conditions and the following disclaimer.
!  * Redistributions in binary form must reproduce the above copyright
!    notice, this list of conditions and the following disclaimer in the
!    documentation and/or other materials provided with the distribution.
!  * Neither the name of NVIDIA CORPORATION nor the names of its
!    contributors may be used to endorse or promote products derived
!    from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ``AS IS'' AND ANY
! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
! PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY
! OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

program laplace
  implicit none
  integer, parameter :: fp_kind=kind(1.0)
  integer, parameter :: n=4096, m=4096, iter_max=1000
  integer :: i, j, iter
  real(fp_kind), dimension (:,:), allocatable :: A, Anew
  real(fp_kind), dimension (:),   allocatable :: y0
  real(fp_kind) :: pi=2.0_fp_kind*asin(1.0_fp_kind), tol=1.0e-5_fp_kind, error=1.0_fp_kind
  real(fp_kind) :: start_time, stop_time

  allocate ( A(0:n-1,0:m-1), Anew(0:n-1,0:m-1) )
  allocate ( y0(0:m-1) )

  A = 0.0_fp_kind

  ! Set B.C.
  y0 = sin(pi* (/ (j,j=0,m-1) /) /(m-1))

  A(0,:)   = 0.0_fp_kind
  A(n-1,:) = 0.0_fp_kind
  A(:,0)   = y0
  A(:,m-1) = y0*exp(-pi)

  write(*,'(a,i5,a,i5,a)') 'Jacobi relaxation Calculation:', n, ' x', m, ' mesh'

  call cpu_time(start_time)

  iter=0

!$omp parallel do shared(Anew)
  do i=1,m-1
    Anew(0,i)   = 0.0_fp_kind
    Anew(n-1,i) = 0.0_fp_kind
  end do
!$end omp parallel do
!$omp parallel do shared(Anew)
  do i=1,n-1
    Anew(i,0)   = y0(i)
    Anew(i,m-1) = y0(i)*exp(-pi)
  end do
!$end omp parallel do

  do while ( error .gt. tol .and. iter .lt. iter_max )
    error=0.0_fp_kind

!$omp parallel shared(m, n, Anew, A)

!$omp do reduction( max:error )
!$acc kernels
    do j=1,m-2
      do i=1,n-2
        Anew(i,j) = 0.25_fp_kind * ( A(i+1,j  ) + A(i-1,j  ) + &
                                     A(i  ,j-1) + A(i  ,j+1) )
        error = max( error, abs(Anew(i,j)-A(i,j)) )
      end do
    end do
!$acc end kernels
!$omp end do

    if(mod(iter,100).eq.0 ) write(*,'(i5,f10.6)'), iter, error
    iter = iter +1

!$omp do
!$acc kernels
    do j=1,m-2
      do i=1,n-2
        A(i,j) = Anew(i,j)
      end do
    end do
!$acc end kernels
!$omp end do

!$omp end parallel

  end do

  call cpu_time(stop_time)
  write(*,'(a,f10.3,a)')  ' completed in ', stop_time-start_time, ' seconds'

  deallocate (A,Anew,y0)
end program laplace


!
!    Copyright 2011 Sebastian Heimann
!
!    Licensed under the Apache License, Version 2.0 (the "License");
!    you may not use this file except in compliance with the License.
!    You may obtain a copy of the License at
!
!        http://www.apache.org/licenses/LICENSE-2.0
!
!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.
!

program test_piecewise_linear_function

    use util
    use piecewise_linear_function

    implicit none

    type(t_plf) :: func
    real :: a,c

    call test_begin("test_piecewise_linear_function")

    call plf_make( func, 0.,0., 1.,1., 2.,1., 3.,0. )
    if (2. .ne. plf_integrate( func, -1.,3. )) then
        call test_fail("1")
    end if

    if (1. .ne. plf_integrate( func, -1.,1.5 )) then
        call test_fail("2")
    end if

    if (6./8.+1. .ne. plf_integrate( func, 0.5,2.5 )) then
        call test_fail("3")
    end if

    if (3./8. .ne. plf_integrate( func, 2.,2.5 )) then
        call test_fail("4")
    end if

    if (0. .ne. plf_integrate( func, 2.,2. )) then
        call test_fail("5")
    end if

    if (0. .ne. plf_integrate( func, 2.5,2.5 )) then
        call test_fail("6")
    end if

    if (1./8.-1./32. .ne. plf_integrate( func, 2.5,2.75 )) then
        call test_fail("7")
    end if

    if (1. .ne. plf_integrate( func, 1.,2. )) then
        call test_fail("8")
    end if

    call plf_integrate_and_centroid( func, -1., 6., a, c )
    if (a .ne. 2. .and. c .ne. 1.5) then
        call test_fail("9")
    end if

    call plf_integrate_and_centroid( func, 0., 0.5, a, c )
    if (a .ne. 1./8. .and. c .ne. 1./3.) then
        call test_fail("10")
    end if

    call plf_integrate_and_centroid( func, 0., 2., a, c )
    if (a .ne. 3./2. .and. c .ne. 1. + 2./9.) then
        call test_fail("11")
    end if

    call test_end()
    call cleanup()

end program


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test f2008 log_gamma intrinsic

program p
 use ISO_C_BINDING
 use check_mod

  interface
    subroutine get_expected_f( src, expct, n ) bind(C)
     use ISO_C_BINDING
      type(C_PTR), value :: src
      type(C_PTR), value :: expct
      integer(C_INT), value :: n
    end subroutine

    subroutine get_expected_d( src, expct, n ) bind(C)
     use ISO_C_BINDING
      type(C_PTR), value :: src
      type(C_PTR), value :: expct
      integer(C_INT), value :: n
    end subroutine
  end interface

  integer, parameter :: N=20
  real*4, target,  dimension(N) :: r_src
  real*4, target,  dimension(N) :: r_rslt
  real*4, target,  dimension(N) :: r_expct

  real*8, target,  dimension(N) :: d_src
  real*8, target,  dimension(N) :: d_rslt
  real*8, target,  dimension(N) :: d_expct

  do i =  0,N-1
    r_src(i+1) = i**6.9 + .2
    d_src(i+1) = (i**20.0)  + .2
  enddo

  r_rslt = log_gamma(r_src)
  d_rslt = log_gamma(d_src)

  call get_expected_f(C_LOC(r_src), C_LOC(r_expct), N)
  call get_expected_d(C_LOC(d_src), C_LOC(d_expct), N)

  call checkr4( r_rslt, r_expct, N, rtoler=0.0000003)
  call checkr8( d_rslt, d_expct, N, rtoler=0.0000003_8)

!   print *, "r_expct:"
!   print *, r_expct
!   print *, "r_rslt:"
!   print *, r_rslt

!   print *, "d_expct:"
!   print *, d_expct
!   print *, "d_rslt:"
!   print *, d_rslt
end program


c come fare return x?
c long integer
c parametri come puntatori? come copiare?

	program fibonacci_bello
	character*32 text

c	call fibonacci(10)
	real*8 v
	v = 35.0

	call factorial(v)

	end

c 	`n` viene passato come puntatore
c 	se devo modificare `n`, devo prima copiarlo
	subroutine factorial(n)
c 		specifico il tipo del parametro `n`
		real*8 n

c 		dichiaro variabili locali
		real*8 iteration_count
		real*8 result

c 		esegui operazioni
		iteration_count = n
		result = 1

		do while (iteration_count >= 2)
			result = result * iteration_count
			iteration_count = iteration_count - 1
		enddo

		write (*, *) 'factorial', n, ' = ', result
	end

	subroutine fibonacci(iteration_count)
		integer iteration_count

		integer i0
		integer i1
		integer i2
		integer current_iteration
		character*64 buffer

		i0 = 1
		i1 = 1
		current_iteration = 0

		do while (current_iteration < iteration_count + 1)
c 			write (buffer, *) 'fibonacci'
c 			write (buffer(12:), '(i6)') current_iteration
c 			write (buffer(20:), *) '='
c 			write (buffer(26:), '(i10)') i0
c 			write (*, *) buffer

			write (*, *) 'fibonacci', current_iteration, ' = ', i0

			i2 = i0 + i1
			i0 = i1
			i1 = i2
			current_iteration = current_iteration + 1
		enddo
	end


      program atomic

      implicit none

       integer :: i,j,k
       integer :: iter,count_rate, count_max,count
       integer :: t_start,t_final
       integer, parameter :: nx=8192
       double precision, parameter    :: pi=4d0*dtan(1d0)
       double precision               :: total,time_s,sum_x
       double precision, allocatable  :: u(:),v(:),w(:)

       call system_clock(count_max=count_max, count_rate=count_rate)

       call system_clock(t_start)

       allocate(u(nx)); allocate(v(nx)); allocate(w(nx))

       do i=1,nx
          u(i) = dsin(i*1d0)**2
          v(i) = dcos(i*1d0)**2
       enddo

!offload data and eliminate the dependencies
      do i=1,nx
         u(i) = u(i) + v(i)
      enddo

!sum up the vector elements of w
      sum_x = 0d0
      do i=1,nx
         sum_x = sum_x + u(i)
      enddo

      write(*,*)'--sum w/nx',sum_x/nx

       call system_clock(t_final)

       time_s = real(t_final - t_start)/real(count_rate)

       print*, '--Time it takes (s)', time_s
       end


      SUBROUTINE IVELT(VTP,AVEVEL,ST,TSI,NSAMPS)
!      IVELT IS A SUBPROGRAM TO CONVERT VELOCITY TIME PAIRS INTO AN ARRAY OF
!  VELOCITIES, EACH SEPARATED IN TIME UNIFORMLY.  (I.E.  THERE'S A VELOCITY
!  FOR EACH TIME SAMPLE.)  LINEAR INTERPOLATION IS USED TO OBTAIN VELOCITIES
!  BETWEEN THE TIMES SPECIFIED.  THE VELOCITY IS HELD CONSTANT FOR TIMES OUTSIDE
!  THE FIRST AND LAST SPECIFIED TIMES. AT LEAST 2 PAIRS MUST BE GIVEN.
!  EXCEED THE BOUNDS OF THE VTP.
!       ARGUMENTS:
!            VTP    - AN ARRAY OF VELOCITY-TIME PAIRS.  VTP(1) IS A VELOCITY,
!                     VTP(2) IS THE TIME, IN SECONDS, OF THE VELOCITY VTP(1),
!                     VTP(3) IS THE NEXT VELOCITY, AND VTP(4) IS THE TIME OF
!                     VTP(3), ETC..  ALL TIMES MUST BE STRICTLY MONOTONICALLY
!                     INCREASING.  IF ST<VTP(2) THEN ALL TIMES FROM ST TO VTP(2)
!                     WILL BE SET TO VTP(1)  ( EXTRAPOLATED.).  LIKEWISE, ALL
!                     TIMES EXCEEDING THE LAST VTP TIME WILL BE SET TO THE LAST
!                     VELOCITY.  THE VTP ARRAY MUST BE TERMINATED BY A TIME <=0
!                     OR A TIME EXCEEDING THE LAST VTP.
!            AVEVEL - AN ARRAY TO RECEIVE THE UNIFORMLY SPACED VELOCITIES.  MUST
!                     BE AT LEAST NSAMPS LONG.
!            ST     - START TIME IN SECONDS OF THE AVEVEL ARRAY.  AVEVEL(1)
!                     WILL HAVE A TIME OF ST ASSOCIATED WITH IT.
!            TSI    - TIME SAMPLE INTERVAL, IN SECONDS.  THE TIME DIFFERENCE
!                     BETWEEN CONSEQUTIVE TIME SAMPLES.
!            NSAMPS - THE NUMBER OF TIME SAMPLES.  THE NUMBER OF VELOCITIES TO
!                     COMPUTE AND STORE INTO AVEVEL.
!
!      PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, MAY 1979
!
      DIMENSION VTP(111),AVEVEL(111)
      TIME=ST
      INDX=1
      N2=1                                                               ! THE POINTER TO A VTP PAIR
!
!    EXTRAPOLATE ANY TIMES LESS THAN VTP(2)
!
   10 IF(TIME.GT.VTP(2)) GO TO 100
!
      AVEVEL(INDX)=VTP(1)
      INDX=INDX+1
      TIME=TIME+TSI
      IF(INDX.GT.NSAMPS) RETURN
      GO TO 10
  100 IF(ST.LE.VTP(N2+3)) GO TO 200
      N2=N2+2                                                            ! STILL TRYING TO FIND A VTP
      IF(VTP(N2+1).GE.0) GO TO 100
      PRINT 120,ST
  120 FORMAT(' ***  ERROR  ***  NO TIME IN THE VTP EXCEEDS THE START ',
     *     'TIME OF ',F10.2,' (IVELT)')
      STOP
!
!    INTERPOLATE VALUES BETWEEN VTP TIMES
!
  200 CONTINUE
      IF(VTP(N2+3).NE.VTP(N2+1)) GO TO 205                              ! CONSTANT VELOCITY
      VT=0.                                                             ! WATCH OUT FOR DIVIDE BY 0.!
      GO TO 210
  205 VT=(VTP(N2+2)-VTP(N2))/(VTP(N2+3)-VTP(N2+1))
  210 CONTINUE
      IF(TIME.LE.VTP(N2+3)) GO TO 300
      N2=N2+2                                                           !  SET UP THE NEXT VTP PAIR
      IF(VTP(N2+3).GT.0) GO TO 200
      V=AVEVEL(INDX-1)                                                  !  EXTRAPOLATE TO TO END
      DO I=INDX,NSAMPS
  220    AVEVEL(I)=V
      ENDDO
      RETURN
  300 AVEVEL(INDX)=(TIME-VTP(N2+1))*VT+VTP(N2)
      INDX=INDX+1
      TIME=TIME+TSI
      IF(INDX.LE.NSAMPS) GO TO 210
      RETURN
      END


MODULE m_statdelta

! ----------------------------------------------------------------------
! MODULE: m_statdelta.f95
! ----------------------------------------------------------------------
! Purpose:
!  Module for computing statistics of two data series comparison
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	11 October 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE statdelta (ds1, ds2, dsr, RMSdsr, Sigmadsr, MEANdsr, MINdsr, MAXdsr)

! ----------------------------------------------------------------------
! SUBROUTINE: statdelta.f95
! ----------------------------------------------------------------------
! Purpose:
!  Numerical comparison between two data series matrices.
!  Numerical differences are computed at the common IDs (e.g. epochs)
! ----------------------------------------------------------------------
! Input arguments:
! - ds1:		1st data series matrix (used as reference)
! - ds2: 		2nd data series matrix
!
! Output arguments:
! - dsr: 		Differences between the two input matrices at the common IDs (epochs)
!        		dsr = [id(common) id2(common) sr2-sr1(:,3:end)]
! - RMSdsr: 	Root Mean Square of each variable's differences
! - Sigmadsr	Standard Deviation of each variable's differences
! - MEANdsr		Mean value of each variable's differences
! - MINdsr:		Minimum value of each variable's differences
! - MAXdsr: 	Maximum value of each variable's differences
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	11 October 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE m_statist
      USE mdl_config
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN), ALLOCATABLE, DIMENSION(:,:) :: ds1, ds2
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_d), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: dsr
      REAL (KIND = prec_d), INTENT(OUT), DIMENSION(:)  , ALLOCATABLE :: RMSdsr, Sigmadsr, MEANdsr, MINdsr, MAXdsr
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d), ALLOCATABLE, DIMENSION(:) :: dx
      REAL (KIND = prec_d) :: RMSdx, Sigmadx, MEANdx, MINdx, MAXdx
      REAL (KIND = prec_d) :: delta_t, dt_limit, smallest_delta, real_smallest_delta
      INTEGER (KIND = prec_int8) :: Nepochs, Nepochs2, Nelements, Nepochs_delta
      INTEGER (KIND = prec_int8) :: i, j, j1, k, looptest
      INTEGER (KIND = prec_int8) :: sz1, sz2, sz3, sz4
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
      INTEGER (KIND = prec_int8) :: Nparam
      REAL (KIND = prec_d), ALLOCATABLE, DIMENSION(:,:) :: ds_temp, ds1_2, ds2_2
      CHARACTER (LEN=100) mesg
! ----------------------------------------------------------------------

dt_limit = 1.D-8
smallest_delta = 1.D+09
real_smallest_delta = 1.D+09

sz1 = size(ds1, DIM = 1)
sz2 = size(ds1, DIM = 2)
Nepochs = sz1

sz3 = size(ds2, DIM = 1)
sz4 = size(ds2, DIM = 2)
Nepochs2 = sz3

! default initialisation
Nparam = min0(sz2, sz4)

! ----------------------------------------------------------------------
! Test collumns dimension
If (sz2 .NE. sz4) Then
!print *,"Subroutine statdelta.f95 within Module mdl_statdelta.f95: Input matrices dimension(DIM=2) do not agree"
!print *,"DIM=2", sz2, sz4
!         STOP "*** - ***"
end if
ALLOCATE (ds1_2(Nepochs,Nparam), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
      write(mesg, *) "Not enough memory - failed to allocate ds1_2, dimensions (", &
              Nepochs, ",", Nparam, ")"
      call report('FATAL', pgrm_name, 'statdelta', mesg, 'src/fortran/m_statdelta.f95', 1)
end if
ds1_2 = ds1(:,1:NParam)
ALLOCATE (ds2_2(Nepochs2,Nparam), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
      write(mesg, *) "Not enough memory - failed to allocate ds2_2, dimensions (", &
              Nepochs2, ",", Nparam, ")"
      call report('FATAL', pgrm_name, 'statdelta', mesg, 'src/fortran/m_statdelta.f95', 1)
end if
ds2_2 = ds2(:,1:NParam)

! ----------------------------------------------------------------------
! Find the number of the common epochs
Nepochs_delta = 0
Do i = 1 , Nepochs
   ! Test the time argument:
   Do j = 1 , Nepochs2
      delta_t = ABS(ds2_2(j,1) - ds1_2(i,1))
      if (delta_t < real_smallest_delta) real_smallest_delta = delta_t
      IF (delta_t < dt_limit) then
         ! Counter of the common epochs
         Nepochs_delta = Nepochs_delta + 1
      else if (delta_t < smallest_delta) then
         smallest_delta = delta_t
      End if
   End Do
End Do
! ----------------------------------------------------------------------
if (1 < 0) then
print *,"Nepochs_delta ", Nepochs_delta
print *,"Nepochs ", Nepochs
print *,"Nepochs2 ", Nepochs2
print *,"Smallest delta ",smallest_delta
print *,"Real Smallest delta ",real_smallest_delta
end if
!print *,"delta_t", delta_t

! Dynamic allocatable array
! Allocate the array of the numerical orbit comparison
ALLOCATE (dsr(Nepochs_delta,Nparam), STAT = AllocateStatus)
        if (AllocateStatus .ne. 0) then
      write(mesg, *) "Not enough memory - failed to allocate dsr, dimensions (", &
              Nepochs_delta, ",", Nparam, ")"
      call report('FATAL', pgrm_name, 'statdelta', mesg, 'src/fortran/m_statdelta.f95', 1)
        end if

! ----------------------------------------------------------------------
! Compute the numerical differences
k = 0
Do i = 1 , Nepochs
   ! Test the time argument:
   Do j = 1 , Nepochs2
      delta_t = ABS(ds2_2(j,1) - ds1_2(i,1))
      IF (delta_t < dt_limit) then
	  ! Compute the numerical differences of the state vector
         k = k + 1
		 dsr(k,1:2) = ds1_2(i,1:2)
         dsr(k,3:sz2) = ds2_2(j,3:sz2) - ds1_2(i,3:sz2)
      end if
   End Do
End Do
! ----------------------------------------------------------------------
!print *,"k", k

! ----------------------------------------------------------------------
! Statistics

! First two collumns refer to Time (MJD, Sec since 00h)
Nelements = sz2 - 2

! Allocate arrays
ALLOCATE (dx(Nepochs_delta), STAT = AllocateStatus)
        if (AllocateStatus .ne. 0) then
      write(mesg, *) "Not enough memory - failed to allocate dx, dimension ", &
              Nepochs_delta
      call report('FATAL', pgrm_name, 'statdelta', mesg, 'src/fortran/m_statdelta.f95', 1)
        end if
ALLOCATE (RMSdsr(Nelements), STAT = AllocateStatus)
        if (AllocateStatus .ne. 0) then
      write(mesg, *) "Not enough memory - failed to allocate RMSdsr, dimension ", &
              Nelements
      call report('FATAL', pgrm_name, 'statdelta', mesg, 'src/fortran/m_statdelta.f95', 1)
        end if
ALLOCATE (Sigmadsr(Nelements), STAT = AllocateStatus)
        if (AllocateStatus .ne. 0) then
      write(mesg, *) "Not enough memory - failed to allocate Sigmadsr, dimension ", &
              Nelements
      call report('FATAL', pgrm_name, 'statdelta', mesg, 'src/fortran/m_statdelta.f95', 1)
        end if
ALLOCATE (MEANdsr(Nelements), STAT = AllocateStatus)
        if (AllocateStatus .ne. 0) then
      write(mesg, *) "Not enough memory - failed to allocate MEANdsr, dimension ", &
              Nelements
      call report('FATAL', pgrm_name, 'statdelta', mesg, 'src/fortran/m_statdelta.f95', 1)
        end if
ALLOCATE (MINdsr(Nelements), STAT = AllocateStatus)
        if (AllocateStatus .ne. 0) then
      write(mesg, *) "Not enough memory - failed to allocate MINdsr, dimension ", &
              Nelements
      call report('FATAL', pgrm_name, 'statdelta', mesg, 'src/fortran/m_statdelta.f95', 1)
        end if
ALLOCATE (MAXdsr(Nelements), STAT = AllocateStatus)
        if (AllocateStatus .ne. 0) then
      write(mesg, *) "Not enough memory - failed to allocate MAXdsr, dimension ", &
              Nelements
      call report('FATAL', pgrm_name, 'statdelta', mesg, 'src/fortran/m_statdelta.f95', 1)
        end if

j = 0
Do i = 3 , sz2
   dx(:) = dsr(:,i)
   if (size(dx) == 0) then
       print *,"error, size dx is 0, i = ", i
       STOP
   end if
   Call statist(dx, RMSdx, Sigmadx, MEANdx, MINdx, MAXdx)
   j = j + 1
   RMSdsr(j) = RMSdx
   Sigmadsr(j) = Sigmadx
   MEANdsr(j) = MEANdx
   MINdsr(j) = MINdx
   MAXdsr(j) = MAXdx
End Do
! ----------------------------------------------------------------------

 100 END SUBROUTINE

End Module