module autodiff
  implicit none
  private
  public :: dual_number,init_dual, &
            operator(+),operator(-),operator(*),operator(/), &
            exp,log

  type dual_number
     real :: val ! value
     real :: eps ! differential
  end type dual_number

  interface operator(+)
     module procedure plus_dual_dual
     module procedure plus_dual_real
     module procedure plus_real_dual
  end interface operator(+)

  interface operator(-)
     module procedure minus_dual_dual
     module procedure minus_dual
     module procedure minus_dual_real
     module procedure minus_real_dual
  end interface operator(-)

  interface operator(*)
     module procedure times_dual_dual
     module procedure times_dual_real
     module procedure times_real_dual
  end interface operator(*)

  interface operator(/)
     module procedure division_dual_dual
     module procedure division_dual_real
     module procedure division_real_dual
  end interface operator(/)

  interface exp
     module procedure exp_dual
  end interface exp
  interface log
     module procedure log_dual
  end interface log

contains

  function init_dual(x) result(r)
    real :: x
    type(dual_number) :: r
    r%val = x ; r%eps = 1.0
  end function init_dual

  function plus_dual_dual(a,b) result(r)
    type(dual_number), intent(in) :: a,b
    type(dual_number) :: r
    r%val = a%val + b%val ; r%eps = a%eps + b%eps
  end function plus_dual_dual

  function plus_dual_real(a,x) result(r)
    type(dual_number), intent(in) :: a
    real, intent(in) :: x
    type(dual_number) :: r
    r%val = a%val + x ; r%eps = a%eps
  end function plus_dual_real

  function plus_real_dual(x,a) result(r)
    type(dual_number), intent(in) :: a
    real, intent(in) :: x
    type(dual_number) :: r
    r%val = a%val + x ; r%eps = a%eps
  end function plus_real_dual

  function minus_dual_dual(a,b) result(r)
    type(dual_number), intent(in) :: a,b
    type(dual_number) :: r
    r%val = a%val - b%val ; r%eps = a%eps - b%eps
  end function minus_dual_dual

  function minus_dual(a) result(r)
    type(dual_number), intent(in) :: a
    type(dual_number) :: r
    r%val = -a%val ; r%eps = -a%eps
  end function minus_dual

  function minus_dual_real(a,x) result(r)
    type(dual_number), intent(in) :: a
    real, intent(in) :: x
    type(dual_number) :: r
    r%val = a%val - x ; r%eps = a%eps
  end function minus_dual_real

  function minus_real_dual(x,a) result(r)
    type(dual_number), intent(in) :: a
    real, intent(in) :: x
    type(dual_number) :: r
    r%val = x - a%val ; r%eps = -a%eps
  end function minus_real_dual

  function times_dual_dual(a,b) result(r)
    type(dual_number), intent(in) :: a,b
    type(dual_number) :: r
    r%val = a%val * b%val ; r%eps = a%eps * b%val + a%val * b%eps
  end function times_dual_dual

  function times_dual_real(a,x) result(r)
    type(dual_number), intent(in) :: a
    real, intent(in) :: x
    type(dual_number) :: r
    r%val = a%val * x ; r%eps = a%eps * x
  end function times_dual_real

  function times_real_dual(x,a) result(r)
    type(dual_number), intent(in) :: a
    real, intent(in) :: x
    type(dual_number) :: r
    r%val = a%val * x ; r%eps = a%eps * x
  end function times_real_dual

  function division_dual_dual(a,b) result(r)
    type(dual_number), intent(in) :: a,b
    type(dual_number) :: r
    r%val = a%val / b%val ; r%eps = (a%eps * b%val - a%val * b%eps) / b%val**2
  end function division_dual_dual

  function division_dual_real(a,x) result(r)
    type(dual_number), intent(in) :: a
    real, intent(in) :: x
    type(dual_number) :: r
    r%val = a%val / x ; r%eps = a%eps / x
  end function division_dual_real

  function division_real_dual(x,a) result(r)
    type(dual_number), intent(in) :: a
    real, intent(in) :: x
    type(dual_number) :: r
    r%val = 1.0 / a%val ; r%eps = -x * a%eps / a%val**2
  end function division_real_dual

  function exp_dual(a) result(r)
    type(dual_number), intent(in) :: a
    type(dual_number) :: r
    r%val = exp(a%val) ; r%eps = a%eps * exp(a%val)
  end function exp_dual

  function log_dual(a) result(r)
    type(dual_number), intent(in) :: a
    type(dual_number) :: r
    r%val = log(a%val) ; r%eps = a%eps / a%val
  end function log_dual

end module autodiff


PROGRAM F041

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

    IMPLICIT NONE

    CHARACTER (LEN=9), PARAMETER  :: DIGIT = "123456789"

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

    CHARACTER (LEN=10) :: PRIME_NUM_STR

    INTEGER :: LARGEST_PANDIGITAL_PRIME = 0

    INTEGER :: I, STR_LEN

    LOGICAL :: IS_PANDIGITAL

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

    DO
        READ(2, *, END=10) PRIME_NUM

        IF (PRIME_NUM > 7654321) EXIT

        STR_LEN = INT(LOG10(REAL(PRIME_NUM)))

        IS_PANDIGITAL = .TRUE.

        WRITE(PRIME_NUM_STR, '(I10)') PRIME_NUM
        PRIME_NUM_STR = ADJUSTL(PRIME_NUM_STR)

        DO I = 1, STR_LEN

            IF (INDEX(PRIME_NUM_STR, DIGIT(I:I)) == 0) THEN
                IS_PANDIGITAL = .FALSE.
                EXIT
            END IF
        END DO

        IF (IS_PANDIGITAL) THEN
            IF (PRIME_NUM > LARGEST_PANDIGITAL_PRIME) THEN
                LARGEST_PANDIGITAL_PRIME = PRIME_NUM
            END IF
        END IF

    END DO

    10 CLOSE(2)

    PRINT ('(I0)'), LARGEST_PANDIGITAL_PRIME

END PROGRAM F041


module orthogonalization
      use, intrinsic :: iso_fortran_env, only: rk => real64
      use prep, only: equals0
      implicit none

      real(rk), parameter :: GS_MIN = 1.0e-9
      contains
      subroutine gs_modify(A, n, p)
          !classical gs only modifying A to be the end result
          !A: n x p  n is nbasis p is ncsf
          !Q: n x p
          !R: p x p
          !A = QR

          !p could change, only output non-zero unit vectors in E
          !directly modifies table and p
          integer, intent(in) :: n
          real(rk), allocatable :: A(:, :),  Q(:, :), R(:, :), E(:, :)
          integer :: k, i, j,  p
          if(.not.allocated(Q)) then
              allocate(Q(n, p))
          endif
          if(.not.allocated(R)) then
              allocate(R(p, p))
          endif

          write(*, *) '========================= Orthogonalization ================================'
          write(*, *) 'Input matrix A'
          do i = 1, n
              write(*, *) A(i, 1:p)
          enddo

          j = 1
          do k = 1, p
              Q(1:n, k) = A(1:n, k)
              if(k.ne.1) then
                  do i = 1, k-1
                      R(i, k) = dot_product(Q(1:n, i), Q(1:n, k))
                  enddo
                  !R(1:k-1, k) = matmul(transpose(Q(:, k-1:k-1)),Q(:, k))
                  Q(1:n, k) = Q(1:n, k) - matmul(Q(1:n, 1:k-1), R(1:k-1, k))
              endif
              R(k, k) = norm2(Q(1:n, k))
              if(abs(R(k, k)).le.GS_MIN) then
                  do i = 1, n
                      Q(i, k) = 0
                  enddo
              else
                  Q(1:n, k) = Q(1:n, k)/R(k, k)
                  A(1:n, j) = Q(1:n, k)!j<=k
                  j = j + 1
              endif
          enddo

          write(*, *) 'Matrix Q'
          do i = 1, n
              write(*, *) Q(i, 1:p)
          enddo
          write(*, *) 'Matrix R'
          do i = 1, p
              write(*, *) R(i, 1:p)
          enddo

          p = j - 1
          write(*, *) 'Output matrix A'
          do i = 1, n
              write(*, *) A(i, 1:p)
          enddo
          write(*, *) 'Output p =', p

          deallocate(Q)
          deallocate(R)

      end subroutine gs_modify

      subroutine gs(A, Q, R, E, n,p, ncsf)
          !A: n x p
          !Q: n x p
          !R: p x p
          !A = QR

          !p could change, only output non-zero unit vectors in E
          integer, intent(in) :: n, p
          real(rk), intent(in) :: A(:, :)
          real(rk), allocatable :: Q(:, :), R(:, :), E(:, :)
          integer :: k, i, j, ncsf
          if(.not.allocated(Q)) then
              allocate(Q(n, p))
          endif
          if(.not.allocated(R)) then
              allocate(R(p, p))
          endif

          if(.not.allocated(E)) then
              allocate(E(n, p))
          endif

          write(*, *) '========================= Orthogonalization ================================'
          j = 1
          do k = 1, p
              Q(1:n, k) = A(1:n, k)
              if(k.ne.1) then
                  do i = 1, k-1
                      R(i, k) = dot_product(Q(1:n, i), Q(1:n, k))
                  enddo
                  !R(1:k-1, k) = matmul(transpose(Q(:, k-1:k-1)),Q(:, k))
                  Q(1:n, k) = Q(1:n, k) - matmul(Q(1:n, 1:k-1), R(1:k-1, k))
              endif
              R(k, k) = norm2(Q(1:n, k))
              if(equals0(R(k, k))) then
                  do i = 1, n
                      Q(i, k) = 0
                  enddo
              else
                  Q(1:n, k) = Q(1:n, k)/R(k, k)
                  E(1:n, j) = Q(1:n, k)
                  j = j + 1
              endif
          enddo
          ncsf = j - 1
          write(*, *) 'Input matrix A'
          write(*, *) A
          write(*, *) 'Matrix Q'
          write(*, *) Q
          write(*, *) 'Matrix R'
          write(*, *) R
          write(*, *) 'Matrix E'
          write(*, *) E

      end subroutine gs
end module orthogonalization


program test_bisect
use types, only: dp
use utils, only: assert
use optimize, only: bisect
implicit none

real(dp) :: x

x = bisect(f1, -4._dp, 4._dp, 1e-12_dp)
print *, x
call assert(abs(x - 0.73908513_dp) < 1e-8_dp)

x = bisect(f2, -4._dp, 4._dp, 1e-12_dp)
print *, x
call assert(abs(x - 0.86547403_dp) < 1e-8_dp)

x = bisect(f3, 0._dp, 3._dp, 1e-12_dp)
print *, x
call assert(abs(x - 2.40482556_dp) < 1e-8_dp)

x = bisect(f3, 3._dp, 6._dp, 1e-12_dp)
print *, x
call assert(abs(x - 5.52007811_dp) < 1e-8_dp)

x = bisect(f4, -4._dp, 4._dp, 1e-12_dp)
print *, x
call assert(abs(x) < 1e-8_dp)

contains

real(dp) function f1(x)
real(dp), intent(in) :: x
f1 = cos(x) - x
end function

real(dp) function f2(x)
real(dp), intent(in) :: x
f2 = cos(x) - x**3
end function

real(dp) function f3(x)
real(dp), intent(in) :: x
f3 = bessel_jn(0, x)
end function

real(dp) function f4(x)
real(dp), intent(in) :: x
f4 = x
end function

end program


    Program ztzrzf_example

!     ZTZRZF 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 blas_interfaces, Only: dznrm2, ztrsm
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: zgeqp3, ztzrzf, zunmqr, zunmrz
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Complex (Kind=dp), Parameter :: one = (1.0_dp, 0.0_dp)
      Complex (Kind=dp), Parameter :: zero = (0.0_dp, 0.0_dp)
      Integer, Parameter :: inc1 = 1, nb = 64, nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: tol
      Integer :: i, ifail, info, j, k, lda, ldb, lwork, m, n, nrhs
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), b(:, :), tau(:), work(:)
      Real (Kind=dp), Allocatable :: rnorm(:), rwork(:)
      Integer, Allocatable :: jpvt(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs
!     .. Executable Statements ..
      Write (nout, *) 'ZTZRZF Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, nrhs
      lda = m
      ldb = m
      lwork = (n+1)*nb
      Allocate (a(lda,n), b(ldb,nrhs), tau(n), work(lwork), rnorm(n), &
        rwork(2*n), jpvt(n))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, m)
      Read (nin, *)(b(i,1:nrhs), i=1, m)

!     Initialize JPVT to be zero so that all columns are free

      jpvt(1:n) = 0

!     Compute the QR factorization of A with column pivoting as
!     A = Q*(R11 R12)*(P**T)
!            ( 0  R22)
      Call zgeqp3(m, n, a, lda, jpvt, tau, work, lwork, rwork, info)

!     Compute C = (C1) = (Q**H)*B, storing the result in B
!                  (C2)
      Call zunmqr('Left', 'Conjugate transpose', m, nrhs, n, a, lda, tau, b, &
        ldb, work, lwork, info)

!     Choose TOL to reflect the relative accuracy of the input data

      tol = 0.01_dp

!     Determine and print the rank, K, of R relative to TOL

loop: Do k = 1, n
        If (abs(a(k,k))<=tol*abs(a(1,1))) Then
          Exit loop
        End If
      End Do loop
      k = k - 1

      Write (nout, *) 'Tolerance used to estimate the rank of A'
      Write (nout, 100) tol
      Write (nout, *) 'Estimated rank of A'
      Write (nout, 110) k
      Write (nout, *)
      Flush (nout)

!     Compute the RZ factorization of the K by K part of R as
!     (R1 R2) = (T 0)*Z
      Call ztzrzf(k, n, a, lda, tau, work, lwork, info)

!     Compute least squares solutions of triangular problems by
!     back substitution in T*Y1 = C1, storing the result in B
      Call ztrsm('Left', 'Upper', 'No transpose', 'Non-Unit', k, nrhs, one, a, &
        lda, b, ldb)

!     Compute estimates of the square roots of the residual sums of
!     squares (2-norm of each of the columns of C2)

      Do j = 1, nrhs
        rnorm(j) = dznrm2(m-k, b(k+1,j), inc1)
      End Do

!     Set the remaining elements of the solutions to zero (to give
!     the minimum-norm solutions), Y2 = 0

      b(k+1:n, 1:nrhs) = zero

!     Form W = (Z**H)*Y
      Call zunmrz('Left', 'Conjugate transpose', n, nrhs, k, n-k, a, lda, tau, &
        b, ldb, work, lwork, info)

!     Permute the least squares solutions stored in B to give X = P*W

      Do j = 1, nrhs
        Do i = 1, n
          work(jpvt(i)) = b(i, j)
        End Do
        b(1:n, j) = work(1:n)
      End Do

!     Print least squares solutions

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, nrhs, b, &
        ldb, 'Bracketed', 'F7.4', 'Least squares solution(s)', 'Integer', &
        rlabs, 'Integer', clabs, 80, 0, ifail)

!     Print the square roots of the residual sums of squares

      Write (nout, *)
      Write (nout, *) 'Square root(s) of the residual sum(s) of squares'
      Write (nout, 100) rnorm(1:nrhs)

100   Format (3X, 1P, 7E11.2)
110   Format (1X, I6)
    End Program


c     ==========================================
      subroutine mapc2p(x1,y1,xp,yp,zp,Rsphere)
c     ==========================================
c
c     Map computational point (x1,y1) to the point (xp,yp,zp)
c     on the sphere.
c
c     Points in [-1,1]x[-1,1]  are mapped to the upper hemisphere
c     Points in [-3,-1]x[-1,1] are mapped to the lower hemisphere

      implicit real*8(a-h,o-z)
cf2py  double precision intent(in) x1
cf2py  double precision intent(in) y1
cf2py  double precision intent(in) xp
cf2py  double precision intent(in) yp
cf2py  double precision intent(in) zp
cf2py  double precision intent(in) Rsphere

      r1 = Rsphere
      xc = x1
      yc = y1
      pi = 4.d0*datan(1.d0)

c     # ghost cell values outside of [-3,1]x[-1,1] get mapped to other
c     # hemisphere:
      if (xc.ge.1.d0) xc = xc-4.d0
      if (xc.lt.-3.d0) xc = xc+4.d0

      if (yc.ge.1.d0) then
         yc = 2.d0 - yc
         xc = -2.d0 - xc
      endif

      if (yc.lt.-1.d0) then
         yc = -2.d0 - yc
         xc = -2.d0 - xc
      endif

      if (xc.lt.-1.d0) then
c         # points in [-3,-1] map to lower hemisphere - reflect about x=-1
c         # to compute x,y mapping and set sgnz appropriately:
          xc = -2.d0 - xc
          sgnz = -1.d0
      else
          sgnz = 1.d0
      endif

      sgnxc = dsign(1.d0,xc)
      sgnyc = dsign(1.d0,yc)

      xc1 = dabs(xc)
      yc1 = dabs(yc)
      d = dmax1(dmax1(xc1,yc1), 1.d-10)

      DD = r1*d*(2.d0 - d) / dsqrt(2.d0)
      R = r1

      center = DD - dsqrt(dmax1(R**2 - DD**2, 0.d0))
      xp = DD/d * xc1
      yp = DD/d * yc1

      if (yc1 .gt. xc1) then
          yp = center + dsqrt(dmax1(R**2 - xp**2, 0.d0))
      else
          xp = center + dsqrt(dmax1(R**2 - yp**2, 0.d0))
      endif

      zp = dsqrt(dmax1(r1**2 - (xp**2 + yp**2), 0.d0))
      xp = xp*sgnxc
      yp = yp*sgnyc
      zp = zp*sgnz

      return
      end


FUNCTION pythag_sp(a,b)
  USE nrtype
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: a,b
  REAL(SP) :: pythag_sp
  REAL(SP) :: absa,absb
  absa=abs(a)
  absb=abs(b)
  if (absa > absb) then
     pythag_sp=absa*sqrt(1.0_sp+(absb/absa)**2)
  else
     if (absb == 0.0) then
        pythag_sp=0.0
     else
        pythag_sp=absb*sqrt(1.0_sp+(absa/absb)**2)
     end if
  end if
END FUNCTION pythag_sp

FUNCTION pythag_dp(a,b)
  USE nrtype
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: a,b
  REAL(DP) :: pythag_dp
  REAL(DP) :: absa,absb
  absa=abs(a)
  absb=abs(b)
  if (absa > absb) then
     pythag_dp=absa*sqrt(1.0_dp+(absb/absa)**2)
  else
     if (absb == 0.0) then
        pythag_dp=0.0
     else
        pythag_dp=absb*sqrt(1.0_dp+(absa/absb)**2)
     end if
  end if
END FUNCTION pythag_dp


program LUdecomp_gaussseidel
    ! This program does LU decomposition of a general nxn matrix A in the system Ax=b, then solves for x using back substitution
    ! After obtaining x and A it improves the existing solution using simple gauss seidel iteration
    ! LU matrix is stored in a single matrix with L's diagonal terms alll being 1 and hence not stored (do-little's way).
    ! The variable names are pretty straightforward, with Ax=b => LUx=b where Ux = y, thus Ly = b
    implicit none
    real (kind=8), allocatable :: A(:,:), LU(:,:),b(:),x(:),y(:)
    integer :: n , i , j , k

    !READ MATRIX BELOW
    print*, "Give dimension of matrix"
    Read*, n
    allocate(A(n,n), b(n), x(n),y(n))
    print*, 'Give A row wise'
    do i=1,n
        read*, A(i,:)
    enddo
    print*, 'Give b' ; read *, b
    print*, "Reading complete" ; print*, '-------------------------LU decomposition:---------------------------------'

    ! READING COMPLETE NOW DO LU DECOMPOSITION AND SUBSEQUENTLY BACKSUBSTITTUTE
    call LUdecomposition(A,LU)
    call backsubstituteLU(LU,x,y,b)
    print*, '--------------------------------------------------------------------------------------'

    !Do gauss seidel now and print final soltuion
    print*, "Give number of iterations you want for gauss seidel" ; read*, k
    do i = 1,k
        call gausseidel(x,b,A)
        print*, 'Iteration', i, "complete, new solution :", x
        print*, '--------------------------------------------------------------------------------------'
    enddo
    print*, "The final solutions are"
    print*, x
    contains

    SUBROUTINE LUdecomposition(A,LU)
        !This subroutine does LU decomposition given a matrix A using Dolittle (i.e. diagonal terms of L = 1).
        !The LU decomposition is stored in one matrix only with diagonal of L not stored at all (since they are all 1)

        real(kind=8) :: A(:,:),sum
        real(kind=8) , allocatable :: LU(:,:)
        integer :: n(2),i,j,k

        n = shape(A)
        if (n(1) .ne. n(2)) print*, "Bad matrix"
        allocate(LU(n(1),n(2)))
        LU = 0
        do i=1,n(1)                                     !calculate upper triangular terms
            do k=i,n(1)
                sum=0
                do j=1,i
                    sum = sum + LU(i,j)*LU(j,k)         !couldve used dot product intrinsic function to get rid of this do loop
                enddo
                LU(i,k) = A(i,k) - sum
            enddo

            do k=i,n(1)                                 ! now calculate lower triangular
                if (i ==k) cycle
                sum =0
                do j=1,i
                    sum = sum + LU(k,j)*LU(j,i)
                enddo
                LU(k,i) = (A(k,i) - sum)/LU(i,i)
            enddo
        enddo
        do i=1,n(1)
            print*, LU(i,:)
        enddo
    endsubroutine

    SUBROUTINE backsubstituteLU(LU,x,y,b)
        !This subroutine backsubstitutes to get x and y vectors in a Ax=LUx=b equation/matrix system, where Ux=y.
        !LU matrix is LU decomposition of A stored in one matrix with diagonal elements of L =1 (and thus not stored at all).
        ! valid for any nxn system. x,y are pre-allocated empty matrices to be filled by this subroutine
        real(kind=8) :: LU(:,:),x(:),y(:),b(:),sum
        integer :: i,j,k, n(2)
        n = shape(LU)
        !get y values from back substitution below
        y(1) = b(1)
        do i=2,n(1)
            sum =0
            do j=1,i
                sum = sum+ LU(i,j)*y(j)
            enddo
            y(i) = b(i) - sum
        enddo
        ! get x values from back substitution below
        x(n(1)) =  y((n(1)))/LU(n(1),n(1))
        do i=n(1)-1,1,-1
            sum = 0
            do j=i+1,n(1)
                sum = sum + LU(i,j)*x(j)
            enddo
            x(i) = (y(i) - sum)/LU(i,i)
        enddo
    endsubroutine

    SUBROUTINE gausseidel(x,b,A)
        ! This subroutine does one step of gauss-seidel error correction.
        ! the system is of form Ax=b , this subroutine updates x itself valid for any nxn system
        real(kind=8) :: x(:), b(:), A(:,:), sum
        real(kind=8), allocatable :: temp(:)
        integer :: n(2), i, j, k
        n = shape(A)
        allocate(temp(n(1)))

        do i=1,n(1)
            sum=0
            do j = 1,i-1
                sum = sum + A(i,j)*temp(j)
            enddo
            do j = i+1,n(1)
                sum = sum + A(i,j)*x(j)
            enddo
            temp(i) = (b(i)-sum)/A(i,i)
        enddo

        x = temp
        deallocate(temp)

    endsubroutine
end program LUdecomp_gaussseidel


program test_inv
use types, only: dp
use constants, only: i_
use utils, only: assert
use linalg, only: inv, eye
implicit none

real(dp), parameter :: eps = 1e-9_dp
complex(dp) :: A(2, 2), B(2, 2), C(2, 2)
real(dp) :: D(2,2), E(2,2), F(2,2)

! test for complex double routines:
A = reshape([0+0*i_, i_, 2+0*i_, 0+0*i_], [2, 2], order=[2, 1])
C = inv(A)
B = reshape([0+0*i_, 1+0*i_, -2*i_, 0+0*i_], [2, 2], order=[2, 1]) / 2
call assert(maxval(abs(C-B)) < eps)
call assert(maxval(abs(matmul(C, A)-eye(2))) < eps)
call assert(maxval(abs(matmul(A, C)-eye(2))) < eps)

A = reshape([1+0*i_, i_, 2+0*i_, 3*i_], [2, 2], order=[2, 1])
C = inv(A)
B = reshape([3+0*i_, -1+0*i_, 2*i_, -i_], [2, 2], order=[2, 1])
call assert(maxval(abs(C-B)) < eps)
call assert(maxval(abs(matmul(C, A)-eye(2))) < eps)
call assert(maxval(abs(matmul(A, C)-eye(2))) < eps)

A = reshape([0+0*i_, i_, -i_, 0+0*i_], [2, 2], order=[2, 1])
C = inv(A)
call assert(maxval(abs(matmul(C, A)-eye(2))) < eps)
call assert(maxval(abs(matmul(A, C)-eye(2))) < eps)

! tests for double precision routine:
D = reshape([1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp], shape=[2,2])
E = reshape([-2.0_dp, 1.0_dp, 1.5_dp, -0.5_dp], shape=[2,2])
F = inv(D)
call assert(maxval(abs(E - F)) < eps)
call assert(maxval(abs(matmul(F, D) - cmplx(eye(2)))) < eps)
call assert(maxval(abs(matmul(E, D) - cmplx(eye(2)))) < eps)

D = reshape([0.0_dp, 1.0_dp, 1.0_dp, 0.0_dp], shape=[2,2])  ! is its own inverse
F = inv(D)
call assert(maxval(abs(D - F)) < eps)
call assert(maxval(abs(matmul(F, D) - cmplx(eye(2)))) < eps)

end program


MODULE boundary_wavekill_mod
  USE kinds_mod
  implicit none
  private

PUBLIC wave_killing
CONTAINS
!===============================================================================
!> Following Section 3.2 of de Val-Borro et al. (2006, MNRAS, 370, 529).
!> These "wave killing" conditions are designed to reduce wave reflection at
!> solid boundaries.
!>
!> In this approach, the following ODE is applied at each application of the
!> boundary conditions:
!>    dq = - q - q0
!>    --     ------ * R(x)
!>    dt      tau
!> where `q` is the quantity that you wish to damp towards value `q0`, `tau` is
!> the timescale over which `q` is damped, `xbndy` is the location of the actual
!> boundary, `xkill` is the location at which to begin the damping procedure and
!> `x` is the location of the current grid point.
!>
!> `R(x)` is a simple quadratic weighting function that is 1 at the actual boundary
!> (`xbndy`) and 0 at `xkill`.
!>
!> The function returns the *rate* at which quantity `q` is damped; the quantity
!> should then be updated along the lines of:
!>    qold = qnew + dt * wave_killing(qold, q0, tau, xkill, xbndy, x)
!>
!===============================================================================
FUNCTION wave_killing (q, q0, tau, xkill, xbndy, x) RESULT (rate)
  real(kind=KindScalarVar), intent(in) :: q, q0
  real(kind=KindScalarVar), intent(in) :: tau, x, xkill, xbndy
  real(kind=KindScalarVar) :: rate, quadfunc
  !-----------------------------------------------------------------------------

  quadfunc = ((x - xkill) / (xbndy - xkill))**2
  rate = -(q - q0) * quadfunc / tau

END FUNCTION wave_killing

END MODULE boundary_wavekill_mod


\ number.f      - x4 pictured number output words
\ ------------------------------------------------------------------------

  .( loading number.f ) [cr]

\ ------------------------------------------------------------------------

  variable hld              \ points to place to construct number

\ ------------------------------------------------------------------------
\ initiate pictured number construction

: <#            ( --- )
  pad hld ! ;               \ point hold at pad

\ ------------------------------------------------------------------------
\ store character in number string we are creating

: hold          ( c1 --- )
  hld dup decr              \ building number from rt to lt
  @                         \ get address to construct number at
  c! ;                      \ store digit (etc) at that address

\  -------------------------------------------------------------------------
\  hold a '-' if number is negative

: sign          ( n1 --- )
  0< not ?exit
  '-' hold ;

\ ------------------------------------------------------------------------
\ convert next digit of n1 in current base, store in hold

: #             ( d1 --- n2 )
  base                      \ get divisor
  mu/mod                    \ divide d1 by base, leave rem and quo
  rot                       \ get remainder at top
  dup 9 >                   \ is remainder > 9 ?
  7 and +                   \ adds 7 if digit is greater than 9
  '0' +                     \ asciify
  hold ;                    \ store in pad

\ -------------------------------------------------------------------------
\ convert rest of number n1 in current base

: #s            ( d1 --- 0 0 )
  begin
    #                       \ convert next digit
    2dup or 0=              \ anything left to convert ?
  until ;                   \ if so, keep going

\ ------------------------------------------------------------------------
\ complete pictured number conversion

: #>            ( d1 --- a1 n1 )
  2drop                     \ discard d1
  hld @                     \ get address we constructed number at
  pad over - ;              \ get # chars in the string

\ ------------------------------------------------------------------------
\ construct string to display signed d1

: (d.)          ( d1 --- a1 n1 )
  tuck                      \ retain hi half of d1
  dabs <# #s                \ construct string
  rot sign                  \ get hi half back and add '-' sign if needed
  #> ;                      \ complete conversion

\ ------------------------------------------------------------------------
\ display signed number d1

: d.            ( d1 --- )
  (d.) type                 \ convert d1
  space ;                   \ display string

\ -------------------------------------------------------------------------
\ display d1 right justified to n1 chars

: d.r           ( d1 n1 --- )
  >r (d.)                   \ save hustification distance and convert d1
  r> over - spaces          \ justify string to required width
  type ;                    \ display string

\ ------------------------------------------------------------------------
\ display n1

: .             ( n1 --- )
  s>d d. ;                  \ convert n1 to double and display

\ ------------------------------------------------------------------------
\ display right justified n1

: .r            ( n1 n2 --- )
  swap                      \ stash justification away for a sec
  s>d                       \ convert n1 to double
  rot d.r ;                 \ rotate justification back our amd display

\ ------------------------------------------------------------------------

: u.            ( n1 --- )  0 d. ;
: u.r           ( n1 --- )  0 swap d.r ;

\ ------------------------------------------------------------------------

: radix         ( n1 --- )  !> base ;

\ ------------------------------------------------------------------------
\ forth can use almost any damned base it wants to

: hex           ( --- )  16 radix ;
: decimal       ( --- )  10 radix ;
: binary        ( --- )   2 radix ;
: octal         ( --- )   8 radix ;

\ ========================================================================


Module quadratures
  Use math_constants
	Implicit None

Contains
  !This subroutine select the appropiate subroutine for whatever quadrature in terms
  !of the parameters of each quadrature; look inside the function for the parameters
  !order for each quadrature
	! "quad" accepts:
  !                 "CLCU" -> Clenshaw Curtis quadrature
  ! "params_i" -> array with the needed integer parameters
  ! "params_i" -> array with the needed floating point parameters
  ! "qp" -> quadrature points array
  ! "qw" -> quadrature weights array
	Subroutine quad_select(quad,params,qp,qw)
		Implicit None
		character(len=4), intent(in) :: quad !quadrature selector variable
    real * 8, dimension(:), intent(in) :: params !quadrature floating parameters
		real * 8, dimension(:), intent(out) :: qp, qw !quadrature points
    !real * 8, dimension(:), optional, intent(out) :: qw !quadrature weights
    integer :: np
    real * 8 :: xmin,xmax,dr
    xmin = params(1)
    xmax = params(2)
    np   = nint( params(3) )
    select case(quad)
    !Clenshaw Curtis quadrature
    case("CLCU")
      !INTEGER parameters needed order:
      !   Number of points "np"
      !Floating point parameters needed order:
      !   Domain minimum value "xmin"
      !   Domain maximum value "xmax"
      call Clenshaw_Curtis_quadrature(np,qp,qw)
      call rescale_OW(np,qp,qw,-1.d0,1.d0,xmin,xmax)
    !Rectangles quadratures
    case("RECT")
        !INTEGER parameters needed order:
        !   Number of points "np"
        !Floating point parameters needed order:
        !   Domain minimum value "xmin"
        !   Domain maximum value "xmax"
        dr = (xmax-xmin) / dble(np)
        qw = dr
        call rectangles(qp,xmin,dr)
    end select
    return
	End Subroutine

	Subroutine Clenshaw_Curtis_quadrature(order,x,w)
		Implicit None
    Integer, intent(in) :: order
    Real * 8, dimension(order), intent(out) :: x, w
	  Real * 8 :: b
	  Integer :: i
	  Integer :: j
	  Real * 8 :: theta
	  If ( order < 1 ) Then
	    write ( *, '(a)' ) ' '
	    write ( *, '(a)' ) 'CLENSHAW_CURTIS_COMPUTE - Fatal error!'
	    write ( *, '(a,i8)' ) '  Illegal value of ORDER = ', order
	    stop
	  End If
	  If ( order == 1 ) Then
	    x(1) = 0.0D+00
	    w(1) = 2.0D+00
	    return
	  End If
		Do i = 1, order
	    x(i) = cos ( dble ( order - i ) * pi / dble ( order - 1 ) )
	  End Do
	  x(1) = -1.0D+00
	  If ( mod ( order, 2 ) == 1 ) Then
	    x((order+1)/2) = 0.0D+00
	  End If
	  x(order) = +1.0D+00
	  Do i = 1, order
	    theta = dble( i - 1 ) * pi / dble( order - 1 )
	    w(i) = 1.0D+00
	    Do j = 1, ( order - 1 ) / 2
	      If ( 2 * j == ( order - 1 ) ) Then
	        b = 1.0D+00
	      Else
	        b = 2.0D+00
	      End If
	      w(i) = w(i) - b * cos ( 2.0D+00 * dble( j ) * theta ) / dble( 4 * j * j - 1 )
	    End Do
	  End Do
	  w(1) = w(1) / dble( order - 1 )
	  w(2:order-1) = 2.0D+00 * w(2:order-1) / dble( order - 1)
	  w(order) = w(order) / dble( order - 1 )
	  return
	End Subroutine

  Subroutine rectangles(x,x_min,dr)
		Implicit None
	  Real * 8, intent(out), dimension(:) :: x
    Real * 8, intent(in) :: dr,x_min
    integer :: i1
	  Do i1=1, size(x)
      x(i1) = x_min + i1 * dr
    End Do
	  return
	End Subroutine

  !This subroutines rescales the abscissas and weights values from a range of
  !x ϵ [xa, xb] to y ϵ [ya, yb] and obtains the new weights in the new arrays
  !y, wy
  Subroutine rescale_NA(n,x,wx,xa,xb,y,wy,ya,yb)
  	implicit none
  	integer, intent(in) :: n
  	real * 8, intent(in) :: xa,xb,ya,yb
  	real * 8, dimension(n), intent(in) :: x,wx
  	real * 8, dimension(n), intent(out) :: y,wy
  	y(1:n) = ya  + (( yb - ya ) * (x(1:n)-xa) / ( xb - xa ))
    wy(1:n) = ( yb - ya ) * wx(1:n) / ( xb - xa)
  End Subroutine

  !This subroutines rescales the abscissas and weights values from a range of
  !x ϵ [xa, xb] to y ϵ [ya, yb] and obtains the new wy in the arrays x,wx
  Subroutine rescale_OW(n,x,wx,xa,xb,ya,yb)
  	implicit none
  	integer, intent(in) :: n
  	real * 8, intent(in) :: xa,xb,ya,yb
  	real * 8, dimension(n), intent(inout) :: x,wx
  	x(1:n) = ( ( ya + yb ) + ( yb - ya ) * x(1:n) ) / ( xb - xa )
    wx(1:n) = ( yb - ya ) * wx(1:n) / ( xb - xa)
  End Subroutine

  !This subroutine writes down the information of a given quadrature used
	Subroutine quad_writting(quad,i_unit,params)
    Implicit None
    Real * 8, dimension(:), intent(in) :: params
    Character(len=4), intent(in) :: quad
    Integer, intent(in) :: i_unit
    Select case (quad)
			case("CLCU")
				Write(i_unit,*) "				Clenshaw-Curtis"
				Write(i_unit,*) "quadrature minimum value    = ", params(1)
				Write(i_unit,*) "quadrature maximum value    = ", params(2)
        Write(i_unit,*) "quadrature number of points = ", params(3)
      case("RECT")
        Write(i_unit,*) "				Rectangles"
        Write(i_unit,*) "quadrature minimum value    = ", params(1)
        Write(i_unit,*) "quadrature differential     = ", params(2)
			case Default
				Write(i_unit,*) "				"//quad
        Write(i_unit,*) "quadrature minimum value    = ", params(1)
				Write(i_unit,*) "quadrature maximum value    = ", params(2)
        Write(i_unit,*) "quadrature number of points = ", params(3)
		End Select
		Write(i_unit,*) "###############################"
  End Subroutine

  !This subroutine generates the quadrature points and weights of
  !up to Simpson 3/8 quadrature given an order greater than 0
  Subroutine Simpson_3_8_quad(qp,qw,order,qpmin,qpmax)
    Implicit None
    Real * 8, intent(out), dimension(:) :: qp, qw !Quadrature points and quadrature weights
    Real * 8, intent(in) :: qpmin, qpmax
    Integer, intent(in) :: order !Order of the quadrature
    Real * 8 :: dx
    Integer :: i1, i2, ratio, mod_ratio, imax
		dx = (qpmax-qpmin) / dble(order)
    !Calculating the quadrature points
    Do i1 = 1, order
      qp(i1) = qpmin + (i1 * dx)
    End Do
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    If (order<1) Then
      Print *, 'Error at "Simpson_3_8_quad", not a valid order '
    Else If (order == 1) Then
      qw(:) = dx
      return
    Else If (order==2) Then
      qw(:) =  0.5d0 * dx
			return
		Else If (order==3) Then
      qw(1) = 1.d0
      qw(2) = 4.d0
      qw(3) = 1.d0
      qw(:) = qw(:) * dx / 3.d0
			return
		Else If (order==4) Then
      qw(1) = 1.d0
      qw(2) = 3.d0
      qw(3) = 3.d0
      qw(4) = 1.d0
      qw(:) = qw(:) * dx * 0.375d0
			return
		Else If (order==5) Then
      qw(1) = 1.d0
      qw(2) = 4.d0
      qw(3) = 2.d0
      qw(4) = 4.d0
      qw(5) = 1.d0
      qw(:) = qw(:) * dx / 3.d0
			return
		Else If (order>5) Then
      ratio = order/3
			mod_ratio = mod(order,3)
      qw(1) = 1.d0
      Do i1=1, ratio
        i2 = (i1 * 3) - 1
        qw(i2)   = 3.d0
        qw(i2+1) = 3.d0
        if(i2+2 < order) qw(i2+2) = 2.d0
      End Do
      qw(:) = qw(:) * 3.d0 * dx / 8.d0
			If	(mod_ratio == 0) Then
				qw(order-2) = ((3.d0/8.d0) + (1.d0/3.d0)) * dx
        qw(order-1) = 4.d0 * dx / 3.d0
        qw(order)   = 1.d0 * dx / 3.d0
        return
      Else If (mod_ratio==1) Then
        qw(order-1) = (3.d0 / 8.d0 + 0.5d0) * dx
        qw(order)   =  0.5d0 * dx
        return
      Else If (mod_ratio==2) Then
				qw(order) = (3.d0/8.d0) * dx
        return
      End If
    End If
  End Subroutine

End Module


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program test_gaussian

! test the gaussian distribution random number generator routine
! with different means, standard deviations, and iteration counts.

use      types_mod, only : r8
use  utilities_mod, only : register_module, &
                           open_file, close_file, &
                           initialize_utilities, finalize_utilities, &
                           squeeze_out_blanks
use random_seq_mod, only : random_seq_type, init_random_seq, random_gaussian

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

type (random_seq_type) :: r
integer :: i, j, n, f
real(r8) :: r1, sqdist, mean_sqdist
real(r8) :: mean, sd, var, compvar, compsd, compdiff
logical  :: write_this_one
character(len=256) :: fname, temp
character(len=50) :: formf = '(I12,2(F14.6),1(F24.16),2(F12.6))'
logical :: write_me = .true.       ! if true, write each distribution into a file for later diagnostics
integer :: write_limit = 1000000   ! but only if rep count is not greater than this limit

type t_inputs
 real(r8) :: t_mean
 real(r8) :: t_stddev
 integer  :: t_nreps
end type

! to add more tests or change the parameters, specify a test count
! and update the sets of (mean, stddev, sample size) here:

integer, parameter :: ntests = 21
type(t_inputs) :: t(ntests) = (/ &
    t_inputs(  0.0_r8,  1.0_r8,       100), &
    t_inputs(  0.0_r8,  1.0_r8,     10000), &
    t_inputs(  0.0_r8,  1.0_r8,   1000000), &
    t_inputs(  0.0_r8,  1.0_r8, 100000000), &
    t_inputs(  1.0_r8,  5.0_r8,       100), &
    t_inputs(  1.0_r8,  5.0_r8,     10000), &
    t_inputs(  1.0_r8,  5.0_r8,   1000000), &
    t_inputs(  1.0_r8,  5.0_r8, 100000000), &
    t_inputs(  6.0_r8,  8.0_r8,   1000000), &
    t_inputs(-86.0_r8,  8.0_r8,   1000000), &
    t_inputs(  0.6_r8,  8.0_r8,   1000000), &
    t_inputs( -6.0_r8,  8.0_r8,   1000000), &
    t_inputs(956.0_r8,  8.0_r8,   1000000), &
    t_inputs( 36.0_r8,  8.0_r8,   1000000), &
    t_inputs(  6.0_r8,  1.0_r8,   1000000), &
    t_inputs(  6.0_r8, 18.0_r8,   1000000), &
    t_inputs(  6.0_r8, 99.0_r8,   1000000), &
    t_inputs(  6.0_r8,  0.1_r8,   1000000), &
    t_inputs(  6.0_r8,  0.8_r8,   1000000), &
    t_inputs(  6.0_r8,  0.5_r8,   1000000), &
    t_inputs(  6.0_r8, 33.5_r8,   1000000)  /)

call initialize_utilities('test_gaussian')
call register_module(source,revision,revdate)

write(*, *) ''
write(*, *) 'sample size       input mean & std dev        computed std dev       diff       % diff '
write(*, *) ''

do j=1, ntests

   call init_random_seq(r, 5)

   mean = t(j)%t_mean
   sd = t(j)%t_stddev
   n = t(j)%t_nreps

   ! save all values in a file for post-plotting?
   write_this_one = (write_me .and. n <= write_limit)

   if (write_this_one) then
      write(temp, "(A,F8.3,A,F8.3,A,I10)") "gauss_", mean, "_", sd, "_", n
      call squeeze_out_blanks(temp, fname)
      f = open_file(fname)
   endif

   ! analytical values:
   mean_sqdist = 0.0_r8

   do i = 1, n

      r1 = random_gaussian(r, mean, sd)

      if (write_this_one) write(f,*) r1

      sqdist = (mean-r1)**2
      mean_sqdist = mean_sqdist + sqdist
   end do

   if (write_this_one) call close_file(f)

   ! computed values:
   compvar = mean_sqdist / n
   compsd = sqrt(compvar)
   compdiff = compsd - sd

   write(*, formf) n, mean, sd, compsd, compdiff, abs(compdiff/sd) * 100._r8

enddo

call finalize_utilities()

end program test_gaussian

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!
!     12/96
!
!     a program for testing all divergence and inverse divergence routines
!
!     (1) first set an irrotational vector field v, w
!
!     (2) compute the coefficients br, bi, cr, ci of (v, w) using vector analysis
!
!     (3) compute the divergence of (v, w) using divec, dives, divgc, divgs
!
!     (4) analystically compute the divergence and compare with (3)
!
!     (5) invert the divergence and compare with the irrotational (v, w)
!
program tdiv

    use spherepack

    ! Explicit typing only
    implicit none

    real(wp) :: cosp
    real(wp) :: cost
    real(wp) :: d2xdp2
    real(wp) :: d2xdt2
    real(wp) :: d2ydp2
    real(wp) :: d2ydt2
    real(wp) :: d2zdp2
    real(wp) :: d2zdt2
    real(wp) :: dlat
    real(wp) :: dphi
    real(wp) :: dsfdp
    real(wp) :: dsfdt
    real(wp) :: dvdt
    real(wp) :: dve

    real(wp) :: dx2dt2
    real(wp) :: dxdp
    real(wp) :: dxdt
    real(wp) :: dydp
    real(wp) :: dydt
    real(wp) :: dzdp
    real(wp) :: dzdt
    real(wp) :: err2
    real(wp) :: err2v
    real(wp) :: err2w
    integer(ip) :: i
    integer(ip) :: icase
    integer(ip) :: error_flag
    integer(ip) :: j
    integer(ip) :: k
    real(wp) :: phi
    real(wp) :: sf
    real(wp) :: sinp
    real(wp) :: sint
    real(wp) :: theta
    real(wp) :: ve
    real(wp) :: we
    real(wp) :: x
    real(wp) :: y
    real(wp) :: z
    !
    !     set dimensions with parameter statements
    !
    integer(ip), parameter              :: nlat = 15, nlon =  8, nt = 2
    integer(ip), parameter              :: isym = 0
    integer(ip), parameter              :: mdab = (nlon+2)/2, mdb = (nlon + 1)/2
    real(wp), dimension(mdb, nlat, nt)  :: br, bi, cr, ci
    real(wp), dimension(mdab, nlat, nt) :: a, b
    real(wp), dimension(nlat, nlon, nt) :: dv, v, w
    real(wp), dimension(nlat)           :: gaussian_latitudes, gaussian_weights
    real(wp)                            :: pertrb(nt)
    real(wp), allocatable               :: wavetable(:)
    real(wp), parameter                 :: ZERO = 0.0_wp, TWO = 2.0_wp, SIX = 6.0_wp

    call iout(nlat, "nlat")
    call iout(nlon, "nlon")
    call iout(nt, "  nt")

    ! Set equally spaced colatitude and longitude increments
    dphi = TWO_PI/nlon
    dlat = PI/(nlat-1)

    ! Compute nlat-many gaussian latitudinal points
    call compute_gaussian_latitudes_and_weights(nlat, gaussian_latitudes, gaussian_weights, error_flag)

    call name("compute_gaussian_latitudes_and_weights")
    call iout(error_flag, " ier")
    call vecout(gaussian_latitudes, "gaussian_latitudes", nlat)
    !
    !     test all divergence and inverse divergence subroutines
    !
    do icase=1, 4
        call name("****")
        call name("****")
        call iout(icase, "icas")
        !
        !     set vector field v, w
        !
        do k=1, nt
            do j=1, nlon
                phi = real(j - 1, kind=wp) * dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    select case (icase)
                        case (0:2)
                            theta = real(i - 1, kind=wp) * dlat
                        case default
                            theta = gaussian_latitudes(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    dxdt = cost*cosp
                    d2xdt2 = -sint*cosp
                    dxdp = -sint*sinp
                    d2xdp2 = -sint*cosp
                    dydt = cost*sinp
                    d2ydt2 = -sint*sinp
                    dydp = sint*cosp
                    d2ydp2 = -sint*sinp
                    dzdt = -sint
                    d2zdt2 = -cost
                    dzdp = ZERO
                    d2zdp2 = ZERO
                    if (k==1) then
                        sf = x*y
                        dsfdt = x*dydt+y*dxdt
                        dsfdp = x*dydp+y*dxdp
                        v(i, j, k) = dsfdt
                        w(i, j, k) = cosp*dydp+sinp*dxdp
                        !              dv = 1/sint*(d(sint*v)/dt + dw/dp)
                        dvdt = x*d2ydt2 + TWO * dxdt*dydt + y*d2xdt2
                        !              1/sint*dwdp = 1/sint*(cosp*d2ydp2-sinp*dydp+sinp*d2xdp2+cosp*dxdp)
                        !                          = -4.*sinp*cosp
                        dv(i, j, k) = dvdt + cost*(cosp*dydt+sinp*dxdt) -4.*cosp*sinp
                    else if (k==2) then
                        sf = x*z
                        dsfdt = x*dzdt+z*dxdt
                        dsfdp = x*dzdp+z*dxdp
                        v(i, j, k) = dsfdt
                        w(i, j, k) = -cost*sinp
                        dvdt = x*d2zdt2+TWO * dzdt*dxdt + z*dx2dt2
                        !              dv = 1/sint*(d(sint*v)/dt + dw/dp)
                        dv(i, j, k) = -SIX * cost*sint*cosp
                    else if (k==3) then
                        sf = y*z
                        dsfdt = y*dzdt+z*dydt
                        dsfdp = y*dzdp+z*dydp
                        v(i, j, k) = dsfdt
                        w(i, j, k) = z*cosp
                        dv(i, j, k) = -SIX * cost*sint*sinp
                    end if
                end do
            end do
        end do

        if (icase==1) then

            call name("**ec")
            !
            !     analyze vector field
            !
            call initialize_vhaec(nlat, nlon, wavetable, error_flag)
            call name("shs ")
            call iout(error_flag, "error_flag = ")

            call vhaec(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, cr, ci, mdb, &
                nlat, wavetable, error_flag)
            call name("vha ")
            call iout(error_flag, "error_flag = ")

            !     compute divergence of (v, w) in dv
            call initialize_shsec(nlat, nlon, wavetable, error_flag)
            call name("shsi")
            call iout(error_flag, "error_flag = ")

            call divec(nlat, nlon, isym, nt, dv, nlat, nlon, br, bi, mdb, nlat, &
                wavetable, error_flag)
            call name("div ")
            call iout(error_flag, "error_flag = ")
            call iout(nlat, "nlat")
            call iout(nlon, "nlon")

        else if (icase==2) then

            call name("**es")
            call initialize_shses(nlat, nlon, wavetable, error_flag)
            call name("shsi")
            call iout(error_flag, "error_flag = ")

            call dives(nlat, nlon, isym, nt, dv, nlat, nlon, br, bi, mdb, nlat, &
                wavetable, error_flag)

            call name("div ")
            call iout(error_flag, "error_flag = ")

        else if (icase == 3) then

            call name("**gc")

            call initialize_shsgc(nlat, nlon, wavetable, error_flag)
            call name("shsi")
            call iout(error_flag, "error_flag = ")

            call divgc(nlat, nlon, isym, nt, dv, nlat, nlon, br, bi, mdb, nlat, &
                wavetable, error_flag)
            call name("div ")
            call iout(error_flag, "error_flag = ")

        else if (icase == 4) then

            call name("**gs")

            call initialize_shsgs(nlat, nlon, wavetable, error_flag)
            call name("shsi")
            call iout(error_flag, "error_flag = ")

            call divgs(nlat, nlon, isym, nt, dv, nlat, nlon, br, bi, mdb, nlat, &
                wavetable, error_flag)
            call name("div ")
            call iout(error_flag, "error_flag = ")

        end if

        err2 = ZERO
        do k=1, nt
            do j=1, nlon
                phi = real(j - 1, kind=wp) * dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    select case (icase)
                        case (0:2)
                            theta = real(i - 1, kind=wp) * dlat
                        case default
                            theta = gaussian_latitudes(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    dxdt = cost*cosp
                    d2xdt2 = -sint*cosp
                    dxdp = -sint*sinp
                    d2xdp2 = -sint*cosp
                    dydt = cost*sinp
                    d2ydt2 = -sint*sinp
                    dydp = sint*cosp
                    d2ydp2 = -sint*sinp
                    dzdt = -sint
                    d2zdt2 = -cost
                    dzdp = ZERO
                    d2zdp2 = ZERO
                    if (k==1) then
                        sf = x*y
                        dvdt = x*d2ydt2 + TWO * dxdt*dydt + y*d2xdt2
                        dve = dvdt + cost*(cosp*dydt+sinp*dxdt) - 4.*cosp*sinp
                    else if (k==2) then
                        !              sf = x*z
                        dve = -SIX * sint*cost*cosp
                    else if (k==3) then
                        !              sf = y*z
                        dve = -SIX * cost*sint*sinp
                    end if
                    err2 = err2 + (dv(i, j, k)-dve)**2
                end do
            end do
        end do
        !
        !     set and print least squares error in dv
        !
        err2 = sqrt(err2/(nt*nlat*nlon))
        call vout(err2, "err2")

        !     now recompute (v, w) inverting dv using idiv(ec, es, gc, gs)
        v = ZERO
        w = ZERO

        if (icase==1) then

            call name("**ec")

            call initialize_shaec(nlat, nlon, wavetable, error_flag)
            call name("shai")
            call iout(error_flag, "error_flag = ")

            call shaec(nlat, nlon, isym, nt, dv, nlat, nlon, a, b, &
                mdab, nlat, wavetable, error_flag)
            call name("sha ")
            call iout(error_flag, "error_flag = ")

            call initialize_vhsec(nlat, nlon, wavetable, error_flag)
            call name("idvi")
            call iout(error_flag, "error_flag = ")

            call idivec(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, &
                mdab, nlat, wavetable, pertrb, error_flag)
            call name("idiv")
            call iout(error_flag, "error_flag = ")
            call vecout(pertrb, "prtb", nt)

        else if (icase==2) then

            call name("**es")

            call initialize_shaes(nlat, nlon, wavetable, error_flag)
            call name("shai")
            call iout(error_flag, "error_flag = ")

            call shaes(nlat, nlon, isym, nt, dv, nlat, nlon, a, b, &
                mdab, nlat, wavetable, error_flag)
            call name("sha ")
            call iout(error_flag, "error_flag = ")

            call initialize_vhses(nlat, nlon, wavetable, error_flag)
            call name("idvi")
            call iout(error_flag, "error_flag = ")

            call idives(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, &
                mdab, nlat, wavetable, pertrb, error_flag)
            call name("idiv")
            call iout(error_flag, "error_flag = ")
            call vecout(pertrb, "prtb", nt)

        else if (icase==3) then

            call name("**gc")

            call initialize_shagc(nlat, nlon, wavetable, error_flag)
            call name("shai")
            call iout(error_flag, "error_flag = ")

            call shagc(nlat, nlon, isym, nt, dv, nlat, nlon, a, b, &
                mdab, nlat, wavetable, error_flag)
            call name("sha ")
            call iout(error_flag, "error_flag = ")

            call initialize_vhsgc(nlat, nlon, wavetable, error_flag)
            call name("idvi")
            call iout(error_flag, "error_flag = ")

            call idivgc(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, &
                mdab, nlat, wavetable, pertrb, error_flag)
            call name("idiv")
            call iout(error_flag, "error_flag = ")
            call vecout(pertrb, "prtb", nt)

        else if (icase==4) then

            call name("**gs")

            call initialize_shags(nlat, nlon, wavetable, error_flag)
            call name("shai")
            call iout(error_flag, "error_flag = ")

            call shags(nlat, nlon, isym, nt, dv, nlat, nlon, a, b, &
                mdab, nlat, wavetable, error_flag)
            call name("sha ")
            call iout(error_flag, "error_flag = ")

            call initialize_vhsgs(nlat, nlon, wavetable, error_flag)
            call name("idvi")
            call iout(error_flag, "error_flag = ")

            call idivgs(nlat, nlon, isym, nt, v, w, nlat, nlon, a, b, &
                mdab, nlat, wavetable, pertrb, error_flag)
            call name("idiv")
            call iout(error_flag, "error_flag = ")
            call vecout(pertrb, "prtb", nt)

        end if

        !     compare this v, w with original
        err2v = ZERO
        err2w = ZERO
        do k=1, nt
            do j=1, nlon
                phi = real(j - 1, kind=wp) * dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    select case (icase)
                        case (0:2)
                            theta = real(i - 1, kind=wp) * dlat
                        case default
                            theta = gaussian_latitudes(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    dxdt = cost*cosp
                    dxdp = -sint*sinp
                    dydt = cost*sinp
                    dydp = sint*cosp
                    dzdt = -sint
                    dzdp = ZERO
                    if (k==1) then
                        sf = x*y
                        dsfdt = x*dydt+y*dxdt
                        dsfdp = x*dydp+y*dxdp
                        ve = dsfdt
                        we = cosp*dydp+sinp*dxdp
                    else if (k==2) then
                        sf = x*z
                        dsfdt = x*dzdt+z*dxdt
                        dsfdp = x*dzdp+z*dxdp
                        ve = dsfdt
                        we = -cost*sinp
                    else if (k==3) then
                        sf = y*z
                        dsfdt = y*dzdt+z*dydt
                        dsfdp = y*dzdp+z*dydp
                        ve = dsfdt
                        we = z*cosp
                    else if (k==4) then
                    end if
                    err2v = err2v + (v(i, j, k)-ve)**2
                    err2w = err2w + (w(i, j, k)-we)**2
                end do
            end do
        end do
        err2v = sqrt(err2v/(nlat*nlon*nt))
        err2w = sqrt(err2w/(nlat*nlon*nt))
        call vout(err2v, "errv")
        call vout(err2w, "errw")
    end do

    ! Release memory
    deallocate (wavetable)

end program tdiv


subroutine ff_parallelepiped(q, a, b, L, N, ff, M)
    !***************************************************************************
    !Subroutine to calculate the form factor of parallelepiped
    !q = Array of reciprocal wave-vectors at which the form-factor needs to be calculated
    !a = 1st dimension of the cross-section in Angstroms
    !b = 2nd dimension of the cross-section in Angstroms
    !L = length of the parallelepiped in Angstroms
    !M = No. of reciprocal wave-vectors at which the form-factor needs to be calculated
    !N = No. of points at which the discrete angular integration will be done
    !***************************************************************************
    integer :: M, i, j
    double precision, intent(in) :: q(0:M-1)
    double precision, intent(out) :: ff(0:M-1)
    double precision, intent(in) :: a
    double precision, intent(in) :: b
    double precision, intent(in) :: L
    integer, intent(in):: N
    double precision :: phi, psi
    double precision, parameter :: pi=3.14157d0
    double precision :: aa, bb, ll

    do i = 0,M
        ff(i) = 0.0d0
        do j = 1, N
            phi = j * 2 * pi / N
            do k = 1, N
                psi = k * pi / N
                aa = q(i) * a * dsin(phi) * dcos(psi / 2.0d0)
                bb = q(i) * b * dsin(phi) * dsin(psi / 2.0d0)
                ll = q(i) * L * dcos(phi / 2.0d0)
                ff(i)=ff(i) + (dsin(aa) * dsin(bb) * dsin(ll))**2 / (aa * bb * ll)**2
            end do
        enddo
        ff(i) = (a*b*L)**2 * ff(i) * pi / N**2 / 4
    enddo

end subroutine ff_parallelepiped


module density_matrix

   use data_struct

   private
   public :: thermal_Mrho, thermal_rho

contains

   function thermal_Mrho( N, M, c, q, beta ) result( res )

      ! Input:
      !
      !  N - number of particles
      !  M - magnetization
      !  c - parameter multiplying J^2 term
      !  q - parameter multiplying (N+ + N-)
      !  H = c*J^2 + q*(N_{+} + N_{-})
      !  beta - temperature
      !
      ! Output:
      !
      !  res - Mrho data type

      !     res%eigval(i) - exp( -beta * e(i) )/Z
      !     eigenvalues are stored in ascending order
      !     res%eigvec - matrix with eigenvectors (column wise)

      implicit none
      integer, intent(in) :: N, M
      double precision, intent(in) :: c, q, beta
      type( Mrho ) :: res

      ! local variables
      double precision Zstat, E0
      ! for lapack routine
      double precision, allocatable ::  e(:), work(:)
      integer ldz, nn, info
      character*1 compz

      ! for constrution of the Hamiltonian
      integer kmin, kmax, k, i

      ! -----------------------------------------
      ! ----- Construct Hamiltonian matrix ------
      ! -----------------------------------------

      ! Even magnetization case

      if( modulo(M, 2) .eq. 0 ) then

         call EvenBounds( N, M, kmin, kmax )

         ! size of the matrix
         nn = (kmax - kmin + 1)

         ! allocate resources
         if( allocated( res%eigval) ) then
           deallocate( res%eigval )
           allocate( res%eigval(nn) )
         else
           allocate( res%eigval(nn) )
         endif

         if( allocated( e ) ) then
            deallocate(e)
            allocate( e(nn-1) )
         else
            allocate( e(nn-1) )
         endif

         do k=kmin, kmax

            ! array index
            i = k - kmin + 1

            ! diagonal part
            res%eigval(i) = &

                   c * 1.d0/( 2.d0*dble(N) )*( dble(N) + dble(M)**2 + &
                       ( dble(N) - 2.d0*dble(k) )*( 2.d0*dble(N) + 1.d0 - &
                       2.d0*( dble(N) - 2.d0*dble(k) ) ) ) + &
                   q * (2.d0 * dble(k) - dble(N))
                   !q * (2.d0 * dble(k))

            ! offdiagonal part
            if( k < kmax )  then

               e(i) = c * 1.d0/dble(N)*SQRT( ( dble(k) + 1.d0 + dble(M)/2.d0 )*&
                          ( dble(k) + 1.d0 - dble(M)/2.d0 )*( dble(N) - 2.d0*dble(k) )*&
                          ( dble(N) - 2.d0*dble(k) - 1.d0 ) )

            endif

         enddo

      ! Odd magnetization
      else

         call OddBounds( N, M, kmin, kmax )

         ! number of nonzero elements
         nn  = (kmax-kmin+1)

         ! allocate resources
         if( allocated( res%eigval) ) then
           deallocate( res%eigval )
           allocate( res%eigval(nn) )
         else
           allocate( res%eigval(nn) )
         endif

         if( allocated( e ) ) then
            deallocate(e)
            allocate( e(nn-1) )
         else
            allocate( e(nn-1) )
         endif

         do k=kmin, kmax

            ! array index
            i = k - kmin + 1

            ! diagonal part
            res%eigval(i) = &

                   c * 1.d0/( 2.d0*dble(N) )*( dble(N) + dble(M)**2 + &
                       ( dble(N) - 2.d0*dble(k) - 1.d0 )*( 2.d0*dble(N) + 1.d0 - &
                       2.d0*( real(N) - 2.d0*dble(k) - 1.d0 ) ) ) + &
                   q * (2.d0*dble(k) + 1.d0 - dble(N))
                   !q * (2.d0*dble(k))

            ! off-diagonal terms
            if( k < kmax ) then

               e(i) = c * 1.d0/dble(N)*SQRT( ( dble(k) + 1.5d0 + dble(M)/2.d0 )*&
                          ( dble(k) + 1.5d0 - dble(M)/2.d0 )*( dble(N) - 2.d0*dble(k) - 1.d0 )*&
                          ( dble(N) - 2.d0*dble(k) - 2.d0 ) )

            endif

         enddo

      endif

      ! ------------------------------------------
      ! --- Diagonalization of the Hamiltonian ---
      ! ------------------------------------------

      compz = 'I'
      ldz   = nn

      ! allocate workspace
      if( allocated( res%eigvec ) ) then
         deallocate( res%eigvec )
         allocate( res%eigvec(nn,nn) )
      else
         allocate( res%eigvec(nn,nn) )
      endif

      if( allocated( work ) ) then
         deallocate( work )
         allocate( work(2*nn-2) )
      else
         allocate( work(2*nn-2) )
      endif

      call DSTEQR( compz, nn, res%eigval, e, res%eigvec, ldz, work, info )

      if( info .ne. 0 ) then
         if( info < 0 ) then
            write(*,'(A,I2.2,A)') 'the ', abs(info), '-th parameter has an illegeal value'
         else
            write(*,'(A,I8.8,A,I8.8,A)')  'the algorithm failed to find all eigenvalues after ' &
               , 30*nn, ' iterations: ', info, ' off-diagonal elements have not converged to zero'
         endif
      endif

      ! return thermal probabilities
      ! avoids overflow exception
      ! floating-point underflow replaced by 0
      E0 = MINVAL( res%eigval )
      Zstat = 0.0d0
      do i = 1, nn
         Zstat = Zstat + EXP( -beta * ( res%eigval(i) - E0 ) )
      enddo

      do i = 1, nn
         res%eigval(i) = EXP( -beta * ( res%eigval(i) - E0 ) )/Zstat
      enddo

   end function

   function thermal_rho( N, mu, sigma, c, q, beta ) result(res)

   ! INPUT:
   !
   !     N    - number of particles
   !     Mbar - center of magnetization
   !     sigma - dispersion of magnetization
   !     c - parameter of the Hamiltonian J^2
   !     q - parameter of the Hamiltonian N_0
   !     beta = 1/(k_B T)
   !
   ! OUTPUT:
   !
   !     array of data type( Mrho )

      implicit none
      integer, intent(in) :: N
      real( kind = dp ) :: mu, sigma
      double precision, intent(in) :: c, q, beta
      type( rho ) :: res

      ! local variables
      real( kind = dp ) :: norm
      integer M
      ! for lapack routine
      double precision, allocatable ::  e(:), work(:)
      integer ldz, nn, info
      character*1 compz

      ! for constrution of the Hamiltonian
      integer kmin, kmax, k, i, midx

      if( allocated(res%array) ) then
         deallocate( res%array )
         allocate( res%array(0:N) )
      else
         allocate( res%array(0:N) )
      endif

      ! ------------------------------------------------
      !            Loop over magnetizations
      ! ------------------------------------------------
      ! parallel with OpenMP

      ! $OMP PARALLEL DO
      do M = 0, N
         res%array(M) = thermal_Mrho( N, M, c, q, beta )
      enddo
      ! $OMP END PARALLEL DO

      ! -------------------------------------
      ! Gaussian weights for magentization
      ! subspaces M = -N, ..., 0. ,,, N
      ! -------------------------------------
      if( allocated( res%weights) ) then
         deallocate( res%weights )
         allocate( res%weights(-N:N) )
      else
         allocate( res%weights(-N:N) )
      endif

      ! normalized weights
      norm = 0.0_dp
      do M = -N, N
         res%weights(M) = EXP( -0.5_dp * ( (real(M,dp)- mu)/sigma )**2 )
         norm = norm + res%weights(M)
      enddo

      do M = -N, N
         res%weights(M) = res%weights(M)/norm
      enddo

   end function

end module


! Objetivo: Reproduzir o grafico da funcao de Bessel e Neumann de Ordem inteira.

PROGRAM func_bessel_neumann
	USE nrtype
	USE nr, ONLY: bessj0,bessj1,bessj,bessy0,bessy1,bessy
	IMPLICIT none
	INTEGER :: cont_pontos
	INTEGER, PARAMETER :: pontos=1000,saida_bess=9, saida_neum=8
	REAL :: x,bessel_ordem0,bessel_ordem1,bessel_ordem2,bessel_ordem3
	REAL :: neumann_ordem0,neumann_ordem1,neumann_ordem2
	REAL, PARAMETER :: x_inicial=0.0,x_final=10.0
	REAL, PARAMETER :: dx=(x_final-x_inicial)/real(pontos-1)

	OPEN(unit=saida_bess,file="bessel.dat")
	OPEN(unit=saida_neum,file="neumann.dat")
! Calculando os valores das funcoes de Bessel de ordem 0, 1, 2 e 3
! Calculando os valores das funcoes de Neumann de ordem 0, 1 e 2 para x > 0.
	x=x_inicial
   bessel_ordem0=bessj0(x)
	bessel_ordem1=bessj1(x)
	bessel_ordem2=bessj(2,x)
	bessel_ordem3=bessj(3,x)
	WRITE(unit=saida_bess,fmt=*) x,bessel_ordem0,bessel_ordem1,&
					bessel_ordem2,bessel_ordem3
	DO cont_pontos=1,pontos
		x=x+dx
		bessel_ordem0=bessj0(x)
		bessel_ordem1=bessj1(x)
		bessel_ordem2=bessj(2,x)
		bessel_ordem3=bessj(3,x)
		WRITE(unit=saida_bess,fmt=*) x,bessel_ordem0,bessel_ordem1,&
					bessel_ordem2,bessel_ordem3
		neumann_ordem0=bessy0(x)
		neumann_ordem1=bessy1(x)
		neumann_ordem2=bessy(2,x)
		WRITE(unit=saida_neum,fmt=*) x,neumann_ordem0,neumann_ordem1,&
							neumann_ordem2
	END DO
END PROGRAM func_bessel_neumann


program sistu_ppal

use datasissim_interface
use lu_interface
use sistu_interface
use sistl_interface

implicit none

real, dimension(:,:), allocatable :: a
real, dimension(:), allocatable :: b
real, dimension(:), allocatable :: u
real, dimension(:), allocatable :: w

real :: deter

integer :: n, i, j

print*
print*, 'Introduce o orde do sistema: '
read*, n
print*

print*
print*, 'O orde introduce e: ', n
print*

allocate(a(n,n), b(n), u(n), w(n))

call datasissim(a, b)

call chol(a, deter)

call sistl(a,b,w)
call sistu(a,w,u)

print*,
print*, 'Vector u (solucion): '
print*,

print*,
print*, u
print*,

if (allocated(a)) deallocate(a)

if (allocated(b)) deallocate(b)

if (allocated(u)) deallocate(u)

end program


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine rotationvectorinv(c,v)
!
!     calculates rotation matrix from rotation vector
!
      implicit none
!
      real*8 c(3,3),v(3),theta,ds,dc
!
      intent(in) v
!
      intent(out) c
!
      theta=dsqrt(v(1)*v(1)+v(2)*v(2)+v(3)*v(3))
!
      if (theta.eq.0.d0) then
            c(1,1)=1.d0
            c(1,2)=0.d0
            c(1,3)=0.d0
            c(2,1)=0.d0
            c(2,2)=1.d0
            c(2,3)=0.d0
            c(3,1)=0.d0
            c(3,2)=0.d0
            c(3,3)=1.d0
      else
!
            dc=dcos(theta)
            ds=dsin(theta)
!
!     C-matrix from Guido Dhondt, The Finite Element
!     Method for Three-Dimensional Thermomechanical
!     Applications p 158
!
            c(1,1)=dc+(1.d0-dc)*v(1)*v(1)/(theta*theta)
            c(1,2)=   (1.d0-dc)*v(1)*v(2)/(theta*theta)-ds*v(3)/theta
            c(1,3)=   (1.d0-dc)*v(1)*v(3)/(theta*theta)+ds*v(2)/theta
            c(2,1)=   (1.d0-dc)*v(2)*v(1)/(theta*theta)+ds*v(3)/theta
            c(2,2)=dc+(1.d0-dc)*v(2)*v(2)/(theta*theta)
            c(2,3)=   (1.d0-dc)*v(2)*v(3)/(theta*theta)-ds*v(1)/theta
            c(3,1)=   (1.d0-dc)*v(3)*v(1)/(theta*theta)-ds*v(2)/theta
            c(3,2)=   (1.d0-dc)*v(3)*v(2)/(theta*theta)+ds*v(1)/theta
            c(3,3)=dc+(1.d0-dc)*v(3)*v(3)/(theta*theta)
      endif
!
      return
!
      end


C
C     PROGRAM TO DISPLAY EMIRPS
C
C     *** TEST IF A NUMBER IS PRIME ***
      LOGICAL FUNCTION PRIME(N)
      INTEGER N
C     DEAL WITH NUMBERS <= 3
      IF (N .LE. 1) GOTO 200
      IF (N .EQ. 2 .OR. N .EQ. 3) GOTO 100
C     CHECK IF DIVISIBLE BY 2 OR 3
      IF (MOD(N,2) .EQ. 0) GOTO 200
      IF (MOD(N,3) .EQ. 0) GOTO 200
C     SEE IF DIVISIBLE BY 5, 7, ..., UP TO APPROX SQRT(N)
 10   DO 20 I=5,999999,2
         IF (I*I .GT. N) GOTO 100
         IF (MOD(N,I) .EQ. 0) GOTO 200
 20   CONTINUE
 100  PRIME = .TRUE.
      RETURN
 200  PRIME = .FALSE.
      RETURN
      END
C
C     *** REVERSE AN INTEGER'S DIGITS ***
      INTEGER FUNCTION REVRSE(N)
      INTEGER N
      INTEGER M,R
C     M IS COPY OF N FROM WHICH WE TAKE DIGITS
C     R IS REVERSED DIGITS
      M = N
      R = 0
C     LOOP UNTIL NO MORE DIGITS
 10   IF (M .LT. 1) GOTO 100
C     TAKE LAST DIGIT FROM M AND APPEND TO R
      R = R * 10
      R = R + MOD(M, 10)
      M = M / 10
      GOTO 10
 100  REVRSE = R
      RETURN
      END
C
C     *** TEST IF AN INTEGER IS AN EMIRP ***
      LOGICAL FUNCTION EMIRP(N)
      INTEGER N
C     EXTERNAL FUNCTIONS
      INTEGER REVRSE
      LOGICAL PRIME
C     R CONTAINS REVERSED DIGITS OF N
      INTEGER R
      R = REVRSE(N)
C     N AND R MUST BOTH BE PRIME AND NOT THE SAME VALUE
      IF (N .EQ. R) GOTO 200
      IF (.NOT. PRIME(N)) GOTO 200
      IF (.NOT. PRIME(R)) GOTO 200
 100  EMIRP = .TRUE.
      RETURN
 200  EMIRP = .FALSE.
      RETURN
      END
C
C     *** DISPLAY AN INTEGER ***
      SUBROUTINE SHOW(N)
      INTEGER N
      WRITE(6,50) N
 50   FORMAT(I10)
      RETURN
      END
C
C     *** SHOW FIRST 20 EMIRPS ***
      SUBROUTINE TEST1
C     EXTERNAL FUNCTION
      LOGICAL EMIRP
C     I IS COUNT OF EMIRPS FOUND
C     N IS NUMBER TO TEST
      INTEGER I,N
      N = 0
      DO 100 I=1,20
 10      N = N + 1
         IF (.NOT. EMIRP(N)) GOTO 10
         CALL SHOW(N)
 100  CONTINUE
      RETURN
      END
C
C     *** SHOW EMIRPS BETWEEN 7,700 AND 8,000 ***
      SUBROUTINE TEST2
C     EXTERNAL FUNCTION
      LOGICAL EMIRP
C     N IS NUMBER TO TEST
      INTEGER N
 10   DO 100 N=7700,8000
         IF (EMIRP(N)) CALL SHOW(N)
 100  CONTINUE
      RETURN
      END
C
C     *** SHOW 10,000TH EMIRP ***
      SUBROUTINE TEST3
C     EXTERNAL FUNCTION
      LOGICAL EMIRP
C     I IS COUNT OF EMIRPS FOUND
C     N IS NUMBER TO TEST
      INTEGER I,N
      N = 0
      DO 100 I=1,10000
 10      N = N + 1
         IF (.NOT. EMIRP(N)) GOTO 10
 100  CONTINUE
      CALL SHOW(N)
      RETURN
      END
C
C     *** MAIN ENTRY POINT ***
      CALL TEST1
      CALL TEST2
      CALL TEST3
      STOP
      END


      SUBROUTINE MF_QUARTC
     &          (b4,four b3,six b2,four b1,one b0,q)

c     Solution for the roots of a fourth-order polynomial (quartic
c     equation) taken from Burnside and Panton (1904), The Theory of
c     Equations.  A summary of pertinent equations is given in Radio
c     Science Vol. 3, Aug. 1968, pp.792-795.

      character*200 error_msg
      real          mag pos,mag neg
      complex       b4,four b3,six b2,four b1,one b0,q,
     &              h,i,g,h prime,g prime,
     &              sq root,p pos,p,log p,cub rt0,cub rt1,cub rt2,
     &              omega1,omega2,root p,root q,root r,twlv b3,twlv b2,
     &              f,dfdq,del q,fb4
      complex  * 16 b3,b2,b1,b0,b3 sq

      dimension     p ri(2),q(4)

      equivalence  (p ri(1),p)

      data          omega1/(-0.5, 0.8660254038)/,
     &              omega2/(-0.5,-0.8660254038)/

      b3=four b3/(4.*b4)
      b2=six b2/(6.*b4)
      b1=four b1/(4.*b4)
      b0=one b0/b4

      b3 sq=b3**2
      h=b2-b3 sq
      i=b0-4.*b3*b1+3.*b2**2
      g=b1+b3*(-3.*b2+2.*b3 sq)
      h prime=-i/12.
      g prime=-g**2*.25-h*(h**2+3.*h prime)

      sq root=SQRT(g prime**2+4.*h prime**3)
      p=(-g prime+sq root)*0.5
      mag pos=ABS(p ri(1))+ABS(p ri(2))
      p pos=p
      p=(-g prime-sq root)*0.5
      mag neg=ABS(p ri(1))+ABS(p ri(2))
      if (mag pos .gt. mag neg) p=p pos
      log p=LOG(p)
      cub rt0=EXP(log p/3.)
      cub rt1=omega1*cub rt0
      cub rt2=omega2*cub rt0

      root p=SQRT(cub rt0-h prime/cub rt0-h)
      root q=SQRT(cub rt1-h prime/cub rt1-h)
      root r=SQRT(cub rt2-h prime/cub rt2-h)
      if (ABS(g) .ge. 1.e-20) then
         sign=-root p*root q*root r*2./g
         if (sign .lt. 0.) root r=-root r
      end if
      q(1)=+root p+root q+root r-b3
      q(2)=+root p-root q-root r-b3
      q(3)=-root p+root q-root r-b3
      q(4)=-root p-root q+root r-b3

c     Newton-Raphson (first order) iterative improvement.
      fb4=4.*b4
      twlv b3=3.*four b3
      twlv b2=2.*six b2
      do j=1,4
         dlqmin=9.9e9
         do jj=1,4
            if (jj .ne. j) then
               dlq=ABS(q(j)-q(jj))
               if (dlq .lt. dlqmin) dlqmin=dlq
             end if
         end do
         dlqmax=dlqmin/3.

         last=0
         ncount=1
         do while (last .eq. 0 .and. ncount .le. 10)
            f=(((b4*q(j)+four b3)*q(j)+six b2)*q(j)+four b1)*q(j)+one b0
            dfdq=((fb4*q(j)+twlv b3)*q(j)+twlv b2)*q(j)+four b1
            del q=-f/dfdq
            if (ABS(delq) .gt. dlqmax) delq=delq*dlqmax/ABS(delq)
            q(j)=q(j)+del q
            if (ABS(del q/q(j)) .lt. 1.e-4) last=1
            ncount=ncount+1
         end do
         if (ABS(del q/q(j)) .gt. 1.e-2) then
             write(error_msg,
     &           '(''[MF_QUARTC]: q='',4(1pe13.3,e11.3))') q
             call LWPC_ERROR ('WARNING',error_msg)
             write(error_msg,
     &            '(''[MF_QUARTC]: q fails to converge'')')
             call LWPC_ERROR ('ERROR',error_msg)
         end if
      end do
      RETURN
      END      ! MF_QUARTC