!*==dlaein.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse iteration.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLAEIN + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B,
!                          LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
!
!       .. Scalar Arguments ..
!       LOGICAL            NOINIT, RIGHTV
!       INTEGER            INFO, LDB, LDH, N
!       DOUBLE PRECISION   BIGNUM, EPS3, SMLNUM, WI, WR
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
!      $                   WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLAEIN uses inverse iteration to find a right or left eigenvector
!> corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
!> matrix H.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] RIGHTV
!> \verbatim
!>          RIGHTV is LOGICAL
!>          = .TRUE. : compute right eigenvector;
!>          = .FALSE.: compute left eigenvector.
!> \endverbatim
!>
!> \param[in] NOINIT
!> \verbatim
!>          NOINIT is LOGICAL
!>          = .TRUE. : no initial vector supplied in (VR,VI).
!>          = .FALSE.: initial vector supplied in (VR,VI).
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix H.  N >= 0.
!> \endverbatim
!>
!> \param[in] H
!> \verbatim
!>          H is DOUBLE PRECISION array, dimension (LDH,N)
!>          The upper Hessenberg matrix H.
!> \endverbatim
!>
!> \param[in] LDH
!> \verbatim
!>          LDH is INTEGER
!>          The leading dimension of the array H.  LDH >= max(1,N).
!> \endverbatim
!>
!> \param[in] WR
!> \verbatim
!>          WR is DOUBLE PRECISION
!> \endverbatim
!>
!> \param[in] WI
!> \verbatim
!>          WI is DOUBLE PRECISION
!>          The real and imaginary parts of the eigenvalue of H whose
!>          corresponding right or left eigenvector is to be computed.
!> \endverbatim
!>
!> \param[in,out] VR
!> \verbatim
!>          VR is DOUBLE PRECISION array, dimension (N)
!> \endverbatim
!>
!> \param[in,out] VI
!> \verbatim
!>          VI is DOUBLE PRECISION array, dimension (N)
!>          On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
!>          a real starting vector for inverse iteration using the real
!>          eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
!>          must contain the real and imaginary parts of a complex
!>          starting vector for inverse iteration using the complex
!>          eigenvalue (WR,WI); otherwise VR and VI need not be set.
!>          On exit, if WI = 0.0 (real eigenvalue), VR contains the
!>          computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
!>          VR and VI contain the real and imaginary parts of the
!>          computed complex eigenvector. The eigenvector is normalized
!>          so that the component of largest magnitude has magnitude 1;
!>          here the magnitude of a complex number (x,y) is taken to be
!>          |x| + |y|.
!>          VI is not referenced if WI = 0.0.
!> \endverbatim
!>
!> \param[out] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB,N)
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= N+1.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (N)
!> \endverbatim
!>
!> \param[in] EPS3
!> \verbatim
!>          EPS3 is DOUBLE PRECISION
!>          A small machine-dependent value which is used to perturb
!>          close eigenvalues, and to replace zero pivots.
!> \endverbatim
!>
!> \param[in] SMLNUM
!> \verbatim
!>          SMLNUM is DOUBLE PRECISION
!>          A machine-dependent value close to the underflow threshold.
!> \endverbatim
!>
!> \param[in] BIGNUM
!> \verbatim
!>          BIGNUM is DOUBLE PRECISION
!>          A machine-dependent value close to the overflow threshold.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          = 1:  inverse iteration did not converge; VR is set to the
!>                last iterate, and so is VI if WI.ne.0.0.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleOTHERauxiliary
!
!  =====================================================================
      SUBROUTINE DLAEIN(Rightv,Noinit,N,H,Ldh,Wr,Wi,Vr,Vi,B,Ldb,Work,   &
     &                  Eps3,Smlnum,Bignum,Info)
      IMPLICIT NONE
!*--DLAEIN176
!
!  -- LAPACK auxiliary 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 ..
      LOGICAL Noinit , Rightv
      INTEGER Info , Ldb , Ldh , N
      DOUBLE PRECISION Bignum , Eps3 , Smlnum , Wi , Wr
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION B(Ldb,*) , H(Ldh,*) , Vi(*) , Vr(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE , TENTH
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0,TENTH=1.0D-1)
!     ..
!     .. Local Scalars ..
      CHARACTER normin , trans
      INTEGER i , i1 , i2 , i3 , ierr , its , j
      DOUBLE PRECISION absbii , absbjj , ei , ej , growto , norm ,      &
     &                 nrmsml , rec , rootn , scale , temp , vcrit ,    &
     &                 vmax , vnorm , w , w1 , x , xi , xr , y
!     ..
!     .. External Functions ..
      INTEGER IDAMAX
      DOUBLE PRECISION DASUM , DLAPY2 , DNRM2
      EXTERNAL IDAMAX , DASUM , DLAPY2 , DNRM2
!     ..
!     .. External Subroutines ..
      EXTERNAL DLADIV , DLATRS , DSCAL
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , MAX , SQRT
!     ..
!     .. Executable Statements ..
!
      Info = 0
!
!     GROWTO is the threshold used in the acceptance test for an
!     eigenvector.
!
      rootn = SQRT(DBLE(N))
      growto = TENTH/rootn
      nrmsml = MAX(ONE,Eps3*rootn)*Smlnum
!
!     Form B = H - (WR,WI)*I (except that the subdiagonal elements and
!     the imaginary parts of the diagonal elements are not stored).
!
      DO j = 1 , N
         DO i = 1 , j - 1
            B(i,j) = H(i,j)
         ENDDO
         B(j,j) = H(j,j) - Wr
      ENDDO
!
      IF ( Wi==ZERO ) THEN
!
!        Real eigenvalue.
!
         IF ( Noinit ) THEN
!
!           Set initial vector.
!
            DO i = 1 , N
               Vr(i) = Eps3
            ENDDO
         ELSE
!
!           Scale supplied initial vector.
!
            vnorm = DNRM2(N,Vr,1)
            CALL DSCAL(N,(Eps3*rootn)/MAX(vnorm,nrmsml),Vr,1)
         ENDIF
!
         IF ( Rightv ) THEN
!
!           LU decomposition with partial pivoting of B, replacing zero
!           pivots by EPS3.
!
            DO i = 1 , N - 1
               ei = H(i+1,i)
               IF ( ABS(B(i,i))<ABS(ei) ) THEN
!
!                 Interchange rows and eliminate.
!
                  x = B(i,i)/ei
                  B(i,i) = ei
                  DO j = i + 1 , N
                     temp = B(i+1,j)
                     B(i+1,j) = B(i,j) - x*temp
                     B(i,j) = temp
                  ENDDO
               ELSE
!
!                 Eliminate without interchange.
!
                  IF ( B(i,i)==ZERO ) B(i,i) = Eps3
                  x = ei/B(i,i)
                  IF ( x/=ZERO ) THEN
                     DO j = i + 1 , N
                        B(i+1,j) = B(i+1,j) - x*B(i,j)
                     ENDDO
                  ENDIF
               ENDIF
            ENDDO
            IF ( B(N,N)==ZERO ) B(N,N) = Eps3
!
            trans = 'N'
!
         ELSE
!
!           UL decomposition with partial pivoting of B, replacing zero
!           pivots by EPS3.
!
            DO j = N , 2 , -1
               ej = H(j,j-1)
               IF ( ABS(B(j,j))<ABS(ej) ) THEN
!
!                 Interchange columns and eliminate.
!
                  x = B(j,j)/ej
                  B(j,j) = ej
                  DO i = 1 , j - 1
                     temp = B(i,j-1)
                     B(i,j-1) = B(i,j) - x*temp
                     B(i,j) = temp
                  ENDDO
               ELSE
!
!                 Eliminate without interchange.
!
                  IF ( B(j,j)==ZERO ) B(j,j) = Eps3
                  x = ej/B(j,j)
                  IF ( x/=ZERO ) THEN
                     DO i = 1 , j - 1
                        B(i,j-1) = B(i,j-1) - x*B(i,j)
                     ENDDO
                  ENDIF
               ENDIF
            ENDDO
            IF ( B(1,1)==ZERO ) B(1,1) = Eps3
!
            trans = 'T'
!
         ENDIF
!
         normin = 'N'
         DO its = 1 , N
!
!           Solve U*x = scale*v for a right eigenvector
!             or U**T*x = scale*v for a left eigenvector,
!           overwriting x on v.
!
            CALL DLATRS('Upper',trans,'Nonunit',normin,N,B,Ldb,Vr,scale,&
     &                  Work,ierr)
            normin = 'Y'
!
!           Test for sufficient growth in the norm of v.
!
            vnorm = DASUM(N,Vr,1)
            IF ( vnorm>=growto*scale ) GOTO 50
!
!           Choose new orthogonal starting vector and try again.
!
            temp = Eps3/(rootn+ONE)
            Vr(1) = Eps3
            DO i = 2 , N
               Vr(i) = temp
            ENDDO
            Vr(N-its+1) = Vr(N-its+1) - Eps3*rootn
         ENDDO
!
!        Failure to find eigenvector in N iterations.
!
         Info = 1
!
!
!        Normalize eigenvector.
!
 50      i = IDAMAX(N,Vr,1)
         CALL DSCAL(N,ONE/ABS(Vr(i)),Vr,1)
      ELSE
!
!        Complex eigenvalue.
!
         IF ( Noinit ) THEN
!
!           Set initial vector.
!
            DO i = 1 , N
               Vr(i) = Eps3
               Vi(i) = ZERO
            ENDDO
         ELSE
!
!           Scale supplied initial vector.
!
            norm = DLAPY2(DNRM2(N,Vr,1),DNRM2(N,Vi,1))
            rec = (Eps3*rootn)/MAX(norm,nrmsml)
            CALL DSCAL(N,rec,Vr,1)
            CALL DSCAL(N,rec,Vi,1)
         ENDIF
!
         IF ( Rightv ) THEN
!
!           LU decomposition with partial pivoting of B, replacing zero
!           pivots by EPS3.
!
!           The imaginary part of the (i,j)-th element of U is stored in
!           B(j+1,i).
!
            B(2,1) = -Wi
            DO i = 2 , N
               B(i+1,1) = ZERO
            ENDDO
!
            DO i = 1 , N - 1
               absbii = DLAPY2(B(i,i),B(i+1,i))
               ei = H(i+1,i)
               IF ( absbii<ABS(ei) ) THEN
!
!                 Interchange rows and eliminate.
!
                  xr = B(i,i)/ei
                  xi = B(i+1,i)/ei
                  B(i,i) = ei
                  B(i+1,i) = ZERO
                  DO j = i + 1 , N
                     temp = B(i+1,j)
                     B(i+1,j) = B(i,j) - xr*temp
                     B(j+1,i+1) = B(j+1,i) - xi*temp
                     B(i,j) = temp
                     B(j+1,i) = ZERO
                  ENDDO
                  B(i+2,i) = -Wi
                  B(i+1,i+1) = B(i+1,i+1) - xi*Wi
                  B(i+2,i+1) = B(i+2,i+1) + xr*Wi
               ELSE
!
!                 Eliminate without interchanging rows.
!
                  IF ( absbii==ZERO ) THEN
                     B(i,i) = Eps3
                     B(i+1,i) = ZERO
                     absbii = Eps3
                  ENDIF
                  ei = (ei/absbii)/absbii
                  xr = B(i,i)*ei
                  xi = -B(i+1,i)*ei
                  DO j = i + 1 , N
                     B(i+1,j) = B(i+1,j) - xr*B(i,j) + xi*B(j+1,i)
                     B(j+1,i+1) = -xr*B(j+1,i) - xi*B(i,j)
                  ENDDO
                  B(i+2,i+1) = B(i+2,i+1) - Wi
               ENDIF
!
!              Compute 1-norm of offdiagonal elements of i-th row.
!
               Work(i) = DASUM(N-i,B(i,i+1),Ldb) + DASUM(N-i,B(i+2,i),1)
            ENDDO
            IF ( B(N,N)==ZERO .AND. B(N+1,N)==ZERO ) B(N,N) = Eps3
            Work(N) = ZERO
!
            i1 = N
            i2 = 1
            i3 = -1
         ELSE
!
!           UL decomposition with partial pivoting of conjg(B),
!           replacing zero pivots by EPS3.
!
!           The imaginary part of the (i,j)-th element of U is stored in
!           B(j+1,i).
!
            B(N+1,N) = Wi
            DO j = 1 , N - 1
               B(N+1,j) = ZERO
            ENDDO
!
            DO j = N , 2 , -1
               ej = H(j,j-1)
               absbjj = DLAPY2(B(j,j),B(j+1,j))
               IF ( absbjj<ABS(ej) ) THEN
!
!                 Interchange columns and eliminate
!
                  xr = B(j,j)/ej
                  xi = B(j+1,j)/ej
                  B(j,j) = ej
                  B(j+1,j) = ZERO
                  DO i = 1 , j - 1
                     temp = B(i,j-1)
                     B(i,j-1) = B(i,j) - xr*temp
                     B(j,i) = B(j+1,i) - xi*temp
                     B(i,j) = temp
                     B(j+1,i) = ZERO
                  ENDDO
                  B(j+1,j-1) = Wi
                  B(j-1,j-1) = B(j-1,j-1) + xi*Wi
                  B(j,j-1) = B(j,j-1) - xr*Wi
               ELSE
!
!                 Eliminate without interchange.
!
                  IF ( absbjj==ZERO ) THEN
                     B(j,j) = Eps3
                     B(j+1,j) = ZERO
                     absbjj = Eps3
                  ENDIF
                  ej = (ej/absbjj)/absbjj
                  xr = B(j,j)*ej
                  xi = -B(j+1,j)*ej
                  DO i = 1 , j - 1
                     B(i,j-1) = B(i,j-1) - xr*B(i,j) + xi*B(j+1,i)
                     B(j,i) = -xr*B(j+1,i) - xi*B(i,j)
                  ENDDO
                  B(j,j-1) = B(j,j-1) + Wi
               ENDIF
!
!              Compute 1-norm of offdiagonal elements of j-th column.
!
               Work(j) = DASUM(j-1,B(1,j),1) + DASUM(j-1,B(j+1,1),Ldb)
            ENDDO
            IF ( B(1,1)==ZERO .AND. B(2,1)==ZERO ) B(1,1) = Eps3
            Work(1) = ZERO
!
            i1 = 1
            i2 = N
            i3 = 1
         ENDIF
!
         DO its = 1 , N
            scale = ONE
            vmax = ONE
            vcrit = Bignum
!
!           Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
!             or U**T*(xr,xi) = scale*(vr,vi) for a left eigenvector,
!           overwriting (xr,xi) on (vr,vi).
!
            DO i = i1 , i2 , i3
!
               IF ( Work(i)>vcrit ) THEN
                  rec = ONE/vmax
                  CALL DSCAL(N,rec,Vr,1)
                  CALL DSCAL(N,rec,Vi,1)
                  scale = scale*rec
                  vmax = ONE
                  vcrit = Bignum
               ENDIF
!
               xr = Vr(i)
               xi = Vi(i)
               IF ( Rightv ) THEN
                  DO j = i + 1 , N
                     xr = xr - B(i,j)*Vr(j) + B(j+1,i)*Vi(j)
                     xi = xi - B(i,j)*Vi(j) - B(j+1,i)*Vr(j)
                  ENDDO
               ELSE
                  DO j = 1 , i - 1
                     xr = xr - B(j,i)*Vr(j) + B(i+1,j)*Vi(j)
                     xi = xi - B(j,i)*Vi(j) - B(i+1,j)*Vr(j)
                  ENDDO
               ENDIF
!
               w = ABS(B(i,i)) + ABS(B(i+1,i))
               IF ( w>Smlnum ) THEN
                  IF ( w<ONE ) THEN
                     w1 = ABS(xr) + ABS(xi)
                     IF ( w1>w*Bignum ) THEN
                        rec = ONE/w1
                        CALL DSCAL(N,rec,Vr,1)
                        CALL DSCAL(N,rec,Vi,1)
                        xr = Vr(i)
                        xi = Vi(i)
                        scale = scale*rec
                        vmax = vmax*rec
                     ENDIF
                  ENDIF
!
!                 Divide by diagonal element of B.
!
                  CALL DLADIV(xr,xi,B(i,i),B(i+1,i),Vr(i),Vi(i))
                  vmax = MAX(ABS(Vr(i))+ABS(Vi(i)),vmax)
                  vcrit = Bignum/vmax
               ELSE
                  DO j = 1 , N
                     Vr(j) = ZERO
                     Vi(j) = ZERO
                  ENDDO
                  Vr(i) = ONE
                  Vi(i) = ONE
                  scale = ZERO
                  vmax = ONE
                  vcrit = Bignum
               ENDIF
            ENDDO
!
!           Test for sufficient growth in the norm of (VR,VI).
!
            vnorm = DASUM(N,Vr,1) + DASUM(N,Vi,1)
            IF ( vnorm>=growto*scale ) GOTO 100
!
!           Choose a new orthogonal starting vector and try again.
!
            y = Eps3/(rootn+ONE)
            Vr(1) = Eps3
            Vi(1) = ZERO
!
            DO i = 2 , N
               Vr(i) = y
               Vi(i) = ZERO
            ENDDO
            Vr(N-its+1) = Vr(N-its+1) - Eps3*rootn
         ENDDO
!
!        Failure to find eigenvector in N iterations
!
         Info = 1
!
!
!        Normalize eigenvector.
!
 100     vnorm = ZERO
         DO i = 1 , N
            vnorm = MAX(vnorm,ABS(Vr(i))+ABS(Vi(i)))
         ENDDO
         CALL DSCAL(N,ONE/vnorm,Vr,1)
         CALL DSCAL(N,ONE/vnorm,Vi,1)
!
      ENDIF
!
!
!     End of DLAEIN
!
      END SUBROUTINE DLAEIN


module imp_sw_schemes

use vartypes

	!************** Implizite Shallow Water Schemata *************************

	contains

	subroutine imp_onedswupwind(U, U0, x, dt, dx, theta, scheme, funcF, funcA, funcR, funcRi)
	! Loest die eindim Shallow Water Equation mit implizitem Upwind Scheme

	!Variablendeklaration
	implicit none
	type(t_vectorBlock), intent(in)			:: U0				! Startwerte
	type(t_vectorBlock), intent(inout)		:: U				! Loesungsvektoren
	real(dp), intent(in)					:: dt, dx			! delta x und delta t
	real(dp), dimension(:), intent(in)		:: x				! Ortsgitter
	integer, intent(in)						:: scheme			! waehlt das Schema: 0: Upwind, 1: TVD
	integer									:: xdim				! Dimension des Problems
	integer									:: i				! Laufvariable
	real(dp), intent(in)					:: theta			! theta = 0:explizit, =1/2:crank nicolson, =1:implizit
	real(dp)								:: k1, k2, k3		! Hilfsvariblen: (1-theta)dt/(2dx), (theta)dt/(2dx), dt/dx
	real(dp), dimension(2)					:: deltaUrechts, deltaUlinks
	real(dp), dimension(2)					:: Frechts, Flinks
	real(dp)								:: hRoerechts, hRoelinks, uRoerechts, uRoelinks		! Die Roe-Werte
	real(dp), dimension(2,2)				:: bAdachrechts, bAdachlinks						! Betrag von Adach
	real(dp), dimension(2,2)				:: Adachrechts, Adachlinks							! Adach
	real(dp), dimension(2,2)				:: tempR, tempA, tempRi
	real(dp), dimension(2)					:: tempU1, tempB
	type(t_vectorBlock)						:: right_B			! Rechte Seite der Gleichungen
	type(t_blockMatrixTridiag)				:: koeff_A			! Koeffizientenmatrix
	real(dp), dimension(2,2)				:: C, D, E			! Hilfsmatrizen zur Berechnung von koeff_A
	real(dp), dimension(2,2)				:: Eye				! Einheitsmatrix
	integer									:: iter				! Fuer die Defekt-Korrektur
	integer, parameter						:: itemin=10,itemax=100
	real(dp), parameter						:: tol=1d-8, eps=1d-14
	type(t_vectorBlock)						:: residuum, deltaU
	type(t_vectorScalar)					:: tempvec1, tempvec2
	real(dp)								:: dUnorm, Unorm, resnorm	! Norm des Residuums + Norm von (delta)U
	real(dp), dimension(2)					:: tempdeltaW, tempdeltaU				! fuer TVD
	real(dp), dimension(2)					:: deltaWdachrechts, deltaWdachlinks
	real(dp), dimension(2)					:: deltaWrechts, deltaWlinks
	real(dp), dimension(2,2)				:: Rrechts, Rlinks, Rirechts, Rilinks
	real(dp), dimension(2,2)				:: Lambdarechts, Lambdalinks
	integer									:: j
	real(dp)								:: hRoej, uRoej

	! Interfaces angeben
	interface
		! Funktion F aus der Shallow Water PDE
		subroutine funcF(F,q1,q2)
        use vartypes
		real(dp), intent(in)							:: q1, q2
		real(dp), dimension(2), intent(out)				:: F
		end subroutine funcF
		! diagonalisierte Jacobi Matrix der Funktion F aus der Shallow Water PDE
		subroutine funcA(A,q1,q2)
		use vartypes
		real(dp), intent(in)							:: q1, q2
		real(dp), dimension(2,2), intent(out)			:: A
		end subroutine funcA
		! Transformationsmatrix R
		subroutine funcR(R,q1,q2)
		use vartypes
		real(dp), intent(in)							:: q1, q2
		real(dp), dimension(2,2), intent(out)			:: R
		end subroutine funcR
		! Transformationsmatrix R^-1
		subroutine funcRi(Ri,q1,q2)
		use vartypes
		real(dp), intent(in)							:: q1, q2
		real(dp), dimension(2,2), intent(out)			:: Ri
		end subroutine funcRi
	end interface

	! Hilfsvariablen
	k1 = (1-theta)*dt/(2.0d0*dx)									! fuer den expliziten Teil (rechte Seite)
	k2 = theta*dt/(2.0d0*dx)										! fuer den impliziten Teil (linke Seite)
	k3 = dt/dx														! fuer TVD
	Eye = reshape( (/1.0d0, 0.0d0, 0.0d0, 1.0d0/), (/2, 2/) )		! Einheitsmatrix
	xdim = U0%Dvectorblock(1)%neq									! Dimension des Problems

	! U0 in U schreiben
	U%DvectorBlock(1)%datas = U0%DvectorBlock(1)%datas
	U%DvectorBlock(2)%datas = U0%DvectorBlock(2)%datas

	! Erstelle rechte Seite: 	right_B
	! und Koeffizientenmatrix:	koeff_A
	call make_vectorScalar(tempvec1,U0%Dvectorblock(1)%neq)
	call make_vectorScalar(tempvec2,U0%Dvectorblock(1)%neq)
	call make_vectorBlock(right_B,U0%nblocks,U0%Dvectorblock(1)%neq)
	call make_vectorBlock(residuum,U0%nblocks,U0%Dvectorblock(1)%neq)
	call make_vectorBlock(deltaU,U0%nblocks,U0%Dvectorblock(1)%neq)
	call make_blockMatrixTridiag(koeff_A,2*U0%nblocks,U0%Dvectorblock(1)%neq)

	! Berechne die rechte Seite der Gleichungen: right_B
	call create_right_side

	! testweise die Koeffizientenmatrix ausgeben
	!call create_koeff_Matrix
	!write(*,*) koeff_A%trimat(1)%upper%datas
	!write(*,*) koeff_A%trimat(1)%main%datas
	!write(*,*) koeff_A%trimat(1)%lower%datas
	!write(*,*) koeff_A%trimat(2)%upper%datas
	!write(*,*) koeff_A%trimat(2)%main%datas
	!write(*,*) koeff_A%trimat(2)%lower%datas

	! Jetzt loese mit Defektkorrektur
	iter=0
	defect_iter: do
		! neue Koeffizientenmatrix berechnen
		call create_koeff_Matrix

		! Residuum berechnen
		call create_Residuum

		! Loese das Gleichungssystem fuer deltaU
		call linSolvThomas(koeff_A%trimat(1),residuum%DvectorBlock(1),deltaU%DvectorBlock(1))
		call linSolvThomas(koeff_A%trimat(2),residuum%DvectorBlock(2),deltaU%DvectorBlock(2))

		! Addiere deltaU
		U%DvectorBlock(1)%datas = U%DvectorBlock(1)%datas + deltaU%DvectorBlock(1)%datas
		U%DvectorBlock(2)%datas = U%DvectorBlock(2)%datas + deltaU%DvectorBlock(2)%datas

		! Abbruchkriterium
		iter=iter+1
		resnorm = sum(abs(residuum%DvectorBlock(1)%datas))+ sum(abs(residuum%DvectorBlock(2)%datas))
		dUnorm  = sum(abs(deltaU%DvectorBlock(1)%datas))  + sum(abs(deltaU%DvectorBlock(2)%datas))
		Unorm   = sum(abs(U%DvectorBlock(1)%datas))       + sum(abs(U%DvectorBlock(2)%datas))
		if ((iter>itemin).and.( (resnorm<tol).or.(dUnorm/Unorm<eps) )) then
			exit defect_iter
		else
			if (iter>itemax) then
			write(*,*) 'Defekt-Korrektur: Warnung, keine Konvergenz!'
			exit defect_iter
			end if
		end if
	end do defect_iter

	! gebe Anzahl der Iterationen aus
	!write(*,*) iter

	! Gib Speicher frei
	call unmake_vectorScalar(tempvec1)
	call unmake_vectorScalar(tempvec2)
	call unmake_vectorBlock(right_B)			! rechte Seite
	call unmake_vectorBlock(residuum)
	call unmake_vectorBlock(deltaU)
	call unmake_blockMatrixTridiag(koeff_A)		! Koeffizientenmatrix

	contains

	subroutine create_right_side		! Berechnet die rechte Seite und speichert sie in right_B
		implicit none
		integer					:: i	! Laufvariable

		if (scheme==0) then		! Upwind

		! Eintraege fuer die Randwerte
		right_B%Dvectorblock(1)%datas(1) = U0%Dvectorblock(1)%datas(1)
		right_B%Dvectorblock(2)%datas(1) = U0%Dvectorblock(2)%datas(1)
		right_B%Dvectorblock(1)%datas(U0%Dvectorblock(1)%neq) = &
					    U0%Dvectorblock(1)%datas(U0%Dvectorblock(1)%neq)
		right_B%Dvectorblock(2)%datas(U0%Dvectorblock(2)%neq) = &
						U0%Dvectorblock(2)%datas(U0%Dvectorblock(2)%neq)

		! Die inneren Eintraege der rechten Seite berechnen
		do i=2, U0%Dvectorblock(1)%neq-1

			! Berechne einige Hilfsvariablen
			deltaUrechts(1) = U0%Dvectorblock(1)%datas(i+1) - U0%Dvectorblock(1)%datas(i)
			deltaUrechts(2) = U0%Dvectorblock(2)%datas(i+1) - U0%Dvectorblock(2)%datas(i)
			deltaUlinks(1)  = U0%Dvectorblock(1)%datas(i) - U0%Dvectorblock(1)%datas(i-1)
			deltaUlinks(2)  = U0%Dvectorblock(2)%datas(i) - U0%Dvectorblock(2)%datas(i-1)

			hRoerechts = sqrt(U0%Dvectorblock(1)%datas(i+1)*U0%Dvectorblock(1)%datas(i))
			hRoelinks  = sqrt(U0%Dvectorblock(1)%datas(i)*U0%Dvectorblock(1)%datas(i-1))
			uRoerechts = (1/sqrt(U0%Dvectorblock(1)%datas(i))*U0%Dvectorblock(2)%datas(i)+ &
						1/sqrt(U0%Dvectorblock(1)%datas(i+1))*U0%Dvectorblock(2)%datas(i+1))/ &
						(sqrt(U0%Dvectorblock(1)%datas(i))+sqrt(U0%Dvectorblock(1)%datas(i+1)))
			uRoelinks  = (1/sqrt(U0%Dvectorblock(1)%datas(i-1))*U0%Dvectorblock(2)%datas(i-1)+ &
						1/sqrt(U0%Dvectorblock(1)%datas(i))*U0%Dvectorblock(2)%datas(i))/ &
						(sqrt(U0%Dvectorblock(1)%datas(i-1))+sqrt(U0%Dvectorblock(1)%datas(i)))

			call funcR(tempR,hRoerechts,hRoerechts*uRoerechts)
			call funcA(tempA,hRoerechts,hRoerechts*uRoerechts)
			call funcRi(tempRi,hRoerechts,hRoerechts*uRoerechts)
			bAdachrechts = matmul(tempR,matmul(abs(tempA),tempRi))

			call funcR(tempR,hRoelinks,hRoelinks*uRoelinks)
			call funcA(tempA,hRoelinks,hRoelinks*uRoelinks)
			call funcRi(tempRi,hRoelinks,hRoelinks*uRoelinks)
			bAdachlinks = matmul(tempR,matmul(abs(tempA),tempRi))

			call funcF(Frechts,U0%Dvectorblock(1)%datas(i+1),U0%Dvectorblock(2)%datas(i+1))
			call funcF(Flinks,U0%Dvectorblock(1)%datas(i-1),U0%Dvectorblock(2)%datas(i-1))

			tempU1(1) = U0%Dvectorblock(1)%datas(i)
			tempU1(2) = U0%Dvectorblock(2)%datas(i)

			! hier werden die Vektoren berechnet
			tempB = tempU1 - k1*(Frechts-Flinks-matmul(bAdachrechts,deltaUrechts)+ &
					matmul(bAdachlinks,deltaUlinks))

			! und hier abgespeichert
			right_B%Dvectorblock(1)%datas(i) = tempB(1)
			right_B%Dvectorblock(2)%datas(i) = tempB(2)

		end do
		! rechte Seite fertig: right_B

		else		! TVD

		! Eintraege fuer die Randwerte
		right_B%Dvectorblock(1)%datas(1) = U0%Dvectorblock(1)%datas(1)
		right_B%Dvectorblock(1)%datas(2) = U0%Dvectorblock(1)%datas(2)
		right_B%Dvectorblock(2)%datas(1) = U0%Dvectorblock(2)%datas(1)
		right_B%Dvectorblock(2)%datas(2) = U0%Dvectorblock(2)%datas(2)

		right_B%Dvectorblock(1)%datas(U0%Dvectorblock(1)%neq) = &
					    U0%Dvectorblock(1)%datas(U0%Dvectorblock(1)%neq)
		right_B%Dvectorblock(1)%datas(U0%Dvectorblock(1)%neq-1) = &
					    U0%Dvectorblock(1)%datas(U0%Dvectorblock(1)%neq-1)
		right_B%Dvectorblock(2)%datas(U0%Dvectorblock(2)%neq) = &
						U0%Dvectorblock(2)%datas(U0%Dvectorblock(2)%neq)
		right_B%Dvectorblock(2)%datas(U0%Dvectorblock(2)%neq-1) = &
						U0%Dvectorblock(2)%datas(U0%Dvectorblock(2)%neq-1)

		! Loesungsschleife um alle inneren Werte zu berechnen
		do i=3, U0%Dvectorblock(1)%neq-2

			! Berechne einige Hilfsvariablen
			deltaUrechts(1) = U0%Dvectorblock(1)%datas(i+1) - U0%Dvectorblock(1)%datas(i)
			deltaUrechts(2) = U0%Dvectorblock(2)%datas(i+1) - U0%Dvectorblock(2)%datas(i)
			deltaUlinks(1)  = U0%Dvectorblock(1)%datas(i) - U0%Dvectorblock(1)%datas(i-1)
			deltaUlinks(2)  = U0%Dvectorblock(2)%datas(i) - U0%Dvectorblock(2)%datas(i-1)

			hRoerechts = sqrt(U0%Dvectorblock(1)%datas(i+1)*U0%Dvectorblock(1)%datas(i))
			hRoelinks  = sqrt(U0%Dvectorblock(1)%datas(i)*U0%Dvectorblock(1)%datas(i-1))
			uRoerechts = (1/sqrt(U0%Dvectorblock(1)%datas(i))*U0%Dvectorblock(2)%datas(i)+ &
						1/sqrt(U0%Dvectorblock(1)%datas(i+1))*U0%Dvectorblock(2)%datas(i+1))/ &
						(sqrt(U0%Dvectorblock(1)%datas(i))+sqrt(U0%Dvectorblock(1)%datas(i+1)))
			uRoelinks  = (1/sqrt(U0%Dvectorblock(1)%datas(i-1))*U0%Dvectorblock(2)%datas(i-1)+ &
						1/sqrt(U0%Dvectorblock(1)%datas(i))*U0%Dvectorblock(2)%datas(i))/ &
						(sqrt(U0%Dvectorblock(1)%datas(i-1))+sqrt(U0%Dvectorblock(1)%datas(i)))

			call funcR(Rrechts,hRoerechts,hRoerechts*uRoerechts)
			call funcA(Lambdarechts,hRoerechts,hRoerechts*uRoerechts)
			call funcRi(Rirechts,hRoerechts,hRoerechts*uRoerechts)
			bAdachrechts = matmul(Rrechts,matmul(abs(Lambdarechts),Rirechts))

			call funcR(Rlinks,hRoelinks,hRoelinks*uRoelinks)
			call funcA(Lambdalinks,hRoelinks,hRoelinks*uRoelinks)
			call funcRi(Rilinks,hRoelinks,hRoelinks*uRoelinks)
			bAdachlinks = matmul(Rlinks,matmul(abs(Lambdalinks),Rilinks))

			call funcF(Frechts,U0%Dvectorblock(1)%datas(i+1),U0%Dvectorblock(2)%datas(i+1))
			call funcF(Flinks,U0%Dvectorblock(1)%datas(i-1),U0%Dvectorblock(2)%datas(i-1))

			! fuer tvd

			deltaWrechts = matmul(Rirechts,deltaUrechts)
			deltaWlinks  = matmul(Rilinks ,deltaUlinks )

			! berechne die rechten slope ratios und damit deltaWdach rechts
			j=i-nint(sign(1d0,Lambdarechts(1,1)))
			hRoej = sqrt(U0%Dvectorblock(1)%datas(j+1)*U0%Dvectorblock(1)%datas(j))
			uRoej = (1/sqrt(U0%Dvectorblock(1)%datas(j))*U0%Dvectorblock(2)%datas(j)+ &
						1/sqrt(U0%Dvectorblock(1)%datas(j+1))*U0%Dvectorblock(2)%datas(j+1))/ &
						(sqrt(U0%Dvectorblock(1)%datas(j))+sqrt(U0%Dvectorblock(1)%datas(j+1)))
			call funcRi(tempRi,hRoej,hRoej*uRoej)
			tempdeltaU(1) = U0%Dvectorblock(1)%datas(j+1) - U0%Dvectorblock(1)%datas(j)
			tempdeltaU(2) = U0%Dvectorblock(2)%datas(j+1) - U0%Dvectorblock(2)%datas(j)
			tempdeltaW = matmul(tempRi,tempdeltaU)
			!deltaWdachrechts(1)=deltaWrechts(1)*limiterfunc(tempdeltaW(1),deltaWrechts(1))
			deltaWdachrechts(1)=limiterfunc2(tempdeltaW(1),deltaWrechts(1))

			j=i-nint(sign(1d0,Lambdarechts(2,2)))
			hRoej = sqrt(U0%Dvectorblock(1)%datas(j+1)*U0%Dvectorblock(1)%datas(j))
			uRoej = (1/sqrt(U0%Dvectorblock(1)%datas(j))*U0%Dvectorblock(2)%datas(j)+ &
						1/sqrt(U0%Dvectorblock(1)%datas(j+1))*U0%Dvectorblock(2)%datas(j+1))/ &
						(sqrt(U0%Dvectorblock(1)%datas(j))+sqrt(U0%Dvectorblock(1)%datas(j+1)))
			call funcRi(tempRi,hRoej,hRoej*uRoej)
			tempdeltaU(1) = U0%Dvectorblock(1)%datas(j+1) - U0%Dvectorblock(1)%datas(j)
			tempdeltaU(2) = U0%Dvectorblock(2)%datas(j+1) - U0%Dvectorblock(2)%datas(j)
			tempdeltaW = matmul(tempRi,tempdeltaU)
			!deltaWdachrechts(2)=deltaWrechts(2)*limiterfunc(tempdeltaW(2),deltaWrechts(2))
			deltaWdachrechts(2)=limiterfunc2(tempdeltaW(2),deltaWrechts(2))

			! berechne die linken slope ratios und damit deltaWdach links
			j=i-1-nint(sign(1d0,Lambdalinks(1,1)))
			hRoej = sqrt(U0%Dvectorblock(1)%datas(j+1)*U0%Dvectorblock(1)%datas(j))
			uRoej = (1/sqrt(U0%Dvectorblock(1)%datas(j))*U0%Dvectorblock(2)%datas(j)+ &
						1/sqrt(U0%Dvectorblock(1)%datas(j+1))*U0%Dvectorblock(2)%datas(j+1))/ &
						(sqrt(U0%Dvectorblock(1)%datas(j))+sqrt(U0%Dvectorblock(1)%datas(j+1)))
			call funcRi(tempRi,hRoej,hRoej*uRoej)
			tempdeltaU(1) = U0%Dvectorblock(1)%datas(j+1) - U0%Dvectorblock(1)%datas(j)
			tempdeltaU(2) = U0%Dvectorblock(2)%datas(j+1) - U0%Dvectorblock(2)%datas(j)
			tempdeltaW = matmul(tempRi,tempdeltaU)
			!deltaWdachlinks(1)=deltaWlinks(1)*limiterfunc(tempdeltaw(1),deltaWlinks(1))
			deltaWdachlinks(1)=limiterfunc2(tempdeltaw(1),deltaWlinks(1))

			j=i-1-nint(sign(1d0,Lambdalinks(2,2)))
			hRoej = sqrt(U0%Dvectorblock(1)%datas(j+1)*U0%Dvectorblock(1)%datas(j))
			uRoej = (1/sqrt(U0%Dvectorblock(1)%datas(j))*U0%Dvectorblock(2)%datas(j)+ &
						1/sqrt(U0%Dvectorblock(1)%datas(j+1))*U0%Dvectorblock(2)%datas(j+1))/ &
						(sqrt(U0%Dvectorblock(1)%datas(j))+sqrt(U0%Dvectorblock(1)%datas(j+1)))
			call funcRi(tempRi,hRoej,hRoej*uRoej)
			tempdeltaU(1) = U0%Dvectorblock(1)%datas(j+1) - U0%Dvectorblock(1)%datas(j)
			tempdeltaU(2) = U0%Dvectorblock(2)%datas(j+1) - U0%Dvectorblock(2)%datas(j)
			tempdeltaW = matmul(tempRi,tempdeltaU)
			!deltaWdachlinks(2)=deltaWlinks(2)*limiterfunc(tempdeltaw(2),deltaWlinks(2))
			deltaWdachlinks(2)=limiterfunc2(tempdeltaw(2),deltaWlinks(2))

			tempU1(1) = U0%Dvectorblock(1)%datas(i)
			tempU1(2) = U0%Dvectorblock(2)%datas(i)

			! rechte Seite berechnen
			tempB = tempU1 - k1*(Frechts-Flinks-matmul(bAdachrechts,deltaUrechts)+ &									! Der Roe-Upwind Teil
					matmul(bAdachlinks,deltaUlinks)+&
					!										  -k3*matmul(Lambdarechts,Lambdarechts)   wuerde noch bei expl. TVD da stehen
					( matmul(matmul(Rrechts,(abs(Lambdarechts)                                      )),deltaWdachrechts)&		! der zusaetzliche LW-Teil
					 -matmul(matmul(Rlinks ,(abs(Lambdalinks )                                      )),deltaWdachlinks) ) )	! inklusive Limiter in deltaWdach
					 !										  -k3*matmul(Lambdalinks ,Lambdalinks )   wuerde noch bei expl. TVD da stehen

			! rechte Seite abspeichern
			right_B%Dvectorblock(1)%datas(i) = tempB(1)
			right_B%Dvectorblock(2)%datas(i) = tempB(2)

	end do
		end if
	end subroutine create_right_side

	subroutine create_koeff_Matrix				! erstellt die aktuelle Koeffizientenmatrix und speichert sie in koeff_A
	implicit none
	integer					:: i	! Laufvariable

	! Zuerst schreibe die Eintraege fuer die Randwerte
	! fuer die Hauptdiagonalmatrizen
	koeff_A%trimat(1)%main%datas(1)=1.0d0
	koeff_A%trimat(2)%main%datas(1)=1.0d0
	koeff_A%trimat(1)%main%datas(xdim)=1.0d0
	koeff_A%trimat(2)%main%datas(xdim)=1.0d0
	koeff_A%trimat(1)%upper%datas(1)=0.0d0
	koeff_A%trimat(2)%upper%datas(1)=0.0d0
	koeff_A%trimat(1)%lower%datas(xdim-1)=0.0d0
	koeff_A%trimat(2)%lower%datas(xdim-1)=0.0d0
	! fuer die Nebendiagonalmatrizen
	koeff_A%trimat(3)%main%datas(1)=0.0d0
	koeff_A%trimat(4)%main%datas(1)=0.0d0
	koeff_A%trimat(3)%main%datas(xdim)=0.0d0
	koeff_A%trimat(4)%main%datas(xdim)=0.0d0
	koeff_A%trimat(3)%upper%datas(1)=0.0d0
	koeff_A%trimat(4)%upper%datas(1)=0.0d0
	koeff_A%trimat(3)%lower%datas(xdim-1)=0.0d0
	koeff_A%trimat(4)%lower%datas(xdim-1)=0.0d0

	! Nun berechne die inneren Eintraege
	do i=2, xdim-1

			! Berechne einige Hilfsvariablen
			hRoerechts = sqrt(U%Dvectorblock(1)%datas(i+1)*U%Dvectorblock(1)%datas(i))
			hRoelinks  = sqrt(U%Dvectorblock(1)%datas(i)*U%Dvectorblock(1)%datas(i-1))
			uRoerechts = (1/sqrt(U%Dvectorblock(1)%datas(i))*U%Dvectorblock(2)%datas(i)+ &
						1/sqrt(U%Dvectorblock(1)%datas(i+1))*U%Dvectorblock(2)%datas(i+1))/ &
						(sqrt(U%Dvectorblock(1)%datas(i))+sqrt(U%Dvectorblock(1)%datas(i+1)))
			uRoelinks  = (1/sqrt(U%Dvectorblock(1)%datas(i-1))*U%Dvectorblock(2)%datas(i-1)+ &
						1/sqrt(U%Dvectorblock(1)%datas(i))*U%Dvectorblock(2)%datas(i))/ &
						(sqrt(U%Dvectorblock(1)%datas(i-1))+sqrt(U%Dvectorblock(1)%datas(i)))

			call funcR(tempR,hRoerechts,hRoerechts*uRoerechts)
			call funcA(tempA,hRoerechts,hRoerechts*uRoerechts)
			call funcRi(tempRi,hRoerechts,hRoerechts*uRoerechts)
			Adachrechts  = matmul(tempR,matmul(tempA,tempRi))
			bAdachrechts = matmul(tempR,matmul(abs(tempA),tempRi))

			call funcR(tempR,hRoelinks,hRoelinks*uRoelinks)
			call funcA(tempA,hRoelinks,hRoelinks*uRoelinks)
			call funcRi(tempRi,hRoelinks,hRoelinks*uRoelinks)
			Adachlinks  = matmul(tempR,matmul(tempA,tempRi))
			bAdachlinks = matmul(tempR,matmul(abs(tempA),tempRi))

			! hier werden die lokalen Hilfsmatrizen C,D,E berechnet, die spaeter in koeff_A geschrieben werden
			C = k2*(-Adachlinks-bAdachlinks)
			D = Eye + k2*(-Adachrechts+Adachlinks+bAdachrechts+bAdachlinks)
			E = k2*(Adachrechts-bAdachrechts)

			! hier werden die Hilfsmatrizen in koeff_A geschrieben
			! in die Matrizen auf der Hauptdiagonalen
			koeff_A%trimat(1)%main%datas(i)    = D(1,1)			! Hauptdiagonale
			koeff_A%trimat(2)%main%datas(i)    = D(2,2)
			koeff_A%trimat(1)%upper%datas(i)   = E(1,1)			! obere Diagonale
			koeff_A%trimat(2)%upper%datas(i)   = E(2,2)
			koeff_A%trimat(1)%lower%datas(i-1) = C(1,1)			! untere Diagonale
			koeff_A%trimat(2)%lower%datas(i-1) = C(2,2)
			! in die Matrizen auf der Nebendiagonalen
			koeff_A%trimat(3)%main%datas(i)    = D(1,2)			! Hauptdiagonale
			koeff_A%trimat(4)%main%datas(i)    = D(2,1)
			koeff_A%trimat(3)%upper%datas(i)   = E(1,2)			! obere Diagonale
			koeff_A%trimat(4)%upper%datas(i)   = E(2,1)
			koeff_A%trimat(3)%lower%datas(i-1) = C(1,2)			! untere Diagonale
			koeff_A%trimat(4)%lower%datas(i-1) = C(2,1)
			! die Matrix-Bloecke sind jetzt wie folgt angeordnet:	koeff_A%trimat(1) koeff_A%trimat(3)
			!														koeff_A%trimat(4) koeff_A%trimat(2)

		end do
		! Koeffizientenmatrix fertig: koeff_A
	end subroutine create_koeff_Matrix

	! Limiter Funktion fuer TVD
	real(dp) function limiterfunc2(z,n)
    	implicit none
		real(dp), intent(in)		:: z, n				! Zaehler und Nenner des Slope Ratios
		integer, parameter			:: limiter = 3		! Wahl des Limiters (1 = Minmod, 4 = Superbee)
		real(dp)					:: h1				! Hilfsvariable

		h1 = (sign(1.0d0,z)+sign(1.0d0,n))/2.0d0

		select case(limiter)
			case(1)
					limiterfunc2 = h1*min(abs(z),abs(n))									! MinMod
			case(2)
					if (abs(z)+abs(n)>0.001d0) then											! Van Leer
						limiterfunc2 = h1*2.0d0*abs(z*n)/(abs(n)+abs(z))
					else
						limiterfunc2 = 0d0
					end if
			case(3)
					limiterfunc2=h1*min(2.0d0*abs(z),(abs(z)+abs(n))/2.0d0,2.0d0*abs(n))	! MC
			case(4)
					limiterfunc2=h1*max(min(2.0d0*abs(z),abs(n)),min(abs(z),2.0d0*abs(n)))	!Superbee
		end select
    end function limiterfunc2

    ! Residuum berechnen
    subroutine create_Residuum
    implicit none
    integer					:: i

	if (scheme==0) then				! Upwind-Residuum
    	call MatVecMul(koeff_A%trimat(1),U%DvectorBlock(1),tempvec1)
		call MatVecMul(koeff_A%trimat(3),U%DvectorBlock(2),tempvec2)
		residuum%DvectorBlock(1)%datas = right_B%DvectorBlock(1)%datas - tempvec1%datas - tempvec2%datas
		call MatVecMul(koeff_A%trimat(2),U%DvectorBlock(2),tempvec1)
		call MatVecMul(koeff_A%trimat(4),U%DvectorBlock(1),tempvec2)
		residuum%DvectorBlock(2)%datas = right_B%DvectorBlock(2)%datas - tempvec1%datas - tempvec2%datas

	else							! TVD-Residuum
		! Zuerst uebernehme die Eintraege fuer die Randwerte
		residuum%DvectorBlock(1)%datas(1) = 0
		residuum%DvectorBlock(2)%datas(1) = 0
		residuum%DvectorBlock(1)%datas(2) = 0
		residuum%DvectorBlock(2)%datas(2) = 0
		residuum%DvectorBlock(1)%datas(xdim-1) = 0
		residuum%DvectorBlock(2)%datas(xdim-1) = 0
		residuum%DvectorBlock(1)%datas(xdim) = 0
		residuum%DvectorBlock(2)%datas(xdim) = 0

		! Schleife um alle inneren Werte zu berechnen
		do i=3, U%Dvectorblock(1)%neq-2

			! Berechne einige Hilfsvariablen
			deltaUrechts(1) = U0%Dvectorblock(1)%datas(i+1) - U%Dvectorblock(1)%datas(i)
			deltaUrechts(2) = U0%Dvectorblock(2)%datas(i+1) - U%Dvectorblock(2)%datas(i)
			deltaUlinks(1)  = U0%Dvectorblock(1)%datas(i) - U%Dvectorblock(1)%datas(i-1)
			deltaUlinks(2)  = U0%Dvectorblock(2)%datas(i) - U%Dvectorblock(2)%datas(i-1)

			hRoerechts = sqrt(U%Dvectorblock(1)%datas(i+1)*U%Dvectorblock(1)%datas(i))
			hRoelinks  = sqrt(U%Dvectorblock(1)%datas(i)*U%Dvectorblock(1)%datas(i-1))
			uRoerechts = (1/sqrt(U%Dvectorblock(1)%datas(i))*U%Dvectorblock(2)%datas(i)+ &
						1/sqrt(U%Dvectorblock(1)%datas(i+1))*U%Dvectorblock(2)%datas(i+1))/ &
						(sqrt(U%Dvectorblock(1)%datas(i))+sqrt(U%Dvectorblock(1)%datas(i+1)))
			uRoelinks  = (1/sqrt(U%Dvectorblock(1)%datas(i-1))*U%Dvectorblock(2)%datas(i-1)+ &
						1/sqrt(U%Dvectorblock(1)%datas(i))*U%Dvectorblock(2)%datas(i))/ &
						(sqrt(U%Dvectorblock(1)%datas(i-1))+sqrt(U%Dvectorblock(1)%datas(i)))

			call funcR(Rrechts,hRoerechts,hRoerechts*uRoerechts)
			call funcA(Lambdarechts,hRoerechts,hRoerechts*uRoerechts)
			call funcRi(Rirechts,hRoerechts,hRoerechts*uRoerechts)
			bAdachrechts = matmul(Rrechts,matmul(abs(Lambdarechts),Rirechts))

			call funcR(Rlinks,hRoelinks,hRoelinks*uRoelinks)
			call funcA(Lambdalinks,hRoelinks,hRoelinks*uRoelinks)
			call funcRi(Rilinks,hRoelinks,hRoelinks*uRoelinks)
			bAdachlinks = matmul(Rlinks,matmul(abs(Lambdalinks),Rilinks))

			call funcF(Frechts,U%Dvectorblock(1)%datas(i+1),U%Dvectorblock(2)%datas(i+1))
			call funcF(Flinks,U%Dvectorblock(1)%datas(i-1),U%Dvectorblock(2)%datas(i-1))

			! fuer tvd

			deltaWrechts = matmul(Rirechts,deltaUrechts)
			deltaWlinks  = matmul(Rilinks ,deltaUlinks )

			! berechne die rechten slope ratios und damit deltaWdach rechts
			j=i-nint(sign(1d0,Lambdarechts(1,1)))
			hRoej = sqrt(U%Dvectorblock(1)%datas(j+1)*U%Dvectorblock(1)%datas(j))
			uRoej = (1/sqrt(U%Dvectorblock(1)%datas(j))*U%Dvectorblock(2)%datas(j)+ &
						1/sqrt(U%Dvectorblock(1)%datas(j+1))*U%Dvectorblock(2)%datas(j+1))/ &
						(sqrt(U%Dvectorblock(1)%datas(j))+sqrt(U%Dvectorblock(1)%datas(j+1)))
			call funcRi(tempRi,hRoej,hRoej*uRoej)
			tempdeltaU(1) = U%Dvectorblock(1)%datas(j+1) - U%Dvectorblock(1)%datas(j)
			tempdeltaU(2) = U%Dvectorblock(2)%datas(j+1) - U%Dvectorblock(2)%datas(j)
			tempdeltaW = matmul(tempRi,tempdeltaU)
			!deltaWdachrechts(1)=deltaWrechts(1)*limiterfunc(tempdeltaW(1),deltaWrechts(1))
			deltaWdachrechts(1)=limiterfunc2(tempdeltaW(1),deltaWrechts(1))

			j=i-nint(sign(1d0,Lambdarechts(2,2)))
			hRoej = sqrt(U%Dvectorblock(1)%datas(j+1)*U%Dvectorblock(1)%datas(j))
			uRoej = (1/sqrt(U%Dvectorblock(1)%datas(j))*U%Dvectorblock(2)%datas(j)+ &
						1/sqrt(U%Dvectorblock(1)%datas(j+1))*U%Dvectorblock(2)%datas(j+1))/ &
						(sqrt(U%Dvectorblock(1)%datas(j))+sqrt(U%Dvectorblock(1)%datas(j+1)))
			call funcRi(tempRi,hRoej,hRoej*uRoej)
			tempdeltaU(1) = U%Dvectorblock(1)%datas(j+1) - U%Dvectorblock(1)%datas(j)
			tempdeltaU(2) = U%Dvectorblock(2)%datas(j+1) - U%Dvectorblock(2)%datas(j)
			tempdeltaW = matmul(tempRi,tempdeltaU)
			!deltaWdachrechts(2)=deltaWrechts(2)*limiterfunc(tempdeltaW(2),deltaWrechts(2))
			deltaWdachrechts(2)=limiterfunc2(tempdeltaW(2),deltaWrechts(2))

			! berechne die linken slope ratios und damit deltaWdach links
			j=i-1-nint(sign(1d0,Lambdalinks(1,1)))
			hRoej = sqrt(U%Dvectorblock(1)%datas(j+1)*U%Dvectorblock(1)%datas(j))
			uRoej = (1/sqrt(U%Dvectorblock(1)%datas(j))*U%Dvectorblock(2)%datas(j)+ &
						1/sqrt(U%Dvectorblock(1)%datas(j+1))*U%Dvectorblock(2)%datas(j+1))/ &
						(sqrt(U%Dvectorblock(1)%datas(j))+sqrt(U%Dvectorblock(1)%datas(j+1)))
			call funcRi(tempRi,hRoej,hRoej*uRoej)
			tempdeltaU(1) = U%Dvectorblock(1)%datas(j+1) - U%Dvectorblock(1)%datas(j)
			tempdeltaU(2) = U%Dvectorblock(2)%datas(j+1) - U%Dvectorblock(2)%datas(j)
			tempdeltaW = matmul(tempRi,tempdeltaU)
			!deltaWdachlinks(1)=deltaWlinks(1)*limiterfunc(tempdeltaw(1),deltaWlinks(1))
			deltaWdachlinks(1)=limiterfunc2(tempdeltaw(1),deltaWlinks(1))

			j=i-1-nint(sign(1d0,Lambdalinks(2,2)))
			hRoej = sqrt(U%Dvectorblock(1)%datas(j+1)*U%Dvectorblock(1)%datas(j))
			uRoej = (1/sqrt(U%Dvectorblock(1)%datas(j))*U%Dvectorblock(2)%datas(j)+ &
						1/sqrt(U%Dvectorblock(1)%datas(j+1))*U%Dvectorblock(2)%datas(j+1))/ &
						(sqrt(U%Dvectorblock(1)%datas(j))+sqrt(U%Dvectorblock(1)%datas(j+1)))
			call funcRi(tempRi,hRoej,hRoej*uRoej)
			tempdeltaU(1) = U%Dvectorblock(1)%datas(j+1) - U%Dvectorblock(1)%datas(j)
			tempdeltaU(2) = U%Dvectorblock(2)%datas(j+1) - U%Dvectorblock(2)%datas(j)
			tempdeltaW = matmul(tempRi,tempdeltaU)
			!deltaWdachlinks(2)=deltaWlinks(2)*limiterfunc(tempdeltaw(2),deltaWlinks(2))
			deltaWdachlinks(2)=limiterfunc2(tempdeltaw(2),deltaWlinks(2))

			tempU1(1) = U%Dvectorblock(1)%datas(i)
			tempU1(2) = U%Dvectorblock(2)%datas(i)

			! berechne, was von der rechten Seite abgezogen werden muss
			tempB = tempU1 + k2*(Frechts-Flinks-matmul(bAdachrechts,deltaUrechts)+ &									! Der Roe-Upwind Teil
					matmul(bAdachlinks,deltaUlinks)+&
					!										  -k3*matmul(Lambdarechts,Lambdarechts)   wuerde noch bei expl. TVD da stehen
					( matmul(matmul(Rrechts,(abs(Lambdarechts)                                      )),deltaWdachrechts)&		! der zusaetzliche LW-Teil
					 -matmul(matmul(Rlinks ,(abs(Lambdalinks )                                      )),deltaWdachlinks) ) )	! inklusive Limiter in deltaWdach
					 !										  -k3*matmul(Lambdalinks ,Lambdalinks )   wuerde noch bei expl. TVD da stehen

			! Residuum berechnen und abspeichern
			residuum%DvectorBlock(1)%datas(i) = right_B%DvectorBlock(1)%datas(i)-tempB(1)
			residuum%DvectorBlock(2)%datas(i) = right_B%DvectorBlock(2)%datas(i)-tempB(2)

	end do

	end if
    end subroutine create_Residuum

	end subroutine imp_onedswupwind

end module imp_sw_schemes


module stereo_project

character(len=32) :: project_mode
character(len=512) :: input_file
character(len=512) :: output_file
double precision :: lon0
double precision :: lat0
double precision :: radius_sphere

end module

!==================================================================================================!

program main

use io, only: stderr, fileExists
use map, only: stereo

use stereo_project, only: project_mode, &
                          input_file, &
                          output_file, &
                          lon0, &
                          lat0, &
                          radius_sphere

implicit none

! Local variables
character(len=128) :: line
integer :: ios, ierr, luin, luout
double precision :: lon, lat, x, y

! Parse command line
call gcmdln()
!write(0,*) trim(input_file)
!write(0,*) trim(output_file)
!write(0,*) trim(mode)
!write(0,*) lon0
!write(0,*) lat0
!write(0,*) radius

if (input_file.eq.'stdin') then
    luin = 5
else
    if (.not.fileExists(input_file)) then
        call usage('stereo_project: no input file found named '//trim(input_file))
    endif
    luin = 11
    open(unit=11,file=input_file,status='old')
endif

if (trim(output_file).eq.'stdout') then
    luout = 6
else
    luout = 12
    open(unit=12,file=output_file,status='unknown')
endif

! Stereographic projection or inverse
do
    read(luin,'(A)',iostat=ios) line
    if (ios.ne.0) then
        exit
    endif

    if (project_mode.eq.'geo2stereo') then
        read(line,*,iostat=ios) lon, lat
        if (ios.ne.0) then
            write(stderr,*) 'stereo_project: error parsing lon lat from line'
            call usage(trim(line))
        endif

        call stereo(lon,lat,x,y,lon0,lat0,radius_sphere,'lonlat2xy',ierr)
        if (ierr.ne.0) then
            call usage('stereo_project: error computing stereographic projection')
        endif

        write(luout,*) x, y

    elseif (project_mode.eq.'stereo2geo') then
        read(line,*,iostat=ios) x, y
        if (ios.ne.0) then
            write(stderr,*) 'stereo_project: error parsing x y from line'
            call usage(trim(line))
        endif

        call stereo(lon,lat,x,y,lon0,lat0,radius_sphere,'xy2lonlat',ierr)
        if (ierr.ne.0) then
            call usage('stereo_project: error computing inverse stereographic projection')
        endif

        write(luout,*) lon, lat

    else
        call usage('stereo_project: project_mode must be "geo2stereo" or "stereo2geo"')
    endif
enddo

end

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

subroutine gcmdln()

use io, only: stderr
use earth, only: radius_earth_km

use stereo_project, only: project_mode, &
                          input_file, &
                          output_file, &
                          lon0, &
                          lat0, &
                          radius_sphere

implicit none

! Local variables
integer :: i, narg
character(len=1024) :: tag

project_mode = ''
input_file = 'stdin'
output_file = 'stdout'
lon0 = 1.0d3
lat0 = 1.0d3
radius_sphere = radius_earth_km

narg = command_argument_count()
if (narg.eq.0) then
    call usage('')
endif

i = 1

do while (i.le.narg)

    call get_command_argument(i,tag)

    if (trim(tag).eq.'-geo2stereo'.or.tag.eq.'-geo2xy'.or.tag.eq.'-lonlat2xy') then
        project_mode = 'geo2stereo'
    elseif (trim(tag).eq.'-stereo2geo'.or.tag.eq.'-xy2geo'.or.tag.eq.'-xy2lonlat') then
        project_mode = 'stereo2geo'

    elseif (trim(tag).eq.'-f') then
        i = i + 1
        call get_command_argument(i,input_file)
    elseif (trim(tag).eq.'-o') then
        i = i + 1
        call get_command_argument(i,output_file)

    elseif (trim(tag).eq.'-lon0') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*,err=9001) lon0
    elseif (trim(tag).eq.'-lat0') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*,err=9002) lat0
    elseif (trim(tag).eq.'-radius') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*,err=9003) radius_sphere

    else
        call usage('stereo_project: no option '//trim(tag))
    endif

    i = i + 1
enddo

return

! Error messages
9001 write(stderr,*) 'stereo_project: error reading central longitude'
call usage(          'Tried to read: '//trim(tag))
9002 write(stderr,*) 'stereo_project: error reading central latitude'
call usage(          'Tried to read: '//trim(tag))
9003 write(stderr,*) 'stereo_project: error reading radius of sphere'
call usage(          'Tried to read: '//trim(tag))

end subroutine

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

subroutine usage(string)

use io, only: stderr

implicit none

character(len=*) :: string

if (string.ne.'') then
    write(stderr,*) trim(string)
    write(stderr,*)
endif

write(stderr,*) 'Usage: stereo_project ...options...'
write(stderr,*)
write(stderr,*) '-f FILE         Input geographic or projected x-y coordinates (default: stdin)'
write(stderr,*) '-o FILE         Output coordinates (default: stdout)'
write(stderr,*) '-geo2stereo     Project geographic to x-y coordinates'
write(stderr,*) '-stereo2geo     Project x-y coordinates to geographic'
write(stderr,*) '-lon0 LON0      Center longitude of projection'
write(stderr,*) '-lat0 LAT0      Center latitude of projection'
write(stderr,*) '-radius R       Sphere radius'

call error_exit(1)
end subroutine


!*==ssbtrd.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SSBTRD
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SSBTRD + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
!                          WORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO, VECT
!       INTEGER            INFO, KD, LDAB, LDQ, N
!       ..
!       .. Array Arguments ..
!       REAL               AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ),
!      $                   WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SSBTRD reduces a real symmetric band matrix A to symmetric
!> tridiagonal form T by an orthogonal similarity transformation:
!> Q**T * A * Q = T.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] VECT
!> \verbatim
!>          VECT is CHARACTER*1
!>          = 'N':  do not form Q;
!>          = 'V':  form Q;
!>          = 'U':  update a matrix X, by forming X*Q.
!> \endverbatim
!>
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] KD
!> \verbatim
!>          KD is INTEGER
!>          The number of superdiagonals of the matrix A if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!> \endverbatim
!>
!> \param[in,out] AB
!> \verbatim
!>          AB is REAL array, dimension (LDAB,N)
!>          On entry, the upper or lower triangle of the symmetric band
!>          matrix A, stored in the first KD+1 rows of the array.  The
!>          j-th column of A is stored in the j-th column of the array AB
!>          as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>          On exit, the diagonal elements of AB are overwritten by the
!>          diagonal elements of the tridiagonal matrix T; if KD > 0, the
!>          elements on the first superdiagonal (if UPLO = 'U') or the
!>          first subdiagonal (if UPLO = 'L') are overwritten by the
!>          off-diagonal elements of T; the rest of AB is overwritten by
!>          values generated during the reduction.
!> \endverbatim
!>
!> \param[in] LDAB
!> \verbatim
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!> \endverbatim
!>
!> \param[out] D
!> \verbatim
!>          D is REAL array, dimension (N)
!>          The diagonal elements of the tridiagonal matrix T.
!> \endverbatim
!>
!> \param[out] E
!> \verbatim
!>          E is REAL array, dimension (N-1)
!>          The off-diagonal elements of the tridiagonal matrix T:
!>          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
!> \endverbatim
!>
!> \param[in,out] Q
!> \verbatim
!>          Q is REAL array, dimension (LDQ,N)
!>          On entry, if VECT = 'U', then Q must contain an N-by-N
!>          matrix X; if VECT = 'N' or 'V', then Q need not be set.
!>
!>          On exit:
!>          if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;
!>          if VECT = 'U', Q contains the product X*Q;
!>          if VECT = 'N', the array Q is not referenced.
!> \endverbatim
!>
!> \param[in] LDQ
!> \verbatim
!>          LDQ is INTEGER
!>          The leading dimension of the array Q.
!>          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL 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 realOTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Modified by Linda Kaufman, Bell Labs.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE SSBTRD(Vect,Uplo,N,Kd,Ab,Ldab,D,E,Q,Ldq,Work,Info)
      IMPLICIT NONE
!*--SSBTRD166
!
!  -- 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 Uplo , Vect
      INTEGER Info , Kd , Ldab , Ldq , N
!     ..
!     .. Array Arguments ..
      REAL Ab(Ldab,*) , D(*) , E(*) , Q(Ldq,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0)
!     ..
!     .. Local Scalars ..
      LOGICAL initq , upper , wantq
      INTEGER i , i2 , ibl , inca , incx , iqaend , iqb , iqend , j ,   &
     &        j1 , j1end , j1inc , j2 , jend , jin , jinc , k , kd1 ,   &
     &        kdm1 , kdn , l , last , lend , nq , nr , nrt
      REAL temp
!     ..
!     .. External Subroutines ..
      EXTERNAL SLAR2V , SLARGV , SLARTG , SLARTV , SLASET , SROT ,      &
     &         XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters
!
      initq = LSAME(Vect,'V')
      wantq = initq .OR. LSAME(Vect,'U')
      upper = LSAME(Uplo,'U')
      kd1 = Kd + 1
      kdm1 = Kd - 1
      incx = Ldab - 1
      iqend = 1
!
      Info = 0
      IF ( .NOT.wantq .AND. .NOT.LSAME(Vect,'N') ) THEN
         Info = -1
      ELSEIF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Kd<0 ) THEN
         Info = -4
      ELSEIF ( Ldab<kd1 ) THEN
         Info = -6
      ELSEIF ( Ldq<MAX(1,N) .AND. wantq ) THEN
         Info = -10
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SSBTRD',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( N==0 ) RETURN
!
!     Initialize Q to the unit matrix, if needed
!
      IF ( initq ) CALL SLASET('Full',N,N,ZERO,ONE,Q,Ldq)
!
!     Wherever possible, plane rotations are generated and applied in
!     vector operations of length NR over the index set J1:J2:KD1.
!
!     The cosines and sines of the plane rotations are stored in the
!     arrays D and WORK.
!
      inca = kd1*Ldab
      kdn = MIN(N-1,Kd)
      IF ( upper ) THEN
!
         IF ( Kd>1 ) THEN
!
!           Reduce to tridiagonal form, working with upper triangle
!
            nr = 0
            j1 = kdn + 2
            j2 = 1
!
            DO i = 1 , N - 2
!
!              Reduce i-th row of matrix to tridiagonal form
!
               DO k = kdn + 1 , 2 , -1
                  j1 = j1 + kdn
                  j2 = j2 + kdn
!
                  IF ( nr>0 ) THEN
!
!                    generate plane rotations to annihilate nonzero
!                    elements which have been created outside the band
!
                     CALL SLARGV(nr,Ab(1,j1-1),inca,Work(j1),kd1,D(j1), &
     &                           kd1)
!
!                    apply rotations from the right
!
!
!                    Dependent on the the number of diagonals either
!                    SLARTV or SROT is used
!
                     IF ( nr>=2*Kd-1 ) THEN
                        DO l = 1 , Kd - 1
                           CALL SLARTV(nr,Ab(l+1,j1-1),inca,Ab(l,j1),   &
     &                                 inca,D(j1),Work(j1),kd1)
                        ENDDO
!
                     ELSE
                        jend = j1 + (nr-1)*kd1
                        DO jinc = j1 , jend , kd1
                           CALL SROT(kdm1,Ab(2,jinc-1),1,Ab(1,jinc),1,  &
     &                               D(jinc),Work(jinc))
                        ENDDO
                     ENDIF
                  ENDIF
!
!
                  IF ( k>2 ) THEN
                     IF ( k<=N-i+1 ) THEN
!
!                       generate plane rotation to annihilate a(i,i+k-1)
!                       within the band
!
                        CALL SLARTG(Ab(Kd-k+3,i+k-2),Ab(Kd-k+2,i+k-1),  &
     &                              D(i+k-1),Work(i+k-1),temp)
                        Ab(Kd-k+3,i+k-2) = temp
!
!                       apply rotation from the right
!
                        CALL SROT(k-3,Ab(Kd-k+4,i+k-2),1,               &
     &                            Ab(Kd-k+3,i+k-1),1,D(i+k-1),          &
     &                            Work(i+k-1))
                     ENDIF
                     nr = nr + 1
                     j1 = j1 - kdn - 1
                  ENDIF
!
!                 apply plane rotations from both sides to diagonal
!                 blocks
!
                  IF ( nr>0 ) CALL SLAR2V(nr,Ab(kd1,j1-1),Ab(kd1,j1),   &
     &                 Ab(Kd,j1),inca,D(j1),Work(j1),kd1)
!
!                 apply plane rotations from the left
!
                  IF ( nr>0 ) THEN
                     IF ( 2*Kd-1<nr ) THEN
!
!                    Dependent on the the number of diagonals either
!                    SLARTV or SROT is used
!
                        DO l = 1 , Kd - 1
                           IF ( j2+l>N ) THEN
                              nrt = nr - 1
                           ELSE
                              nrt = nr
                           ENDIF
                           IF ( nrt>0 )                                 &
     &                          CALL SLARTV(nrt,Ab(Kd-l,j1+l),inca,     &
     &                          Ab(Kd-l+1,j1+l),inca,D(j1),Work(j1),kd1)
                        ENDDO
                     ELSE
                        j1end = j1 + kd1*(nr-2)
                        IF ( j1end>=j1 ) THEN
                           DO jin = j1 , j1end , kd1
                              CALL SROT(Kd-1,Ab(Kd-1,jin+1),incx,       &
     &                                  Ab(Kd,jin+1),incx,D(jin),       &
     &                                  Work(jin))
                           ENDDO
                        ENDIF
                        lend = MIN(kdm1,N-j2)
                        last = j1end + kd1
                        IF ( lend>0 )                                   &
     &                       CALL SROT(lend,Ab(Kd-1,last+1),incx,       &
     &                       Ab(Kd,last+1),incx,D(last),Work(last))
                     ENDIF
                  ENDIF
!
                  IF ( wantq ) THEN
!
!                    accumulate product of plane rotations in Q
!
                     IF ( initq ) THEN
!
!                 take advantage of the fact that Q was
!                 initially the Identity matrix
!
                        iqend = MAX(iqend,j2)
                        i2 = MAX(0,k-3)
                        iqaend = 1 + i*Kd
                        IF ( k==2 ) iqaend = iqaend + Kd
                        iqaend = MIN(iqaend,iqend)
                        DO j = j1 , j2 , kd1
                           ibl = i - i2/kdm1
                           i2 = i2 + 1
                           iqb = MAX(1,j-ibl)
                           nq = 1 + iqaend - iqb
                           iqaend = MIN(iqaend+Kd,iqend)
                           CALL SROT(nq,Q(iqb,j-1),1,Q(iqb,j),1,D(j),   &
     &                               Work(j))
                        ENDDO
                     ELSE
!
                        DO j = j1 , j2 , kd1
                           CALL SROT(N,Q(1,j-1),1,Q(1,j),1,D(j),Work(j))
                        ENDDO
                     ENDIF
!
                  ENDIF
!
                  IF ( j2+kdn>N ) THEN
!
!                    adjust J2 to keep within the bounds of the matrix
!
                     nr = nr - 1
                     j2 = j2 - kdn - 1
                  ENDIF
!
                  DO j = j1 , j2 , kd1
!
!                    create nonzero element a(j-1,j+kd) outside the band
!                    and store it in WORK
!
                     Work(j+Kd) = Work(j)*Ab(1,j+Kd)
                     Ab(1,j+Kd) = D(j)*Ab(1,j+Kd)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
!
         IF ( Kd>0 ) THEN
!
!           copy off-diagonal elements to E
!
            DO i = 1 , N - 1
               E(i) = Ab(Kd,i+1)
            ENDDO
         ELSE
!
!           set E to zero if original matrix was diagonal
!
            DO i = 1 , N - 1
               E(i) = ZERO
            ENDDO
         ENDIF
!
!        copy diagonal elements to D
!
         DO i = 1 , N
            D(i) = Ab(kd1,i)
         ENDDO
!
      ELSE
!
         IF ( Kd>1 ) THEN
!
!           Reduce to tridiagonal form, working with lower triangle
!
            nr = 0
            j1 = kdn + 2
            j2 = 1
!
            DO i = 1 , N - 2
!
!              Reduce i-th column of matrix to tridiagonal form
!
               DO k = kdn + 1 , 2 , -1
                  j1 = j1 + kdn
                  j2 = j2 + kdn
!
                  IF ( nr>0 ) THEN
!
!                    generate plane rotations to annihilate nonzero
!                    elements which have been created outside the band
!
                     CALL SLARGV(nr,Ab(kd1,j1-kd1),inca,Work(j1),kd1,   &
     &                           D(j1),kd1)
!
!                    apply plane rotations from one side
!
!
!                    Dependent on the the number of diagonals either
!                    SLARTV or SROT is used
!
                     IF ( nr>2*Kd-1 ) THEN
                        DO l = 1 , Kd - 1
                           CALL SLARTV(nr,Ab(kd1-l,j1-kd1+l),inca,      &
     &                                 Ab(kd1-l+1,j1-kd1+l),inca,D(j1), &
     &                                 Work(j1),kd1)
                        ENDDO
                     ELSE
                        jend = j1 + kd1*(nr-1)
                        DO jinc = j1 , jend , kd1
                           CALL SROT(kdm1,Ab(Kd,jinc-Kd),incx,          &
     &                               Ab(kd1,jinc-Kd),incx,D(jinc),      &
     &                               Work(jinc))
                        ENDDO
                     ENDIF
!
                  ENDIF
!
                  IF ( k>2 ) THEN
                     IF ( k<=N-i+1 ) THEN
!
!                       generate plane rotation to annihilate a(i+k-1,i)
!                       within the band
!
                        CALL SLARTG(Ab(k-1,i),Ab(k,i),D(i+k-1),         &
     &                              Work(i+k-1),temp)
                        Ab(k-1,i) = temp
!
!                       apply rotation from the left
!
                        CALL SROT(k-3,Ab(k-2,i+1),Ldab-1,Ab(k-1,i+1),   &
     &                            Ldab-1,D(i+k-1),Work(i+k-1))
                     ENDIF
                     nr = nr + 1
                     j1 = j1 - kdn - 1
                  ENDIF
!
!                 apply plane rotations from both sides to diagonal
!                 blocks
!
                  IF ( nr>0 ) CALL SLAR2V(nr,Ab(1,j1-1),Ab(1,j1),       &
     &                 Ab(2,j1-1),inca,D(j1),Work(j1),kd1)
!
!                 apply plane rotations from the right
!
!
!                    Dependent on the the number of diagonals either
!                    SLARTV or SROT is used
!
                  IF ( nr>0 ) THEN
                     IF ( nr>2*Kd-1 ) THEN
                        DO l = 1 , Kd - 1
                           IF ( j2+l>N ) THEN
                              nrt = nr - 1
                           ELSE
                              nrt = nr
                           ENDIF
                           IF ( nrt>0 )                                 &
     &                          CALL SLARTV(nrt,Ab(l+2,j1-1),inca,      &
     &                          Ab(l+1,j1),inca,D(j1),Work(j1),kd1)
                        ENDDO
                     ELSE
                        j1end = j1 + kd1*(nr-2)
                        IF ( j1end>=j1 ) THEN
                           DO j1inc = j1 , j1end , kd1
                              CALL SROT(kdm1,Ab(3,j1inc-1),1,Ab(2,j1inc)&
     &                                  ,1,D(j1inc),Work(j1inc))
                           ENDDO
                        ENDIF
                        lend = MIN(kdm1,N-j2)
                        last = j1end + kd1
                        IF ( lend>0 )                                   &
     &                       CALL SROT(lend,Ab(3,last-1),1,Ab(2,last),1,&
     &                       D(last),Work(last))
                     ENDIF
                  ENDIF
!
!
!
                  IF ( wantq ) THEN
!
!                    accumulate product of plane rotations in Q
!
                     IF ( initq ) THEN
!
!                 take advantage of the fact that Q was
!                 initially the Identity matrix
!
                        iqend = MAX(iqend,j2)
                        i2 = MAX(0,k-3)
                        iqaend = 1 + i*Kd
                        IF ( k==2 ) iqaend = iqaend + Kd
                        iqaend = MIN(iqaend,iqend)
                        DO j = j1 , j2 , kd1
                           ibl = i - i2/kdm1
                           i2 = i2 + 1
                           iqb = MAX(1,j-ibl)
                           nq = 1 + iqaend - iqb
                           iqaend = MIN(iqaend+Kd,iqend)
                           CALL SROT(nq,Q(iqb,j-1),1,Q(iqb,j),1,D(j),   &
     &                               Work(j))
                        ENDDO
                     ELSE
!
                        DO j = j1 , j2 , kd1
                           CALL SROT(N,Q(1,j-1),1,Q(1,j),1,D(j),Work(j))
                        ENDDO
                     ENDIF
                  ENDIF
!
                  IF ( j2+kdn>N ) THEN
!
!                    adjust J2 to keep within the bounds of the matrix
!
                     nr = nr - 1
                     j2 = j2 - kdn - 1
                  ENDIF
!
                  DO j = j1 , j2 , kd1
!
!                    create nonzero element a(j+kd,j-1) outside the
!                    band and store it in WORK
!
                     Work(j+Kd) = Work(j)*Ab(kd1,j)
                     Ab(kd1,j) = D(j)*Ab(kd1,j)
                  ENDDO
               ENDDO
            ENDDO
         ENDIF
!
         IF ( Kd>0 ) THEN
!
!           copy off-diagonal elements to E
!
            DO i = 1 , N - 1
               E(i) = Ab(2,i)
            ENDDO
         ELSE
!
!           set E to zero if original matrix was diagonal
!
            DO i = 1 , N - 1
               E(i) = ZERO
            ENDDO
         ENDIF
!
!        copy diagonal elements to D
!
         DO i = 1 , N
            D(i) = Ab(1,i)
         ENDDO
      ENDIF
!
!
!     End of SSBTRD
!
      END SUBROUTINE SSBTRD


      SUBROUTINE cftfax_g(n, ifax, trigs)
      USE stel_kinds
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER n
      INTEGER, DIMENSION(13) :: ifax
      REAL(rprec), DIMENSION(*) :: trigs
!DEC$ IF .NOT.DEFINED(CRAY) .OR. DEFINED(LONESTAR) .OR. DEFINED(MCURIE)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: k
C-----------------------------------------------
c
c on input     n
c               the length of each complex transform to be performed
c
c               n must be greater than 1 and contain no prime
c               factors greater than 5.
c
c on output    ifax
c               ifax(1)
c                 the number of factors chosen or -99 in CASE of error
c               ifax(2) thru ifax( ifax(1)+1 )
c                 the factors of n in the followin order:  appearing
c                 first are as many factors of 4 as can be obtained.
c                 subsequent factors are primes, and appear in
c                 ascending order, except for multiple factors.
c
c              trigs
c               2n SIN and COS values for USE by the transform routine
c
      CALL fact_g (n, ifax)
      k = ifax(1)
      IF (k<1 .or. ifax(k+1)>5) ifax(1) = -99
      IF (ifax(1) .le. 0) STOP 'IFAX(1) <= 0 in CFTFAX'
      CALL cftrig_g (n, trigs)
!DEC$ ELSE
      CALL cftfax (n, ifax, trigs)
!DEC$ ENDIF
      END SUBROUTINE cftfax_g


program main
    use plantfem
    implicit none

    type(Triangle_) :: tri
    integer(int32) :: i
    call tri%import(FileName="rect.txt")
    call tri%GetOuterNormal()
    call tri%show()
    print *, tri%center(:), tri%OuterNormal(:)
    print *, dot_product(tri%NodCoord(1,:)-tri%center(:), tri%OuterNormal(:))
    print *, dot_product(tri%NodCoord(2,:)-tri%center(:), tri%OuterNormal(:))
    print *, dot_product(tri%NodCoord(3,:)-tri%center(:), tri%OuterNormal(:))

    open(10,file="test.txt")
    do i=1,size(tri%NodCoord,1)
        write(10,*) tri%NodCoord(i,:)
    enddo
    write(10,*) tri%NodCoord(i,:)

    close(10)
    open(20,file="vec.txt")
    write(20,*) tri%center(:),tri%OuterNormal(:)
    close(20)

end program


      subroutine genint
c
c----------------------------------------------------------------------
c
c This subroutine inputs the integration information.
c
c----------------------------------------------------------------------
c
      include "common.h"

      real*8, allocatable :: tmpQpt (:,:), tmpQwt (:)
      real*8, allocatable :: tmpQptb(:,:), tmpQwtb(:)

c
c.... compute the shape function parameters
c

c
c.... get quadrature data for interior and boundary elements
c
c
c  Tets
c
      if (nen.eq.4) then
         nshape  = (ipord+1)*(ipord+2)*(ipord+3)/6
         nshapeb = (ipord+1)*(ipord+2)/2
      endif

      select case (intg(1,1))
      case (1)
         nint(1) = 1
      case (2)
         nint(1) = 4
      case (3)
         nint(1) = 16
      case (4)
         nint(1) = 29
      end select
      select case (intg(2,1))
      case (1)
         nintb(1) = 1
      case (2)
         nintb(1) = 3
      case (3)
         nintb(1) = 6
      case (4)
         nintb(1) = 12
      end select

      allocate (tmpQpt (4,nint(1)))
      allocate (tmpQwt (nint(1)))
      allocate (tmpQptb(4,nintb(1)))
      allocate (tmpQwtb(nintb(1)))

      call symtet(nint(1),tmpQpt,tmpQwt,nerr) ! interior elements
      Qpt(1,1:4,1:nint(1)) = tmpQpt(1:4,1:nint(1))
      Qwt(1,1:nint(1))     = tmpQwt(1:nint(1))

      call symtri(nintb(1),tmpQptb,tmpQwtb,nerr) ! boundary elements
      Qptb(1,1:4,1:nintb(1)) = tmpQptb(1:4,1:nintb(1))
      Qwtb(1,1:nintb(1))     = tmpQwtb(1:nintb(1))

      deallocate (tmpQpt)
      deallocate (tmpQwt)
      deallocate (tmpQptb)
      deallocate (tmpQwtb)

c
c.... adjust quadrature weights to be consistent with the
c     design of tau.
c
      Qwt(1,:) = (four/three)*Qwt(1,:)
      Qwtb(1,:) = two*Qwtb(1,:)
c
c     Hexes now
c
      if (nen.eq.8) then
         nshape = nen
         if ( ipord .gt. 1 ) then
            nshape = nshape + 12*(ipord - 1)
         endif

         if ( ipord .gt. 3 ) then
            nshape = nshape + 3*(ipord -2)*(ipord - 3)
         endif

         if ( ipord .gt. 5 ) then
            nshape = nshape + (ipord - 3)*(ipord - 4)*(ipord - 5)/6
         endif

         nshapeb = nenb

         if ( ipord .gt. 1 ) then
            nshapeb = nshapeb + 4*(ipord - 1)
         endif

         if ( ipord .gt. 3 ) then
            nshapeb = nshapeb +(ipord -2)*(ipord - 3)/2
         endif
      endif

      select case (intg(1,1))
      case (1)
         nint(2) = 1
      case (2)
         nint(2) = 8
      case (3)
         nint(2) =27
      case (4)
         nint(2) = 64
      case (5)
         nint(2) = 125
      end select

      select case (intg(2,1))
      case (1)
         nintb(2) = 1
      case (2)
         nintb(2) = 4
      case(3)
         nintb(2) = 9
      case (4)
         nintb(2) = 16
      case (5)
         nintb(2) = 25
      end select

      allocate (tmpQpt (4,nint(2)))
      allocate (tmpQwt (nint(2)))
      allocate (tmpQptb(4,nintb(2)))
      allocate (tmpQwtb(nintb(2)))

      call symhex(nint(2),tmpQpt,tmpQwt,nerr)
      Qpt(2,1:4,1:nint(2)) = tmpQpt(1:4,1:nint(2))
      Qwt(2,1:nint(2)) = tmpQwt(1:nint(2))

      call symquad(nintb(2),tmpQptb,tmpQwtb,nerr)
      Qptb(2,1:4,1:nintb(2)) = tmpQptb(1:4,1:nintb(2))
      Qwtb(2,1:nintb(2)) = tmpQwtb(1:nintb(2))

      deallocate (tmpQpt)
      deallocate (tmpQwt)
      deallocate (tmpQptb)
      deallocate (tmpQwtb)

      if (nen.eq.5) then        ! for pyramid

         nshape = nen           ! counting the nodal functions

         if ( ipord .gt. 1 ) then
            nshape = nshape + 8*(ipord - 1) ! counting the edge functions
         endif

         if ( ipord .gt. 2 ) then
                                ! counting the triangular face functions
            nshape = nshape + 2*(ipord -1)*(ipord - 2)
         endif

         if ( ipord .gt. 3 ) then
                                ! counting the quadrilateral face functions
            nshape = nshape + (ipord - 2)*(ipord - 3)/2
         endif

         if ( ipord .gt. 5 ) then
            nshape = nshape + (ipord - 3)*(ipord - 4)*(ipord - 5)/6
         endif

         nshapeb = nenb
                                ! assume only the quadrilateral face on boundary
         if ( ipord .gt. 1 ) then
            nshapeb = nshapeb + 4*(ipord - 1)
         endif
         if ( ipord .gt. 3 ) then
            nshape = nshape +(ipord - 2)*(ipord - 3)/2
         endif

      endif

      select case (intg(1,1))
      case (1)
         nint(5) = 1
      case (2)
         nint(5) = 8
      case (3)
         nint(5) = 27
      case (4)
         nint(5) = 64
      case (5)
         nint(5) = 125
      end select
      select case (intg(2,1))
      case (1)
         nintb(5) = 1
      case (2)
         nintb(5) = 4
      case (3)
         nintb(5) = 9
      case (4)
         nintb(5) = 16
      case (5)
         nintb(5) = 25
      end select
      select case (intg(2,1))
      case (1)
         nintb(6) = 1
      case (2)
         nintb(6) = 4
      case (3)
         nintb(6) = 9
      case (4)
         nintb(6) = 12
      case (5)
         nintb(6) = 12 ! tri face boundary integration rules not coded
      end select

      allocate (tmpQpt (4,nint(5)))
      allocate (tmpQwt (nint(5)))

      call sympyr(nint(5),tmpQpt,tmpQwt,nerr) ! interior elements
      Qpt(5,1:4,1:nint(5)) = tmpQpt(1:4,1:nint(5))
      Qwt(5,1:nint(5)) = tmpQwt(1:nint(5))

      deallocate (tmpQpt)
      deallocate (tmpQwt)

      allocate (tmpQptb(4,nintb(5)))
      allocate (tmpQwtb(nintb(5)))

      call symquad (nintb(5),tmpQptb,tmpQwtb,nerr) ! quad boundary elements
      Qptb(5,1:4,1:nintb(5)) = tmpQptb(1:4,1:nintb(5))
      Qwtb(5,1:nintb(5)) = tmpQwtb(1:nintb(5))

      deallocate (tmpQptb)
      deallocate (tmpQwtb)

      allocate (tmpQptb(4,nintb(6)))
      allocate (tmpQwtb(nintb(6)))

      call symtripyr (nintb(6),tmpQptb,tmpQwtb,nerr) ! tri boundary elements
      Qptb(6,1:4,1:nintb(6)) = tmpQptb(1:4,1:nintb(6))
      Qwtb(6,1:nintb(6)) = tmpQwtb(1:nintb(6))

      deallocate (tmpQptb)
      deallocate (tmpQwtb)

      if (nen.eq.6) then
c
c     later for hierarchic basis nshape formulas will be inserted
c
         nshape = nen

         if ( ipord .gt. 1 ) then
            nshape = nshape + 9*(ipord - 1)
         endif

         if ( ipord .gt. 2 ) then
            nshape = nshape + (ipord -1)*(ipord - 2)
         endif

         if ( ipord .gt. 3 ) then
            nshape = nshape + 3*(ipord - 2)*(ipord - 3)/2
         endif

         if ( ipord .gt. 4 ) then
            nshape = nshape + (ipord - 2)*(ipord - 3)*(ipord - 4)/6
         endif

         nshapeb = nenb
c
         if (nenb .eq. 3) then
            if ( ipord .gt. 1 ) then
               nshapeb = nshapeb + 3*(ipord - 1)
            endif
            if ( ipord .gt. 2 ) then
               nshape = nshape +(ipord - 1)*(ipord - 2)/2
            endif
         endif
c
         if (nenb .eq. 4) then
            if ( ipord .gt. 1 ) then
               nshapeb = nshapeb + 4*(ipord - 1)
            endif
            if ( ipord .gt. 2 ) then
               nshape = nshape +(ipord - 2)*(ipord - 3)/2
            endif
         endif
      endif

      select case (intg(1,1))
      case (2)
         nint(3) = 6
      case (3)
         nint(3) = 18
      case (4)
         nint(3) = 48
      end select
      select case (intg(2,1))
      case (2)
         nintb(3) = 3
         nintb(4) = 4
      case (3)
         nintb(3) = 6
         nintb(4) = 9
      case (4)
         nintb(3) = 12
         nintb(4) = 16
      end select

      allocate (tmpQpt (4,nint(3)))
      allocate (tmpQwt (nint(3)))

      call symwdg(nint(3),tmpQpt,tmpQwt,nerr) ! interior elements
      Qpt(3,1:4,1:nint(3)) = tmpQpt(1:4,1:nint(3))
      Qwt(3,1:nint(3)) = tmpQwt(1:nint(3))

      deallocate (tmpQpt)
      deallocate (tmpQwt)

      allocate (tmpQptb(4,nintb(3)))
      allocate (tmpQwtb(nintb(3)))

      call symtri(nintb(3),tmpQptb,tmpQwtb,nerr) ! boundary elements
      Qptb(3,1:2,2:nintb(3)) = tmpQptb(1:2,1:nintb(3)-1)
      Qptb(3,1:2,1) = tmpQptb(1:2,nintb(3))
c
c     wedges want the third entry to be zeta=-1 (not t=1-r-s)
c     4th entry not used
c
      Qptb(3,3:4,1:nintb(3)) = -1
c$$$  Qptb(3,1:4,1:nintb(3)) = tmpQptb(1:4,1:nintb(3))
      Qwtb(3,1:nintb(3)) = tmpQwtb(1:nintb(3))

      deallocate (tmpQptb)
      deallocate (tmpQwtb)

      allocate (tmpQptb(4,nintb(4)))
      allocate (tmpQwtb(nintb(4)))

      call symquadw(nintb(4),tmpQptb,tmpQwtb,nerr) ! boundary elements
      Qptb(4,1:4,1:nintb(4)) = tmpQptb(1:4,1:nintb(4))
      Qwtb(4,1:nintb(4)) = tmpQwtb(1:nintb(4))

      deallocate (tmpQptb)
      deallocate (tmpQwtb)

c
c.... return
c
      return
      end


submodule (m_random) sm_rngChiSq
  !! Generate random numbers from a Chi squared distribution.

  ! Original Version
  ! Author: Alan Miller

  ! Updated version:
  ! Version 2.00, 11 November 2016
  ! Increased precision to double
  !
  ! Updated again
  ! Added overloaded operations for single number, nD arrays
  !     Author: Leon Foks
implicit none

contains

  !====================================================================!
  module procedure rngChisq_d1!(this,ndf,first)
  !====================================================================!
  ! Generates a random variate from the chi-squared distribution with
  ! ndf degrees of freedom
!    INTEGER, INTENT(IN) :: ndf
!    LOGICAL, INTENT(IN) :: first
!    real(r64) :: this
  call rngGamma(this,half*dble(ndf), first)
  this = two * this
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure rngChisq_d1D!(this,ndf,first)
  !====================================================================!
!    real(r64) :: this(:)
!    INTEGER, INTENT(IN) :: ndf
!    LOGICAL, INTENT(IN) :: first
  integer :: i,N
  N=size(this)
  call rngChisq(this(1),ndf,first)
  do i=2,N
    call rngChisq(this(i),ndf,.false.)
  end do
  end procedure
  !====================================================================!
end submodule


module FuncIfaces
    use Const
    implicit none
    interface

        ! Sample functions for solvers
        function fRR(x) result(y)
            import mpc
            real(mpc),intent(in) :: x
            real(mpc) :: y
        end function

        function fRnRn(x) result(y)
            import mpc
            real(mpc), intent(in), dimension(:) :: x
            real(mpc), dimension(size(x)) ::y
        end function

        function fRnR1(x) result(y)
            import mpc
            real(mpc), intent(in), dimension(:) :: x
            real(mpc) ::y
        end function

        function genericTransform(x) result (x1)
            import mpc
            real(mpc), intent(in), dimension(:) :: x
            real(mpc), dimension(size(x)) :: x1
        end function genericTransform
    end interface
end module FuncIfaces