module mod_tests_jacobi_iteration_4_point_stencil
  use,intrinsic :: iso_fortran_env
  use mod_wall_clock_time, only : wall_clock_time
  implicit none
  private
  public tests_jacobi
  contains
    !---
    subroutine tests_jacobi(nsize,nloop,nimp,wct,a,b)
      integer(int32),intent(in) :: nsize,nloop,nimp
      real(real64),dimension(nimp),intent(out) :: wct
      real(real64),dimension(nsize,nsize),intent(inout) :: a,b
      integer(int32) :: i,j,k,l
      real(real64) :: t1,t2,error

      ! implementation 1 "sequential do"
      i = 1
      call wall_clock_time(t1)
      do l=1,nloop
        do k=2,nsize-1
          do j=2,nsize-1
            b(j,k) = 0.25d0*(a(j,k-1)+a(j-1,k)+a(j+1,k)+a(j,k+1))
          end do
        end do
        !error = sum(abs(a-b))
        do k=2,nsize-1
          do j=2,nsize-1
            a(j,k) = b(j,k)
          end do
        end do
      end do
      call wall_clock_time(t2)
      wct(i) = t2-t1

      ! implementation 2 "OpenMP do"
      i = 2
      call wall_clock_time(t1)
      do l=1,nloop
        !$omp parallel do collapse(2) private(j,k) shared(nsize,a,b)
        do k=2,nsize-1
          do j=2,nsize-1
            b(j,k) = 0.25d0*(a(j,k-1)+a(j-1,k)+a(j+1,k)+a(j,k+1))
          end do
        end do
        !$omp end parallel do
        !error = sum(abs(a-b))
        !$omp parallel do collapse(2) private(j,k) shared(nsize,a,b)
        do k=2,nsize-1
          do j=2,nsize-1
            a(j,k) = b(j,k)
          end do
        end do
        !$omp end parallel do
      end do
      call wall_clock_time(t2)
      wct(i) = t2-t1

      ! implementation 3 "do concurrent (single loop)"
      i = 3
      call wall_clock_time(t1)
      do l=1,nloop
        do concurrent(k=2:nsize-1,j=2:nsize-1)
          b(j,k) = 0.25d0*(a(j,k-1)+a(j-1,k)+a(j+1,k)+a(j,k+1))
        end do
        !error = sum(abs(a-b))
        do concurrent(k=2:nsize-1,j=2:nsize-1)
        !do concurrent(j=2:nsize-1,k=2:nsize-1)
          a(j,k) = b(j,k)
        end do
      end do
      call wall_clock_time(t2)
      wct(i) = t2-t1

       ! implementation 4 "do concurrent (double loop)"
      i = 4
      call wall_clock_time(t1)
      do l=1,nloop
        do concurrent(k=2:nsize-1)
          do concurrent(j=2:nsize-1)
            b(j,k) = 0.25d0*(a(j,k-1)+a(j-1,k)+a(j+1,k)+a(j,k+1))
          end do
        end do
        !error = sum(abs(a-b))
        do concurrent(k=2:nsize-1)
          do concurrent(j=2:nsize-1)
            a(j,k) = b(j,k)
          end do
        end do
      end do
      call wall_clock_time(t2)
      wct(i) = t2-t1

    end subroutine tests_jacobi
    !---
end module mod_tests_jacobi_iteration_4_point_stencil


program test

  !----------------------------------------------------------------------------
  ! MODULS AND VARIABLS
  !----------------------------------------------------------------------------

  USE mo_kind,         ONLY: sp, dp, i4
  use mo_ansi_colors,  only: color, c_red, c_green
  USE mo_pumpingtests, ONLY: thiem, theis, ext_thiem2d, ext_thiem3d, ext_theis2d, ext_theis3d
  use mo_utils,        ONLY: eq

  Implicit none

  REAL(sp) :: Reftest, hreftest, Qwtest, Ktest, Ltest, Stest, TGtest, &
       vartest, corrtest, anisotest!, proptest
  REAL(dp) :: Reftestd, hreftestd, Qwtestd, Ktestd, Ltestd, Stestd, &
       TGtestd, vartestd, corrtestd, anisotestd
  !, proptestd
  LOGICAL  :: isgood

  real(dp), dimension(3,3)   :: fpoints_dp, fpoints2_dp, fpoints3_dp
  real(sp), dimension(3,3)   :: fpoints_sp, fpoints2_sp, fpoints3_sp

  real(dp), dimension(9,2)   :: grid_dp
  real(sp), dimension(9,2)   :: grid_sp

  integer(i4) :: m,n

  real(sp) :: stmp
  real(dp) :: dtmp

  !----------------------------------------------------------------------------
  ! test-parameters
  !----------------------------------------------------------------------------

  Reftest         = 1.0_sp
  hreftest        = 0.0_sp
  Qwtest          = -0.001_sp
  Ktest           = 0.0001_sp
  Ltest           = 1.0_sp
  Stest           = 0.001_sp
  TGtest          = Ltest*Ktest
  vartest         = 1.0_sp
  !proptest        = 0.8_sp
  corrtest        = 10.0_sp
  anisotest       = 1.0_sp

  Reftestd        = 1.0_dp
  hreftestd       = 0.0_dp
  Qwtestd         = -0.001_dp
  Ktestd          = 0.0001_dp
  Ltestd          = 1.0_dp
  Stestd          = 0.001_dp
  TGtestd         = Ltestd*Ktestd
  vartestd        = 1.0_dp
  !proptestd       = 0.8_dp
  corrtestd       = 10.0_dp
  anisotestd      = 1.0_dp

  grid_sp         =   reshape((/  1._sp,      2._sp,      3._sp,&
       1._sp,      2._sp,      3._sp,&
       1._sp,      2._sp,      3._sp,&
       50.0_sp,    50.0_sp,    50.0_sp,&
       100.0_sp,   100.0_sp,   100.0_sp,&
       1000.0_sp,  1000.0_sp,  1000.0_sp /), (/9,2/))

  grid_dp         =   reshape((/  1._dp,      2._dp,      3._dp,&
       1._dp,      2._dp,      3._dp,&
       1._dp,      2._dp,      3._dp,&
       50.0_dp,    50.0_dp,    50.0_dp,&
       100.0_dp,   100.0_dp,   100.0_dp,&
       1000.0_dp,  1000.0_dp,  1000.0_dp /), (/9,2/))

  isgood          = .TRUE.

  !----------------------------------------------------------------------------
  ! tests
  !----------------------------------------------------------------------------

  write (*,*) ''
  write (*,*) 'Test mo_pumpingtests.f90'
  write (*,*) ''

  write (*,*) "THIEM's SOLUTION"
  write (*,*) '-------------------------------------------------------------------------'

  ! Thiemsp(0.2)         =  -2.56150007
  ! Thiemsp(0.3)         =  -1.91618240
  ! Thiemdp(0.2)         =  -2.5614999936338809
  ! Thiemdp(0.3)         =  -1.9161822315668402

  stmp = thiem(0.2_sp, (/Ktest /), (/Reftest , hreftest , Qwtest , Ltest /))
  isgood = isgood .and. (nint(stmp*1000)       .EQ. -2562)
  stmp = thiem(0.3_sp, (/Ktest /), (/Reftest , hreftest , Qwtest , Ltest /))
  isgood = isgood .and. (nint(stmp*1000)       .EQ. -1916)
  dtmp = thiem(0.2_dp, (/Ktestd/), (/Reftestd, hreftestd, Qwtestd, Ltestd/))
  isgood = isgood .and. (nint(dtmp*1000000)    .EQ. -2561500)
  dtmp = thiem(0.3_dp, (/Ktestd/), (/Reftestd, hreftestd, Qwtestd, Ltestd/))
  isgood = isgood .and. (nint(dtmp*1000000)    .EQ. -1916182)
  !sp
  write (*,*) 'Thiemsp(0.2) =', thiem(0.2_sp, (/Ktest /), (/Reftest , hreftest , Qwtest , Ltest /))
  write (*,*) 'Thiemsp(0.3) =', thiem(0.3_sp, (/Ktest /), (/Reftest , hreftest , Qwtest , Ltest /))
  !dp
  write (*,*) 'Thiemdp(0.2) =', thiem(0.2_dp, (/Ktestd/), (/Reftestd, hreftestd, Qwtestd, Ltestd/))
  write (*,*) 'Thiemdp(0.3) =', thiem(0.3_dp, (/Ktestd/), (/Reftestd, hreftestd, Qwtestd, Ltestd/))

  write (*,*) ' '

  write (*,*) "EXTENDED THIEM's SOLUTION IN 3D"
  write (*,*) '-------------------------------------------------------------------------'

  ! ext_Thiem3d_sp(0.2)  =  -4.19452763
  ! ext_Thiem3d_sp(0.3)  =  -3.13209820
  ! ext_Thiem3d_sp(0.2)  =  -1.55417931           optional
  ! ext_Thiem3d_sp(0.3)  =  -1.16274548           optional
  ! ext_Thiem3d_dp(0.2)  =  -4.1945268260359985
  ! ext_Thiem3d_dp(0.3)  =  -3.1320977426835279
  ! ext_Thiem3d_dp(0.2)  =  -1.5541790860603071   optional
  ! ext_Thiem3d_dp(0.3)  =  -1.1627453616249193   optional

  stmp = ext_thiem3d(0.2_sp, (/Ktest , vartest , corrtest , anisotest/), &
       (/Reftest , hreftest , Qwtest , Ltest  /))
  isgood = isgood .and. (nint(stmp*1000)          .EQ. -4195)
  stmp = ext_thiem3d(0.3_sp, (/Ktest , vartest , corrtest , anisotest/), &
       (/Reftest , hreftest , Qwtest , Ltest  /))
  isgood = isgood .and. (nint(stmp*1000)          .EQ. -3132)
  stmp = ext_thiem3d(0.2_sp, (/Ktest , vartest , corrtest , anisotest/), &
       (/Reftest , hreftest , Qwtest , Ltest  /), .false., 1.0_sp)
  isgood = isgood .and. (nint(stmp*1000)                            .EQ. -1554)
  stmp = ext_thiem3d(0.3_sp, (/Ktest , vartest , corrtest , anisotest/), &
       (/Reftest , hreftest , Qwtest , Ltest  /), .false., 1.0_sp)
  isgood = isgood .and. (nint(stmp*1000)                            .EQ. -1163)
  dtmp = ext_thiem3d(0.2_dp, (/Ktestd, vartestd, corrtestd, anisotestd/), &
       (/Reftestd, hreftestd, Qwtestd, Ltestd/))
  isgood = isgood .and. (nint(dtmp*1000000).EQ. -4194527)
  dtmp = ext_thiem3d(0.3_dp, (/Ktestd, vartestd, corrtestd, anisotestd/), &
       (/Reftestd, hreftestd, Qwtestd, Ltestd/))
  isgood = isgood .and. (nint(dtmp*1000000).EQ. -3132098)
  dtmp = ext_thiem3d(0.2_dp, (/Ktestd, vartestd, corrtestd, anisotestd/), &
       (/Reftestd, hreftestd, Qwtestd, Ltestd/), .false., 1.0_dp)
  isgood = isgood .and. (nint(dtmp*1000000)                         .EQ. -1554179)
  dtmp = ext_thiem3d(0.3_dp, (/Ktestd, vartestd, corrtestd, anisotestd/), &
       (/Reftestd, hreftestd, Qwtestd, Ltestd/), .false., 1.0_dp)
  isgood = isgood .and. (nint(dtmp*1000000)                         .EQ. -1162745)
  !sp
  write (*,*) 'ext_Thiem3d_sp(0.2)_std=', ext_thiem3d(0.2_sp, (/Ktest , vartest , corrtest , anisotest /), &
       (/Reftest , hreftest , Qwtest , Ltest /))
  write (*,*) 'ext_Thiem3d_sp(0.3)_std=', ext_thiem3d(0.3_sp, (/Ktest , vartest , corrtest , anisotest /), &
       (/Reftest , hreftest , Qwtest , Ltest /))
  !with optional inputs
  write (*,*) 'ext_Thiem3d_sp(0.2)_opt=', ext_thiem3d(0.2_sp, (/Ktest , vartest , corrtest , anisotest /), &
       (/Reftest , hreftest , Qwtest , Ltest /), &
       .false., 1.0_sp)
  write (*,*) 'ext_Thiem3d_sp(0.3)_opt=', ext_thiem3d(0.3_sp, (/Ktest , vartest , corrtest , anisotest /), &
       (/Reftest , hreftest , Qwtest , Ltest /), &
       .false., 1.0_sp)
  !dp
  write (*,*) 'ext_Thiem3d_dp(0.2)_std=', ext_thiem3d(0.2_dp, (/Ktestd, vartestd, corrtestd, anisotestd/), &
       (/Reftestd, hreftestd, Qwtestd, Ltestd/))
  write (*,*) 'ext_Thiem3d_dp(0.3)_std=', ext_thiem3d(0.3_dp, (/Ktestd, vartestd, corrtestd, anisotestd/), &
       (/Reftestd, hreftestd, Qwtestd, Ltestd/))
  !with optional inputs
  write (*,*) 'ext_Thiem3d_dp(0.2)_opt=', ext_thiem3d(0.2_dp, (/Ktestd, vartestd, corrtestd, anisotestd/), &
       (/Reftestd, hreftestd, Qwtestd, Ltestd/), &
       .false., 1.0_dp)
  write (*,*) 'ext_Thiem3d_dp(0.3)_opt=', ext_thiem3d(0.3_dp, (/Ktestd, vartestd, corrtestd, anisotestd/), &
       (/Reftestd, hreftestd, Qwtestd, Ltestd/), &
       .false., 1.0_dp)

  write (*,*) ' '

  write (*,*) "EXTENDED THIEM's SOLUTION IN 2D"
  write (*,*) '-------------------------------------------------------------------------'

  ! ext_Thiem2d_sp(0.2)  =  -2.57654548
  ! ext_Thiem2d_sp(0.3)  =  -1.93043315
  ! ext_Thiem2d_sp(0.2)  =  -2.56530547           optional
  ! ext_Thiem2d_sp(0.3)  =  -1.91978836           optional
  ! ext_Thiem2d_dp(0.2)  =  -2.5765449512179259
  ! ext_Thiem2d_dp(0.3)  =  -1.9304329811242074
  ! ext_Thiem2d_dp(0.2)  =  -2.5653048154494607   optional
  ! ext_Thiem2d_dp(0.3)  =  -1.9197882246039830   optional

  stmp = ext_thiem2d(0.2_sp, (/TGtest , vartest , corrtest /), (/Reftest , hreftest , Qwtest /))
  isgood = isgood .and. (nint(stmp*1000)                    .EQ. -2577)
  stmp = ext_thiem2d(0.3_sp, (/TGtest , vartest , corrtest /), (/Reftest , hreftest , Qwtest /))
  isgood = isgood .and. (nint(stmp*1000)                    .EQ. -1930)
  stmp = ext_thiem2d(0.2_sp, (/TGtest , vartest , corrtest /), (/Reftest , hreftest , Qwtest /),1.0_sp)
  isgood = isgood .and. (nint(stmp*1000)             .EQ. -2565)
  stmp = ext_thiem2d(0.3_sp, (/TGtest , vartest , corrtest /), (/Reftest , hreftest , Qwtest /),1.0_sp)
  isgood = isgood .and. (nint(stmp*1000)             .EQ. -1920)
  dtmp = ext_thiem2d(0.2_dp, (/TGtestd, vartestd, corrtestd/), (/Reftestd, hreftestd, Qwtestd/))
  isgood = isgood .and. (nint(dtmp*1000000)                 .EQ. -2576545)
  dtmp = ext_thiem2d(0.3_dp, (/TGtestd, vartestd, corrtestd/), (/Reftestd, hreftestd, Qwtestd/))
  isgood = isgood .and. (nint(dtmp*1000000)                 .EQ. -1930433)
  dtmp = ext_thiem2d(0.2_dp, (/TGtestd,vartestd,corrtestd/), (/Reftestd,hreftestd,Qwtestd/),1.0_dp)
  isgood = isgood .and. (nint(dtmp*1000000)            .EQ. -2565305)
  dtmp = ext_thiem2d(0.3_dp, (/TGtestd,vartestd,corrtestd/), (/Reftestd,hreftestd,Qwtestd/),1.0_dp)
  isgood = isgood .and. (nint(dtmp*1000000)            .EQ. -1919788)
  !sp
  write (*,*) 'ext_Thiem2d_sp(0.2)_std=', ext_thiem2d(0.2_sp, (/TGtest , vartest , corrtest /), &
       (/Reftest , hreftest , Qwtest /))
  write (*,*) 'ext_Thiem2d_sp(0.3)_std=', ext_thiem2d(0.3_sp, (/TGtest , vartest , corrtest /), &
       (/Reftest , hreftest , Qwtest /))
  !with optional inputs
  write (*,*) 'ext_Thiem2d_sp(0.2)_opt=', ext_thiem2d(0.2_sp,(/TGtest ,vartest ,corrtest /), &
       (/Reftest ,hreftest ,Qwtest /),1.0_sp)
  write (*,*) 'ext_Thiem2d_sp(0.3)_opt=', ext_thiem2d(0.3_sp,(/TGtest ,vartest ,corrtest /), &
       (/Reftest ,hreftest ,Qwtest /),1.0_sp)
  !dp
  write (*,*) 'ext_Thiem2d_dp(0.2)_std=', ext_thiem2d(0.2_dp, (/TGtestd, vartestd, corrtestd/), &
       (/Reftestd, hreftestd, Qwtestd/))
  write (*,*) 'ext_Thiem2d_dp(0.3)_std=', ext_thiem2d(0.3_dp, (/TGtestd, vartestd, corrtestd/), &
       (/Reftestd, hreftestd, Qwtestd/))
  !with optional inputs
  write (*,*) 'ext_Thiem2d_dp(0.2)_opt=', ext_thiem2d(0.2_dp,(/TGtestd,vartestd,corrtestd/), &
       (/Reftestd,hreftestd,Qwtestd/),1.0_dp)
  write (*,*) 'ext_Thiem2d_dp(0.3)_opt=', ext_thiem2d(0.3_dp,(/TGtestd,vartestd,corrtestd/), &
       (/Reftestd,hreftestd,Qwtestd/),1.0_dp)

  write (*,*) ' '

  write (*,*) "THEIS' SOLUTION"
  write (*,*) '-------------------------------------------------------------------------'

  ! Theissp(r=.2,t=.0)   =  0.00000000
  ! Theissp(r=.2,t=.1)   = -0.174579859
  ! Theissp(r=.3,t=.2)   = -0.142127588
  ! Theissp(r=.3,t=.3)   = -0.270834625
  ! Theisdp(r=.2,t=.0)   =  0.0000000000000000
  ! Theisdp(r=.2,t=.1)   = -0.17458018796997515
  ! Theisdp(r=.3,t=.2)   = -0.14212753460648780
  ! Theisdp(r=.3,t=.3)   = -0.27083461355368116

  stmp = theis(0.2_sp, 0.0_sp, (/Stest , Ktest /),   (/Qwtest , Ltest /) )
  isgood = isgood .and. (nint(stmp*1000)         .EQ. 0)
  stmp = theis(0.2_sp, 0.1_sp, (/Stest , Ktest /),   (/Qwtest , Ltest /) )
  isgood = isgood .and. (nint(stmp*1000)         .EQ. -175)
  stmp = theis(0.3_sp, 0.2_sp, (/Stest , Ktest /),   (/Qwtest , Ltest /) )
  isgood = isgood .and. (nint(stmp*1000)         .EQ. -142)
  stmp = theis(0.3_sp, 0.3_sp, (/Stest , Ktest /),   (/Qwtest , Ltest /) )
  isgood = isgood .and. (nint(stmp*1000)         .EQ. -271)
  dtmp = theis(0.2_dp, 0.0_dp, (/Stestd, Ktestd/),   (/Qwtestd, Ltestd/) )
  isgood = isgood .and. (nint(dtmp*1000000)      .EQ. 0)
  dtmp = theis(0.2_dp, 0.1_dp, (/Stestd, Ktestd/),   (/Qwtestd, Ltestd/) )
  isgood = isgood .and. (nint(dtmp*1000000)      .EQ. -174580)
  dtmp = theis(0.3_dp, 0.2_dp, (/Stestd, Ktestd/),   (/Qwtestd, Ltestd/) )
  isgood = isgood .and. (nint(dtmp*1000000)      .EQ. -142128)
  dtmp = theis(0.3_dp, 0.3_dp, (/Stestd, Ktestd/),   (/Qwtestd, Ltestd/) )
  isgood = isgood .and. (nint(dtmp*1000000)      .EQ. -270835)
  !sp
  write (*,*) 'Theissp(r=.2,t=.0)     =', theis(0.2_sp, 0.0_sp, (/Stest , Ktest /),   (/Qwtest , Ltest /) )
  write (*,*) 'Theissp(r=.2,t=.1)     =', theis(0.2_sp, 0.1_sp, (/Stest , Ktest /),   (/Qwtest , Ltest /) )
  write (*,*) 'Theissp(r=.3,t=.2)     =', theis(0.3_sp, 0.2_sp, (/Stest , Ktest /),   (/Qwtest , Ltest /) )
  write (*,*) 'Theissp(r=.3,t=.3)     =', theis(0.3_sp, 0.3_sp, (/Stest , Ktest /),   (/Qwtest , Ltest /) )
  !dp
  write (*,*) 'Theisdp(r=.2,t=.0)     =', theis(0.2_dp, 0.0_dp, (/Stestd, Ktestd/),   (/Qwtestd, Ltestd/) )
  write (*,*) 'Theisdp(r=.2,t=.1)     =', theis(0.2_dp, 0.1_dp, (/Stestd, Ktestd/),   (/Qwtestd, Ltestd/) )
  write (*,*) 'Theisdp(r=.3,t=.2)     =', theis(0.3_dp, 0.2_dp, (/Stestd, Ktestd/),   (/Qwtestd, Ltestd/) )
  write (*,*) 'Theisdp(r=.3,t=.3)     =', theis(0.3_dp, 0.3_dp, (/Stestd, Ktestd/),   (/Qwtestd, Ltestd/) )

  write (*,*) ' '

  write (*,*) "EXTENDED THEIS' SOLUTION IN 2D"
  write (*,*) '-------------------------------------------------------------------------'

  ! ext_theis2d_dp_vec(r=           1 ,t=          50 )  =   -2.6724678924208556
  ! ext_theis2d_dp_vec(r=           1 ,t=         100 )  =   -3.4409275281733089
  ! ext_theis2d_dp_vec(r=           1 ,t=        1000 )  =   -5.7384083577267218
  ! ext_theis2d_dp_vec(r=           2 ,t=          50 )  =   -1.2250879935634749
  ! ext_theis2d_dp_vec(r=           2 ,t=         100 )  =   -1.8423690881291142
  ! ext_theis2d_dp_vec(r=           2 ,t=        1000 )  =   -4.0012094551152613
  ! ext_theis2d_dp_vec(r=           3 ,t=          50 )  =   -0.60506500331545221
  ! ext_theis2d_dp_vec(r=           3 ,t=         100 )  =   -1.0950539046041157
  ! ext_theis2d_dp_vec(r=           3 ,t=        1000 )  =   -3.0545777884298797

  fpoints_dp    =             ext_theis2d(&
       rad     =   (/1._dp,2._dp,3._dp/),&
       time    =   (/50.0_dp,100.0_dp,1000.0_dp/),&
       params  =   (/TGtestd, vartestd, corrtestd, Stestd/),&
       inits   =   (/Qwtestd/))

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        fpoints2_dp(m,n) =  ext_theis2d(&
             rad     =   real(m,dp),&
             time    =   real(425_i4*n**2_i4-1225_i4*n+850_i4,dp),&  !polynomial with p(1)=50 p(2)=100 p(3)=1000
             params  =   (/TGtestd, vartestd, corrtestd, Stestd/),&
             inits   =   (/Qwtestd/))
     end do
  end do

  fpoints3_dp =               reshape(&
       ext_theis2d(&
       grid    =   grid_dp,&
       params  =   (/TGtestd, vartestd, corrtestd, Stestd/),&
       inits   =   (/Qwtestd/)),(/3,3/))

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        isgood = isgood .and. eq(fpoints_dp(m,n),fpoints2_dp(m,n))
        isgood = isgood .and. eq(fpoints_dp(m,n),fpoints3_dp(m,n))
     end do
  end do

  dtmp = fpoints_dp(1,1)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -2672468)
  dtmp = fpoints_dp(1,2)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -3440928)
  dtmp = fpoints_dp(1,3)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -5738408)
  dtmp = fpoints_dp(2,1)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -1225088)
  dtmp = fpoints_dp(2,2)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -1842369)
  dtmp = fpoints_dp(2,3)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -4001209)
  dtmp = fpoints_dp(3,1)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -605065)
  dtmp = fpoints_dp(3,2)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -1095054)
  dtmp = fpoints_dp(3,3)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -3054578)

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        write(*,*) "ext_theis2d_dp_vec(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints_dp(m,n)
        write(*,*) "ext_theis2d_dp_sgl(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints2_dp(m,n)
        write(*,*) "ext_theis2d_dp_gri(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints3_dp(m,n)
     end do
  end do

  !### sp #########################################################################
  ! ext_theis2d_sp_vec(r=           1 ,t=          50 )  =   -2.67246795
  ! ext_theis2d_sp_vec(r=           1 ,t=         100 )  =   -3.44092774
  ! ext_theis2d_sp_vec(r=           1 ,t=        1000 )  =   -5.73840857
  ! ext_theis2d_sp_vec(r=           2 ,t=          50 )  =   -1.22508800
  ! ext_theis2d_sp_vec(r=           2 ,t=         100 )  =   -1.84236920
  ! ext_theis2d_sp_vec(r=           2 ,t=        1000 )  =   -4.00120974
  ! ext_theis2d_sp_vec(r=           3 ,t=          50 )  =   -0.605064988
  ! ext_theis2d_sp_vec(r=           3 ,t=         100 )  =   -1.09505391
  ! ext_theis2d_sp_vec(r=           3 ,t=        1000 )  =   -3.05457783

  fpoints_sp             =    ext_theis2d(&
       rad     =   (/1._sp,2._sp,3._sp/),&
       time    =   (/50.0_sp,100.0_sp,1000.0_sp/),&
       params  =   (/TGtest, vartest, corrtest, Stest/),&
       inits   =   (/Qwtest/))

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        fpoints2_sp(m,n) =  ext_theis2d(&
             rad     =   real(m,sp),&
             time    =   real(425_i4*n**2_i4-1225_i4*n+850_i4,sp),&  !polynomial with p(1)=50 p(2)=100 p(3)=1000
             params  =   (/TGtest, vartest, corrtest, Stest/),&
             inits   =   (/Qwtest/))
     end do
  end do

  fpoints3_sp             =   reshape(&
       ext_theis2d(&
       grid    =   grid_sp,&
       params  =   (/TGtest, vartest, corrtest, Stest/),&
       inits   =   (/Qwtest/)),(/3,3/))

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        isgood = isgood .and. eq(fpoints_sp(m,n),fpoints2_sp(m,n))
        isgood = isgood .and. eq(fpoints_sp(m,n),fpoints3_sp(m,n))
     end do
  end do

  stmp = fpoints_sp(1,1)
  isgood = isgood .and. (nint(stmp*1000) .eq. -2672)
  stmp = fpoints_sp(1,2)
  isgood = isgood .and. (nint(stmp*1000) .eq. -3441)
  stmp = fpoints_sp(1,3)
  isgood = isgood .and. (nint(stmp*1000) .eq. -5738)
  stmp = fpoints_sp(2,1)
  isgood = isgood .and. (nint(stmp*1000) .eq. -1225)
  stmp = fpoints_sp(2,2)
  isgood = isgood .and. (nint(stmp*1000) .eq. -1842)
  stmp = fpoints_sp(2,3)
  isgood = isgood .and. (nint(stmp*1000) .eq. -4001)
  stmp = fpoints_sp(3,1)
  isgood = isgood .and. (nint(stmp*1000) .eq. - 605)
  stmp = fpoints_sp(3,2)
  isgood = isgood .and. (nint(stmp*1000) .eq. -1095)
  stmp = fpoints_sp(3,3)
  isgood = isgood .and. (nint(stmp*1000) .eq. -3055)

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        write(*,*) "ext_theis2d_sp_vec(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints_sp(m,n)
        write(*,*) "ext_theis2d_sp_sgl(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints2_sp(m,n)
        write(*,*) "ext_theis2d_sp_gri(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints3_sp(m,n)
     end do
  end do

  write (*,*) ' '

  write (*,*) "EXTENDED THEIS' SOLUTION IN 3D"
  write (*,*) '-------------------------------------------------------------------------'

  ! ext_theis3d_dp_vec(r=           1 ,t=          50 )  =   -2.6719739969853862
  ! ext_theis3d_dp_vec(r=           1 ,t=         100 )  =   -3.4114799964304905
  ! ext_theis3d_dp_vec(r=           1 ,t=        1000 )  =   -5.4641666480313242
  ! ext_theis3d_dp_vec(r=           2 ,t=          50 )  =   -1.2452670522580507
  ! ext_theis3d_dp_vec(r=           2 ,t=         100 )  =   -1.8293707976344475
  ! ext_theis3d_dp_vec(r=           2 ,t=        1000 )  =   -3.7458081837503667
  ! ext_theis3d_dp_vec(r=           3 ,t=          50 )  =  -0.64353916624054508
  ! ext_theis3d_dp_vec(r=           3 ,t=         100 )  =   -1.1069066253083155
  ! ext_theis3d_dp_vec(r=           3 ,t=        1000 )  =   -2.8268598328483159

  fpoints_dp    =             ext_theis3d(&
       rad     =   (/1._dp,2._dp,3._dp/),&
       time    =   (/50.0_dp,100.0_dp,1000.0_dp/),&
       params  =   (/Ktestd, vartestd, corrtestd, Stestd, anisotestd/),&
       inits   =   (/Qwtestd, Ltestd/))

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        fpoints2_dp(m,n) =   ext_theis3d(&
             rad     =   real(m,dp),&
             time    =   real(425_i4*n**2_i4-1225_i4*n+850_i4,dp),&  !polynomial with p(1)=50 p(2)=100 p(3)=1000
             params  =   (/Ktestd, vartestd, corrtestd, Stestd, anisotestd/),&
             inits   =   (/Qwtestd, Ltestd/))
     end do
  end do

  fpoints3_dp             =   reshape(&
       ext_theis3d(&
       grid    =   grid_dp,&
       params  =   (/Ktestd, vartestd, corrtestd, Stestd, anisotestd/),&
       inits   =   (/Qwtestd, Ltestd/)),(/3,3/))

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        isgood = isgood .and. eq(fpoints_dp(m,n), fpoints2_dp(m,n))
        isgood = isgood .and. eq(fpoints_dp(m,n), fpoints3_dp(m,n))
     end do
  end do

  dtmp = fpoints_dp(1,1)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -2671974)
  dtmp = fpoints_dp(1,2)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -3411480)
  dtmp = fpoints_dp(1,3)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -5464167)
  dtmp = fpoints_dp(2,1)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -1245267)
  dtmp = fpoints_dp(2,2)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -1829371)
  dtmp = fpoints_dp(2,3)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -3745808)
  dtmp = fpoints_dp(3,1)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -643539)
  dtmp = fpoints_dp(3,2)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -1106907)
  dtmp = fpoints_dp(3,3)
  isgood = isgood .and. (nint(dtmp*1000000) .eq. -2826860)

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        write(*,*) "ext_theis3d_dp_vec(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints_dp(m,n)
        write(*,*) "ext_theis3d_dp_sgl(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints2_dp(m,n)
        write(*,*) "ext_theis3d_dp_gri(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints3_dp(m,n)
     end do
  end do

  ! ext_theis3d_sp_vec(r=           1 ,t=          50 )  =   -2.67197418
  ! ext_theis3d_sp_vec(r=           1 ,t=         100 )  =   -3.41148019
  ! ext_theis3d_sp_vec(r=           1 ,t=        1000 )  =   -5.46416712
  ! ext_theis3d_sp_vec(r=           2 ,t=          50 )  =   -1.24526703
  ! ext_theis3d_sp_vec(r=           2 ,t=         100 )  =   -1.82937086
  ! ext_theis3d_sp_vec(r=           2 ,t=        1000 )  =   -3.74580836
  ! ext_theis3d_sp_vec(r=           3 ,t=          50 )  =  -0.643539190
  ! ext_theis3d_sp_vec(r=           3 ,t=         100 )  =   -1.10690665
  ! ext_theis3d_sp_vec(r=           3 ,t=        1000 )  =   -2.82685995

  fpoints_sp              =   ext_theis3d(&
       rad     =   (/1._sp,2._sp,3._sp/),&
       time    =   (/50.0_sp,100.0_sp,1000.0_sp/),&
       params  =   (/Ktest, vartest, corrtest, Stest, anisotest/),&
       inits   =   (/Qwtest, Ltest/))

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        fpoints2_sp(m,n) =   ext_theis3d(&
             rad     =   real(m,sp),&
             time    =   real(425_i4*n**2_i4-1225_i4*n+850_i4,sp),&  !polynomial with p(1)=50 p(2)=100 p(3)=1000
             params  =   (/Ktest, vartest, corrtest, Stest, anisotest/),&
             inits   =   (/Qwtest, Ltest/))
     end do
  end do

  fpoints3_sp             =   reshape(&
       ext_theis3d(&
       grid    =   grid_sp,&
       params  =   (/Ktest, vartest, corrtest, Stest, anisotest/),&
       inits   =   (/Qwtest, Ltest/)),(/3,3/))

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        isgood = isgood .and. eq(fpoints_sp(m,n), fpoints2_sp(m,n))
        isgood = isgood .and. eq(fpoints_sp(m,n), fpoints3_sp(m,n))
     end do
  end do

  stmp = fpoints_sp(1,1)
  isgood = isgood .and. (nint(stmp*1000) .eq. -2672)
  stmp = fpoints_sp(1,2)
  isgood = isgood .and. (nint(stmp*1000) .eq. -3411)
  stmp = fpoints_sp(1,3)
  isgood = isgood .and. (nint(stmp*1000) .eq. -5464)
  stmp = fpoints_sp(2,1)
  isgood = isgood .and. (nint(stmp*1000) .eq. -1245)
  stmp = fpoints_sp(2,2)
  isgood = isgood .and. (nint(stmp*1000) .eq. -1829)
  stmp = fpoints_sp(2,3)
  isgood = isgood .and. (nint(stmp*1000) .eq. -3746)
  stmp = fpoints_sp(3,1)
  isgood = isgood .and. (nint(stmp*1000) .eq. -644)
  stmp = fpoints_sp(3,2)
  isgood = isgood .and. (nint(stmp*1000) .eq. -1107)
  stmp = fpoints_sp(3,3)
  isgood = isgood .and. (nint(stmp*1000) .eq. -2827)

  do m=1_i4,3_i4
     do n=1_i4,3_i4
        write(*,*) "ext_theis3d_sp_vec(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints_sp(m,n)
        write(*,*) "ext_theis3d_sp_sgl(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints2_sp(m,n)
        write(*,*) "ext_theis3d_sp_gri(r=",m,",t=",425_i4*n**2_i4-1225_i4*n+850_i4,")  = ", fpoints3_sp(m,n)
     end do
  end do

  write (*,*) ' '

  write (*,*) '-------------------------------------------------------------------------'
  write (*,*) '-------------------------------------------------------------------------'
  if (isgood) then
     write(*,*) 'mo_pumpingtests ', color('o.k.', c_green)
  else
     write(*,*) 'mo_pumpingtests ', color('failed', c_red)
  endif

end program test


      module MOD_DTDR
      contains
C**********  MODULNAME: DTDR      ******* 01/06/87  20.29.23.******    82 KARTEN
c*** this version was for the IMSL routine IPERK
c      SUBROUTINE DTDR(N,R,T,TPRIME)
c*** present version for the numerical recipes routines
      SUBROUTINE DTDR(R,T,TPRIME)
C*******************************************************************************
C***  THIS SUBROUTINE HELPS TO CALCULATE THE TEMPERATURE STRUCTURE OF A
C***  SPHERICAL, GREY ATMOSPHERE.
C***  IT IS A FORMAL PARAMETER OF THE IMSL-ROUTINE "IVPRK"(DVERK) AND CALLED
C***  ONLY FROM THERE.
C***  THE DIFFERENTIAL EQUATION IS WRITTEN: Y' = F(X,Y)
C***  HERE:  DT/DR = FUNCTION OF (R,T)
C***  THE EDDINGTON FACTOR F IS ASSUMED TO BE 1/3 INSIDE THE RADIUS R1, I.E.
C***  WHERE TAU=1.
C***  OUTSIDE THE RADIUS R13, I.E. WHERE TAU=1/3, WE ASSUME GEOMETRICAL DILUTION
C***  DILUTION OF THE RADIATION FIELD AS FOR A UNIFORM RADIATING SPHERE
C***  OF RADIUS R23
C***  F IS INTERPOLATED IN THE INTERJACENT REGION
C*******************************************************************************

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

      PARAMETER ( ONE = 1.D+0, TWO = 2.D+0, THREE = 3.D+0 )

      COMMON /COMTEFF/ TEFF,TMIN,TMODIFY,SPHERIC
C***  OPAROSS FROM SUBROUTINE GREY
      COMMON /COMDTDR/ OPAMEAN,R23COM,R1COM,R13COM

      IF (R .LE. R1 COM) THEN
C***     OPTICALLY THICK REGION
          FEDDI=.33333333333333
          BFAC=0.
      ELSE IF (R .LT. R13COM) THEN
C***  INTERPOLATED REGION AROUND R23, I.E. BETWEEN TAU=1/3 AND TAU=1
C***  F1 = FEDDI AT R1
      F1=0.333333333333
C***  F2 = FEDDI AT R13
      R2=R13COM*R13COM
         SMUE=SQRT(ONE-R23COM*R23COM/R2)
      F2=((SMUE+ONE)*SMUE+ONE)/THREE
C***  F3 = FPRIME AT R1
      F3=0.
C***  F4 = FPRIME AT R13
      F4=(TWO+ONE/SMUE)*R23COM*R23COM/R2/R13COM/THREE
C***  POLYNOMIAL COEFFICIENTS, SEE SUBROUTINE CUBIC
      D1=ONE/(R13COM-R1COM)
      D2=D1*D1
      D3=D1*D2
      D23=D2/THREE
      H11=D3
      H12=-D3
      H13=D23
      H14=TWO*D23
      H21=-D1
      H22=TWO*D1
      H23=-0.333333333333333D0
      H24=-0.666666666666666D0
      H31=-D3
      H32=D3
      H33=-TWO*D23
      H34=-D23
      H41=TWO*D1
      H42=-D1
      H43=0.666666666666666D0
      H44=0.333333333333333D0
C***  CALCULATE POLYNOMIAL COEFFICIENTS: P(VECTOR) = H(MATRIX) * F(VECTOR)
      P1=H11*F1+H12*F2+H13*F3+H14*F4
      P2=H21*F1+H22*F2+H23*F3+H24*F4
      P3=H31*F1+H32*F2+H33*F3+H34*F4
      P4=H41*F1+H42*F2+H43*F3+H44*F4
C***  EVALUATION OF THE POLYNOMIAL
      FEDDI=P1*(R-R1COM)**3 + P2*(R-R1COM)
     +     +P3*(R13COM-R)**3+P4*(R13COM-R)
C***  ... AND ITS DERIVATIVE
      FPRIME=THREE*P1*(R-R1COM)**2 + P2
     -      -THREE*P3*(R13COM-R)**2-P4
          BFAC=(THREE*FEDDI-ONE)/R+FPRIME
      ELSE
          R2=R*R
         SMUE=SQRT(ONE-R23COM*R23COM/R2)
          FEDDI=((SMUE+ONE)*SMUE+ONE)/THREE
          FPRIME=(TWO+ONE/SMUE)*R23COM*R23COM/R2/R/THREE
          BFAC=(THREE*FEDDI-ONE)/R+FPRIME
      ENDIF
      TT=TEFF/T
      TT3=TT*TT*TT
      TPRIME=-BFAC*T/4./FEDDI-OPAMEAN/R/R*TEFF/16./FEDDI*TT3
      RETURN
      END subroutine
      end module


        subroutine cauchy_ppart2(x,nx,xres,fx,pint)

!     -----------------------------------------------
!     Returns principal part of int(x,fx/(x-xres))
!     -----------------------------------------------

        implicit none
        integer, parameter :: idebug = 0

        integer   nx
        real xres
        real x(nx), fx(nx)
        real pint
!       ---------------
!       local variables
!       ---------------
        logical, parameter :: use_linear = .true.

        integer :: i
        real, dimension(nx-1) :: va0,va1,va2
        real :: a0,a1,a2,  x1,x2,x3,  f1,f2,f3
        real :: tmp1,tmp2,  d1,d2,d3,  d31,d21
        real :: value0,value1,value2, xleft,xright
        real :: v0,v1,v2
        intrinsic :: log

!       ------------------------------------------------------------
!       compute piecewise quadratic over
!       [x(i-1), x(i), x(i+1)] as    a0 + a1*(x-xres)+ a2*(x-xres)^2
!
!       assume xres is not exactly one of x(1:n)
!       ------------------------------------------------------------
        do i=2,nx-1
           x1 = x(i-1)
           x2 = x(i)
           x3 = x(i+1)
           f1 = fx(i-1)
           f2 = fx(i)
           f3 = fx(i+1)
!          --------------------------------------
!          find a0,a1,a2 such that
!
!          a0 + a1*(x1-xres) + a2*(x1-xres)^2 = f1
!          a0 + a1*(x2-xres) + a2*(x2-xres)^2 = f2
!          a0 + a1*(x3-xres) + a2*(x3-xres)^2 = f3
!          --------------------------------------
           d1 = x1-xres
           d2 = x2-xres
           d3 = x3-xres
           d31 = (d3-d1)*(d3+d1)
           d21 = (d2-d1)*(d2+d1)
!          ----------------------------------
!          a1 * ( d3-d1 ) + a2*( d31 ) = f3-f1
!          a1 * ( d2-d1 ) + a2*( d21 ) = f2-f1
!          -----------------------------------
           tmp1 = ((f3-f1)*(d2-d1) - (f2-f1)*(d3-d1))
           tmp2 = ( d31*(d2-d1) - d21*(d3-d1) )

           a2 = tmp1/tmp2
           a1 = ((f3-f1) - a2*d31 )/(d3-d1)
           a0 = f1 - a2*d1*d1 - a1*d1

           va0(i) = a0
           va1(i) = a1
           va2(i) = a2
       enddo

!       --------------------------------------------
!       special handling for first interval
!       --------------------------------------------
       if (use_linear) then
!         ------------------------------
!         backward compatible with df_dv
!
!         a0 + a1*(x1-xres) = f1
!         a0 + a1*(x2-xres) = f2
!         ------------------------------
               x1 = x(1)
               x2 = x(2)
               f1 = fx(1)
               f2 = fx(2)

               a1 = (f2-f1)/(x2-x1)
               a0 = f1 - a1*(x1-xres)
               a2 = 0.0

               va0(1) = a0
               va1(1) = a1
               va2(1) = a2
       else
!        ------------------------------------
!        use quadratic even in first interval
!        ------------------------------------
               va0(1) = va0(2)
               va1(1) = va1(2)
               va2(1) = va2(2)

       endif

       if (idebug.ge.1) then
         do i=1,nx-1
          write(*,*) 'i,a0,a1,a2 ',i,va0(i),va1(i),va2(i)
         enddo
       endif

!      ----------------------------------------------
!      sum contribtions from a0
!
!      int( 1/(x-xres), x=xleft..xright ) = log( (xright-xres)/(xleft-xres) )
!
!      sum contributions from a1
!
!      int( a1, x=xleft..xright) = (xright-xleft)*a1
!
!      sum contributions from a2
!
!      int( a2*(x-xres), x=xleft..xright) =
!      = (a2/2) * ( (xright-xres)**2 - (xleft-xres)**2)
!      = (a2/2) * ( (xright+xleft - 2*xres) * (xright-xleft) )
!      ----------------------------------------------
       value0 = 0.0d0
       value1 = 0.0d0
       value2 = 0.0d0

       do i=1,nx-1
          a0 = va0(i)
          a1 = va1(i)
          a2 = va2(i)

          xleft = x(i)
          xright = x(i+1)

          v0 = a0*log( abs( (xright-xres)/(xleft-xres) ) )
          v1 = a1*(xright-xleft)
          v2 = a2*(xright+xleft-2.0d0*xres)*(xright-xleft)

          value0 = value0 + v0
          value1 = value1 + v1
          value2 = value2 + v2

          if (idebug.ge.1) then
            write(*,*) 'i,v0,v1,v2 ',i,v0,v1,v2
          endif

        enddo
        value2 = value2*0.5d0

        pint = value0 + value1 + value2

        return
        end subroutine cauchy_ppart2

!
!*************************************************************************
!

        subroutine cauchy_ppart6(x,nx,xres,nfx,fx,pint,is_uniform)
!     -----------------------------------------------
!     Returns principal part of int(x,fx/(x-xres))
!     -----------------------------------------------
        implicit none
        integer, parameter :: idebug = 0

        integer   nx,nfx
        real*8 xres
        real*8 x(nx), fx(nx,nfx)
        real*8 pint(nfx)
        logical  :: is_uniform
!       ---------------
!       local variables
!       ---------------

        integer :: i,j,ih,nlog
        real*8, dimension(nx) :: vx, vlogt
        real*8 :: a0,a1,a2,  x1,x2,x3,  f1,f2,f3
        real*8 :: tmp1,tmp2,  d1,d2,d3,  d31,d21
        real*8 :: d3md1, d2md1
        real*8, dimension(nfx) :: value0,value1,value2
        real*8 :: xleft,xright
        real*8 :: v0,v1,v2
        real*8 :: xc,a,b

        intrinsic :: log,abs,mod

        logical, parameter ::use_approx = .false.

        logical, parameter :: use_pade = .true.

        real*8 ::  h,t,dx,t2, logt
        real*8, parameter :: zero=0.0d0
        real*8, parameter :: one=1.0d0
        real*8, parameter :: two=2.0d0
        real*8, parameter :: three=3.0d0
        real*8, parameter :: four=4.0d0
        real*8, parameter :: five=5.0d0
        real*8, parameter :: six=6.0d0
        real*8, parameter :: seven=7.0d0
        real*8, parameter :: eight=8.0d0
        logical :: isok

!       ------------------------------------------------------------
!       compute piecewise quadratic over
!       [x(i-1), x(i), x(i+1)] as    a0 + a1*(x-xres)+ a2*(x-xres)^2
!
!       assume xres is not exactly one of x(1:n)
!       ------------------------------------------------------------

        value0 = zero
        value1 = zero
        value2 = zero
        pint = zero

!       ------------------
!       precompute the logs
!       ------------------
        nlog = (nx-1)/2
        do ih=1,nlog
           i = 2*ih
           x1 = x(i-1)
           x2 = x(i)
           x3 = x(i+1)
           vx(ih) = abs( (x3-xres)/(x1-xres) )
        enddo
        call vlog( vlogt, vx, nlog )

        if (is_uniform) then

        dx = (x(nx)-x(1))/dble(nx-1)
        h = dx

        do j=1,nfx
        do ih=1,nlog
           i = 2*ih

           x1 = x(i-1)
           x2 = x(i)
           x3 = x(i+1)

             d2 = x2-xres
             d1 = d2 - h
             d3 = d2 + h

           f1 = fx(i-1,j)
           f2 = fx(i,j)
           f3 = fx(i+1,j)

!          --------------------------------------
!          find a0,a1,a2 such that
!
!          a0 + a1*(x1-xres) + a2*(x1-xres)^2 = f1
!          a0 + a1*(x2-xres) + a2*(x2-xres)^2 = f2
!          a0 + a1*(x3-xres) + a2*(x3-xres)^2 = f3
!
!          a0 + a1*(x2-xres) + a2*(x2-xres)^2 = f2
!          a0 + a1*((x2-xres)-h) + a2*((x2-xres)-h)^2 = f1
!          a0 + a1*((x2-xres)+h) + a2*((x2-xres)+h)^2 = f3
!
!          f2 + a1*h + a2*(h*h + 2*h*(x2-xres)) = f3
!          f2 - a1*h + a2*(h*h - 2*h*(x2-xres)) = f1
!          --------------------------------------

!             ---------------------
!             d31 = (d3-d1)*(d3+d1)
!             d21 = (d2-d1)*(d2+d1)
!
!          a1 * ( d3-d1 ) + a2*( d31 ) = f3-f1
!          a1 * ( d2-d1 ) + a2*( d21 ) = f2-f1
!          -----------------------------------

             a2 = (f3-two*f2+f1)/(two*h*h)
             a1 = (f3-f1)/(two*h) - two*a2*d2
             a0 = f2 - (a1*d2 + a2*d2*d2)

             logt = vlogt(ih)
             value0(j) = value0(j) + a0*logt
             value1(j) = value1(j) + a1
             value2(j) = value2(j) + a2*d2

            enddo
            enddo

            value1 = value1 * (two*h)
            value2 = value2 * (four*h)

        else

        do j=1,nfx
        do ih=1,nlog
           i = 2*ih
           x1 = x(i-1)
           x2 = x(i)
           x3 = x(i+1)

!          --------------------------------------
!          find a0,a1,a2 such that
!
!          a0 + a1*(x1-xres) + a2*(x1-xres)^2 = f1
!          a0 + a1*(x2-xres) + a2*(x2-xres)^2 = f2
!          a0 + a1*(x3-xres) + a2*(x3-xres)^2 = f3
!          --------------------------------------
             d1 = x1-xres
             d2 = x2-xres
             d3 = x3-xres
             d31 = (d3-d1)*(d3+d1)
             d21 = (d2-d1)*(d2+d1)
!          ----------------------------------
!          a1 * ( d3-d1 ) + a2*( d31 ) = f3-f1
!          a1 * ( d2-d1 ) + a2*( d21 ) = f2-f1
!          -----------------------------------
             logt = log( abs( (x3-xres)/(x1-xres) ))

             f1 = fx(i-1,j)
             f2 = fx(i,j)
             f3 = fx(i+1,j)

             tmp1 = ((f3-f1)*(d2-d1) - (f2-f1)*(d3-d1))
             tmp2 = ( d31*(d2-d1) - d21*(d3-d1) )

             a2 = tmp1/tmp2
             a1 = ((f3-f1) - a2*d31 )/(d3-d1)
             a0 = f1 - a2*d1*d1 - a1*d1
!
!         f(x) = a0 + a1*(x-xres) + a2*(x-xres)^2
!
!         int( f(x)/(x-xres), x=x1..x3 ) =
!         a0 * int( 1/(x-xres), x=x1..x3 ) +
!         a1 * int( 1, x=x1..x3)
!         a2 * int( (x-xres), x=x1..x3 )
!

             logt = vlogt(ih)
             value0(j) = value0(j) + a0 * logt
             value1(j) = value1(j) + a1 * (x3-x1)
             value2(j) = value2(j) + a2 * (x3-x1)*((x3-xres)+(x1-xres))

              enddo

          enddo
          endif

!         ----------------------------------
!         do we have an odd number of intervals?
!         if so, need to account for last interval
!         ----------------------------------
          if (mod(nx,2).eq.0) then

           x1 = x(nx-2)
           x2 = x(nx-1)
           x3 = x(nx)

             d1 = x1-xres
             d2 = x2-xres
             d3 = x3-xres
             d31 = (d3-d1)*(d3+d1)
             d21 = (d2-d1)*(d2+d1)

             logt = log( abs( (x3-xres)/(x2-xres) ))

           do j=1,nfx

           f1 = fx(nx-2,j)
           f2 = fx(nx-1,j)
           f3 = fx(nx,j)

!          --------------------------------------
!          find a0,a1,a2 such that
!
!          a0 + a1*(x1-xres) + a2*(x1-xres)^2 = f1
!          a0 + a1*(x2-xres) + a2*(x2-xres)^2 = f2
!          a0 + a1*(x3-xres) + a2*(x3-xres)^2 = f3
!          --------------------------------------
!          ----------------------------------
!          a1 * ( d3-d1 ) + a2*( d31 ) = f3-f1
!          a1 * ( d2-d1 ) + a2*( d21 ) = f2-f1
!          -----------------------------------
             tmp1 = ((f3-f1)*(d2-d1) - (f2-f1)*(d3-d1))
             tmp2 = ( d31*(d2-d1) - d21*(d3-d1) )

             a2 = tmp1/tmp2
             a1 = ((f3-f1) - a2*d31 )/(d3-d1)
             a0 = f1 - a2*d1*d1 - a1*d1
!
!         f(x) = a0 + a1*(x-xres) + a2*(x-xres)^2
!
!         int( f(x)/(x-xres), x=x2..x3 ) =
!         a0 * int( 1/(x-xres), x=x2..x3 ) +
!         a1 * int( 1, x=x1..x3)
!         a2 * int( (x-xres), x=x2..x3 )
!
             value1(j) = value1(j) + a1 * (x3-x2)
             value2(j) = value2(j) + a2 * (x3-x2)*(x3+x2-two*xres)
             value0(j) = value0(j) + a0 * logt
           enddo

           endif

          value2 = value2 / two
          pint = value0 + value1 + value2

          return

        end subroutine cauchy_ppart6


! An example of the diffusion equation.
module diffusion

  implicit none

  ! Define the attributes of the model.
  type :: diffusion_model
     real :: dt
     real :: t
     real :: t_end

     integer :: n_x
     integer :: n_y

     real :: dx
     real :: dy

     real, pointer :: density(:,:)
     real, pointer :: density_tmp(:,:)
  end type diffusion_model

contains

  ! Initializes the model with values read from a file.
  subroutine initialize_from_file(model, config_file)
    character (len=*), intent (in) :: config_file
    type (diffusion_model), intent (out) :: model

    open(15, file=config_file)
    read(15, *) model%dt, model%t_end, model%n_x, model%n_y
    close(15)
    call initialize(model)
  end subroutine initialize_from_file

  ! Initializes the model with default hardcoded values.
  subroutine initialize_from_defaults(model)
    type (diffusion_model), intent (out) :: model

    model%dt = 1.
    model%t_end = 20.
    model%n_x = 10
    model%n_y = 20
    call initialize(model)
  end subroutine initialize_from_defaults

  ! Allocates memory and sets values for either initialization technique.
  subroutine initialize(model)
    type (diffusion_model), intent (inout) :: model

    model%t = 0.
    model%dx = 1.
    model%dy = 1.

    allocate(model%density(model%n_y, model%n_x))
    allocate(model%density_tmp(model%n_y, model%n_x))

    model%density = 0.
    model%density_tmp = 0.

    call set_boundary_conditions(model%density)
    call set_boundary_conditions(model%density_tmp)
  end subroutine initialize

  ! Sets boundary conditions on values array.
  subroutine set_boundary_conditions(z)
    implicit none
    real, dimension (:,:), intent (out) :: z
    integer :: i, top_x

    top_x = size(z, 2)-1

    do i = 0, top_x
       z(1,i+1) = 0.25*top_x**2 - (i - 0.5*top_x)**2
    end do
  end subroutine set_boundary_conditions

  ! Frees memory when program completes.
  subroutine cleanup(model)
    type (diffusion_model), intent (inout) :: model

    deallocate (model%density)
    deallocate (model%density_tmp)
  end subroutine cleanup

  ! Steps the diffusion model forward in time.
  subroutine advance_in_time(model)
    type (diffusion_model), intent (inout) :: model

    call solve_2d(model)
    model%density = model%density_tmp
    model%t = model%t + model%dt
  end subroutine advance_in_time

  ! The solver for the two-dimensional diffusion equation.
  subroutine solve_2d(model)
    type (diffusion_model), intent (inout) :: model

    real, parameter :: rho = 0.
    real :: dx2
    real :: dy2
    real :: dx2_dy2_rho
    real :: coef
    integer :: i, j

    dx2 = model%dx**2
    dy2 = model%dy**2
    dx2_dy2_rho = dx2 * dy2 * rho
    coef = model%dt / (2. * (dx2 + dy2))

    do i = 2, model%n_y-1
       do j = 2, model%n_x-1
          model%density_tmp(i,j) = coef * ( &
               dx2*(model%density(i-1,j) + model%density(i+1,j)) + &
               dy2*(model%density(i,j-1) + model%density(i,j+1)) - &
               dx2_dy2_rho )
       end do
    end do
  end subroutine solve_2d

  ! A helper routine for displaying model parameters.
  subroutine print_info(file_unit, model)
    type (diffusion_model), intent (in) :: model
    integer :: file_unit

    write(file_unit,"(a10, i8)") "n_x:", model%n_x
    write(file_unit,"(a10, i8)") "n_y:", model%n_y
    write(file_unit,"(a10, f8.2)") "dx:", model%dx
    write(file_unit,"(a10, f8.2)") "dy:", model%dy
    write(file_unit,"(a10, f8.2)") "dt:", model%dt
    write(file_unit,"(a10, f8.2)") "t:", model%t
    write(file_unit,"(a10, f8.2)") "t_end:", model%t_end
  end subroutine print_info

  ! A helper routine that prints the current state of the model.
  subroutine print_values(file_unit, model)
    type (diffusion_model), intent (in) :: model
    integer :: file_unit, i, j
    character(len=30) :: rowfmt

    write(rowfmt,'(a,i4,a)') '(', model%n_x, '(1x,f6.1))'
    do i = 1, model%n_y
       write(file_unit,fmt=rowfmt) model%density(i,:)
    end do
  end subroutine print_values

end module diffusion


module quadglobal
use mpmodule
implicit none
integer ndebug, ndigits, nerror, nquadl
end module

program tquadts

!   David H. Bailey      2002-11-05
!   This is the ARPREC Fortran-90 version.

!   This software is provided for research purposes only.
!   Commercial usage requires license agreement.

!   This work was supported by the Director, Office of Science, Division
!   of Mathematical, Information, and Computational Sciences of the
!   U.S. Department of Energy under contract number DE-AC03-76SF00098.

!   This program demonstrates the quadrature routine 'quadts', which employs
!   the tanh-sinh function.  The function quadts is suitable to integrate
!   a function that is continuous, infinitely differentiable and integrable on a
!   finite open interval.  It can also be used for certain integrals on
!   infinite intervals, by making a suitable change of variable -- see below.
!   While this routine is not quite as efficient as quadgs for functions that
!   are regular on a closed interval, it can be used for functions with an
!   integrable singularity at one or both of the endpoints.

!   The function(s) to be integrated is(are) defined in external function
!   subprogram(s) -- see the sample function subprograms below.  The name(s) of
!   the function subprogram(s) must be included in appropriate type and external
!   statements in the main program.

!   Note that an integral of a function on an infinite interval can be
!   converted to an integral on a finite interval by means of a suitable
!   change of variable.  Example (here the notation "inf" means infinity):

!   Int_0^inf f(t) dt  =  Int_0^1 f(t) dt + Int_1^inf f(t) dt
!                      =  Int_0^1 f(t) dt + Int_0^1 f(1/t)/t^2 dt

!   Inputs set in parameter statement below:
!   kdebug Debug level setting.  Default = 2.
!   ndp    Digits of precision.  May not exceed mpipl in file mpmod90.f.
!            In some cases, ndp must be significantly greater than the desired
!            tolerance in the result-- see the examples below.
!   neps   Log10 of the desired tolerance in the result (negative integer).
!   nq1    Max number of phases in quadrature routine; adding 1 increases
!            (possibly doubles) the number of accurate digits in the result,
!            but also roughly quadruples the run time.  nq1 > 2.
! XSL  nq1 = m
!   nq2    Space parameter for wk and xk arrays in the calling program.  By
!            default it is set to 8 * 2^nq1.  Increase nq2 if directed by a
!            message produced in initqts.  Note that the dimension of the
!            wk and xk arrays starts with -1, so the length of these arrays is
!            (nq2+2) * (mpwds+5) eight-byte words.

use mpmodule
use quadglobal
implicit none
integer i, kdebug, ndp, neps, nq1, nq2, n1
parameter (kdebug = 2, ndp = 400, neps = -400, nq1 = 9, nq2 = 8 * 2 ** nq1)
double precision dplog10q, d1, d2, second, tm0, tm1
type (mp_real) err, quadts, fun01, fun02, fun03, fun04, fun05, fun06, fun07, &
  fun08, fun09, fun10, fun11, fun12, fun13, fun14, fun15a, fun15b, &
  t1, t2, t3, t4, wk(-1:nq2), xk(-1:nq2), x1, x2
external quadts, fun01, fun02, fun03, fun04, fun05, fun06, fun07, fun08, &
  fun09, fun10, fun11, fun12, fun13, fun14, fun15a, fun15b, second

call mpinit
if (ndp > mpipl .or. nq1 < 2) stop
call mpsetprec (ndp)
mpeps = mpreal (10.d0) ** neps
mpoud = ndp

ndebug = kdebug
ndigits = ndp
nerror = 0
nquadl = nq1
write (6, 1) ndigits, neps, nquadl
1 format ('Quadts test'/'Digits =',i6,'  Epsilon =',i6,'   Quadlevel =',i6)

!   Initialize quadrature tables wk and xk (weights and abscissas).

tm0 = second ()
call initqts (nq1, nq2, wk, xk)
tm1 = second ()
if (nerror > 0) stop
write (6, 2) tm1 - tm0
2 format ('Quadrature initialization completed: cpu time =',f12.6)

! XSL
write(*, *) 'nq1 = ', nq1, '  nq2 = ', nq2
!

!   Begin quadrature tests.

write (6, 11)
11 format (/'Continuous functions on finite itervals:'//&
  'Problem 1: Int_0^1 t*log(1+t) dt = 1/4')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun01, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
3 format ('Quadrature completed: CPU time =',f12.6/'Result =')
call mpwrite (6, t1)
t2 = 0.25d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1
4 format ('Actual error =',f10.6,'x10^',i5)

stop

write (6, 12)
12 format (/'Problem 2: Int_0^1 t^2*arctan(t) dt = (pi - 2 + 2*log(2))/12')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun02, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = (mppic - 2.d0 + 2.d0 * mpl02) / 12.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 13)
13 format (/'Problem 3: Int_0^(pi/2) e^t*cos(t) dt = 1/2*(e^(pi/2) - 1)')
x1 = 0.d0
x2 = 0.5d0 * mppic
tm0 = second ()
t1 = quadts (fun03, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0 * (exp (0.5d0 * mppic) - 1.d0)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 14)
14 format (/ &
  'Problem 4: Int_0^1 arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2)) dt = 5*Pi^2/96')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun04, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 5.d0 * mppic**2 / 96.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 15)
15 format (/&
  'Continuous functions on finite itervals, but non-diff at an endpoint'// &
  'Problem 5: Int_0^1 sqrt(t)*log(t) dt = -4/9')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun05, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = mpreal (-4.d0) / 9.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 16)
16 format (/'Problem 6: Int_0^1 sqrt(1-t^2) dt = pi/4')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun06, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.25d0 * mppic
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 17)
17 format (/&
  'Functions on finite intervals with integrable singularity at an endpoint.'//&
  'Problem 7: Int_0^1 t/sqrt(1-t^2) dt = 1')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun07, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 1.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 18)
18 format (/'Problem 8: Int_0^1 log(t)^2 dt = 2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun08, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 2.d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 19)
19 format (/'Problem 9: Int_0^(pi/2) log(cos(t)) dt = -pi*log(2)/2')
x1 = 0.d0
x2 = 0.5d0 * mppic
tm0 = second ()
t1 = quadts (fun09, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = -0.5d0 * mppic * mpl02
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 20)
20 format (/'Problem 10: Int_0^(pi/2) sqrt(tan(t)) dt = pi*sqrt(2)/2')
x1 = 0.d0
x2 = 0.5d0 * mppic
tm0 = second ()
t1 = quadts (fun10, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0 * mppic * sqrt (mpreal (2.d0))
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 21)
21 format (/&
  'Functions on an infinite interval (requiring a two-step solution'//&
  'Problem 11: Int_0^inf 1/(1+t^2) dt = pi/2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun11, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0 * mppic
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 22)
22 format (/'Problem 12: Int_0^inf e^(-t)/sqrt(t) dt = sqrt(pi)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun12, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = sqrt (mppic)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 23)
23 format (/'Problem 13: Int_0^inf e^(-t^2/2) dt = sqrt(pi/2)')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun13, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = sqrt (0.5d0 * mppic)
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 24)
24 format (/&
  'Oscillatory functions on an infinite interval.'//&
  'Problem 14: Int_0^inf e^(-t)*cos(t) dt = 1/2')
x1 = 0.d0
x2 = 1.d0
tm0 = second ()
t1 = quadts (fun14, x1, x2, nq1, nq2, wk, xk)
tm1 = second ()
write (6, 3) tm1 - tm0
call mpwrite (6, t1)
t2 = 0.5d0
call decmdq (t2 - t1, d1, n1)
write (6, 4) d1, n1

write (6, 25)
25 format (/'Problem 15: Int_0^inf sin(t)/t = pi/2')
x1 = 0.d0
x2 = mppic
tm0 = second ()
t1 = quadts (fun15a, x1, x2, nq1, nq2, wk, xk)
x2 = 1.d0 / mppic
t2 = quadts (fun15b, x1, x2, nq1, nq2, wk, xk)
t3 = t1 + 40320.d0 * t2 - 1.d0 / mppic + 2.d0 / mppic ** 3 &
  - 24.d0 / mppic ** 5 + 720.d0 / mppic ** 7
tm1 = second ()
write (6, 3) tm1 - tm0
t4 = 0.5d0 * mppic
call decmdq (t4 - t3, d1, n1)
write (6, 4) d1, n1
write (6, 26)
26 format ('Prob 15 error may be 40,000 X higher than estimated error.')

stop
end

function fun01 (t)

!   fun01(t) = t * log(1+t)

use mpmodule
implicit none
type (mp_real) fun01, t

fun01 = t * log (1.d0 + t)
return
end

function fun02 (t)

!   fun02(t) = t^2 * arctan(t)

use mpmodule
implicit none
type (mp_real) fun02, t

fun02 = t ** 2 * atan (t)
return
end

function fun03 (t)

!   fun03(t) = e^t * cos(t)

use mpmodule
implicit none
type (mp_real) fun03, t

fun03 = exp(t) * cos(t)
return
end

function fun04 (t)

!   fun04(t) = arctan(sqrt(2+t^2))/((1+t^2)sqrt(2+t^2))

use mpmodule
implicit none
type (mp_real) fun04, t, t1

t1 = sqrt (2.d0 + t**2)
fun04 = atan(t1)/((1.d0 + t**2)*t1)
return
end

function fun05 (t)

!    fun05(t) = sqrt(t)*log(t)

use mpmodule
implicit none
type (mp_real) fun05, t

fun05 = sqrt (t) * log (t)
return
end

function fun06 (t)

!    fun06(t) = sqrt(1-t^2)

use mpmodule
implicit none
type (mp_real) fun06, t

fun06 = sqrt (1.d0 - t**2)
return
end

function fun07 (t)

!   fun07(t) = t / sqrt(1-t^2)

use mpmodule
implicit none
type (mp_real) fun07, t

fun07 = t / sqrt (1.d0 - t**2)
return
end

function fun08 (t)

!   fun08(t) = log(t)^2

use mpmodule
implicit none
type (mp_real) fun08, t

fun08 = log (t) ** 2
return
end

function fun09 (t)

!   fun09(t) = log (cos (t))

use mpmodule
implicit none
type (mp_real) fun09, t

fun09 = log (cos (t))
return
end

function fun10 (t)

!   fun10(t) = sqrt(tan(t))

use mpmodule
implicit none
type (mp_real) fun10, t

fun10 = sqrt (tan (t))
return
end

function fun11 (t)

!   fun11(t) = 1/(u^2(1+(1/u-1)^2)) = 1/(1 - 2*u + u^2)

use mpmodule
implicit none
type (mp_real) fun11, t

fun11 = 1.d0 / (1.d0 - 2.d0 * t + 2.d0 * t ** 2)
return
end

function fun12 (t)

!   fun12(t) = e^(-(1/t-1)) / sqrt(t^3 - t^4)

use mpmodule
implicit none
type (mp_real) fun12, t, t1

t1 = 1.d0 / t - 1.d0
fun12 = exp (-t1) / sqrt (t ** 3 - t ** 4)
return
end

function fun13 (t)

!   fun13(t) = e^(-(1/t-1)^2/2) / t^2

use mpmodule
implicit none
type (mp_real) fun13, t, t1

t1 = 1.d0 / t - 1.d0
fun13 = exp (-0.5d0 * t1 ** 2) / t ** 2
return
end

function fun14 (t)

!   fun14(t) = e^(-(1/t-1)) * cos (1/t-1) / t^2

use mpmodule
implicit none
type (mp_real) fun14, t, t1

t1 = 1.d0 / t - 1.d0
fun14 = exp (-t1) * cos (t1) / t ** 2
return
end

function fun15a (t)

!   fun15a(t) = sin(t)/t

use mpmodule
use quadglobal
implicit none
type (mp_real) fun15a, t

fun15a = sin (t) / t
return
end

function fun15b (t)

!   fun15b(t) = t^7 * sin(1/t)

use mpmodule
use quadglobal
implicit none
type (mp_real) fun15b, t

fun15b = t**7 * sin (1.d0 / t)
return
end

subroutine initqts (nq1, nq2, wk, xk)

!   This subroutine initializes the quadrature arays xk and wk using the
!   function x(t) = tanh (pi/2*sinh(t)).  The argument nq2 is the space
!   allocated for wk and xk in the calling program.  By default it is set to
!   8 * 2^nq1.  Increase nq2 if directed by a message produced below.
!   Upon completion, wk(-1) = nq1, and xk(-1) = n, the maximum space parameter
!   for these arrays.  In other words, the arrays occupy (wk(i), i = -1 to n)
!   and (xk(i), i = -1 to n), where n = xk(-1).
!   David H Bailey    2002-11-05

use mpmodule
use quadglobal
implicit none
integer i, ierror, iprint, j, k, k1, nq1, nq2
! XSL
integer ntids, tid, OMP_GET_THREAD_NUM, OMP_GET_NUM_THREADS
real*8 h
parameter (iprint = 1000)
type (mp_real) p2, t1, t2, t3, t4, t5, wk(-1:nq2), xk(-1:nq2)

if (ndebug >= 1) then
  write (6, 1)
1 format ('initqts: Tanh-sinh quadrature initialization')
endif

p2 = 0.5d0 * mppic
h = 0.5d0 ** nq1
wk(-1) = dble (nq1)

!$omp parallel do private(k,t1,t2,t3,t4,t5,ntids,tid) shared(nq2,p2,h)
do k = 0, nq2
  if (ndebug >= 2 .and. mod (k, iprint) == 0) then
      ntids = omp_get_num_threads()
      tid = omp_get_thread_num()
      print*, 'nthreads = ', ntids, '  thread = ', tid
      write (6, *) k, nq2
  endif
  t1 = dble (k) * h

!   xk(k) = tanh (p2 * sinh (t1))
!   wk(k) = p2 * cosh (t1) / cosh (p2 * sinh (t1)) ** 2

!   The next five lines are equivalent to the above two, but faster.

  call mpcsshf (t1, t2, t3)
  t3 = p2 * t3
  call mpcsshf (t3, t4, t5)
  xk(k) = t5 / t4
  wk(k) = p2 * t2 / t4 ** 2

!  call mpgetpar ('mpier', ierror)
!  if (ierror > 0) goto 120
!  if (xk(k) .eq. 1.d0) goto 100
enddo
!$omp end parallel do

print*, 'k = ', k
goto 100

write (6, 2) nq2
2 format ('initqts: Table space parameter is too small; value =',i8)
nerror = 91
goto 130

100 continue

! XSL, out-of parallel-do loop, k is not defined
k = nq2
!
xk(-1) = dble (k)
if (ndebug >= 2) then
  write (6, 3) k
3 format ('initqts: Table spaced used =',i8)
endif
goto 130

120 continue

nerror = ierror + 100
write (6, 4) nerror
4 format ('initqts: Error in quadrature initialization; code =',i5)

130  continue

return
end

function quadts (fun, x1, x2, nq1, nq2, wk, xk)

!   This routine computes the integral of the function in fun on the interval
!   [x1, x2], with up to nq1 iterations, with a target tolerance of mpeps.
!   wk and xk are precomputed tables of weights and abscissas.  The function
!   fun is not evaluated at x = x1 or x2.
!   David H. Bailey     2002-11-05

use mpmodule
use quadglobal
implicit none
integer i, ierror, ip(0:100), j, k, k1, k2, n, nds, nq1, nq2, nqq1
real*8 d1, d2, d3, d4, dplog10q, h
type (mp_real) ax, bx, c10, quadts, eps, eps1, eps2, err, fmx, fun, &
  sum, s1, s2, s3, t1, t2, t3, t4, term, wk(-1:nq2), xk(-1:nq2), &
  x1, x2, xx1, xx2
external fun, dplog10q

nds = mpoud
mpoud = 56
ax = 0.5d0 * (x2 - x1)
bx = 0.5d0 * (x2 + x1)
sum = 0.d0
s1 = 0.d0
s2 = 0.d0
h = 1.d0
c10 = 10.d0
eps = mpeps
eps1 = 2.d0 ** 48 * mpeps

if (wk(-1) < dble (nq1)) then
  write (6, 1) nq1
1 format ('quadts: quadrature arrays have not been initialized; nq1 =',i6)
  nerror = 70
  goto 140
endif
nqq1 = dble (wk(-1))  ! XSL note: nqq1 = nq1 = m
n = dble (xk(-1))

do k = 0, nqq1
  ip(k) = 2 ** k
enddo

do k = 1, nq1
  h = 0.5d0 * h
  s3 = s2
  s2 = s1
  fmx = 0.d0
  k1 = ip(nqq1-k)
  k2 = ip(nqq1-k+1)

!   Evaluate function at level k in x, avoiding unnecessary computation.

  do i = 0, n, k1
    if (mod (i, k2) /= 0 .or. k == 1) then
      xx1 = - ax * xk(i) + bx
      xx2 = ax * xk(i) + bx
      if (xx1 > x1 .and. xx2 < x2) then
        t1 = fun (xx1)
        call mpgetpar ('mpier', ierror)
        if (ierror > 0 .or. nerror > 0) goto 130
        if (i > 0) then
          t2 = fun (xx2)
          call mpgetpar ('mpier', ierror)
          if (ierror > 0 .or. nerror > 0) goto 130
        else
          t2 = 0.d0
        endif
        sum = sum + wk(i) * (t1 + t2)
        fmx = max (fmx, abs (t1), abs (t2))
      else
        goto 100
      endif
    endif
  enddo

100 continue

!   Compute s1 = current integral approximation and err = error estimate.

  s1 =  ax * h * sum
  eps2 = fmx * eps1
  d1 = dplog10q (abs (s1 - s2))
  d2 = dplog10q (abs (s1 - s3))
  d3 = dplog10q (eps2) - 12.d0

  if (k <= 2) then
    err = 1.d0
  elseif (d1 .eq. -9999.d0) then
    err = 0.d0
  else
    d4 = min (0.d0, max (d1 ** 2 / d2, 2.d0 * d1, d3))
    err = c10 ** nint (d4)
  endif

!   Output current integral approximation and error estimate, to 56 dp.

  if (ndebug >= 2) then
    write (6, 2) k, nq1, nint (dplog10q (abs (err)))
2   format ('quadts: Iteration',i3,' of',i3,'; est error = 10^',i5, &
      '; approx value =')
    call mpwrite (6, s1)
  endif
  if (k >= 3 .and. err < eps1) goto 140
  if (k >= 3 .and. err < eps2) goto 120
enddo

write (6, 3) nint (dplog10q (abs (err))), nquadl
3 format ('quadts: Estimated error = 10^',i5/&
  'Increase Quadlevel for greater accuracy. Current Quadlevel =',i4)
goto 140

120 continue

write (6, 4) nint (dplog10q (abs (err))), ndigits
4 format ('quadts: Estimated error = 10^',i5/&
  'Increase working prec (Digits) for greater accuracy. Current Digits =',i4)
goto 140

130 continue

if (ierror > 0) nerror = ierror + 100
write (6, 5) nerror
5 format ('quadts: Error in quadrature calculation; code =',i5)
s1 = 0.d0

140 continue

quadts = s1
mpoud = nds
return
end

function dplog10q (a)

!   For input MP value a, this routine returns a DP approximation to log10 (a).

use mpmodule
implicit none
integer ia
double precision da, dplog10q, t1
type (mp_real) a

call mpmdc (a%mpr, da, ia)
if (da .eq. 0.d0) then
  dplog10q = -9999.d0
else
  dplog10q = log10 (abs (da)) + ia * log10 (2.d0)
endif

100 continue
return
end

subroutine decmdq (a, b, ib)

!   For input MP value a, this routine returns DP b and integer ib such that
!   a = b * 10^ib, with 1 <= abs (b) < 10 for nonzero a.

use mpmodule
implicit none
integer ia, ib
double precision da, b, t1, xlt
parameter (xlt = 0.3010299956639812d0)
type (mp_real) a

call mpmdc (a%mpr, da, ia)
if (da .ne. 0.d0) then
  t1 = xlt * ia + log10 (abs (da))
  ib = t1
  if (t1 .lt. 0.d0) ib = ib - 1
  b = sign (10.d0 ** (t1 - ib), da)
else
  b = 0.d0
  ib = 0
endif

return
end


module norm
contains

    function Jnorm(j)
        implicit none
        integer, INTENT(IN)  :: j
        real(kind=8) :: Jnorm

        Jnorm = 2d0 * j + 1d0

    end function Jnorm

    function j2norm(two_j)
        implicit none
        integer, intent(in) :: two_j
        integer :: j2norm

        j2norm = two_j + 1

    end function j2norm

    function Qnorm(j)
        implicit none
        integer, INTENT(IN) :: j
        real(kind=8)  :: Qnorm

        if (j<0) STOP "qnorm error: negative j"

        Qnorm = sqrt(2d0 * j + 1d0)

    end function Qnorm

    function q2norm(two_j)
        implicit none
        integer, intent(in) :: two_j
        real(kind=8) :: q2norm
        if (two_j<0) STOP "qnorm error: negative j"

        q2norm = sqrt(two_j + 1d0)

    end function q2norm

end module norm


PROGRAM MAIN

  IMPLICIT NONE

  ! Loop counter and maximum value
  INTEGER :: i, max_val
  ! Variables for previous sequence vals, and current one
  INTEGER :: fib_first, fib_second, fib_current

  ! Do the first 20 terms
  max_val = 20

  ! Optional last but to add- sanity check on max_val
  IF(max_val < 3 .OR. max_val > 46) THEN
    PRINT*, "Sequence is too short or long. max_val should be between 3 and 46"
  END IF

  ! f(1) = 1 and f(2) = 1
  fib_first = 1
  fib_second = 1

  ! Print the initial 2 values so we see the whole sequence up to max_val
  PRINT*, fib_first
  PRINT*, fib_second

  ! Loop from the third value to max_value, calculating and printing the term
  DO i = 3, max_val

    ! This is the current term
    fib_current = fib_first + fib_second

    ! these are the previous terms, fib_first = f(n-2) and fib_second=f(n-1)
    fib_first = fib_second
    fib_second = fib_current

    ! Print the calculated value
    PRINT*, fib_current

  END DO

END PROGRAM


      program pendulum
      real omega(300),teta(300),t(300)
      open(7,file="pend_out")
      print*, "Enter teta0"
      read(5,*) teta0
      print*, "Enter q"
      read(5,*) q
 111  format(2(2x,e11.5))
      pi=3.1415927
      teta=teta0*pi/180.0
      g=9.8
      s1=1.0
      freq=sqrt(g/s1)
      period=2.0*pi/freq
      tt=4.0*period
      dt=tt/300.0
      t(1)=0.0
      omega(1)=0.0
      teta(1)=teta0
      g1=g/s1
      do i=1,299
        t(i+1)=t(i)+dt
        omega(i+1)=omega(i)-(g1*teta(i)+q*omega(i))*dt
        teta(i+1)=teta(i)+omega(i+1)*dt
        write(7,111) t(i+1),teta(i+1)
      enddo
      end


PROGRAM FDM_HeatEq2D
    USE FDM_Grid2D
    USE SimulationTime
	IMPLICIT NONE
    REAL(dp), DIMENSION(:,:), ALLOCATABLE :: T, TNew
    REAL(dp) :: time
    INTEGER  :: i, j
    INTEGER  :: timeStep = 0

    CALL SetFDMGrid
    CALL CalculateDt

    IF (.NOT. ALLOCATED(T)) THEN
      ALLOCATE(T(1:nx,1:ny))
    ENDIF

    IF (.NOT. ALLOCATED(Tnew)) THEN
      ALLOCATE(Tnew(1:nx,1:ny))
      Tnew = 0.0d0
    ENDIF

    ! B.C
	T(1,1:ny)  = 0.0d0
    T(nx,1:ny) = 0.0d0
    T(1:nx,1)  = 0.0d0
    T(1:nx,ny) = 0.0d0

    ! Initial solution
    T(2:nx-1,2:ny-1) = 0.0d0
    T(nx/2,ny/2) = 100.0d0
    T(nx/2+1,ny/2) = 100.0d0
    T(nx/2,ny/2+1) = 100.0d0
    T(nx/2+1,ny/2+1) = 100.0d0

    CALL SetEndTime

    time = 0.0d0

  	DO WHILE (time <= endTime)
    	time = time + dt
        timeStep = timeStep + 1
        DO j = 2, ny - 1
          DO i = 2, nx - 1
			TNew(i,j) = TNew(i,j) + dt * kappa * (T(i-1,j) - 2.0d0*T(i,j) + T(i+1,j)) / delta_x**2
            TNew(i,j) = TNew(i,j) + dt * kappa * (T(i,j-1) - 2.0d0*T(i,j) + T(i,j+1)) / delta_y**2
          ENDDO
        ENDDO

        T = TNew

        IF (MOD(timeStep,10) == 0) CALL WriteSolutionToVTK(timeStep)
    ENDDO

    CONTAINS

    	SUBROUTINE WriteSolutionToMatlab(timeStep)
        	IMPLICIT NONE
            INTEGER, INTENT(IN) :: timeStep
            INTEGER             :: j
            CHARACTER(20)       :: chrTimeStep

            WRITE(chrTimeStep,'(I7.7)') timeStep
            OPEN(UNIT = 20, FILE = trim(chrTimeStep)//'.dat', STATUS = 'REPLACE')
            DO j = 1, ny
              WRITE(20,'(1000f13.5)') T(:,j)
            ENDDO
            CLOSE(UNIT = 20)
        END SUBROUTINE WriteSolutionToMatlab

        SUBROUTINE WriteSolutionToVTK(timeStep)
        	IMPLICIT NONE
            INTEGER, INTENT(IN) :: timeStep
            INTEGER             :: i, j
            CHARACTER(20)       :: chrTimeStep

            WRITE(chrTimeStep,'(I7.7)') timeStep
            OPEN(UNIT = 20, FILE = trim(chrTimeStep)//'.vtk', STATUS = 'REPLACE')
            WRITE(20,'(1A26)') '# vtk DataFile Version 2.0'
            WRITE(20,'(A)') 'Diffusion 2D'
            WRITE(20,'(A)') 'ASCII'
            WRITE(20,'(A)') 'DATASET STRUCTURED_GRID'
            WRITE(20,100) nx, ny, 1
            WRITE(20,200) nx * ny
            DO j = 1, ny
              DO i = 1, nx
                WRITE(20,*) x(i), y(j), 0.0d0
              ENDDO
            ENDDO
            WRITE(20,*) 'POINT_DATA', nx * ny
            WRITE(20,'(A)') 'SCALARS T float'
            WRITE(20,'(A)') 'LOOKUP_TABLE default'
            DO j = 1, ny
              DO i = 1, nx
                WRITE(20,*) T(i,j)
              ENDDO
            ENDDO
            CLOSE(UNIT = 20)

100 FORMAT('DIMENSIONS ',3I9)
200 FORMAT('POINTS ',I9,' float')
        END SUBROUTINE WriteSolutionToVTK

END PROGRAM FDM_HeatEq2D


MODULE populate
IMPLICIT NONE
REAL, DIMENSION(-50:50,0:100) :: values
INTEGER :: i, j
CONTAINS
  SUBROUTINE populate_array()
    INTEGER, DIMENSION(8) :: time
    CALL DATE_AND_TIME(VALUES=time)
    CALL SRAND(time(8))
    DO i = -50, 50
      DO j = 0, 100
        IF (RAND() .gt. 0.95) THEN
          values(i, j) = 0.
        ELSE
          values(i, j) = RAND() * 20. - 10.
        END IF
      END DO
    END DO
  END SUBROUTINE populate_array
END MODULE populate

PROGRAM counting
USE populate
IMPLICIT NONE
INTEGER :: pos_count = 0, neg_count = 0, zero_count = 0

CALL populate_array()

DO i = -50, 50
  DO j = 0, 100
    IF (values(i, j) .gt. 0.0) THEN
      pos_count = pos_count + 1
    ELSE IF (values(i, j) .lt. 0.0) THEN
      neg_count = neg_count + 1
    ELSE
      zero_count = zero_count + 1
    END IF
  END DO
END DO

WRITE(*, *) "Counting positive, negative, and zero values in array..."
WRITE(*, *) "Results using DO and IF statements:"
WRITE(*, '(3(A,I5,2X))') "POS: ", pos_count, "NEG: ", neg_count, "ZERO: ", zero_count
WRITE(*, *) "Results using COUNT statements:"
WRITE(*, '(3(A,I5,2X))') "POS: ", COUNT(values > 0.), "NEG: ", COUNT(values < 0.), "ZERO: ", COUNT(values == 0.)
END PROGRAM counting


C$Procedure      POLYDS ( Compute a Polynomial and its Derivatives )

      SUBROUTINE POLYDS ( COEFFS, DEG, NDERIV, T, P )

C$ Abstract
C
C     Compute the value of a polynomial and it's first
C     n derivatives at the value T.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C
C      INTERPOLATION,  MATH,  POLYNOMIAL
C
C$ Declarations

      DOUBLE PRECISION   COEFFS ( 0:* )
      INTEGER            DEG
      INTEGER            NDERIV
      DOUBLE PRECISION   T
      DOUBLE PRECISION   P      ( 0:* )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      COEFFS     I   Coefficients of the polynomial to be evaluated.
C      DEG        I   Degree of the polynomial to be evaluated.
C      NDERIV     I   Number of derivatives to compute.
C      T          I   Point to evaluate the polynomial and derivatives
C      P          O   Value of polynomial and derivatives.
C
C$ Detailed_Input
C
C      COEFFS     containst the coefficients of the polynomial that is
C                 to be evaluated.  The first element of this array
C                 should be the constant term, the second element the
C                 linear coefficient, the third term the quadratic
C                 coefficient, and so on. The number of coefficients
C                 supplied should be one more than DEG.
C
C      DEG        is the degree of the polynomial to be evaluated.  DEG
C                 should be one less than the number of coefficients
C                 supplied.
C
C      NDERIV     is the number of derivatives to compute.  If NDERIV
C                 is zero, only the polynomial will be evaluated.  If
C                 NDERIV = 1, then the polynomial and its first
C                 derivative will be evaluated, and so on.  If the value
C                 of NDERIV is negative, the routine returns
C                 immediately.
C
C      T          is the point at which the polynomial and its
C                 derivatives should be evaluated.
C
C$ Detailed_Output
C
C      P          is an array containing the value of the polynomial and
C                 its derivatives evaluated at T.  The first element of
C                 the array contains the value of P at T. The second
C                 element of the array contains the value of the first
C                 derivative of P at T and so on.  The NDERIV + 1'st
C                 element of the array contains the NDERIV'th derivative
C                 of P evaluated at T.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      This routine uses the user supplied coefficients (COEFFS)
C      to evaluate a polynomial (having these coefficients) and its
C      derivatives at the point T.  The zero'th derivative of the
C      polynomial is regarded as the polynomial itself.
C
C$ Examples
C
C    Suppose T = 1.0D0
C
C
C    Degree  COEFFS        Deriviative Number     P
C    ------  ------        ------------------  ----------
C    0       1                    0                5
C    1       3                    1               10
C    2       0.5                  2               29
C    3       1                    3              102
C    4       0.5
C    5      -1
C    6       1
C
C$ Restrictions
C
C      Depending on the coefficients the user should be careful when
C      taking high order derivatives.  As the example shows, these
C      can get big in a hurry.  In general the coefficients of the
C      derivatives of a polynomial grow at a rate greater
C      than N! (N factorial).
C
C$ Exceptions
C
C     Error free
C
C     1) If NDERIV is less than zero, the routine simply returns
C
C     2) If the degree of the polynomial is less than 0, the routine
C        simply returns.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.1.0, 11-JUL-1995 (KRG)
C
C        Replaced the function calls to DFLOAT with standard conforming
C        calls to DBLE.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     compute a polynomial and its derivatives
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.1.0, 11-JUL-1995 (KRG)
C
C        Replaced the function calls to DFLOAT with standard conforming
C        calls to DBLE.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-     Beta Version 1.0.1, 30-DEC-1988 (WLT)
C
C      The error free specification was added as well as notes
C      on exceptional degree or derivative requests.
C
C-&

C
C     Local variables
C
      INTEGER          I
      INTEGER          K
      DOUBLE PRECISION SCALE

      IF ( NDERIV .LT. 0 ) THEN
         RETURN
      END IF

C
C     The following loops may not look like much, but they compute
C     P(T), P'(T), P''(T), ... etc.
C
C     To see why, recall that if A_0 through A_N are the coefficients
C     of a polynomial, then P(t) can be computed from the sequence
C     of polynomials given by:
C
C        P_0(t) = 0
C        P_1(t) = t*P_0(t)     +   A_N
C        P_2(t) = t*P_1(t)     +   A_[N-1]
C               .
C               .
C               .
C        P_n(t) = t*P_[n-1](t) +   A_0
C
C     The final polynomial in this list is in fact P(t).  From this
C     it follows that P'(t) is given by P_n'(t).  But
C
C        P_n'(t)     = t*P_[n-1]'(t) +   P_[n-1](t)
C
C     and
C
C        P_[n-1]'(t) = t*P_[n-2]'(t) +   P_[n-2](t)
C                    .
C                    .
C                    .
C        P_2'(t)     = t*P_1'(t)     +   P_1(t)
C        P_1'(t)     = t*P_0'(t)     +   P_0(t)
C        P_0'(t)     = 0
C
C     Rearranging the sequence we have a recursive method
C     for computing P'(t).  At the i'th stage we require only the i-1st
C     polynomials P_[i-1] and P_[i-1]' .
C
C        P_0'(t)     = 0
C        P_1'(t)     = t*P_0'(t)     +   P_0(t)
C        P_2'(t)     = t*P_1'(t)     +   P_1(t)
C                    .
C                    .
C                    .
C        P_[n-1]'(t) = t*P_[n-2]'(t) +   P_[n-2](t)
C        P_n'(t)     = t*P_[n-1]'(t) +   P_[n-1](t)
C
C
C     Similarly,
C
C        P_0''(t)     = 0
C        P_1''(t)     = t*P_0''(t)     +   2*P_0'(t)
C        P_2''(t)     = t*P_1''(t)     +   2*P_1'(t)
C                     .
C                     .
C                     .
C        P_[n-1]''(t) = t*P_[n-2]''(t) +   2*P_[n-2]'(t)
C
C
C
C        P_0'''(t)     = 0
C        P_1'''(t)     = t*P_0'''(t)     +   3*P_0''(t)
C        P_2'''(t)     = t*P_1'''(t)     +   3*P_1''(t)
C                      .
C                      .
C                      .
C        P_[n-1]'''(t) = t*P_[n-2]'''(t) +   3*P_[n-2]''(t)
C
C     Thus if P(I) contains the k'th iterations of the i'th derivative
C     computation of P and P(I-1) contains the k'th iteration of the
C     i-1st derivative of P then, t*P(I) + I*P(I-1) is the value of the
C     k+1st iteration of the computation of the i'th derivative of
C     P. This can then be stored in P(I).
C
C     If in a loop we compute in-place k'th iteration of the
C     I'th derivative before we perform the in-place k'th iteration
C     of the I-1st and I-2cnd derivative, then the k-1'th values
C     of the I-1st and I-2cnd will not be altered and will be available
C     for the computation of the k'th interation of the I-1st
C     derivative.  This observation gives us an economical way to
C     compute all of the derivatives (including the zero'th derivative)
C     in place.  We simply compute the iterates of the high order
C     derivatives first.

C
C     Initialize the polynomial value (and all of its derivatives) to be
C     zero.
C
      DO I = 0, NDERIV
         P(I) = 0.0D0
      END DO

C
C     Set up the loop "counters" (they count backwards) for the first
C     pass through the loop.
C
      K     = DEG
      I     = NDERIV
      SCALE = DBLE ( NDERIV )

      DO WHILE ( K .GE. 0 )

         DO WHILE ( I .GT. 0 )
            P(I)  = T*P(I) + SCALE*P(I-1)
            SCALE = SCALE - 1
            I     = I - 1
         END DO

         P(0)  = T*P(0) + COEFFS(K)
         K     = K - 1
         I     = NDERIV
         SCALE = DBLE( NDERIV )
      END DO

      RETURN
      END


    Program zhegv_example

!     ZHEGV Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen
      Use lapack_interfaces, Only: ddisna, zhegv, zlanhe, ztrcon
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Real (Kind=dp) :: anorm, bnorm, eps, rcond, rcondb, t1, t2, t3
      Integer :: i, ifail, info, k, lda, ldb, lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:, :), work(:)
      Complex (Kind=dp) :: dummy(1)
      Real (Kind=dp), Allocatable :: eerbnd(:), rcondz(:), rwork(:), w(:), &
        zerbnd(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, conjg, epsilon, max, maxloc, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZHEGV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      Allocate (a(lda,n), b(ldb,n), eerbnd(n), rcondz(n), rwork(3*n-2), w(n), &
        zerbnd(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call zhegv(1, 'Vectors', 'Upper', n, a, lda, b, ldb, w, dummy, lwork, &
        rwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((nb+1)*n, nint(real(dummy(1))))
      Allocate (work(lwork))

!     Read the upper triangular parts of the matrices A and B

      Read (nin, *)(a(i,i:n), i=1, n)
      Read (nin, *)(b(i,i:n), i=1, n)

!     Compute the one-norms of the symmetric matrices A and B

      anorm = zlanhe('One norm', 'Upper', n, a, lda, rwork)
      bnorm = zlanhe('One norm', 'Upper', n, b, ldb, rwork)

!     Solve the generalized Hermitian eigenvalue problem
!     A*x = lambda*B*x (itype = 1)

      Call zhegv(1, 'Vectors', 'Upper', n, a, lda, b, ldb, w, work, lwork, &
        rwork, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:n)
        Flush (nout)

!       Normalize the eigenvectors, largest element real
!       (normalization w.r.t B unaffected: Z^HBZ = I).
        Do i = 1, n
          rwork(1:n) = abs(a(1:n,i))
          k = maxloc(rwork(1:n), 1)
          scal = conjg(a(k,i))/abs(a(k,i))
          a(1:n, i) = a(1:n, i)*scal
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', n, n, a, lda, &
          'Eigenvectors', ifail)

!       Call ZTRCON to estimate the reciprocal condition
!       number of the Cholesky factor of B.  Note that:
!       cond(B) = 1/rcond**2
        Call ztrcon('One norm', 'Upper', 'Non-unit', n, b, ldb, rcond, work, &
          rwork, info)

!       Print the reciprocal condition number of B

        rcondb = rcond**2
        Write (nout, *)
        Write (nout, *) 'Estimate of reciprocal condition number for B'
        Write (nout, 110) rcondb
        Flush (nout)

!       Get the machine precision, eps, and if rcondb is not less
!       than eps**2, compute error estimates for the eigenvalues and
!       eigenvectors

        eps = epsilon(1.0E0_dp)
        If (rcond>=eps) Then

!         Call DDISNA to estimate reciprocal condition
!         numbers for the eigenvectors of (A - lambda*B)

          Call ddisna('Eigenvectors', n, n, w, rcondz, info)

!         Compute the error estimates for the eigenvalues and
!         eigenvectors

          t1 = eps/rcondb
          t2 = anorm/bnorm
          t3 = t2/rcond
          Do i = 1, n
            eerbnd(i) = t1*(t2+abs(w(i)))
            zerbnd(i) = t1*(t3+abs(w(i)))/rcondz(i)
          End Do

!         Print the approximate error bounds for the eigenvalues
!         and vectors

          Write (nout, *)
          Write (nout, *) 'Error estimates for the eigenvalues'
          Write (nout, 110) eerbnd(1:n)
          Write (nout, *)
          Write (nout, *) 'Error estimates for the eigenvectors'
          Write (nout, 110) zerbnd(1:n)
        Else
          Write (nout, *)
          Write (nout, *) 'B is very ill-conditioned, error ', &
            'estimates have not been computed'
        End If
      Else If (info>n) Then
        i = info - n
        Write (nout, 120) 'The leading minor of order ', i, &
          ' of B is not positive definite'
      Else
        Write (nout, 130) 'Failure in ZHEGV. INFO =', info
      End If

100   Format (3X, (6F11.4))
110   Format (4X, 1P, 6E11.1)
120   Format (1X, A, I4, A)
130   Format (1X, A, I4)
    End Program


PROGRAM CNPE2_HF
 USE PE2D_TYPE
 USE PE2D_VAR
 USE PE2D_AUX
 USE PE2D_GROUND
 IMPLICIT NONE
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) "========== Parabolic Equation Package =========="
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "University of Bristol"
 WRITE(*,*) "Mech. Eng. Department"
 WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
 WRITE(*,*) ""
 WRITE(*,*) "Codor Khodr, July 2016"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "CNPE2_HF"
 WRITE(*,*) "Dimension  : 2D"
 WRITE(*,*) "Atmosphere : Homogeneous"
 WRITE(*,*) "Boundary   : Flat"
 WRITE(*,*) "Impedance  : Rigid"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Read data
 OPEN(UNIT=10,FILE="CNPE2_IN.dat",STATUS="OLD")
 READ(10,*) L          !Domain range
 READ(10,*) F          !Frequency
 READ(10,*) ZS         !Source height
 READ(10,*) ZR         !Target height
 READ(10,*) ZX         !Impedance real part
 READ(10,*) ZY         !Impedance imaginary part
 READ(10,*) ANGLE      !Terrain maximum angle
 READ(10,*) DC         !Atmosphere profile coefficient
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 C0     = 343.0_DP
 LMBDA0 = C0/F
 K0     = 2*PI*F/C0
 DZ     = LMBDA0/10
 DR     = LMBDA0/10
 H      = 100*LMBDA0
 HA     = 30*LMBDA0
 N      = FLOOR(H/DZ)
 M      = FLOOR(L/DR)
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Size of the system : ", N
 WRITE(*,*) "Number of steps : ", M
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 NS     = MAX(1,FLOOR(ZS/DZ))
 NA     = FLOOR(HA/DZ)
 A      = IM/(2.0_DP*K0*DZ**2)
 KU     = 1
 KL     = 1
 NDIAG  = KU+KL+1
 WIDE_I = 1
 Z      = CMPLX(ZX,ZY,KIND=DPC)
 R      = (Z-1.0_DP)/(Z+1.0_DP)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Absorbing coefficient
 AS = 4.897_DP*(10**(-9))*(F**3) - &
      7.119_DP*(10**(-6))*(F**2) + &
      3.109_DP*(10**(-3))*F + &
      0.113
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Atmosphere density and wave velocity
 ALLOCATE(C(N),K(N),DK2(N),ALT(N))
 Z0 = 0.5_DP
 DO NZ = 1,N
  ALT(NZ) = NZ*DZ
  C(NZ)   = C0+DC*ALT(NZ)!LOG(1+ALT(NZ)/Z0)
  K(NZ)   = 2.0_DP*PI*F/C(NZ)
  IF (NZ.GT.(N-NA)) THEN
   K(NZ)  = K(NZ)+AS*IM*(NZ-N+NA)**2/NA**2
  END IF
  DK2(NZ) = K(NZ)**2-K0**2
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Starting field
 ALLOCATE(PHI(N,M+1),PC(N,M),QC(N,M),P(N,M),Q(N,M))
 A0 = 1.3717_DP
 A2 = -0.3701_DP
 B  = 3.0_DP
 DO NZ = 1,N
  PHI(NZ,1) = SQRT(IM*K0)* &
              ((A0+A2*K0**2*(NZ*DZ-ZS)**2)*EXP(-K0**2*(NZ*DZ-ZS)**2/B) + &
              R*(A0+A2*K0**2*(NZ*DZ+ZS)**2)*EXP(-K0**2*(NZ*DZ+ZS)**2/B))
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Initialization (Dense Matrices)
 ALLOCATE(T(N,N),D(N,N),E(N,N),I(N,N))
 TAU1    =  4.0_DP/(3.0_DP-2.0_DP*IM*K0*DZ)
 TAU2    = -1.0_DP/(3.0_DP-2.0_DP*IM*K0*DZ)
 SIGMA1  =  4.0_DP*Z/(3.0_DP*Z-2.0_DP*IM*K0*DZ)
 SIGMA2  = -1.0_DP*Z/(3.0_DP*Z-2.0_DP*IM*K0*DZ)
 T(:,:)  = 0.0_DP
 DO NZ = 2,N-1
  T(NZ,NZ-1) =  1.0_DP
  T(NZ,NZ)   = -2.0_DP
  T(NZ,NZ+1) =  1.0_DP
 END DO
 T(1,1)   = -2.0_DP+SIGMA1
 T(1,2)   =  1.0_DP+SIGMA2
 T(N,N-1) =  1.0_DP+TAU2
 T(N,N)   = -2.0_DP+TAU1
 E        = DDIAG(CMPLX(ALT,0.0_DP,KIND=DPC),N)
 D        = (IM/(2.0_DP*K0))*DDIAG(DK2,N)
 I        = EYE(N)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !System - M1 and M2
 ALLOCATE(M1(N,N),M2(N,N),MB2(NDIAG,N),MB1(NDIAG,N))
 C1 = CMPLX(1.0_DP,0.0_DP,KIND=DPC)
 C2 = CMPLX(0.0_DP,0.0_DP,KIND=DPC)
 SELECT CASE (WIDE_I)
  CASE(0)
   BETA1 = DR/2.0_DP
   BETA2 = -DR/2.0_DP
  CASE(1)
   BETA1 = 1.0_DP/(2.0_DP*IM*K0)+DR/2.0_DP
   BETA2 = 1.0_DP/(2.0_DP*IM*K0)-DR/2.0_DP
  CASE DEFAULT
   STOP "[MAIN] : Enter valid wide-angle case"
 END SELECT
 WRITE(*,*) "Wide-angle order : ", WIDE
 M1  = I+A*BETA1*T+BETA1*D
 M2  = I+A*BETA2*T+BETA2*D
 MB1 = D2B(M1,N,KL,KU)
 MB2 = D2B(M2,N,KL,KU)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Forward-marching procedure
 ALLOCATE(MB2T(KL+NDIAG,N),IPIV(N),TEMP(N,1))
 MB2T(KL+1:KL+NDIAG,:) = MB2
 CALL CPU_TIME(TI)
 !-----------------------------------------------------------
 DO MX = 2,M+1
  WRITE(*,*) "Step :", MX-1, "out of", M
  !-------------------------------
  !Right hand side multiplication
  !-------------------------------
  CALL ZGBMV('N',N,N,KL,KU,C1,MB1,KL+KU+1,PHI(1:N,MX-1),1,C2,TEMP(:,1),1)
  WRITE(*,*) ".... Right-hand side multiplied"
  !-------------------------------
  !System solving
  !-------------------------------
  CALL ZGBSV(N,KL,KU,1,MB2T,2*KL+KU+1,IPIV,TEMP,N,INFO)                                           !Band matrix form
  IF (INFO.NE.0) THEN
   STOP "ERROR : Matrix is singular"
  END IF
  WRITE(*,*) ".... System solved"
  !-------------------------------
  !Real pressure
  !-------------------------------
  PHI(1:N,MX) = TEMP(:,1)
  PC(1:N,MX-1) = EXP(IM*K0*(MX-1)*DR)*PHI(1:N,MX)*(1/SQRT((MX-1)*DR))
  P(1:N,MX-1)  = REALPART(PC(1:N,MX-1))
  WRITE(*,*)
 END DO
 !-----------------------------------------------------------
 CALL CPU_TIME(TF)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 ALLOCATE(LP(N,M),LQ(N,M),LPG(M),LQG(M))
 P0 = ABS(PC(NS,1))                  !Reference pressure (real)
 Q0 = ABS(QC(NS,1))                  !Reference corrected pressure (real)
 DO MX = 1,M
  DO NZ = 1,N
   LP(NZ,MX) = 10.0_DP*LOG10(ABS(PC(NZ,MX))**2/(P0**2))
   LQ(NZ,MX) = 10.0_DP*LOG10(ABS(QC(NZ,MX))**2/(Q0**2))
   IF (LP(NZ,MX).LE.-120) THEN
    LP(NZ,MX) = -120
    LQ(NZ,MX) = -120
  END IF
  END DO
 END DO
 LP0 = LP(NS,1)
 LQ0 = LQ(NS,1)
 LPG = LP(1,1:M)
 LQG = LQ(1,1:M)
 LPR = LP(NR,M)
 LQR = LQ(NR,M)
 PR  = SQRT(2.0_DP)*P0*10**(LPR/20)
 QR  = SQRT(2.0_DP)*Q0*10**(LPR/20)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Output
 OPEN(UNIT=10,FILE="CNPE2_TL.dat")
 OPEN(UNIT=20,FILE="CNPE2_FIELD.dat")
 !OPEN(UNIT=30,FILE="CNPE2_PC.dat")
 !OPEN(UNIT=50,FILE="CNPE2_Topo.dat")
 DO MX = 1,M
  WRITE(10,100) MX*DR, 0.0, LPG(MX)
  DO NZ = 1,N
   WRITE(20,100) MX*DR, NZ*DZ, LP(NZ,MX)
  END DO
  WRITE(20,*)
 END DO
 100 FORMAT(3(3X,F12.6))
 !101 FORMAT(4(3X,F12.6),3X,F12.6,SP,F12.6,SS,"i")
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 DEALLOCATE(PHI,PC,QC,P,Q,LP,LQ)
 CALL SYSTEM('gnuplot -p plot_xterm.plt')
 CALL SYSTEM('gnuplot -p plot_xterm_contour.plt')
 WRITE(*,*) "================================================"
 WRITE(*,*) "Input file  : ", TOPO
 WRITE(*,*) "================================================"
 WRITE(*,*) "Output file : CNPE2_TL.dat"
 WRITE(*,*) "              CNPE2_FIELD.dat"
 WRITE(*,*) "================================================"
 WRITE(*,*)
 WRITE(*,*) "System size (N x M) :", N, M
 WRITE(*,*) "Step size :", DR
 WRITE(*,*) "Main CPU time (s) :", TF-TI
 WRITE(*,*) "Real pressure at the source - P0 (Pa) :", P0
 WRITE(*,*) "Real pressure at the target - PR (Pa) :", PR
 WRITE(*,*) "SPL/TL at the source - LP0 (dB) :", LP0
 WRITE(*,*) "SPL/TL at the target - LPR (dB) :", LPR
 WRITE(*,*)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
END PROGRAM CNPE2_HF