      PROGRAM EITEST
C------------------------------------------------------------------
C FORTRAN 77 program to test EI, EONE, and EXPEI.
C
C  Method:
C
C     Accuracy test compare function values against local Taylor's
C     series expansions.  Derivatives for Ei(x) are generated from
C     the recurrence relation using a technique due to Gautschi
C     (see references).  Special argument tests are run with the
C     related functions E1(x) and exp(-x)Ei(x).
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - An environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C              IBETA  - The radix of the floating-point system
C              IT     - The number of base-ibeta digits in the
C                       significant of a floating-point number
C              XMAX   - The largest finite floating-point number
C
C     REN(K) - A function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C      ABS, AINT, DBLE, LOG, MAX, REAL, SQRT
C
C  References: "The use of Taylor series to test accuracy of
C               function programs", Cody, W. J., and Stoltz, L.,
C               submitted for publication.
C
C              "Recursive computation of certain derivatives -
C               A study of error propagation", Gautschi, W., and
C               Klein, B. J., Comm. ACM 13 (1970), 7-9.
C
C              "Remark on Algorithm 282", Gautschi, W., and Klein,
C               B. J., Comm. ACM 13 (1970), 53-54.
C
C  Latest modification: March 9, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C------------------------------------------------------------------
      INTEGER I,IBETA,IEXP,IOUT,IRND,IT,J,JT,K,K1,K2,K3,
     1        MACHEP,MAXEXP,MINEXP,N,NEGEP,NGRD,N1
CS    REAL
      DOUBLE PRECISION
     1    A,AIT,ALBETA,B,BETA,CONV,C1,D,DEL,DX,EN,EI,EONE,EPS,EPSNEG,
     2    EXPEI,FIV12,FOUR,FOURTH,ONE,P0625,REM,REN,R6,R7,SIX,SUM,
     3    TEN,TWO,U,V,W,X,XBIG,XC,XDEN,XL,XLGE,XMAX,XMIN,XN,XNP1,
     4    XNUM,X0,X99,Y,Z,ZERO
      DIMENSION D(0:25)
C------------------------------------------------------------------
CS    DATA ZERO,FOURTH,ONE,FOUR,SIX/0.0E0,0.25E0,1.0E0,4.0E0,6.0E0/,
CS   1     TEN,X0,X99,P0625/10.0E0,0.3725E0,-999.0E0,0.0625E0/,
CS   2     FIV12,REM/512.0E0,-7.424779065800051695596E-5/
      DATA ZERO,FOURTH,ONE,FOUR,SIX/0.0D0,0.25D0,1.0D0,4.0D0,6.0D0/,
     1     TEN,X0,X99,P0625/10.0D0,0.3725D0,-999.0D0,0.0625D0/,
     2     FIV12,REM/512.0D0,-7.424779065800051695596D-5/
      DATA IOUT/6/
C------------------------------------------------------------------
C  Statement functions for conversion
C------------------------------------------------------------------
CS    CONV(I) = REAL(I)
      CONV(I) = DBLE(I)
C------------------------------------------------------------------
C  Determine machine parameters and set constants
C------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      DX = -P0625
      A = FOURTH + DX
      B = X0 + DX
      N = 2000
      N1 = 25
      XN = CONV(N)
      JT = 0
C-----------------------------------------------------------------
C  Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 8
         K1 = 0
         K3 = 0
         XC = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / XN
         XL = A
         DO 200 I = 1, N
            Y = DEL * REN(JT) + XL
            X = Y - DX
            Y = X + DX
C-----------------------------------------------------------------
C  Test Ei against series expansion
C-----------------------------------------------------------------
            V = EI(X)
            Z = EI(Y)
            SUM = ZERO
            U = X
            CALL DSUBN(U,N1,XMAX,D)
            EN = CONV(N1)+ONE
            SUM = D(N1)*DX/EN
            DO 100 K = N1,1,-1
               EN = EN-ONE
               SUM = (SUM + D(K-1))*DX/EN
  100       CONTINUE
            U = V + SUM
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = Z - U
            W = W / Z
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  XC = Y
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C------------------------------------------------------------------
C  Gather and print statistics for test
C------------------------------------------------------------------
         K2 = N - K3 - K1
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1
         WRITE (IOUT,1015) K2,K3
         WRITE (IOUT,1020) IT,IBETA
         IF (R6 .NE. ZERO) THEN
               W = LOG(ABS(R6))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1021) R6,IBETA,W,XC
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         IF (R7 .NE. ZERO) THEN
               W = LOG(ABS(R7))/ALBETA
            ELSE
               W = X99
         END IF
         WRITE (IOUT,1023) R7,IBETA,W
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C------------------------------------------------------------------
C  Initialize for next test
C------------------------------------------------------------------
         IF (J .EQ. 1) THEN
               DX = -DX
               A = X0 + DX
               B = SIX
            ELSE IF (J .LE. 4) THEN
               A = B
               B = B+B
            ELSE IF (J .EQ. 5) THEN
               A = -FOURTH
               B = -ONE
            ELSE IF (J .EQ. 6) THEN
               A = B
               B = -FOUR
            ELSE
               A = B
               B = -TEN
         END IF
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests.  First, check accuracy near the zero of Ei(x)
C-----------------------------------------------------------------
      WRITE (IOUT,1040)
      X = (FOUR - ONE) / (FOUR + FOUR)
      Y = EI(X)
      WRITE (IOUT,1041) X,Y
      Z = ((Y - (FOUR+ONE)/(FIV12)) - REM)/Y
      IF (Z .NE. ZERO) THEN
            W = LOG(ABS(Z))/ALBETA
         ELSE
            W = X99
      END IF
      WRITE (IOUT,1042) Z,IBETA,W
      W = MAX(AIT+W,ZERO)
      WRITE (IOUT,1022) IBETA,W
C-----------------------------------------------------------------
C  Check near XBIG, the largest argument acceptable to EONE, i.e.,
C    the negative of the smallest argument acceptable to EI.
C    Determine XBIG with Newton iteration on the equation
C                  EONE(x) = XMIN.
C---------------------------------------------------------------------
      WRITE (IOUT,1050)
      TWO = ONE+ONE
      V = SQRT(EPS)
      C1 = CONV(MINEXP) * LOG(BETA)
      XN = -C1
  320 XNUM = -XN - LOG(XN) + LOG(ONE+ONE/XN) - C1
      XDEN = -(XN*XN+XN+XN+TWO) / (XN*(XN+ONE))
      XNP1 = XN - XNUM/XDEN
      W = (XN-XNP1)/XNP1
      IF (ABS(W) .GT. V) THEN
         XN = XNP1
         GO TO 320
      END IF
      XBIG = XNP1
      X = AINT(TEN*XBIG) / TEN
      WRITE (IOUT,1052) X
      Y = EONE(X)
      WRITE (IOUT,1062) Y
      X = XBIG * (ONE+V)
      WRITE (IOUT,1053) X
      Y = EONE(X)
      WRITE (IOUT,1062) Y
C---------------------------------------------------------------------
C  Check near XMAX, the largest argument acceptable to EI.  Determine
C    XLGE with Newton iteration on the equation
C                  EI(x) = XMAX.
C---------------------------------------------------------------------
      C1 = CONV(MAXEXP) * LOG(BETA)
      XN = C1
  330 XNUM = XN - LOG(XN) + LOG(ONE+ONE/XN) - C1
      XDEN = (XN*XN-TWO) / (XN*(XN+ONE))
      XNP1 = XN - XNUM/XDEN
      W = (XN-XNP1)/XNP1
      IF (ABS(W) .GT. V) THEN
         XN = XNP1
         GO TO 330
      END IF
      XLGE = XNP1
      X = AINT(TEN*XLGE) / TEN
      WRITE (IOUT,1054) X
      Y = EI(X)
      WRITE (IOUT,1064) Y
      X = XLGE * (ONE+V)
      WRITE (IOUT,1055) X
      Y = EI(X)
      WRITE (IOUT,1064) Y
C---------------------------------------------------------------------
C  Check with XHUGE, the largest acceptable argument for EXPEI
C---------------------------------------------------------------------
      IF (XMIN*XMAX .LE. ONE) THEN
            X = XMAX
         ELSE
            X = ONE/XMIN
      END IF
      WRITE (IOUT,1056) X
      Y = EXPEI(X)
      WRITE (IOUT,1065) Y
      X = ZERO
      WRITE (IOUT,1055) X
      Y = EI(X)
      WRITE (IOUT,1064) Y
      WRITE (IOUT,1100)
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of Ei(x) vs series expansion'//)
 1010 FORMAT(I7,' Random arguments were tested from the interval (',
     1    F7.3,',',F7.3,')'//)
 1011 FORMAT('     EI(X) was larger',I6,' times,')
 1015 FORMAT(14X,' agreed',I6,' times, and'/
     1    10X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number'//)
 1021 FORMAT(' The maximum relative error of',E15.4E3,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6E3)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1040 FORMAT(//' Test of special arguments'//)
 1041 FORMAT('   EI (',E13.6E3,') = ',E13.6E3//)
 1042 FORMAT(' The relative error is',E15.4E3,' = ',I4,' **',F7.2/)
 1050 FORMAT(' Test of Error Returns'///)
 1052 FORMAT(' EONE will be called with the argument',E13.6E3,/
     1    ' This should not underflow'//)
 1053 FORMAT(' EONE will be called with the argument',E13.6E3,/
     1    ' This should underflow'//)
 1054 FORMAT(' EI will be called with the argument',E13.6E3,/
     1    ' This should not overflow'//)
 1055 FORMAT(' EI will be called with the argument',E13.6E3,/
     1    ' This should overflow'//)
 1056 FORMAT(' EXPEI will be called with the argument',E13.6E3,/
     1    ' This should not underflow'//)
 1062 FORMAT(' EONE returned the value',E13.6E3///)
 1064 FORMAT(' EI returned the value',E13.6E3///)
 1065 FORMAT(' EXPEI returned the value',E13.6E3///)
 1100 FORMAT(' This concludes the tests')
C---------- Last line of EI test program ----------
      END


!********************************************************
! Convolution module for applying the observing resolution
!********************************************************
module convol
use variables
use emerging
implicit none
contains

! ---------------------------------------------------------
! Returns the mean of a vector
! ---------------------------------------------------------
	function mean2(v)
	real(kind=8) :: mean2, v(:)
	integer :: n
		n = size(v)
		mean2 = sum(v) / n
	end function mean2

!-----------------------------------------------------------------
! This subroutine performs the FFT of a complex signal of size nn, given in
! the pseudo-complex form, taking 2*nn arrays
!-----------------------------------------------------------------
SUBROUTINE four1(data,nn,isign)
INTEGER isign,nn
REAL(kind=8) data(2*nn)
INTEGER i,istep,j,m,mmax,n
REAL(kind=8) tempi,tempr
DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      n=2*nn
      j=1
      do 11 i=1,n,2
        if(j.gt.i)then
          tempr=data(j)
          tempi=data(j+1)
          data(j)=data(i)
          data(j+1)=data(i+1)
          data(i)=tempr
          data(i+1)=tempi
        endif
        m=n/2
1       if ((m.ge.2).and.(j.gt.m)) then
          j=j-m
          m=m/2
        goto 1
        endif
        j=j+m
11    continue
      mmax=2
2     if (n.gt.mmax) then
        istep=2*mmax
        theta=6.28318530717959d0/(isign*mmax)
        wpr=-2.d0*sin(0.5d0*theta)**2
        wpi=sin(theta)
        wr=1.d0
        wi=0.d0
        do 13 m=1,mmax,2
          do 12 i=m,n,istep
            j=i+mmax
            tempr=sngl(wr)*data(j)-sngl(wi)*data(j+1)
            tempi=sngl(wr)*data(j+1)+sngl(wi)*data(j)
            data(j)=data(i)-tempr
            data(j+1)=data(i+1)-tempi
            data(i)=data(i)+tempr
            data(i+1)=data(i+1)+tempi
12        continue
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
13      continue
        mmax=istep
      goto 2
      endif
      return
      END subroutine four1

!-----------------------------------------------------------------
! This subroutine convolves the signal with the filter. The size of the filter has to
! be lower than the size of the signal
! The filter has to be given in wrap-around order
!-----------------------------------------------------------------
subroutine convolve(signal,filter)
real(kind=8), INTENT(INOUT) :: signal(:)
real(kind=8), INTENT(IN) :: filter(:)
real(kind=8), allocatable :: signal_complex(:), filter_complex(:), ans(:)
real(kind=8) :: filter_completo(size(signal)), a, b, c, d
integer :: m, n, n2, i

	n = size(signal)
	m = size(filter)
	n2 = 2*n

	allocate(signal_complex(n2))
	allocate(filter_complex(n2))
	allocate(ans(n2))

! Zero padding of the filter
	do i = 1, (m-1)/2
		filter_completo(i) = filter(i)
		filter_completo(n+1-i) = filter(m+1-i)
	enddo
	do i = (m+3)/2,n-(m-1)/2
		filter_completo(i) = 0.0
	enddo

! Put the filter in pseudo-complex format
	do i = 1, n
		filter_complex(2*(i-1)+1) = filter_completo(i)
	enddo

! Put the signal in pseudo-complex format
	do i = 1, n
		signal_complex(2*(i-1)+1) = signal(i)
	enddo

! FFT both the filter and the signal
	call four1(filter_complex,n,1)
	call four1(signal_complex,n,1)

! Do the complex multiplication
	do i = 1, n
		a = signal_complex(2*(i-1)+1)
		b = signal_complex(2*i)
		c = filter_complex(2*(i-1)+1)
		d = filter_complex(2*i)
		ans(2*(i-1)+1) = a*c - b*d
		ans(2*i) = a*d + b*c
	enddo

! Inverse FFT of the product
	call four1(ans,n,-1)

! In the inverse FFT, the result is multiplied by n
	ans = ans / n

! Get the real part
	do i = 1, n
		signal(i) = ans(2*(i-1)+1)
	enddo

	deallocate(signal_complex)
	deallocate(filter_complex)
	deallocate(ans)

end subroutine convolve

!-------------------------------------------------------------------
! Return the Stokes profiles convolved with the given filter
!-------------------------------------------------------------------
subroutine convolve_macroturbulence(dw,emerg,emerg_conv)
real(kind=8) :: dw(:), emerg(:), emerg_conv(:)
real(kind=8), allocatable :: filter(:), ans(:), padding(:)
real(kind=8) :: macro_hz, x, wave, step, macro_A
integer :: i, m, n, n2

		n = size(dw)
      wave = mean2(dw)
		macro_hz = instrum_sigma(3.d14 / wave)
      step = dw(2) - dw(1)
		m = 3 * macro_hz / step
		m = 2 * m + 1
		allocate(filter(m))

! Build the filter. It is a gaussian of sigma=macro_A, but it has to be built in
! the correct way in order to have a working convolution.
		macro_A = 1.d0  ! DANGER!!!!!!!!!!!!
		do i = 1, m/2+1
			x = (i-1.d0)*step / macro_A
			filter(i) = exp(-x**2)
		enddo

		do i = m/2+2, m
			filter(i) = filter(m-i+1)
		enddo

! Normalize the filter
		filter = filter / sum(filter)

! Find the nearest higher power of 2
		i = 1
     	do while (2.d0**i < n)
			i = i + 1
		enddo
     	n2=2.d0**i

		allocate(padding(n2))
		allocate(ans(2*n2))

		padding(1:n) = emerg(:)
		padding(n:n2) = padding(n)
		call convolve(padding,filter)
		emerg_conv(:) = padding(1:n)

		if (allocated(filter)) deallocate(filter)
		if (allocated(ans)) deallocate(ans)

end subroutine convolve_macroturbulence

end module convol


submodule(euler_interface_m) euler_prob_0043_m
    implicit none
    integer(int64) :: answer

contains

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

    integer(int64) function ans()
        integer(int64) :: test_arr(10)

        test_arr = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]
        call permute(10_int64, test_arr, 1_int64, 10_int64)
        ans = answer
    end function ans

    recursive subroutine permute(n, a, l, r)
        integer(int64), intent(in) :: n, l, r
        integer(int64), intent(inout) :: a(n)
        integer(int64) :: i, tmp

        if (l == r) then
            call arr_2_int(a, tmp)

            if (is_subinteger_divisible(tmp)) then
                answer = answer + tmp
            end if
            return
        else
            do i = l, r
                call swap(a(i), a(l))
                call permute(10_int64, a, l + 1_int64, r)
                call swap(a(i), a(l))
            end do
        end if
    end subroutine permute

    logical function is_subinteger_divisible(n)
        integer(int64), intent(in) :: n
        integer(int64) :: i, tmp, three_int, prime_arr(7)

        prime_arr = [17, 13, 11, 7, 5, 3, 2]
        tmp = n

        is_subinteger_divisible = .true.
        do i = 1, 7
            three_int = tmp - tmp/1000*1000
            if (mod(three_int, prime_arr(i)) /= 0) then
                is_subinteger_divisible = .false.
                return
            end if

            tmp = tmp/10
        end do
    end function is_subinteger_divisible

end submodule euler_prob_0043_m


module stdlib_bitsets_64
    implicit none

contains

    logical function all_set(x, num_bits) result(res)
        integer, intent(in) :: x
        integer, intent(in) :: num_bits

        logical, intrinsic :: btest
        integer :: pos

        res = .true.
        do pos = 0, num_bits - 1
            if ( .not. btest(x, pos) ) then
                res = .false.
            end if
        end do
    end function all_set
end module

program intrinsics_26
use stdlib_bitsets_64, only : all_set
implicit none

    integer :: i = 31
    print *, all_set(i, 5)

end program


*DECK IDAMAX
      INTEGER FUNCTION IDAMAX (N, DX, INCX)
C***BEGIN PROLOGUE  IDAMAX
C***PURPOSE  Find the smallest index of that component of a vector
C            having the maximum magnitude.
C***CATEGORY  D1A2
C***TYPE      DOUBLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, 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        N  number of elements in input vector(s)
C       DX  double precision vector with N elements
C     INCX  storage spacing between elements of DX
C
C     --Output--
C   IDAMAX  smallest index (zero if N .LE. 0)
C
C     Find smallest index of maximum magnitude of double precision DX.
C     IDAMAX = first I, I = 1 to N, to maximize ABS(DX(IX+(I-1)*INCX)),
C     where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX.
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   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900821  Modified to correct problem with a negative increment.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  IDAMAX
      DOUBLE PRECISION DX(*), DMAX, XMAG
      INTEGER I, INCX, IX, N
C***FIRST EXECUTABLE STATEMENT  IDAMAX
      IDAMAX = 0
      IF (N .LE. 0) RETURN
      IDAMAX = 1
      IF (N .EQ. 1) RETURN
C
      IF (INCX .EQ. 1) GOTO 20
C
C     Code for increments not equal to 1.
C
      IX = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      DMAX = ABS(DX(IX))
      IX = IX + INCX
      DO 10 I = 2,N
        XMAG = ABS(DX(IX))
        IF (XMAG .GT. DMAX) THEN
          IDAMAX = I
          DMAX = XMAG
        ENDIF
        IX = IX + INCX
   10 CONTINUE
      RETURN
C
C     Code for increments equal to 1.
C
   20 DMAX = ABS(DX(1))
      DO 30 I = 2,N
        XMAG = ABS(DX(I))
        IF (XMAG .GT. DMAX) THEN
          IDAMAX = I
          DMAX = XMAG
        ENDIF
   30 CONTINUE
      RETURN
      END


subroutine axpy(n, a, X, Y, Z)
use iso_fortran_env, only: real64
implicit none
integer :: n
real(real64) :: a
real(real64) :: X(*), Y(*), Z(*)
integer :: i

  do i = 1, n
    Z(i) = a * X(i) + Y(i)
  end do

end subroutine axpy

program axpyProg
use iso_fortran_env, only: real64
!use mpi

implicit none
include 'mpif.h'
real(real64) :: a_P
real(real64), allocatable :: X(:), Y(:), Z(:)
real(real64), allocatable :: X_P(:), Y_P(:), Z_P(:)
integer :: n, n_P
integer :: nProcs, procN, err

  n = 2**10

  call mpi_init(err)

  call mpi_comm_size(mpi_comm_world, nProcs, err)
  call mpi_comm_rank(mpi_comm_world, procN, err)

  if (procN == 0) then
    allocate(X(n))
    allocate(Y(n))
    allocate(Z(n))

    call random_seed
    call random_number(a_P)
    call random_number(X)
    call random_number(Y)
  end if

  n_P = n / nProcs

  allocate(X_P(n_P))
  allocate(Y_P(n_P))
  allocate(Z_P(n_P))

  call mpi_bcast(a_P, 1, mpi_double_precision, 0, mpi_comm_world, err)
  call mpi_scatter(X, n_P, mpi_double_precision, X_P, n_P, mpi_double_precision, 0, mpi_comm_world, err)
  call mpi_scatter(Y, n_P, mpi_double_precision, Y_P, n_P, mpi_double_precision, 0, mpi_comm_world, err)

  call axpy(n_P, a_P, X_P, Y_P, Z_P)

  deallocate(X_P)
  deallocate(Y_P)

  call mpi_gather(Z_P, n_P, mpi_double_precision, Z, n_P, mpi_double_precision, 0, mpi_comm_world, err)

  deallocate(Z_P)

  if (procN == 0) then
    print *, maxval(abs(Z)), maxval(abs(Z / (a_P * X + Y) - 1.0_real64))

    deallocate(X)
    deallocate(Y)
    deallocate(Z)
  end if

  call mpi_finalize(err)

end program axpyProg


!-----------------------------------------------------------------------
! Initialize state variables and cumulated diagnostics
!-----------------------------------------------------------------------
subroutine INITIALIZE

use CONSTANTS, only : &
  g,                 &! Acceleration due to gravity (m/s^2)
  Lf,                &! Latent heat of fusion (J/kg)
  rho_ice,           &! Density of ice (kg/m^3)
  rho_wat,           &! Density of water (kg/m^3)
  Tm                  ! Melting point (K)

use DIAGNOSTICS, only : &
  diags,             &! Cumulated diagnostics
  Nave,              &! Number of timesteps in average outputs
  SWint,             &! Cumulated incoming solar radiation (J/m^2)
  SWout               ! Cumulated reflected solar radiation (J/m^2)

use GRID, only : &
  Nsoil,             &! Number of soil layers
  Dzsoil              ! Soil layer thicknesses (m)

use IOUNITS, only : &
  uout                ! Output file unit number

use SOIL_PARAMS, only : &
  b,                 &! Clapp-Hornberger exponent
  sathh,             &! Saturated soil water pressure (m)
  Vsat                ! Soil moisture concentration at saturation

use STATE_VARIABLES, only : &
  albs,              &! Snow albedo
  Ds,                &! Snow layer thicknesses (m)
  Mf,                &! Frozen moisture content of soil layers (kg/m^2)
  Mu,                &! Unfrozen moisture content of soil layers (kg/m^2)
  Nsnow,             &! Number of snow layers
  Sice,              &! Ice content of snow layers (kg/m^2)
  Sliq,              &! Liquid content of snow layers (kg/m^2)
  snowdepth,         &! Snow depth (m)
  SWE,               &! Snow water equivalent (kg/m^2)
  Tsnow,             &! Snow layer temperatures (K)
  Tsoil,             &! Soil layer temperatures (K)
  Tsurf               ! Surface skin temperature (K)

implicit none

character(len=70) :: &
  out_file            ! Output file name

integer :: &
  k                   ! Level counter

real :: &
  dPsidT,            &! Rate of change of ice potential with temperature (m/K)
  sthf,              &! Frozen soil moisture concentration
  sthu,              &! Unfrozen soil moisure concentration
  Tmax                ! Maximum temperature for any frozen moisture (K)

real :: &
  fsat(Nsoil),       &! Initial moisture content of soil layers as fractions of saturation
  theta(Nsoil)        ! Total soil moisture concentration

namelist /initial/ fsat,Tsoil
namelist /outputs/ Nave,out_file

! Cumulated diagnostics
diags(:) = 0
SWint = 0
SWout = 0

! No snow in initial state
albs = 0.8
Ds(:) = 0
Nsnow = 0
Sice(:) = 0
Sliq(:) = 0
snowdepth = 0
SWE = 0
Tsnow(:) = Tm

! Initial soil profiles from namelist
fsat(:) = 0.5
Tsoil(:) = 285.
read(5,initial)
Tsurf = Tsoil(1)
dPsidT = - rho_ice*Lf/(rho_wat*g*Tm)
do k = 1, Nsoil
  theta(k) = fsat(k)*Vsat
  Tmax = 0
  if (theta(k) > epsilon(theta))  &
    Tmax = Tm + (sathh/dPsidT)*(Vsat/theta(k))**b
  if (Tsoil(k) > Tmax) then
    sthu = theta(k)
    sthf = 0
  else
    sthu = Vsat*(dPsidT*(Tsoil(k) - Tm)/sathh)**(-1/b)
    sthu = min(sthu, theta(k))
    sthf = (theta(k) - sthu)*rho_wat/rho_ice
  end if
  Mf(k) = rho_ice*Dzsoil(k)*sthf
  Mu(k) = rho_wat*Dzsoil(k)*sthu
end do

! Output options
Nave = 24
out_file = 'out.txt'
read(5,outputs)
open(uout, file = out_file)

end subroutine INITIALIZE


      subroutine gen3jet(r,p,wt3,*)
C---generate three particle phase space and x1,x2 integration
C---p1+p2 --> p3+p4+p5
      implicit none
      include 'constants.f'
      include 'mxdim.f'
      include 'phasemin.f'
      include 'reset.f'
      include 'x1x2.f'
      include 'first.f'
      integer j,nu
      double precision r(mxdim),p(mxpart,4),
     . ymax,ymin,xjac,y3,y4,y5,phi,phi45,wt0,wt3,
     . pt3,pt4,pt5,xt3,xt4,xt5,rtson2,cphi,sphi,cphi45,sphi45,deltay
      include 'energy.f'
      parameter(wt0=1d0/512d0/pi**3)
      double precision hmin,hmax,delh,h
      double precision ptjetmin,etajetmin,etajetmax
      save ptjetmin,etajetmin,etajetmax
!$omp threadprivate(ptjetmin,etajetmin,etajetmax)

      if (first .or. reset) then
        first=.false.
        reset=.false.
        call read_jetcuts(ptjetmin,etajetmin,etajetmax)
      endif

      do j=6,mxpart
      do nu=1,4
      p(j,nu)=0d0
      enddo
      enddo

      phi=2d0*pi*r(1)
      cphi=dcos(phi)
      sphi=dsin(phi)
      phi45=2d0*pi*r(2)
      cphi45=dcos(phi45)
      sphi45=dsin(phi45)
      xjac=sqrts**2
      ymax=10d0
      ymin=-10d0
      Deltay=ymax-ymin
      y3=ymin+Deltay*r(3)
      y4=ymin+Deltay*r(4)
      y5=ymin+Deltay*r(5)

c--- debug: try to get collinear 4 and 5
c      y5=y4-r(5)*1d-6

c--- debug: try to get collinear 2 and 5
c      y5=-8d0-r(5)*1d-6

c--- debug: try to get collinear 1 and 5
c      y5=+8d0+r(5)*1d-6

c--- debug: try to get collinear 2 and 4
c      y4=-8d0-r(4)*1d-6

c--- debug: try to get collinear 1 and 4
c      y4=+8d0+r(4)*1d-6

      xjac=xjac*Deltay**3

      rtson2=0.5d0*sqrts

c--- this is the old method
c      xt4=r(6)
c      xt5=r(7)
c      xjac=xjac*xt4*xt5

c--- this is the new method
      hmin=1d0/dsqrt(1d0+(ptjetmin/rtson2)**2)
      hmax=rtson2/ptjetmin
      delh=hmax-hmin
      h=hmin+r(6)*delh
      xt4=dsqrt(1d0/h**2-(ptjetmin/rtson2)**2)
      xjac=xjac*(delh/h**3)
      h=hmin+r(7)*delh
      xt5=dsqrt(1d0/h**2-(ptjetmin/rtson2)**2)
      xjac=xjac*(delh/h**3)

      pt4=rtson2*xt4
      pt5=rtson2*xt5

      p(4,1)=rtson2*xt4*sphi
      p(4,2)=rtson2*xt4*cphi

      p(5,1)=rtson2*xt5*(+cphi45*sphi+sphi45*cphi)
      p(5,2)=rtson2*xt5*(-sphi45*sphi+cphi45*cphi)

      p(3,1)=-p(4,1)-p(5,1)
      p(3,2)=-p(4,2)-p(5,2)
      pt3=dsqrt(p(3,1)**2+p(3,2)**2)
      xt3=pt3/rtson2

      xx(1)=half*(+xt3*exp(+y3)+xt4*exp(+y4)+xt5*exp(+y5))
      xx(2)=half*(+xt3*exp(-y3)+xt4*exp(-y4)+xt5*exp(-y5))

      if   ((xx(1) .gt. 1d0)
     & .or. (xx(2) .gt. 1d0)
     & .or. (xx(1) .lt. xmin)
     & .or. (xx(2) .lt. xmin)) then
c      write(6,*) 'problems with xx(1),xx(2) in gen3',xx(1),xx(2)
      return 1
      endif

      p(1,4)=-0.5d0*xx(1)*sqrts
      p(1,1)=0d0
      p(1,2)=0d0
      p(1,3)=-0.5d0*xx(1)*sqrts

      p(2,4)=-0.5d0*xx(2)*sqrts
      p(2,1)=0d0
      p(2,2)=0d0
      p(2,3)=+0.5d0*xx(2)*sqrts

      p(3,4)=+pt3*cosh(y3)
      p(3,3)=+pt3*sinh(y3)

      p(4,4)=+pt4*cosh(y4)
      p(4,3)=+pt4*sinh(y4)

      p(5,4)=+pt5*cosh(y5)
      p(5,3)=+pt5*sinh(y5)

      wt3=wt0*xjac
      return

      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                                                                                !!
!!  This file is part of SciFT project                                               !!
!!  Copyright (c) 2011-2016 Nestor F. Aguirre (nfaguirrec@gmail.com)                 !!
!!                                                                                !!
!!  Redistribution and use in source and binary forms, with or without               !!
!!  modification, are permitted provided that the following conditions are met:      !!
!!                                                                                !!
!!  1. Redistributions of source code must retain the above copyright notice, this   !!
!!     list of conditions and the following disclaimer.                              !!
!!  2. Redistributions in binary form must reproduce the above copyright notice,     !!
!!     this list of conditions and the following disclaimer in the documentation     !!
!!     and/or other materials provided with the distribution.                        !!
!!  3. Neither the name of the copyright holders nor the names of its contributors   !!
!!     may be used to endorse or promote products derived from this software         !!
!!     without specific prior written permission.                                    !!
!!                                                                                !!
!!  The copyright holders provide no reassurances that the source code provided      !!
!!  does not infringe any patent, copyright, or any other intellectual property      !!
!!  rights of third parties.  The copyright holders disclaim any liability to any    !!
!!  recipient for claims brought against recipient by any third party for            !!
!!  infringement of that parties intellectual property rights.                       !!
!!                                                                                !!
!!  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND  !!
!!  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED    !!
!!  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE           !!
!!  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR  !!
!!  ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES   !!
!!  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;     !!
!!  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND      !!
!!  ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT       !!
!!  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS    !!
!!  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.                     !!
!!                                                                                !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!>
!! @brief Test program
!!
program main
	use IOStream_
	use String_
	use CommandLineParser_
	use Spline_
	use RNFunction_
	use NDerivator_
	implicit none

	type(String) :: iFileName
	type(String) :: oFileName
	type(IFStream) :: ifile
	type(RNFunction) :: nFunc
	type(RNFunction) :: nFuncSmooth
	type(RNFunction) :: dnFunc
	type(Spline) :: nFuncSpline
	type(NDerivator) :: derivator
	type(String) :: strBuffer
	type(CommandLineParser) :: parser

	character(5), allocatable :: tokens(:)
	integer :: columns(2)
	integer :: order
	integer :: nPoints
	integer :: smoothFactor
	integer :: i

	iFileName = parser.getString( "-i" )
	oFileName = parser.getString( "-o" )

	strBuffer = parser.getString( "-c", def="1,2" )
	call strBuffer.split( tokens, "," )
	columns = [ FString_toInteger(tokens(1)), FString_toInteger(tokens(2)) ]

	order = parser.getInteger( "-n", def=1 )
	nPoints = parser.getInteger( "-p", def=5 )
	smoothFactor = parser.getInteger( "-s", def=1 )

	call ifile.init( iFileName.fstr )
	call nFunc.fromFStream( ifile, columns=columns )
	call ifile.close()

	if( nFunc.xGrid.isEquallyspaced ) then
		call derivator.init( nFunc, nPoints )
		dnFunc = derivator.evaluate( order )
	else
		call nFuncSpline.init( nFunc )
		nFuncSmooth = nFuncSpline.smooth( smoothFactor )

		call derivator.init( nFuncSmooth, nPoints )
		dnFunc = derivator.evaluate( order )
	end if

	call dnFunc.save( oFileName.fstr )

! 	if( .not. nFunc.xGrid.isEquallyspaced ) then
! 		write(*,*) ""
! 		write(*,*) ""
! 		call nFuncSmooth.save( oFileName.fstr )
! 	end if

end program main


      program main

c*********************************************************************72
c
cc MAIN is the main program for BLAS1_Z_PRB.
c
c  Discussion:
c
c    BLAS1_Z_PRB tests the BLAS1_Z library.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      call timestamp ( )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS1_Z_PRB:'
      write ( *, '(a)' ) '  FORTRAN77 version'
      write ( *, '(a)' ) '  Test the BLAS1_Z library.'

      call test01 ( )
      call test02 ( )
      call test03 ( )
      call test04 ( )
      call test05 ( )
      call test06 ( )
      call test07 ( )
      call test08 ( )
      call test09 ( )

      call test10 ( )
      call test11 ( )
      call test12 ( )
      call test13 ( )
      call test14 ( )
      call test15 ( )
      call test16 ( )
      call test17 ( )
c
c  Terminate.
c
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BLAS1_Z_PRB:'
      write ( *, '(a)' ) '  Normal end of execution.'
      write ( *, '(a)' ) ' '
      call timestamp ( )

      stop
      end
      subroutine test01 ( )

c*********************************************************************72
c
cc TEST01 tests DZASUM.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer ma
      integer na
      integer nx

      parameter ( ma = 5 )
      parameter ( na = 4 )
      parameter ( nx = 8 )

      double complex a(ma,na)
      double precision dzasum
      integer i
      integer j
      double complex x(nx)

      a(1,1) = ( -3.0D+00,  4.0D+00 )
      a(2,1) = (  2.0D+00,  0.0D+00 )
      a(3,1) = (  3.0D+00, -4.0D+00 )
      a(4,1) = (  2.0D+00,  0.0D+00 )
      a(5,1) = (  2.0D+00, -1.0D+00 )
      a(1,2) = ( -1.0D+00,  1.0D+00 )
      a(2,2) = (  0.0D+00,  5.0D+00 )
      a(3,2) = ( -4.0D+00, -2.0D+00 )
      a(4,2) = ( -4.0D+00,  1.0D+00 )
      a(5,2) = ( -4.0D+00, -3.0D+00 )
      a(1,3) = (  0.0D+00, -2.0D+00 )
      a(2,3) = (  1.0D+00,  3.0D+00 )
      a(3,3) = ( -3.0D+00,  3.0D+00 )
      a(4,3) = ( -3.0D+00,  3.0D+00 )
      a(5,3) = ( -1.0D+00, -2.0D+00 )
      a(1,4) = ( -1.0D+00,  2.0D+00 )
      a(2,4) = (  2.0D+00, -4.0D+00 )
      a(3,4) = (  0.0D+00, -1.0D+00 )
      a(4,4) = (  0.0D+00, -1.0D+00 )
      a(5,4) = ( -2.0D+00,  4.0D+00 )

      x(1) = (  2.0D+00, -1.0D+00 )
      x(2) = ( -4.0D+00, -2.0D+00 )
      x(3) = (  3.0D+00,  1.0D+00 )
      x(4) = (  2.0D+00,  2.0D+00 )
      x(5) = ( -1.0D+00, -1.0D+00 )
      x(6) = ( -1.0D+00,  0.0D+00 )
      x(7) = (  0.0D+00, -3.0D+00 )
      x(8) = (  4.0D+00,  0.0D+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST01'
      write ( *, '(a)' ) '  DZASUM adds the absolute values of'
      write ( *, '(a)' ) '  elements of a complex vector.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, nx
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' )
     &  '  DZASUM ( NX,   X, 1    ) = ', dzasum ( nx,   x, 1 )
      write ( *, '(a,g14.6)' )
     &  '  DZASUM ( NX/2, X, 2    ) = ', dzasum ( nx/2, x, 2 )
      write ( *, '(a,g14.6)' )
     &  '  DZASUM ( 2,    X, NX/2 ) = ', dzasum ( 2,    x, nx/2 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Demonstrate with a matrix A:'
      write ( *, '(a)' ) ' '
      do i = 1, ma
        write ( *, '(4(2x,f6.1,2x,f6.1))' ) ( a(i,j), j = 1, na )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)' )
     &  '  DZASUM ( MA, A(1,2), 1 )   = ', dzasum ( ma, a(1,2), 1 )
      write ( *, '(a,g14.6)' )
     &  '  DZASUM ( NA, A(2,1), MA ) = ', dzasum ( na, a(2,1), ma )

      return
      end
      subroutine test02 ( )

c*********************************************************************72
c
cc TEST02 tests DZNRM2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      double precision dznrm2
      integer i
      integer incx
      double precision norm
      double complex x(n)

      x(1) = (  2.0D+00, -1.0D+00 )
      x(2) = ( -4.0D+00, -2.0D+00 )
      x(3) = (  3.0D+00,  1.0D+00 )
      x(4) = (  2.0D+00,  2.0D+00 )
      x(5) = ( -1.0D+00, -1.0D+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST02'
      write ( *, '(a)' ) '  DZNRM2 returns the Euclidean norm'
      write ( *, '(a)' ) '  of a complex vector.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The vector X:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '( 2x, i6, 2x, f6.1, 2x, f6.1 )' ) i, x(i)
      end do

      incx = 1
      norm = dznrm2 ( n, x, incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,g14.6)'    ) '  The L2 norm of X is ', norm

      return
      end
      subroutine test03 ( )

c*********************************************************************72
c
cc TEST03 tests IZAMAX.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n

      parameter ( n = 5 )

      integer i
      integer incx
      integer izamax
      double complex x(n)
      double precision zabs1

      x(1) = (  2.0D+00, -1.0D+00 )
      x(2) = ( -4.0D+00, -2.0D+00 )
      x(3) = (  3.0D+00,  1.0D+00 )
      x(4) = (  2.0D+00,  2.0D+00 )
      x(5) = ( -1.0D+00, -1.0D+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST03'
      write ( *, '(a)' ) '  IZAMAX returns the index of maximum '
      write ( *, '(a)' ) '  magnitude;'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The entries and ZABS1 magnitudes:'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2f8.4,2x,f8.4)' ) i, x(i), zabs1 ( x(i) )
      end do

      incx = 1

      i = izamax ( n, x, incx )

      write ( *, '(a)' ) ' '
      write ( *, '(a,i6)' ) '  The index of maximum magnitude = ', i
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Note that this is a 1-based index.'
      write ( *, '(a)' ) '  Note that the L1 norm is used.'

      return
      end
      subroutine test04 ( )

c*********************************************************************72
c
cc TEST04 tests ZABS1.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      double complex c
      double precision c_norm
      integer i
      integer seed
      double complex c8_uniform_01
      double precision zabs1

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST04'
      write ( *, '(a)' ) '  ZABS1 returns the L1 norm '
      write ( *, '(a)' ) '  of a double complex number.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '      Real      Imaginary              '
      write ( *, '(a)' ) '      Part      Part           ZABS1(Z)'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c = 5.0D+00 * c8_uniform_01 ( seed )

        c_norm = zabs1 ( c )

        write ( *, '(2x,2f10.4,5x,f10.4)' ) c, c_norm

      end do

      return
      end
      subroutine test05 ( )

c*********************************************************************72
c
cc TEST05 tests ZABS2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      double complex c
      double precision c_norm
      integer i
      integer seed
      double complex c8_uniform_01
      double precision zabs2

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST05'
      write ( *, '(a)' ) '  ZABS2 returns the L2 norm '
      write ( *, '(a)' ) '  of a double complex number.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '      Real      Imaginary              '
      write ( *, '(a)' ) '      Part      Part           ZABS2(Z)'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c = 5.0D+00 * c8_uniform_01 ( seed )

        c_norm = zabs2 ( c )

        write ( *, '(2x,2f10.4,5x,f10.4)' ) c, c_norm

      end do

      return
      end
      subroutine test06 ( )

c*********************************************************************72
c
cc TEST06 tests ZAXPY.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    27 February 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      integer i
      double complex s
      double complex x(n)
      double complex y(n)

      x(1) = (  2.0D+00, -1.0D+00 )
      x(2) = ( -4.0D+00, -2.0D+00 )
      x(3) = (  3.0D+00,  1.0D+00 )
      x(4) = (  2.0D+00,  2.0D+00 )
      x(5) = ( -1.0D+00, -1.0D+00 )

      y(1) = ( -1.0D+00,  0.0D+00 )
      y(2) = (  0.0D+00, -3.0D+00 )
      y(3) = (  4.0D+00,  0.0D+00 )
      y(4) = ( -3.0D+00,  4.0D+00 )
      y(5) = ( -2.0D+00,  0.0D+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST06'
      write ( *, '(a)' ) '  ZAXPY adds a multiple of one '
      write ( *, '(a)' ) '  double complex vector to another.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, y(i)
      end do

      s = ( 0.50D+00, -1.00D+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a,2g14.6)' ) '  The scalar multiplier is: ', s

      call zaxpy ( n, s, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A * X + Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2f10.6)' ) i, y(i)
      end do

      return
      end
      subroutine test07 ( )

c*********************************************************************72
c
cc TEST07 tests ZCOPY.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      double complex a(5,5)
      integer i
      integer j
      double complex x(10)
      double complex y(10)

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST07'
      write ( *, '(a)' ) '  ZCOPY copies one double complex vector '
      write ( *, '(a)' ) '  into another.'

      do i = 1, 10
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, 10
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      do i = 1, 5
        do j = 1, 5
          a(i,j) = cmplx ( 10 * i,  j )
        end do
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,2g14.6)' ) i, x(i)
      end do
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,2g14.6)' ) i, y(i)
      end do
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,10f7.1)' ) ( a(i,j), j = 1, 5 )
      end do

      call zcopy ( 5, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  ZCOPY ( 5, X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,2g14.6)' ) i, y(i)
      end do

      do i = 1, 10
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      call zcopy ( 3, x, 2, y, 3 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  ZCOPY ( 3, X, 2, Y, 3 )'
      write ( *, '(a)' ) ' '
      do i = 1, 10
        write ( *, '(2x,i6,2g14.6)' ) i, y(i)
      end do

      call zcopy ( 5, x, 1, a, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  ZCOPY ( 5, X, 1, A, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,10f7.1)' ) ( a(i,j), j = 1, 5 )
      end do

      do i = 1, 5
        do j = 1, 5
          a(i,j) = cmplx ( 10 * i,  j )
        end do
      end do

      call zcopy ( 5, x, 2, a, 5 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  ZCOPY ( 5, X, 2, A, 5 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  A = '
      write ( *, '(a)' ) ' '
      do i = 1, 5
        write ( *, '(2x,10f7.1)' ) ( a(i,j), j = 1, 5 )
      end do

      return
      end
      subroutine test08 ( )

c*********************************************************************72
c
cc TEST08 tests ZDOTC.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      integer i
      double complex x(n)
      double complex x_norm
      double complex xy_dot
      double complex y(n)
      double complex zdotc

      x(1) = (  2.0D+00, -1.0D+00 )
      x(2) = ( -4.0D+00, -2.0D+00 )
      x(3) = (  3.0D+00,  1.0D+00 )
      x(4) = (  2.0D+00,  2.0D+00 )
      x(5) = ( -1.0D+00, -1.0D+00 )

      y(1) = ( -1.0D+00,  0.0D+00 )
      y(2) = (  0.0D+00, -3.0D+00 )
      y(3) = (  4.0D+00,  0.0D+00 )
      y(4) = ( -3.0D+00,  4.0D+00 )
      y(5) = ( -2.0D+00,  0.0D+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST08'
      write ( *, '(a)' ) '  ZDOTC computes the conjugated dot product'
      write ( *, '(a)' ) '  of two double complex vectors.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      x_norm = zdotc ( n, x, 1, x, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The square of the norm of X, computed as'
      write ( *, '(a,f10.4,2x,f10.4)' ) '  ZDOTC(X,X) = ', x_norm

      xy_dot = zdotc ( n, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, y(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,f10.4,2x,f10.4)' )
     &  '  The dot product X.Y* is ', xy_dot

      return
      end
      subroutine test09 ( )

c*********************************************************************72
c
cc TEST09 tests ZDOTU.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      integer i
      double complex x_norm
      double complex xy_dot
      double complex x(n)
      double complex y(n)
      double complex zdotu

      x(1) = (  2.0D+00, -1.0D+00 )
      x(2) = ( -4.0D+00, -2.0D+00 )
      x(3) = (  3.0D+00,  1.0D+00 )
      x(4) = (  2.0D+00,  2.0D+00 )
      x(5) = ( -1.0D+00, -1.0D+00 )

      y(1) = ( -1.0D+00,  0.0D+00 )
      y(2) = (  0.0D+00, -3.0D+00 )
      y(3) = (  4.0D+00,  0.0D+00 )
      y(4) = ( -3.0D+00,  4.0D+00 )
      y(5) = ( -2.0D+00,  0.0D+00 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST09'
      write ( *, '(a)' ) '  ZDOTU computes the unconjugated dot product'
      write ( *, '(a)' ) '  of two double complex vectors.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      x_norm = zdotu ( n, x, 1, x, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  The unconjugated dot product ( X dot X )'
      write ( *, '(a)' )
     &  '  (which is NOT the square of the norm of X!):'
      write ( *, '(a,f10.4,2x,f10.4)' ) '  ZDOTU(X,X) = ', x_norm

      xy_dot = zdotu ( n, x, 1, y, 1 )

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  Y = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, y(i)
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a,f10.4,2x,f10.4)' )
     &  '  The dot product ( X dot Y ) is ', xy_dot

      return
      end
      subroutine test10 ( )

c*********************************************************************72
c
cc TEST10 tests ZDROT.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      double precision c
      integer i
      double precision s
      doublecomplex x(n)
      doublecomplex y(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, n
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST10'
      write ( *, '(a)' ) '  ZDROT carries out a Givens rotation'
      write ( *, '(a)' ) '  on a double complex vector.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f10.1,2x,2f10.1)' ) i, x(i), y(i)
      end do

      c = 0.5D+00
      s = sqrt ( 1.0D+00 - c * c )
      call zdrot ( n, x, 1, y, 1, c, s )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a,f8.4,a)' )
     &  '  ZDROT ( N, X, 1, Y, 1, ', c, ',', s, ' )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f10.1,2x,2f10.1)' ) i, x(i), y(i)
      end do

      return
      end
      subroutine test11 ( )

c*********************************************************************72
c
cc TEST11 tests ZDSCAL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      double precision da
      integer i
      double complex x(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST11'
      write ( *, '(a)' ) '  ZDSCAL multiplies a double precision'
      write ( *, '(a)' ) '  scalar times a double complex vector.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      da = 5.0D+00
      call zdscal ( n, da, x, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  ZDSCAL ( N, ', da, ', X, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      da = -2.0D+00
      call zdscal ( 3, da, x, 2 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  ZDSCAL ( 3, ', da, ', X, 2 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      return
      end
      subroutine test12 ( )

c*********************************************************************72
c
cc TEST12 tests ZMACH.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    01 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      double precision zmach

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST12'
      write ( *, '(a)' ) '  ZMACH computes several machine-dependent'
      write ( *, '(a)' ) '  double complex arithmetic parameters.'

      write ( *, '(a)' ) ' '
      write ( *, * ) '  ZMACH(1)  = machine epsilon = ', zmach ( 1 )
      write ( *, * ) '  ZMACH(2)  = a tiny value    = ', zmach ( 2 )
      write ( *, * ) '  ZMACH(3)  = a huge value    = ', zmach ( 3 )

      return
      end
      subroutine test13 ( )

c*********************************************************************72
c
cc TEST13 tests ZROTG.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    15 May 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      double complex a
      double complex b
      double precision c
      double complex r
      double complex s
      double complex sa
      double complex sb
      integer seed
      integer test
      integer test_num
      double complex c8_uniform_01

      test_num = 5

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST13'
      write ( *, '(a)' ) '  ZROTG generates a complex Givens rotation'
      write ( *, '(a)' ) '    (  C  S ) * ( A ) = ( R )'
      write ( *, '(a)' ) '    ( -S  C )   ( B )   ( 0 )'
      write ( *, '(a)' ) ' '

      seed = 123456789

      do test = 1, test_num

        a = c8_uniform_01 ( seed )
        b = c8_uniform_01 ( seed )

        sa = a
        sb = b

        call zrotg ( sa, sb, c, s )

        r = sa

        write ( *, '(a)' ) ' '
        write ( *, '(a,2g14.6)' ) '  A =  ', a
        write ( *, '(a,2g14.6)' ) '  B =  ', b
        write ( *, '(a, g14.6)' ) '  C =  ', c
        write ( *, '(a,2g14.6)' ) '  S =  ', s
        write ( *, '(a,2g14.6)' ) '  R =  ', r
        write ( *, '(a,2g14.6)' )
     &    '         C *A+S*B = ',          c   * a + s * b
        write ( *, '(a,2g14.6)' )
     &    '  -conjg(S)*A+C*B = ', -conjg ( s ) * a + c * b

      end do

      return
      end
      subroutine test14 ( )

c*********************************************************************72
c
cc TEST14 tests ZSCAL.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 6 )

      double complex da
      integer i
      double complex x(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST14'
      write ( *, '(a)' ) '  ZSCAL multiplies a double complex scalar '
      write ( *, '(a)' ) '  times a vector.'

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X = '
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      da = ( 5.0D+00, 0.0D+00 )
      call zscal ( n, da, x, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,2f8.4,a)' ) '  ZSCAL ( N, (', da, '), X, 1 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      da = ( -2.0D+00, 1.0D+00 )
      call zscal ( 3, da, x, 2 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,2f8.4,a)' ) '  ZSCAL ( 3, (', da, '), X, 2 )'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,f6.1,2x,f6.1)' ) i, x(i)
      end do

      return
      end
      subroutine test15 ( )

c*********************************************************************72
c
cc TEST15 tests ZSIGN1.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      double complex c1
      double complex c2
      double complex c3
      integer i
      integer seed
      double complex c8_uniform_01
      double complex zsign1

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST15'
      write ( *, '(a)' ) '  ZSIGN1 ( C1, C2 ) transfers the sign of'
      write ( *, '(a)' ) '  double complex C2 to the ZABS1 magnitude '
      write ( *, '(a)' ) '  of C1.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' )
     &  '           C1                    C2                    C3'
      write ( *, '(a,a)' )
     &  '  --------------------  --------------------  ',
     &  '--------------------'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c1 = 5.0D+00 * c8_uniform_01 ( seed )
        c2 = 5.0D+00 * c8_uniform_01 ( seed )
        c3 = zsign1 ( c1, c2 )

        write ( *, '(2x,2f10.4,2x,2f10.4,2x,2f10.4)' ) c1, c2, c3

      end do

      return
      end
      subroutine test16 ( )

c*********************************************************************72
c
cc TEST16 tests ZSIGN2.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    14 April 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      double complex c1
      double complex c2
      double complex c3
      integer i
      integer seed
      double complex c8_uniform_01
      double complex zsign2

      seed = 123456789

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST16'
      write ( *, '(a)' ) '  ZSIGN2 ( C1, C2 ) transfers the sign of'
      write ( *, '(a)' ) '  double complex C2 to the ZABS2 magnitude '
      write ( *, '(a)' ) '  of C1.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' )
     &  '           C1                    C2                    C3'
      write ( *, '(a,a)' )
     &  '  --------------------  --------------------  ',
     &  '--------------------'
      write ( *, '(a)' ) ' '

      do i = 1, 10

        c1 = 5.0D+00 * c8_uniform_01 ( seed )
        c2 = 5.0D+00 * c8_uniform_01 ( seed )
        c3 = zsign2 ( c1, c2 )

        write ( *, '(2x,2f10.4,2x,2f10.4,2x,2f10.4)' ) c1, c2, c3

      end do

      return
      end
      subroutine test17 ( )

c*********************************************************************72
c
cc TEST17 tests ZSWAP.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    02 March 2006
c
c  Author:
c
c    John Burkardt
c
      implicit none

      integer n
      parameter ( n = 5 )

      integer i
      double complex x(n)
      double complex y(n)

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, n
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'TEST17'
      write ( *, '(a)' ) '  ZSWAP swaps two double complex vectors.'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f7.1,2x,2f7.1)' ) i, x(i), y(i)
      end do

      call zswap ( n, x, 1, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  ZSWAP ( N, X, 1, Y, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f7.1,2x,2f7.1)' ) i, x(i), y(i)
      end do

      do i = 1, n
        x(i) = cmplx ( 10 * i, i )
      end do

      do i = 1, n
        y(i) = cmplx ( 20 * i, 2 * i )
      end do

      call zswap ( 3, x, 2, y, 1 )
      write ( *, '(a)' ) ' '
      write ( *, '(a,f8.4,a)' ) '  ZSWAP ( 3, X, 2, Y, 1 )'
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) '  X and Y'
      write ( *, '(a)' ) ' '
      do i = 1, n
        write ( *, '(2x,i6,2x,2f7.1,2x,2f7.1)' ) i, x(i), y(i)
      end do

      return
      end


MODULE PolynomialBasisModule_Lagrange

  USE KindModule, ONLY: &
    DP
  USE ProgramHeaderModule, ONLY: &
    nDOFX, nDOF, &
    nNodesE, nNodesX, nNodes
  USE QuadratureModule, ONLY: &
    xG1, xG2, xG3, xG4
  USE ReferenceElementModuleX, ONLY: &
    NodeNumberTableX3D
  USE ReferenceElementModule, ONLY: &
    NodeNumberTable4D

  IMPLICIT NONE
  PRIVATE

  INTERFACE
    PURE REAL(DP) FUNCTION Basis( x0 )
      USE KindModule, ONLY: DP
      REAL(DP), INTENT(IN) :: x0
    END FUNCTION Basis
  END INTERFACE

  TYPE :: PolynomialBasisType
    PROCEDURE (Basis), POINTER, NOPASS :: P
  END TYPE PolynomialBasisType

  REAL(DP),                  ALLOCATABLE         :: nodes(:,:)
  INTEGER,                   ALLOCATABLE, PUBLIC :: IndL_Q (:,:)
  INTEGER,                   ALLOCATABLE, PUBLIC :: IndLx_Q(:,:)
  TYPE(PolynomialBasisType), ALLOCATABLE, PUBLIC :: L_E (:), dL_E (:)
  TYPE(PolynomialBasisType), ALLOCATABLE, PUBLIC :: L_X1(:), dL_X1(:)
  TYPE(PolynomialBasisType), ALLOCATABLE, PUBLIC :: L_X2(:), dL_X2(:)
  TYPE(PolynomialBasisType), ALLOCATABLE, PUBLIC :: L_X3(:), dL_X3(:)

  PUBLIC :: InitializePolynomialBasis_Lagrange
  PUBLIC :: evalL
  PUBLIC :: evalL_X1
  PUBLIC :: evalLX
  PUBLIC :: evalLX_X1
  PUBLIC :: LagrangeP
  PUBLIC :: dLagrangeP

CONTAINS

  SUBROUTINE InitializePolynomialBasis_Lagrange

    ALLOCATE( nodes(nNodes,nNodes) )
    CALL InitializeNodes

    ALLOCATE( L_E(nNodesE), dL_E(nNodesE) )
    CALL InitializeBasis( L_E, dL_E )

    ALLOCATE( L_X1(nNodesX(1)), dL_X1(nNodesX(1)) )
    CALL InitializeBasis( L_X1, dL_X1 )

    ALLOCATE( L_X2(nNodesX(2)), dL_X2(nNodesX(2)) )
    CALL InitializeBasis( L_X2, dL_X2 )

    ALLOCATE( L_X3(nNodesX(3)), dL_X3(nNodesX(3)) )
    CALL InitializeBasis( L_X3, dL_X3 )

    ALLOCATE( IndL_Q (0:3,nDOF) )
    ALLOCATE( IndLX_Q(1:3,nDOF) )
    CALL InitializeIndices_TensorProductBasis

    CALL ComputeMassMatrix

  END SUBROUTINE InitializePolynomialBasis_Lagrange

  SUBROUTINE InitializeNodes

    SELECT CASE ( nNodes )

      CASE ( 1 )

        CALL SetNodes( xG1 )

      CASE ( 2 )

        CALL SetNodes( xG2 )

      CASE ( 3 )

        CALL SetNodes( xG3 )

      CASE ( 4 )

        CALL SetNodes( xG4 )

      CASE DEFAULT

        WRITE(*,*)
        WRITE(*,*) "  Invalid nNodes  "
        STOP

    END SELECT

  END SUBROUTINE InitializeNodes

  SUBROUTINE SetNodes( x )

    REAL(DP), DIMENSION(nNodes), INTENT(inout) :: x

    INTEGER :: i, j, k

    nodes(nNodes,:) = x

    DO j = 1, nNodes
      k = 1
      DO i = 1, nNodes
        IF( i == j ) CYCLE
        nodes(k,j) = x(i)
        k = k + 1
      END DO
    END DO

  END SUBROUTINE SetNodes

  SUBROUTINE InitializeBasis( P, dP )

    TYPE(PolynomialBasisType), DIMENSION(:) :: P, dP

    SELECT CASE ( SIZE( P ) )

      CASE ( 1 )

        P (1) % P => Unity
        dP(1) % P => Empty

      CASE ( 2 )

        P (1) % P =>  Lagrange_1
        P (2) % P =>  Lagrange_2
        dP(1) % P => dLagrange_1
        dP(2) % P => dLagrange_2

      CASE ( 3 )

        P (1) % P =>  Lagrange_1
        P (2) % P =>  Lagrange_2
        P (3) % P =>  Lagrange_3
        dP(1) % P => dLagrange_1
        dP(2) % P => dLagrange_2
        dP(3) % P => dLagrange_3

      CASE ( 4 )

        P (1) % P =>  Lagrange_1
        P (2) % P =>  Lagrange_2
        P (3) % P =>  Lagrange_3
        P (4) % P =>  Lagrange_4
        dP(1) % P => dLagrange_1
        dP(2) % P => dLagrange_2
        dP(3) % P => dLagrange_3
        dP(4) % P => dLagrange_4

      CASE DEFAULT

        WRITE(*,*)
        WRITE(*,*) "  Invalid Basis Size  "
        STOP

    END SELECT

  END SUBROUTINE InitializeBasis

  SUBROUTINE InitializeIndices_TensorProductBasis

    INTEGER :: i, iNodeE, iNodeX1, iNodeX2, iNodeX3

    i = 1
    DO iNodeX3 = 1, nNodesX(3)
      DO iNodeX2 = 1, nNodesX(2)
        DO iNodeX1 = 1, nNodesX(1)

          IndLX_Q(1:3,i) = [ iNodeX1, iNodeX2, iNodeX3 ]
          i = i + 1

        END DO
      END DO
    END DO

    i = 1
    DO iNodeX3 = 1, nNodesX(3)
      DO iNodeX2 = 1, nNodesX(2)
        DO iNodeX1 = 1, nNodesX(1)
          DO iNodeE = 1, nNodesE

            IndL_Q(0:3,i) = [ iNodeE, iNodeX1, iNodeX2, iNodeX3 ]
            i = i + 1

          END DO
        END DO
      END DO
    END DO

  END SUBROUTINE InitializeIndices_TensorProductBasis

  SUBROUTINE ComputeMassMatrix

    REAL(DP), DIMENSION(1:nNodesE,   1:nNodesE)    :: M_E
    REAL(DP), DIMENSION(1:nNodesX(1),1:nNodesX(1)) :: M_X1
    REAL(DP), DIMENSION(1:nNodesX(2),1:nNodesX(2)) :: M_X2
    REAL(DP), DIMENSION(1:nNodesX(3),1:nNodesX(3)) :: M_X3

  END SUBROUTINE ComputeMassMatrix

  PURE REAL(DP) FUNCTION evalL( u, E, X1, X2, X3 )

    REAL(DP), INTENT(in) :: u(1:nDOF), E, X1, X2, X3

    INTEGER  :: i, iE, iX1, iX2, iX3
    REAL(DP) :: TMP_X1, TMP_X2, TMP_X3

    i = 1
    evalL = 0.0_DP
    DO iX3 = 1, nNodesX(3)
      TMP_X3 = L_X3(iX3) % P( X3 )
      DO iX2 = 1, nNodesX(2)
        TMP_X2 = L_X2(iX2) % P( X2 )
        DO iX1 = 1, nNodesX(1)
          TMP_X1 = L_X1(iX1) % P( X1 )
          DO iE = 1, nNodesE

            evalL &
              = evalL &
                + L_E(iE) % P( E ) * u(i) &
                    * TMP_X1 * TMP_X2 * TMP_X3

            i = i + 1

          END DO
        END DO
      END DO
    END DO

    RETURN
  END FUNCTION evalL

  PURE REAL(DP) FUNCTION evalL_X1( u, X1, iE, iX2, iX3 )

    REAL(DP), INTENT(in) :: u(1:nDOF), X1
    INTEGER,  INTENT(in) :: iE, iX2, iX3

    INTEGER :: iX1, iNode

    evalL_X1 = 0.0_DP
    DO iX1 = 1, nNodesX(1)

      iNode = NodeNumberTable4D( iE, iX1, iX2, iX3 )

      evalL_X1 &
        = evalL_X1 &
            + L_X1(iX1) % P( X1 ) * u(iNode)

    END DO

    RETURN
  END FUNCTION evalL_X1

  PURE REAL(DP) FUNCTION evalLX( u, X1, X2, X3 )

    REAL(DP), INTENT(in) :: u(1:nDOFX), X1, X2, X3

    INTEGER  :: i, iX1, iX2, iX3
    REAL(DP) :: TMP_X2, TMP_X3

    i = 1
    evalLX = 0.0_DP
    DO iX3 = 1, nNodesX(3)
      TMP_X3 = L_X3(iX3) % P( X3 )
      DO iX2 = 1, nNodesX(2)
        TMP_X2 = L_X2(iX2) % P( X2 )
        DO iX1 = 1, nNodesX(1)

          evalLX &
            = evalLX &
              + L_X1(iX1) % P( X1 ) * u(i) &
                  * TMP_X2 * TMP_X3

          i = i + 1

        END DO
      END DO
    END DO

    RETURN
  END FUNCTION evalLX

  PURE REAL(DP) FUNCTION evalLX_X1( u, X1, iX2, iX3 )

    REAL(DP), INTENT(in) :: u(1:nDOFX), X1
    INTEGER,  INTENT(in) :: iX2, iX3

    INTEGER :: iX1, iNode

    evalLX_X1 = 0.0_DP
    DO iX1 = 1, nNodesX(1)

      iNode = NodeNumberTableX3D( iX1, iX2, iX3 )

      evalLX_X1 &
        = evalLX_X1 &
            + L_X1(iX1) % P( X1 ) * u(iNode)

    END DO

    RETURN
  END FUNCTION evalLX_X1

  !***************************************************************************
  !  Elements of Lagrange Polynomial Basis
  !***************************************************************************

  PURE REAL(DP) FUNCTION Unity( x )
    REAL(DP), INTENT(IN) :: x
    Unity = 1.0_DP
    RETURN
  END FUNCTION Unity

  PURE REAL(DP) FUNCTION Lagrange_1( x )
    REAL(DP), INTENT(IN) :: x
    Lagrange_1 = Lagrange( x, nodes(:,1) )
    RETURN
  END FUNCTION Lagrange_1

  PURE REAL(DP) FUNCTION Lagrange_2( x )
    REAL(DP), INTENT(IN) :: x
    Lagrange_2 = Lagrange( x, nodes(:,2) )
    RETURN
  END FUNCTION Lagrange_2

  PURE REAL(DP) FUNCTION Lagrange_3( x )
    REAL(DP), INTENT(IN) :: x
    Lagrange_3 = Lagrange( x, nodes(:,3) )
    RETURN
  END FUNCTION Lagrange_3

  PURE REAL(DP) FUNCTION Lagrange_4( x )
    REAL(DP), INTENT(IN) :: x
    Lagrange_4 = Lagrange( x, nodes(:,4) )
    RETURN
  END FUNCTION Lagrange_4

  PURE REAL(DP) FUNCTION Lagrange( x, xx )

    REAL(DP),                    INTENT(in) :: x
    REAL(DP), DIMENSION(nNodes), INTENT(in) :: xx

    INTEGER :: i

    Lagrange = 1.0_DP
    DO i = 1, nNodes - 1
      Lagrange = Lagrange * ( x - xx(i) ) / ( xx(nNodes) - xx(i) )
    END DO

  END FUNCTION Lagrange

  PURE REAL(DP) FUNCTION LagrangeP( x, i, xx, nn )

    INTEGER,  INTENT(in) :: i, nn
    REAL(DP), INTENT(in) :: x, xx(nn)

    INTEGER :: j

    LagrangeP = 1.0_DP
    DO j = 1, nn
      IF( j == i ) CYCLE
      LagrangeP = LagrangeP * ( x - xx(j) ) / ( xx(i) - xx(j) )
    END DO

    RETURN
  END FUNCTION LagrangeP

  !***************************************************************************
  !  Derivative of Lagrange Polynomial Basis
  !***************************************************************************

  PURE REAL(DP) FUNCTION Empty( x )

    REAL(DP), INTENT(IN) :: x

    Empty = 0.0_DP

  END FUNCTION Empty

  PURE REAL(DP) FUNCTION dLagrange_1( x )

    REAL(DP), INTENT(IN) :: x

    dLagrange_1 = dLagrange( x, nodes(:,1) )

  END FUNCTION dLagrange_1

  PURE REAL(DP) FUNCTION dLagrange_2( x )

    REAL(DP), INTENT(IN) :: x

    dLagrange_2 = dLagrange( x, nodes(:,2) )

  END FUNCTION dLagrange_2

  PURE REAL(DP) FUNCTION dLagrange_3( x )

    REAL(DP), INTENT(IN) :: x

    dLagrange_3 = dLagrange( x, nodes(:,3) )

  END FUNCTION dLagrange_3

  PURE REAL(DP) FUNCTION dLagrange_4( x )

    REAL(DP), INTENT(IN) :: x

    dLagrange_4 = dLagrange( x, nodes(:,4) )

  END FUNCTION dLagrange_4

  PURE REAL(DP) FUNCTION dLagrange( x, xx )

    REAL(DP),                    INTENT(IN) :: x
    REAL(DP), DIMENSION(nNodes), INTENT(IN) :: xx

    INTEGER  :: i, j
    REAL(DP) :: Denominator, Numerator

    Denominator = 1.0_DP
    DO i = 1, nNodes - 1
      Denominator = Denominator * ( xx(nNodes) - xx(i) )
    END DO

    dLagrange = 0.0_DP
    DO i = 1, nNodes - 1
      Numerator = 1.0_DP
      DO j = 1, nNodes - 1
        IF( j == i ) CYCLE
        Numerator = Numerator * ( x - xx(j) )
      END DO
      dLagrange = dLagrange + Numerator / Denominator
    END DO

  END FUNCTION dLagrange

  PURE REAL(DP) FUNCTION dLagrangeP( x, i, xx, nn )

    INTEGER,  INTENT(in) :: i, nn
    REAL(DP), INTENT(in) :: x, xx(nn)

    INTEGER  :: j, k
    REAL(DP) :: Denominator, Numerator

    Denominator = 1.0_DP
    DO j = 1, nn
      IF( j == i ) CYCLE
      Denominator = Denominator * ( xx(i) - xx(j) )
    END DO

    dLagrangeP = 0.0_DP
    DO j = 1, nn
      IF( j == i ) CYCLE
      Numerator = 1.0_DP
      DO k = 1, nn
        IF( k == i .OR. k == j ) CYCLE
        Numerator = Numerator * ( x - xx(k) )
      END DO
      dLagrangeP = dLagrangeP + Numerator / Denominator
    END DO

    RETURN
  END FUNCTION dLagrangeP

END MODULE PolynomialBasisModule_Lagrange


PROGRAM check
!  check results between different runs/implementations
!  26 March 2019
  IMPLICIT none

!  Non-dimensional constants
  INTEGER p, q, n, ip, jp
  PARAMETER (p = 18)
  PARAMETER (q = 15)
  PARAMETER (n = 24)
  PARAMETER (ip = 9)
  PARAMETER (jp = 13)

!  Declare data, physical info.
  REAL z1(0:p,0:q), z2(0:p,0:q)
  REAL delta(0:p,0:q)
  CHARACTER b

!  Declare computational variables
  INTEGER i, j, k, tk

! BEGIN THE EXECUTION HERE
  OPEN (UNIT=1, FILE="ENIAC.REF", FORM="FORMATTED", STATUS="OLD")
  OPEN (UNIT=2, FILE="ENIAC.OUT", FORM="FORMATTED", STATUS="OLD")

!***********************************************************!!
!  BEGIN THE ITERATIVE SOLUTION OF THE EQUATIONS
  !DO k = 0, 3*n-1 ! can't go the full 3 days because the instability starts throwing * in the output
  DO k = 0, 60

    READ (1,9003) tk
    READ (1,9001) ((z1(i,j),j=0,q),i=0,p)
    READ (1,9002) b

    READ (2,9003) tk
    READ (2,9001) ((z2(i,j),j=0,q),i=0,p)
    READ (2,9002) b

    delta = z1 - z2
    WRITE (*,9004) k, tk, MAXVAL(delta), MINVAL(delta), SUM(delta*delta)
    WRITE (*,9001) ((delta(i,j),j=0,q),i=0,p)
    WRITE (*,9002) b

  ENDDO

 9001 FORMAT (16F7.2)
 9002 FORMAT (A1)
 9003 FORMAT (I3)
 9004 FORMAT ('k = ',2I3, 2F9.2, F15.7)

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

  END


c     Fortran translation (Heh!) of test14 in quadpack-tests.lisp.
      program test14
      implicit none
      double precision alpha
      integer key

      print *, 'Test 14'
      print *
      print *, ' integrate(x^(-1/2)*exp(-2^(-alpha)*x)*cos(x)'
      print 9001
 9001 format('   = (1+eps)*sqrt(pi)*(1-4^(-alpha))^(-1/4)*cos(atan(2^alp
     $ha)/2)')

      print *
      print *
      print *, 'QAWF'
      print 9000
      do 20 alpha = 1d0,6d0
         call qqawf(alpha)
   20 continue
      print *
      print *, 'QAWO'
      print 9000
      do 50 alpha = 1d0, 6d0
         call qqawo(alpha)
   50 continue
 9000 format('alpha   est result              est abserr             nev
     &al    ier   true answer            true abs err')
      end
      double precision function soln(alpha)
      double precision pi
      parameter (pi = 3.141592653589793d0)
      double precision alpha
      soln = sqrt(pi)*(1+4**(-alpha))**(-.25d0)*cos(atan(2**alpha)/2)
      return
      end

      double precision function f(x)
      double precision x, tmp
      double precision alfa

      common /param/ alfa
      f = exp(-(2**(-alfa))*x)/sqrt(x)
      return
      end

      subroutine qqawf(alpha)
      integer limit, lenw
      parameter (limit = 200, maxp1 = 100, leniw = limit, limlst = 10)
      parameter (lenw = 2*leniw + maxp1*25)

      double precision alpha
      double precision alfa
      common /param/alfa

      integer iwork(leniw)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha
      last = 0
      call dqawf(f, 1d-10, 1d0, 1, 1d-8, result, abserr, neval, ier,
     $     limlst, last, leniw, maxp1, lenw, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end

      subroutine qqawo(alpha)
      integer leniw, limit, lenw, maxp1
      parameter (limit = 200, leniw = limit, maxp1 = 100)
      parameter (lenw = 2*leniw+25*maxp1)

      double precision alpha
      double precision alfa
      common /param/alfa

      integer iwork(leniw)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqawo(f, 1d-10, 20*2**alpha, 1d0, 1, 0d0, 1d-8,
     $     result, abserr, neval, ier,
     $     leniw, maxp1, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end


      subroutine decomp(neq,ndim,a,ip)
      implicit none
      integer neq,ndim
      real*8  a(ndim,ndim)
      integer ip(ndim)
      real*8 eps,eps2,amult,apm,apn
      integer n,nm1,i,ip1,k,j,l
      data eps,eps2 /1.d-30,1.d-60/
      nm1=neq-1
      do 10 n=1,neq
  10  ip(n)=n
      do 100 i=1,nm1
      ip1=i+1
       k=i
      apm    =abs(a(ip(i),i))
      do 110 j=ip1,neq
      apn=abs(a(ip(j),i))
      if(apm.ge.apn) go to 110
      apm=apn
       k=j
  110 continue
      j=ip(k)
      ip(k)=ip(i)
      ip(i)=j
  115 if(apm.lt.eps) go to 1000
      do 120 l=ip1,neq
      n=ip(l)
      amult=a(n,i)/a(j,i)
      a(n,i)=amult
      if(abs(amult).lt.eps2) go to 120
      do 130 k=ip1,neq
      a(n,k)=a(n,k)-amult*a(j,k)
  130 continue
  120 continue
  100 continue
      if(abs(a(ip(neq),neq)).lt.eps) go to 1000
      return
 1000 continue
      write(6,*)a(ip(neq),neq)
      stop"singular matrix in decomp"
      end

      subroutine solve(neq,ndim,a,b,ip)
      implicit none
      real*8 a(ndim,ndim),b(ndim)
      integer ip(ndim)
      integer neq,ndim
      integer nm1,l,lm1,k,j,jp1,n
      real*8 scr
      nm1 = neq-1
      do 10 l=2,neq
      n=ip(l)
      lm1=l-1
      do 20 k=1,lm1
      b(n)=b(n)-a(n,k)*b(ip(k))
  20  continue
   10 continue
      b(ip(neq))=b(ip(neq))/a(ip(neq),neq)
      do 30 l=1,nm1
      j=neq-l
      jp1=j+1
      n=ip(j)
      do 40 k=jp1,neq
      b(n)=b(n)-a(n,k  )*b(ip(k))
   40 continue
      b(n)=b(n)/a(n,j)
   30 continue
      do 50 n=1,neq
   60 if(ip(n) .eq. n) go to 50
      j=ip(n)
      scr=b(j)
      ip(n)=ip(j)
      b(j)=b(ip(j))
      b(ip(j))=scr
      ip(j)=j
      go to 60
   50 continue
      return
      end


*DECK D9GMIT
      DOUBLE PRECISION FUNCTION D9GMIT (A, X, ALGAP1, SGNGAM, ALX)
C***BEGIN PROLOGUE  D9GMIT
C***SUBSIDIARY
C***PURPOSE  Compute Tricomi's incomplete Gamma function for small
C            arguments.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      DOUBLE PRECISION (R9GMIT-S, D9GMIT-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, SMALL X,
C             SPECIAL FUNCTIONS, TRICOMI
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute Tricomi's incomplete gamma function for small X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DLNGAM, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  D9GMIT
      DOUBLE PRECISION A, X, ALGAP1, SGNGAM, ALX, AE, AEPS, ALGS, ALG2,
     1  BOT, EPS, FK, S, SGNG2, T, TE, D1MACH, DLNGAM
      LOGICAL FIRST
      SAVE EPS, BOT, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  D9GMIT
      IF (FIRST) THEN
         EPS = 0.5D0*D1MACH(3)
         BOT = LOG (D1MACH(1))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'D9GMIT',
     +   'X SHOULD BE GT 0', 1, 2)
C
      MA = A + 0.5D0
      IF (A.LT.0.D0) MA = A - 0.5D0
      AEPS = A - MA
C
      AE = A
      IF (A.LT.(-0.5D0)) AE = AEPS
C
      T = 1.D0
      TE = AE
      S = T
      DO 20 K=1,200
        FK = K
        TE = -X*TE/FK
        T = TE/(AE+FK)
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 30
 20   CONTINUE
      CALL XERMSG ('SLATEC', 'D9GMIT',
     +   'NO CONVERGENCE IN 200 TERMS OF TAYLOR-S SERIES', 2, 2)
C
 30   IF (A.GE.(-0.5D0)) ALGS = -ALGAP1 + LOG(S)
      IF (A.GE.(-0.5D0)) GO TO 60
C
      ALGS = -DLNGAM(1.D0+AEPS) + LOG(S)
      S = 1.0D0
      M = -MA - 1
      IF (M.EQ.0) GO TO 50
      T = 1.0D0
      DO 40 K=1,M
        T = X*T/(AEPS-(M+1-K))
        S = S + T
        IF (ABS(T).LT.EPS*ABS(S)) GO TO 50
 40   CONTINUE
C
 50   D9GMIT = 0.0D0
      ALGS = -MA*LOG(X) + ALGS
      IF (S.EQ.0.D0 .OR. AEPS.EQ.0.D0) GO TO 60
C
      SGNG2 = SGNGAM * SIGN (1.0D0, S)
      ALG2 = -X - ALGAP1 + LOG(ABS(S))
C
      IF (ALG2.GT.BOT) D9GMIT = SGNG2 * EXP(ALG2)
      IF (ALGS.GT.BOT) D9GMIT = D9GMIT + EXP(ALGS)
      RETURN
C
 60   D9GMIT = EXP (ALGS)
      RETURN
C
      END


!
!   FnVFB.f90
!
!
!
!   Created by Kurt Mitman on 10/10/14.
!
!

DOUBLE PRECISION FUNCTION FnVFB(bsav)

USE Params
USE Globals
USE funcs
USE Procedures

IMPLICIT NONE

DOUBLE PRECISION, INTENT(IN) :: bsav
DOUBLE PRECISION             :: cons,qmtemp,qltemp
DOUBLE PRECISION             :: vals(2)
INTEGER                      :: inds(2)

call basefun(GridB,nb,bsav,vals,inds)

call BiLinInterp1(nb,GridB,ngpPh,PhGrid,qm(:,gil,gim,gih,giExo,:,gij+1),bsav,gPh,qmtemp)
call BiLinInterp1(nb,GridB,ngpPh,PhGrid,ql(:,gil,gim,gih,giExo,:,gij+1),bsav,gPh,qltemp)

cons=gliq+(qltemp*gloc+qmtemp*gmort)*ghouse-FnQb(bsav,(gPh-gmort)*ghouse)*bsav

if(cons .GT. cmin) then

    FnVFB = -1.0d0*(uown(cons,ghouse,gij)+bet*(vals(1)*EVown(inds(1),gil,gim,gih,gij)+vals(2)*EVown(inds(2),gil,gim,gih,gij)))

else

    FnVFB = 1.0d10+10.0d0*(cmin-cons)

endif

END FUNCTION FnVFB


      program tcr
*
*     2019/02/07 for FOD
*     2019/12/10 for SOD
*     2020/11/19 for FGD
*     2021/02/05 for FGD
*
      integer nvar, nt, nite
      real    dt, xmiss, cs, cd

      parameter ( nvar = 5, nt = 201, nite = 1000 )
      parameter ( dt = 1. )
      parameter ( xmiss = -999. )

* Geoffroy et al. 2013
c      parameter ( cs = 8.2 )    !! CMIP5 MME mean upper layer heat capacity
c      parameter ( cd = 109. )    !! CMIP5 MME mean deeper layer heat capacity
* Smith et al. 2020
      parameter ( cs = 8.2075 ) !! CMIP6 MME mean upper layer heat capacity
      parameter ( cd = 97.6382 ) !! CMIP6 MME mean deeper layer heat capacity

      real    erf( nvar )
      real    fdb( nvar )
      real    ecs( nvar )
      real    gamma( nvar )
      real    eps( nvar )
      real    epsgamma( nvar )

      real    df( nvar )

      real    frc1( nvar )
      real    frc2( nvar )
      real    tstep( nvar )     !! T for step 2xCO2
      real    t1ppt( nvar )     !! T for 1%
      real    tstep_bak( nt,nvar )     !! T for step 2xCO2
      real    t1ppt_bak( nt,nvar )     !! T for 1%

      real    tcrout( nvar )       !! TCR
      real    dum( nvar )

      real    t
      real    b, b_ast, delta, phi_f, phi_s
      real    tau_f, tau_s, af, as, fact1, fact2, fact3
      real    x1, y1, z1, x2, y2, z2
      integer m, n, i, j, ite

* see the bottom for .ctl files
      character cfo(3)*90
      data cfo(1)
     &/'./erf_evolution.grd'/
      data cfo(2)
     &/'./ecs_evolution.grd'/
      data cfo(3)
     &/'./tcr_evolution.grd'/

*     vars: 5%, 17%, mean, 83%, 95%
      data  erf                 !! 2xCO2
     &     / 3.5, 3.698, 4.0, 4.302, 4.5 / !! FGD
      data  fdb                 !! lambda from process (sign reversed)
     &     / 1.8131, 1.5395, 1.1608, 0.7821, 0.5085 /!! FGD
      data  ecs                 !! ECS from process
     &     / 2.15, 2.54, 3.44, 5.23, 7.81 /!! FGD
      data  gamma               !! CMIP6 gamma
     &     / 0.4161, 0.4958, 0.6177, 0.7397, 0.8193 /
      data  eps                 !! CMIP6 epsiron
     &     / 0.8336, 1.0227, 1.3123, 1.6018, 1.7910 /
      data  epsgamma            !! CMIP6 epsiron x gamma
     &     / 0.3688, 0.5450, 0.8148, 1.0845, 1.2607 /

      open ( 91, file=cfo(1), form='unformatted' )
      open ( 92, file=cfo(2), form='unformatted' )
      open ( 93, file=cfo(3), form='unformatted' )
*
      do m = 1, nvar
         df( m ) = erf( m ) / 70.
      enddo
*
      dum = xmiss
*
*     ERF
*
      write( 6,* )
     &     ' @@@ ERF '

      t = 0.
      frc1 = 0.
      frc2 = 0.
      do n = 1, nt
         t = dt * real( n-1 )
         do m = 1, nvar
            frc1( m ) = erf( m ) !! F2xCO2
            frc2( m ) = df( m ) * t !! F(t)
            if( t .ge. 70. ) frc2( m ) = frc1( m )
         enddo
         do m = 1, nvar
            write( 91 ) frc1( m )
         enddo
         do m = 1, nvar
            write( 91 ) frc2( m )
         enddo
      enddo
*
*     ECS & TCR (varying F and lambda only)
*
      write( 6,* )
     &     ' @@@ ECS & TCR (varying F and lambda only) '

      t = 0.
      tstep = 0.
      t1ppt = 0.
      do n = 1, nt
         t = dt * real( n-1 )

         do m = 1, nvar

            b = ( fdb( m ) + epsgamma( 3 ) ) / cs
     &           + epsgamma( 3 ) / cd / eps( 3 )
            b_ast = ( fdb( m ) + epsgamma( 3 ) ) / cs
     &           - epsgamma( 3 ) / cd / eps( 3 )
            delta = b**2 - 4. * ( fdb( m )*epsgamma( 3 ) )
     &           / ( cs * cd * eps( 3 ) )
            phi_f = cs * ( b_ast - sqrt( delta ) ) / 2. / epsgamma( 3 )
            phi_s = cs * ( b_ast + sqrt( delta ) ) / 2. / epsgamma( 3 )
            tau_f = cs * cd * eps( 3 ) * ( b - sqrt( delta ) )
     &           / ( 2.*fdb( m )*epsgamma( 3 ) )
            tau_s = cs * cd * eps( 3 ) * ( b + sqrt( delta ) )
     &           / ( 2.*fdb( m )*epsgamma( 3 ) )
            af = fdb( m ) / cs - 1. / tau_s
            af = af * ( tau_f * tau_s ) / ( tau_s - tau_f )
            as = 1. - af
            fact1 = af * exp( -t/tau_f )
     &           + as * exp( -t/tau_s )
            fact2 = tau_f * af * ( 1. - exp( -t/tau_f ) )
     &            + tau_s * as * ( 1. - exp( -t/tau_s ) )
            fact3 = tau_f * af * ( 1. - exp( -70./tau_f ) )
     &                         * exp( -( t-70. )/tau_f )
     &            + tau_s * as * ( 1. - exp( -70./tau_s ) )
     &                         * exp( -( t-70. )/tau_s )

            tstep( m ) = ecs( m ) * ( 1. - fact1 ) !! F2xCO2 / lambda
            t1ppt( m ) = ecs( m ) * df( m ) / erf( m )
     &                   * ( t - fact2 )
            if( t .gt. 70. ) then
               t1ppt( m ) = ecs( m ) * ( 1. - df( m )/erf( m )*fact3 )
            endif

            if( n .gt. 140 ) then
               tstep( m ) = ecs( m )
               t1ppt( m ) = xmiss
            else if( n .gt. 130 ) then
               tstep( m ) = xmiss
               t1ppt( m ) = xmiss
            endif

         enddo
         do m = 1, nvar
            write( 92 ) tstep( m )
         enddo
         do m = 1, nvar
            write( 92 ) t1ppt( m )
         enddo

         do m = 1, nvar
            tstep_bak( n,m ) = tstep( m )
            t1ppt_bak( n,m ) = t1ppt( m )
         enddo

         if( n .eq. 70 ) then
            write( 6,* )
     &           '    TCR (5%, 17%, mean, 83%, 95%) = '
            write( 6,* ) t1ppt
         endif

      enddo                     !! n
*
*     ECS & TCR (varying F and lambda, and epsiron & gamma)
*
      write( 6,* )
     &     ' @@@ ECS & TCR (varying F and lambda, and epsiron & gamma) '

      t = 0.
      tstep = 0.
      t1ppt = 0.
      do n = 1, nt
         t = dt * real( n-1 )

         do m = 1, nvar

            b = ( fdb( 3 ) + epsgamma( m ) ) / cs
     &           + epsgamma( m ) / cd / eps( m )
            b_ast = ( fdb( 3 ) + epsgamma( m ) ) / cs
     &           - epsgamma( m ) / cd / eps( m )
            delta = b**2 - 4. * ( fdb( 3 )*epsgamma( m ) )
     &           / ( cs * cd * eps( m ) )
            phi_f = cs * ( b_ast - sqrt( delta ) ) / 2. / epsgamma( m )
            phi_s = cs * ( b_ast + sqrt( delta ) ) / 2. / epsgamma( m )
            tau_f = cs * cd * eps( m ) * ( b - sqrt( delta ) )
     &           / ( 2.*fdb( 3 )*epsgamma( m ) )
            tau_s = cs * cd * eps( m ) * ( b + sqrt( delta ) )
     &           / ( 2.*fdb( 3 )*epsgamma( m ) )
            af = fdb( 3 ) / cs - 1. / tau_s
            af = af * ( tau_f * tau_s ) / ( tau_s - tau_f )
            as = 1. - af
            fact1 = af * exp( -t/tau_f )
     &           + as * exp( -t/tau_s )
            fact2 = tau_f * af * ( 1. - exp( -t/tau_f ) )
     &            + tau_s * as * ( 1. - exp( -t/tau_s ) )
            fact3 = tau_f * af * ( 1. - exp( -70./tau_f ) )
     &                         * exp( -( t-70. )/tau_f )
     &            + tau_s * as * ( 1. - exp( -70./tau_s ) )
     &                         * exp( -( t-70. )/tau_s )

            tstep( m ) = ecs( 3 ) * ( 1. - fact1 ) !! F2xCO2 / lambda
            t1ppt( m ) = ecs( 3 ) * df( 3 ) / erf( 3 )
     &                   * ( t - fact2 )
            if( t .gt. 70. ) then
               t1ppt( m ) = ecs( 3 ) * ( 1. - df( 3 )/erf( 3 )*fact3 )
            endif

            if( n .gt. 140 ) then
               tstep( m ) = ecs( m )
               t1ppt( m ) = xmiss
            else if( n .gt. 130 ) then
               tstep( m ) = xmiss
               t1ppt( m ) = xmiss
            endif

         enddo                  !! m
*
*     multiply uncertainty
*
         if( n .le. 130 ) then
            do m = 1, nvar
               x1 = tstep_bak( n,m ) - tstep( 3 )
               y1 = tstep( m ) - tstep( 3 )
               z1 = sqrt( x1**2 + y1**2 )
               x2 = t1ppt_bak( n,m ) - t1ppt( 3 )
               y2 = t1ppt( m ) - t1ppt( 3 )
               z2 = sqrt( x2**2 + y2**2 )
               if( m .lt. 3 ) then
                  tstep( m ) = tstep( 3 ) - z1
                  t1ppt( m ) = t1ppt( 3 ) - z2
               else if( m .gt. 3 ) then
                  tstep( m ) = tstep( 3 ) + z1
                  t1ppt( m ) = t1ppt( 3 ) + z2
               endif
            enddo
         endif

         do m = 1, nvar
            write( 93 ) tstep( m )
         enddo
         do m = 1, nvar
            write( 93 ) t1ppt( m )
         enddo
         do m = 1, nvar
            if( n .lt. 130 ) then
               write( 93 ) dum( m )
            elseif( n .lt. 140 ) then
               write( 93 ) tcrout( m )
            elseif( n .eq. 140 ) then
               write( 93 ) dum( m )
            else
               write( 93 ) ecs( m )
            endif
         enddo

         if( n .eq. 70 ) then
            do m = 1, nvar
               tcrout( m ) = t1ppt( m )
            enddo
            write( 6,* )
     &           '    TCR (5%, 17%, mean, 83%, 95%) = '
            write( 6,* ) t1ppt
         endif

      enddo                     !! n
*
      close( 91 )
      close( 92 )
      close( 93 )

      stop
      end
********************************
* .ctl file (copy and delete * below)
*
* ZDEF:
* z=1  5%ile
* z=2  17%ile
* z=3  mean
* z=4  83%ile
* z=5  95%ile
* TDEF: year
* t=>141 is ECS
********************************
*dset ^erf_evolution.grd
*options sequential
*undef -999.
*title ERF
*ydef 1     linear -90.000000 1.25
*xdef 1     linear 0.000000 1.250000
*zdef 5     linear 1 1
*tdef 201  linear 00Z01Jan0000 1yr
*vars 2
*f1     5 99 ERF 2xCO2
*f2     5 99 ERF time dependent
*ENDVARS
********************************
*dset ^ecs_evolution.grd
*options sequential
*undef -999.
*title ECS/TCR
*ydef 1     linear -90.000000 1.25
*xdef 1     linear 0.000000 1.250000
*zdef 5     linear 1 1
*tdef 201  linear 00Z01Jan000 1yr
*vars 2
*t1     5 99 temperature response to 2xCO2
*t2     5 99 temperature response to 1% increase
*ENDVARS
********************************
*dset ^tcr_evolution.grd
*options sequential
*undef -999.
*title TCR
*ydef 1     linear -90.000000 1.25
*xdef 1     linear 0.000000 1.250000
*zdef 5     linear 1 1
*tdef 201  linear 00Z01Jan000 1yr
*vars 3
*t1     5 99 temperature response to 2xCO2
*t2     5 99 temperature response to 1% increase
*tf     5 99 temperature response (TCR & ECS)
*ENDVARS


! Subroutine SNOEM calculates nitric oxide zonal mean altitude profile
! as function of magnetic latitude for specified day of year, Kp, and F10.7.

! The NOEM empirical model is based on data from the SNOE ultraviolet
! spectrometer during 1998-2000, using empirical orthogonal function analysis.
! Altitude range is from 100 to 150 km.

! Marsh et al., JGR, 109, A07301, doi:10.1029/2003JA010199, 2004.

! Adapted by Stan Solomon, 5/2014, from IDL and F90 code supplied by Dan Marsh.
! Minor revisions to make compatible with gfortran, SCS, 4/2017

    subroutine snoem(doy, kp, f107, z, mlat, nozm)

      use cglow,only: data_dir

      implicit none

      integer,intent(in) :: doy
      real,intent(in) :: kp, f107
      real,intent(out) :: z(16), mlat(33), nozm(33,16)

      real, save :: zin(16)          ! altitude grid
      real, save :: mlatin(33)       ! magnetic latitude grid
      real, save :: no_mean(33,16)   ! mean nitric oxide distribution
      real, save :: eofs(33,16,3)    ! empirical orthogonal functions
      real :: theta0                 ! day number in degrees
      real :: dec                    ! solar declination angle
      real :: m1, m2, m3             ! coefficients for first 3 eofs
      real, parameter :: pi=3.1415926536
      integer, save :: ifirst=1
      integer :: j, k, n
      character(len=1024) :: filepath

!... read eof file on first call

      if (ifirst == 1) then
        ifirst = 0
        filepath = trim(data_dir)//'snoem_eof.dat'
        open(unit=1,file=filepath,status='old',action='read')
        read(1,*) (zin(k),k=1,16)
        read(1,*) (mlatin(j),j=1,33)
        read(1,*) ((no_mean(j,k),j=1,33),k=1,16)
        read(1,*) (((eofs(j,k,n),j=1,33),k=1,16),n=1,3)
        close(unit=1)
      endif

!... calculate coefficients (m1 to m3) for eofs based on geophysical parameters

!... eof1 - kp

      m1 =  kp * 0.689254 - 1.53366

!... eof2 - declination

      theta0 = 2.*pi * float(doy - 1) / 365.

      dec = 0.006918 &
          - 0.399912 * cos(theta0)   + 0.070257 * sin(theta0) &
          - 0.006758 * cos(2*theta0) + 0.000907 * sin(2*theta0) &
          - 0.002697 * cos(3*theta0) + 0.001480 * sin(3*theta0)

      dec = dec * 180./pi

      m2 = -0.31978 + dec*0.097309 + dec**2*0.00048979 - dec**3*0.00010360

!... eof3 - f107

      m3 =  alog10(f107) * 6.35777 - 13.8163

!... zonal mean distrib. is sum of mean and eofs

      do k=1,16
        do j=1,33
          nozm(j,k) = no_mean(j,k)-m1*eofs(j,k,1)+m2*eofs(j,k,2)-m3*eofs(j,k,3)
        end do
      end do

      z(:) = zin(:)
      mlat(:) = mlatin(:)

      return

    end subroutine snoem


!     bar 2nd piola-kichhoff
subroutine r_spiola(xmj,dxmj,xto)
  use r_common
  use solid_variables, only: nsd_solid

  implicit none

  real(8) :: xto(nsd_solid,nsd_solid)
  real(8) :: PK2str_tens(nsd_solid,nsd_solid)

  integer :: i,isd,jsd,ksd

  real(8) :: xmj(3),dxmj(3,2*nsd_solid)
  do i=1,2*nsd_solid
      bPK2str(i) = rc1*dxmj(1,i) + rc2*dxmj(2,i) + rk*(xmj(3)-1.0d0)*dxmj(3,i)
      PK2str(i) = bPK2str(i)
  enddo

  threedim: if (nsd_solid .eq. 3) then

	PK2str_tens(1,1) = PK2str(1)
	PK2str_tens(1,2) = PK2str(6)
	PK2str_tens(1,3) = PK2str(5)
	PK2str_tens(2,1) = PK2str(6)
	PK2str_tens(2,2) = PK2str(2)
	PK2str_tens(2,3) = PK2str(4)
	PK2str_tens(3,1) = PK2str(5)
	PK2str_tens(3,2) = PK2str(4)
	PK2str_tens(3,3) = PK2str(3)

  endif  threedim

  twodim: if (nsd_solid .eq. 2) then

	PK2str_tens(1,1) = PK2str(1)
	PK2str_tens(1,2) = PK2str(3)
	PK2str_tens(2,1) = PK2str(3)
	PK2str_tens(2,2) = PK2str(2)

  endif twodim

  do isd = 1,nsd_solid
     do jsd = 1,nsd_solid
        PK1str_tens(isd,jsd) = 0.0d0
        do ksd = 1,nsd_solid
!           PK1str_tens(isd,jsd) = PK1str_tens(isd,jsd) + PK2str_tens(isd,ksd)*xto(jsd,ksd)
	    PK1str_tens(isd,jsd) = PK1str_tens(isd,jsd) + PK2str_tens(ksd,isd)*xto(jsd,ksd)
		enddo
     enddo
  enddo

  return
end subroutine r_spiola


module EVTS_EDROMO
! Description:
!    Contains event functions for the EDromo formulation in double precision.
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

use KINDS, only: ik,dk,qk

contains

subroutine DEDROMO_EVT(neq,phi,z,ng,roots)
! Description:
!    Finds roots to stop the integration for the EDromo formulation.
!
! ==============================================================================

! MODULES
use AUXILIARIES, only: JD_next,JD_stop
use CONSTANTS,   only: TU,secsPerDay
use SETTINGS,    only: flag_time_EDr

! VARIABLES
implicit none
! Arguments IN
integer(ik),intent(in)   ::  neq
integer(ik),intent(in)   ::  ng
real(dk),intent(in)      ::  phi
real(dk),intent(in)      ::  z(1:neq)
! Arguments OUT
real(dk),intent(out)     ::  roots(1:ng)

! Locals
real(dk)  ::  zeta
real(dk)  ::  t         ! Current time [-]

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

! Get time
zeta  = z(1)*sin(phi) - z(2)*cos(phi)
if ( flag_time_EDr == 0_ik ) then
    ! Physical time
    t = z(8)
elseif  ( flag_time_EDr == 1_ik ) then
    ! Constant time element
    t = z(8) - z(3)**1.5_dk*(zeta - phi)
elseif  ( flag_time_EDr == 2_ik ) then
    ! Linear time element
    t = z(8) - z(3)**1.5_dk*zeta
end if

! ==============================================================================
! 01. Next timestep
! ==============================================================================

roots(1) = t - JD_next*secsPerDay*TU

! ==============================================================================
! 02. Stop integration
! ==============================================================================

roots(2) = t - JD_stop*secsPerDay*TU

end subroutine DEDROMO_EVT

end module EVTS_EDROMO