program utest

    use AVD, T1=>avd_d1, T2=>avd_d2, T3=>avd_d3, T4=>avd_d4

    real(8)  :: c, t

    t = 0.5d0
    call init

    t_1: block
        type(T1) :: a, u, v, w, s, ref
        a = t
        u = sin(a)
        v = cos(a)
        w = u*v ! w = sin(x)*cos(x) == 0.5*sin(2x) :: D(w) = cos(2x) ; DD(w) = -2*sin(2x)
        ref = T1(0.5*sin(1.0),cos(1.0)) !,-2*sin(1.0d0)) !,-4*cos(1.0d0),8*sin(1.0d0))
        call testResult_av1('T1 => sin(x)*cos(x)',ref,w)

        u = 0.5*sin(2*a)
        call testResult_av1('T1 => 0.5*sin(2x)',ref,u)

        s = 0.5
        w = s**3 + s
        ref = T1(0.5**3+0.5,3*0.5**2 + 1) !,6*0.5) !, 6, 0)
        call testResult_av1('T1 => x**3 + x',ref,w)

        w = (3*s + 1) * (1 + s) * (1 - s)
        ref = T1((3*t + 1)*(1 + t)*(1 - t),3-2*t-9*t**2) !,-18*t-2,-18.0d0)
        call testResult_av1('T1 => (3*x + 1)*(1 + x)*(1 - x)',ref,w)
    end block t_1

    t_2: block
        type(T2) :: a, u, v, w, s, ref
        a = t
        u = sin(a)
        v = cos(a)
        w = u*v ! w = sin(x)*cos(x) == 0.5*sin(2x) :: D(w) = cos(2x) ; DD(w) = -2*sin(2x)
        ref = T2(0.5*sin(1.0),cos(1.0),-2*sin(1.0)) !,-4*cos(1.0d0),8*sin(1.0d0))
        call testResult_av2('T2 => sin(x)*cos(x)',ref,w)

        u = 0.5*sin(2*a)
        call testResult_av2('T2 => 0.5*sin(2x)',ref,u)

        s = 0.5
        w = s**3 + s
        ref = T2(0.5**3+0.5,3*0.5**2 + 1,6*0.5) !, 6, 0)
        call testResult_av2('T2 => x**3 + x',ref,w)

        w = (3*s + 1) * (1 + s) * (1 - s)
        ref = T2((3*t + 1)*(1 + t)*(1 - t),3-2*t-9*t**2,-18*t-2) !,-18.0d0)
        call testResult_av2('T2 => (3*x + 1)*(1 + x)*(1 - x)',ref,w)
    end block t_2

    t_3: block
        type(T3) :: a, u, v, w, s, ref

        a = t
        u = sin(a)
        v = cos(a)
        w = u*v ! w = sin(x)*cos(x) == 0.5*sin(2x) :: D(w) = cos(2x) ; DD(w) = -2*sin(2x)
        ref = T3(0.5*sin(1.0),cos(1.0),-2*sin(1.0),-4*cos(1.0)) !,8*sin(1.0d0))
        call testResult_av3('T3 => sin(x)*cos(x)',ref,w)

        u = 0.5*sin(2*a)
        call testResult_av3('T3 => 0.5*sin(2x)',ref,u)

        s = 0.5
        w = s**3 + s
        ref = T3(0.5**3+0.5,3*0.5**2 + 1,6*0.5, 6)
        call testResult_av3('T3 => x**3 + x',ref,w)

        w = (3*s + 1) * (1 - s) * (1 + s)
        ref = T3((3*t + 1)*(1 + t)*(1 - t),3-2*t-9*t**2,-18*t-2,-18.0)
        call testResult_av3('T3 => (3*x + 1)*(1 + x)*(1 - x)',ref,w)

        w = s**5
        c = t
        ref = T3(c**5,5*c**4,5*4*c**3,5*4*3*c**2)
        call testResult_av3('T3 => x**5',ref,w)

        w = (2 - 3*s)**5
        c = (2 - 3*t)
        ref = T3(c**5,5*(-3)*c**4,5*4*(-3)*(-3)*c**3,5*4*3*(-3)*(-3)*(-3)*c**2)
        call testResult_av3('T3 => (2-3x)**5',ref,w)
    end block t_3

    t_4: block
        type(T4) :: a, u, v, w, s, ref
        real(8)  :: r4, s4, y, y1, y2, y3
        a = t
        u = sin(a)
        v = cos(a)
        w = u*v ! w = sin(x)*cos(x) == 0.5*sin(2x) :: D(w) = cos(2x) ; DD(w) = -2*sin(2x)
        ref = T4(0.5*sin(1.0),cos(1.0),-2*sin(1.0),-4*cos(1.0),8*sin(1.0))
        call testResult_av4('T4 => sin(x)*cos(x)',ref,w)

        u = 0.5*sin(2*a)
        call testResult_av4('T4 => 0.5*sin(2x)',ref,u)

        s = 0.5
        w = s**3 + s
        ref = T4(0.5**3+0.5,3*0.5**2 + 1,6*0.5, 6, 0)
        call testResult_av4('T4 => x**3 + x',ref,w)

        w = (3*s + 1) * (1 + s) * (1 - s)
        ref = T4((3*t + 1)*(1 + t)*(1 - t),3-2*t-9*t**2,-18*t-2,-18.0, 0.0)
        call testResult_av4('T4 => (3*x + 1)*(1 + x)*(1 - x)',ref,w)

        w = (2 - 3*s)**5
        ref = T4(t**5,5*(-3)*t**4,5*4*(-3)*(-3)*t**3,5*4*3*(-3)*(-3)*(-3)*t**2,5*4*3*2*(-3)*(-3)*(-3)*(-3)*t)
        call testResult_av4('T4 => (2-3x)**5',ref,w)

        w = 1/s;
        ref = T4(1/0.5,-(1/0.5**2),2/(0.5**3),-6/(0.5**4),24/(0.5**5))
        call testResult_av4('T4 => 1/x',ref,w)

        w = 1/sqrt(4-s**2)
        s4 = 1/sqrt(4-t**2)
        r4 = 24*(0.5**4 + 12*0.5**2 + 6)*s4**9
        ref = T4( &
        s4, &
        0.5*s4**3, &
        s4**3 + 3*0.5**2*s4**5, &
        3*0.5*s4**5*(3+5*(0.5*s4)**2), &
        r4)
        call testResult_av4('T4 => 1/sqrt(4-x**2)',ref,w)

        w = tan(s)
        y = tan(t)
        ref = T4(y, 1+y**2, 2*y*(1+y**2), 2*(1+3*y**2)*(1+y**2), 8*y*(3*y**2+2)*(1+y**2))
        call testResult_av4('T4 => tan(x)',ref,w)
        w = 2*tan(s/2) / (1-tan(s/2)**2)
        call testResult_av4('T4 => 2tan(x/2)/(1-tan(x/2)**2) == tan(x)',ref,w)

        w = s*exp(2*s)
        y = exp(2*t)
        ref = T4(t*y,(2*t+1)*y,4*(t+1)*y,4*(2*t+3)*y,16*(t+2)*y)
        call testResult_av4('T4 => x*exp(2x)',ref,w)

        w = s*log(2*s)
        y = log(2*t)
        ref = T4(t*y,1+log(2.0)+log(t),1/t,-1/t**2,2/t**3)
        call testResult_av4('T4 => x*log(2x)',ref,w)

        u = 0.5*sinh(2*a)
        ref = T4(0.5*sinh(1.0),cosh(1.0),2*sinh(1.0),4*cosh(1.0),8*sinh(1.0))
        call testResult_av4('T4 => 0.5*sinh(2x)',ref,u)

        u = 0.5*cosh(2*a)
        ref = T4(0.5*cosh(1.0),sinh(1.0),2*cosh(1.0),4*sinh(1.0),8*cosh(1.0))
        call testResult_av4('T4 => 0.5*cosh(2x)',ref,u)

        w = tanh(s)
        y = tanh(t)
        y1 = 1 - y**2
        y2 = -2*y*y1
        y3 = -2*(y1**2 + y*y2)
        ref = T4(y, y1, y2, y3, -2*(3*y1*y2 + y*y3))
        call testResult_av4('T4 => tanh(x)',ref,w)

        w = 2*tanh(s/2) / (1+tanh(s/2)**2)
        call testResult_av4('T4 => 2tanh(x/2)/(1+tanh(x/2)**2) == tanh(x)',ref,w)

        !w = 2**s
    end block t_4

    stop
    contains
!        subroutine testResult(str,ref,res)
!            character(len=*), intent(in) :: str
!            class(auto_var_u), intent(in) :: res
!            class(auto_var_u), intent(in) :: ref
!            if (res == ref) then
!                write(*,'(a)') 'passed'//' :: '//str
!                return
!            end if
!            write(*,'(a)') 'FAILED :: '//str//' => '//res%as_string()//' != '//ref%as_string()
!        end subroutine testResult

        subroutine testResult_av1(str,ref,res)
            character(len=*), intent(in) :: str
            type(T1), intent(in) :: res
            type(T1), intent(in) :: ref
            if (res == ref) then
                write(*,'(a)') 'passed'//' :: '//str
                return
            end if
            write(*,'(a)') 'FAILED :: '//str//' => '//res%as_string()//' != '//ref%as_string()
        end subroutine testResult_av1

        subroutine testResult_av2(str,ref,res)
            character(len=*), intent(in) :: str
            type(T2), intent(in) :: res
            type(T2), intent(in) :: ref
            if (res == ref) then
                write(*,'(a)') 'passed'//' :: '//str
                return
            end if
            write(*,'(a)') 'FAILED :: '//str//' => '//res%as_string()//' != '//ref%as_string()
        end subroutine testResult_av2

        subroutine testResult_av3(str,ref,res)
            character(len=*), intent(in) :: str
            type(T3), intent(in) :: res
            type(T3), intent(in) :: ref
            if (res == ref) then
                write(*,'(a)') 'passed'//' :: '//str
                return
            end if
            write(*,'(a)') 'FAILED :: '//str//' => '//res%as_string()//' != '//ref%as_string()
        end subroutine testResult_av3

        subroutine testResult_av4(str,ref,res)
            character(len=*), intent(in) :: str
            type(T4), intent(in) :: res
            type(T4), intent(in) :: ref
            if (res == ref) then
                write(*,'(a)') 'passed'//' :: '//trim(str)
                return
            end if
            write(*,'(a)') 'FAILED :: '//trim(str)//' => '//res%as_string()//' != '//ref%as_string()
        end subroutine testResult_av4

end program utest


program intrinsics_22
! Test min/max intrinsics both declarations and executable statements.
! Single and double precision, real only.
integer, parameter :: dp = kind(0.d0)

real, parameter :: &
    s1 = min(-5., 3.), &
    s1b = max(-5., 3.)
real(dp), parameter :: &
    d1 = min(-5._dp, 3._dp), &
    d1b = max(-5._dp, 3._dp)
integer, parameter :: &
    j1 = min(-5, 3), &
    j1b = max(-5, 3)

real :: x1, x2
real(dp) :: y1, y2
integer :: i1, i2

i1 = -5; i2 = 3
x1 = i1; y1 = i1;
x2 = i2; y2 = i2;
print *, min(-5., 3.), min(-5._dp, 3._dp), min(x1, x2), min(y1, y2), s1, d1
print *, max(-5., 3.), max(-5._dp, 3._dp), max(x1, x2), max(y1, y2), s1b, d1b
print *, min(-5, 3), min(i1, i2), j1
print *, max(-5, 3), max(i1, i2), j1b

end


!
!     Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
!
! NVIDIA CORPORATION and its licensors retain all intellectual property
! and proprietary rights in and to this software, related documentation
! and any modifications thereto.
!
!
!    These example codes are a portion of the code samples from the companion
!    website to the book "CUDA Fortran for Scientists and Engineers":
!
! http://store.elsevier.com/product.jsp?isbn=9780124169708
!

! This the main host code for the finite difference
! example.  The kernels are contained in the derivative_m
! module

program derivativeTest
    use cudafor
    use precision_m
    use derivative_m

    implicit none

    real(fp_kind), parameter :: fx = 10.0, fy = 10.0, fz = 10.0
    integer, parameter :: nReps = 2000

    real(fp_kind) :: f(mx,my,mz), df(mx,my,mz), sol(mx,my,mz)
    real(fp_kind), device :: f_d(mx,my,mz), df_d(mx,my,mz)
    real(fp_kind) :: twopi, error, maxError
    type(cudaEvent) :: startEvent, stopEvent
    type(cudaDeviceProp) :: prop

    real :: time
    integer :: i, j, k, istat

    ! Print device and precision

    istat = cudaGetDeviceProperties(prop, 0)
    write(*,"(/,'Device Name: ',a)") trim(prop%name)
    write(*,"('Compute Capability: ',i0,'.',i0)") &
         prop%major, prop%minor
    if (fp_kind == singlePrecision) then
       write(*,"('Single Precision')")
    else
       write(*,"('Double Precision')")
    end if

    ! initialize

    twopi = 8.*atan(1.d0)
    call setDerivativeParameters()

    istat = cudaEventCreate(startEvent)
    istat = cudaEventCreate(stopEvent)

    ! x-derivative using 64x4 tile

    write(*,"(/,'x derivatives')")

    do i = 1, mx
       f(i,:,:) = cos(fx*twopi*(i-1.)/(mx-1))
    enddo
    f_d = f
    df_d = 0

    call deriv_x<<<g_sp(1),b_sp(1)>>>(f_d, df_d)
    istat = cudaEventRecord(startEvent,0)
    do i = 1, nReps
       call deriv_x<<<g_sp(1),b_sp(1)>>>(f_d, df_d)
    enddo
    istat = cudaEventRecord(stopEvent,0)
    istat = cudaEventSynchronize(stopEvent)
    istat = cudaEventElapsedTime(time, startEvent, stopEvent)

    df = df_d

    do i = 1, mx
       sol(i,:,:) = -fx*twopi*sin(fx*twopi*(i-1.)/(mx-1))
    enddo

    error = sqrt(sum((sol-df)**2)/(mx*my*mz))
    maxError = maxval(abs(sol-df))

    write(*,"(/,'  Using shared memory tile of x-y: ', &
         i0, 'x', i0)") mx, sPencils
    write(*,*) '  RMS error: ', error
    write(*,*) '  MAX error: ', maxError
    write(*,*) '  Average time (ms): ', time/nReps
    write(*,*) '  Average Bandwidth (GB/s): ', &
         2.*1.e-6*sizeof(f)/(time/nReps)

    if (maxError .le. 0.00003_fp_kind) then
       write(*,*) '  Test Passed'
    else
       write(*,*) '  Test Failed'
    endif

    ! x-deriv - similar to above but first
    ! syncthreads removed

    do i = 1, mx
       f(i,:,:) = cos(fx*twopi*(i-1.)/(mx-1))
    enddo
    f_d = f
    df_d = 0

    call deriv_x_1sync<<<g_sp(1),b_sp(1)>>>(f_d, df_d)
    istat = cudaEventRecord(startEvent,0)
    do i = 1, nReps
       call deriv_x_1sync<<<g_sp(1),b_sp(1)>>>(f_d, df_d)
    enddo
    istat = cudaEventRecord(stopEvent,0)
    istat = cudaEventSynchronize(stopEvent)
    istat = cudaEventElapsedTime(time, startEvent, stopEvent)

    df = df_d

    do i = 1, mx
       sol(i,:,:) = -fx*twopi*sin(fx*twopi*(i-1.)/(mx-1))
    enddo

    error = sqrt(sum((sol-df)**2)/(mx*my*mz))
    maxError = maxval(abs(sol-df))

    write(*,"(/,a,a, i0, 'x', i0)") &
         '  Single syncthreads,', &
         ' using shared memory tile of x-y: ', &
         mx, sPencils
    write(*,*) '  RMS error: ', error
    write(*,*) '  MAX error: ', maxError
    write(*,*) '  Average time (ms): ', time/nReps
    write(*,*) '  Average Bandwidth (GB/s): ', &
         2.*1.e-6*sizeof(f)/(time/nReps)

    if (maxError .le. 0.00003_fp_kind) then
       write(*,*) '  Test Passed'
    else
       write(*,*) '  Test Failed'
    endif

    ! x-deriv - uses extended tile (lPencils)

    do i = 1, mx
       f(i,:,:) = cos(fx*twopi*(i-1.)/(mx-1))
    enddo
    f_d = f
    df_d = 0

    call deriv_x_lPencils<<<g_lp(1),b_lp(1)>>>(f_d, df_d)
    istat = cudaEventRecord(startEvent,0)
    do i = 1, nReps
       call deriv_x_lPencils<<<g_lp(1),b_lp(1)>>>(f_d, df_d)
    enddo
    istat = cudaEventRecord(stopEvent,0)
    istat = cudaEventSynchronize(stopEvent)
    istat = cudaEventElapsedTime(time, startEvent, stopEvent)

    df = df_d

    do i = 1, mx
       sol(i,:,:) = -fx*twopi*sin(fx*twopi*(i-1.)/(mx-1))
    enddo

    error = sqrt(sum((sol-df)**2)/(mx*my*mz))
    maxError = maxval(abs(sol-df))

    write(*,"(/,'  Using shared memory tile of x-y: ', &
         i0, 'x', i0)") mx, lPencils
    write(*,*) '  RMS error: ', error
    write(*,*) '  MAX error: ', maxError
    write(*,*) '  Average time (ms): ', time/nReps
    write(*,*) '  Average Bandwidth (GB/s): ', &
         2.*1.e-6*sizeof(f)/(time/nReps)

    if (maxError .le. 0.00003_fp_kind) then
       write(*,*) '  Test Passed'
    else
       write(*,*) '  Test Failed'
    endif

    ! y-derivative

    write(*,"(/,'y derivatives')")

    do j = 1, my
       f(:,j,:) = cos(fy*twopi*(j-1.)/(my-1))
    enddo
    f_d = f
    df_d = 0

    call deriv_y<<<g_sp(2), b_sp(2)>>>(f_d, df_d)
    istat = cudaEventRecord(startEvent,0)
    do i = 1, nReps
       call deriv_y<<<g_sp(2), b_sp(2)>>>(f_d, df_d)
    enddo
    istat = cudaEventRecord(stopEvent,0)
    istat = cudaEventSynchronize(stopEvent)
    istat = cudaEventElapsedTime(time, startEvent, stopEvent)

    df = df_d

    do j = 1, my
       sol(:,j,:) = -fy*twopi*sin(fy*twopi*(j-1.)/(my-1))
    enddo

    error = sqrt(sum((sol-df)**2)/(mx*my*mz))
    maxError = maxval(abs(sol-df))

    write(*,"(/,'  Using shared memory tile of x-y: ', &
         i0, 'x', i0)") sPencils, my
    write(*,*) '  RMS error: ', error
    write(*,*) '  MAX error: ', maxError
    write(*,*) '  Average time (ms): ', time/nReps
    write(*,*) '  Average Bandwidth (GB/s): ', &
         2.*1.e-6*sizeof(f)/(time/nReps)

    if (maxError .le. 0.00003_fp_kind) then
       write(*,*) '  Test Passed'
    else
       write(*,*) '  Test Failed'
    endif

    ! y-derivative lPencils

    do j = 1, my
       f(:,j,:) = cos(fy*twopi*(j-1.)/(my-1))
    enddo
    f_d = f
    df_d = 0

    call deriv_y_lPencils<<<g_lp(2), b_lp(2)>>>(f_d, df_d)
    istat = cudaEventRecord(startEvent,0)
    do i = 1, nReps
       call deriv_y_lPencils<<<g_lp(2), b_lp(2)>>>(f_d, df_d)
    enddo
    istat = cudaEventRecord(stopEvent,0)
    istat = cudaEventSynchronize(stopEvent)
    istat = cudaEventElapsedTime(time, startEvent, stopEvent)

    df = df_d

    do j = 1, my
       sol(:,j,:) = -fy*twopi*sin(fy*twopi*(j-1.)/(my-1))
    enddo

    error = sqrt(sum((sol-df)**2)/(mx*my*mz))
    maxError = maxval(abs(sol-df))

    write(*,"(/,'  Using shared memory tile of x-y: ', &
         i0, 'x', i0)") lPencils, my
    write(*,*) '  RMS error: ', error
    write(*,*) '  MAX error: ', maxError
    write(*,*) '  Average time (ms): ', time/nReps
    write(*,*) '  Average Bandwidth (GB/s): ', &
         2.*1.e-6*sizeof(f)/(time/nReps)

    if (maxError .le. 0.00003_fp_kind) then
       write(*,*) '  Test Passed'
    else
       write(*,*) '  Test Failed'
    endif

    ! z-derivative

    write(*,"(/,'z derivatives')")

    do k = 1, mz
       f(:,:,k) = cos(fz*twopi*(k-1.)/(mz-1))
    enddo
    f_d = f
    df_d = 0

    call deriv_z<<<g_sp(3),b_sp(3)>>>(f_d, df_d)
    istat = cudaEventRecord(startEvent,0)
    do i = 1, nReps
       call deriv_z<<<g_sp(3),b_sp(3)>>>(f_d, df_d)
    enddo
    istat = cudaEventRecord(stopEvent,0)
    istat = cudaEventSynchronize(stopEvent)
    istat = cudaEventElapsedTime(time, startEvent, stopEvent)

    df = df_d

    do k = 1, mz
       sol(:,:,k) = -fz*twopi*sin(fz*twopi*(k-1.)/(mz-1))
    enddo

    error = sqrt(sum((sol-df)**2)/(mx*my*mz))
    maxError = maxval(abs(sol-df))

    write(*,"(/,'  Using shared memory tile of x-z: ', &
         i0, 'x', i0)") sPencils, mz
    write(*,*) '  RMS error: ', error
    write(*,*) '  MAX error: ', maxError
    write(*,*) '  Average time (ms): ', time/nReps
    write(*,*) '  Average Bandwidth (GB/s): ', &
         2.*1.e-6*sizeof(f)/(time/nReps)

    if (maxError .le. 0.00003_fp_kind) then
       write(*,*) '  Test Passed'
    else
       write(*,*) '  Test Failed'
    endif

    ! z-derivative lPencils

    do k = 1, mz
       f(:,:,k) = cos(fz*twopi*(k-1.)/(mz-1))
    enddo
    f_d = f
    df_d = 0

    call deriv_z_lPencils<<<g_lp(3),b_lp(3)>>>(f_d, df_d)
    istat = cudaEventRecord(startEvent,0)
    do i = 1, nReps
       call deriv_z_lPencils<<<g_lp(3),b_lp(3)>>>(f_d, df_d)
    enddo
    istat = cudaEventRecord(stopEvent,0)
    istat = cudaEventSynchronize(stopEvent)
    istat = cudaEventElapsedTime(time, startEvent, stopEvent)

    df = df_d

    do k = 1, mz
       sol(:,:,k) = -fz*twopi*sin(fz*twopi*(k-1.)/(mz-1))
    enddo

    error = sqrt(sum((sol-df)**2)/(mx*my*mz))
    maxError = maxval(abs(sol-df))

    write(*,"(/,'  Using shared memory tile of x-z: ', &
         i0, 'x', i0)") lPencils, mz
    write(*,*) '  RMS error: ', error
    write(*,*) '  MAX error: ', maxError
    write(*,*) '  Average time (ms): ', time/nReps
    write(*,*) '  Average Bandwidth (GB/s): ', &
         2.*1.e-6*sizeof(f)/(time/nReps)

    if (maxError .le. 0.00003_fp_kind) then
       write(*,*) '  Test Passed'
    else
       write(*,*) '  Test Failed'
    endif
    write(*,*)

  end program derivativeTest


module nonlinalg
  use iso_fortran_env, only: wp => real64
  use linalg, only: linsolve_quick
  implicit none

  ! real(wp), parameter :: pi = 4._wp * datan(1._wp)

  interface
    function fun_interf(n, x) result(y)
      import wp
      integer,  intent(in)                  :: n
      real(wp), intent(in), dimension(n)    :: x
      real(wp),             dimension(n)    :: y
    end function
  end interface

contains

  function nonlinsolve(myfun, n, x0) result(x)
    integer,  intent(in)                  :: n
    real(wp), intent(in), dimension(n)    :: x0
    procedure(fun_interf)                 :: myfun

    integer                   :: ii, maxit = 100
    real(wp), dimension(n)    :: x, z, b
    real(wp), dimension(n,n)  :: jac
    real(wp), parameter       :: eps = epsilon(1e0)

    x = x0
    ii = 1

    do

      b = myfun(n,x)
      if ( ii == 1 .or. modulo(ii, 1) == 0 ) then
        jac = jacobian(myfun, n, x)
      end if

      call linsolve_quick(n, jac, 1, -b, z)

      ! print '(8(f13.6))', x, norm2(z), norm2(myfun(n, x))

      x = x + z

      ! if ( norm2(myfun(n, x)) < eps ) exit
      if ( norm2(z) < eps ) exit

      if ( ii == maxIt ) then
        print*, " *** Error: Maximum Number of Iterations Reached *** "
        print*, " *** Number of Iterations in multivariate Newton's Method reached *** "
        stop
      end if

      ii = ii + 1
    end do

  end function nonlinsolve

  function jacobian(fun, n, x) result(dydx)
    integer,  intent(in)                  :: n
    real(wp), intent(in), dimension(n)    :: x
    real(wp),             dimension(n,n)  :: dydx
    procedure(fun_interf)                 :: fun

    integer                   :: jj
    real(wp), dimension(n)    :: xx, fun_plus, fun_minus
    real(wp), parameter       :: eps = epsilon(1e0)

    ! print*,
    ! print*, "Now Calculating jacobian"
    ! print*,

    dydx = 0._wp

    ! do jj = 1,n
    !   print*, dydx(jj,:)
    ! end do
    ! stop

    !$omp parallel do &
    !$omp& private (jj, xx, fun_plus, fun_minus) shared(dydx, x, n)
    do jj = 1,n
      xx = x
      xx(jj) = xx(jj) + eps
      fun_plus = fun(n, xx)

      xx = x
      xx(jj) = xx(jj) - eps
      fun_minus = fun(n, xx)

      dydx(:,jj) = (fun_plus - fun_minus ) / (2._wp * eps)
    end do
    !$omp end parallel do

    ! do jj = 1,n
    !   print*, dydx(jj,:)
    ! end do
    ! stop

    return
  end function jacobian

end module nonlinalg


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 3 node
!!  trianglar element (Langrange  interpolation)
module shape_tri3n
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_tri3n(areacoord,func)
    real(kind=kreal), intent(in) :: areacoord(2)
    real(kind=kreal) :: func(3)
    func(1:2) = areacoord(1:2)
    func(3)   = 1.d0-areacoord(1)-areacoord(2)
  end subroutine

  subroutine ShapeDeriv_tri3n(func)
    real(kind=kreal) :: func(3,2)
    func(1,1) = 1.d0
    func(2,1) = 0.d0
    func(3,1) = -1.d0

    func(1,2) = 0.d0
    func(2,2) = 1.d0
    func(3,2) = -1.d0
  end subroutine

  subroutine Shape2ndDeriv_tri3n(func)
    real(kind=kreal) :: func(3,2,2)
    func(:,:,:) = 0.d0
  end subroutine

  ! (Gaku Hashimoto, The University of Tokyo, 2012/11/15) <
  !####################################################################
  subroutine NodalNaturalCoord_tri3n(nncoord)
    !####################################################################

    implicit none

    !--------------------------------------------------------------------

    real(kind = kreal), intent(out) :: nncoord(3, 2)

    !--------------------------------------------------------------------

    ! xi-coordinate at a node in a local element
    nncoord(1, 1) =  1.0D0
    nncoord(2, 1) =  0.0D0
    nncoord(3, 1) =  0.0D0
    ! eta-coordinate at a node in a local element
    nncoord(1, 2) =  0.0D0
    nncoord(2, 2) =  1.0D0
    nncoord(3, 2) =  0.0D0

    !--------------------------------------------------------------------

    return

    !####################################################################
  end subroutine NodalNaturalCoord_tri3n
  !####################################################################
  ! > (Gaku Hashimoto, The University of Tokyo, 2012/11/15)

end module


subroutine jacobi2d_sub(n, tol, maxiter, iter, dumax, nthreads)
    ! Implements 2d jacobi iteration on n by n grid
    ! Inputs:  n, tol, maxiter, nthreads
    ! Outputs: iter, dumax

    use omp_lib ! #include <omp.h>
    implicit none
    integer, intent(in) :: n, maxiter, nthreads
    integer, intent(out) :: iter

    ! Timing variables
    integer :: clock_start, clock_finish, clock_rate
    real(kind=8) :: elapsed_time

    real(kind=8), intent(in) :: tol
    real(kind=8), intent(out) :: dumax

    ! local variables:
    integer, parameter :: nprint = 100000
    real(kind=8), dimension(:,:), allocatable :: u,uold,f
    ! two dimension array
    real(kind=8), dimension(:), allocatable :: x,y
    ! one dimension array
    real(kind=8) :: h
    integer :: i,j

    ! allocate storage for boundary points too:
    allocate(x(0:n+1), y(0:n+1), u(0:n+1, 0:n+1), uold(0:n+1, 0:n+1), &
             f(0:n+1, 0:n+1))

    open(unit=20, file="solution.txt", status="unknown")
    ! where 'status' may be 'OLD', 'NEW', 'REPLACE', 'SCRATCH' or 'UNKNOWN'. If 'OLD' is specified the file must exist; if 'NEW' the file must not exist; if 'REPLACE' and the file exists it will be deleted before a new file is created; and if 'SCRATCH' the file will be deleted when closed. In general use 'OLD' for input and 'NEW' for output. 'UNKNOWN', to connect an existing file, or to create and connect a new file. If the file exists, it is connected as OLD. If the file does not exist, it is connected as NEW.

    ! 1x1 size square
    ! grid spacing:
    h = 1.d0 / (n+1.d0)

    do i=0,n+1
        ! grid points in x:
        x(i) = i*h

        ! boundary conditions:
        ! bottom boundary y=0:
        u(i,0) = 0.d0
        ! top boundary y=1:
        if ((x(i) <= 0.3d0) .or. (x(i) >= 0.7d0)) then
           u(i,n+1) = 0.d0
        else
           u(i,n+1) = 1.d0
        endif
    enddo

    do j=0,n+1
        ! grid points in y:
        y(j) = j*h

        ! boundary conditions:
        ! left boundary x=0
        u(0,j) = 0.d0
        ! right boundary x=1
        if ((y(j) <= 0.3d0) .or. (y(j) >= 0.7d0)) then
           u(n+1,j) = 0.d0
        else
           u(n+1,j) = 1.d0
        endif
        enddo

    do j=1,n
        do i=1,n
            ! source term:
            f(i,j) = 0.d0
            ! initial guess:
            u(i,j) = 0.d0
            enddo
        enddo

    ! tolerance and max number of iterations:
    !print *, "Convergence tolerance: tol = ",tol
    !print *, "Maximum number of iterations: maxiter = ",maxiter

    !$ call omp_set_num_threads(nthreads)
    !$ if (nthreads == 1) then
    !$    print "('Using only 1 thread')"
    !$ else
    !$    print "('Using OpenMP with ',i3,' threads')", nthreads
    !$ endif

    call system_clock(clock_start,clock_rate)

    ! Jacobi iteratation:

    do iter=1,maxiter
        uold = u         ! old values
        dumax = 0.d0
        !$omp parallel do private(i) reduction(max : dumax)
        ! private - only be accessed by a single thread.
        do j=1,n
            do i=1,n
                u(i,j) = 0.25d0*(uold(i-1,j) + uold(i+1,j) + &
                                 uold(i,j-1) + uold(i,j+1) + h**2*f(i,j))
                dumax = max(dumax, abs(u(i,j)-uold(i,j)))
            enddo
        enddo

        if (mod(iter,nprint)==0) then
            print 203, iter, dumax
203         format("After ",i8," iterations, dumax = ",d16.6,/)
            endif
        ! check for convergence:
        if (dumax .lt. tol) exit

        enddo

    call system_clock(clock_finish,clock_rate)
    elapsed_time = real(clock_finish - clock_start,kind=8) / &
                    real(clock_rate,kind=8)

    print "('Converged in ',i6,' iterations')", iter
    ! i6 - 6 characters wide
    print "('Elapsed time: ', f10.3,' seconds')", elapsed_time
    ! f10.3 - floating number, 10 characters wide, 3 decimal places.

    ! print out solution to file:

    do j=0,n+1
        do i=0,n+1
            write(20,222) x(i), y(j), u(i,j)
            enddo
        enddo
222 format(3e20.10)
! three

    !print *, "Solution is in solution.txt"
    print *, ' '

    close(20)

end subroutine jacobi2d_sub


PROGRAM main

  USE mo_kind,   ONLY: dp, sp, i4
  USE mo_corr,   ONLY: autocoeffk, autocorr, corr, crosscoeffk, crosscorr
  USE mo_moment, ONLY: mean, variance, covariance
  use mo_ansi_colors, only: color, c_red, c_green

  IMPLICIT NONE

  INTEGER(i4), PARAMETER :: n = 1500_i4
  REAL(dp), DIMENSION(n) :: dat1, dat2, dc
  REAL(sp), DIMENSION(n) :: sat1, sat2, sc
  INTEGER(i4) :: i, nout

  LOGICAL :: isgood

  Write(*,*) ''
  Write(*,*) 'Test mo_corr.f90'

  ! Double precision
  forall(i=1:n) dat1(i) = real(i,dp)
  dat2 = dat1 + sin(dat1)
  isgood = .true.
  if (abs(variance(dat2) - autocoeffk(dat2,0)) > epsilon(1.0_dp)) isgood = .false.
  if (abs(variance(dat2, ddof=1_i4) - autocoeffk(dat2,0, ddof=1_i4)) > epsilon(1.0_dp)) isgood = .false.
  if (abs(autocorr(dat2,0) - 1.0_dp) > epsilon(1.0_dp)) isgood =.false.
  if (abs(covariance(dat1,dat2) - crosscoeffk(dat1,dat2,0))> epsilon(1.0_dp)) isgood =.false.
  if (abs(autocorr(dat1,10) - crosscorr(dat1,dat1,10))> epsilon(1.0_dp)) isgood =.false.
  ! Covariance function: covariance(x,y) = corr(x,y)/n
  call random_number(dat1)
  dat2 = dat1 + sin(dat1)
  dc = corr(dat1-mean(dat1), dat2-mean(dat2), nadjust=nout)
  if (abs(dc(1)/real(nout,dp) - covariance(dat1,dat2)) > 0.01_dp) isgood =.false.

  if (isgood) then
     write(*,*) 'mo_corr double precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_corr double precision ', color('failed!', c_red)
  endif

  ! Single precision
  forall(i=1:n) sat1(i) = real(i,sp)
  sat2 = sat1 + sin(sat1)
  isgood = .true.
  if (nint(variance(sat2)) /= nint(autocoeffk(sat2,0))) isgood =.false.
  if (abs(variance(sat2, ddof=1_i4) - autocoeffk(sat2,0, ddof=1_i4)) > epsilon(1.0_sp)) isgood = .false.
  if (abs(autocorr(sat2,0) - 1.0_sp) > epsilon(1.0_sp)) isgood =.false.
  if (abs(covariance(sat1,sat2) - crosscoeffk(sat1,sat2,0))> epsilon(1.0_sp)) isgood =.false.
  if (abs(autocorr(sat1,10) - crosscorr(sat1,sat1,10))> epsilon(1.0_sp)) isgood =.false.
  ! Covariance function: covariance(x,y) = corr(x,y)/n
  call random_number(sat1)
  sat2 = sat1 + sin(sat1)
  sc = corr(sat1-mean(sat1), sat2-mean(sat2), nadjust=nout)
  if (abs(sc(1)/real(nout,sp) - covariance(sat1,sat2)) > 0.01_sp) isgood =.false.

  if (isgood) then
     write(*,*) 'mo_corr single precision ', color('o.k.', c_green)
  else
     write(*,*) 'mo_corr single precision ', color('failed!', c_red)
  endif

END PROGRAM main


       REAL*8 FUNCTION SBESSJ(N,X)
       IMPLICIT REAL*8 (A-H,O-Z)
C
C
C
       PARAMETER(ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,ZERO=0.0D0)
       PARAMETER(FIVE = 5.0D0,TEN = 10.0D0,FOURTN = 14.0D0)
C
C      SPHERICAL BESSEL FUNCTION OF THE FIRST KIND
C
       IF(ABS(X) .GT. 0.001) THEN
         SB0 = SIN(X)/X
       ELSE
         X2 = X*X/TWO
         SB0 = ONE - (X2/THREE)*(ONE - X2/TEN)
       ENDIF
       IF(N .EQ. 0) THEN
         SBESSJ = SB0
       ELSE
         IF(ABS(X) .GT. 0.001) THEN
           SB1 = (SIN(X)/X - COS(X)) / X
         ELSE
           X2 = X*X/TWO
           SB1 = (X/THREE)*(ONE - (X2/FIVE)*(ONE - X2/FOURTN))
         ENDIF
         IF(N .EQ. 1) THEN
           SBESSJ = SB1
         ELSEIF(X .EQ. ZERO) THEN
           SBESSJ = ZERO
         ELSE
           BY = SB1
           BYM = SB0
           UX = ONE / X
           DO 10 J=1,N-1
             BYP = REAL(2*J+1)*UX*BY - BYM
             BYM = BY
             BY = BYP
 10        CONTINUE
           SBESSJ = BY
         ENDIF
       ENDIF
       RETURN
       END


      REAL    FUNCTION  POLY (XPT, XPTS, YPTS, NDEG)

C***********************************************************************
C Version "$Id: poly.f 1 2017-06-10 18:05:20Z coats $"
C EDSS/Models-3 I/O API.
C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr.,
C (C) 2003-2010 by Baron Advanced Meteorological Systems.
C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1
C See file "LGPL.txt" for conditions of use.
C.........................................................................
C  function body starts at line  64
C
C  FUNCTION:
C        Performs arbitrary-degree polynomial interpolation for XPT on
C        curve determined by XPTS and YPTS using Newton divided-differences.
C  NOTE:  high-order purely polynomial interpolations have stability
C         problems.  NDEG <= 5 is recommended. -- CJC
C
C  REVISION HISTORY:
C
C    11/88   Modified for ROMNET
C    ??/90   Modified for ROM 2.2 by CJC:  scalar coefficient arithmetic --
C            no restrictions on NDEG
C    4/91    Modified by CJC:  optimized initialization
C       Modified 03/2010 by CJC: F9x changes for I/O API v3.1
C
C  ARGUMENT LIST DESCRIPTION:
C
C    Input arguments:
C        :XPT       point on curve whose value is to be determined
C        :XPTS      points at which function values are known
C                   (there are NDEG + 1 values necessary)
C        :YPTS      function values at each of XPTS
C        :NDEG      degree of polynomial
C
C    Function Value:  POLY      interpolated value at XPT
C
C***********************************************************************

        IMPLICIT NONE

C...........   ARGUMENTS:

        INTEGER, INTENT(IN   ) :: NDEG
        REAL   , INTENT(IN   ) :: XPT
        REAL   , INTENT(IN   ) :: XPTS ( NDEG + 1 )
        REAL   , INTENT(IN   ) :: YPTS ( NDEG + 1 )

C...........   LOCAL VARIABLES:

        INTEGER         I, J, K
        REAL            TDIFF, COEFF
        REAL            DSCR, XSCR, YSCR

C........................................................................
C.......   begin body of POLY

C.......   Compute divided differences: denominator is a product for J <> K.
C.......   Initialization uses unrolled degree I=1 (linear interpolation terms)

        XSCR  =  XPTS ( 1 )
        COEFF =  XPT  -  XSCR
        DSCR  =  COEFF / ( XSCR  -  XPTS( 2 ) )
        YSCR  =  YPTS ( 1 )
        POLY  =  YSCR  +  DSCR * ( YSCR  -  YPTS( 2 ) )

C.......   Now compute higher order terms using divided differences:
C.......   denom is a product for J <> K.

        DO  144  I = 2, NDEG

C.......   Initialization uses unrolled K=1 case.

            XSCR = XPTS ( 1 )
            DSCR = XSCR - XPTS ( 2 )

            DO  100  J = 3 , I + 1
                DSCR = DSCR * ( XSCR - XPTS ( J ) )
100         CONTINUE

            TDIFF  =  YPTS ( 1 ) / DSCR

            DO  133  K = 2, I + 1       !  loop on points K

                XSCR = XPTS ( K )
                DSCR = XSCR - XPTS ( 1 )

                DO  111  J = 2 , K - 1
                    DSCR = DSCR * ( XSCR - XPTS ( J ) )
111             CONTINUE                ! end loop: j not k, part 1

                DO  122  J = K + 1 , I + 1
                    DSCR = DSCR * ( XSCR - XPTS ( J ) )
122             CONTINUE                ! end loop: j not k, part 2

C...........   Compute differences term:

                TDIFF  =  TDIFF  +  YPTS ( K ) / DSCR

133         CONTINUE            !  end loop on points K

C...........   Compute polynomial coefficients:

            COEFF  =  COEFF * ( XPT  -  XPTS ( I ) )

C...........   Compute interpolated value

            POLY = POLY  +  COEFF * TDIFF

144     CONTINUE        !  end loop on terms of degree I

        RETURN
        END FUNCTION POLY


subroutine compute_flux(phi, ng_p, fluxx, fluxy, ng_f, lo, hi, dx)

  implicit none

  integer lo(2),hi(2),ng_p,ng_f
  double precision   phi(lo(1)-ng_p:hi(1)+ng_p,lo(2)-ng_p:hi(2)+ng_p)
  double precision fluxx(lo(1)-ng_f:hi(1)+ng_f+1,lo(2)-ng_f:hi(2)+ng_f)
  double precision fluxy(lo(1)-ng_f:hi(1)+ng_f,lo(2)-ng_f:hi(2)+ng_f+1)
  double precision dx

  ! local variables
  integer i,j

  ! x-fluxes
  do j=lo(2),hi(2)
     do i=lo(1),hi(1)+1
        fluxx(i,j) = ( phi(i,j) - phi(i-1,j) ) / dx
     end do
  end do

  ! y-fluxes
  do j=lo(2),hi(2)+1
     do i=lo(1),hi(1)
        fluxy(i,j) = ( phi(i,j) - phi(i,j-1) ) / dx
     end do
  end do

end subroutine compute_flux

subroutine update_phi(phiold, phinew, ng_p, fluxx, fluxy, ng_f, lo, hi, dx, dt)

  integer          :: lo(2), hi(2), ng_p, ng_f
  double precision :: phiold(lo(1)-ng_p:hi(1)+ng_p,lo(2)-ng_p:hi(2)+ng_p)
  double precision :: phinew(lo(1)-ng_p:hi(1)+ng_p,lo(2)-ng_p:hi(2)+ng_p)
  double precision ::  fluxx(lo(1)-ng_f:hi(1)+ng_f+1,lo(2)-ng_f:hi(2)+ng_f)
  double precision ::  fluxy(lo(1)-ng_f:hi(1)+ng_f,lo(2)-ng_f:hi(2)+ng_f+1)
  double precision :: dx, dt

  ! local variables
  integer i,j

  do j=lo(2),hi(2)
     do i=lo(1),hi(1)

        phinew(i,j) = phiold(i,j) + dt * &
             ( fluxx(i+1,j)-fluxx(i,j) + fluxy(i,j+1)-fluxy(i,j) ) / dx

     end do
  end do

end subroutine update_phi


ELEMENTAL FUNCTION func_hypergeometric(a, b, c, z) RESULT(ans)
    ! NOTE: See https://en.wikipedia.org/wiki/Hypergeometric_function
    ! NOTE: See https://docs.scipy.org/doc/scipy/reference/generated/scipy.special.hyp2f1.html

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    REAL(kind = REAL64)                                                         :: ans
    REAL(kind = REAL64), INTENT(in)                                             :: a
    REAL(kind = REAL64), INTENT(in)                                             :: b
    REAL(kind = REAL64), INTENT(in)                                             :: c
    REAL(kind = REAL64), INTENT(in)                                             :: z

    ! Declare internal parameters ...
    INTEGER(kind = INT64), PARAMETER                                            :: imax = 1024_INT64
    REAL(kind = REAL64), PARAMETER                                              :: epsmin = 1.0e-10_REAL64

    ! Declare internal variables ...
    INTEGER(kind = INT64)                                                       :: i
    REAL(kind = REAL64)                                                         :: eps
    REAL(kind = REAL64)                                                         :: n

    ! Check that this value of z means that the answer is obtainable via the
    ! power series ...
    IF(ABS(z) < 1.0e0_REAL64)THEN
        ! Initialize answer ...
        ans = 1.0e0_REAL64

        ! Loop over iterations ...
        DO i = 1_INT64, imax
            ! Create short-hand ...
            n = REAL(i, kind = REAL64)

            ! Calculate increment ...
            eps = (func_rising_factorial(a, n) * func_rising_factorial(b, n) * (z ** i)) / (func_rising_factorial(c, n) * func_factorial(n))

            ! Increment answer ...
            ans = ans + eps

            ! Stop looping if the answer has converged ...
            IF(ABS(eps / ans) <= epsmin)THEN
                EXIT
            END IF
        END DO
    ELSE
        ! Set value ...
        ans = 0.0e0_REAL64
    END IF
END FUNCTION func_hypergeometric


MODULE matrices

  IMPLICIT NONE

CONTAINS

  FUNCTION one_norm(m,n,A)
    INTEGER, INTENT(in) :: m,n,A(m,n)
    INTEGER :: one_norm
    INTEGER :: icol, colsum
    one_norm = -HUGE(one_norm)
    DO icol = 1,n
      colsum = SUM(A(:,icol))
      IF (colsum > one_norm) one_norm = colsum
    END DO
  END FUNCTION one_norm

  ! Test assumed size
  FUNCTION one_norm_2(m,A) RESULT(one_norm)
    INTEGER, INTENT(in) :: m, A(m,*)
    INTEGER :: one_norm
    INTEGER :: icol, colsum, n
    n = 2
    one_norm = -HUGE(one_norm)
    DO icol = 1,n
      colsum = SUM(A(:,icol))
      IF (colsum > one_norm) one_norm = colsum
    END DO
  END FUNCTION one_norm_2

  SUBROUTINE multiply(m,n,A,b,Ab)
    INTEGER, INTENT(in) :: m,n, b(n)
    INTEGER, INTENT(in), DIMENSION(m,n) :: A
    INTEGER, INTENT(out) :: Ab(m)
    Ab = MATMUL(A,b)
  END SUBROUTINE multiply

END MODULE matrices


PARAMETER(IM=102)

real C(IM), CN(IM), K, DT, DX
INTEGER I,J,IN

DX = 100
DT = 100
K = 10
r = K * DT/DX **2

DO I = 1, IM
    C(I) = 0
ENDDO
C(50) = 100

DO 20 IT =1, 1000
    DO I =2, IM-1
        CN(I) = (1-2*r) * C(I) + r * C(I+1) + r*C(I-1)
    ENDDO
    ! 虚拟边界
    CN(1) = CN(2)
    CN(IM) = CN(IM-1)

    DO I = 1, IM
        C(I) = CN(I)
    ENDDO
Continue

OPEN(1, FILE = 'concentration.dat')

DO I = 1, IM
    write(1,*) I, C(I)
ENDDO
CLOSE(1)

END


!------------------------------------------------------
! Module containing routines to perform fitting
!            Written by Y. Han, July 18, 2008
!------------------------------------------------------
MODULE Regression

  USE type_kinds         , ONLY : fp_kind
  USE Message_Handler    , ONLY : SUCCESS, FAILURE, Display_Message
!  USE Common_parameters

  ! ---------------------------
  ! Disable all implicit typing
  ! ---------------------------

  IMPLICIT NONE

  PRIVATE

  PUBLIC Compute_AutoCross_Matrix
  PUBLIC Compute_RegressionCoeff
  PUBLIC SMOOTH_Coeff
  PUBLIC SMOOTH_Coeff_vertical
  PUBLIC Normalization
  PUBLIC Generation_H_matrix

  REAL(fp_kind), PARAMETER  :: ZERO = 0.0_fp_kind
  REAL(fp_kind), PARAMETER  :: ONE  = 1.0_fp_kind
  REAL(fp_kind), PARAMETER  :: TWO  = 2.0_fp_kind
  REAL(fp_kind), PARAMETER  :: TOLERANCE = EPSILON( ONE )

CONTAINS

  !-------------------------------------------------------------------
  ! Compute Auto and cross correlation matrixes:
  !      A = Transpose(X)#X   - Auto correlation
  !      C = TRanspose(X)#Y   - Cross correlation
  !  Inputs:
  !     X - an n x m array (n - sample size; m - number of variables)
  !     Y - an array of size n
  !  Outputs:
  !     A - an m x m array containing elements of auto correlation
  !     C - an array size of m containing cross correlation
  !-------------------------------------------------------------------
  SUBROUTINE Compute_AutoCross_Matrix(X, Y, A, C)
    REAL(fp_kind), INTENT( IN )  :: X(:,:)    ! n x m
    REAL(fp_kind), INTENT( IN )  :: Y(:)      ! n
    REAL(fp_kind), INTENT( OUT ) :: A(:, :)   ! m x m
    REAL(fp_kind), INTENT( OUT ) :: C(:)      ! m

    ! Local
    INTEGER :: m, n, i, j

    n = SIZE(X, DIM = 1)
    m = SIZE(X, DIM = 2)

    A = ZERO
    C = ZERO

    DO i = 1, m
      C(i) = SUM(X(:, i)*Y)
      DO j = 1, i
        A(i,j)  = SUM(X(:, i)*X(:,j))
        A(j, i) = A(i, j)
      END DO
    END DO

  END SUBROUTINE Compute_AutoCross_Matrix

  !--------------------------------------------------------------------------
  ! Compute least square fitting solution:
  !     Coeff = INVERSE(A)#C
  !   for the linear equation Y = X#Coeff, where
  !   A = Transpose(X)#X and C = TRanspose(X)#Y
  !      X an n x m array (n - sample size; m - number of variables )
  !      Y - an array of size n
  ! Inputs:
  !   A - an m x m array containing elements of auto correlation
  !       Transpose(X)#X. m is the number of variables
  !   C - an array size of m containing cross correlation
  !     A and C may be computed using the routine Compute_AutoCross_Matrix
  ! Outputs:
  !   Coeff - an array of size m containing the solution (coefficients)
  !--------------------------------------------------------------------------
  FUNCTION Compute_RegressionCoeff(A, C, Coeff)RESULT(Error_Status)
    REAL(fp_kind), INTENT( IN )  :: A(:, :)     ! m x m
    REAL(fp_kind), INTENT( IN )  :: C(:)        ! m
    REAL(fp_kind), INTENT( OUT ) :: Coeff(:)    ! m

    INTEGER :: Error_Status

    ! Local
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Compute_RegressionCoeff'
    INTEGER :: m
    REAL(fp_kind) ::  Awork(SIZE(C), SIZE(C)), Cwork(SIZE(C), 1)

    m = SIZE(C)

    Awork       = A
    Cwork(:, 1) = C

    CALL DPOTRF( 'U', m, Awork, m, error_status)
    IF(Error_Status /= 0)THEN
      CALL Display_Message( ROUTINE_NAME, &
                            "Error calling LAPACK DPOTRF to perform Cholesky factorization", &
                            FAILURE )
      RETURN
    END IF
    CALL DPOTRS( 'U', m, 1, Awork, m, Cwork, m, error_status)
    IF(Error_Status /= 0)THEN
      CALL Display_Message( ROUTINE_NAME, &
                            "Error calling LAPACK DPOTRS to solve linear equation", &
                            FAILURE )
      RETURN
    END IF
    Coeff = Cwork(:,1)

  END FUNCTION Compute_RegressionCoeff

  !---------------------------------------------------
  ! Derive coefficients using constrained regression:
  !   x = (transpose(A)A + gamma*H)^(-1)transpose(A)Y
  !     = AB^(-1)*AY
  !     where AB = transpose(A)A + gamma*H
  !           AY = transpose(A)Y
  ! note that the AA and H mtrixes are both symmetric
  ! band matrix
  !   with KD = Nvar, where KD is the superdiagnals of AA
  !              and Nvar is the number of predictors + 1
  ! The up triangle of AB is stored in AB_band:
  !   AB_band(KD+1+i-j,j) = AB(i,j) for max(1,j-KD)<=i<=j
  !
  ! For example, the following 6x6 triagle symmetric band
  ! matrix with KD = 2:
  !  a11 a12 a13
  !  a12 a22 a23 a24
  !  a13 a23 a33 a34 a35
  !      a24 a34 a44 a45 a46
  !          a35 a45 a55 a56
  !              a46 a56 a66
  !
  !  It is stored in a band matrix with dimension (2+1)x6
  !    *    *   a13  a24  a35  a46
  !    *   a12  a23  a34  a45  a56
  !   a11  a22  a33  a44  a55  a66
  !
  !---------------------------------------------------
  SUBROUTINE SMOOTH_Coeff(PdSub, kp, Gamma, Coeff, ierr)

     !inputs

    REAL(fp_kind), intent(in) :: Gamma
    REAL(fp_kind), intent(in), DIMENSION(:,0:,:,:) ::  PdSub
                                    !Npd,0:wNlay,1:Nangle,1:Natm
    REAL(fp_kind), intent(in), DIMENSION(0:,:,:) ::  Kp
                                    !(0:wNlay,1:Nangle,1:Natm)

     REAL(fp_kind), intent(out) :: COEFF(:,:)
     integer, intent(out) :: Ierr

    ! local

    real(fp_kind) :: ONE = 1.0_fp_kind, TWO = 2.0_fp_kind, ZERO = 0.0_fp_kind
    real(fp_kind), allocatable :: H_band(:, :), AA_band(:,:), AB_band(:,:), &
                                  AY(:,:), AA_layer(:,:)

    INTEGER :: Nsample, Nw, Nvar, Natm, Nangle

    INTEGER :: I, J, K, M, N, iatm, iang, offset, KD

    NVAR = SIZE(PdSub, DIM=1) + 1
    NW = SIZE(PdSub, DIM=2)
    Nangle = SIZE(PdSub, DIM=3)
    Natm = SIZE(PdSub, DIM=4)

    NSAMPLE = Nangle * Natm

    N = Nw * Nvar
    M = Nsample*Nw

    allocate(H_band(Nvar + 1, N), &
             AA_band(Nvar + 1, N), &
             AB_band(Nvar + 1, N), &
             AY(N, 1), AA_layer(Nvar, Nvar))

    !--------------------------------------------------------
    ! H matrix used to constrain vertical coeffienct profile
    ! minimize the difference between adjacent coefficient
    !--------------------------------------------------------
   H_band(:,:) = ZERO
   H_band(1, Nvar+1:N) = -ONE
   H_band(Nvar+1, 1:Nvar) = ONE
   H_band(Nvar+1, Nvar+1:N-Nvar) = TWO
   H_band(Nvar+1, N-Nvar+1:N) = ONE

    !-------------------------------------------------------
    ! prepare AA band matrix
    !   Note here AA_layer is a layer Nvar x Nvar matrix
    !       | AA_layer1                       |
    !       |          AA_Layer2              |
    !  AA = |                   .....         |
    !       |                       AA_LayerN |
    ! prepare AY matric
    !-------------------------------------------------------

    AA_band(:,:) = ZERO
    AY(:, 1) = ZERO
    KD = Nvar

    DO K = 1, Nw

      ! put data in up triangle

      offset = (k-1)*Nvar
      AA_layer(:,:) = ZERO

      do iang = 1, Nangle
      do iatm = 1, Natm

        if(ABS(kp(k-1, iang, iatm)) > TOLERANCE) then

          AA_layer(1,1) = AA_layer(1,1) + ONE
          AY(offset+1, 1) = AY(offset+1, 1) + kp(k-1, iang, iatm)
          do i = 2, Nvar

            AY(offset+i, 1) = AY(offset+i, 1) + &
                   PdSub(i-1, k-1, iang, iatm)*kp(k-1, iang, iatm)
            AA_layer(1, i) = AA_layer(1, i) + PdSub(i-1,k-1,iang, iatm)

            do j = i, Nvar
              AA_layer(i, j) = AA_layer(i, j) + &
              PdSub(i-1,k-1,iang, iatm) * PdSub(j-1,k-1,iang,iatm)
            enddo
          enddo

        endif
      enddo
      enddo

      do j = 1, Nvar
       do i = max(1,j-KD), j
         AA_band(KD+1+i-j, j+offset) = AA_layer(i,j)
       enddo
      enddo

    ENDDO

    !----------------------------------------------
    ! prepare AB
    !----------------------------------------------

    AB_band = AA_band + Gamma * H_band

    !-----------------------------------------------------------
    ! Lapack routine to computes the solution
    ! to a real system of linear equations
    !        AB_band * X = AY
    !-----------------------------------------------------------
!!!    call DPBSV( 'U', N, KD, 1, AB_band, Nvar+1, AY, N, ierr )
    ierr = 0
    if(ierr /= 0)then
      print *, 'Error flag returned from regression DPBSV'
    endif

    !--- get coefficients ---
    do k = 1, Nw
      do i = 1, Nvar
        COEFF(i,k) = AY((k-1)*Nvar+i, 1)
      enddo
    enddo

    deallocate(H_band,AA_band,AB_band,AY,AA_layer)

  END Subroutine SMOOTH_coeff

       SUBROUTINE SMOOTH_Coeff_vertical(H, PdSub, kp, Gamma, Coeff, ierr)

        IMPLICIT NONE

        !inputs

       REAL(fp_kind), intent(in) :: Gamma
       REAL(fp_kind), intent(in), DIMENSION(:,0:,:,:) ::  PdSub    !Npd, 0:wNlay,1:Nangle,1:Natm,Igas
       REAL(fp_kind), intent(in), DIMENSION(0:,:,:) ::  Kp  !(0:wNlay,1:Nangle,1:Natm)
       REAL(fp_kind)  ::  H(:,:)

       ! I/O
        REAL(fp_kind), intent(inout) :: COEFF(:,:)
        integer, intent(inout) :: Ierr

        ! local

 real(fp_kind), allocatable :: A(:,:), AA(:,:), AA1(:,:)
 real(fp_kind), allocatable ::  YA(:), AAinv(:,:), Y(:), B(:)

 INTEGER :: Nsample, Nw, Nvar, Natm, Nangle

 real(fp_kind)::SUMM

 INTEGER :: I, J, K, N, M, N1, N2, N3, N4, iatm, iang

 NVAR = SIZE(PdSub, DIM=1) + 1
 NW = SIZE(PdSub, DIM=2)
 Nangle = SIZE(PdSub, DIM=3)
 Natm = SIZE(PdSub, DIM=4)

 NSAMPLE = Nangle * Natm

 N = Nw * Nvar
 M = Nsample*Nw

print*, Nw, Nvar, Nangle, Natm, Nsample, N, M

allocate(A(M,N), AA(N,N))

!--- A

      A(:,:) = 0.0

      DO K = 1, Nw
        j = 0
        DO iatm = 1, Natm
        Do iang = 1, Nangle
        J = j + 1

        A( (K-1)*NSAMPLE+J, (K-1)*Nvar+1)  = 1.

        A( (K-1)*NSAMPLE+J, (K-1)*Nvar+2:K*Nvar) &
           = PdSub(1:Nvar-1,K-1,iang, iatm)

        ENDDO
        ENDDO
      ENDDO

      allocate( YA(N), Y(M))

       Y(:) = 0.0

      DO J = 1, Nw

        i =0
        DO iatm = 1, Natm
        Do iang = 1, Nangle
  i = i +1

   Y((J-1)*NSAMPLE  +I) = KP(J-1,Iang, Iatm)

   ENDDO
   ENDDO
 ENDDO

summ = sum(Y)/dble(Natm*Nangle*Nw)

print*, "avg and std of Y", summ, &
      sqrt( sum((Y -summ)**2)/dble(Natm*Nangle*Nw ))

! YA=A(T)*Y

print*, " computation of YA = A(T)*Y, ", N, M

YA(:) = 0.0

DO I = 1, N

  DO K = (I-1)/Nvar*Nsample+1, (I-1)/Nvar*Nsample+Nsample
      YA(I) = YA(I) + A(K,I) * Y(K)
  ENDDO

ENDDO

print*, " computation of A(T)A"

! AA

AA(:,:) = 0.0

DO I = 1, N

  DO J = (I-1)/Nvar*Nvar+1, (I-1)/Nvar*Nvar + Nvar

     DO K = (J-1)/Nvar*Nsample+1, (J-1)/Nvar*Nsample+Nsample  !ignore the zero.
       !----------------------------------------------------------------------!
       ! if Y(I) = 0 and gas/=correction term, this sample can not be counted !
       !----------------------------------------------------------------------!
       if( abs(Y(K)) > TOLERANCE ) then
       AA(I,J) = AA(I,J) + A(K,I) * A(K,J)
       endif

     ENDDO

  ENDDO

ENDDO

! --- to reduce the size of array if the sample number for layer is less than 5
N1 = N
DO I = N+1-Nvar, 1, -Nvar
if(AA(I,I) >= Nvar-1) exit
N1 = I-1
ENDDO

! --- to reduce the size of array if the sample number for top-layer is less than 5
N2 = 0
DO I = 1, N+1-Nvar, Nvar
N2 = I-1
if(AA(I,I) >= Nvar-1) exit
ENDDO

!--- if the sample number >1, the coefficients in the top can not be zero
if(N2 > Nvar) then
N3 = N2
DO I = N2+1, 1, -Nvar
if(AA(I,I) == 0) exit
N3 = I
ENDDO
endif

!--- if the sample number >1, the coefficients in the bottom can not be zero
N4 = N1
DO I = N1+1, N+1-Nvar, Nvar
N4 = I-1
if(AA(I,I) == 0) exit
ENDDO

! array: 1 00 n3 n2 n1 00 n4

! --------- since H is not adjust based on the H, the results are ugly sometimes.
! --------- change to H is necessary

      deallocate(Y,A)

      allocate(B(N))

! -- to change H in the top
do i = N2+1, N2+Nvar
H(i,i) = 1.0
enddo
! -- to change H in the bottom
do i = N1-Nvar+1, N1
H(i,i) = 1.0
enddo

print*, "gamma = ", gamma

DO I = 1, N
DO J = 1, N

AA(I,J) = AA(I,J) + GAMMA * H(I,J)

ENDDO
ENDDO

if(N1 <= N2) then
print*, "error in the array size!"
stop
endif

allocate( AAinv(N1-N2,N1-N2) , AA1(N1-N2, N1-N2))

print*, " computation of AAinV", N1, N2, N3, N4, nvar

AA1(1:N1-N2, 1:N1-N2) = AA(N2+1:N1, N2+1:N1)

!!!	call rinvrs(AA1,AAinv,ierr)

deallocate(AA1)

B(:)=0.

     if(ierr == 0) then

do i = 1, N1-N2
  summ = 0.
  do j = 1, N1-N2
  summ = summ + YA(N2+j)*AAinv(j,i)
  end do
B(N2+i) = summ
end do

do i = N1+1, N4
B(i) = B(i-Nvar)
enddo

if(N2 > Nvar) then
do i = N3, N2
B(i) = B(N2-N3+1+i)
enddo
endif

     else if(ierr == -1) then

      print*, "WARNING ... singular array in the computation of AAinv", N1

     endif

COEFF(:,:) = 0.0

DO J = 1, Nw
DO I = 1,Nvar
COEFF(I,J) = B((J-1)*Nvar  +I)
ENDDO
ENDDO

deallocate(AA,YA,AAinv,B)

RETURN
END Subroutine SMOOTH_Coeff_vertical

Subroutine Normalization (X, factor)

! --- INPUT
REAL(fp_kind), intent(inout), DIMENSION(0:,:, :) :: X

REAL(fp_kind), intent(out) :: factor

!-- LOCAL

REAL(fp_kind) :: XAVG, summ

INTEGER  i,j, k
integer Natm, Nang, Nw

Nw = SIZE(X, DIM=1)-1
Nang = SIZE(X, DIM=2)
Natm = SIZE(X, DIM=3)

XAVG = sum(X)/dble(Nang*Natm*(Nw+1))

summ = ZERO
do i = 0, Nw
do j = 1, Nang
do k = 1, Natm
summ = summ + (x(i,j,k) - xavg)**2
enddo
enddo
enddo

factor = sqrt(summ/dble(Nang*Natm*(Nw+1)))

X(0:Nw, 1:Nang, 1:Natm) = X(0:Nw, 1:Nang, 1:Natm) / factor

return

END Subroutine Normalization

Subroutine Generation_H_matrix( H, Nvar)

!-- input
Integer:: Nvar

! -- output
REAL(fp_kind), intent(out), DIMENSION(:, :) ::  H

! --local
Integer :: N, I, J, K
REAL(fp_kind), allocatable :: KK(:,:), KT(:,:)

N = Size(H, DIM=1)

allocate(KK(N,N), KT(N,N))

KK(:,:) = 0.

DO I = 2, N-Nvar+1

   KK(I,I-1) = 1.
   KK(I, I+Nvar-1) = -1.

ENDDO

! H = K*K

H(:,:) = 0.

KT = transpose(KK)

print*, "multification of array, H=K(T)K"
DO I = 1, N
   DO J = 1, N

    DO K = 1, N
    H(I,J) = H(I,J) + KT(I,K)*KK(K,J)
    ENDDO

  ENDDO
ENDDO

deallocate(kk, KT)

return

End Subroutine Generation_H_matrix

END MODULE Regression


module vecutils

    ! module vec : functions for performing vector operations

    implicit none

    private
    public cross3, mag3, calcrotation3

contains

    pure function cross3(a,b)

        ! cross3() : returns the cross product a x b, with a(3) and b(3)
        !
        !   Inputs:
        !   =======
        !   a,b      : real(3) vectors
        !
        !   Outputs:
        !   ========
        !   cross(3) : real(3) vector

        real, intent(in) :: a(3), b(3)
        real :: cross3(3)

        cross3(1) = a(2) * b(3) - a(3) * b(2)
        cross3(2) = a(3) * b(1) - a(1) * b(3)
        cross3(3) = a(1) * b(2) - a(2) * b(1)

    end function cross3

    pure function mag3(a)

        ! mag3() : returns the magnitude of a(3)
        !
        !   Inputs:
        !   =======
        !   a        : real(3) vector
        !
        !   Outputs:
        !   ========
        !   mag      : real, length of a

        real, intent(in) :: a(3)
        real             :: mag3

        mag3 = sqrt(sum(a**2))

    end function mag3

    subroutine calcrotation3(R,VecI,VecO,reverse)

        real    :: R(3,3), VecI(3), VecO(3)
        integer :: reverse

        ! Apply rotation matrix R to VecI to get VecO
        ! Reverse: 1 to use the transpose of R

        if (reverse == 0) then
            VecO(1)=R(1,1)*VecI(1)+R(1,2)*VecI(2)+R(1,3)*VecI(3)
            VecO(2)=R(2,1)*VecI(1)+R(2,2)*VecI(2)+R(2,3)*VecI(3)
            VecO(3)=R(3,1)*VecI(1)+R(3,2)*VecI(2)+R(3,3)*VecI(3)
        else
            VecO(1)=R(1,1)*VecI(1)+R(2,1)*VecI(2)+R(3,1)*VecI(3)
            VecO(2)=R(1,2)*VecI(1)+R(2,2)*VecI(2)+R(3,2)*VecI(3)
            VecO(3)=R(1,3)*VecI(1)+R(2,3)*VecI(2)+R(3,3)*VecI(3)
        end if

    end subroutine calcrotation3

end module vecutils


      PROGRAM xstoerm
C     driver for routine stoerm
      INTEGER NVAR
      REAL HTOT,X1
      PARAMETER(NVAR=4,X1=0.,HTOT=1.570796)
      INTEGER i
      REAL a1,a2,x,xf,y(NVAR),yout(NVAR),d2y(NVAR),d2y1,d2y2
      EXTERNAL derivs
      d2y1(x)=x+sin(x)
      d2y2(x)=x**2+cos(x)-2
      y(1)=0.
      y(2)=-1.
      y(3)=2.
      y(4)=0.
      call derivs(X1,y,d2y)
      xf=X1+HTOT
      a1=d2y1(xf)
      a2=d2y2(xf)
      write(*,'(1x,a/)') 'Stoermer''s Rule:'
      do 11 i=5,45,10
        call stoerm(y,d2y,NVAR,X1,HTOT,i,yout,derivs)
        write(*,'(1x,a,f6.4,a,f6.4,a,i2,a)') 'X = ',X1,
     *       ' to ',X1+HTOT,' in ',i,' steps'
        write(*,'(1x,t5,a,t20,a)') 'Integration','Answer'
        write(*,'(1x,2f12.6)') yout(1),a1
        write(*,'(1x,2f12.6)') yout(2),a2
11    continue
      END
      SUBROUTINE derivs(x,y,d2y)
      REAL x,y(*),d2y(*)
      d2y(1)=x-y(1)
      d2y(2)=x*x-y(2)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xstoerm.for


program main

    use open_linalg_m, only: det
    real :: x(2, 2) = reshape([1, 2, 3, 4], [2, 2])

    print *, det(x)

end program main

!@note: Fortran array column first
! -2.00000000


subroutine mg_correction_face_vel(uf, vf, pc, auf_bar, avf_bar, dx, dy, imax, jmax)
!use variables
use kind_parameters
implicit none

!! Input variables

integer, intent(in):: imax, jmax
real(kind=dp), dimension(imax, jmax):: pc
real(kind=dp), dimension(imax-1, jmax):: uf, auf_bar
real(kind=dp), dimension(imax, jmax-1):: vf, avf_bar
real(kind=dp):: dx(imax), dy(jmax)

!! Other local variables
integer:: iu, ju, iv, jv

! Correct face velocities

do ju = 2,jmax-1

      do iu = 2,imax-2

            uf(iu,ju) = uf(iu,ju) + dy(ju)/auf_bar(iu,ju)*(pc(iu,ju)-pc(iu+1,ju))

      end do

end do

do jv = 2,jmax-2

      do iv=2,imax-1

            vf(iv,jv) = vf(iv,jv) + dx(iv)/avf_bar(iv,jv)*(pc(iv,jv)-pc(iv,jv+1))

      end do

end do

end subroutine


	FUNCTION PC_DHGT  ( tkb, tkt, pb, pt, hb, delh )
C************************************************************************
C* PC_DHGT								*
C*									*
C* This function computes the dry hydrostatic height.			*
C*									*
C* REAL PC_DHGT  ( TKB, TKT, PB, PT, HB, DELH )				*
C*									*
C* Input parameters:							*
C*	TKB		REAL		Bottom temperature		*
C*	TKT		REAL		Top temperature			*
C*	PB		REAL		Bottom pressure			*
C*	PT		REAL		Top pressure			*
C*	HB		REAL		Bottom height			*
C*									*
C* Output parameters:							*
C*	DELH		REAL		Height increment		*
C*	PC_DHGT		REAL		Dry hydrostatic height		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	11/84						*
C* T. Piper/GSC		11/98		Updated prolog			*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ( .not. ERMISS (tkb) ) .and. ( .not. ERMISS (tkt) ) .and.
     +	      ( .not. ERMISS (pb)  ) .and. ( .not. ERMISS (pt) ) .and.
     +	      ( .not. ERMISS (hb)  ) .and. ( pt .ne. 0. ) )  THEN
	    delh = RKAP * 0.5 * (tkb + tkt) * ALOG ( pb / pt )
	    PC_DHGT = hb + delh
	  ELSE
	    delh = RMISSD
	    PC_DHGT = RMISSD
	END IF
C*
	RETURN
	END


      module pib_mod
!
!     This module supports programs written to solve the modified
!     Particle-in-a-Box (mPIB) problem. In this problem, the standard PIB
!     potential is modified to include a linear potential within the box (0 < x
!     < L) given by V(x) = bx.
!
!     H. P. Hratchian, 2020.
!
!
!     Global Variable Declarations and Parameters
!       Global Parameters:
!       iOUt ... An integer with the stardard output unit number.
!       pi   ...  A real with the value of pi.
!
      integer,parameter::iOut=6
      real,parameter::pi=float(4)*ATan(1.0)
!
!     Procedure Interfaces
!
      Interface print_matrix
        module procedure print_matrix_full_real
      end Interface
!
!
!     Module Procedures
!
      Contains
!
!PROCEDURE kineticEnergy.
      function kineticEnergy(mass,boxLength,qnM,qnN) result(matrixElement)
!
!     This function returns the kinetic energy matrix element for <m|T|n> where
!     m and n are PIB eigenfunction labels and T is the 1D kinetic energy
!     operator.
!
!
!     Variable Delarations
!
      implicit none
      real,intent(in)::mass,boxLength
      integer,intent(in)::qnM,qnN
      real::matrixElement
!
!     Since the PIB eigenfunctions are eigenfunctions of the kinetic energy
!     operator, test to see if qnM and qnN are the same. If not, just set the
!     result to zero.
!
      if(qnM.eq.qnN) then
        matrixElement = (float(qnN**2)*pi**2)/(float(2)*mass*boxLength**2)
      else
        matrixElement = 0
      endIf
!
      return
      end function kineticEnergy
!
!PROCEDURE potentialEnergy.
      function potentialEnergy(mass,boxLength,slope,qnM,qnN) result(matrixElement)
!
!     This function returns the potential energy matrix element for <m|V|n>
!     where m and n are PIB eigenfunction labels and V is the potential energy
!     operator.
!
!
!     Variable Delarations
!
      implicit none
      real,intent(in)::mass,boxLength,slope
      integer,intent(in)::qnM,qnN
      real::matrixElement
      real::prefactorPlus,prefactorMinus
!
 9000 Format('*** PROBLEM IN POTENTIAL ENERGY FUNCTION! ***')
!
!     Since the PIB eigenfunctions are eigenfunctions of the kinetic energy
!     operator, test to see if qnM and qnN are the same. If not, just set the
!     result to zero.
!
      if(qnM.eq.qnN) then
        matrixElement = boxLength*slope/float(2)
      else
        select case (mod(qnM+qnN,2))
        case(0)
          matrixElement = float(0)
        case(1)
          prefactorPlus = float(1)/float(qnM+qnN)
          prefactorMinus = float(1)/float(qnM-qnN)
          matrixElement = (float(2)*boxLength*slope/pi**2)*  &
            (prefactorPlus**2-prefactorMinus**2)
        case default
          matrixElement = float(0)
          write(iOut,9000)
        end select
      endIf
!
      return
      end function potentialEnergy
!
!PROCEDURE print_matrix_full_real
      subroutine print_matrix_full_real(amat)
!
!     This subroutine prints a real matrix that is fully dimension - i.e., not
!     stored in packed form. AMat is the matrix.
!
!     The output of this routine is sent to unit number 6 (set by the local
!     parameter integer IOut).
!
!
!     Variable Declarations
!
      implicit none
      real,dimension(:,:),intent(in)::AMat
!
!     Local variables
      integer,parameter::IOut=6,NColumns=5
      integer::i,j,IFirst,ILast
!
 1000 Format(1x,A)
 2000 Format(5x,5(7x,I7))
 2010 Format(1x,I7,5F14.6)
!
      do ifirst = 1,SIZE(AMat,2),ncolumns
        ILast = Min(IFirst+NColumns-1,SIZE(AMat,2))
        write(IOut,2000) (i,i=IFirst,ILast)
        do i = 1,SIZE(AMat,1)
          write(IOut,2010) i,(AMat(i,j),j=IFirst,ILast)
        endDo
      endDo
!
      return
      end subroutine print_matrix_full_real
!
!
      end module pib_mod


    Program zgerqf_example

!     ZGERQF 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_interfaces, Only: zgerqf, ztrtrs, zunmrq
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Complex (Kind=dp), Parameter :: zero = (0.0_dp, 0.0_dp)
      Integer, Parameter :: nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, info, lda, lwork, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:), tau(:), work(:), x(:)
!     .. Executable Statements ..
      Write (nout, *) 'ZGERQF Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      lwork = nb*m
      Allocate (a(lda,n), b(m), tau(m), work(lwork), x(n))

!     Read the matrix A and the vector b from data file

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

!     Compute the RQ factorization of A
      Call zgerqf(m, n, a, lda, tau, work, lwork, info)

!     Copy the m-element vector b into elements x(n-m+1), ..., x(n) of x

      x(n-m+1:n) = b(1:m)

!     Solve R*y2 = b, storing the result in x2
      Call ztrtrs('Upper', 'No transpose', 'Non-Unit', m, 1, a(1,n-m+1), lda, &
        x(n-m+1), m, info)

      If (info>0) Then
        Write (nout, *) 'The upper triangular factor, R, of A is singular, '
        Write (nout, *) 'the least squares solution could not be computed'
      Else

!       Set y1 to zero (stored in x(1:n-m))

        x(1:n-m) = zero

!       Compute minimum-norm solution x = (Q**H)*y
        Call zunmrq('Left', 'Conjugate transpose', n, 1, m, a, lda, tau, x, n, &
          work, lwork, info)

!       Print minimum-norm solution

        Write (nout, *) 'Minimum-norm solution'
        Write (nout, 100) x(1:n)
      End If

100   Format (4(' (',F8.4,',',F8.4,')',:))
    End Program


module testmod_dif1
implicit none
private
public fcn, dp

integer, parameter :: dp=kind(0d0)

contains

subroutine fcn(m, n, x, fvec, iflag)
integer, intent(in) :: m, n, iflag
real(dp), intent(in) :: x(n)
real(dp), intent(out) :: fvec(m)

integer :: i
real(dp) :: tmp1, tmp2, tmp3, y(15)
! Suppress compiler warning:
y(1) = iflag
y = [1.4D-1, 1.8D-1, 2.2D-1, 2.5D-1, 2.9D-1, 3.2D-1, 3.5D-1, 3.9D-1, &
        3.7D-1, 5.8D-1, 7.3D-1, 9.6D-1, 1.34D0, 2.1D0, 4.39D0]

do i = 1, 15
    tmp1 = i
    tmp2 = 16 - i
    tmp3 = tmp1
    if (i .gt. 8) tmp3 = tmp2
    fvec(i) = y(i) - (x(1) + tmp1/(x(2)*tmp2 + x(3)*tmp3))
end do
end subroutine

end module

program example_lmdif1
use minpack, only: enorm, lmdif1
use testmod_dif1, only: dp, fcn
implicit none

integer :: info, m, n
real(dp) :: tol, x(3), fvec(15)
integer :: iwa(size(x))
real(dp), allocatable :: wa(:)

! The following starting values provide a rough fit.
x = [1._dp, 1._dp, 1._dp]

! Set tol to the square root of the machine precision. Unless high precision
! solutions are required, this is the recommended setting.
tol = sqrt(epsilon(1._dp))

m = size(fvec)
n = size(x)
allocate(wa(m*n + 5*n + m))
call lmdif1(fcn, size(fvec), size(x), x, fvec, tol, info, iwa, wa, size(wa))
print 1000, enorm(size(fvec), fvec), info, x
1000 format(5x, 'FINAL L2 NORM OF THE RESIDUALS', d15.7 // &
            5x, 'EXIT PARAMETER', 16x, i10              // &
            5x, 'FINAL APPROXIMATE SOLUTION'            // &
            5x, 3d15.7)
end program


integer function SHFindLWin(theta0, m, alpha, taper_number)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function will output the spherical harmonic bandwidth for
!	the space concentrated taper that yields a concetration factor
!	equal to or greater than the input value of alpha. By default, the concentration
!	factor of the first taper is computed, but this can be modified by
!	inputing the optional arguement taper_number.
!
!	Calling Parameters
!		IN
!			theta0		Angular radius of the concentration spherical
!					cap in RADIANS.
!			alpha		Concentration factor of the window.
!			m		Angular order of the space concetrated tapers.
!		IN (OPTIONAL)
!			taper_number	Taper number used to calculate concentration factors.
!
!
!	Dependencies: LAPACK, BLAS, ComputeDm, ComputeD0, EigValSym
!
!	Written by Mark Wieczorek June 2004.
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS, only: ComputeDm, ComputeD0, EigvalSym

	implicit none

	real*8, intent(in) :: 	theta0, alpha
	integer, intent(in) :: 	m
	integer, intent(in), optional ::	taper_number
	real*8, allocatable ::	dllm(:,:), eval(:)
	real*8 ::	pi, alpha1
	integer ::	l, astat(2), tn

	if (alpha < 0.0d0 .or. alpha > 1.0d0) then
		print*, "Error --- SHFindLWin"
		print*, "The concentration factor alpha must be between 0 and 1."
		print*, "Input value is ", alpha
		stop
	endif

	pi = acos(-1.0d0)

	if (present(taper_number)) then

		if (taper_number < 1) then
			print*, "Error --- SHFindLWin"
			print*, "TAPER_NUMBER must be greater than 0."
			print*, "Input value is ", taper_number
			stop
		endif

		tn = taper_number
	else
		tn = 1
	endif

	l = tn

	do
		l = l + 1

		allocate(dllm(l+1,l+1), stat = astat(1)) ; dllm = 0.0d0
		allocate(eval(l+1), stat = astat(2)) ; eval = 0.0d0

		if (astat(1) /=0 .or. astat(2) /=0) then
			print*, "Error --- SHFindLWin"
			print*, "Probelm allocating arrays."
			stop
		endif

		if (m==0) then
			call ComputeD0(dllm, l, theta0)
		else
			call ComputeDm(dllm, l, abs(m), theta0)
		endif

		call EigValSym(dllm, l+1, eval(1:l+1))

		alpha1 = eval(tn)

		deallocate(dllm)
		deallocate(eval)

		if (alpha1 >= alpha) then
			SHFindLWin = l
			return
		endif
	enddo

end function SHFindLWin


C ************************************************************************
C FILE: ser_prime.f
C DESCRIPTION:
C   This program generates primes. The approach taken is a "brute force"
C   method which requires increasingly greater amounts of cpu as the problem
C   size increases.  It should lend itself well to an embarassingly parallel
C   solution since each prime can be computed independently of all other
C   primes.
C AUTHOR: Blaise Barney 11/25/95 - adapted from version contributed by
C   Richard Ng & Wong Sze Cheong during MHPCC Singapore Workshop (8/22/95).
C LAST REVISED: 04/02/05
C ************************************************************************
C Explanation of constants and variables
C   LIMIT                  = Increase this to find more primes
C   PRINT                  = Print a line after this many numbers
C   rank                   = task identifier
C   pc                     = prime counter
C   foundone               = most recent prime found

      program prime

      integer LIMIT, PRINT
      parameter(LIMIT=2500000)
      parameter(PRINT=100000)

      integer n, pc, foundone
      logical result

      print *,'Starting. Numbers to be scanned=',LIMIT
C     Assume first four primes are counted here
      pc = 4
      do n=11, LIMIT, 2
         call isprime(n,result)
         if (result .eqv. .true.) then
            pc = pc + 1
            foundone = n
C           ***** Optional: print each prime as it is found
C           print *, foundone
C           *****
         endif
         if (mod(n-1,PRINT).eq.0) then
            print *,'Numbers scanned=',n-1,' Primes found= ',pc
         endif
      enddo
      print *,'Done. Largest prime is ',foundone,' Total primes ',pc
      end

      subroutine isprime (n,result)
      integer n
      logical result
      integer i, squareroot
      real*4 realn
      if (n .gt. 10) then
         realn = real(n)
         squareroot = int (sqrt(realn))
         do i=3,squareroot,2
           if (mod(n,i) .eq. 0) then
              result = .false.
              return
           endif
         enddo
         result = .true.
         return
C Assume first four primes are counted elsewhere. Forget everything else
      else
        result = .false.
        return
      endif
      end


program intrinsics_01
integer, parameter :: dp = kind(0.d0)
real(dp) :: a, b, c(4)
integer :: i
a = 1.1_dp
b = 1.2_dp
if (b-a > 0.2_dp) error stop
if (abs(b-a) > 0.2_dp) error stop
if (abs(a-b) > 0.2_dp) error stop

a = 4._dp
if (abs(sqrt(a)-2._dp) > 1e-12_dp) error stop

a = 4._dp
if (abs(log(a)-1.3862943611198906_dp) > 1e-12_dp) error stop

c(1) = -1._dp
c(2) = -1._dp
c(3) = -1._dp
c(4) = -1._dp
call random_number(c)
do i = 1, 4
    if (c(i) < 0._dp) error stop
    if (c(i) > 1._dp) error stop
end do
end


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_line_proj( n, c, gg, x0, v, smin, smax )

!  Given the ellipsoid E = { x | norm(G^T * (x-c) ) <=1 ),
!  where G is an n x n lower triangular, and given the line
!  L = { x | x = x0 + v * s }, determine the line segment
!  (smin, smax) which is the orthogonal projection of E onto L.
!  The array gg contains the matrix G in packed format.

!  Method:  E = { x | x = c + G^{-T} u,  |u| <=1}
!           s = v^T * ( x - x0 ) / v^T * v
!             = v^T * ( c - x0 + G^{-T} u ) / v^T * v
!             = s0 + w^T * u,  s0 = v^T * ( c - x0 ) / v^T * v,
!                              w  = G^{-1} * v  / v^T * v
!           smax = s0 + |w|, smin = s0 - |w|

!  S.B. Pope  6/12/04

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: c(n), gg((n*(n+1))/2), x0(n), v(n)
real(k_dp), intent(out) :: smin, smax

real(k_dp) :: vnormsq, w(n), s0, wnorm

vnormsq = sum(v*v)   !  v^T * v = |v|^2
if( vnormsq == 0.d0 ) then
   write(0,*)'ell_line_proj: |v| = 0'
   stop
endif

w  = v / vnormsq
s0 = sum( w * (c-x0) )  !  s0 = v^T ( c - x0 ) / |v|^2

call dtpsv( 'L', 'N', 'N', n, gg, w, 1 ) ! w  = G^{-1} * v  / v^T * v
wnorm = sqrt( sum( w * w ) )

smin = s0 - wnorm
smax = s0 + wnorm

return
end subroutine ell_line_proj


function convolve(x, h)
        implicit none

        !x is the signal array
        !h is the noise/impulse array
        real, dimension(:), allocatable :: convolve, y
        real, dimension(:) :: x, h
        integer :: kernelsize, datasize
        integer :: i,j,k

        datasize = size(x)
        kernelsize = size(h)

        allocate(y(datasize))
        allocate(convolve(datasize))

        do i=kernelsize,datasize
            y(i) = 0.0
            j=i
            do k=1,kernelsize
                y(i) = y(i) + x(j)*h(k)
                j = j-1
            end do
        end do

        do i=1,kernelsize
            y(i) = 0.0
            j=i
            k=1
            do while (j > 0)
                y(i) = y(i) + x(j)*h(k)
                j = j-1
                k = k+1
            end do
        end do

        convolve = y

    end function convolve


*DECK EZFFTF
      SUBROUTINE EZFFTF (N, R, AZERO, A, B, WSAVE)
C***BEGIN PROLOGUE  EZFFTF
C***PURPOSE  Compute a simplified real, periodic, fast Fourier forward
C            transform.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A1
C***TYPE      SINGLE PRECISION (EZFFTF-S)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine EZFFTF computes the Fourier coefficients of a real
C  periodic sequence (Fourier analysis).  The transform is defined
C  below at Output Parameters AZERO, A and B.  EZFFTF is a simplified
C  but slower version of RFFTF.
C
C  Input Parameters
C
C  N       the length of the array R to be transformed.  The method
C          is most efficient when N is the product of small primes.
C
C  R       a real array of length N which contains the sequence
C          to be transformed.  R is not destroyed.
C
C
C  WSAVE   a work array which must be dimensioned at least 3*N+15
C          in the program that calls EZFFTF.  The WSAVE array must be
C          initialized by calling subroutine EZFFTI(N,WSAVE), and a
C          different WSAVE array must be used for each different
C          value of N.  This initialization does not have to be
C          repeated so long as N remains unchanged.  Thus subsequent
C          transforms can be obtained faster than the first.
C          The same WSAVE array can be used by EZFFTF and EZFFTB.
C
C  Output Parameters
C
C  AZERO   the sum from I=1 to I=N of R(I)/N
C
C  A,B     for N even B(N/2)=0. and A(N/2) is the sum from I=1 to
C          I=N of (-1)**(I-1)*R(I)/N
C
C          for N even define KMAX=N/2-1
C          for N odd  define KMAX=(N-1)/2
C
C          then for  K=1,...,KMAX
C
C               A(K) equals the sum from I=1 to I=N of
C
C                    2./N*R(I)*COS(K*(I-1)*2*PI/N)
C
C               B(K) equals the sum from I=1 to I=N of
C
C                    2./N*R(I)*SIN(K*(I-1)*2*PI/N)
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  RFFTF
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing references to intrinsic function FLOAT
C               to REAL.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  EZFFTF
      DIMENSION R(*), A(*), B(*), WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  EZFFTF
      IF (N-2) 101,102,103
  101 AZERO = R(1)
      RETURN
  102 AZERO = .5*(R(1)+R(2))
      A(1) = .5*(R(1)-R(2))
      RETURN
  103 DO 104 I=1,N
         WSAVE(I) = R(I)
  104 CONTINUE
      CALL RFFTF (N,WSAVE,WSAVE(N+1))
      CF = 2./N
      CFM = -CF
      AZERO = .5*CF*WSAVE(1)
      NS2 = (N+1)/2
      NS2M = NS2-1
      DO 105 I=1,NS2M
         A(I) = CF*WSAVE(2*I)
         B(I) = CFM*WSAVE(2*I+1)
  105 CONTINUE
      IF (MOD(N,2) .EQ. 0) A(NS2) = .5*CF*WSAVE(N)
      RETURN
      END


c     Fortran translation (Heh!) of test4 in quadpack-tests.lisp.
      program test4
      implicit none
      double precision alpha
      integer key

      print *, 'Test 4, same integral as test 1'
      print *
      print *, ' integrate(x^alpha*log(1/x), x, 0, 1)'
      print *, '   = (1+alpha)^(-2)'
      print *
      print *, 'QNG'
      print 9000
      do 10 alpha = -0.9d0, 0d0, 0.1d0
         call qqng(alpha)
   10 continue
      do 20 alpha = 0.2d0, 2.6d0, 0.2d0
         call qqng(alpha)
   20 continue
      print *
      print *, 'QAGS'
      print 9000
      do 30 alpha = -0.9d0, 0d0, 0.1d0
         call qqags(alpha)
   30 continue
      do 40 alpha = 0.2d0, 2.6d0, 0.2d0
         call qqags(alpha)
   40 continue
      print *
      print *, 'QAG'
      print 9000
      do 50 alpha = -0.9d0, 0d0, 0.1d0
         call qqag(alpha)
   50 continue
      do 60 alpha = 0.2d0, 2.6d0, 0.2d0
         call qqag(alpha)
   60 continue
 9000 format('alpha   est result              est abserr             nev
     &al    ier   true answer            true abs err')
      end
      double precision function soln(alpha)
      double precision alpha
      soln = (1 + alpha)**(-2)
      return
      end

      double precision function f(x)
      double precision x
      double precision alfa
      common /param/ alfa
      f = x**alfa * log(1/x)
      return
      end

      subroutine qqng(alpha)
      integer limit, lenw
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqng(f, 0d0, 1d0, 0d0, 1d-8, result, abserr, neval, ier)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end

      subroutine qqags(alpha)
      integer limit, lenw
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqags(f, 0d0, 1d0, 0d0, 1d-8, result, abserr, neval, ier,
     $     limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end

      subroutine qqag(alpha)
      integer limit, lenw
      parameter (limit = 200, lenw = 4*limit)

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqag(f, 0d0, 1d0, 0d0, 1d-8, 1, result, abserr, neval, ier,
     $     limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end


module NNActiv
    implicit none

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

    contains

    !-- Elemental Activation --!
    elemental function elementalActivation(y,activation) result(z)
        implicit none

        real(dp),intent(in)         :: y
        character(len=*),intent(in) :: activation
        real(dp)                    :: z

        select case(activation)
            case("Sigmoid")
                if (y > 100.0) then
                    z = 1.0/(1.0 + exp(-100.0))
                else if (y < -100.0) then
                    z = exp(-100.0)
                else
                    z = 1.0/(1.0 + exp(-y))
                end if

            case("ReLU")
                if (y < 0.0) then
                    z = 0.0
                else
                    z = y
                end if

            case("lReLU")
                if (y < 0.0) then
                    z = 1E-3*y
                else
                    z = y
                end if

            case("tanh")
                if (y > 100.0) then
                    z = tanh(100.0)
                else if (y < -100.0) then
                    z = tanh(-100.0)
                else
                    z = tanh(y)
                end if

            case("soft+")
                if (y > 100.0) then
                    z = y
                else
                    z = log(1.0+exp(y))
                end if

            case("none")
                z = y

        end select
    end function

    !-- Elemental Deactivation --!
    elemental function elementalDeactivation(y,z,activation) result(dzdy)
        implicit none

        real(dp),intent(in)         :: y,z
        character(len=*),intent(in) :: activation
        real(dp)                    :: dzdy

        select case(activation)
            case("Sigmoid")
                dzdy = z*(1-z)

            case("ReLU")
                if (y > 0) then
                    dzdy = 1.0
                else
                    dzdy = 0.0
                end if

            case("lReLU")
                if (y > 0) then
                    dzdy = 1.0
                else
                    dzdy = 1E-3
                end if

            case("tanh")
                dzdy = 1-z*z

            case("soft+")
                dzdy = 1-exp(-z)

            case("none")
                dzdy = y

        end select
    end function

    !-- ACTIVATE --!
    function activate(Y,activation) result(Z)
        implicit none

        real(dp),intent(in)         :: Y(:,:)
        character(len=*),intent(in) :: activation
        real(dp)                    :: Z(size(Y,1),size(Y,2))

        if (activation .eq. "softmax") then
            Z = softmax(Y)
        else
            Z = elementalActivation(Y,activation)
        end if
    end function

    !-- DEACTIVATE --!
    function deactivate(dLdZ,Y,Z,activation) result(dLdY)
        implicit none

        real(dp),intent(in)         :: dLdZ(:,:)
        real(dp),intent(in)         :: Y(:,:)
        real(dp),intent(in)         :: Z(:,:)
        character(len=*),intent(in) :: activation
        real(dp)                    :: dLdY(size(dLdZ,1),size(dLdZ,2))

        integer     :: i,j

        do j = 1,size(dLdY,2)
            do i = 1,size(dLdY,1)
                if (activation .eq. "softMax") then
                    dLdY(i,j) = -Z(j,i)*Z(j,i)
                    if (i == j) then
                        dLdY(j,j) = dLdY(j,j) + Z(j,i)
                    end if
                    dLdY(i,j) = dLdY(i,j)*dLdZ(i,j)
                else
                    dLdY(i,j) = dLdZ(i,j)*elementalDeactivation(Y(j,i),Z(j,i),activation)
                end if
            end do
        end do

    end function

    !-- SOFTMAX --!
    function softmax(Y) result(Z)
        implicit none

        real(dp),intent(in) :: Y(:,:)
        real(dp)            :: Z(size(Y,1),size(Y,2))

        real(dp)    :: mx,s
        integer     :: i

        mx = maxval(Y(:,1))

        s = 0
        do i = 1,size(Y,1)
            Z(i,1) = exp(Y(i,1)-mx)
            s = s + Z(i,1)
        end do
        do i = 1,size(y,1)
            Z(i,1) = Z(i,1)/s
        end do
    end function

end module


subroutine secant(f,a,b,x,tol,maxiter,iter,ier)

integer, parameter :: dp=kind(1.d0)
real(dp),external :: f
real(dp),intent(inout) :: a
real(dp),intent(inout) :: b
real(dp),intent(inout) :: x
real(dp),intent(in) :: tol
integer,intent(in) :: maxiter
integer,intent(out) :: iter
integer,intent(out) :: ier

real(dp) :: fa,fb,xzero,fxzero,deltax

fa = f(a)
fb = f(b)

if (fa*fb .gt. 0.0_dp) then
 print*,"ERROR IN SECANT METHOD !!! BAD INTERVAL !!!"
end if

xzero = b - fb*(b - a)/(fb - fa)
fxzero = f(xzero)
iter = 1
deltax = 1.0_dp

do while (deltax.gt.tol.and.iter.lt.maxiter)
 x = xzero - fxzero*(xzero - b)/(fxzero - fb)
 deltax = abs(xzero - x)
 b = xzero
 xzero = x
 fb = fxzero
 fxzero = f(x)
 iter = iter + 1
end do

 if (iter.gt.maxiter) then
  ier = 1
  print*,"ERROR IN SECANT METHOD !!! TOO MANY ITERATIONS !!!"
 else
  ier = 0
 end if

end subroutine


program test_cos
use lfortran_intrinsic_math, only: cos
implicit none
real :: x
x = cos(9.5)
if (abs(x - (-0.997172177)) > 1e-5) error stop
end program


c fishpk32 from portlib                                  12/30/83
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                        f i s h p a k                          *
c     *                                                               *
c     *                                                               *
c     *     a package of fortran subprograms for the solution of      *
c     *                                                               *
c     *      separable elliptic partial differential equations        *
c     *                                                               *
c     *                  (version 3.1 , october 1980)                  *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *        john adams, paul swarztrauber and roland sweet         *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the national center for atmospheric research          *
c     *                                                               *
c     *                boulder, colorado  (80307)  u.s.a.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the national science foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     program to illustrate the use of hstcyl to solve the equation
c
c    (1/r)(d/dr)(r*du/dr) + (d/dz)(du/dz) = (2*r*z)**2*(4*z**2 + 3*r**2)
c
c     on the rectangle 0 .lt. r .lt. 1 , 0 .lt. z .lt. 1 with the
c     boundary conditions
c
c     (du/dr)(1,z) = 4*z**2  for  0 .le. z .le. 1
c
c     and
c
c     (du/dz)(r,0) = 0 and (du/dz)(r,1) = 4*r**2  for  0 .le. r .le. 1 .
c
c     the solution to this problem is not unique.  it is a
c     one-parameter family of solutions given by
c
c            u(r,z) = (r*z)**4 + arbitrary constant .
c
c     the r-interval will contain 50 unknowns and the z-interval will
c     contain 52 unknowns.
c
      program thstcyl
      dimension       f(51,52)   ,bdb(52)    ,bdc(50)    ,bdd(50)    ,
     1                w(1108)    ,r(50)      ,z(52)
      dimension bda(1)
c
c     from dimension statement we get value of idimf.  also note that w
c     is dimensioned (13 + int(log2(n)))*m + 4*n .
c
      idimf = 51
      a = 0.
      b = 1.
      m = 50
      mbdcnd = 6
      c = 0.
      d = 1.
      n = 52
      nbdcnd = 3
      elmbda = 0.
c
c     generate and store grid points for the purpose of computing
c     boundary data and the right side of the poisson equation.
c
      do 101 i=1,m
         r(i) = (float(i)-0.5)/50.
  101 continue
      do 102 j=1,n
         z(j) = (float(j)-0.5)/52.
  102 continue
c
c     generate boundary data.
c
      do 103 j=1,n
         bdb(j) = 4.*z(j)**4
  103 continue
      do 104 i=1,m
         bdc(i) = 0.
         bdd(i) = 4.*r(i)**4
  104 continue
c
c     bda is a dummy variable.
c
c     generate right side of equation.
c
      do 106 i=1,m
         do 105 j=1,n
            f(i,j) = 4.*r(i)**2*z(j)**2*(4.*z(j)**2+3.*r(i)**2)
  105    continue
  106 continue
      call hstcyl (a,b,m,mbdcnd,bda,bdb,c,d,n,nbdcnd,bdc,bdd,elmbda,f,
     1             idimf,pertrb,ierror,w)
c
c     compute discretization error by minimizing over all a the function
c     norm(f(i,j) - a*1 - u(r(i),z(j))).  the exact solution is
c                u(r,z) = (r*z)**4 + arbitrary constant.
c
      x = 0.
      do 108 i=1,m
         do 107 j=1,n
            x = x+f(i,j)-(r(i)*z(j))**4
  107    continue
  108 continue
      x = x/float(m*n)
      do 110 i=1,m
         do 109 j=1,n
            f(i,j) = f(i,j)-x
  109    continue
  110 continue
      err = 0.
      do 112 i=1,m
         do 111 j=1,n
            x = abs(f(i,j)-(r(i)*z(j))**4)
            if (x .gt. err) err = x
  111    continue
  112 continue
      print 1001 , ierror,pertrb,err,w(1)
      stop
c
 1001 format (1h1,20x,25hsubroutine hstcyl example///
     1        10x,46hthe output from the ncar control data 7600 was//
     2        32x,10hierror = 0/32x,20hpertrb =-4.43114e-04/
     3        18x,34hdiscretization error = 7.52796e-05/
     4        12x,32hrequired length of w array = 958//
     5        10x,32hthe output from your computer is//
     6        32x,8hierror =,i2/32x,8hpertrb =,e12.5/
     7        18x,22hdiscretization error =,e12.5/
     8        12x,28hrequired length of w array =,f4.0)
c
      end


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

! Sum square difference
!
! The sum of the squares of the first ten natural numbers is,
! 1^2 + 2^2 + ... + 10^2 = 385
!
! The square of the sum of the first ten natural numbers is,
! (1 + 2 + ... + 10)^2 = 55^2 = 3025
!
! Hence the difference between the sum of the squares of the first ten natural
! numbers and the square of the sum is 3025 - 385 = 2640.
!
! Find the difference between the sum of the squares of the first one hundred
! natural numbers and the square of the sum.
module MPEProblem6

    implicit none
    private

    type, public :: TPEProblem6
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present
        write (*, '(A)') 'Problem 6. Sum square difference.'

        write (*, '(A, I)') 'Difference 1: ', difference1()
    end subroutine

    function difference1()
        integer difference1
        integer sum
        integer square
        integer index

        ! initial values
        sum    = 0
        square = 0

        do concurrent (index = 1:100)
            ! the sum of the squares
            sum = sum + index ** 2

            ! the square of the sum
            square = square + index
        end do

        square = square ** 2

        difference1 = square - sum
    end function
end module


MODULE Triangle_Operations
     IMPLICIT NONE
CONTAINS
     FUNCTION Area(x,y,z)
      REAL(8) :: Area            ! function type
      REAL(8), INTENT( IN ) :: x, y, z
      REAL(8) :: theta, height
      theta = ACOS((x**2+y**2-z**2)/(2.0*x*y))
      height = x*SIN(theta); Area = 0.5*y*height
     END FUNCTION Area
END MODULE Triangle_Operations

PROGRAM Triangle
     USE Triangle_Operations
     IMPLICIT NONE
     REAL(8) :: a, b, c, area_sum

     INTEGER :: a_i, b_i, c_i

     area_sum = 0.0

     DO a_i = 1, 1000, 1
        a = a_i * 1.0
        DO b_i = 1, 1000, 1
            b = b_i * 1.0
            DO c_i = 1, 1000, 1
                c = c_i * 1.0
                area_sum = area_sum + Area(a, b, c)
            END DO
        END DO
     END DO

     PRINT *, 'Triangle''s area:  ', area_sum
END PROGRAM Triangle