program Demo_Remark

! Demo driver for revised Algorithm 982: Explicit solutions of triangular
! systems of first-order linear initial-value ordinary differential
! equations with constant coefficients.

  use Triangular_ODE, only: Compute_Solution, Compute_Z_Matrix, Solve_A_C_B

  implicit NONE

  integer, parameter :: RK = kind(0.0d0)

  real(rk) :: A(3,3)     ! Activity matrix
  real(rk) :: B(3) = 0   ! A(1:m,1:m)^{-1) C(1:m)
  real(rk) :: C(3)       ! Inhomogeneous part -- production rate constant
  real(rk) :: N(3)       ! Amount at time T
  real(rk) :: N0(3) = 0  ! Amount at T = 0
  real(rk) :: T(2)       ! Times in seconds with N(0) = 0 and C /= 0,
                         !                       N(0) = N(T(1)) and C = 0
  real(rk) :: Z(3,3) = 0 ! Solution coefficient matrix

  character(5) :: ID(3) = [ "Sr-90", "Y-90 ", "Zr-90" ]
  integer :: I, J, M

! Using apparent activities from ORIGEN output
! SR-90 29.109712 y, Y-90 2.665996 d
  data ((A(i,j),j=1,3),i=1,3) / -7.54558e-10_rk,  0,              0, & ! Sr-90
                              &  7.54558e-10_rk, -3.00921e-06_rk, 0, & ! Y-90
                              &  0,               3.00921e-06_rk, 0  / ! Zr-90

  data C / 7.5773424e-08_rk    , 3.1224202e-10_rk    , 2.9049726e-10_rk/

! Using JEFF 3.11
!  SR-90 28.790028 y, Y-90 2.67172 d
!  data ((A(i,j),j=1,3),i=1,3) / -7.62937e-10_rk,  0,              0, & ! Sr-90
!                              &  7.62937e-10_rk, -3.00376e-06_rk, 0, & ! Y-90
!                             &  0,                3.00376e-06_rk, 0  / ! Zr-90

! data C / 7.58109127244020e-08, 2.27383445862016e-10, 3.078259767e-10 /

  parameter ( T = [ 1387.0_rk * 86400, 10 * 365.2422_rk * 86400 ] )

! Solve A B = C for the nonsingular part of A

  call solve_a_c_b ( a, c, b, m )
  b(m+1:) = c(m+1:)

  call compute_z_matrix ( a, z, m )

  write ( *, '(a)' ) 'Activity matrix A'
  do i = 1, 3
    write ( *, '(a,1p3g13.4)' ) id(i), a(i,1:i)
  end do
  write ( *, '(a,i0,a)' ) 'Activity matrix has ', m, ' nonzero diagonal elements'
  write ( *, '(a)' ) 'Solution coefficients Z'
  do i = 1, m
    write ( *, '(a,1p3g13.4)' ) id(i), z(i,1:i-1)
  end do

  write ( *, '(a)' ) 'Inhomogenous parts, B(1:m) = A(1:m,1:m)^{-1) C(1:m)', &
                   & '          B            C'
  write ( *, '(a5,1p2g13.4)' ) ( id(i), b(i), c(i), i = 1, m )
  write ( *, '(a5,13x,1pg13.4)' ) ( id(i), c(i), i = m+1, 3 )

  ! Compute amount, starting from nothing, after t(1) seconds
  call compute_solution ( t(1), a, z, n0, n, b )

  write ( *, '(3a)' ) 'Amounts (moles) after ', trim(number(t(1)/86400)), ' days'
  write ( *, '(a5,1pg13.4)' ) ( id(i), n(i), i = 1, 3 )

  ! After production ceases (c=0), compute amount after ten more years
  n0 = n
  call compute_solution ( t(2), a, z, n0, n )

  write ( *, '(3a)' ) 'Amounts (moles) after ', &
                    & trim(number(t(2)/86400/365.2422)),  ' more years'
  write ( *, '(a5,1pg13.4)' ) ( id(i), n(i), i = 1, 3 )

contains

  character(13) function Number ( X )
    real(rk), intent(in) :: X
    integer :: J
    write ( number, '(1pg13.4)' ) x
    number = adjustl(number)
    if ( index(number,'.') == 0 ) return
    do j = len(number), 1, -1
      if ( number(j:j) == '0' ) number(j:j) = ''
      if ( number(j:j) == '.' ) then
        number(j:j) = ''
        exit
      end if
    end do
  end function Number

end program Demo_Remark
