!>
! Runs a linear advection diffusion equation with increasing resolution and checks that the observed
! convergence orders match the order of the involved discretizations.
!
PROGRAM advection_diffusion_test

USE Timestepper, only : Euler, RK3Ssp, InitializeTimestepper, FinalizeTimestepper
IMPLICIT NONE

INCLUDE 'mpif.h'

#include <preprocessor.f90>

#if(linear==0)
    WRITE(*,*) 'WARNING: advection_diffusion_test requires linear advection to have analytical solution available... recompile with flag linear=1 to run this test. Now exiting.'
    STOP
#else

DOUBLE PRECISION, PARAMETER :: pi = 3.1415926535897932_8 ! underscore indicates rounding to real(8) precision
INTEGER, PARAMETER, DIMENSION(5) :: N_v = (/ 20, 30, 40, 50, 60 /)

DOUBLE PRECISION, PARAMETER :: Tend = 0.05

DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: Q, Qref
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: error

DOUBLE PRECISION :: dx, dy, dz, x, y, z, dt, nu, convrate
INTEGER :: method, i, j, k, Nx, Ny, Nz, nn, order_adv, order_diff, Nsteps, Nthreads, mpi_thread_provided, ierr

CALL MPI_INIT_THREAD(MPI_THREAD_FUNNELED, mpi_thread_provided, ierr)

DO method=1,3,2

        IF  (method==1) THEN
            order_adv  = 1
            order_diff = 2
        ELSE IF (method==3) THEN
            order_adv  = 5
            order_diff = 4
        END IF

        ALLOCATE(error(SIZE(N_v)))

        DO nn=1,SIZE(N_v)

            Nx = N_v(nn)-3
            Ny = N_v(nn)+1
            Nz = N_v(nn)+3

            dx = 1.0/DBLE(Nx)
            dy = 1.0/DBLE(Ny)
            dz = 1.0/DBLE(Nz)

            !nu = 0.0025
            nu = 0.0
            !dt = 0.5*(dz*dz)/nu
            dt = 0.25*dz
            Nsteps = CEILING(Tend/dt)
            dt     = Tend/DBLE(Nsteps)

           Nthreads=1

          ALLOCATE(Q(   -2:Nx+3, -2:Ny+3, -2:Nz+3, 0:Nthreads-1))
          ALLOCATE(Qref(-2:Nx+3, -2:Ny+3, -2:Nz+3, 0:Nthreads-1))

          CALL InitializeTimestepper(nu, Nx, Ny, Nz, Nthreads)

          ! Compute initial and analytic solution
          DO k=-2,Nz+3
              DO j=-2,Ny+3
                  DO i=-2,Nx+3

                  x = 0.5*dx + DBLE(i - 1)*dx
                  y = 0.5*dy + DBLE(j - 1)*dy
                  z = 0.5*dz + DBLE(k - 1)*dz

                  Q(i,j,k,:)    = SIN(2.0*pi*x)*SIN(2.0*pi*y)*SIN(2.0*pi*z)
                  Qref(i,j,k,:) = EXP(-12*nu*pi*pi*Tend)*SIN(2.0*pi*(x-Tend))*SIN(2.0*pi*(y-Tend))*SIN(2.0*pi*(z-Tend))

                  END DO
              END DO
          END DO

          IF (method==1) THEN
              CALL Euler( Q(:,:,:,0), DBLE(0.0), Tend, Nsteps, dx, dy, dz, order_adv, order_diff)
          ELSE IF (method==3) THEN
              CALL Rk3Ssp(Q(:,:,:,0), DBLE(0.0), Tend, Nsteps, dx, dy, dz, order_adv, order_diff)
          END IF

          error(nn) = MAXVAL(ABS(Q(1:Nx,1:Ny,1:Nz,0) - Qref(1:Nx,1:Ny,1:Nz,0)))/MAXVAL(ABS(Qref(1:Nx,1:Ny,1:Nz,0)))

          CALL FinalizeTimestepper

          DEALLOCATE(Q)
          DEALLOCATE(Qref)

        END DO ! N_v

        DO nn=1,SIZE(N_v)-1
            convrate = LOG10( error(nn+1)/error(nn) )/LOG10( DBLE(N_v(nn))/DBLE(N_v(nn+1)) )
           IF (convrate < 0.95*DBLE(method)) THEN
              WRITE(*,'(A, I2, A)') 'ERROR: Method ', method, ' failed to reproduce expected order of convergence. Now exiting.'
              STOP
           END IF
        END DO

        DEALLOCATE(error)

END DO ! method

CALL MPI_FINALIZE(ierr)

PRINT*, '\x1B[32m[0] -- Successful: Both Euler and Rk3Ssp produced the expected order of convergence for the linear advection-diffusion problem. \x1B[0m'

#endif

END PROGRAM advection_diffusion_test


module test_various_functions_mod
   use various_functions_mod
   use funit
   implicit none

contains

   @test
   subroutine test_dmatinv3()

      double precision,dimension(3,3) :: A, B, C, D
      double precision,dimension(3,3) :: D_known
      integer :: ierr

      A = reshape((/1.d0, 0.d0, 0.d0, 0.d0, 1.d0, 0.d0, 0.d0, 0.d0, 1.d0/), (/3, 3/))
      call dmatinv3(A, B, ierr)

      @assertEqual(A, B, tolerance=1e-13, message="test various_functions_mod with identity matrix")

      C = reshape((/0.d0, 1.d0, 1.d0, 1.d0, 0.d0, 1.d0, 1.d0, 1.d0, 0.d0/), (/3, 3/))
      call dmatinv3(C, D, ierr)

      D_known = 1.d0/2.d0*reshape((/-1.d0, 1.d0, 1.d0, 1.d0, -1.d0, 1.d0, 1.d0, 1.d0, -1.d0/), (/3, 3/))
      @assertEqual(D, D_known, tolerance=1e-13, message="test various_functions_mod with a symmetric matrix")

   end subroutine test_dmatinv3

   @test
   subroutine test_dmatinv3_fail()

      double precision,dimension(3,3) :: A, B, C, D
      integer :: ierr

      A = reshape((/1.d0, 0.d0, 0.d0, 0.d0, 1.d0, 0.d0, 0.d0, 0.d0, 0.d0/), (/3, 3/))
      call dmatinv3(A, B, ierr)

      @assertEqual(ierr, 1, message = "test various_functions_mod, matrix not invertible")

   end subroutine test_dmatinv3_fail

end module test_various_functions_mod


subroutine heat_fort_rhs(blockno, mbc,mx,my,meqn,mfields, &
                         xlower,ylower,dx,dy,lambda, method,q,rhs)
    IMPLICIT NONE

    INTEGER mbc,mx,my, mfields, meqn, method
    DOUBLE PRECISION xlower,ylower,dx,dy, lambda
    DOUBLE PRECISION rhs(1-mbc:mx+mbc,1-mbc:my+mbc,mfields)
    DOUBLE PRECISION q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

    INTEGER i,j, blockno

    do i = 1-mbc,mx+mbc
        do j = 1-mbc,my+mbc
!!            xc = xlower + (i-0.5)*dx
!!            yc = ylower + (j-0.5)*dy
            rhs(i,j,1) = lambda*q(i,j,1)
        end do
    end do

end subroutine heat_fort_rhs

subroutine heat_update_q(mbc,mx,my,meqn,mfields,rhs,q)
    IMPLICIT NONE

    INTEGER mbc,mx,my, mfields, meqn
    DOUBLE PRECISION rhs(1-mbc:mx+mbc,1-mbc:my+mbc,mfields)
    DOUBLE PRECISION q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

    INTEGER i,j

    do i = 1,mx
        do j = 1,my
            q(i,j,1) = rhs(i,j,1)
        end do
    end do
!!100 format(2F16.8)

end subroutine heat_update_q


! Longest Collatz sequence
!
! The following iterative sequence is defined for the set of positive integers:
!
!    n  > n/2 (n is even)
!    n  > 3n + 1 (n is odd)
!
! Using the rule above and starting with 13, we generate the following sequence:
!
!    13 > 40 > 20 > 10 > 5 > 16 > 8 > 4 > 2 > 1
!
! It can be seen that this sequence (starting at 13 and finishing at 1) contains
! 10  terms. Although it has not been proved yet (Collatz Problem), it is
! thought that all starting numbers finish at 1.
!
! Which starting number, under one million, produces the longest chain?
!
! NOTE: Once the chain starts the terms are allowed to go above one million.
module Problem14

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 14. Longest Collatz sequence.'

        write (*, '(A, I)') 'Chain 1: ', chain1()
    end subroutine

    function chain1
        integer :: chain1
        integer :: index
        integer :: value
        integer :: max

        ! initial values
        chain1 = 0
        index  = 0
        value  = 0
        max    = 0

        do index = 1, 1000000
            value = get_length(index)

            if (value .gt. max) then
                max    = value
                chain1 = index
            end if
        end do
    end function

    function get_length(number)
        integer, intent(in) :: number

        integer :: get_length
        integer*8 :: value

        ! initial value
        get_length = 1
        value      = number

        do while (value .gt. 1)
            if (mod(value, 2) .eq. 0) then
                value = value / 2
            else
                value = (value * 3) + 1
            end if

            get_length = get_length + 1
        end do
    end function
end module


   !#################################################################################!
 !/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\!
!######################################################################################!
!##!                                                                                !##!
!##!                                                                                !##!
MODULE Additional_Functions_Module                                                  !##!
!##!                                                                                !##!
!##!________________________________________________________________________________!##!
!##!                                                                                !##!
!##!    Contains functions and subroutine to calculate special functions such as    !##!
!##!    the Lagrange and Legendre Polynomials and Spherical Harmonics, initialize   !##!
!##!    quadratures, perform other useful operations                                !##!
!##!                                                                                !##!
!##!================================================================================!##!
!##!                                                                                !##!
!##!    Contains:                                                                   !##!
!##!                                                                                !##!
!##!    +101+   Lagrange_Poly                                                       !##!
!##!    +102+   Lagrange_First_Deriv                                                !##!
!##!    +103+   Lagrange_Second_Deriv                                               !##!
!##!    +104+   Legendre_Poly                                                       !##!
!##!    +105+   Spherical_Harmonic                                                  !##!
!##!                                                                                !##!
!##!    +201+   Norm_Factor                                                         !##!
!##!    +202+   Factorial                                                           !##!
!##!    +203+   Factorial_Division                                                  !##!
!##!    +204+   Power                                                               !##!
!##!                                                                                !##!
!##!    +301+   Map_To_X_Space                                                      !##!
!##!    +302+   Map_From_X_Space                                                    !##!
!##!                                                                                !##!
!##!    +401+   MVMULT_CCS                                                          !##!
!##!    +402+   MVMULT_FULL                                                         !##!
!##!    +403+   SVVAD                                                               !##!
!##!                                                                                !##!
!##!    +501+   Initialize_LGL_Quadrature                                           !##!
!##!    +502+   Initialize_LGL_Quadrature_Locations                                 !##!
!##!    +503+   Initialize_LG_Quadrature                                            !##!
!##!    +504+   Initialize_LG_Quadrature_Locations                                  !##!
!##!                                                                                !##!
!##!    +601+   SphericalHarmonic_OrthogonalityTest                                 !##!
!##!                                                                                !##!
!##!                                                                                !##!
!######################################################################################!
 !\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/!
   !#################################################################################!

!*D*================================!
!                                   !
!           Dependencies            !
!                                   !
!===================================!
USE constants, &
            ONLY: idp, pi, eps

IMPLICIT NONE

CONTAINS
 !+101+################################################################!
!                                                                       !
!   Lagrange_Poly - Calculates the value of the Lagrange Polynomial     !
!                                                                       !
!                                                                       !
 !#####################################################################!
PURE FUNCTION Lagrange_Poly(x, Ord, xlocs)

INTEGER, INTENT(IN)                                 :: Ord
REAL(KIND = idp), INTENT(IN)                        :: x
REAL(KIND = idp), INTENT(IN), DIMENSION(0:Ord)      :: xlocs

INTEGER                                             :: i,j
REAL(KIND = idp), DIMENSION(0:Ord)                  :: tmp
REAL(KIND = idp), DIMENSION(0:Ord)                  :: Lagrange_Poly

tmp(:) = 1.0_idp

DO j = 0,Ord
    DO i = 0,Ord
        IF (i .NE. j) THEN
            tmp(i) = tmp(i) * (x - xlocs(j))/(xlocs(i) - xlocs(j))
        END IF
    END DO
END DO

Lagrange_Poly = tmp

END FUNCTION Lagrange_Poly

 !+102+################################################################!
!                                                                       !
!   Lagrange_Poly_Deriv - Calculates the value of the first derivative  !
!                    of Lagrange Polynomials.                           !
!                                                                       !
!                                                                       !
 !#####################################################################!
FUNCTION Lagrange_Poly_Deriv(x, Ord, xlocs)

INTEGER, INTENT(in)                                 :: Ord
REAL(KIND = idp), INTENT(in)                        :: x
REAL(KIND = idp), INTENT(inout), DIMENSION(0:Ord)   :: xlocs

INTEGER                                             :: i,j,k
REAL(KIND = idp), DIMENSION(0:Ord)                  :: tmp,tmp2
REAL(KIND = idp), DIMENSION(0:Ord)                  :: Lagrange_Poly_Deriv

tmp(:) = 1.0_idp
tmp2(:) = 0.0_idp

DO j = 0,Ord
    DO i = 0,Ord
        IF (i .NE. j) THEN

            tmp(i) = 1/(xlocs(i) - xlocs(j))

            DO k = 0,Ord

                IF (k .NE. i .AND. k .NE. j) THEN
                    tmp(i) = tmp(i) * (x - xlocs(k))/(xlocs(i) - xlocs(k))
                END IF

            END DO
            tmp2(i) = tmp2(i) + tmp(i)
        END IF
    END DO
END DO

Lagrange_Poly_Deriv = tmp2

END FUNCTION Lagrange_Poly_Deriv

 !+103+################################################################!
!                                                                       !
!   Lagrange_Second_Deriv - Calculates the value of the first derivative  !
!                    of Lagrange Polynomials.                           !
!                                                                       !
!                                                                       !
 !#####################################################################!
FUNCTION Lagrange_Second_Deriv(x, Ord, xlocs)

INTEGER, INTENT(in)                                 :: Ord
REAL(KIND = idp), INTENT(in)                        :: x
REAL(KIND = idp), INTENT(inout), DIMENSION(0:Ord)   :: xlocs

INTEGER                                             :: i, j, k, l
REAL(KIND = idp), DIMENSION(0:Ord)                  :: tmp,tmp2
REAL(KIND = idp), DIMENSION(0:Ord)                  :: Lagrange_Second_Deriv

IF (Ord == 1) THEN

    LAGRANGE_SECOND_DERIV = 0.0_idp

ELSE

    tmp(:) = 1.0_idp
    tmp2(:) = 0.0_idp

    DO i = 0,Ord

        DO k = 0,Ord

            IF (k .NE. i) THEN

                DO l = 0,Ord

                    IF (l .NE. i .AND. l .NE. k) THEN

                        tmp(i) = (1/(xlocs(i) - xlocs(k)))*(1/(xlocs(i) - xlocs(l)))

                        !print*,"tmp A ",i, k, l, tmp(i)

                        DO j = 0,Ord

                            IF (j .NE. i .AND. j .NE. k .AND. j .NE. l) THEN

                                tmp(i) = tmp(i) * (x - xlocs(j))/(xlocs(i) - xlocs(j))
                                !print*,"tmp B ",i, k, l, j, tmp(i)

                            END IF

                        END DO  ! j Loop

                        tmp2(i) = tmp2(i) + tmp(i)

                        !print*,"tmp A",j, i, tmp2(i)

                    END IF

                END DO ! l Loop

            END IF

        END DO  ! k Loop

    END DO  ! i Loop

    Lagrange_Second_Deriv = tmp2

END IF

END FUNCTION Lagrange_Second_Deriv

 !+104+################################################################!
!                                                                       !
!   Legendre_Poly - Calculates the value of the Legendre Polynomial     !
!                   P^m_l(cos(theta))                                   !
!                                                                       !
 !#####################################################################!
FUNCTION Legendre_Poly(l,m,num_points,theta)

!  Returns array that conatins the values P^m_n(cos(theta)) for n = 0:l
!  If m > n then returns 0 as the poly doesn't exist there.

INTEGER, INTENT(IN)                                     :: l,m, num_points
REAL(KIND = idp),  INTENT(IN), DIMENSION(1:num_points)  :: theta
REAL(KIND = idp), DIMENSION(1:num_points)               :: Legendre_Poly, Legendre_Polyc

INTEGER                                         :: i,j,n
REAL(KIND = idp)                                :: factor, normfactor
REAL(KIND = idp), DIMENSION(1:num_points)       :: costheta, sqrfactor
REAL(KIND = idp), DIMENSION(0:l,1:num_points)   :: Plm

n = abs(m)
costheta = cos(theta)
sqrfactor = sqrt(1.0_idp - costheta*costheta)

Plm(:,:) = 0.0_idp

IF (n <= l) THEN

    Plm(n,:) = 1.0_idp
    factor = 1.0_idp

    DO i = 1,n
        Plm(n,:) = -Plm(n,:)*factor*sqrfactor(:)
        factor = factor + 2.0_idp
    END DO
END IF

IF (n + 1 <= l) THEN
    Plm(n+1,:) = costheta(:)*(2.0_idp*n + 1.0_idp) * Plm(n,:)
END IF

DO i = n+2,l

    Plm(i,:) = ( ( 2*i - 1)*costheta(:)*Plm(i-1,:) + (-i - n +1)*Plm(i-2,:) )/(i - n)

END DO

If (m < 0) THEN
    normfactor = ((-1)**n)*(1.0_idp*Factorial(l-n))/(1.0_idp*Factorial(l+n))

    Legendre_Poly(:) = normfactor*Plm(l,:)
ELSE
    Legendre_Poly(:) = Plm(l,:)
END IF

END FUNCTION Legendre_Poly

 !+105+################################################################!
!                                                                       !
!   Spherical_Harmonic - Calculates the value of the spherical harmonic,!
!                       Y^M_L(Theta, Phi). Uses Legendre_Poly           !
!                                                                       !
!           Output - 2L Value array - (Real, Imaginary)                 !
!                                                                       !
 !#####################################################################!
FUNCTION Spherical_Harmonic(l,m,theta,phi)

INTEGER, INTENT(IN)                         :: l,m
REAL(KIND = idp), INTENT(IN)                :: theta, phi

INTEGER                                     :: abs_m
REAL(KIND = idp), DIMENSION(0:0)            :: Plm
COMPLEX(KIND = idp)                         :: Spherical_Harmonic

Plm = Legendre_Poly(l,m,1,[theta])

Spherical_Harmonic = Norm_Factor(l,m)*Plm(0)*EXP(COMPLEX(0,m*phi))

END FUNCTION Spherical_Harmonic

 !+201+####################################################!
!                                                           !
!       Norm_Factor - Calculate normalization factor for    !
!                       spherical harmonics                 !
!                                                           !
 !#########################################################!
FUNCTION Norm_Factor(l,m)

INTEGER, INTENT(IN)         :: l,m
REAL(KIND = idp)            :: Norm_Factor

!Norm_Factor = 1.0_idp
Norm_Factor = sqrt( ( ( 2.0_idp * l + 1.0_idp) * Factorial(l - m))/( 4.0_idp * pi * Factorial(l + m)))
!Norm_Factor = sqrt(  (( 2.0_idp * l + 1.0_idp)/( 4.0_idp * pi)) * Factorial_Division(l - m, l + m) )

END FUNCTION Norm_Factor

 !+202+################################################################!
!                                                                       !
!       Factorial - Calulcates N!, for use in Legendre_Poly             !
!                                                                       !
 !#####################################################################!
PURE REAL(KIND = idp) FUNCTION Factorial(n)

INTEGER, INTENT(IN) :: n

INTEGER             :: i
REAL(KIND = idp)  :: fact

fact = 1
DO i = 2,n
    fact = fact*i
END DO

Factorial = fact

END FUNCTION Factorial

 !+203+################################################################!
!                                                                       !
!       Factorial_Division - Calulcates M!/N!, for use in Legendre_Poly !
!                                                                       !
 !#####################################################################!
REAL(KIND = idp) FUNCTION Factorial_Division(M,N)

INTEGER, INTENT(IN) :: N,M

INTEGER             :: i
REAL(KIND = idp)  :: fact

IF (M .GE. N) THEN

    fact = N
    DO i = N+1,M
        fact = fact*i
    END DO

    IF (fact .EQ. 0) THEN
        fact = 1
    END IF

END IF

IF (M < N) THEN

    fact = M

    IF (fact .EQ. 0) THEN
        fact = 1
    END IF

    DO i = M+1, N
        fact = fact*i
    END DO

    fact = 1/fact

END IF

Factorial_Division = fact

END FUNCTION Factorial_Division

 !+204+################################################################!
!                                                                       !
!       POWER - Simple x**y function for testing code, TEST_LGL         !
!                                                                       !
 !#####################################################################!
PURE ELEMENTAL FUNCTION POWER(x,y)

INTEGER, INTENT(IN)             :: y
REAL(KIND = idp), INTENT(IN)    :: x

INTEGER                         :: i
REAL(KIND = idp)                :: tmp
REAL(KIND = idp)                :: POWER

tmp = 1.0_idp

IF (y < 0) THEN

    DO i = 1,abs(y)

        tmp = tmp/x

    END DO

ELSE

    DO i = 1,y
        tmp = tmp*x
    END DO

END IF

POWER = tmp

END FUNCTION POWER

!+301+##################################################!
!                                                       !
!      Map_To_X_Space - maps r value between ra, and rb to x   !
!                   space such that x in [-1,1].        !
!                                                       !
!#######################################################!
PURE ELEMENTAL FUNCTION Map_To_X_Space(ra, rb, r)

REAL(KIND = idp)                            ::  Map_To_X_Space
REAL(KIND = idp), intent(in)                ::  ra, rb
REAL(KIND = idp), intent(in)                ::  r

Map_To_X_Space = (2.0_idp*(r - ra))/(rb - ra) - 1.0_idp

END FUNCTION Map_To_X_Space

!+302+##################################################!
!                                                       !
!      Map_From_X_Space - maps x value between -1, and 1 to r    !
!                   space such that r in [ra,rb].       !
!                                                       !
!#######################################################!
PURE ELEMENTAL FUNCTION Map_From_X_Space(a, b, x)

REAL(KIND = idp)                            ::  Map_From_X_Space
REAL(KIND = idp), intent(in)                ::  a, b
REAL(KIND = idp), intent(in)                ::  x

Map_From_X_Space = ((b - a)* (x+1.0_idp))/2.0_idp  + a

END FUNCTION Map_From_X_Space

!+401+############################################################!
!
!     MVMULT_CCS: Multiply a vector by a matrix in CCS format
!
!#################################################################!
FUNCTION MVMULT_CCS(N, NNZ, ELEM_VAL, COL_PTR, ROW_IND, VECT)

INTEGER, INTENT(IN)                                         :: N, NNZ
INTEGER, DIMENSION(0:N), INTENT(IN)                         :: COL_PTR
INTEGER, DIMENSION(0:NNZ - 1),INTENT(IN)                    :: ROW_IND

REAL(KIND = idp), DIMENSION(0:NNZ - 1), INTENT(IN)          :: ELEM_VAL
REAL(KIND = idp), DIMENSION(0:N-1), INTENT(IN)              :: VECT

REAL(KIND = idp), DIMENSION(0:N-1)                          :: MVMULT_CCS

INTEGER                                                     :: i, j

MVMULT_CCS = 0.0_idp

DO i = 0,N-1

    DO j = COL_PTR(i),COL_PTR(i+1)-1

        MVMULT_CCS(ROW_IND(j)) =  MVMULT_CCS(ROW_IND(j)) + ELEM_VAL(j)*VECT(i)

    END DO

END DO

END FUNCTION MVMULT_CCS

!+402+############################################################!
!
!     MVMULT_FULL: Multiply a vector by a matrix in CCS format
!
!#################################################################!
PURE FUNCTION MVMULT_FULL(A, V, N, M)

INTEGER, INTENT(IN)                                         :: N, M
REAL(KIND = idp), INTENT(IN), DIMENSION(1:M)                :: V
REAL(KIND = idp), INTENT(IN), DIMENSION(1:N,1:M)            :: A

REAL(KIND = idp), DIMENSION(1:N)                            :: MVMULT_FULL

REAL(KIND = idp), DIMENSION(1:N)                            :: Sol

INTEGER                                                     :: i,j

Do i = 1,N

    Sol(i) = 0.D0

    Do j = 1,M

    Sol(i) = Sol(i) + A(i,j)*V(j)

    END DO

END DO

MVMULT_FULL = Sol

END FUNCTION MVMULT_FULL

!+403+############################################!
!
!     SVVAD - Scaled Vector-Vector Addition
!               A = alpha*A + B
!
!################################################!
FUNCTION SVVADD(N, alpha, A, B )

INTEGER, INTENT(IN)                                 :: N
REAL(KIND = idp), INTENT(IN)                        :: alpha

REAL(KIND = idp), DIMENSION(0:N-1), INTENT(IN)      :: B
REAL(KIND = idp), DIMENSION(0:N-1), INTENT(IN)      :: A

REAL(KIND = idp), DIMENSION(0:N-1)                  :: SVVADD

INTEGER                                             :: i

DO i = 0,N-1

    SVVADD(i) = alpha*A(i) + B(i)

END DO

END FUNCTION SVVADD

 !+501+####################################################################!
!                                                                           !
!   Initialize_LGL_Quadrature - Calculate the Legendre-Gauss-Lobatto        !
!               Quadrature node locations and weights.                      !
!                                                                           !
 !#########################################################################!
SUBROUTINE Initialize_LGL_Quadrature(Ord, xloc, weights)

INTEGER, INTENT(IN)                                     ::  Ord
REAL(KIND = idp), INTENT(INOUT), DIMENSION(0:Ord)       ::  xloc, weights

INTEGER                                                 ::  i, j, Op1
REAL(KIND = idp), DIMENSION(0:Ord)                      ::  xtmp, xlast
REAL(KIND = idp), DIMENSION(0:Ord,0:Ord)                ::  VanderM

Op1 = Ord +1

!! Set Initial Guess at x locations !!
DO i = 0,Ord
    xtmp(i) = cos(i*pi/Ord)
END DO

!! Initialize VanderM and xlast !!
VanderM(:,:) = 0.0_idp
xlast(:) = 42

!! Loop until converged on machine precision !!
DO WHILE (MAXVAL(ABS(xtmp(:) - xlast(:))) > eps)

    !! Set xlast to newest versions of xtmp !!
    xlast(:) = xtmp(:)

    VanderM(:,0) = 1
    VanderM(:,1) = xtmp(:)

    !! Calculate Elements of Vandermonde Matrix for Legendre Polynomials !!
    DO i = 1,Ord-1
        VanderM(:,i+1) = ((2*(i+1)-1)*xtmp(:)*VanderM(:,i) - (i)*VanderM(:,i-1))/(i+1)
    END DO

    !! Update xtmp using derivative of Legendre Polynomials !!
    xtmp(:) = xlast(:) - ( xtmp(:)*VanderM(:,Ord) - VanderM(:,Ord-1) )/(Op1 * VanderM(:,Ord))

END DO

DO i = 0,Ord
    xloc(i) = xtmp(Ord-i)
    weights(i) = 2/(Ord*Op1 * VanderM(Ord-i,Ord)*VanderM(Ord-i,Ord))
END DO

END SUBROUTINE Initialize_LGL_Quadrature

 !+502+########################################################################!
!                                                                               !
!   Initialize_LGL_Quadrature_Locations - Calculates the Legendre-Gauss-Lobatto !
!               Quadrature node locations. Does not calculate the weights       !
!               needed for integration, use "Initialize_LGL_Quadrature", +501+, !
!               for locations and weights.                                      !
!                                                                               !
 !#############################################################################!
PURE FUNCTION Initialize_LGL_Quadrature_Locations(Ord)

INTEGER, INTENT(IN)                                     ::  Ord
REAL(KIND = idp),  DIMENSION(0:Ord)                     ::  Initialize_LGL_Quadrature_Locations

INTEGER                                                 ::  i, j, Op1
REAL(KIND = idp), DIMENSION(0:Ord)                      ::  xtmp, xlast
REAL(KIND = idp), DIMENSION(0:Ord,0:Ord)                ::  VanderM

Op1 = Ord +1

!! Set Initial Guess at x locations !!
DO i = 0,Ord
    xtmp(i) = cos(i*pi/Ord)
END DO

!! Initialize VanderM and xlast !!
VanderM(:,:) = 0.0_idp
xlast(:) = 42

!! Loop until converged on machine precision !!
DO WHILE (MAXVAL(ABS(xtmp(:) - xlast(:))) > eps)

    !! Set xlast to newest versions of xtmp !!
    xlast(:) = xtmp(:)

    VanderM(:,0) = 1
    VanderM(:,1) = xtmp(:)

    !! Calculate Elements of Vandermonde Matrix for Legendre Polynomials !!
    DO i = 1,Ord-1
        VanderM(:,i+1) = ((2*(i+1)-1)*xtmp(:)*VanderM(:,i) - (i)*VanderM(:,i-1))/(i+1)
    END DO

    !! Update xtmp using derivative of Legendre Polynomials !!
    xtmp(:) = xlast(:) - ( xtmp(:)*VanderM(:,Ord) - VanderM(:,Ord-1) )/(Op1 * VanderM(:,Ord))

END DO

DO i = 0,Ord
    Initialize_LGL_Quadrature_Locations(i) = xtmp(Ord-i)
END DO

END FUNCTION Initialize_LGL_Quadrature_Locations

!+503+##################################################################!
!                                                                       !
!   Initialize_LG_Quadrature - Calculate the Legendre-Gauss Quadrature  !
!                              node locations and weights.              !
!                                                                       !
!#######################################################################!
SUBROUTINE Initialize_LG_Quadrature(Ord, xloc, weights)

INTEGER, INTENT(IN)                                     ::  Ord
REAL(KIND = idp), INTENT(INOUT), DIMENSION(1:Ord)       ::  xloc, weights

INTEGER                                                 :: i, j, m
REAL(KIND = idp)                                        :: p1, p2, p3, pp, z, z1

m = (Ord + 1)/2

DO i = 1,m

    z = cos(pi * (i-0.25_idp)/(Ord + 0.5_idp))
    z1 = 42.0_idp

    DO WHILE ( ABS(z - z1) .GT. eps)
        p1 = 1.0_idp
        p2 = 0.0_idp

        DO j = 1, Ord

            p3 = p2
            p2 = p1
            p1 = ((2.0_idp*j - 1.0_idp)*z*p2 - (j - 1.0_idp)*p3)/j

        END DO

        pp = Ord*(z*p1 - p2)/(z*z-1.0_idp)
        z1 = z
        z = z1 - p1/pp

    END DO

    xloc(i) = -z
    xloc(Ord-i+1) = +z

    weights(i) = 2.0_idp/((1.0_idp - z*z)*pp*pp)
    weights(Ord-i+1) = weights(i)

END DO

!PRINT*,"!!!!!!!!!!!!!!!"
!PRINT*,xloc
!PRINT*," "
!PRINT*,weights
!PRINT*,"!!!!!!!!!!!!!!!"

END SUBROUTINE Initialize_LG_Quadrature

 !+504+########################################################################!
!                                                                               !
!   Initialize_LG_Quadrature_Locations - Calculates the Legendre-Gauss          !
!               Quadrature node locations. Does not calculate the weights       !
!               needed for integration, use "Initialize_LG_Quadrature", +503+,  !
!               for locations and weights.                                      !
!                                                                               !
 !#############################################################################!
PURE FUNCTION Initialize_LG_Quadrature_Locations(Ord)

INTEGER, INTENT(IN)                                     ::  Ord

REAL(KIND = idp), DIMENSION(1:Ord)                      ::  Initialize_LG_Quadrature_Locations

INTEGER                                                 :: i, j, m
REAL(KIND = idp)                                        :: p1, p2, p3, pp, z, z1

m = (Ord + 1)/2

DO i = 1,m

    z = cos(pi * (i-0.25_idp)/(Ord + 0.5_idp))
    z1 = 42.0_idp

    DO WHILE ( ABS(z - z1) .GT. eps)
        p1 = 1.0_idp
        p2 = 0.0_idp

        DO j = 1, Ord

            p3 = p2
            p2 = p1
            p1 = ((2.0_idp*j - 1.0_idp)*z*p2 - (j - 1.0_idp)*p3)/j

        END DO

        pp = Ord*(z*p1 - p2)/(z*z-1.0_idp)
        z1 = z
        z = z1 - p1/pp

    END DO

    Initialize_LG_Quadrature_Locations(i) = -z
    Initialize_LG_Quadrature_Locations(Ord-i+1) = +z

END DO

!PRINT*,"!!!!!!!!!!!!!!!"
!PRINT*,xloc
!PRINT*," "
!PRINT*,weights
!PRINT*,"!!!!!!!!!!!!!!!"

END FUNCTION Initialize_LG_Quadrature_Locations

!+601+####################################################################!
!                                                                           !
!       SphericalHarmonic_OrthogonalityTest - Shows Orthogonality of Spherical        !
!                                       Harmonic Functions                  !
!                                                                           !
 !#########################################################################!
SUBROUTINE SphericalHarmonic_OrthogonalityTest(L_LIMIT, L_SPECIFIC, M_SPECIFIC)

!REAL(KIND = idp)                                :: BC_Integralb
!COMPLEX(KIND = idp)                                :: SphereHarmonic_OrthogTest

INTEGER, INTENT(IN)                             :: L_LIMIT, L_SPECIFIC, M_SPECIFIC

INTEGER                                         ::  l, m
INTEGER                                         ::  te, td, pe, pd

INTEGER                                         ::  T_Degree, P_Degree

INTEGER                                         ::  T_SUB_ELEMENTS, P_SUB_ELEMENTS

REAL(KIND = idp), ALLOCATABLE, DIMENSION(:)     ::  P_xlocs, P_locs, P_weights, &
                                                    T_xlocs, T_locs, T_weights, &
                                                    Sub_tlocs, Sub_plocs

REAL(KIND = idp)                                ::  deltasubt, deltasubp, deltat, deltap

COMPLEX(KIND = idp)                             :: TMP_VALUE

T_SUB_ELEMENTS = 32
P_SUB_ELEMENTS = 32

T_Degree = 5
P_Degree = 5

ALLOCATE(P_xlocs(0:P_Degree), P_locs(0:P_Degree), P_weights(0:P_Degree))
ALLOCATE(T_xlocs(0:T_Degree), T_locs(0:T_Degree), T_weights(0:T_Degree))
ALLOCATE(Sub_tlocs(0:T_SUB_ELEMENTS),Sub_plocs(0:P_SUB_ELEMENTS))

CALL Initialize_LGL_Quadrature(P_Degree, P_xlocs, P_weights)
CALL Initialize_LGL_Quadrature(T_Degree, T_xlocs, T_weights)

deltasubt = (pi)/REAL(T_SUB_ELEMENTS)
deltasubp = (2*pi)/REAL(P_SUB_ELEMENTS)

DO te = 0, T_SUB_ELEMENTS
    Sub_tlocs(te) = 0.0_idp + te*deltasubt
END DO

DO pe = 0,P_SUB_ELEMENTS
    Sub_plocs(pe) = 0.0_idp + pe*deltasubp
END DO

PRINT*,"L_SPECIFIC, l, M_SPECIFIC, m, Integral Value"
DO l = 0,L_LIMIT
    DO m = -l,l

        TMP_VALUE = 0.0_idp

        DO te = 0, T_SUB_ELEMENTS - 1

            T_locs = Map_From_X_Space(Sub_tlocs(te), Sub_tlocs(te+1), T_xlocs)
            deltat = Sub_tlocs(te+1)-Sub_tlocs(te)

            DO pe = 0, P_SUB_ELEMENTS - 1

                P_locs = Map_From_X_Space(Sub_plocs(pe), Sub_plocs(pe+1), P_xlocs)
                deltap = Sub_plocs(pe+1) - Sub_plocs(pe)

                DO td = 0, T_Degree

                    DO pd = 0, P_Degree

                        TMP_VALUE = TMP_VALUE + T_weights(td)*P_weights(pd)                                             &
                                                * Spherical_Harmonic(L_SPECIFIC, M_SPECIFIC, T_locs(td), P_locs(pd))    & ! Ylm
                                                * POWER(-1.0_idp, M)*Spherical_Harmonic(L, -M, T_locs(td), P_locs(pd))  & ! Ylm* = (-1)^m Yl-m
                                                * sin(T_locs(td))                                                       &
                                                * deltat/2.0_idp*deltap/2.0_idp

                    END DO
                END DO
            END DO
        END DO

        PRINT*, L_SPECIFIC, l, M_SPECIFIC, m, TMP_VALUE

    END DO
END DO

END SUBROUTINE SphericalHarmonic_OrthogonalityTest

END MODULE Additional_Functions_Module


MODULE matrix_maintenance
IMPLICIT NONE
INTEGER, PARAMETER :: COL_WIDTH = 8

CONTAINS
  SUBROUTINE LOAD_MATRIX(filename, arr, r, c, fmt)
  IMPLICIT NONE
  CHARACTER(*), INTENT(IN) :: filename
  REAL, DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: arr
  INTEGER, INTENT(OUT) :: r, c
  CHARACTER(*) :: fmt
  INTEGER :: i, j, status
  CHARACTER(LEN=800) :: line
  CHARACTER(LEN=3) :: col_str

  OPEN (1, FILE=filename, STATUS='OLD', ACTION='READ')
  DO
    READ(1, '(A)', IOSTAT=status) line
    IF (status .lt. 0) THEN
      EXIT
    ELSE
      r = r + 1
    END IF
  END DO
  c = LEN_TRIM(line) / COL_WIDTH

  ! Convert the integer c to a string
  WRITE(col_str, '(I3)') c
  col_str = TRIM(col_str)
  fmt = '(' // col_str // 'F8.1)'

  ALLOCATE(arr(1:r, 1:c))
  REWIND(1)
  READ(1, fmt) ((arr(i, j), j=1, c), i=1, r)
  END SUBROUTINE LOAD_MATRIX
END MODULE matrix_maintenance

PROGRAM matrix_mult
USE matrix_maintenance
IMPLICIT NONE

REAL, ALLOCATABLE, DIMENSION(:,:) :: matrixA, matrixB, matrixC
REAL :: temp
INTEGER :: i, j, k, l, colsA, rowsA, colsB, rowsB
CHARACTER(LEN=9) :: col_fmtA, col_fmtB

rowsA = 0
colsA = 0
CALL LOAD_MATRIX("matrixA.dat", matrixA, rowsA, colsA, col_fmtA)
WRITE(*, *) "MATRIX A:"
WRITE(*, col_fmtA) ((matrixA(i, j), j=1, colsA), i=1, rowsA)

rowsB = 0
colsB = 0
CALL LOAD_MATRIX("matrixB.dat", matrixB, rowsB, colsB, col_fmtB)
WRITE(*, *) "MATRIX B:"
WRITE(*, col_fmtB) ((matrixB(i, j), j=1, colsB), i=1, rowsB)

IF (colsA .eq. rowsB) THEN
  ! Call matrix multiplication function.
  ALLOCATE(matrixC(1:rowsA, 1:colsB))
  DO i = 1, rowsA
    DO j = 1, colsB
      temp = 0
      DO k = 1, colsA
        temp = temp + matrixA(i, k) * matrixB(k, j)
      END DO
      matrixC(i, j) = temp
    END DO
  END DO
END IF

WRITE(*, *) "MATRIX C:"
WRITE(*, '(3F14.3)') ((matrixC(i, j), j = 1, colsB), i = 1, rowsA)
matrixC = 0.
WRITE(*, *) "MATRIX C:"
WRITE(*, '(3F14.3)') ((matrixC(i, j), j = 1, colsB), i = 1, rowsA)
matrixC = MATMUL(matrixA, matrixB)
WRITE(*, *) "MATRIX C:"
WRITE(*, '(3F14.3)') ((matrixC(i, j), j = 1, colsB), i = 1, rowsA)

CLOSE(1)
END PROGRAM matrix_mult


PROGRAM F047

    ! Copyright 2021 Melwyn Francis Carlo
    ! FILE REFERENCE: http://www.naturalnumbers.org/primes.html

    IMPLICIT NONE

    INTEGER, PARAMETER :: MAX_N = 5E5

    INTEGER :: PRIME_NUM
    CHARACTER (LEN=50), PARAMETER :: FILENAME = "problems/003/PrimeNumbers_Upto_1000000"

    INTEGER :: I          = 1
    INTEGER :: MAIN_COUNT = 0

    INTEGER, DIMENSION(INT(MAX_N/10)) :: PRIMES_LIST = 0

    INTEGER :: J, TEMP_I, I_BY_5, SUB_COUNT

    OPEN (2, FILE = FILENAME, STATUS = 'OLD')

    DO
        READ(2, *, END=10) PRIME_NUM
        IF (PRIME_NUM > MAX_N) EXIT
        PRIMES_LIST(I) = PRIME_NUM
        I = I + 1
    END DO

    10 CLOSE(2)

    DO I = 1000, MAX_N

        J         = 1
        TEMP_I    = I
        I_BY_5    = INT(I / 5)
        SUB_COUNT = 0

        DO WHILE (PRIMES_LIST(J) < I_BY_5)

            IF (MOD(TEMP_I, PRIMES_LIST(J)) /= 0) THEN
               J = J + 1
               CYCLE
            END IF

            DO WHILE (MOD(TEMP_I, PRIMES_LIST(J)) == 0)
                TEMP_I = TEMP_I / PRIMES_LIST(J)
            END DO

            SUB_COUNT = SUB_COUNT + 1

            IF (SUB_COUNT == 4) EXIT

            J = J + 1

        END DO

        IF (SUB_COUNT /= 4) THEN
            MAIN_COUNT = 0
            CYCLE
        END IF

        MAIN_COUNT = MAIN_COUNT + 1

        IF (MAIN_COUNT == 4) EXIT

    END DO

    PRINT ('(I0)'), I - 3

END PROGRAM F047


FUNCTION SETSTVEL(D,SSG)

  ! **  NONCOHEASIVE SEDIMENT SETTLING AND SHIELDS CRITERIA
  ! **  USING VAN RIJN'S EQUATIONS

  ! CHANGE RECORD

  IMPLICIT NONE

  REAL :: SETSTVEL,D,SSG,VISC,GP,GPD,SQGPD,RD,WSET,TMP

  VISC=1.D-6
  GP=(SSG-1.)*9.82
  GPD=GP*D
  SQGPD=SQRT(GPD)
  RD=SQGPD*D/VISC

  ! **  SETTLING VELOCITY

  IF( D < 1.0E-4 )THEN
    WSET=SQGPD*RD/18.
  ENDIF
  IF( D >= 1.0E-4 .AND. D < 1.E-3 )THEN
    TMP=SQRT(1.+0.01*RD*RD)-1.
    WSET=10.0*SQGPD*TMP/RD
  ENDIF
  IF( D >= 1.E-3 )THEN
    WSET=1.1*SQGPD
  ENDIF
  SETSTVEL=WSET

END FUNCTION


MODULE NORM_MOD

!  The Norm Module contains the function Norm, which returns a random number
!    (deviate) drawn from a normal distribution with zero mean and unit
!    variance (i.e., standard deviation = 1).
!
!  Created by:            Elizabeth North
!  Modified by:           Zachary Schlag
!  Created on:            22 Aug 2008
!  Last Modified on:         Feb 2011

IMPLICIT NONE
PUBLIC

CONTAINS

! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! ~~                                                               ~~
! ~~                       FUNCTION norm                           ~~
! ~~                                                               ~~
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  DOUBLE PRECISION FUNCTION norm()
    ! This function returns a normally distributed deviate with
    !   zero mean and unit variance (i.e., standard deviation = 1).
    !   By E. North, 8/22/08
    USE PARAM_MOD,  ONLY: PI
    USE RANDOM_MOD, ONLY: genrand_real3
    IMPLICIT NONE

    DOUBLE PRECISION :: dev1,dev2

    dev1 = genrand_real3()
    dev2 = genrand_real3()
    norm = sqrt(DBLE(-2.)*log(dev1)) * cos(DBLE(2.)*PI*dev2)

  END FUNCTION norm

END MODULE NORM_MOD


program main
  implicit none

  integer, parameter :: d = 1  ! Number of inputs
  integer, parameter :: k = 1  ! Number of outputs
  integer, parameter :: h = 8  ! Number of hidden nodes
  integer, parameter :: n = 64  ! Training data counts
  integer, parameter :: epochs = 1000  ! Iteration of training
  real(8), parameter :: learn_rate = 0.03

  type type_weights
    real(8) :: w1(h, d), w2(k, h), b1(h), b2(k)
  end type type_weights

  call training()

  contains

  subroutine training()
    ! Main subroutine
    integer :: itr, i
    real(8) :: train_x(d, n), train_y(k, n)
    real(8) :: loss, y(k), diff(k)
    type(type_weights) :: weights
    call get_initial_weights(weights)
    call get_training_data(train_x, train_y)
    do itr = 1, epochs
      loss = 0.0
      do i = 1, n  ! Todo: shuffled order
        y = forward(train_x(:, i), weights)
        diff = y - train_y(:, i)
        loss = loss + sum(diff ** 2)
        call backward(train_x(:, i), weights, diff)
      end do
      print *, loss  ! Decays to zero
    end do
  end subroutine training

  pure function activation(a)
    ! Hyperbolic tangent activation function
    real(8), intent(in) :: a(h)
    real(8) :: activation(h)
    activation = tanh(a)
  end function activation

  pure function activation_prime(a)
    ! Derivative of the activation function
    real(8), intent(in) :: a(h)
    real(8) :: activation_prime(h)
    activation_prime = cosh(a) ** (-2)
  end function activation_prime

  pure function forward(x, w)
    ! Forward evaluation of neural network
    real(8), intent(in) :: x(d)
    type(type_weights), intent(in) :: w
    real(8) :: forward(k)
    forward = matmul(w%w2, activation(matmul(w%w1, x) + w%b1)) + w%b2
  end function forward

  subroutine backward(x, w, diff)
    ! Calculate derivative of loss function in weight space and gradient descent
    real(8), intent(in) :: x(d), diff(k)
    type(type_weights), intent(inout) :: w
    real(8) :: v1(h), v2(h)
    v1 = matmul(diff, w%w2) * activation_prime(matmul(w%w1, x) + w%b1)
    v2 = activation(matmul(w%w1, x) + w%b1)
    w%w1 = w%w1 - learn_rate * matmul(reshape(v1, (/h, 1/)), reshape(x, (/1, d/)))
    w%b1 = w%b1 - learn_rate * v1
    w%w2 = w%w2 - learn_rate * matmul(reshape(diff, (/k, 1/)), reshape(v2, (/1, h/)))
    w%b2 = w%b2 - learn_rate * diff
  end subroutine backward

  subroutine get_training_data(train_x, train_y)
    ! Training data is y = 2 x^2 - 1
    real(8), intent(out) :: train_x(d, n), train_y(k, n)
    integer :: i
    if ((d /= 1) .or. (k /= 1)) then
      print *, "Shape mismatch. Stop."
      stop 3
    end if
    do i = 1, n
      train_x(1, i) = -1.0 + (2.0 * i / n)
      train_y(1, i) = 2 * train_x(1, i) ** 2 - 1
    end do
  end subroutine get_training_data

  subroutine get_initial_weights(res)
    ! Randomly initialize weights
    type(type_weights), intent(out) :: res
    integer :: seed(100)
    seed(:) = 0
    call random_seed(put=seed)
    call random_number(res%w1)
    call random_number(res%w2)
    call random_number(res%b1)
    call random_number(res%b2)
    res%w1 = res%w1 - 0.5
    res%w2 = res%w2 - 0.5
    res%b1 = res%b1 - 0.5
    res%b2 = res%b2 - 0.5
  end subroutine get_initial_weights
end program main


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(scalar_laplacian_routines) scalar_laplacian_gaussian_grid

contains
    !     subroutine slapgc(nlat, nlon, isym, nt, slap, ids, jds, a, b, &
    !                       mdab, ndab, wshsgc, ierror)
    !
    !
    !     given the scalar spherical harmonic coefficients a and b, precomputed
    !     by subroutine shagc for a scalar field sf, subroutine slapgc computes
    !     the laplacian of sf in the scalar array slap.  slap(i, j) is the
    !     laplacian of sf at the gaussian colatitude theta(i) (see nlat as
    !     an input parameter) and east longitude lambda(j) = (j-1)*2*pi/nlon
    !     on the sphere.  i.e.
    !
    !         slap(i, j) =
    !
    !                  2                2
    !         [1/sint*d (sf(i, j)/dlambda + d(sint*d(sf(i, j))/dtheta)/dtheta]/sint
    !
    !
    !     where sint = sin(theta(i)).  the scalar laplacian in slap has the
    !     same symmetry or absence of symmetry about the equator as the scalar
    !     field sf.  the input parameters isym, nt, mdab, ndab must have the
    !     same values used by shagc to compute a and b for sf. the associated
    !     legendre functions are stored rather than recomputed as they are
    !     in subroutine slapgc.
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are computed
    !            in radians in theta(1) <...< theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid point
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct longitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than zero. the axisymmetric case corresponds to nlon=1.
    !            the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !     isym   this parameter should have the same value input to subroutine
    !            shagc to compute the coefficients a and b for the scalar field
    !            sf.  isym is set as follows:
    !
    !            = 0  no symmetries exist in sf about the equator. scalar
    !                 synthesis is used to compute slap on the entire sphere.
    !                 i.e., in the array slap(i, j) for i=1, ..., nlat and
    !                 j=1, ..., nlon.
    !
    !           = 1  sf and slap are antisymmetric about the equator. the
    !                synthesis used to compute slap is performed on the
    !                northern hemisphere only.  if nlat is odd, slap(i, j) is
    !                computed for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if
    !                nlat is even, slap(i, j) is computed for i=1, ..., nlat/2
    !                and j=1, ..., nlon.
    !
    !
    !           = 2  sf and slap are symmetric about the equator. the
    !                synthesis used to compute slap is performed on the
    !                northern hemisphere only.  if nlat is odd, slap(i, j) is
    !                computed for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.  if
    !                nlat is even, slap(i, j) is computed for i=1, ..., nlat/2
    !                and j=1, ..., nlon.
    !
    !
    !     nt     the number of analyses.  in the program that calls slapgc
    !            the arrays slap, a, and b can be three dimensional in which
    !            case multiple synthesis will be performed.  the third index
    !            is the synthesis index which assumes the values k=1, ..., nt.
    !            for a single analysis set nt=1. the description of the
    !            remaining parameters is simplified by assuming that nt=1
    !            or that all the arrays are two dimensional.
    !
    !   ids      the first dimension of the array slap as it appears in the
    !            program that calls slapgc.  if isym = 0 then ids must be at
    !            least nlat.  if isym > 0 and nlat is even then ids must be
    !            at least nlat/2. if isym > 0 and nlat is odd then ids must
    !            be at least (nlat + 1)/2.
    !
    !   jds      the second dimension of the array slap as it appears in the
    !            program that calls slapgc. jds must be at least nlon.
    !
    !
    !   a, b      two or three dimensional arrays (see input parameter nt)
    !            that contain scalar spherical harmonic coefficients
    !            of the scalar field sf as computed by subroutine shagc.
    !     ***    a, b must be computed by shagc prior to calling slapgc.
    !
    !
    !    mdab    the first dimension of the arrays a and b as it appears
    !            in the program that calls slapgc.  mdab must be at
    !            least min(nlat, (nlon+2)/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !    ndab    the second dimension of the arrays a and b as it appears
    !            in the program that calls slapgc. ndbc must be at least
    !            least nlat.
    !
    !            mdab, ndab should have the same values input to shagc to
    !            compute the coefficients a and b.
    !
    !
    !    wshsgc  an array which must be initialized by subroutine shsgci.
    !            once initialized, wshsgc
    !            can be used repeatedly by slapgc as long as nlat and nlon
    !            remain unchanged.  wshsgc must not be altered between calls
    !            of slapgc.
    !
    !    lshsgc  the dimension of the array wshsgc as it appears in the
    !            program that calls slapgc.  let
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshsgc must be at least
    !
    !               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
    !
    !     output parameters
    !
    !
    !    slap    a two or three dimensional arrays (see input parameter nt) that
    !            contain the scalar laplacian of the scalar field sf.  slap(i, j)
    !            is the scalar laplacian at the gaussian colatitude theta(i)
    !            and longitude lambda(j) = (j-1)*2*pi/nlon for i=1, ..., nlat
    !            and j=1, ..., nlon.
    !
    !
    !  ierror    a parameter which flags errors in input parameters as follows:
    !
    !            = 0  no errors detected
    !
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of ids
    !            = 6  error in the specification of jds
    !            = 7  error in the specification of mdab
    !            = 8  error in the specification of ndab
    !            = 9  error in the specification of lshsgc
    !
    module subroutine slapgc(nlat, nlon, isym, nt, slap, ids, jds, a, b, &
        mdab, ndab, wshsgc, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: slap(ids, jds, nt)
        integer(ip), intent(in)  :: ids
        integer(ip), intent(in)  :: jds
        real(wp),    intent(in)  :: a(mdab, ndab, nt)
        real(wp),    intent(in)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wshsgc(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip)                  :: required_wavetable_size
        type(ScalarSynthesisUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lshsgc(nlat, nlon)

        call util%check_scalar_transform_inputs(isym, ids, jds, &
            mdab, ndab, nlat, nlon, nt, required_wavetable_size, &
            wshsgc, ierror)

        ! Check error flag
        if (ierror /= 0) return

        call scalar_laplacian_lower_utility_routine(nlat, nlon, isym, nt, slap, &
            a, b, wshsgc, shsgc, ierror)

    end subroutine slapgc

end submodule scalar_laplacian_gaussian_grid


c=======================================================================
c
c     subroutine PESBM
c
c     Simulation of a Standard Brownian Motion
c
c                dSt = mu*dt + sigma*dWt
c
c     Method: Euler discretization of SDE
c
c                S(1)    = S
c                S(1+t)  = S(t) + mu*dt +  sigma*sqrt(dt)*N(0,1)
c
c                with dt = T/(N-1)
c
c-----------------------------------------------------------------------
c
c     INPUT :
c            T      : time (days, months, years)                 integer
c            N      : number of sub-division(s)                  integer
c            S      : initial value                               double
c            mu     : process drifts                              double
c            sigma  : process volatility                          double
c
c     OUTPUT :
c            y      : generated process (N)                       double
c            info   : diagnostic information                     integer
c
c-----------------------------------------------------------------------
c
      SUBROUTINE pesbm ( T, N, S, mu, sigma, y, info )
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER T, N, info
      DOUBLE PRECISION S, mu, sigma, y(*)
c
c     local variables
      INTEGER i, M
      DOUBLE PRECISION dt
c
c     external functions
      DOUBLE PRECISION rn
      EXTERNAL rn
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     discetization step
      M = N - 1
      dt = (dfloat(T)/M)
c
c     standard Brownian motion
      y(1) = S
      DO i = 1,M
         y(i + 1) = y(i) + mu*dt + sigma* SQRT(dt) * rn()
      ENDDO
c
      RETURN
      END


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

    implicit none

    ! model parameters
    real*8, parameter :: gamma = 0.50d0
    real*8, parameter :: beta = 0.96d0
    real*8, parameter :: alpha = 0.36d0
    real*8, parameter :: delta = 0.08d0
    real*8, parameter :: rho = 0.6d0
    real*8, parameter :: sigma_eps = 0.04d0*(1d0-rho**2)

    ! numerical parameters
    real*8, parameter :: a_l = 0d0
    real*8, parameter :: a_u = 100d0
    real*8, parameter :: a_grow = 0.01d0
    real*8, parameter :: sig_in = 1d-10
    real*8, parameter :: sig_out = 1d-6
    integer, parameter :: itermax = 50000

    ! macroeconomic variables
    real*8 :: r, w, KK, AA, LL, YY, CC, II

    ! the shock process
    integer, parameter :: NS = 7
    real*8 :: pi(NS, NS), eta(NS), weights(NS)

    ! policy and value function
    integer, parameter :: NA = 1000
    real*8 :: a(0:NA), c(0:NA, NS), V(0:NA, NS)

    ! variables to numerically determine policy function
    real*8 :: c_new(0:NA, NS), RHS(0:NA, NS)
    logical :: check

    ! variables to communicate with function
    real*8 :: a_com
    integer :: is_com

    ! simulated path of consumption and savings
    integer, parameter :: TT = 100000
    real*8 :: c_t(-5000:TT), a_t(-5000:TT), eta_t(-5000:TT)
    integer :: is_t(-5000:TT)

contains

    ! calculate the difference on the asset market given an interest rate
    function asset_market(r_input)

        implicit none
        real*8, intent(in) :: r_input
        real*8 :: asset_market

        ! set the interest rate
        r = r_input

        ! calculate the corresponding capital stock
        KK = (alpha/(r+delta))**(1d0/(1d0-alpha))*LL

        ! get wages and output
        w = (1d0-alpha)*(KK/LL)**alpha
        YY = KK**alpha*LL**(1d0-alpha)

        ! solve the household value function iteration problem
        call solve_household()

        ! simulate an asset and consumption path
        call simulate_path()

        ! get aggregate assets
        AA = sum(a_t(0:TT))/dble(TT+1)

        ! get the difference between asset demand and supply
        asset_market = (AA - KK)/AA

        write(*,'(2f10.4,f12.8)')KK/YY*100d0, r*100d0, AA-KK

    end function

    ! determines the solution to the household optimization problem
    subroutine solve_household()

        use toolbox

        implicit none
        integer :: ia, is, iter
        real*8 :: con_lev, x_in

        ! set tolerance level for interior optimization
        call settol_root(sig_in)

        ! do a policy function iteration with rootfinding
        do iter = 1, itermax

            ! interpolate coefficients
            call interpolate()

            ! solve the household problem for all gridpoints
            do ia = 0, NA
                do is = 1, NS

                    ! initialize starting value and communication variables
                    x_in = c(ia, is)
                    a_com = a(ia)
                    is_com = is

                    ! find the optimal consumption level
                    call fzero(x_in, foc, check)
                    if(check)write(*,*)'ERROR IN ROOTFINDING PROCESS'

                    ! check for borrowing constraint
                    if(x_in > (1d0+r)*a_com+w*eta(is_com) - a_l) &
                       x_in = (1d0+r)*a_com+w*eta(is_com) - a_l

                    ! get optimal consumption and value function
                    c_new(ia, is) = x_in

                enddo
            enddo

            ! get convergence level
            con_lev = maxval(abs(c_new(:, :) - c(:, :))/max(abs(c(:, :)), 1d-10))

            ! check for convergence
            if(con_lev < sig_in)then
                return
            endif

            c = c_new
        enddo

        write(*,*)'Policy Function Iteration did not converge'

    end subroutine

    ! the first order condition
    function foc(x_in)

        use toolbox

        implicit none
        real*8, intent(in) :: x_in
        real*8 :: foc, aplus, varphi
        integer :: ial, iar

        ! future assets
        aplus = (1d0+r)*a_com + w*eta(is_com) - x_in

        ! calculate future expected marginal utility
        call linint_Grow(aplus, a_l, a_u, a_grow, NA, ial, iar, varphi)
        foc = varphi*RHS(ial,is_com) + (1d0-varphi)*RHS(iar,is_com)

        ! get first order condition
        foc = x_in - foc

    end function

    ! Set up data for interpolation
    subroutine interpolate()

        implicit none
        integer :: is, ia, is_p

        do is = 1, NS
            do ia = 0, NA

                ! calculate the RHS of the first order condition
                RHS(ia, is) = 0d0
                do is_p = 1, NS
                    RHS(ia, is) = RHS(ia, is) + pi(is, is_p)*c_new(ia, is_p)**(-1d0/gamma)
                enddo
                RHS(ia, is) = (beta*(1d0+r)*RHS(ia, is))**(-gamma)
            enddo

        enddo

    end subroutine

    ! simulates household path through time
    subroutine simulate_path()

        use toolbox

        implicit none
        integer :: it, ial, iar
        real*8 :: varphi

        ! initialize variables
        eta_t(-5000) = eta(is_t(-5000))
        a_t(-5000) = 1d0
        call linint_Grow(a_t(-5000), a_l, a_u, a_grow, NA, ial, iar, varphi)
        c_t(-5000) = varphi*c(ial, is_t(-5000)) + (1d0-varphi)*c(iar, is_t(-5000))

        ! calculate the time path of all economic variables
        do it = -4999, TT
            eta_t(it) = eta(is_t(it))
            a_t(it) = min(w*eta_t(it-1) + (1d0+r)*a_t(it-1) - c_t(it-1), a_u)
            call linint_Grow(a_t(it), a_l, a_u, a_grow, NA, ial, iar, varphi)
            c_t(it) = varphi*c(ial, is_t(it)) + (1d0-varphi)*c(iar, is_t(it))
        enddo

    end subroutine

end module


module parameters
    integer, parameter :: latt_leng = 30
    integer, parameter :: EXCH_CONST = 1 ! exchange constant
    integer, parameter :: n_T_step = 500
    double precision, parameter :: T_start = 0.5d0
    double precision, parameter :: T_end = 3.5d0
    integer, dimension(-1 : latt_leng, -1 : latt_leng) :: spin_of ! (-1 ... latt_leng) X (-1 ... latt_leng)
end module

program Tc_calculate
    use parameters
    implicit none
    integer i
    double precision, dimension(0 : n_T_step):: M
    double precision, dimension(0 : n_T_step):: Cv
    double precision, dimension(0 : n_T_step):: E
    double precision :: T, Tc_E, Tc_M, Tc_Cv

    open (unit=15, file='output_ising_model_avg_E_change_plot_5.txt', status='old',    &
             access='sequential', form='formatted', action='read' )
    open (unit=20, file='output_ising_model_avg_M_change_plot_5.txt', status='old',    &
             access='sequential', form='formatted', action='read' )
    open (unit=25, file='output_ising_model_avg_Cv_change_plot_5.txt', status='old',    &
             access='sequential', form='formatted', action='read' )

    do i = 0, n_T_step
        read (15, *) T, E(i)
        read (20, *) T, M(i)
        read (25, *) T, Cv(i)
    end do

    call compute_Tc_with_E_or_M(E, Tc_E)
    call compute_Tc_with_E_or_M(M, Tc_M)
    call compute_Tc_with_Cv(Cv, Tc_Cv)
    print *, "Tc_E = ", Tc_E
    print *, "Tc_M = ", Tc_M
    print *, "Tc_Cv = ", Tc_Cv
    close(15)
    close(20)
    close(25)
end program

subroutine compute_Tc_with_E_or_M(phys_obsv, Tc) ! Compute Tc by calculating T where dp_q / dT is max.
    use parameters
    integer :: T_step
    double precision :: max_slope, slope, del_T, T
    double precision, intent(out) :: Tc
    double precision, dimension(0 : n_T_step), intent(in) :: phys_obsv

    max_slope = 0d0
    slope = 0d0
    del_T = (T_end - T_start) / n_T_step
    do T_step = 0, n_T_step - 1
        T = T_start + del_T * T_step
        slope = (phys_obsv(T_step + 1) - phys_obsv(T_step)) / del_T
        if (slope > max_slope) then
            max_slope = slope
            Tc = T + 0.5*del_T
        end if
    end do
end subroutine
subroutine compute_Tc_with_Cv(Cv, Tc)
    use parameters
    integer :: T_step
    double precision :: max_value, del_T, T
    double precision, intent(out) :: Tc
    double precision, dimension(0 : n_T_step), intent(in) :: Cv

    max_value = 0d0
    del_T = (T_end - T_start) / n_T_step
    do T_step = 0, n_T_step
        T = T_start + del_T * T_step
        if (Cv(T_step) > max_value) then
            max_value = Cv(T_step)
            Tc = T
        end if
    end do
end subroutine


          program demo_decodebase
          use M_strings, only : codebase, decodebase
          implicit none
          integer           :: ba,bd
          character(len=40) :: x,y
          integer           :: r

          print *,' BASE CONVERSION'
          write(*,'("Start   Base (2 to 36): ")',advance='no'); read *, bd
          write(*,'("Arrival Base (2 to 36): ")',advance='no'); read *, ba
          INFINITE: do
             print *,''
             write(*,'("Enter number in start base: ")',advance='no'); read *, x
             if(x.eq.'0') exit INFINITE
             if(decodebase(x,bd,r)) then
                if(codebase(r,ba,y)) then
                  write(*,'("In base ",I2,": ",A20)')  ba, y
                else
                  print *,'Error in coding number.'
                endif
             else
                print *,'Error in decoding number.'
             endif
          enddo INFINITE

          end program demo_decodebase


MODULE FUN_xyCOLINEAR
!!#### PURPOSE
!! Test for colinearity between:
!! @ three points in R^2 <P3>
!! @ a line and a point in R^2 <LnP>

!!#### DETAILS
!! Collinear is the most common spelling but I don"t know where the
!! extra "l" comes from so I"m not using it.

!!#### METHOD
!! For three points to be colinear, the following ratios must be equal:
!!       x2-x1:y2-y1 = x3-x1:y3-y1
!! where the three points being tested are (x1,y1), (x2,y2), and (x3,y3).

!!#### SOURCE
!! Eric W. Weisstein. "Collinear." From MathWorld--A Wolfram Web Resource. http://mathworld.wolfram.com/Collinear.html

!We will check to see that the following fraction is equal.
!
!! x2-x1   x3-x1
!! ----- = -----
!! y2-y1   y3-y1

!!#### DEPENDENCIES
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp                   !!((01-A-KND_IntrinsicTypes.f90))
USE FUN_Default                                                  !!((04-A-FUN_Default.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyCOLINEAR_P3
 MODULE PROCEDURE xyCOLINEAR_P3_Rsp
 MODULE PROCEDURE xyCOLINEAR_P3_Rdp
END INTERFACE

INTERFACE xyCOLINEAR_LnP
 MODULE PROCEDURE xyCOLINEAR_LnP_Rsp
 MODULE PROCEDURE xyCOLINEAR_LnP_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyCOLINEAR_P3
PUBLIC :: xyCOLINEAR_LnP

CONTAINS

FUNCTION xyCOLINEAR_P3_Rsp( P3 , tol , err ) RESULT(COLINEAR)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes       ,ONLY: KIND_R=>KIND_Rsp             !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rsp        ,ONLY: c_1                          !!((02-A-PAR_Constants_Rsp.f90))
USE VAR_ComputationalGeometry,ONLY: DEFAULT_tol=>DEFAULT_tol_Rsp !!((03-A-VAR_ComputationalGeometry.f90))
INCLUDE "05-B-FUN_xyCOLINEAR_P3.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyCOLINEAR_P3.f90.alg"
!!--end--
END FUNCTION

FUNCTION xyCOLINEAR_P3_Rdp( P3 , tol , err ) RESULT(COLINEAR)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes       ,ONLY: KIND_R=>KIND_Rdp             !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp        ,ONLY: c_1                          !!((02-A-PAR_Constants_Rdp.f90))
USE VAR_ComputationalGeometry,ONLY: DEFAULT_tol=>DEFAULT_tol_Rdp !!((03-A-VAR_ComputationalGeometry.f90))
INCLUDE "05-B-FUN_xyCOLINEAR_P3.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyCOLINEAR_P3.f90.alg"
!!--end--
END FUNCTION

FUNCTION xyCOLINEAR_LnP_Rsp( Ln , P , tol , err ) RESULT(COLINEAR)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes       ,ONLY: KIND_R=>KIND_Rsp             !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rsp        ,ONLY: c_1                          !!((02-A-PAR_Constants_Rsp.f90))
USE VAR_ComputationalGeometry,ONLY: DEFAULT_tol=>DEFAULT_tol_Rsp !!((03-A-VAR_ComputationalGeometry.f90))
INCLUDE "05-B-FUN_xyCOLINEAR_LnP.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyCOLINEAR_LnP.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyCOLINEAR_LnP_Rdp( Ln , P , tol , err ) RESULT(COLINEAR)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes       ,ONLY: KIND_R=>KIND_Rdp             !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp        ,ONLY: c_1                          !!((02-A-PAR_Constants_Rdp.f90))
USE VAR_ComputationalGeometry,ONLY: DEFAULT_tol=>DEFAULT_tol_Rdp !!((03-A-VAR_ComputationalGeometry.f90))
INCLUDE "05-B-FUN_xyCOLINEAR_LnP.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyCOLINEAR_LnP.f90.bdy"
!!--end--
END FUNCTION

FUNCTION TEST_xyCOLINEAR_LnP() RESULT(Pass)
LOGICAL :: Pass
Pass = .TRUE.

END FUNCTION

END MODULE


Program Task1
IMPLICIT NONE
! p 'Results.dat' u 1:2 w l, '' u 1:3 w l

REAL, Dimension(:), Allocatable:: Time, Mass, MassExact, MassError
REAL:: h, MassDash, LargestError
INTEGER:: I, npts

npts=300

Allocate(Time(0:npts), Mass(0:npts), MassExact(0:npts), MassError(0:npts))

Mass(0)=0.1; Time(0)=0.0; h=0.1 !Setting intial boundary conditions

OPEN(10, FILE='Results.dat')

DO i=1,npts

  Time(i)=Time(i-1)+h
  MassDash=-0.3*Mass(i-1)
  Mass(i)=Mass(i-1)+h*MassDash

  MassExact(i)=0.1*exp(-0.3*Time(i))

  MassError(i) = ABS(MassExact(i)-Mass(i))

  WRITE(10,'(f9.5, f9.5, f9.5, f9.5)') Time(i), Mass(i), MassExact(i), MassError(i)

END DO

LargestError = MAXVAL(MassError)

WRITE(6,*) 'Largest absolute difference between exact and apporximated mass is:',LargestError

CLOSE(10)

DEALLOCATE(Time, Mass, MassExact)

END PROGRAM


double precision function true_solution(x, y, t)

! True solution for the porous medium equation,
!     q_t = (q**2)_xx.

    double precision :: x, y, t
    double precision :: mass, tau, t0
    parameter(mass = 1.d0)
    parameter(t0 = .3d0)

    tau = t + t0
    true_solution = (mass - 1.d0/16.d0 * (x**2 + y**2) / sqrt(tau)) / sqrt(tau)
    if (true_solution < 0.d0) true_solution = 0.d0
end function true_solution


!
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
! *                                                               *
! *                  copyright (c) 2005 by UCAR                   *
! *                                                               *
! *       University Corporation for Atmospheric Research         *
! *                                                               *
! *                      all rights reserved                      *
! *                                                               *
! *                         Fishpack                              *
! *                                                               *
! *                      A Package of Fortran                     *
! *                                                               *
! *                Subroutines and Example Programs               *
! *                                                               *
! *               for Modeling Geophysical Processes              *
! *                                                               *
! *                             by                                *
! *                                                               *
! *        John Adams, Paul Swarztrauber and Roland Sweet         *
! *                                                               *
! *                             of                                *
! *                                                               *
! *         the National Center for Atmospheric Research          *
! *                                                               *
! *                Boulder, Colorado  (80307)  U.S.A.             *
! *                                                               *
! *                   which is sponsored by                       *
! *                                                               *
! *              the National Science Foundation                  *
! *                                                               *
! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
! Purpose:
!
! To illustrate the use of subroutine blktri to
! solve the equation
!
! 0.5/s*(d/ds)(0.5/s*du/ds)+0.5/t*(d/dt)(0.5/t*du/dt)
!                                                      (1)
!               = 15/4*s*t*(s**4+t**4)
!
! on the rectangle 0 < s < 1 and 0 < t < 1
! with the boundary conditions
!
! u(0, t) = 0
!                        0 <= t <= 1
! u(1, t) = t**5
!
! and
!
! u(s, 0) = 0
!                        0 <= s <= 1
! u(s, 1) = s**5
!
! the exact solution of this problem is u(s, t) = (s*t)**5
!
! define the integers m = 50 and n = 63. then define the
! grid increments deltas = 1/(m+1) and deltat = 1/(n+1).
!
! the grid is then given by s(i) = i*deltas for i = 1, ..., m
! and t(j) = j*deltat for j = 1, ..., n.
!
! the approximate solution is given as the solution to
! the following finite difference approximation of equation (1).
!
! .5/(s(i)*deltas)*((u(i+1, j)-u(i, j))/(2*s(i+.5)*deltas)
!                 -(u(i, j)-u(i-1, j))/(2*s(i-.5)*deltas))
! +.5/(t(i)*deltat)*((u(i, j+1)-u(i, j))/(2*t(i+.5)*deltat) (2)
!                 -(u(i, j)-u(i, j-1))/(2*t(i-.5)*deltat))
!           = 15/4*s(i)*t(j)*(s(i)**4+t(j)**4)
!
!         where s(i+.5) = .5*(s(i+1)+s(i))
!               s(i-.5) = .5*(s(i)+s(i-1))
!               t(i+.5) = .5*(t(i+1)+t(i))
!               t(i-.5) = .5*(t(i)+t(i-1))
!
! the approach is to write equation (2) in the form
!
! am(i)*u(i-1, j)+bm(i, j)*u(i, j)+cm(i)*u(i+1, j)
!   +an(j)*u(i, j-1)+bn(j)*u(i, j)+cn(j)*u(i, j+1)      (3)
!       = y(i, j)
!
! and then call subroutine blktri to determine u(i, j)
!
program test_blktri

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    type(FishpackWorkspace)    :: workspace
    integer(ip), parameter     :: M = 50, N = 63
    integer(ip), parameter     :: IDIMY = 75, NT = 105
    integer(ip)                :: iflg, np, mp, i, j, ierror
    real(wp)                   :: y(IDIMY, NT)
    real(wp), dimension(IDIMY) :: am, bm, cm, s
    real(wp), dimension(NT)    :: an, bn, cn, t
    real(wp)                   :: ds, dt
    real(wp), parameter        :: ONE = 1.0_wp, TWO = 2.0_wp

    ! Set boundary conditions
    np = 1
    mp = 1

    ! Set mesh sizes
    ds = ONE/(M + 1)
    dt = ONE/(N + 1)

    ! Generate and store grid points for the purpose of computing the
    ! coefficients and the array y.
    do i = 1, M
        s(i) = real(i, kind=wp) * ds
    end do

    do j = 1, N
        t(j) = real(j, kind=wp) * dt
    end do

    ! Compute the coefficients am, bm, cm corresponding to the s direction
    block
        real(wp) :: half_ds, two_ds
        real(wp) :: temp1, temp2, temp3

        half_ds = ds/2
        two_ds = TWO * ds

        do i = 1, M
            temp1 = ONE/(s(i) * two_ds)
            temp2 = ONE/((s(i) - half_ds) * two_ds)
            temp3 = ONE/((s(i) + half_ds) * two_ds)
            am(i) = temp1 * temp2
            cm(i) = temp1 * temp3
            bm(i) = -(am(i) + cm(i))
        end do
    end block

    ! Compute the coefficients an, bn, cn corresponding to the t direction
    block
        real(wp) :: half_dt, two_dt
        real(wp) :: temp1, temp2, temp3

        half_dt = dt/2
        two_dt = TWO * dt

        do j = 1, N
            temp1 = ONE / (t(j) * two_dt)
            temp2 = ONE / ((t(j)-half_dt) * two_dt)
            temp3 = ONE / ((t(j)+half_dt) * two_dt)
            an(j) = temp1 * temp2
            cn(j) = temp1 * temp3
            bn(j) = -(an(j) + cn(j))
        end do
    end block

    ! Compute right hand side of equation
    do j = 1, n
        y(:M, j) = 3.75_wp * s(:M) * t(j) * (s(:M)**4 + t(j)**4)
    end do

    ! The nonzero boundary conditions enter the linear system via
    ! the right side y(i, j). if the equations (3) given above
    ! are evaluated at i=m and j=1, ..., n then the term cm(m)*u(m+1, j)
    ! is known from the boundary condition to be cm(m)*t(j)**5.
    ! therefore this term can be included in the right side y(m, j).
    ! the same analysis applies at j=n and i=1, .., m. note that the
    ! corner at j=n, i=m includes contributions from both boundaries.
    y(M,:N) = y(M,:N) - cm(M) * (t(:N)**5)
    y(:M,N) = y(:M,N) - cn(N) * (s(:M)**5)

    ! Initialize workspace and lower solver routines
    iflg = 0
    call blktri(iflg, np, N, an, bn, cn, mp, M, am, bm, cm, IDIMY, y, ierror, workspace)

    iflg = iflg + 1
    do while (iflg <= 1)

        ! Solve real block tridiagonal linear system
        call blktri(iflg, np, N, an, bn, cn, mp, M, am, bm, cm, IDIMY, &
            y, ierror, workspace)

        iflg = iflg + 1 ! Increment flag
    end do

    ! Compute discretization error. The exact solution is
    !
    ! u(s,t) = (st)**5
    block
        real(wp), parameter :: KNOWN_ERROR = 0.164778571363905e-4_wp
        real(wp) :: discretization_error
        real(wp) :: exact_solution(M, N)

        do j = 1, N
            do i = 1, M
                exact_solution(i,j) = (s(i)*t(j))**5
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution-y(:M,:N)))

        call check_output('blktri', ierror, KNOWN_ERROR, discretization_error)
    end block

    ! Release memory
    call workspace%destroy()

end program test_blktri


      program phitest
c-------------------------------------------------------------------
c Test program for exponential propagator using Arnoldi approach
c This main program is a very simple test using diagonal matrices
c (Krylov subspace methods are blind to the structure of the matrix
c except for symmetry). This provides a good way of testing the
c accuracy of the method as well as the error estimates. This test
c program tests the phi-function variant instead of the exponential.
c
c The subroutine phipro which is tested here computes an approximation
c to the vector
c
c   	w(tn) = w(t0) + tn *  phi( - A * tn ) * (r - A w(t0))
c
c where phi(z) = (1-exp(z)) / z
c
c i.e. it solves dw/dt = -A w + r in [t0,t0+ tn] (returns only w(t0+tn))
c
c In this program t0=0, tn is input by the user and A is a simple
c diagonal matrix.
c
c-------------------------------------------------------------------
      implicit real*8 (a-h,o-z)
      parameter (nmax = 400, ih0=60, ndmx=20,nzmax = 7*nmax)
      real*8 a(nzmax), u(ih0*nmax), w(nmax),w1(nmax),x(nmax),y(nmax),
     *     r(nmax)
      integer ioff(10)
      data iout/6/,a0/0.0/,b0/1.0/,epsmac/1.d-10/,eps/1.d-10/
c
c     dimendion of matrix
c
      n = 100
c---------------------------define matrix -----------------------------
c     A is a single diagonal matrix (ndiag = 1 and ioff(1) = 0 )
c-----------------------------------------------------------------------
      ndiag = 1
      ioff(1) = 0
c
c     entriesin the diagonal are uniformly distributed.
c
      h = 1.0d0 / real(n+1)
      do 1 j=1, n
         a(j) = real(j+1)*h
 1    continue
c--------
      write (6,'(10hEnter tn: ,$)')
      read (5,*) tn
c
      write (6,'(36hEpsilon (desired relative accuracy): ,$)')
      read (5,*)  eps
c-------
      write (6,'(36h m (= dimension of Krylov subspace): ,$)')
      read (5,*)  m
c
c     define initial conditions to be (1,1,1,1..1)^T
c
      do 2 j=1,n
         w(j) = 1.0 - 1.0/real(j+10)
         r(j) = 1.0
         w1(j) = w(j)
 2    continue
c
c
c     HERE IT IS DONE IN 10 SUBSTEPS
c     nsteps = 10
c     tnh = tn/real(nsteps)
c     MARCHING LOOP
c     do jj =1, nsteps
c     call phiprod (n, m, eps, tnh, u, w, r, x, y, a, ioff, ndiag)
      call phiprod (n, m, eps, tn, u, w, r, x, y, a, ioff, ndiag)
c     enddo
      print *, ' final answer '
      print *, (w(k),k=1,20)
c
c     exact solution
c
      do 4 k=1,n
         w1(k)=w1(k)+((1.0 - dexp(-a(k)*tn) )/a(k))*(r(k)
     +        - a(k)*w1(k) )
 4    continue
c
c     exact solution
c
      print *, ' exact answer '
      print *, (w1(k),k=1,20)
c
c     computing actual 2-norm of error
c
      t = 0.0d0
      do 47 k=1,n
         t = t+ (w1(k)-w(k))**2
 47   continue
      t = dsqrt(t / ddot(n, w,1,w,1) )
c
      write (6,*) ' final error', t
c-----------------------------------------------------------------------
      stop
      end
c-----------------------------------------------------------------------
	subroutine oped(n,x,y,diag,ioff,ndiag)
c======================================================
c this kernel performs a matrix by vector multiplication
c for a diagonally structured  matrix stored in diagonal format
c======================================================
	implicit real*8 (a-h,o-z)
	real*8 x(n), y(n), diag(n,ndiag)
	common nope, nmvec
	integer j, n, ioff(ndiag)
CDIR$ IVDEP
	do 1 j=1, n
		y(j) = 0.00
 1	continue
c
	do 10 j=1,ndiag
	io = ioff(j)
	i1=max0(1,1-io)
	i2=min0(n,n-io)
CDIR$ IVDEP
	do 9 k=i1,i2
	y(k) = y(k)+diag(k,j)*x(k+io)
 9	continue
 10	continue
	nmvec  = nmvec + 1
	nope = nope + 2*ndiag*n
	return
	end
c


      real*8 function fndmnx(vector,ndim,minmax)
c
c     find smallest(minmax=1) or largest(minmax=2)
c     *absolute* value of elements in vector
*     or
c     find smallest(minmax=-1) or largest(minmax=-2)
c     value of elements in vector
c
c     adapted from Jeppe Olsen's version
c
      implicit none
      integer, intent(in) ::
     &     ndim, minmax
      real(8), intent(in) ::
     &     vector(ndim)
      integer ::
     &     i
c
      if(minmax.eq.1) then
        fndmnx=abs(vector(1))
        do i=2,ndim
          fndmnx=min(fndmnx,abs(vector(i)))
        end do
      end if
c
      if(minmax.eq.2) then
        fndmnx=abs(vector(1))
        do i=2,ndim
          fndmnx=max(fndmnx,abs(vector(i)))
        end do
      end if
c
      if(minmax.eq.-1) then
        fndmnx=vector(1)
        do i=2,ndim
          fndmnx=min(fndmnx,vector(i))
        end do
      end if
c
      if(minmax.eq.-2) then
        fndmnx=vector(1)
        do i=2,ndim
          fndmnx=max(fndmnx,vector(i))
        end do
      end if

      return
      end


MODULE Residuo

   CONTAINS

   SUBROUTINE calcula_residuo_UV( A, u, b, r, t)

       USE ClassMatrizA

       IMPLICIT NONE

       TYPE ( MatrizA ), INTENT(IN) :: A
       DOUBLE PRECISION, DIMENSION(:, :), INTENT(INOUT) :: r
       DOUBLE PRECISION, DIMENSION(:, :), INTENT(IN) :: u, b
       INTEGER, INTENT(IN) :: t

       INTEGER :: p, stencil, ite, se ! se = elemento do stencil
       DOUBLE PRECISION :: ax, ux, sm, correcao ! Soma dos componentes do stencil

       DO p = 1, A % Nx * A % Ny

           ! Obtendo o stencil do volume
           stencil = A % v(p)

           ! Para cada coeficiente do stencil da matriz
           ! Lembrando que o primeiro e sempre ap e Gauss-Seidel
           ! e definido como
           ! u(p) = (aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ... + b(p)) / ap
           ! O codigo abaixo soma aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ...
           sm = 0.0d0
           DO se = 2, SIZE(A % s(stencil) % p) !(comeca em 2 porque nao considera o ap)

               ! ax =     aw,     ae,       as,      an,     aww,        ann, etc...
               ! ux = u(p-1), u(p+1),  u(p-Nx), u(p+Nx),  u(p-2),  u(p+2*Nx), etc...
               ! Logo
               ! ax * ux = aw * u(p-1), ae * u(p+1), as * u(p-Nx), etc...

               ax = A % s(stencil) % c(se)
               ux = u(p + A % s(stencil) % p(se), t+1)

               sm = sm +  ax * ux

           END DO

           ! Obtendo o ap
           ax = A % s(stencil) % c(1)
           sm  = sm + u(p, t)

           ! Somando b(p) e subtraindo ap * up para compor o residuo
           r(p, t+1) = sm + b(p, t) - ax * u(p, t+1)

       END DO

   END SUBROUTINE calcula_residuo_UV

   SUBROUTINE calcula_residuo_P(A, u, b, r, t)

        USE ClassMatrizA

       IMPLICIT NONE

       TYPE ( MatrizA ), INTENT(IN) :: A
       DOUBLE PRECISION, DIMENSION(:, :), INTENT(INOUT) :: r
       DOUBLE PRECISION, DIMENSION(:, :), INTENT(IN) :: u, b
       INTEGER, INTENT(IN) :: t

       INTEGER :: p, stencil, ite, se ! se = elemento do stencil
       DOUBLE PRECISION :: ax, ux, sm, correcao ! Soma dos componentes do stencil

       DO p = 1, A % Nx * A % Ny

           ! Obtendo o stencil do volume
           stencil = A % v(p)

           ! Para cada coeficiente do stencil da matriz
           ! Lembrando que o primeiro e sempre ap e Gauss-Seidel
           ! e definido como
           ! u(p) = (aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ... + b(p)) / ap
           ! O codigo abaixo soma aw * u(p-1) + ae * u(p+1) + as * u(p-Nx) ...
           sm = 0.0d0
           DO se = 2, SIZE(A % s(stencil) % p) !(comeca em 2 porque nao considera o ap)

               ! ax =     aw,     ae,       as,      an,     aww,        ann, etc...
               ! ux = u(p-1), u(p+1),  u(p-Nx), u(p+Nx),  u(p-2),  u(p+2*Nx), etc...
               ! Logo
               ! ax * ux = aw * u(p-1), ae * u(p+1), as * u(p-Nx), etc...

               ax = A % s(stencil) % c(se)
               ux = u(p + A % s(stencil) % p(se), t+1)

               sm = sm +  ax * ux

           END DO

           ! Obtendo o ap
           ax = A % s(stencil) % c(1)

           ! Somando b(p) e subtraindo ap * up para compor o residuo
           r(p, t+1) = sm + b(p, t) - ax * u(p, t+1)

       END DO

   END SUBROUTINE calcula_residuo_P

END MODULE Residuo


program problem26
  implicit none
  integer :: i,temp,answer=-1,best=-1

  do i=2,1000
     temp=period(i)
     if (temp>best) then
        best=temp
        answer=i
     end if
  end do

  print *, answer

contains
  pure function period(n)
    implicit none
    integer, intent(in)      :: n
    integer, parameter       :: size=1000000
    integer, dimension(size) :: quotients,remainders
    integer                  :: period,i,j

    quotients(1)=0
    remainders(1)=1

    ! Generate sequence of (quotient,remainder) pairs.  A cycle occurs
    ! when and only when a (quotient,remainder) pair is repeated.
    do i=2,size
       quotients(i)=(remainders(i-1)*10)/n
       remainders(i)=mod(remainders(i-1)*10,n)
       ! Look for a repeated pair
       do j=1,i-1
          if (quotients(i)==quotients(j) .and. remainders(i)==remainders(j)) then
             period=i-j
             go to 1
          end if
       end do
    end do
1   continue

  end function period

end program problem26


*DECK CTRCO
      SUBROUTINE CTRCO (T, LDT, N, RCOND, Z, JOB)
C***BEGIN PROLOGUE  CTRCO
C***PURPOSE  Estimate the condition number of a triangular matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2C3
C***TYPE      COMPLEX (STRCO-S, DTRCO-D, CTRCO-C)
C***KEYWORDS  CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
C             TRIANGULAR MATRIX
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     CTRCO estimates the condition of a complex triangular matrix.
C
C     On Entry
C
C        T       COMPLEX(LDT,N)
C                T contains the triangular matrix.  The zero
C                elements of the matrix are not referenced, and
C                the corresponding elements of the array can be
C                used to store other information.
C
C        LDT     INTEGER
C                LDT is the leading dimension of the array T.
C
C        N       INTEGER
C                N is the order of the system.
C
C        JOB     INTEGER
C                = 0         T  is lower triangular.
C                = nonzero   T  is upper triangular.
C
C     On Return
C
C        RCOND   REAL
C                an estimate of the reciprocal condition of  T .
C                For the system  T*X = B , relative perturbations
C                in  T  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  T  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       COMPLEX(N)
C                a work vector whose contents are usually unimportant.
C                If  T  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CSSCAL, SCASUM
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CTRCO
      INTEGER LDT,N,JOB
      COMPLEX T(LDT,*),Z(*)
      REAL RCOND
C
      COMPLEX W,WK,WKM,EK
      REAL TNORM,YNORM,S,SM,SCASUM
      INTEGER I1,J,J1,J2,K,KK,L
      LOGICAL LOWER
      COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
      CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2))
C
C***FIRST EXECUTABLE STATEMENT  CTRCO
      LOWER = JOB .EQ. 0
C
C     COMPUTE 1-NORM OF T
C
      TNORM = 0.0E0
      DO 10 J = 1, N
         L = J
         IF (LOWER) L = N + 1 - J
         I1 = 1
         IF (LOWER) I1 = J
         TNORM = MAX(TNORM,SCASUM(L,T(I1,J),1))
   10 CONTINUE
C
C     RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  T*Z = Y  AND  CTRANS(T)*Y = E .
C     CTRANS(T)  IS THE CONJUGATE TRANSPOSE OF T .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF Y .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE CTRANS(T)*Y = E
C
      EK = (1.0E0,0.0E0)
      DO 20 J = 1, N
         Z(J) = (0.0E0,0.0E0)
   20 CONTINUE
      DO 100 KK = 1, N
         K = KK
         IF (LOWER) K = N + 1 - KK
         IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K))
         IF (CABS1(EK-Z(K)) .LE. CABS1(T(K,K))) GO TO 30
            S = CABS1(T(K,K))/CABS1(EK-Z(K))
            CALL CSSCAL(N,S,Z,1)
            EK = CMPLX(S,0.0E0)*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = CABS1(WK)
         SM = CABS1(WKM)
         IF (CABS1(T(K,K)) .EQ. 0.0E0) GO TO 40
            WK = WK/CONJG(T(K,K))
            WKM = WKM/CONJG(T(K,K))
         GO TO 50
   40    CONTINUE
            WK = (1.0E0,0.0E0)
            WKM = (1.0E0,0.0E0)
   50    CONTINUE
         IF (KK .EQ. N) GO TO 90
            J1 = K + 1
            IF (LOWER) J1 = 1
            J2 = N
            IF (LOWER) J2 = K - 1
            DO 60 J = J1, J2
               SM = SM + CABS1(Z(J)+WKM*CONJG(T(K,J)))
               Z(J) = Z(J) + WK*CONJG(T(K,J))
               S = S + CABS1(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               W = WKM - WK
               WK = WKM
               DO 70 J = J1, J2
                  Z(J) = Z(J) + W*CONJG(T(K,J))
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
C
      YNORM = 1.0E0
C
C     SOLVE T*Z = Y
C
      DO 130 KK = 1, N
         K = N + 1 - KK
         IF (LOWER) K = KK
         IF (CABS1(Z(K)) .LE. CABS1(T(K,K))) GO TO 110
            S = CABS1(T(K,K))/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
            YNORM = S*YNORM
  110    CONTINUE
         IF (CABS1(T(K,K)) .NE. 0.0E0) Z(K) = Z(K)/T(K,K)
         IF (CABS1(T(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0)
         I1 = 1
         IF (LOWER) I1 = K + 1
         IF (KK .GE. N) GO TO 120
            W = -Z(K)
            CALL CAXPY(N-KK,W,T(I1,K),1,Z(I1),1)
  120    CONTINUE
  130 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (TNORM .NE. 0.0E0) RCOND = YNORM/TNORM
      IF (TNORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END


Real Function fd1(dmass, aj, al, width, widb0, srt)
  Save
  amn = 0.938
  amp = 0.138
  amd = amn
  ak02 = 0.25*(dmass**2-amd**2-amp**2)**2 - (amp*amd)**2
  If (ak02>0.) Then
    q0 = sqrt(ak02/dmass)
  Else
    q0 = 0.0
    fd1 = 0
    Return
  End If
  ak2 = 0.25*(srt**2-amd**2-amp**2)**2 - (amp*amd)**2
  If (ak2>0.) Then
    q = sqrt(ak2/dmass)
  Else
    q = 0.00
    fd1 = 0
    Return
  End If
  b = widb0*1.2*dmass/srt*(q/q0)**(2.*al+1)/(1.+0.2*(q/q0)**(2*al))
  fd1 = (2.*aj+1)*width**2*b/((srt-dmass)**2+0.25*width**2)/(2.*q**2)
  Return
End Function fd1