    Program dpftrs_example

!     DPFTRS Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dpftrf, dpftrs
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, k, lar1, ldb, lenar, n, nrhs, q
      Character (1) :: transr, uplo
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ar(:), b(:, :)
!     .. Executable Statements ..
      Write (nout, *) 'DPFTRS Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, nrhs, uplo, transr

      lenar = n*(n+1)/2
      ldb = n
      Allocate (ar(lenar), b(ldb,nrhs))

!     Setup notional dimensions of RFP matrix AR
      k = n/2
      q = n - k
      If (transr=='N' .Or. transr=='n') Then
        lar1 = 2*k + 1
      Else
        lar1 = q
      End If

!     Read an RFP matrix into array AR
      Do i = 1, lar1
        Read (nin, *) ar(i:lenar:lar1)
      End Do

!     Read RHS matrix B
      Do i = 1, n
        Read (nin, *) b(i, 1:nrhs)
      End Do

!     Factorize A
      Call dpftrf(transr, uplo, n, ar, info)

      Write (nout, *)
      Flush (nout)
      If (info==0) Then

!       Compute solution
        Call dpftrs(transr, uplo, n, nrhs, ar, b, ldb, info)

!       Print solution
        ifail = 0
        Call nagf_file_print_matrix_real_gen('General', ' ', n, nrhs, b, ldb, &
          'Solution(s)', ifail)

      Else
        Write (nout, *) 'A is not positive definite'
      End If

    End Program


*DECK SROTG
      SUBROUTINE SROTG (SA, SB, SC, SS)
C***BEGIN PROLOGUE  SROTG
C***PURPOSE  Construct a plane Givens rotation.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1B10
C***TYPE      SINGLE PRECISION (SROTG-S, DROTG-D, CROTG-C)
C***KEYWORDS  BLAS, GIVENS ROTATION, GIVENS TRANSFORMATION,
C             LINEAR ALGEBRA, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C       SA  single precision scalar
C       SB  single precision scalar
C
C     --Output--
C       SA  single precision result R
C       SB  single precision result Z
C       SC  single precision result
C       SS  single precision result
C
C     Construct the Givens transformation
C
C         ( SC  SS )
C     G = (        ) ,    SC**2 + SS**2 = 1 ,
C         (-SS  SC )
C
C     which zeros the second entry of the 2-vector  (SA,SB)**T.
C
C     The quantity R = (+/-)SQRT(SA**2 + SB**2) overwrites SA in
C     storage.  The value of SB is overwritten by a value Z which
C     allows SC and SS to be recovered by the following algorithm:
C
C           If Z=1  set  SC=0.0  and  SS=1.0
C           If ABS(Z) .LT. 1  set  SC=SQRT(1-Z**2)  and  SS=Z
C           If ABS(Z) .GT. 1  set  SC=1/Z  and  SS=SQRT(1-SC**2)
C
C     Normally, the subprogram SROT(N,SX,INCX,SY,INCY,SC,SS) will
C     next be called to apply the transformation to a 2 by N matrix.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SROTG
C***FIRST EXECUTABLE STATEMENT  SROTG
      IF (ABS(SA) .LE. ABS(SB)) GO TO 10
C
C *** HERE ABS(SA) .GT. ABS(SB) ***
C
      U = SA + SA
      V = SB / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF SA
C
      R = SQRT(0.25E0 + V**2) * U
C
C     NOTE THAT SC IS POSITIVE
C
      SC = SA / R
      SS = V * (SC + SC)
      SB = SS
      SA = R
      RETURN
C
C *** HERE ABS(SA) .LE. ABS(SB) ***
C
   10 IF (SB .EQ. 0.0E0) GO TO 20
      U = SB + SB
      V = SA / U
C
C     NOTE THAT U AND R HAVE THE SIGN OF SB
C     (R IS IMMEDIATELY STORED IN SA)
C
      SA = SQRT(0.25E0 + V**2) * U
C
C     NOTE THAT SS IS POSITIVE
C
      SS = SB / SA
      SC = V * (SS + SS)
      IF (SC .EQ. 0.0E0) GO TO 15
      SB = 1.0E0 / SC
      RETURN
   15 SB = 1.0E0
      RETURN
C
C *** HERE SA = SB = 0.0 ***
C
   20 SC = 1.0E0
      SS = 0.0E0
      RETURN
C
      END


! Created by EverLookNeverSee@GitHub on 5/30/20
! For more information see FCS/img/Exercise_04.png

program main
    implicit none
    ! declaring variables
    integer :: i = 1
    real :: R = 20.0
    real , dimension(37) :: S
    ! checking current value of R to compute corresponding S
    1   if (R <= 120) then
        S(i) = 17000.0 - (0.485 * R ** 2)
        else
        S(i) = 18000.0 / (1.0 + (R ** 2 / 18000.0))
    end if
    ! checking current value of R to making loop
    if (R < 200) then
        ! incrementation of R
        R = R + 5.0
        ! icrementation of array blocks counter
        i = i + 1
        goto 1
    end if
    ! do loop for formated print
    do i = 1, 37, 1
        print "(a2,i2,a3,f11.5)", "S(", i, "): ", S(i)
    end do
end program main


module mod_rgrd2
    use mod_rgrd1
    implicit none

contains
    !

    ! Code converted using TO_F90 by Alan Miller
    ! Date: 2013-09-18  Time: 12:22:55

    ! ... file rgrd2.f

    !     this file contains documentation for subroutine rgrd2 followed by
    !     fortran code for rgrd2 and additional subroutines.

    ! ... author

    !     John C. Adams (NCAR 1999)

    ! ... subroutine rgrd2(nx,ny,x,y,p,mx,my,xx,yy,q,intpol,w,lw,iw,liw,ier)

    ! ... purpose

    !     subroutine rgrd2 interpolates the values p(i,j) on the orthogonal
    !     grid (x(i),y(j)) for i=1,...,nx and j=1,...,ny onto q(ii,jj) on the
    !     orthogonal grid (xx(ii),yy(jj)) for ii=1,...,mx and jj=1,...,my.

    ! ... language

    !     coded in portable FORTRAN77 and FORTRAN90

    ! ... test program

    !     file trgrd2.f on regridpack includes a test program for subroutine rgrd2

    ! ... method

    !     linear or cubic interpolation is used (independently) in
    !     each direction (see argument intpol).

    ! ... required files

    !     file rgrd1.f must be loaded with rgrd2.f.  it includes
    !     subroutines called by the routines in rgrd2.f

    ! ... requirements

    !     each of the x,y grids must be strictly montonically increasing
    !     and each of the xx,yy grids must be montonically increasing (see
    !     ier = 4).  in addition the (X,Y) region

    !          [xx(1),xx(mx)] X [yy(1),yy(my)]

    !     must lie within the (X,Y) region

    !          [x(1),x(nx)] X [y(1),y(ny)].

    !     extrapolation is not allowed (see ier=3).  if these (X,Y)
    !     regions are identical and the orthogonal grids are UNIFORM
    !     in each direction then subroutine rgrd2u (see file rgrd2u.f)
    !     should be used instead of rgrd2.

    ! ... efficiency

    !     inner most loops in regridpack software vectorize.
    !     If the arguments mx,my (see below) have different values, optimal
    !     vectorization will be achieved if mx > my.

    ! *** input argument

    ! ... nx

    !     the integer dimension of the grid vector x and the first dimension
    !     of p.  nx > 1 if intpol(1) = 1 or nx > 3 if intpol(1) = 3 is required.

    ! ... ny

    !     the integer dimension of the grid vector y and the second dimension
    !     of p.  ny > 1 if intpol(2) = 1 or ny > 3 if intpol(2) = 3 is required.

    ! ... x

    !     a real (kind=8) nx vector of strictly increasing values which defines the x
    !     portion of the orthogonal grid on which p is given

    ! ... y

    !     a real (kind=8) ny vector of strictly increasing values which defines the y
    !     portion of the orthogonal grid on which p is given

    ! ... p

    !     a real (kind=8) nx by ny array of values given on the orthogonal (x,y) grid

    ! ... mx

    !     the integer dimension of the grid vector xx and the first dimension
    !     of q.  mx > 0 is required.

    ! ... my

    !     the integer dimension of the grid vector yy and the second dimension
    !     of q.  my > 0 is required.

    ! ... xx

    !     a real (kind=8) mx vector of increasing values which defines the x portion of the
    !     orthogonal grid on which q is defined.  xx(1) < x(1) or xx(mx) > x(nx)
    !     is not allowed (see ier = 3)

    ! ... yy

    !     a real (kind=8) my vector of increasing values which defines the y portion of the
    !     orthogonal grid on which q is defined.  yy(1) < y(1) or yy(my) > y(ny)
    !     is not allowed (see ier = 3)

    ! ... intpol

    !     an integer vector of dimension 2 which sets linear or cubic
    !     interpolation in the x,y directions as follows:

    !        intpol(1) = 1 sets linear interpolation in the x direction
    !        intpol(1) = 3 sets cubic interpolation in the x direction.

    !        intpol(2) = 1 sets linear interpolation in the y direction
    !        intpol(2) = 3 sets cubic interpolation in the y direction.

    !     values other than 1 or 3 in intpol are not allowed (ier = 5).

    ! ... w

    !     a real (kind=8) work space of length at least lw which must be provided in the
    !     routine calling rgrd2

    ! ... lw

    !     the integer length of the real (kind=8) work space w.  let

    !          lwx =   mx            if intpol(1) = 1
    !          lwx = 4*mx            if intpol(1) = 3

    !          lwy = my+2*mx         if intpol(2) = 1
    !          lwy = 4*(mx+my)       if intpol(2) = 3

    !     then lw must be greater than or equal to lwx+lwy

    ! ... iw

    !     an integer work space of length at least liw which must be provided in the
    !     routine calling rgrd2

    ! ... liw

    !     the integer length of the integer work space iw.  liw must be at least mx+my

    ! *** output arguments

    ! ... q

    !     a real (kind=8) mx by my array of values on the (xx,yy) grid which are
    !     interpolated from p on the (x,y) grid

    ! ... ier

    !     an integer error flag set as follows:

    !     ier = 0 if no errors in input arguments are detected

    !     ier = 1 if  min0(mx,my) < 1

    !     ier = 2 if nx < 2 when intpol(1)=1 or nx < 4 when intpol(1)=3 (or)
    !                ny < 2 when intpol(2)=1 or ny < 4 when intpol(2)=3

    !     ier = 3 if xx(1) < x(1) or x(nx) < xx(mx) (or)
    !                yy(1) < y(1) or y(ny) < yy(my) (or)

    ! *** to avoid this flag when end points are intended to be the
    !     same but may differ slightly due to roundoff error, they
    !     should be set exactly in the calling routine (e.g., if both
    !     grids have the same y boundaries then yy(1)=y(1) and yy(my)=y(ny)
    !     should be set before calling rgrd2)

    !     ier = 4 if one of the grids x,y is not strictly monotonically
    !             increasing or if one of the grids xx,yy is not
    !             montonically increasing.  more precisely if:

    !             x(i+1) <= x(i) for some i such that 1 <= i < nx (or)

    !             y(j+1) <= y(j) for some j such that 1 <= j < ny (or)

    !             xx(ii+1) < xx(ii) for some ii such that 1 <= ii < mx (or)

    !             yy(jj+1) < yy(jj) for some jj such that 1 <= jj < my

    !     ier = 5 if lw or liw is to small (insufficient work space)

    !     ier = 6 if intpol(1) or intpol(2) is not equal to 1 or 3

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

    !     end of rgrd2 documentation, fortran code follows:

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

    SUBROUTINE rgrd2(nx,ny,x,y,p,mx,my,xx,yy,q,intpol,w,lw,iw,liw,ier)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    real (kind=8), INTENT(IN)                :: x(nx)
    real (kind=8), INTENT(IN)                :: y(ny)
    real (kind=8), INTENT(IN)                :: p(nx,ny)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    real (kind=8), INTENT(IN)                :: xx(mx)
    real (kind=8), INTENT(IN)                :: yy(my)
    real (kind=8), INTENT(OUT)               :: q(mx,my)
    INTEGER, INTENT(IN)                      :: intpol(2)
    real (kind=8), INTENT(INOUT)             :: w(lw)
    INTEGER, INTENT(IN)                      :: lw
    INTEGER, INTENT(INOUT)                   :: iw(liw)
    INTEGER, INTENT(IN)                      :: liw
    INTEGER, INTENT(OUT)                     :: ier

    INTEGER :: i,ii,j,jj,j2,j3,j4,j5,j6,j7,j8,j9,i2,i3,i4,i5
    INTEGER :: jy,lwx,lwy

    !     check input arguments

    ier = 1

    !     check (xx,yy) grid resolution

    IF (MIN0(mx,my) < 1) RETURN

    !     check intpol

    ier = 6
    IF (intpol(1) /= 1 .AND. intpol(1) /= 3) RETURN
    IF (intpol(2) /= 1 .AND. intpol(2) /= 3) RETURN

    !     check (x,y) grid resolution

    ier = 2
    IF (intpol(1) == 1 .AND. nx < 2) RETURN
    IF (intpol(1) == 3 .AND. nx < 4) RETURN
    IF (intpol(2) == 1 .AND. ny < 2) RETURN
    IF (intpol(2) == 3 .AND. ny < 4) RETURN

    !     check work space lengths

    ier = 5
    IF (intpol(1) == 1) THEN
      lwx = mx
    ELSE
      lwx = 4*mx
    END IF
    IF (intpol(2) == 1) THEN
      lwy = my+2*mx
    ELSE
      lwy = 4*(mx+my)
    END IF
    IF (lw < lwx+lwy) RETURN
    IF (liw < mx+my) RETURN

    !     check (xx,yy) grid contained in (x,y) grid

    ier = 3
    IF (xx(1) < x(1) .OR. xx(mx) > x(nx)) RETURN
    IF (yy(1) < y(1) .OR. yy(my) > y(ny)) RETURN

    !     check montonicity of grids

    ier = 4
    DO i=2,nx
      IF (x(i-1) >= x(i)) RETURN
    END DO
    DO j=2,ny
      IF (y(j-1) >= y(j)) RETURN
    END DO
    DO ii=2,mx
      IF (xx(ii-1) > xx(ii)) RETURN
    END DO
    DO jj=2,my
      IF (yy(jj-1) > yy(jj)) RETURN
    END DO

    !     arguments o.k.

    ier = 0

    !     set pointer in integer work space

    jy = mx+1
    IF (intpol(2) == 1) THEN

    !     linearly interpolate in y

      j2 = 1
      j3 = j2
      j4 = j3+my
      j5 = j4
      j6 = j5
      j7 = j6
      j8 = j7+mx
      j9 = j8+mx

    !     set y interpolation indices and scales and linearly interpolate

      CALL linmx(ny,y,my,yy,iw(jy),w(j3))
      i2 = j9

    !     set work space portion and indices which depend on x interpolation

      IF (intpol(1) == 1) THEN
        i3 = i2
        i4 = i3
        i5 = i4
        CALL linmx(nx,x,mx,xx,iw,w(i3))
      ELSE
        i3 = i2+mx
        i4 = i3+mx
        i5 = i4+mx
        CALL cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
      END IF
      CALL lint2(nx,ny,p,mx,my,q,intpol,iw(jy),w(j3),  &
          w(j7),w(j8),iw,w(i2),w(i3),w(i4),w(i5))
      RETURN

    ELSE

    !     cubically interpolate in y, set indice pointers

      j2 = 1
      j3 = j2+my
      j4 = j3+my
      j5 = j4+my
      j6 = j5+my
      j7 = j6+mx
      j8 = j7+mx
      j9 = j8+mx
      CALL cubnmx(ny,y,my,yy,iw(jy),w(j2),w(j3),w(j4),w(j5))
      i2 =  j9+mx

    !     set work space portion and indices which depend on x interpolation

      IF (intpol(1) == 1) THEN
        i3 = i2
        i4 = i3
        i5 = i4
        CALL linmx(nx,x,mx,xx,iw,w(i3))
      ELSE
        i3 = i2+mx
        i4 = i3+mx
        i5 = i4+mx
        CALL cubnmx(nx,x,mx,xx,iw,w(i2),w(i3),w(i4),w(i5))
      END IF
      CALL cubt2(nx,ny,p,mx,my,q,intpol,iw(jy),w(j2),w(j3),  &
          w(j4),w(j5),w(j6),w(j7),w(j8),w(j9),iw,w(i2),w(i3),w(i4),w(i5))
      RETURN
    END IF
    END SUBROUTINE rgrd2

    SUBROUTINE lint2(nx,ny,p,mx,my,q,intpol,jy,dy,pj,pjp, ix,dxm,dx,dxp,dxpp)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    real (kind=8), INTENT(IN)                :: p(nx,ny)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    real (kind=8), INTENT(OUT)               :: q(mx,my)
    INTEGER, INTENT(IN)                      :: intpol(2)
    INTEGER, INTENT(IN)                      :: jy(my)
    real (kind=8), INTENT(IN)                :: dy(my)
    real (kind=8), INTENT(OUT)               :: pj(mx)
    real (kind=8), INTENT(IN OUT)            :: pjp(mx)
    INTEGER, INTENT(IN OUT)                  :: ix(mx)
    real (kind=8), INTENT(IN OUT)            :: dxm(mx)
    real (kind=8), INTENT(IN OUT)            :: dx(mx)
    real (kind=8), INTENT(IN OUT)            :: dxp(mx)
    real (kind=8), INTENT(IN OUT)            :: dxpp(mx)

    INTEGER :: jsave,j,jj,ii

    !     linearly interpolate in y

    IF (intpol(1) == 1) THEN

    !     linear in x

      jsave = -1
      DO jj=1,my
        j = jy(jj)
        IF (j == jsave) THEN

    !       j pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (j == jsave+1) THEN

    !       update j and interpolate j+1

          DO ii=1,mx
            pj(ii) = pjp(ii)
          END DO
          CALL lint1(nx,p(1,j+1),mx,pjp,ix,dx)
        ELSE

    !       interpolate j,j+1in pj,pjp on xx mesh

          CALL lint1(nx,p(1,j),mx,pj,ix,dx)
          CALL lint1(nx,p(1,j+1),mx,pjp,ix,dx)
        END IF

    !       save j pointer for next pass

        jsave = j

    !       linearly interpolate q(ii,jj) from pjp,pj in y direction

        DO ii=1,mx
          q(ii,jj) = pj(ii)+dy(jj)*(pjp(ii)-pj(ii))
        END DO
      END DO

    ELSE

    !     cubic in x

      jsave = -1
      DO jj=1,my
        j = jy(jj)
        IF (j == jsave) THEN

    !       j pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (j == jsave+1) THEN

    !       update j and interpolate j+1

          DO ii=1,mx
            pj(ii) = pjp(ii)
          END DO
          CALL cubt1(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp)
        ELSE

    !       interpolate j,j+1 in pj,pjp on xx mesh

          CALL cubt1(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp)
          CALL cubt1(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp)
        END IF

    !       save j pointer for next pass

        jsave = j

    !       linearly interpolate q(ii,jj) from pjp,pj in y direction

        DO ii=1,mx
          q(ii,jj) = pj(ii)+dy(jj)*(pjp(ii)-pj(ii))
        END DO
      END DO
      RETURN
    END IF
    END SUBROUTINE lint2

    SUBROUTINE cubt2(nx,ny,p,mx,my,q,intpol,jy,dym,dy,dyp,  &
        dypp,pjm,pj,pjp,pjpp,ix,dxm,dx,dxp,dxpp)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    real (kind=8), INTENT(IN)                :: p(nx,ny)
    INTEGER, INTENT(IN)                      :: mx
    INTEGER, INTENT(IN)                      :: my
    real (kind=8), INTENT(OUT)               :: q(mx,my)
    INTEGER, INTENT(IN)                      :: intpol(2)
    INTEGER, INTENT(IN)                      :: jy(my)
    real (kind=8), INTENT(IN)                :: dym(my)
    real (kind=8), INTENT(IN)                :: dy(my)
    real (kind=8), INTENT(IN)                :: dyp(my)
    real (kind=8), INTENT(IN OUT)            :: dypp(my)
    real (kind=8), INTENT(OUT)               :: pjm(mx)
    real (kind=8), INTENT(IN OUT)            :: pj(mx)
    real (kind=8), INTENT(IN OUT)            :: pjp(mx)
    real (kind=8), INTENT(IN OUT)            :: pjpp(mx)
    INTEGER, INTENT(IN OUT)                  :: ix(mx)
    real (kind=8), INTENT(IN OUT)            :: dxm(mx)
    real (kind=8), INTENT(IN OUT)            :: dx(mx)
    real (kind=8), INTENT(IN OUT)            :: dxp(mx)
    real (kind=8), INTENT(IN OUT)            :: dxpp(mx)

    INTEGER :: jsave,j,jj,ii

    IF (intpol(1) == 1) THEN

    !     linear in x

      jsave = -3
      DO jj=1,my

    !       load closest four j lines containing interpolate on xx mesh
    !       for j-1,j,j+1,j+2 in pjm,pj,pjp,pjpp

        j = jy(jj)
        IF (j == jsave) THEN

    !       j pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (j == jsave+1) THEN

    !       update j-1,j,j+1 and interpolate j+2

          DO ii=1,mx
            pjm(ii) = pj(ii)
            pj(ii) = pjp(ii)
            pjp(ii) = pjpp(ii)
          END DO
          CALL lint1(nx,p(1,j+2),mx,pjpp,ix,dx)
        ELSE IF (j == jsave+2) THEN

    !     update j-1,j and interpolate j+1,j+2

          DO ii=1,mx
            pjm(ii) = pjp(ii)
            pj(ii) = pjpp(ii)
          END DO
          CALL lint1(nx,p(1,j+1),mx,pjp,ix,dx)
          CALL lint1(nx,p(1,j+2),mx,pjpp,ix,dx)
        ELSE IF (j == jsave+3) THEN

    !       update j-1 and interpolate j,j+1,j+2

          DO ii=1,mx
            pjm(ii) = pjpp(ii)
          END DO
          CALL lint1(nx,p(1,j),mx,pj,ix,dx)
          CALL lint1(nx,p(1,j+1),mx,pjp,ix,dx)
          CALL lint1(nx,p(1,j+2),mx,pjpp,ix,dx)
        ELSE

    !       interpolate all four j-1,j,j+1,j+2

          CALL lint1(nx,p(1,j-1),mx,pjm,ix,dx)
          CALL lint1(nx,p(1,j),mx,pj,ix,dx)
          CALL lint1(nx,p(1,j+1),mx,pjp,ix,dx)
          CALL lint1(nx,p(1,j+2),mx,pjpp,ix,dx)
        END IF

    !     save j pointer for next pass

        jsave = j

    !     cubically interpolate q(ii,jj) from pjm,pj,pjp,pjpp in y direction

        DO ii=1,mx
          q(ii,jj) = dym(jj)*pjm(ii)+dy(jj)*pj(ii)+dyp(jj)*pjp(ii)+  &
              dypp(jj)*pjpp(ii)
        END DO
      END DO
      RETURN

    ELSE

    !     cubic in x

      jsave = -3
      DO jj=1,my

    !       load closest four j lines containing interpolate on xx mesh
    !       for j-1,j,j+1,j+2 in pjm,pj,pjp,pjpp

        j = jy(jj)
        IF (j == jsave) THEN

    !         j pointer has not moved since last pass (no updates or interpolation)

        ELSE IF (j == jsave+1) THEN

    !         update j-1,j,j+1 and interpolate j+2

          DO ii=1,mx
            pjm(ii) = pj(ii)
            pj(ii) = pjp(ii)
            pjp(ii) = pjpp(ii)
          END DO
          CALL cubt1(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp)
        ELSE IF (j == jsave+2) THEN

    !         update j-1,j and interpolate j+1,j+2

          DO ii=1,mx
            pjm(ii) = pjp(ii)
            pj(ii) = pjpp(ii)
          END DO
          CALL cubt1(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp)
          CALL cubt1(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp)
        ELSE IF (j == jsave+3) THEN

    !         update j-1 and interpolate j,j+1,j+2

          DO ii=1,mx
            pjm(ii) = pjpp(ii)
          END DO
          CALL cubt1(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp)
          CALL cubt1(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp)
          CALL cubt1(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp)
        ELSE

    !         interpolate all four j-1,j,j+1,j+2

          CALL cubt1(nx,p(1,j-1),mx,pjm,ix,dxm,dx,dxp,dxpp)
          CALL cubt1(nx,p(1,j),mx,pj,ix,dxm,dx,dxp,dxpp)
          CALL cubt1(nx,p(1,j+1),mx,pjp,ix,dxm,dx,dxp,dxpp)
          CALL cubt1(nx,p(1,j+2),mx,pjpp,ix,dxm,dx,dxp,dxpp)
        END IF

    !       save j pointer for next pass

        jsave = j

    !       cubically interpolate q(ii,jj) from pjm,pj,pjp,pjpp in y direction

        DO ii=1,mx
          q(ii,jj) = dym(jj)*pjm(ii)+dy(jj)*pj(ii)+dyp(jj)*pjp(ii)+  &
              dypp(jj)*pjpp(ii)
        END DO
      END DO
      RETURN
    END IF
    END SUBROUTINE cubt2
end module


!-----------------------------------------------------------------------
!
! Header with common subroutine
!
      include 't320-basis-f.h'
!-----------------------------------------------------------------------
      subroutine feval(x1,x2,val)
      real*8 x1,x2,val

      val=x1*x1+x2*x2+x1*x2+1

      end
!-----------------------------------------------------------------------
      subroutine dfeval(x1,x2,val)
      real*8 x1,x2,val

      val=2*x1+x2

      end
!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err
      integer input,output
      integer p,q,d
      parameter(p=6)
      parameter(q=4)
      parameter(d=2)

      real*8 qref(d*q)
      real*8 qweight(q)
      real*8 interp(p*q)
      real*8 grad(d*p*q)
      real*8 xq(d*q)
      real*8 xr(d*p)
      real*8 iinput(p)
      real*8 ooutput(d*q)
      real*8 val,diff
      real*8 x1,x2
      integer*8 ioffset,ooffset

      integer b,i

      character arg*32

      xq=(/2.d-1,6.d-1,1.d0/3.d0,2.d-1,2.d-1,2.d-1,   1.d0/3.d0,6.d-1/)
      xr=(/0.d0,5.d-1,1.d0,0.d0,5.d-1,0.d0,0.d0,0.d0,   0.d0,5.d-1,5.d-1,1.d0/)

      call getarg(1,arg)

      call buildmats(qref,qweight,interp,grad)

      call ceedinit(trim(arg)//char(0),ceed,err)

      call ceedbasiscreateh1(ceed,ceed_triangle,1,p,q,interp,grad,qref,qweight,&
     & b,err)

      do i=1,p
        x1=xr(0*p+i)
        x2=xr(1*p+i)
        call feval(x1,x2,val)
        iinput(i)=val
      enddo

      call ceedvectorcreate(ceed,p,input,err)
      ioffset=0
      call ceedvectorsetarray(input,ceed_mem_host,ceed_use_pointer,iinput,&
     & ioffset,err)
      call ceedvectorcreate(ceed,q*d,output,err)
      call ceedvectorsetvalue(output,0.d0,err)

      call ceedbasisapply(b,1,ceed_notranspose,ceed_eval_grad,input,output,err)

      call ceedvectorgetarrayread(output,ceed_mem_host,ooutput,ooffset,err)
      do i=1,q
        x1=xq(0*q+i)
        x2=xq(1*q+i)
        call dfeval(x1,x2,val)
        diff=val-ooutput(0*q+i+ooffset)
        if (abs(diff)>1.0d-10) then
! LCOV_EXCL_START
          write(*,'(A,I1,A,F12.8,A,F12.8)')  '[',i,'] ',ooutput(i+ooffset),&
     &     ' != ',val
! LCOV_EXCL_STOP
        endif
        call dfeval(x2,x1,val)
        diff=val-ooutput(1*q+i+ooffset)
        if (abs(diff)>1.0d-10) then
! LCOV_EXCL_START
          write(*,'(A,I1,A,F12.8,A,F12.8)')  '[',i,'] ',ooutput(i+ooffset),&
     &     ' != ',val
! LCOV_EXCL_STOP
        endif
      enddo
      call ceedvectorrestorearrayread(output,ooutput,ooffset,err)

      call ceedvectordestroy(input,err)
      call ceedvectordestroy(output,err)
      call ceedbasisdestroy(b,err)
      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


subroutine zinv(A, ndim)
  IMPLICIT NONE
  COMPLEX*16, intent(inout) :: A(ndim,ndim)
  INTEGER, intent(in)       :: ndim
  ! locals
  INTEGER    :: info, lwork, lda
  INTEGER    :: ipiv(ndim)
  COMPLEX*16 :: work(ndim*64)
  lwork = ndim*64
  lda = ndim

  CALL ZGETRF( ndim, ndim, A, lda, ipiv, info )

  if (info.ne.0) then
     print *, 'zgetrf info=', info
  endif

  CALL ZGETRI( ndim, A, lda, ipiv, work, lwork, info )

  if (info.ne.0) then
     print *, 'zgetri info=', info
  endif

end subroutine zinv

subroutine dinv(A, ndim)
  IMPLICIT NONE
  REAL*8, intent(inout) :: A(ndim,ndim)
  INTEGER, intent(in)   :: ndim
  ! locals
  INTEGER    :: info, lwork, lda
  INTEGER    :: ipiv(ndim)
  REAL*8 :: work(ndim*64)
  lwork = ndim*64
  lda = ndim

  CALL DGETRF( ndim, ndim, A, lda, ipiv, info )

  if (info.ne.0) then
     print *, 'dgetrf info=', info
  endif

  CALL DGETRI( ndim, A, lda, ipiv, work, lwork, info )

  if (info.ne.0) then
     print *, 'dgetri info=', info
  endif

end subroutine dinv


c---------------------------------------------------------------------
      double precision function randlc (x, a)
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c
c   This routine returns a uniform pseudorandom double precision number in the
c   range (0, 1) by using the linear congruential generator
c
c   x_{k+1} = a x_k  (mod 2^46)
c
c   where 0 < x_k < 2^46 and 0 < a < 2^46.  This scheme generates 2^44 numbers
c   before repeating.  The argument A is the same as 'a' in the above formula,
c   and X is the same as x_0.  A and X must be odd double precision integers
c   in the range (1, 2^46).  The returned value RANDLC is normalized to be
c   between 0 and 1, i.e. RANDLC = 2^(-46) * x_1.  X is updated to contain
c   the new seed x_1, so that subsequent calls to RANDLC using the same
c   arguments will generate a continuous sequence.
c
c   This routine should produce the same results on any computer with at least
c   48 mantissa bits in double precision floating point data.  On 64 bit
c   systems, double precision should be disabled.
c
c   David H. Bailey     October 26, 1990
c
c---------------------------------------------------------------------

      implicit none

      double precision r23,r46,t23,t46,a,x,t1,t2,t3,t4,a1,a2,x1,x2,z
      parameter (r23 = 0.5d0 ** 23, r46 = r23 ** 2, t23 = 2.d0 ** 23,
     >  t46 = t23 ** 2)

c---------------------------------------------------------------------
c   Break A into two parts such that A = 2^23 * A1 + A2.
c---------------------------------------------------------------------
      t1 = r23 * a
      a1 = int (t1)
      a2 = a - t23 * a1

c---------------------------------------------------------------------
c   Break X into two parts such that X = 2^23 * X1 + X2, compute
c   Z = A1 * X2 + A2 * X1  (mod 2^23), and then
c   X = 2^23 * Z + A2 * X2  (mod 2^46).
c---------------------------------------------------------------------
      t1 = r23 * x
      x1 = int (t1)
      x2 = x - t23 * x1

      t1 = a1 * x2 + a2 * x1
      t2 = int (r23 * t1)
      z = t1 - t23 * t2
      t3 = t23 * z + a2 * x2
      t4 = int (r46 * t3)
      x = t3 - t46 * t4
      randlc = r46 * x
      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine vranlc (n, x, a, y)

c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   This routine generates N uniform pseudorandom double precision numbers in
c   the range (0, 1) by using the linear congruential generator
c
c   x_{k+1} = a x_k  (mod 2^46)
c
c   where 0 < x_k < 2^46 and 0 < a < 2^46.  This scheme generates 2^44 numbers
c   before repeating.  The argument A is the same as 'a' in the above formula,
c   and X is the same as x_0.  A and X must be odd double precision integers
c   in the range (1, 2^46).  The N results are placed in Y and are normalized
c   to be between 0 and 1.  X is updated to contain the new seed, so that
c   subsequent calls to RANDLC using the same arguments will generate a
c   continuous sequence.
c
c   This routine generates the output sequence in batches of length NV, for
c   convenience on vector computers.  This routine should produce the same
c   results on any computer with at least 48 mantissa bits in double precision
c   floating point data.  On Cray systems, double precision should be disabled.
c
c   David H. Bailey    August 30, 1990
c---------------------------------------------------------------------

      integer n
      double precision x, a, y(*)

      double precision r23, r46, t23, t46
      integer nv
      parameter (r23 = 2.d0 ** (-23), r46 = r23 * r23, t23 = 2.d0 ** 23,
     >     t46 = t23 * t23, nv = 64)
      double precision  xv(nv), t1, t2, t3, t4, an, a1, a2, x1, x2, yy
      integer n1, i, j
      external randlc
      double precision randlc

c---------------------------------------------------------------------
c     Compute the first NV elements of the sequence using RANDLC.
c---------------------------------------------------------------------
      t1 = x
      n1 = min (n, nv)

      do  i = 1, n1
         xv(i) = t46 * randlc (t1, a)
      enddo

c---------------------------------------------------------------------
c     It is not necessary to compute AN, A1 or A2 unless N is greater than NV.
c---------------------------------------------------------------------
      if (n .gt. nv) then

c---------------------------------------------------------------------
c     Compute AN = AA ^ NV (mod 2^46) using successive calls to RANDLC.
c---------------------------------------------------------------------
         t1 = a
         t2 = r46 * a

         do  i = 1, nv - 1
            t2 = randlc (t1, a)
         enddo

         an = t46 * t2

c---------------------------------------------------------------------
c     Break AN into two parts such that AN = 2^23 * A1 + A2.
c---------------------------------------------------------------------
         t1 = r23 * an
         a1 = aint (t1)
         a2 = an - t23 * a1
      endif

c---------------------------------------------------------------------
c     Compute N pseudorandom results in batches of size NV.
c---------------------------------------------------------------------
      do  j = 0, n - 1, nv
         n1 = min (nv, n - j)

c---------------------------------------------------------------------
c     Compute up to NV results based on the current seed vector XV.
c---------------------------------------------------------------------
         do  i = 1, n1
            y(i+j) = r46 * xv(i)
         enddo

c---------------------------------------------------------------------
c     If this is the last pass through the 140 loop, it is not necessary to
c     update the XV vector.
c---------------------------------------------------------------------
         if (j + n1 .eq. n) goto 150

c---------------------------------------------------------------------
c     Update the XV vector by multiplying each element by AN (mod 2^46).
c---------------------------------------------------------------------
         do  i = 1, nv
            t1 = r23 * xv(i)
            x1 = aint (t1)
            x2 = xv(i) - t23 * x1
            t1 = a1 * x2 + a2 * x1
            t2 = aint (r23 * t1)
            yy = t1 - t23 * t2
            t3 = t23 * yy + a2 * x2
            t4 = aint (r46 * t3)
            xv(i) = t3 - t46 * t4
         enddo

      enddo

c---------------------------------------------------------------------
c     Save the last seed in X so that subsequent calls to VRANLC will generate
c     a continuous sequence.
c---------------------------------------------------------------------
 150  x = xv(n1)

      return
      end

c----- end of program ------------------------------------------------


module init_module

  use datatypes_module

  implicit none

contains

  subroutine prob_init(U)

    use grid_module
    use runtime_params_module

    implicit none

    real(dp_t) :: U(a_lo:a_hi, NVAR)

    integer :: i

    do i = ilo, ihi
       if (x(i) < 0.5_dp_t) then
          ! left half
          U(i,URHO) = rho_l
          U(i,UMX) = rho_l * u_l
          U(i,UENER) = p_l/(gamma - 1.0_dp_t) + 0.5_dp_t * rho_l * u_l**2

       else
          ! left half
          U(i,URHO) = rho_r
          U(i,UMX) = rho_r * u_r
          U(i,UENER) = p_r/(gamma - 1.0_dp_t) + 0.5_dp_t * rho_r * u_r**2

       endif

    enddo

  end subroutine prob_init

end module init_module


SUBROUTINE p43(input_file,output_file)
!-------------------------------------------------------------------------
! Program 4.3 Analysis of elastic beams using 2-node beam elements
!             (elastic foundation optional).
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,k,loaded_nodes,ndof=4,nels,neq,nod=2,      &
   nodof=2,nn,nprops,np_types,nr,nlen
 REAL(iwp)::penalty=1.0e20_iwp,zero=0.0_iwp
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),kdiag(:),nf(:,:),no(:),      &
   node(:),num(:),sense(:)
 REAL(iwp),ALLOCATABLE::action(:),eld(:),ell(:),km(:,:),kv(:),loads(:),   &
   mm(:,:),prop(:,:),value(:)
 CHARACTER(LEN=15)::argv
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,nprops,np_types
 nn=nels+1
 ALLOCATE(g(ndof),num(nod),nf(nodof,nn),etype(nels),ell(nels),eld(ndof),  &
   km(ndof,ndof),mm(ndof,ndof),action(ndof),g_g(ndof,nels),               &
   prop(nprops,np_types))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)ell
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq))
!-----------------------loop the elements to find global array sizes------
 kdiag=0
 elements_1: DO iel=1,nels
   num=(/iel,iel+1/)
   CALL num_to_g(num,nf,g)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------global stiffness matrix assembly------------------
 kv=zero
 elements_2: DO iel=1, nels
   CALL beam_km(km,prop(1,etype(iel)),ell(iel))
   mm=zero
   IF(nprops>1)CALL beam_mm(mm,prop(2,etype(iel)),ell(iel))
   g=g_g(:,iel)
   CALL fsparv(kv,km+mm,g,kdiag)
 END DO elements_2
!-----------------------read loads and/or displacements-------------------
 loads=zero
 READ(10,*)loaded_nodes,(k,loads(nf(:,k)),i=1,loaded_nodes)
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),no(fixed_freedoms),                      &
     sense(fixed_freedoms),value(fixed_freedoms))
   READ(10,*)(node(i),sense(i),value(i),i=1,fixed_freedoms)
   DO i=1,fixed_freedoms
     no(i)=nf(sense(i),node(i))
   END DO
   kv(kdiag(no))=kv(kdiag(no))+penalty
   loads(no)=kv(kdiag(no))*value
 END IF
!-----------------------equation solution --------------------------------
 CALL sparin(kv,kdiag)
 CALL spabac(kv,loads,kdiag)
 loads(0)=zero
 WRITE(11,'(/A)')"  Node Translation Rotation"
 DO k=1,nn
   WRITE(11,'(I5,2E12.4)')k,loads(nf(:,k))
 END DO
!-----------------------retrieve element end actions----------------------
 WRITE(11,'(/A)')" Element Force       Moment      Force       Moment"
 elements_3: DO iel=1,nels
   CALL beam_km(km,prop(1,etype(iel)),ell(iel))
   mm=zero
   IF(nprops>1)CALL beam_mm(mm,prop(2,etype(iel)),ell(iel))
   g=g_g(:,iel)
   eld=loads(g)
   action=MATMUL(km+mm,eld)
   WRITE(11,'(I5,4E12.4)')iel,action
 END DO elements_3
 CALL beamdis(loads,nf,0.40_iwp,10,nels,ell,argv,nlen,12)
END SUBROUTINE p43


      PROGRAM MAIN
          USE CONFIG
          USE DISPLAY
          USE EDGEMATRIX
          USE LINE
          USE MATRIXUTIL
          USE UTILITIES

          IMPLICIT NONE
          INTEGER :: I, COLOR(3), THEDISPLAY(3, DIMD, DIMC, DIMR)

          CHARACTER(LEN=128) :: FILENAME ! hard-limit for now
          CHARACTER(LEN=128) :: LINE
          CHARACTER          :: RDIR
          LOGICAL  :: BOOL
          INTEGER  :: IOS
          REAL(DP) :: RDATA(10)
          REAL(DP) :: TMPTRANS(4, 4)

          REAL(DP) :: TRANSM(4, 4)
          TYPE(EDGMAT) :: EDGES

          CALL GET_COMMAND_ARGUMENT(1, FILENAME)
          INQUIRE(FILE=FILENAME, EXIST=BOOL)
          IF (.NOT. BOOL) THEN
              WRITE (0,*) 'Specified file "', TRIM(ADJUSTL(FILENAME)),
     +                    '" does not exist; bailing out.'
              STOP
          END IF

          CALL EDGES%INIT()
          COLOR = [255, 0, 0]
          IOS = 0

          OPEN(RFD, FILE=FILENAME, ACTION="READ")
          DO
              READ (RFD,*,IOSTAT=IOS) LINE
              IF (IOS .NE. 0) EXIT
              SELECT CASE (LINE)
                  CASE ("line")
                      READ (RFD,*) RDATA(1:6)
                      CALL EDGES%ADDEDGE(RDATA(1:3), RDATA(4:6))
                  CASE ("ident")
                      CALL MATRIX_IDENT(TRANSM)
                  CASE ("scale")
                      READ (RFD,*) RDATA(1:3)
                      CALL MATRIX_SCALE(TMPTRANS, RDATA(1:3))
                      TRANSM = MATRIX_MULT(TMPTRANS, TRANSM)
                  CASE ("move")
                      READ (RFD,*) RDATA(1:3)
                      CALL MATRIX_TRANSLATE(TMPTRANS, RDATA(1:3))
                      TRANSM = MATRIX_MULT(TMPTRANS, TRANSM)
                  CASE ("rotate")
                      READ (RFD,*) RDIR, RDATA(1)
                      RDATA(1) = DEG2RAD(RDATA(1))
                      SELECT CASE (RDIR)
                          CASE("x")
                              CALL MATRIX_ROTATE(TMPTRANS, RDATA(1), 1)
                          CASE("y")
                              CALL MATRIX_ROTATE(TMPTRANS, RDATA(1), 2)
                          CASE("z")
                              CALL MATRIX_ROTATE(TMPTRANS, RDATA(1), 3)
                      END SELECT
                      TRANSM = MATRIX_MULT(TMPTRANS, TRANSM)
                  CASE ("apply")
                      CALL EDGES%TRANSFORM(TRANSM)
                  CASE ("save")
                      READ (RFD,*) LINE
                      CALL EDGES%DRAW(THEDISPLAY, COLOR)
                      OPEN(WFD, FILE=LINE, ACTION="WRITE")
                      CALL DISPLAY_PRINT(THEDISPLAY, WFD)
                      CLOSE(WFD)
                  CASE DEFAULT
                      WRITE (0,*) 'Warning: could not interpret "',
     +                  TRIM(ADJUSTL(LINE)), '" at postion', FTELL(RFD)
              END SELECT
          END DO
          CLOSE(RFD)

      END PROGRAM MAIN


Module vector_class
! module contains full vector class implmentation
!
!
    use constants, only : wp

    type :: vector
        real(kind=wp)  :: x, y, z
        contains

        procedure :: magnitude       => magnitude_fn
        procedure :: print           => print_sub
        procedure :: length          => length
        generic   :: operator(.dot.) => vec_dot_vec, vec_dot_mat
        generic   :: operator(/)     => vec_div_scal_r4, vec_div_scal_int
        generic   :: operator(*)     => vec_mult_vec, vec_mult_scal, scal_mult_vec
        generic   :: operator(+)     => vec_add_vec, vec_add_scal, scal_add_vec
        generic   :: operator(-)     => vec_minus_vec, vec_minus_scal, scal_minus_vec

        procedure, pass(a), private :: vec_dot_vec
        procedure, pass(a), private :: vec_dot_mat

        procedure, pass(a), private :: vec_div_scal_r4
        procedure, pass(a), private :: vec_div_scal_int

        procedure, pass(a), private :: vec_mult_vec
        procedure, pass(a), private :: vec_mult_scal
        procedure, pass(b), private :: scal_mult_vec

        procedure, pass(a), private :: vec_add_vec
        procedure, pass(a), private :: vec_add_scal
        procedure, pass(b), private :: scal_add_vec

        procedure, pass(a), private :: vec_minus_vec
        procedure, pass(a), private :: vec_minus_scal
        procedure, pass(b), private :: scal_minus_vec

    end type vector

    private
    public :: magnitude, vector, print, abs, length, max, invert, nint, clamp_vec

    interface nint
        module procedure nint_vec
    end interface nint

    interface abs
        module procedure abs_vec
    end interface abs

    interface max
        module procedure max_vec
    end interface max

    contains

        type(vector) function clamp_vec(this, lo, hi)

            use utils, only : clamp

            implicit none

            type(vector), intent(IN) :: this, lo, hi

            real(kind=wp) :: x, y, z

            x = clamp(this%x, lo%x, hi%x)
            y = clamp(this%y, lo%y, hi%y)
            z = clamp(this%z, lo%z, hi%z)

            clamp_vec = vector(x, y, z)

        end function clamp_vec

        type(vector) function nint_vec(this)

            implicit none

            type(vector), intent(IN) :: this

            nint_vec = vector(real(nint(this%x), kind=wp), real(nint(this%y), kind=wp), real(nint(this%z), kind=wp))

        end function nint_vec

        type(vector) function abs_vec(this)

            implicit none

            type(vector), intent(IN) :: this

            abs_vec = vector(abs(this%x), abs(this%y), abs(this%z))

        end function abs_vec

        type(vector) function max_vec(this, val)

            implicit none

            type(vector),  intent(IN) :: this
            real(kind=wp), intent(IN) :: val

            max_vec = vector(max(this%x, val), max(this%y, val), max(this%z, val))

        end function max_vec

        type(vector) function min_fn(this, val)

            implicit none

            type(vector),  intent(IN) :: this
            real(kind=wp), intent(IN) :: val

            min_fn = vector(min(this%x, val), min(this%y, val), min(this%z, val))

        end function min_fn

        type(vector) function vec_minus_vec(a, b)

            implicit none

            class(vector), intent(IN) :: a
            type(vector),  intent(IN) :: b

            vec_minus_vec = vector(a%x - b%x, a%y - b%y, a%z - b%z)

        end function vec_minus_vec

        type(vector) function vec_add_scal(a, b)

            implicit none

            class(vector), intent(IN) :: a
            real(kind=wp), intent(IN) :: b

            vec_add_scal = vector(a%x + b, a%y + b, a%z + b)

        end function vec_add_scal

        type(vector) function scal_add_vec(a, b)

            implicit none

            class(vector), intent(IN) :: b
            real(kind=wp), intent(IN) :: a

            scal_add_vec = vector(b%x + a, b%y + a, b%z + a)

        end function scal_add_vec

        type(vector) function vec_minus_scal(a, b)

            implicit none

            class(vector), intent(IN) :: a
            real(kind=wp), intent(IN) :: b

            vec_minus_scal = vector(a%x - b, a%y - b, a%z - b)

        end function vec_minus_scal

        type(vector) function scal_minus_vec(a, b)

            implicit none

            class(vector), intent(IN) :: b
            real(kind=wp), intent(IN) :: a

            scal_minus_vec = vector(b%x - a, b%y - a, b%z - a)

        end function scal_minus_vec

        type(vector) function vec_add_vec(a, b)

            implicit none

            class(vector), intent(IN) :: a
            type(vector),  intent(IN) :: b

            vec_add_vec = vector(a%x + b%x, a%y + b%y, a%z + b%z)

        end function vec_add_vec

        elemental function vec_dot_vec(a, b) result (dot)

            implicit none

            class(vector), intent(IN) :: a
            type(vector),  intent(IN) :: b
            real(kind=wp) :: dot

            dot = (a%x * b%x) + (a%y * b%y) + (a%z * b%z)

        end function vec_dot_vec

        function vec_dot_mat(a, b) result (dot)

            implicit none

            class(vector), intent(IN) :: a
            real(kind=wp), intent(IN) :: b(4, 4)
            type(vector) :: dot

            dot%x = b(1, 1)*a%x + b(2, 1)*a%y + b(3, 1)*a%z + b(4, 1)*1.
            dot%y = b(1, 2)*a%x + b(2, 2)*a%y + b(3, 2)*a%z + b(4, 2)*1.
            dot%z = b(1, 3)*a%x + b(2, 3)*a%y + b(3, 3)*a%z + b(4, 3)*1.

        end function vec_dot_mat

        type(vector) function vec_mult_vec(a, b)

            implicit none

            class(vector), intent(IN) :: a
            type(vector),  intent(IN) :: b

            vec_mult_vec = vector(a%x * b%x, a%y * b%y, a%z * b%z)

        end function vec_mult_vec

        type(vector) function vec_mult_scal(a, b)

            implicit none

            class(vector), intent(IN) :: a
            real(kind=wp), intent(IN) :: b

            vec_mult_scal = vector(a%x * b, a%y * b, a%z * b)

        end function vec_mult_scal

        type(vector) function scal_mult_vec(a, b)

            implicit none

            class(vector), intent(IN) :: b
            real(kind=wp), intent(IN) :: a

            scal_mult_vec = vector(a * b%x, a * b%y, a * b%z)

        end function scal_mult_vec

        type(vector) function vec_div_scal_r4(a, b)

            implicit none

            class(vector), intent(IN) :: a
            real(kind=wp), intent(IN) :: b

            vec_div_scal_r4 = vector(a%x / b, a%y / b, a%z / b)

        end function vec_div_scal_r4

        type(vector) function vec_div_scal_int(a, b)

            implicit none

            class(vector), intent(IN) :: a
            integer,       intent(IN) :: b

            vec_div_scal_int = vector(a%x / real(b, kind=wp), a%y / real(b, kind=wp), a%z / real(b, kind=wp))

        end function vec_div_scal_int

        type(vector) function magnitude_fn(this)

            implicit none

            class(vector) :: this

            real(kind=wp) :: tmp

            tmp = sqrt(this%x**2 + this%y**2 + this%z**2)
            magnitude_fn = this / tmp

        end function magnitude_fn

        real function length(this)

            implicit none

            class(vector) :: this

            length = sqrt(this%x**2 + this%y**2 + this%z**2)

        end function length

        subroutine print_sub(this)

            implicit none

            class(vector) :: this

            print*,this%x, this%y, this%z

        end subroutine

    pure function invert(A) result(B)
        !! from http://fortranwiki.org/fortran/show/Matrix+inversion
        !! Performs a direct calculation of the inverse of a 4×4 matrix.
        real(kind=wp), intent(in) :: A(4,4)   !! Matrix

        real(kind=wp) :: B(4,4)   !! Inverse matrix
        real(kind=wp) :: detinv

    ! Calculate the inverse determinant of the matrix
    detinv = &
      1./(A(1,1)*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))&
        - A(1,2)*(A(2,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))&
        + A(1,3)*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))&
        - A(1,4)*(A(2,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(2,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(2,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1))))

    ! Calculate the inverse of the matrix
    B(1,1) = detinv*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))
    B(2,1) = detinv*(A(2,1)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(2,3)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(2,4)*(A(3,3)*A(4,1)-A(3,1)*A(4,3)))
    B(3,1) = detinv*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
    B(4,1) = detinv*(A(2,1)*(A(3,3)*A(4,2)-A(3,2)*A(4,3))+A(2,2)*(A(3,1)*A(4,3)-A(3,3)*A(4,1))+A(2,3)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
    B(1,2) = detinv*(A(1,2)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(1,3)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(1,4)*(A(3,3)*A(4,2)-A(3,2)*A(4,3)))
    B(2,2) = detinv*(A(1,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(1,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(1,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))
    B(3,2) = detinv*(A(1,1)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(1,2)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(1,4)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
    B(4,2) = detinv*(A(1,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(1,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(1,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
    B(1,3) = detinv*(A(1,2)*(A(2,3)*A(4,4)-A(2,4)*A(4,3))+A(1,3)*(A(2,4)*A(4,2)-A(2,2)*A(4,4))+A(1,4)*(A(2,2)*A(4,3)-A(2,3)*A(4,2)))
    B(2,3) = detinv*(A(1,1)*(A(2,4)*A(4,3)-A(2,3)*A(4,4))+A(1,3)*(A(2,1)*A(4,4)-A(2,4)*A(4,1))+A(1,4)*(A(2,3)*A(4,1)-A(2,1)*A(4,3)))
    B(3,3) = detinv*(A(1,1)*(A(2,2)*A(4,4)-A(2,4)*A(4,2))+A(1,2)*(A(2,4)*A(4,1)-A(2,1)*A(4,4))+A(1,4)*(A(2,1)*A(4,2)-A(2,2)*A(4,1)))
    B(4,3) = detinv*(A(1,1)*(A(2,3)*A(4,2)-A(2,2)*A(4,3))+A(1,2)*(A(2,1)*A(4,3)-A(2,3)*A(4,1))+A(1,3)*(A(2,2)*A(4,1)-A(2,1)*A(4,2)))
    B(1,4) = detinv*(A(1,2)*(A(2,4)*A(3,3)-A(2,3)*A(3,4))+A(1,3)*(A(2,2)*A(3,4)-A(2,4)*A(3,2))+A(1,4)*(A(2,3)*A(3,2)-A(2,2)*A(3,3)))
    B(2,4) = detinv*(A(1,1)*(A(2,3)*A(3,4)-A(2,4)*A(3,3))+A(1,3)*(A(2,4)*A(3,1)-A(2,1)*A(3,4))+A(1,4)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)))
    B(3,4) = detinv*(A(1,1)*(A(2,4)*A(3,2)-A(2,2)*A(3,4))+A(1,2)*(A(2,1)*A(3,4)-A(2,4)*A(3,1))+A(1,4)*(A(2,2)*A(3,1)-A(2,1)*A(3,2)))
    B(4,4) = detinv*(A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)))
  end function invert
end Module vector_class


subroutine full_diag_ham(ndim, ham, eval, evec)
    use m_constants, only : dp, zero

    implicit none

    integer,     intent(in)  :: ndim
    complex(dp), intent(in)  :: ham(ndim, ndim)
    real(dp),    intent(out) :: eval(ndim)
    complex(dp), intent(out) :: evec(ndim,ndim)

    integer :: info
    integer :: lwork
    integer :: lrwork
    real(dp), allocatable    :: rwork(:)
    complex(dp), allocatable :: work(:)

    lwork = 2 * ndim - 1
    lrwork = 3 * ndim - 2

    allocate(work(lwork))
    allocate(rwork(lrwork))

    eval = zero
    evec = ham

    call ZHEEV('V', 'U', ndim, evec, ndim, eval, work, lwork, rwork, info)

    if ( allocated(work ) ) deallocate(work )
    if ( allocated(rwork) ) deallocate(rwork)

    return
end subroutine full_diag_ham


!*==zlartg.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022

!> \brief \b ZLARTG generates a plane rotation with real cosine and complex sine.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZLARTG + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZLARTG( F, G, CS, SN, R )
!
!       .. Scalar Arguments ..
!       DOUBLE PRECISION   CS
!       COMPLEX*16         F, G, R, SN
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZLARTG generates a plane rotation so that
!>
!>    [  CS  SN  ]     [ F ]     [ R ]
!>    [  __      ]  .  [   ]  =  [   ]   where CS**2 + |SN|**2 = 1.
!>    [ -SN  CS  ]     [ G ]     [ 0 ]
!>
!> This is a faster version of the BLAS1 routine ZROTG, except for
!> the following differences:
!>    F and G are unchanged on return.
!>    If G=0, then CS=1 and SN=0.
!>    If F=0, then CS=0 and SN is chosen so that R is real.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] F
!> \verbatim
!>          F is COMPLEX*16
!>          The first component of vector to be rotated.
!> \endverbatim
!>
!> \param[in] G
!> \verbatim
!>          G is COMPLEX*16
!>          The second component of vector to be rotated.
!> \endverbatim
!>
!> \param[out] CS
!> \verbatim
!>          CS is DOUBLE PRECISION
!>          The cosine of the rotation.
!> \endverbatim
!>
!> \param[out] SN
!> \verbatim
!>          SN is COMPLEX*16
!>          The sine of the rotation.
!> \endverbatim
!>
!> \param[out] R
!> \verbatim
!>          R is COMPLEX*16
!>          The nonzero component of the rotated vector.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16OTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel
!>
!>  This version has a few statements commented out for thread safety
!>  (machine parameters are computed on each entry). 10 feb 03, SJH.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE ZLARTG(F,G,Cs,Sn,R)
      IMPLICIT NONE
!*--ZLARTG108
!
!  -- 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 ..
      DOUBLE PRECISION Cs
      COMPLEX*16 F , G , R , Sn
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION TWO , ONE , ZERO
      PARAMETER (TWO=2.0D+0,ONE=1.0D+0,ZERO=0.0D+0)
      COMPLEX*16 CZERO
      PARAMETER (CZERO=(0.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
!     LOGICAL            FIRST
      INTEGER count , i
      DOUBLE PRECISION d , di , dr , eps , f2 , f2s , g2 , g2s ,        &
     &                 safmin , safmn2 , safmx2 , scale
      COMPLEX*16 ff , fs , gs
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH , DLAPY2
      LOGICAL DISNAN
      EXTERNAL DLAMCH , DLAPY2 , DISNAN
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , DCMPLX , DCONJG , DIMAG , INT , LOG , MAX ,&
     &          SQRT
!     ..
!     .. Statement Functions ..
      DOUBLE PRECISION ABS1 , ABSSQ
!     ..
!     .. Statement Function definitions ..
      ABS1(ff) = MAX(ABS(DBLE(ff)),ABS(DIMAG(ff)))
      ABSSQ(ff) = DBLE(ff)**2 + DIMAG(ff)**2
!     ..
!     .. Executable Statements ..
!
      safmin = DLAMCH('S')
      eps = DLAMCH('E')
      safmn2 = DLAMCH('B')**INT(LOG(safmin/eps)/LOG(DLAMCH('B'))/TWO)
      safmx2 = ONE/safmn2
      scale = MAX(ABS1(F),ABS1(G))
      fs = F
      gs = G
      count = 0
      IF ( scale>=safmx2 ) THEN
         DO
            count = count + 1
            fs = fs*safmn2
            gs = gs*safmn2
            scale = scale*safmn2
            IF ( scale<safmx2 .OR. count>=20 ) EXIT
         ENDDO
      ELSEIF ( scale<=safmn2 ) THEN
         IF ( G==CZERO .OR. DISNAN(ABS(G)) ) THEN
            Cs = ONE
            Sn = CZERO
            R = F
            RETURN
         ENDIF
         DO
            count = count - 1
            fs = fs*safmx2
            gs = gs*safmx2
            scale = scale*safmx2
            IF ( scale>safmn2 ) EXIT
         ENDDO
      ENDIF
      f2 = ABSSQ(fs)
      g2 = ABSSQ(gs)
      IF ( f2<=MAX(g2,ONE)*safmin ) THEN
!
!        This is a rare case: F is very small.
!
         IF ( F==CZERO ) THEN
            Cs = ZERO
            R = DLAPY2(DBLE(G),DIMAG(G))
!           Do complex/real division explicitly with two real divisions
            d = DLAPY2(DBLE(gs),DIMAG(gs))
            Sn = DCMPLX(DBLE(gs)/d,-DIMAG(gs)/d)
            RETURN
         ENDIF
         f2s = DLAPY2(DBLE(fs),DIMAG(fs))
!        G2 and G2S are accurate
!        G2 is at least SAFMIN, and G2S is at least SAFMN2
         g2s = SQRT(g2)
!        Error in CS from underflow in F2S is at most
!        UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS
!        If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN,
!        and so CS .lt. sqrt(SAFMIN)
!        If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN
!        and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS)
!        Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S
         Cs = f2s/g2s
!        Make sure abs(FF) = 1
!        Do complex/real division explicitly with 2 real divisions
         IF ( ABS1(F)>ONE ) THEN
            d = DLAPY2(DBLE(F),DIMAG(F))
            ff = DCMPLX(DBLE(F)/d,DIMAG(F)/d)
         ELSE
            dr = safmx2*DBLE(F)
            di = safmx2*DIMAG(F)
            d = DLAPY2(dr,di)
            ff = DCMPLX(dr/d,di/d)
         ENDIF
         Sn = ff*DCMPLX(DBLE(gs)/g2s,-DIMAG(gs)/g2s)
         R = Cs*F + Sn*G
      ELSE
!
!        This is the most common case.
!        Neither F2 nor F2/G2 are less than SAFMIN
!        F2S cannot overflow, and it is accurate
!
         f2s = SQRT(ONE+g2/f2)
!        Do the F2S(real)*FS(complex) multiply with two real multiplies
         R = DCMPLX(f2s*DBLE(fs),f2s*DIMAG(fs))
         Cs = ONE/f2s
         d = f2 + g2
!        Do complex/real division explicitly with two real divisions
         Sn = DCMPLX(DBLE(R)/d,DIMAG(R)/d)
         Sn = Sn*DCONJG(gs)
         IF ( count/=0 ) THEN
            IF ( count>0 ) THEN
               DO i = 1 , count
                  R = R*safmx2
               ENDDO
            ELSE
               DO i = 1 , -count
                  R = R*safmn2
               ENDDO
            ENDIF
         ENDIF
      ENDIF
!
!     End of ZLARTG
!
      END SUBROUTINE ZLARTG


      subroutine SSYMQL(A, LDA, N, EVAL, WORK, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 SSYMQL  Krogh  Changes to use M77CON
c>> 1992-04-24 SSYMQL  CLL  Minor edits.
c>> 1992-04-08 SSYMQL  Krogh Unused label 130 removed.
c>> 1991-10-23 SSYMQL  Krogh Initial version, converted from EISPACK.
c
c     This subroutine is a slight modification of the EISPACK subroutine
c     TRED2 (dated August 1983) which reduces a real matrix to a
c     symmetric tridiagonal matrix using and accumulating orthogonal
c     similarity transformations.  This subroutine then calls SIMQL to
c     compute the eigenvalues and eigenvectors of the matrix.
c     TRED2 was in turn a translation of the ALGOL procedure, TRED2,
c     Num. Math. 11, 181-195(1968) by Martin, Reinsch, and Wilkinson.
c
c     On input
c
c     LDA  must be set to the row dimension of the two-dimensional array
c          A as declared in the calling program dimension statement.
c
c     N    is the order of the matrix.
c
c     A    contains the real symmetric input matrix.  only the
c          lower triangle of the matrix need be supplied.
c
c     On output
c
c     A    contains the eigenvectors.
c
c     EVAL contains the eigenvalues in ascending order.  If an
c          error exit is made, the eigenvalues are correct but
c          unordered for indices 1,2,...,IERR-1.
c
c     WORK used for working storage.
c
c     IERR is set to:
c          zero  for normal return,
c          J     if the J-th eigenvalue has not been determined after 30
c                iterations.
c     ------------------------------------------------------------------
c--S replaces "?": ?SYMQL, ?IMQL
c     ------------------------------------------------------------------
      integer N, LDA, IERR
      integer I, J, K, L
      real             A(LDA,N), EVAL(N), WORK(N)
      real             F, G, H, HH, SCALE
c
c     ------------------------------------------------------------------
c
      do 100 I = 1, N
         EVAL(I) = A(N,I)
  100 continue
c
      if (N .le. 1) then
         if (N .eq. 1) then
            A(1,1) = 1.0E0
         else
            call IERM1('SSYMQL',-1, 0, 'Require N > 0.', 'N', N, '.')
            IERR = -1
         end if
         return
      end if
      do 300 I = N, 2, -1
         L = I - 1
         H = 0.0E0
         SCALE = 0.0E0
         if (L .ge. 2) then
c     .......... scale row (algol tol then not needed) ..........
            do 120 K = 1, L
               SCALE = SCALE + abs(EVAL(K))
  120       continue
            if (SCALE .ne. 0.0E0) go to 140
         end if
c
         WORK(I) = EVAL(L)
c
         do 135 J = 1, L
            EVAL(J) = A(L,J)
            A(I,J) = 0.0E0
            A(J,I) = 0.0E0
  135    continue
c
         go to 290
c
  140    do 150 K = 1, L
            EVAL(K) = EVAL(K) / SCALE
            H = H + EVAL(K) * EVAL(K)
  150    continue
c
         F = EVAL(L)
         G = -sign(sqrt(H),F)
         WORK(I) = SCALE * G
         H = H - F * G
         EVAL(L) = F - G
c     .......... form A*u ..........
         do 170 J = 1, L
            WORK(J) = 0.0E0
  170    continue
c
         do 240 J = 1, L
            F = EVAL(J)
            A(J,I) = F
            G = WORK(J) + A(J,J) * F
c
            do 200 K = J+1, L
               G = G + A(K,J) * EVAL(K)
               WORK(K) = WORK(K) + A(K,J) * F
  200       continue
c
            WORK(J) = G
  240    continue
c     .......... form P ..........
         F = 0.0E0
c
         do 245 J = 1, L
            WORK(J) = WORK(J) / H
            F = F + WORK(J) * EVAL(J)
  245    continue
c
         HH = F / (H + H)
c     .......... form q ..........
         do 250 J = 1, L
            WORK(J) = WORK(J) - HH * EVAL(J)
  250    continue
c     .......... form reduced A ..........
         do 280 J = 1, L
            F = EVAL(J)
            G = WORK(J)
c
            do 260 K = J, L
               A(K,J) = A(K,J) - F * WORK(K) - G * EVAL(K)
  260       continue
c
            EVAL(J) = A(L,J)
            A(I,J) = 0.0E0
  280    continue
c
  290    EVAL(I) = H
  300 continue
c     .......... accumulation of transformation matrices ..........
      do 500 I = 2, N
         L = I - 1
         A(N,L) = A(L,L)
         A(L,L) = 1.0E0
         H = EVAL(I)
         if (H .ne. 0.0E0) then
c
            do 330 K = 1, L
               EVAL(K) = A(K,I) / H
  330       continue
c
            do 360 J = 1, L
               G = 0.0E0
c
               do 340 K = 1, L
                  G = G + A(K,I) * A(K,J)
  340          continue
c
               do 350 K = 1, L
                  A(K,J) = A(K,J) - G * EVAL(K)
  350          continue
  360       continue
         end if
c
         do 400 K = 1, L
            A(K,I) = 0.0E0
  400    continue
c
  500 continue
c
      do 520 I = 1, N
         EVAL(I) = A(N,I)
         A(N,I) = 0.0E0
  520 continue
c
      A(N,N) = 1.0E0
      call SIMQL(A, LDA, N, EVAL, WORK, IERR)
      return
      end


      subroutine tpindex(pw,tw,qh2o,pref,tref,wrefh2o,LCOEF,MT,MP,
     *                   NH2O,wratio)

C  GCM2.0  Feb 2003
C
C
C  PURPOSE
C    Get the TI, UI values for a 2-dimensional interpolation
C    based on the following (The interpolation is done in interpco2):
C    Interpolate the CO2 K-coefficients to the current P,T values.
C    The CO2 coefficients are given on a P,T grid:
C    P = {1E-6, 1E-5, 1E-4, 1E-3, 1E-2, 1E-1, 1, 1E+1, 1E+2, 1E+3, 1E+4},
C    T = {50, 100, 150, 200, 250, 300, 350}.
C
C    The interpolation is the usual interpolation in 2-dimensions given
C    in "Numerical Recipes", where the "X" are P, the "Y" are
C    T, and the F(X,Y) are the CO2 K-coefficients.
C
C     The interpolating box is designated as follows:
C
C           (PL,TU)                        (PRR,TU)
C
C                          (TW,PW)
C
C
C           (PL,TL)                        (PRR,TL)
C
C     PL  - Pressure left
C     PRR - Pressure right
C     TL  - Temperature lower
C     TU  - Temperature upper
C     PW  - Pressure wanted
C     TW  - Temperature wanted
C
C
C  AUTHOR
C      JIM SCHAEFFER     STERLING SOFTWARE  TASK 404  MAR 1998
C
C  FOR
C      BOB HABERLE       PART OF GCM II/RADTRAN UPDATES
C
C  ENVIRONMENT
C      SUN ULTRA-2       SOLARIS 2.5.1   FORTRAN 77
C
C  REVISION HISTORY
C     3-98  JRS  ORIGINAL
C
C  INPUT PARAMETERS
C    PW                 - The pressure to interpolate to
C    TW                 - The temperature to interpolate to
C    Pref(NP)           - The pressure grid array.
C    Tref(NT)           - The temperature grid array.
C
C  OUTPUT PARAMETERS
C    TI                 - Interpolation term (pressure)
C    UI                 - Interpolation term (temperature)
C    MT                 - Temperature index (bottom left Temperature)
C                         of bounding box
C    MP                 - Pressure index (bottom left pressure)
C                         of bounding box
C
C  CALLED BY
C    SETRAD
C
C  SUBROUTINES CALLED
C      NONE
C
C----------------------------------------------------------------------C

      implicit none

      include "grid.h"
      include 'radinc.h'

      real*8 Tref(L_NTREF)
      real*8 pref(L_PINT)
      real*8 wrefh2o(L_REFH2O)

      integer MT, MP, N, M, NP, NH2O
      real*8  PW, TW, Qh2o, wratio
      real*8  PWL, LCOEF(4), T, U

C======================================================================C

C     Get the upper and lower Temperature-grid indicies that bound the
C     requested temperature.  If the requested temperature is outside
C     the T-grid, set up to extrapolate from the appropriate end.

      IF(TW.LE.TREF(1)) THEN
        MT = 1
        U  = 0.0D0
      ELSE
        do n=1,L_NTREF-1
          if(tw.gt.Tref(n) .and. TW.LE.TREF(N+1)) then
            MT = n
            U = (TW-TREF(MT))/(TREF(MT+1)-TREF(MT))
            goto 10
          end if
        end do

        MT = L_NTREF-1
        U  = 1.0D0

   10   continue
      END IF

C     Get the upper and lower Pressure-grid indicies that bound the
C     requested pressure.  If the requested pressure is outside
C     the P-grid, set up to extrapolate from the appropiate end.

      pwl = log10(pw)

      if(pwl.le.Pref(1)) then
        MP = 1
        T  = 0.0D0
      else
        do n=2,L_PINT-1
          if(pwl.le.Pref(n)) then
            MP = n-1
            T = (PWL-PREF(MP))/(PREF(MP+1)-PREF(MP))
            goto 20
          end if
        end do

        MP = L_PINT-1
        T  = 1.0D0

   20   continue
      end if

C  Fill the interpolation coeficients:

      LCOEF(1) = (1.0-T)*(1.0-U)
      LCOEF(2) = T*(1.0-U)
      LCOEF(3) = T*U
      LCOEF(4) = (1.0-T)*U

C  Get the indicies for water abundance.  There are 10 sets of
C  k-coefficients with differing amounts of water vs. CO2.

      IF(Qh2o.le.WREFH2O(1)) then
        NH2O   = 1
        WRATIO = 0.0D0
      ELSEIF(Qh2o.ge.WREFH2O(L_REFH2O)) then
        NH2O   = L_REFH2O - 1
        WRATIO = 1.0D0
      ELSE
        DO N=2,L_REFH2O
          IF(QH2O.GE.WREFH2O(N-1) .and. QH2O.lt.WREFH2O(N)) then
            NH2O   = N-1
            WRATIO = (QH2O - WREFH2O(N-1))/(WREFH2O(N) - WREFH2O(N-1))
            GOTO 30
          END IF
        END DO
      END IF

   30 CONTINUE

      return
      end


*     AB05RD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, MVMAX, PMAX, PZMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, MVMAX = 20,
     $                   PMAX = 20, PZMAX = 20 )
      INTEGER          LDA, LDB, LDBC, LDC, LDCC, LDD, LDDC, LDF, LDG,
     $                 LDH, LDK, LDWORK, LIWORK
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDBC = NMAX,
     $                   LDC = PMAX, LDCC = PZMAX,
     $                   LDD = PMAX, LDDC = PZMAX, LDF = MMAX,
     $                   LDG = MMAX, LDH  = PZMAX, LDK = MMAX,
     $                   LDWORK = MAX( MMAX, PMAX*MVMAX,
     $                   PMAX*PMAX + 4*PMAX ), LIWORK = 2*PMAX )
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
*     .. Local Scalars ..
      LOGICAL          LJOBD, OUTPF
      CHARACTER*1      FBTYPE, JOBD
      INTEGER          I, INFO, J, M, MV, N, P, PZ
      DOUBLE PRECISION ALPHA, BETA, RCOND
*     .. Local Arrays ..
      INTEGER          IWORK(LIWORK)
      DOUBLE PRECISION A(LDA,NMAX), B(LDB,MMAX), BC(LDBC,MVMAX),
     $                 C(LDC,NMAX), CC(LDCC,NMAX),
     $                 D(LDD,MMAX), DC(LDDC,MVMAX),  DWORK(LDWORK),
     $                 F(LDF,PMAX), G(LDG,MVMAX), H(LDH,PMAX),
     $                 K(LDK,NMAX)
*     .. External functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         AB05RD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, MV, PZ, ALPHA, BETA, FBTYPE, JOBD
      OUTPF = LSAME( FBTYPE, 'O' )
      LJOBD = LSAME( JOBD, 'D' )
      IF ( N.LE.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
         IF ( M.LE.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), I = 1,N ), J = 1,M )
            IF ( BETA.NE.ZERO )
     $         READ ( NIN, FMT = * ) ( ( K(I,J), J = 1,N ), I = 1,M )
            IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N ), I = 1,P )
               IF ( LJOBD )
     $            READ ( NIN, FMT = * ) ( ( D(I,J), J = 1,M ), I = 1,P )
               IF ( OUTPF.AND.ALPHA.NE.ZERO )
     $            READ ( NIN, FMT = * ) ( ( F(I,J), J = 1,P ), I = 1,M )
               IF ( MV.LE.0 .OR. MV.GT.MVMAX ) THEN
                  WRITE ( NOUT, FMT = 99989 ) MV
               ELSE
                  READ ( NIN, FMT = * )
     $                 ( ( G(I,J), J = 1,MV ), I = 1,M )
                  IF ( PZ.LE.0 .OR. PZ.GT.PZMAX ) THEN
                     WRITE ( NOUT, FMT = 99988 ) PZ
                  ELSE
                     READ ( NIN, FMT = * )
     $                    ( ( H(I,J), J = 1,P ), I = 1,PZ )
*                       Find the state-space model (A,B,C,D).
                     CALL AB05RD( FBTYPE, JOBD, N, M, P, MV, PZ, ALPHA,
     $                            BETA, A, LDA, B, LDB, C, LDC, D, LDD,
     $                            F, LDF, K, LDK, G, LDG, H, LDH, RCOND,
     $                            BC, LDBC, CC, LDCC, DC, LDDC, IWORK,
     $                            DWORK, LDWORK, INFO )
*
                     WRITE ( NOUT, FMT = 99987 ) RCOND
                     IF ( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99998 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99997 )
                        DO 20 I = 1, N
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( A(I,J), J = 1,N )
   20                   CONTINUE
                        WRITE ( NOUT, FMT = 99995 )
                        DO 40 I = 1, N
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( BC(I,J), J = 1,MV )
   40                   CONTINUE
                        WRITE ( NOUT, FMT = 99994 )
                        DO 60 I = 1, PZ
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( CC(I,J), J = 1,N )
   60                   CONTINUE
                        IF ( LJOBD ) THEN
                           WRITE ( NOUT, FMT = 99993 )
                           DO 80 I = 1, PZ
                              WRITE ( NOUT, FMT = 99996 )
     $                              ( DC(I,J), J = 1,MV )
   80                      CONTINUE
                        END IF
                     END IF
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB05RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB05RD = ',I2)
99997 FORMAT (' The state transition matrix of the closed-loop system is
     $')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix of the closed-loop system is ')
99994 FORMAT (/' The state/output matrix of the closed-loop system is ')
99993 FORMAT (/' The input/output matrix of the closed-loop system is ')
99992 FORMAT (/' N is out of range.',/' N = ',I5)
99991 FORMAT (/' M is out of range.',/' M = ',I5)
99990 FORMAT (/' P is out of range.',/' P = ',I5)
99989 FORMAT (/' MV is out of range.',/' MV = ',I5)
99988 FORMAT (/' PZ is out of range.',/' PZ = ',I5)
99987 FORMAT ( ' The reciprocal condition number of the matrix ',
     $         ' I - alpha*D*F is',F8.4,/1X)
      END


*----------------------------------------------------------------------*
      subroutine svd_drv(ndim,mat,singval)
*----------------------------------------------------------------------*
*     split matrix into non-coupling blocks and perform the svd
*     on these individual blocks
*     matrix should be symmetric
*
*     matthias, dec 2010
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'
      include 'routes.h'
      include 'def_filinf.h'
      include 'ifc_memman.h'

      integer, parameter ::
     &     ntest = 00
      real(8), parameter ::
     &     coupl_thresh = 1d-14 ! threshold for coupling elements
      integer, intent(in) ::
     &     ndim
      real(8), intent(out) ::
     &     singval(ndim)
      real(8), intent(inout) ::
     &     mat(ndim,ndim)
      real(8) ::
     &     dum1,dum2,umat(ndim,ndim)
      real(8), pointer ::
     &     mat_tmp(:,:),mat_tmpv(:), !mat_tmpv is only a handler for the mat_tmp memory as memman can only allocate one dimensional vectors
     &     sing_tmp(:), wrk(:)
      integer ::
     &     cur_els(ndim), nels, iels, iidim
      logical ::
     &     decomposed(ndim)

      integer ::
     &     nrot, idx, lwrk, info, idx2, luinp, iostatus,
     &     ifree
      integer, external ::
     &     idxlist

      umat = 0d0
      singval = 0d0
      decomposed = .false.

      do iidim = 1, ndim
        ifree = mem_setmark('svd_drv')
        if (decomposed(iidim)) cycle

        ! find all coupling elements
        nels = 1
        cur_els(1) = iidim
        iels = 1
        ! find all elements which couple with elements on list
        do while(iels.le.nels)
          do idx2 = 1, ndim
            ! skip if already on list
            if (idxlist(idx2,cur_els,nels,1).gt.0) cycle
            if (abs(mat(cur_els(iels),idx2)).gt.coupl_thresh) then
              nels = nels + 1
              cur_els(nels) = idx2
            end if
          end do
          decomposed(cur_els(iels)) = .true.
          iels = iels + 1
        end do
        ! zero element? do nothing
        if (nels.eq.1.and.mat(cur_els(1),cur_els(1)).lt.coupl_thresh)
     &       cycle
c dbg
c        print *,'cur_els: ',cur_els(1:nels)
c dbgend

! assemble block

        ifree = mem_alloc_real(mat_tmpv, nels*nels,'mat_tmp')
        ifree = mem_alloc_real(sing_tmp, nels,'sing_tmp')
        mat_tmp(1:nels,1:nels) => mat_tmpv
        do idx = 1, nels
          do idx2 = 1, nels
            mat_tmp(idx,idx2) = mat(cur_els(idx),cur_els(idx2))
          end do
        end do

        ! call singular value decomposer
        lwrk=max(1024,nels**2)
        ifree = mem_alloc_real(wrk, lwrk,'wrk')
        info = 0
        call dgesvd('O','N',nels,nels,
     &       mat_tmp,nels,sing_tmp,
     &       dum1,1,dum2,1,
     &       wrk,lwrk,info)
        if (info.ne.0) then
          write(lulog,*) 'WARNING in svd_drv: SVD in trouble'
        end if

        ! copy singular values and eigenvector
        do idx = 1, nels
          singval(cur_els(idx)) = sing_tmp(idx)
          do idx2 = 1, nels
            umat(cur_els(idx),cur_els(idx2)) = mat_tmp(idx,idx2)
          end do
        end do

        ifree = mem_flushmark()
      end do

      mat = umat

      return
      end


!##############################################################################
!# ****************************************************************************
!# <name> dom3d_c3d0 </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains some auxiliary routines for the 3D domain which is
!# used in the "flow around a cylinder" benchmark.
!#
!# The domain can be described as the [0, 2.5]x[0, 0.41]x[0, 0.41] hexahedron
!# without a cylinder of radius 0.05 around the axis (0,0,1) through the point
!# (0.5, 0.2, 0).
!#
!# To be (mathematically) more precise:
!#
!#   A := { (x,y,z) \in R^3 | 0 <= x <= 2.5 , 0 <= y, z <= 0.41 }
!#   B := { (x,y,z) \in R^3 | 0 <= SQRT((x-0.5)^2 + (y-0.2)^2) < 0.05 }
!#
!# Then the domain is A \ B.
!#
!# The domain is described by seven boundary regions:
!# 1. The bottom face, i.e. all cells whose Z-coordinate is 0.
!# 2. The front face,  i.e. all cells whose Y-coordinate is 0.
!# 3. The right face,  i.e. all cells whose X-coordinate is 2.5.
!# 4. The back face,   i.e. all cells whose Y-coordinate is 0.41.
!# 5. The left face,   i.e. all cells whose X-coordinate is 0.
!# 6. The top face,    i.e. all cells whose Z-coordinate is 0.41.
!# 7. The cylinder,    i.e. all cells whose X- and Y-coordinates fulfill
!#                     SQRT((x-0.5)^2 + (y-0.2)^2) = 0.05.
!#
!# Note:
!# This module may be modified to work with another "flow around a cylinder"
!# domain by simply modifying the parameters in the "Domain parametrisation"
!# constantblock below, as long as the axis of the cylinder is (0,0,1).
!#
!# The following routines can be found here:
!#
!#  1.) dom3d_c3d0_calcMeshRegion
!#      -> Creates a mesh region describing a set of specific domain faces.
!#
!#  2.) dom3d_c3d0_HitTest
!#      -> A hit-test routine that is used by dom3d_c3d0_calcMeshRegion,
!#         to identify which cells of the triangulation belong to which
!#         domain face.
!#
!#  3.) dom3d_c3d0_correctMesh
!#      -> A routine which corrects a mesh after it was refined, i.e.
!#         which 'projects' all vertices, which belong to the cylinder onto
!#         the cylinder.
!#
!#  3.) dom3d_c3d0_calcParProfile
!#      -> Calculates the parabolic profile for a given domain region.
!#
!# </purpose>
!##############################################################################

module dom3d_c3d0

  use fsystem
  use storage
  use triangulation
  use meshregion

  implicit none

!<constants>

!<constantblock description="Domain parametrisation">

  ! X-Coordinate ranges
  real(DP), parameter :: DOM3D_C3D0_X_MIN  = 0.0_DP
  real(DP), parameter :: DOM3D_C3D0_X_MAX  = 2.5_DP

  ! Y-Coordinate ranges
  real(DP), parameter :: DOM3D_C3D0_Y_MIN  = 0.0_DP
  real(DP), parameter :: DOM3D_C3D0_Y_MAX  = 0.41_DP

  ! Z-Coordinate ranges
  real(DP), parameter :: DOM3D_C3D0_Z_MIN  = 0.0_DP
  real(DP), parameter :: DOM3D_C3D0_Z_MAX  = 0.41_DP

  ! Cylinder midpoint coordinates
  real(DP), parameter :: DOM3D_C3D0_X_MID  = 0.5_DP
  real(DP), parameter :: DOM3D_C3D0_Y_MID  = 0.2_DP

  ! Cylinder radius
  real(DP), parameter :: DOM3D_C3D0_RADIUS = 0.05_DP

!</constantblock>

!<constantblock description="Region identifiers">

  ! Identification flag for the bottom face:
  integer(I32), parameter :: DOM3D_C3D0_REG_BOTTOM   = 2**0

  ! Identification flag for the front face:
  integer(I32), parameter :: DOM3D_C3D0_REG_FRONT    = 2**1

  ! Identification flag for the right face:
  integer(I32), parameter :: DOM3D_C3D0_REG_RIGHT    = 2**2

  ! Identification flag for the back face:
  integer(I32), parameter :: DOM3D_C3D0_REG_BACK     = 2**3

  ! Identification flag for the left face:
  integer(I32), parameter :: DOM3D_C3D0_REG_LEFT     = 2**4

  ! Identification flag for the top face:
  integer(I32), parameter :: DOM3D_C3D0_REG_TOP      = 2**5

  ! Identification flag for the cylinder:
  integer(I32), parameter :: DOM3D_C3D0_REG_CYLINDER = 2**6

  ! Frequently used: All regions except for the right face.
  ! This combination is often used in (Navier-)Stokes examples where
  ! every region (including the cylinder) is Dirichlet, except for the
  ! right face, which is left Neumann.
  integer(I32), parameter :: DOM3D_C3D0_REG_STOKES = DOM3D_C3D0_REG_BOTTOM &
                     + DOM3D_C3D0_REG_FRONT + DOM3D_C3D0_REG_BACK &
                     + DOM3D_C3D0_REG_LEFT + DOM3D_C3D0_REG_TOP &
                     + DOM3D_C3D0_REG_CYLINDER

!</constantblock>

!</constants>

interface dom3d_c3d0_calcMeshRegion
  module procedure dom3d_c3d0_calcMeshRegion_C
  module procedure dom3d_c3d0_calcMeshRegion_I
end interface

contains

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

!<subroutine>

  subroutine dom3d_c3d0_calcMeshRegion_C(rmeshRegion,rtriangulation,cregions)

!<description>
  ! This routine calculates a mesh region containing all vertices, edges and
  ! faces that belong to a specific set of domain regions.
!</description>

!<input>
  ! The triangulation on which the mesh region is to be defined.
  ! This trinagulation must represent the "flow around a cylinder" domain.
  type(t_triangulation), target, intent(in)      :: rtriangulation

  ! A combination of DOM3D_C3D0_REG_XXXX contants defined above specifying
  ! which regions should be in the mesh region.
  integer(I32), intent(in)                       :: cregions
!<input>

!<output>
  ! The mesh region that is to be created.
  type(t_meshRegion), intent(out)                :: rmeshRegion
!<output>

!<subroutine>

  ! Some local variables
  integer :: i
  integer, dimension(7) :: Iregions

    ! First of all, set up the Iregions array:
    do i = 1, 7

      ! If the corresponding bit is set, we'll add the region, otherwise
      ! we will set the corresponding Iregions entry to -1.
      if(iand(cregions, int(2**(i-1),I32)) .ne. 0) then
        ! Add the region
        Iregions(i) = i
      else
        ! Ignore the region
        Iregions(i) = -1
      end if

    end do

    ! Create a mesh-region holding all the regions, based on the hit-test
    ! routine below.
    call mshreg_createFromHitTest(rmeshRegion, rtriangulation, &
         MSHREG_IDX_FACE, .true., dom3d_c3d0_HitTest, Iregions)

    ! Now calculate the vertice and edge index arrays in the mesh region
    ! based on the face index array.
    call mshreg_recalcVerticesFromFaces(rmeshRegion)
    call mshreg_recalcEdgesFromFaces(rmeshRegion)

    ! That's it

  end subroutine

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

!<subroutine>

  subroutine dom3d_c3d0_calcMeshRegion_I(rmeshRegion,rtriangulation,Iregions)

!<description>
  ! This routine calculates a mesh region containing all vertices, edges and
  ! faces that belong to a specific set of domain regions.
!</description>

!<input>
  ! The triangulation on which the mesh region is to be defined.
  ! This trinagulation must represent the "flow around a cylinder" domain.
  type(t_triangulation), target, intent(in)      :: rtriangulation

  ! An array holding the indices of the domain regions which should be in
  ! the mesh region.
  integer, dimension(:), intent(in)              :: Iregions
!<input>

!<output>
  ! The mesh region that is to be created.
  type(t_meshRegion), intent(out)                :: rmeshRegion
!<output>

!<subroutine>

    ! Create a mesh-region holding all the regions, based on the hit-test
    ! routine below.
    call mshreg_createFromHitTest(rmeshRegion, rtriangulation, &
         MSHREG_IDX_FACE, .true., dom3d_c3d0_HitTest, Iregions)

    ! Now calculate the vertice and edge index arrays in the mesh region
    ! based on the face index array.
    call mshreg_recalcVerticesFromFaces(rmeshRegion)
    call mshreg_recalcEdgesFromFaces(rmeshRegion)

    ! That's it

  end subroutine

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

!<subroutine>

  subroutine dom3d_c3d0_HitTest(inumCells,Dcoords,Ihit,rcollection)

  use collection

!<description>
  ! This subroutine is called for hit-testing cells to decide whether a
  ! cell belongs to a specific mesh region or not.
  ! This routine corresponds to the interface defined in
  ! "intf_mshreghittest.inc".
!</description>

!<input>
  ! Number of cells (i.e. vertices,edges,faces,etc.) for which the
  ! hit-test is to be performed.
  integer, intent(in)                          :: inumCells

  ! Coordinates of the points for which the hit-test is to be performed.
  ! The dimension of the array is at least (1:idim,1:inumCells), where:
  ! -> idim is the dimension of the mesh, i.e. 1 for 1D, 2 for 2D, etc.
  ! -> inumCells is the parameter passed to this routine.
  real(DP), dimension(:,:), intent(in)         :: Dcoords
!</input>

!<output>
  ! An array that recieves the result of the hit-test.
  ! The dimension of the array is at least (1:inumCells).
  integer, dimension(:), intent(out)           :: Ihit
!</output>

!</inputoutput>
  ! OPTIONAL: A collection structure to provide additional information
  ! to the hit-test routine.
  type(t_collection), intent(inout), optional  :: rcollection
!</inputoutput>

!</subroutine>

  ! Some local variables
  integer :: i
  real(DP) :: dl

  real(DP), parameter :: tol = 0.0001_DP

    ! Loop through all cells
    do i = 1, inumCells

      ! Bottom face?
      if      ((Dcoords(3,i) - DOM3D_C3D0_Z_MIN) .lt. tol) then
        Ihit(i) = 1

      ! Front face?
      else if ((Dcoords(2,i) - DOM3D_C3D0_Y_MIN) .lt. tol) then
        Ihit(i) = 2

      ! Right face?
      else if ((Dcoords(1,i) - DOM3D_C3D0_X_MAX) .gt. -tol) then
        Ihit(i) = 3

      ! Back face?
      else if ((Dcoords(2,i) - DOM3D_C3D0_Y_MAX) .gt. -tol) then
        Ihit(i) = 4

      ! Left face?
      else if ((Dcoords(1,i) - DOM3D_C3D0_X_MIN) .lt. tol) then
        Ihit(i) = 5

      ! Top face?
      else if ((Dcoords(3,i) - DOM3D_C3D0_Z_MAX) .gt. -tol) then
        Ihit(i) = 6

      else

        ! Calculate distance to cylinder axis
        dl = sqrt((Dcoords(1,i) - DOM3D_C3D0_X_MID)**2 &
                + (Dcoords(2,i) - DOM3D_C3D0_Y_MID)**2)

        ! Cylinder?
        if ((dl - DOM3D_C3D0_RADIUS) .lt. tol) then
          Ihit(i) = 7
        else
          Ihit(i) = 0
        end if

      end if

    end do

  end subroutine

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

!<subroutine>

  subroutine dom3d_c3d0_correctMesh(rtriangulation)

  use collection

!<description>
  ! This routine is called to correct a mesh after it has been refined, i.e.
  ! it 'projects' all vertices which belong to the cylinder onto the cylinder.
!</description>

!</inputoutput>
  ! The mesh that is to be corrected
  type(t_triangulation), intent(inout) :: rtriangulation
!</inputoutput>

!</subroutine>

  ! Some local variables
  integer, dimension(:), pointer :: p_IverticesAtBoundary
  real(DP), dimension(:,:), pointer :: p_Dcoords
  integer :: i, ivt
  real(DP) :: dx,dy,dl,dr

  real(DP), parameter :: tol = 0.0001_DP

    ! First of all, get the vertices-at-boundary array from the triangulation,
    ! so we don't check all vertices, but only those on the boundary.
    call storage_getbase_int(rtriangulation%h_IverticesAtBoundary, &
                             p_IverticesAtBoundary)

    ! And get the vertice coordinates
    call storage_getbase_double2D(rtriangulation%h_DvertexCoords, p_Dcoords)

    ! Now loop through all vertices on the boundary
    do i = 1, rtriangulation%NVBD

      ! Get the index of the vertice
      ivt = p_IverticesAtBoundary(i)

      ! Get the X- and Y-coordinates of the distance vector from the
      ! vertice and the cylinder axis
      dx = p_Dcoords(1,ivt) - DOM3D_C3D0_X_MID
      dy = p_Dcoords(2,ivt) - DOM3D_C3D0_Y_MID

      ! Calculate distance from the cylinder-axis
      dl = sqrt(dx**2 + dy**2)

      ! Is the vertice inside our cylinder?
      if ((dl .gt.  tol) .and. ((dl - DOM3D_C3D0_RADIUS) .lt. tol)) then

        ! Calculate the scaling factor for the correction
        dr = DOM3D_C3D0_RADIUS / dl

        ! Correct the X- and Y-coordinates of the vertice
        p_Dcoords(1,ivt) = DOM3D_C3D0_X_MID + dr * dx
        p_Dcoords(2,ivt) = DOM3D_C3D0_Y_MID + dr * dy

      end if

    end do

  end subroutine

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

!<subroutine>

  subroutine dom3d_c3d0_calcParProfile (dvalue, iregion, dx, dy, dz)

!<description>
  ! This routine calculates the parabolic profile for a speicified domain
  ! boundary region.
!</description>

!<input>
  ! Specifies the index of the boundary region of which the parabolic profile
  ! is to be calculated.
  integer, intent(in)                            :: iregion

  ! The coordinates of the point in which the parabolic profile is to be
  ! evaluated.
  real(DP), intent(in)                           :: dx, dy, dz
!</input>

!<output>
  ! The result of the evaluation of the parabolic profile.
  real(DP), intent(out)                          :: dvalue
!</output>

!</subroutine>

  ! Relative X-, Y- and Z-coordinates
  real(DP) :: x,y,z

    ! Convert coordinates to be in range [0,1]
    x = (dx - DOM3D_C3D0_X_MIN) / (DOM3D_C3D0_X_MAX - DOM3D_C3D0_X_MIN)
    y = (dy - DOM3D_C3D0_Y_MIN) / (DOM3D_C3D0_Y_MAX - DOM3D_C3D0_Y_MIN)
    z = (dz - DOM3D_C3D0_Z_MIN) / (DOM3D_C3D0_Z_MAX - DOM3D_C3D0_Z_MIN)

    select case(iregion)
    case (1,6)
      ! X-Y-Profile
      dvalue = 16.0_DP*x*(1.0_DP-x)*y*(1.0_DP-y)

    case (2,4)
      ! X-Z-Profile
      dvalue = 16.0_DP*x*(1.0_DP-x)*z*(1.0_DP-z)

    case (3,5)
      ! Y-Z-Profile
      dvalue = 16.0_DP*y*(1.0_DP-y)*z*(1.0_DP-z)

    case (7)
      ! Z-Profile on the boundary of the cylinder
      dvalue = 2.0_DP*z*(1.0_DP-z)

    case DEFAULT
      ! Invalid region
      print *, 'ERROR: dom3d_c3d0_calcParProfile: Invalid region'
      call sys_halt()
    end select

  end subroutine

end module