!*==zgbcon.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZGBCON
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGBCON + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND,
!                          WORK, RWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          NORM
!       INTEGER            INFO, KL, KU, LDAB, N
!       DOUBLE PRECISION   ANORM, RCOND
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       DOUBLE PRECISION   RWORK( * )
!       COMPLEX*16         AB( LDAB, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGBCON estimates the reciprocal of the condition number of a complex
!> general band matrix A, in either the 1-norm or the infinity-norm,
!> using the LU factorization computed by ZGBTRF.
!>
!> An estimate is obtained for norm(inv(A)), and the reciprocal of the
!> condition number is computed as
!>    RCOND = 1 / ( norm(A) * norm(inv(A)) ).
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] NORM
!> \verbatim
!>          NORM is CHARACTER*1
!>          Specifies whether the 1-norm condition number or the
!>          infinity-norm condition number is required:
!>          = '1' or 'O':  1-norm;
!>          = 'I':         Infinity-norm.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] KL
!> \verbatim
!>          KL is INTEGER
!>          The number of subdiagonals within the band of A.  KL >= 0.
!> \endverbatim
!>
!> \param[in] KU
!> \verbatim
!>          KU is INTEGER
!>          The number of superdiagonals within the band of A.  KU >= 0.
!> \endverbatim
!>
!> \param[in] AB
!> \verbatim
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          Details of the LU factorization of the band matrix A, as
!>          computed by ZGBTRF.  U is stored as an upper triangular band
!>          matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
!>          the multipliers used during the factorization are stored in
!>          rows KL+KU+2 to 2*KL+KU+1.
!> \endverbatim
!>
!> \param[in] LDAB
!> \verbatim
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!> \endverbatim
!>
!> \param[in] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices; for 1 <= i <= N, row i of the matrix was
!>          interchanged with row IPIV(i).
!> \endverbatim
!>
!> \param[in] ANORM
!> \verbatim
!>          ANORM is DOUBLE PRECISION
!>          If NORM = '1' or 'O', the 1-norm of the original matrix A.
!>          If NORM = 'I', the infinity-norm of the original matrix A.
!> \endverbatim
!>
!> \param[out] RCOND
!> \verbatim
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the matrix A,
!>          computed as RCOND = 1/(norm(A) * norm(inv(A))).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (2*N)
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16GBcomputational
!
!  =====================================================================
      SUBROUTINE ZGBCON(Norm,N,Kl,Ku,Ab,Ldab,Ipiv,Anorm,Rcond,Work,     &
     &                  Rwork,Info)
      IMPLICIT NONE
!*--ZGBCON151
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Norm
      INTEGER Info , Kl , Ku , Ldab , N
      DOUBLE PRECISION Anorm , Rcond
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      DOUBLE PRECISION Rwork(*)
      COMPLEX*16 Ab(Ldab,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ONE , ZERO
      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
!     ..
!     .. Local Scalars ..
      LOGICAL lnoti , onenrm
      CHARACTER normin
      INTEGER ix , j , jp , kase , kase1 , kd , lm
      DOUBLE PRECISION ainvnm , scale , smlnum
      COMPLEX*16 t , zdum
!     ..
!     .. Local Arrays ..
      INTEGER isave(3)
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER IZAMAX
      DOUBLE PRECISION DLAMCH
      COMPLEX*16 ZDOTC
      EXTERNAL LSAME , IZAMAX , DLAMCH , ZDOTC
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA , ZAXPY , ZDRSCL , ZLACN2 , ZLATBS
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , DIMAG , MIN
!     ..
!     .. Statement Functions ..
      DOUBLE PRECISION CABS1
!     ..
!     .. Statement Function definitions ..
      CABS1(zdum) = ABS(DBLE(zdum)) + ABS(DIMAG(zdum))
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      onenrm = Norm=='1' .OR. LSAME(Norm,'O')
      IF ( .NOT.onenrm .AND. .NOT.LSAME(Norm,'I') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Kl<0 ) THEN
         Info = -3
      ELSEIF ( Ku<0 ) THEN
         Info = -4
      ELSEIF ( Ldab<2*Kl+Ku+1 ) THEN
         Info = -6
      ELSEIF ( Anorm<ZERO ) THEN
         Info = -8
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGBCON',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      Rcond = ZERO
      IF ( N==0 ) THEN
         Rcond = ONE
         RETURN
      ELSEIF ( Anorm==ZERO ) THEN
         RETURN
      ENDIF
!
      smlnum = DLAMCH('Safe minimum')
!
!     Estimate the norm of inv(A).
!
      ainvnm = ZERO
      normin = 'N'
      IF ( onenrm ) THEN
         kase1 = 1
      ELSE
         kase1 = 2
      ENDIF
      kd = Kl + Ku + 1
      lnoti = Kl>0
      kase = 0
      DO
         CALL ZLACN2(N,Work(N+1),Work,ainvnm,kase,isave)
         IF ( kase/=0 ) THEN
            IF ( kase==kase1 ) THEN
!
!           Multiply by inv(L).
!
               IF ( lnoti ) THEN
                  DO j = 1 , N - 1
                     lm = MIN(Kl,N-j)
                     jp = Ipiv(j)
                     t = Work(jp)
                     IF ( jp/=j ) THEN
                        Work(jp) = Work(j)
                        Work(j) = t
                     ENDIF
                     CALL ZAXPY(lm,-t,Ab(kd+1,j),1,Work(j+1),1)
                  ENDDO
               ENDIF
!
!           Multiply by inv(U).
!
               CALL ZLATBS('Upper','No transpose','Non-unit',normin,N,  &
     &                     Kl+Ku,Ab,Ldab,Work,scale,Rwork,Info)
            ELSE
!
!           Multiply by inv(U**H).
!
               CALL ZLATBS('Upper','Conjugate transpose','Non-unit',    &
     &                     normin,N,Kl+Ku,Ab,Ldab,Work,scale,Rwork,Info)
!
!           Multiply by inv(L**H).
!
               IF ( lnoti ) THEN
                  DO j = N - 1 , 1 , -1
                     lm = MIN(Kl,N-j)
                     Work(j) = Work(j)                                  &
     &                         - ZDOTC(lm,Ab(kd+1,j),1,Work(j+1),1)
                     jp = Ipiv(j)
                     IF ( jp/=j ) THEN
                        t = Work(jp)
                        Work(jp) = Work(j)
                        Work(j) = t
                     ENDIF
                  ENDDO
               ENDIF
            ENDIF
!
!        Divide X by 1/SCALE if doing so will not cause overflow.
!
            normin = 'Y'
            IF ( scale/=ONE ) THEN
               ix = IZAMAX(N,Work,1)
               IF ( scale<CABS1(Work(ix))*smlnum .OR. scale==ZERO ) EXIT
               CALL ZDRSCL(N,scale,Work,1)
            ENDIF
            CYCLE
         ENDIF
!
!     Compute the estimate of the reciprocal condition number.
!
         IF ( ainvnm/=ZERO ) Rcond = (ONE/ainvnm)/Anorm
         EXIT
      ENDDO
!
!
!     End of ZGBCON
!
      END SUBROUTINE ZGBCON


 SUBROUTINE DGELSS1_F95( A, B, RANK, S, RCOND, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => DP
    USE LA_AUXMOD, ONLY: ERINFO, LA_WS_GELSS
    USE F77_LAPACK, ONLY: GELSS_F77 => LA_GELSS
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    INTEGER, INTENT(OUT), OPTIONAL :: RANK
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
    REAL(WP), INTENT(IN), OPTIONAL :: RCOND
!   .. ARRAY ARGUMENTS ..
    REAL(WP), INTENT(INOUT) :: A(:,:), B(:)
    REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: S(:)
!   .. PARAMETERS ..
    CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GELSS'
    CHARACTER(LEN=1), PARAMETER :: VER = 'D'
!   .. LOCAL SCALARS ..
    INTEGER :: LINFO, ISTAT, ISTAT1, LWORK, N, M, MN, NRHS, LRANK, SS
    REAL(WP) :: LRCOND
!   .. LOCAL POINTERS ..
    REAL(WP), POINTER :: WORK(:), LS(:)
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT, MAX, MIN, EPSILON
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0; M = SIZE(A,1); N = SIZE(A,2); NRHS = 1; MN = MIN(M,N)
    IF( PRESENT(RCOND) )THEN; LRCOND = RCOND; ELSE
        LRCOND = 100*EPSILON(1.0_WP) ; ENDIF
    IF( PRESENT(S) )THEN; SS = SIZE(S); ELSE; SS =MN; ENDIF
!   .. TEST THE ARGUMENTS
    IF( M < 0 .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( SIZE( B ) /= MAX(1,M,N) ) THEN; LINFO = -2
    ELSE IF( SS /= MN ) THEN; LINFO = -4
    ELSE IF( LRCOND <= 0.0_WP ) THEN; LINFO = -5
    ELSE
       IF( PRESENT(S) )THEN; LS => S
       ELSE; ALLOCATE( LS(MN), STAT = ISTAT ); END IF
       IF( ISTAT == 0 ) THEN
          LWORK = LA_WS_GELSS( VER, M, N, NRHS )
          ALLOCATE( WORK(LWORK), STAT = ISTAT )
          IF( ISTAT /= 0 ) THEN
             DEALLOCATE( WORK, STAT=ISTAT1 )
             LWORK = MAX( 1, 3*MIN(M,N) + MAX( 2*MIN(M,N), MAX(M,N), NRHS ) )
             ALLOCATE( WORK(LWORK), STAT = ISTAT )
             IF( ISTAT /= 0 ) CALL ERINFO( -200, SRNAME, LINFO )
          END IF
       END IF
       IF ( ISTAT == 0 ) THEN
!      .. CALL LAPACK77 ROUTINE
          CALL GELSS_F77( M, N, NRHS, A, MAX(1,M), B, MAX(1,M,N), &
                         LS, LRCOND, LRANK, WORK, LWORK, LINFO )
       ELSE; LINFO = -100; END IF
       IF( PRESENT(RANK) ) RANK = LRANK
       DEALLOCATE(WORK, STAT = ISTAT1 )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
 END SUBROUTINE DGELSS1_F95


!------------------------------------------------------------------
! Code generated by GeneXproTools 4.0 on 03/03/2009 8:02:50 PM
! Training Samples:  246
! Fitness  Function: RRSE
! Training Fitness:  866.465722781635
! Training R-square: 0.976331602056821
!------------------------------------------------------------------

	real function gepModel(d)

		real, intent(in) :: d(0:1)

		real, parameter :: G1C0 = -7.840851
		real, parameter :: G1C1 = -9.934205
		real, parameter :: G2C0 = 3.905793
		real, parameter :: G2C1 = 4.713165
		real, parameter :: G3C0 = -2.181244
		real, parameter :: G3C1 = -6.156738

		real :: varTemp
		varTemp = 0.0

		varTemp = ((G1C0+sin(sqrt(d(0))))*((d(0)-G1C1)**(1.0/3.0)))
		varTemp = varTemp + (d(1)-(cos((d(1)**(1.0/3.0)))*(G2C0**3)))
		varTemp = varTemp + (d(0)-sqrt((sin((G3C1*d(1)))-G3C0)))

		gepModel = varTemp

	end function gepModel

docs/Thermo Diagram Research/Tephigram Data/02-raw-Kelvin/02-gepModel-algorithm.f95


! { dg-do run }
! Tests the fix for PR38907, in which any expressions, including unary plus,
! in front of the call to S_REAL_SUM_I (marked) would throw the mechanism
! for correcting invalid host association.
!
! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
!
module sa0054_stuff
  REAL :: S_REAL_SUM_2(10) = [(REAL (I), I = 1, 10)]
contains
  ELEMENTAL FUNCTION S_REAL_SUM_I (A)
    REAL  ::  S_REAL_SUM_I
    REAL, INTENT(IN)  ::  A
    X = 1.0
    S_REAL_SUM_I = X
  END FUNCTION S_REAL_SUM_I
  SUBROUTINE SA0054 (RDA)
    REAL RDA(:)
    RDA =  + S_REAL_SUM_I (RDA)          ! Reported problem => ICE
    RDA = RDA + S_REAL_SUM_2 (INT (RDA)) ! Also failed
  CONTAINS
    ELEMENTAL FUNCTION S_REAL_SUM_I (A)
      REAL  ::  S_REAL_SUM_I
      REAL, INTENT(IN)  ::  A
      S_REAL_SUM_I = 2.0 * A
    END FUNCTION S_REAL_SUM_I
    ELEMENTAL FUNCTION S_REAL_SUM_2 (A)
      REAL  ::  S_REAL_SUM_2
      INTEGER, INTENT(IN)  ::  A
      S_REAL_SUM_2 = 2.0 * A
    END FUNCTION S_REAL_SUM_2
  END SUBROUTINE
end module sa0054_stuff

  use sa0054_stuff
  REAL :: RDA(10) = [(REAL(I), I = 1, 10)]
  call SA0054 (RDA)
  IF (ANY (INT (RDA) .ne. [(6 * I, I = 1, 10)])) print *, rda
END

! { dg-final { cleanup-modules "sa0054_stuff" } }


submodule(euler_interface_m) euler_prob_0052_m
    implicit none

contains

    module character(len=20) function euler0052()
        write (euler0052, "(i20)") ans()
    end function euler0052

    integer function ans()
        integer :: i, j
        logical, dimension(0:9) :: arr, arr_tmp

        i = 1
        outer: do
            call digs_used_in_num(i, arr)

            inner: do j = 2, 6
                call digs_used_in_num(i*j, arr_tmp)

                if (all(arr .eqv. arr_tmp)) then
                    if (j == 6) exit outer
                else
                    exit inner
                end if
            end do inner

            i = i + 1
        end do outer

        ans = i
    end function ans

    subroutine digs_used_in_num(n, arr)
        integer, intent(in) :: n
        logical, intent(out) :: arr(0:9)
        integer, allocatable :: int_arr(:)
        integer :: i

        call int_2_arr(n, int_arr)
        arr = .false.

        do i = 1, digs_of_int(n)
            arr(int_arr(i)) = .true.
        end do
    end subroutine digs_used_in_num

end submodule euler_prob_0052_m


      subroutine titand ( tau, gtau, n )
c  from  * a practical guide to splines *  by c. de boor
c  these data represent a property of titanium as a function of
c  temperature. they have been used extensively as an example in spline
c  approximation with variable knots.
      integer n,   i
      real gtau(49),tau(49),gtitan(49)
      data gtitan /.644,.622,.638,.649,.652,.639,.646,.657,.652,.655,
     2		   .644,.663,.663,.668,.676,.676,.686,.679,.678,.683,
     3		   .694,.699,.710,.730,.763,.812,.907,1.044,1.336,1.881,
     4		   2.169,2.075,1.598,1.211,.916,.746,.672,.627,.615,.607
     5		  ,.606,.609,.603,.601,.603,.601,.611,.601,.608/
      n = 49
      do 10 i=1,n
	 tau(i) = 585. + 10.*float(i)
   10	 gtau(i) = gtitan(i)
					return
      end


!RUN: %f18 -fdebug-dump-symbols -fparse-only %s | FileCheck %s

! Size and alignment of derived types

! Array of derived type with 64-bit alignment
subroutine s1
  type t1
    real(8) :: a
    real(4) :: b
  end type
  !CHECK: x1 size=12 offset=0:
  !CHECK: y1 size=12 offset=16:
  type(t1) :: x1, y1
  !CHECK: z1 size=160 offset=32:
  type(t1) :: z1(10)
end

! Like t1 but t2 does not need to be aligned on 64-bit boundary
subroutine s2
  type t2
    real(4) :: a
    real(4) :: b
    real(4) :: c
  end type
  !CHECK: x2 size=12 offset=0:
  !CHECK: y2 size=12 offset=12:
  type(t2) :: x2, y2
  !CHECK: z2 size=120 offset=24:
  type(t2) :: z2(10)
end

! Parameterized derived types
subroutine s3
  type :: t(k, l)
    integer, kind :: k
    integer, len :: l
    real(k) :: a3
    integer(kind=k) :: b3
    character(kind=k, len=8) :: c3
    character(kind=k, len=l) :: d3
  end type
  !CHECK: DerivedType scope: size=48 align=8 instantiation of t(k=2_4,l=10_4)
  !CHECK: a3 size=2 offset=0:
  !CHECK: b3 size=2 offset=2:
  !CHECK: c3 size=16 offset=4:
  !CHECK: d3 size=24 offset=24:
  type(t(2, 10)) :: x3
  !CHECK: DerivedType scope: size=64 align=8 instantiation of t(k=4_4,l=20_4)
  !CHECK: a3 size=4 offset=0:
  !CHECK: b3 size=4 offset=4:
  !CHECK: c3 size=32 offset=8:
  !CHECK: d3 size=24 offset=40:
  type(t(4, 20)) :: x4
end


program problem_15

    use aoc_utilities

    !! see: https://en.wikipedia.org/wiki/Dijkstra's_algorithm#Pseudocode

    implicit none

    type :: pair
        integer,dimension(2) :: ij = -1
    end type pair

    logical :: status_ok
    integer :: iunit, i, j, k, n_rows, n_cols
    character(len=:),allocatable :: line
    integer,dimension(:,:),allocatable :: map
    logical,dimension(:,:),allocatable :: visited
    integer,dimension(:,:),allocatable :: dist
    type(pair),dimension(:,:),allocatable :: prev
    integer,dimension(2) :: iloc
    integer :: icase, fact

    integer,parameter :: n_cases = 2
    character(len=1),dimension(2),parameter :: ab = ['a', 'b']

    do icase = 1, n_cases

        if (icase==1) then
            fact = 1
        else
            fact = 5
        end if

        open(newunit=iunit,file='inputs/day15.txt', status='OLD')
        n_rows = number_of_lines_in_file(iunit)
        do i = 1, n_rows
            call read_line_from_file(iunit,line,status_ok)
            if (i==1) then
                n_cols = len(line)
                if (allocated(map)) deallocate(map); allocate(map(n_rows*fact,n_cols*fact))
                if (allocated(visited)) deallocate(visited); allocate(visited(n_rows*fact,n_cols*fact))
                if (allocated(dist)) deallocate(dist); allocate(dist(n_rows*fact,n_cols*fact))
                if (allocated(prev)) deallocate(prev); allocate(prev(n_rows*fact,n_cols*fact))
            end if
            read(line,'(*(I1))') map(i,1:n_cols)
        end do
        if (icase==2) then ! expand the map

            do i = 2, fact
                map(1:n_rows, n_cols*(i-1)+1:n_cols*i) = mod(map(1:n_rows, n_cols*(i-2)+1:n_cols*(i-1)) + 1, 10)
                where (map==0) map = 1 ! not efficient
            end do
            do i = 2, fact
                map(n_rows*(i-1)+1:n_rows*i, 1:n_cols*fact) = mod(map(n_rows*(i-2)+1:n_rows*(i-1), 1:n_cols*fact) + 1, 10)
                where (map==0) map = 1 ! not efficient
            end do

            n_rows = n_rows * fact
            n_cols = n_cols * fact

        end if
        ! ! write:
        ! do i = 1, n_rows
        !     write(*,'(*(I1))') map(i,:)
        ! end do

        dist = huge(1)
        visited = .false.
        dist(1,1) = 0

        do

            iloc = minloc(dist, mask=.not. visited)
            i = iloc(1)
            j = iloc(2)
            visited(i,j) = .true.

            if (i == n_rows .and. j == n_cols) exit ! we are done

            call check([i,j], [i+1,j])
            call check([i,j], [i,j+1])
            call check([i,j], [i-1,j])
            call check([i,j], [i,j-1])

        end do

        write(*,*) '15'//ab(icase)//': dist = ', dist(n_rows, n_cols)

    end do

    contains

    subroutine check(u, v)
        implicit none
        integer,dimension(2),intent(in) :: u ! current
        integer,dimension(2),intent(in) :: v ! neighbor
        integer :: alt

        if (v(1)<1 .or. v(2)<1 .or. v(1)>n_rows .or. v(2)>n_cols) return
        if (visited(v(1),v(2))) return ! already visited this one

        alt = dist(u(1),u(2)) + map(v(1),v(2))

        if (alt < dist(v(1),v(2))) then
            dist(v(1),v(2)) = alt
            prev(v(1),v(2)) = pair(u)
        end if

    end subroutine check

end program problem_15


! { dg-do compile }
! { dg-options "-Warray-temporaries" }
! PR 48231 - this used to create an unnecessary temporary.
module UnitValue_Module
  type :: UnitValue
    real          :: Value = 1.0
  end type

  interface operator(*)
    module procedure ProductReal_LV
  end interface operator(*)

  interface assignment(=)
    module procedure Assign_LV_Real
  end interface assignment(=)
contains

  elemental function ProductReal_LV(Multiplier, Multiplicand) result(P_R_LV)
    real, intent(in)            :: Multiplier
    type(UnitValue), intent(in) :: Multiplicand
    type(UnitValue)             :: P_R_LV
    P_R_LV%Value = Multiplier * Multiplicand%Value
  end function ProductReal_LV

  elemental subroutine Assign_LV_Real(LeftHandSide, RightHandSide)
    real, intent(inout)         :: LeftHandSide
    type(UnitValue), intent(in) :: RightHandSide
    LeftHandSide = RightHandSide%Value
  end subroutine Assign_LV_Real
end module UnitValue_Module

program TestProgram
  use UnitValue_Module

  type :: TableForm
    real, dimension(:,:), allocatable :: RealData
  end type TableForm

  REAL :: CENTIMETER
  type(TableForm), pointer :: Table

  allocate(Table)
  allocate(Table%RealData(10,5))

  CENTIMETER = 42
  Table%RealData = 1
  Table%RealData(:,1) = Table%RealData(:,1) * CENTIMETER
end program TestProgram


!##############################################################################
!# Tutorial 003e: Random number generator
!##############################################################################

module tutorial003e

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput
  use random

  implicit none
  private

  public :: start_tutorial003e

contains

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

  subroutine start_tutorial003e

    ! Declare some variables
    type(t_random) :: rrng
    integer :: i
    integer(I32), dimension(4) :: Ival
    real(DP), dimension(4) :: Dval

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 003e")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Generate random numbers
    ! =================================

    ! Initialise the pseudo-random generator.
    call rng_init(rrng, 7635_I32)

    ! Generate some integer numbers.
    do i=1,4
      call rng_get(rrng, Ival(i))
    end do

    ! Generate some double numbers.
    do i=1,4
      call rng_get(rrng, Dval(i))
    end do

    ! =================================
    ! Output
    ! =================================

    do i=1,4
#ifdef USE_LARGEINT
      call output_line (" " // trim(sys_siL(int(Ival(i),I64),10)),bnolinebreak=(i .ne. 4))
#else
      call output_line (" " // trim(sys_siL(Ival(i),10)), bnolinebreak=(i .ne. 4))
#endif
    end do

    do i=1,4
      call output_line (" " // sys_sdL(Dval(i),2), bnolinebreak=(i .ne. 4))
    end do

  end subroutine

end module


program main
  use mod_monolis
  implicit none
  type(monolis_com) :: monoCOM
  integer(kind=kint) :: i, N, NZ, NDOF
  integer(kind=kint) :: method, precond, maxiter
  logical :: is_scaling, is_reordering, is_init_x
  logical :: show_iterlog, show_time, show_summary
  integer(kind=kint), pointer :: index(:) => NULL()
  integer(kind=kint), pointer :: item(:) => NULL()
  real(kind=kdouble), pointer :: A(:) => NULL()
  real(kind=kdouble), pointer :: X(:) => NULL()
  real(kind=kdouble), pointer :: B(:) => NULL()
  real(kind=kdouble) :: tol
  character :: ctemp*10

  write(*,"(a)")"* monolis csr_matrix test"

  !> reference: matrix market
  !> https://math.nist.gov/MatrixMarket/data/Harwell-Boeing/bcsstruc2/bcsstk14.html
  open(20, file="./test.mtx", status="old")
    read(20,*)ctemp
    read(20,*)N, NZ
    allocate(index(0:N))
    allocate(item(NZ))
    allocate(A(NZ))
    read(20,*)(index(i), i = 0, N)
    read(20,*)(item(i), i = 1, NZ)
    read(20,*)(A(i), i = 1, NZ)
  close(20)

  NDOF = 1

  call monolis_com_initialize(monoCOM)

  allocate(X(N))
  allocate(B(N))

  X = 1.0d0
  B = 1.0d0
  method = 1
  precond = monolis_prec_MUMPS
  maxiter = 1000
  tol = 1.0d-8
  is_scaling    = .true.
  is_reordering = .true.
  is_init_x     = .true.
  show_iterlog  = .true.
  show_time     = .true.
  show_summary  = .true.

  write(*,"(a)")"* call monolis"
  call monolis(monoCOM, N, N, NZ, NDOF, A, X, B, index, item, &
    & method, precond, maxiter, tol, &
    & is_scaling, is_reordering, is_init_x, show_iterlog, show_time, show_summary)

  write(*,"(a)")"* monolis result"
  write(*,"(1p3e12.5)")X

  B = 0.0d0
  call monolis_matvec_wrapper(monoCOM, N, N, NZ, NDOF, A, index, item, X, B)

  write(*,"(a)")"* monolis b = Ax"
  write(*,"(1p3e12.5)")B

  deallocate(X)
  deallocate(B)

  call monolis_com_finalize(monoCOM)
end program main


#include "scalar.fpp"

!=====================================================================!
! This is a simple example of setting up a physical system for time
! dependent analysis.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module first_order_ode_class

  use constants                 , only : WP
  use dynamic_physics_interface , only : dynamics

  implicit none

  private

  public :: FODE

  !-------------------------------------------------------------------!
  ! Type that implements a test FODE of supplied differential order
  !-------------------------------------------------------------------!

  type, extends(dynamics) :: FODE

     ! Define constants and other parameters needed for residual and
     ! jacobian assembly here

     type(scalar) :: a
     type(scalar) :: b

   contains

     ! Implement deferred procedures from superclasses
     procedure :: add_residual
     procedure :: add_jacobian
     procedure :: get_initial_condition

     ! Destructor
     final :: destruct_FODE

  end type FODE

  ! Interface to construct the FODE
  interface FODE
     procedure construct_FODE
  end interface FODE

contains

  !===================================================================!
  ! Constructor for FODE system
  !===================================================================!

  pure type(FODE) function construct_FODE(a, b) &
       & result (this)

    type(scalar)  , intent(in) :: a, b

    ! Set the number of state variables of FODE system
    call this % set_num_state_vars(1)

    ! Set time order of FODE system
    call this % set_differential_order(1)

    ! Set the system parameters
    this % a = a
    this % b = b

  end function construct_FODE

  !===================================================================!
  ! Destructor for FODE system
  !===================================================================!

  pure subroutine destruct_FODE(this)

    type(FODE), intent(inout) :: this

  end subroutine destruct_FODE

  !===================================================================!
  ! Residual assembly at each time step. This is a mandary function
  ! that the user needs to implement to use the integration
  ! scheme. This is where the differential equations are supplied to
  ! the solver.
  ! ===================================================================!

  pure subroutine add_residual(this, residual, U, X)

    class(FODE)  , intent(inout) :: this
    type(scalar) , intent(inout) :: residual(:)
    type(scalar) , intent(in)    :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    residual = residual + U(2,:) - this % b * U(1,:) - this % a

  end subroutine add_residual

  !===================================================================!
  ! Jacobian assembly at each time step.
  !
  ! Jacobian is the matrix of partial derivatives. Each row in the
  ! Jacobian matrix arises from differentiating a single
  ! equation. Each column in the Jacobian comes from a variable in the
  ! problem. Note the NEQN should be equal to NVARS for the system to
  ! be solved.
  !
  ! Note: alpha, beta and gamma are scalars that need to be multiplied
  ! with the partial derivatives DRDQ, DRDudot and DRDuddot
  ! respectively.
  !===================================================================!

  pure subroutine add_jacobian(this, jacobian, coeff, U, X)

    class(FODE)   , intent(inout) :: this
    type(scalar) , intent(inout) :: jacobian(:,:)
    type(scalar) , intent(in)    :: coeff(:)
    type(scalar) , intent(in)    :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    jacobian(1,1) = jacobian(1,1) + coeff(2) - coeff(1)*this % b

  end subroutine add_jacobian

  !===================================================================!
  ! Sets the initial condition for use in the integator. If first order
  ! system just set initial Q, if a second order system set initial Q
  ! and qdot
  !===================================================================!

  pure subroutine get_initial_condition(this, U, X)

    class(FODE)   , intent(in)    :: this
    type(scalar) , intent(inout) :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    U(1,:) = 48.0d0

  end subroutine get_initial_condition

end module first_order_ode_class