! { dg-do  run }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }

program main
  implicit none
  real(kind=8), ALLOCATABLE :: a(:,:), b(:,:), v1(:), v2(:)
  real(kind=8), dimension(3,3) :: v1res, v2res
  integer :: n, i

  data v1res/ 442.d0,   -492.d0,   586.d0, &
            -4834.d0,   5694.d0, -7066.d0, &
            13042.d0, -15450.d0, 19306.d0 /

  data v2res/ 5522.d0,  -6310.d0,   7754.d0, &
             -7794.d0,   8982.d0, -11034.d0, &
             10490.d0, -12160.d0,  14954.d0 /
  n = 3

  ALLOCATE(a(N,N),b(N,N),v1(N), v2(N))

  a = reshape([((-1)**i*(-i-5)*(i+3)+5,i=1,n**2)], shape(a))
  b = reshape([((-1)**i*(-i-1)*(i-2),i=1,n**2)], shape(a))

  DO i=1,N
     v1 = MATMUL(a,b(:,i))
     if (any(abs(v1-v1res(:,i)) > 1e-10)) STOP 1

     v2 = MATMUL(a,b(i,:))
     if (any(abs(v2-v2res(:,i)) > 1e-10)) STOP 2

  ENDDO

END program main
! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "original" } }


PROGRAM Test_RegCubicSpline

      ! This program is used to test the routines to interpolate regularly spaced arrays using cubic splines.

   USE                                    :: NWTC_Library

   IMPLICIT                                  NONE

      ! Type declarations.

   INTEGER, PARAMETER                        :: AryLen     = 10               ! Index into the arrays.

   REAL(ReKi)                                :: X                             ! The value to interpolate for.
   REAL(ReKi)                                :: Y                             ! The interpolated value from   regularly spaced data.
   REAL(ReKi)                                :: Z                             ! The interpolated value from irregularly spaced data.

   INTEGER                                   :: I                             ! Index into the arrays.
   INTEGER(IntKi)                            :: ErrStat                       ! Error status.

   CHARACTER(4096)                           :: ErrMsg                        ! Error message.

   TYPE(   CubSplineType)                    ::    CubSplineData              ! Derived type to hold data for irregularly spaced cubic splines.
   TYPE(RegCubSplineType)                    :: RegCubSplineData              ! Derived type to hold data for regularly spaced cubic splines.

      ! Initialize the NWTC Library.

   CALL NWTC_Init ( 'Test_RegCubicSpline', 'v1.00.00, 17-May-2013', EchoLibVer=.FALSE. )
   CALL WrScr     ( NewLine//' Running Test_RegCubicSpline (v1.00.00, 17-May-2013)' )

      ! Set up the regularly spaced data to be interpolated.

   RegCubSplineData%NumPts = 10

   ALLOCATE ( RegCubSplineData%XAry( RegCubSplineData%NumPts ), STAT=ErrStat )
   IF ( ErrStat /= 0 )  THEN
      CALL ProgAbort ( ' >> Error allocating memory for the RegCubSplineData%XAry array in Test_RegCubicSpline.', .FALSE., 1.0, &
                       ErrStat )
   ENDIF

   ALLOCATE ( RegCubSplineData%YAry( RegCubSplineData%NumPts ), STAT=ErrStat )
   IF ( ErrStat /= 0 )  THEN
      CALL ProgAbort ( ' >> Error allocating memory for the RegCubSplineData%YAry array in Test_RegCubicSpline.', .FALSE., 1.0, &
                       ErrStat )
   ENDIF

   ALLOCATE ( RegCubSplineData%Coef( RegCubSplineData%NumPts-1, 0:3 ), STAT=ErrStat )
   IF ( ErrStat /= 0 )  THEN
      CALL ProgAbort ( ' >> Error allocating memory for the RegCubSplineData%Coef array in Test_RegCubicSpline.', .FALSE., 1.0, &
                       ErrStat )
   ENDIF

      ! Set up the irregularly spaced data to be interpolated.

   CubSplineData%NumPts = RegCubSplineData%NumPts

   ALLOCATE ( CubSplineData%XAry( CubSplineData%NumPts ), STAT=ErrStat )
   IF ( ErrStat /= 0 )  THEN
      CALL ProgAbort ( ' >> Error allocating memory for the CubSplineData%XAry array in Test_RegCubicSpline.', .FALSE., 1.0, &
                       ErrStat )
   ENDIF

   ALLOCATE ( CubSplineData%YAry( CubSplineData%NumPts ), STAT=ErrStat )
   IF ( ErrStat /= 0 )  THEN
      CALL ProgAbort ( ' >> Error allocating memory for the CubSplineData%YAry array in Test_RegCubicSpline.', .FALSE., 1.0, &
                       ErrStat )
   ENDIF

   ALLOCATE ( CubSplineData%Coef( CubSplineData%NumPts-1, 0:3 ), STAT=ErrStat )
   IF ( ErrStat /= 0 )  THEN
      CALL ProgAbort ( ' >> Error allocating memory for the CubSplineData%Coef array in Test_RegCubicSpline.', .FALSE., 1.0, &
                       ErrStat )
   ENDIF

      ! Create an array to interpolate.

   PRINT *

   DO I=1,AryLen
      RegCubSplineData%XAry(I) = REAL( 2*I - 2 )*Pi/REAL( AryLen - 1 )           ! Values from 0 to 2*Pi in steps of 2*Pi/(AryLen-1)
      RegCubSplineData%YAry(I) = SIN( RegCubSplineData%XAry(I) )
         CubSplineData%XAry(I) = RegCubSplineData%XAry(I)
         CubSplineData%YAry(I) = RegCubSplineData%YAry(I)
      PRINT '(I5,1X,F12.4)', NINT( R2D*RegCubSplineData%XAry(I) ), RegCubSplineData%YAry(I)
   ENDDO ! I

      ! Compute the coefficients of the piecewise polynomials for the regularly-spaced data.

   CALL RegCubicSplineInit ( RegCubSplineData%NumPts, RegCubSplineData%XAry, RegCubSplineData%YAry, RegCubSplineData%DelX &
                           , RegCubSplineData%Coef, ErrStat, ErrMsg )
   IF ( ErrStat == ErrID_Fatal )  THEN
      CALL ProgAbort ( ErrMsg, .FALSE., 1.0, ErrStat )
   ELSEIF ( ErrStat /= ErrID_None )  THEN
      CALL WrScr ( ErrMsg )
   ENDIF

      ! Compute the coefficients of the piecewise polynomials for the irregularly-spaced data.

   CALL CubicSplineInit ( CubSplineData%NumPts, CubSplineData%XAry, CubSplineData%YAry &
                                              , CubSplineData%Coef, ErrStat, ErrMsg )
   IF ( ErrStat == ErrID_Fatal )  THEN
      CALL ProgAbort ( ErrMsg, .FALSE., 1.0, ErrStat )
   ELSEIF ( ErrStat /= ErrID_None )  THEN
      CALL WrScr ( ErrMsg )
   ENDIF

      ! Write out the interpolated values for both sets of interpolated data.

   PRINT *

   DO I=0,360,1
      X = REAL( I )*D2R
      Y = RegCubicSplineInterp( X, RegCubSplineData%NumPts, RegCubSplineData%XAry, RegCubSplineData%YAry &
                                 , RegCubSplineData%DelX  , RegCubSplineData%Coef, ErrStat, ErrMsg )
      Z = CubicSplineInterp   ( X,    CubSplineData%NumPts,    CubSplineData%XAry,    CubSplineData%YAry &
                                                          ,    CubSplineData%Coef, ErrStat, ErrMsg )
      IF ( ErrStat == ErrID_Fatal )  THEN
         CALL ProgAbort ( ErrMsg, .FALSE., 1.0, ErrStat )
      ELSEIF ( ErrStat /= ErrID_None )  THEN
         CALL WrScr ( ErrMsg )
      ENDIF
      PRINT '(I5,2(1X,F12.4))', I, Y, Z
   ENDDO ! I

   CALL NormStop

END PROGRAM Test_RegCubicSpline


subroutine init_phi(lo, hi, phi, philo, phihi, dx, prob_lo, prob_hi) bind(C, name="init_phi")
  use amrex_fort_module, only : amrex_real

  implicit none

  integer, intent(in) :: lo(2), hi(2), philo(2), phihi(2)
  real(amrex_real), intent(inout) :: phi(philo(1):phihi(1),philo(2):phihi(2))
  real(amrex_real), intent(in   ) :: dx(2)
  real(amrex_real), intent(in   ) :: prob_lo(2)
  real(amrex_real), intent(in   ) :: prob_hi(2)

  integer          :: i,j
  double precision :: x,y,r2,tupi
  tupi=3.14159265358979323846d0*2d0

  do j = lo(2), hi(2)
     y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
     do i = lo(1), hi(1)
        x = prob_lo(1) + (dble(i)) * dx(1)

        r2 = ((x-0.25d0)**2 + (y-0.25d0)**2) / 0.01d0

        phi(i,j) = sin(x*tupi)
     end do
  end do

end subroutine init_phi

subroutine err_phi(lo, hi, phi, philo, phihi, dx, prob_lo, prob_hi,time) bind(C, name="err_phi")

  use amrex_fort_module, only : amrex_real

  implicit none

  integer, intent(in) :: lo(2), hi(2), philo(2), phihi(2)
  real(amrex_real), intent(inout) :: phi(philo(1):phihi(1),philo(2):phihi(2))
  real(amrex_real), intent(in   ) :: dx(2)
  real(amrex_real), intent(in   ) :: prob_lo(2)
  real(amrex_real), intent(in   ) :: prob_hi(2)
  real(amrex_real), intent(in   ) :: time

  integer          :: i,j
  double precision :: x,y,r2,sym,tupi

  tupi=3.14159265358979323846d0*2d0
  sym=(-2.0d0+2.0d0*cos(tupi*dx(1)))/(dx(1)*dx(1))
!  sym=(-30.0d0+32.0d0*cos(tupi*dx(1))-2.0d0*cos(2.0d0*tupi*dx(1)))/(12.0d0*dx(1)*dx(1))
!  print *,Tfin,tupi,sym
  do j = lo(2), hi(2)
     y = prob_lo(2) + (dble(j)+0.5d0) * dx(2) +0.0d0*time
     do i = lo(1), hi(1)
        !        x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)
        x = prob_lo(1) + (dble(i)) * dx(1) +0.0d0*time

        r2 = ((x-0.25d0)**2 + (y-0.25d0)**2) / 0.01d0

        phi(i,j) = phi(i,j)-sin(x*tupi)*exp(0.1d0*time*sym)
     end do
  end do

end subroutine err_phi


program Roman_decode
  implicit none

  write(*,*) decode("MCMXC"), decode("MMVIII"), decode("MDCLXVI")

contains

function decode(roman) result(arabic)
  character(*), intent(in) :: roman
  integer :: i, n, lastval, arabic

  arabic = 0
  lastval = 0
  do i = len(roman), 1, -1
    select case(roman(i:i))
      case ('M','m')
        n = 1000
      case ('D','d')
        n = 500
      case ('C','c')
        n = 100
      case ('L','l')
        n = 50
      case ('X','x')
        n = 10
      case ('V','v')
        n = 5
      case ('I','i')
        n = 1
      case default
        n = 0
    end select
    if (n < lastval) then
      arabic = arabic - n
    else
      arabic = arabic + n
    end if
    lastval = n
  end do
end function decode
end program Roman_decode


      SUBROUTINE jacobi(N,A)
      INTEGER N,T,I

      REAL*8 A(N,N)

      DO 10, T=2,100
         DO 20, I=2,N-1
            A(T,I)=A(T-1,I-1)+A(T-1,I)+A(T-1,I+1)
 20      CONTINUE
 10   CONTINUE

      END


	FUNCTION PR_PMST  ( thte, tmpk )
C************************************************************************
C* PR_PMST 								*
C*									*
C* This function computes parcel PRES from THTE and TMPC, where TMPC	*
C* is the parcel temperature at PRES on a specified moist adiabat	*
C* (THTE). The computation is an iterative Newton-Raphson technique	*
C* of the form:								*
C*	                                                                *
C*   x = x(guess) + [ f( x ) - f( x(guess) ) ] / f'( x(guess) )		*
C*	                                                                *
C*     f' is approximated with finite differences			*
C*     f' = [ f( x(guess) + 1 ) - f( x(guess) ) ] / 1			*
C*	                                                                *
C* Convergence is not guaranteed for extreme input values.  If the	*
C* computation does not converge after 100 iterations, the missing	*
C* data value will be returned.						*
C*	                                                                *
C* REAL PR_PMST  ( THTE, TMPK )						*
C*									*
C* Input parameters:							*
C*	THTE   		REAL		Equivalent potential temp in K	*
C*	TMPK		REAL		Parcel temperature in Kelvin	*
C*									*
C* Output parameters:							*
C*	PR_PMST       	REAL    	Pressure in millibars		*
C**									*
C* Log:									*
C* T. Lee/GSC		 1/00	Created					*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
	LOGICAL		done
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( thte ) .or. ERMISS ( tmpk )
     +	      .or. ( thte .le. 0. ) ) THEN
	    PR_PMST = RMISSD
	    RETURN
	END IF
C
C*	Set convergence and initial guess of pressure.
C
	epsi = .01
	tmpc = PR_TMKC ( tmpk )
	pgdn = 1000. * ( tmpk / thte ) ** AKAPPA
C
C*	Set a limit of 100 iterations.  Compute TEDN and TEUP, the
C*	THTE's at one degree above the guess temperature.
C
	done = .false.
	i = 1
	DO  WHILE ( .not. done )
	  pgup =  pgdn + 1.
	  tedn = PR_THTE ( pgdn, tmpc, tmpc )
	  teup = PR_THTE ( pgup, tmpc, tmpc )
C
C*	  Check THTE.
C
	  IF  ( ( ERMISS ( tedn ) ) .or. ( ERMISS ( teup ) ) )  THEN
	      PR_PMST = RMISSD
	      RETURN
	  END IF
C
C*	  Compute the correction; return on convergence.
C
	  cor  = ( thte - tedn ) / ( teup - tedn )
	  pgdn = pgdn + cor
	  IF  ( ABS ( cor ) .lt. epsi )  THEN
	      PR_PMST = pgdn
	      RETURN
	  END IF
	  i = i + 1
	  IF  ( i .gt. 100 ) done = .true.
	END DO
C
C*	Failed to converge; return missing.
C
	PR_PMST = RMISSD
C*
	RETURN
	END


program barrier_breach
implicit none

! Allocate variables
integer, parameter :: dp = selected_real_kind(15, 307)
real, allocatable, dimension(:) :: bathy, row
integer :: i, j, mx, my , t1, t2, rowidx, colidx
real :: xll, yll, cellsize, nodata_value, amp_max, dx, sigma, h0, x1, x2, col, stepx, stepy
real :: time(10) != (/(i, i=0,9, 1)/)
real, dimension(10) :: amp
integer, dimension(10) :: zero_array
integer, dimension(10) :: one_array
real, dimension(600) :: y
real,allocatable, dimension(:,:) :: X_mesh, Y_mesh, breach
real, dimension(500) :: x
CHARACTER(*), PARAMETER :: fileplace = "/home/claw/clawpack-v5.5.0/geoclaw/scratch/"
! Determine number of increments for X_mesh and Y_mesh
stepx = (100.0 + 100.0)/ 499.0
stepy = (60e3 / 599)

! fill x and y like np.linspace
x = (/((i-1)*stepx -100.0, i=1,500)/)
y = (/((i-1)* stepy + 0, i=1, 600)/)
print *, fileplace//'test.tt3'
! Open bathy file and read header to get size
! OPEN(unit=10, status="old",file=fileplace//"file1.dat")
open(10, file=fileplace//'test.tt3', status='old')
	read(10,*) mx
	read(10,*) my
	read(10,*) xll
	read(10,*) yll
	read(10,*) cellsize
	read(10,*) nodata_value
close(10)

! Declare Amplitude array based on time steps
t1 = 3.0
t2 = 6.0
amp_max = 5.0
dx = 10.0/9.0
time(1:10) = [(0 + ((i-1)*dx),i=1, 10)]

zero_array = 0
one_array = 1

do i = 1, 10
	if (time(i) < t1) then
		amp(i) = zero_array(i)
	elseif (t1 <= time(i) .and. time(i) < t2) then
		amp(i) =  (amp_max / (t2 - t1) * (time(i) - t1))
	elseif (t2 <= time(i)) then
		amp(i) = one_array(i) * amp_max
end if

end do
! Open and read bathymetry into memory
! Skip header and declare bathy matrix
allocate(bathy(1:mx*my))
open(11, file='test.tt3')
do i=1,6
    read(11, *)
end do
! Read bathy data into array
do j=1, my !*nrows
   read(11, *) (bathy((j-1)* mx + i),i=1,mx)
end do

! fill x and y matrices a la np.meshgrid
allocate(X_mesh(size(y), size(x)))
allocate(Y_mesh(size(y), size(x)))
do i=1, size(y)
	do j=1, size(x)
		X_mesh(i,j) = x(j)
		Y_mesh(i,j) = y(i)
	end do
end do
! Add breach parameters
x1 = -25.0
x2 = 25.0
sigma = 10.0
h0 = 10.0
allocate(breach(size(X_mesh, 1), size(X_mesh, 2)))
! Initialize breach to match initial height
do i= 1, size(X_mesh,2)
	breach(:,i) = h0
	do j = 1, size(X_mesh,1)
		breach(j,:) = h0
	end do
end do
! Breach the barrier island depending on time
do i = 1, size(amp)
	do rowidx = 1, size(X_mesh, 1)
		row = X_mesh(rowidx,:)
			do colidx = 1, size(X_mesh, 2)
				col = X_mesh(rowidx, colidx)
				if (col >= x1 .and. col <= x2) then
					breach(rowidx, colidx) = breach(rowidx, colidx) &
					- (amp(i) * exp(-X_mesh(rowidx, colidx)**2/(sigma**2)) &
					* 0.1 * Y_mesh(rowidx, colidx))
				end if
			end do
	end do
end do

end program barrier_breach


!==========================================================================
elemental function gsw_t_freezing_poly (sa, p, saturation_fraction, polynomial)
!==========================================================================
!
!  Calculates the in-situ temperature at which seawater freezes from a
!  computationally efficient polynomial.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!  saturation_fraction = the saturation fraction of dissolved air in
!                        seawater
!
!  t_freezing = in-situ temperature at which seawater freezes.    [ deg C ]
!               (ITS-90)
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sso

use gsw_mod_freezing_poly_coefficients

use gsw_mod_toolbox, only : gsw_ct_freezing_poly, gsw_t_from_ct

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p
real (r8), intent(in), optional :: saturation_fraction
logical, intent(in), optional :: polynomial

real (r8) :: gsw_t_freezing_poly

real (r8) :: p_r, sa_r, x, ctf, sfrac
logical :: direct_poly

if (present(polynomial)) then
   direct_poly = polynomial
else
   direct_poly = .false.
end if

if (.not. direct_poly) then

   if (present(saturation_fraction)) then
      sfrac = saturation_fraction
   else
      sfrac = 1.0_r8
   end if

   ctf = gsw_ct_freezing_poly(sa,p,sfrac)
   gsw_t_freezing_poly = gsw_t_from_ct(sa,ctf,p)

else

   ! Alternative calculation ...
   sa_r = sa*1e-2_r8
   x = sqrt(sa_r)
   p_r = p*1e-4_r8

   gsw_t_freezing_poly = t0 &
       + sa_r*(t1 + x*(t2 + x*(t3 + x*(t4 + x*(t5 + t6*x))))) &
       + p_r*(t7 + p_r*(t8 + t9*p_r)) &
       + sa_r*p_r*(t10 + p_r*(t12 + p_r*(t15 + t21*sa_r)) &
       + sa_r*(t13 + t17*p_r + t19*sa_r) &
       + x*(t11 + p_r*(t14 + t18*p_r) + sa_r*(t16 + t20*p_r + t22*sa_r)))

   if (.not. present(saturation_fraction)) return

   ! Adjust for the effects of dissolved air
   gsw_t_freezing_poly = gsw_t_freezing_poly - &
                  saturation_fraction*(1e-3_r8)*(2.4_r8 - sa/(2.0_r8*gsw_sso))
end if

return
end function

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


      subroutine ire_dph(ctfmp,n_K,n_alpha,n_beta,n_divbeta,n_phi,nm1_ph
     &i,np1_phi,Nx,ht,hx,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 ctfmp(Nx)
      real*8 n_K(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_divbeta(Nx)
      real*8 n_phi(Nx)
      real*8 nm1_phi(Nx)
      real*8 np1_phi(Nx)
      real*8 res
      real*8 qb
      res = 0.0D0
      do i=2, Nx-1, 1
      qb = 0.5000000000000000D0 * (-0.1D1 * nm1_phi(i) + np1_phi(i)) / h
     #t + 0.5000000000000000D0 / ctfmp(i) * (n_phi(i - 1) - 0.1D1 * n_ph
     #i(i + 1)) / hx * n_beta(i) + 0.1666666666666667D0 * n_alpha(i) * n
     #_K(i) - 0.1666666666666667D0 * n_divbeta(i)
      res = res + qb**2
      end do
      res = sqrt(res/(1*Nx))
      END


subroutine step_forwards
  use systemparams
  implicit none
  tt(:) = 0.0
  do i=1,nx+1
     if(i/=1.and.i/=nx+1) then
        tt(i) = (deltax(i)*deltax(i)*C_tot(i))/(2.0*0.5*diff*((1.0-x(i+1)*x(i+1)) + (1.0-x(i)*x(i))))
     else
        tt(i) = 1.0e30
     end if
  end do
 dt=0.9*minval(tt)
end subroutine step_forwards


    Program zunghr_example

!     ZUNGHR Example Program Text

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

!     .. Use Statements ..
      Use blas_interfaces, Only: zgemm
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: zgehrd, zhseqr, zlange, zunghr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: alpha, beta
      Real (Kind=dp) :: norm
      Integer :: i, ifail, info, lda, ldc, ldd, ldz, lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), c(:, :), d(:, :), tau(:), &
        w(:), work(:), z(:, :)
      Real (Kind=dp), Allocatable :: rwork(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: cmplx, epsilon
!     .. Executable Statements ..
      Write (nout, *) 'ZUNGHR Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldc = n
      ldd = n
      ldz = n
      lwork = 64*(n-1)
      Allocate (a(lda,n), c(ldc,n), d(ldd,n), rwork(lda), tau(n), w(n), &
        work(lwork), z(ldz,n))

!     Read A from data file
      Read (nin, *)(a(i,1:n), i=1, n)

!     Store A in D
      d(1:ldd, 1:n) = a(1:lda, 1:n)

!     Print matrix A
!     ifail: behaviour on error exit
!            =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, a, &
        lda, 'Bracketed', 'F7.4', 'Matrix A', 'Integer', rlabs, 'Integer', &
        clabs, 80, 0, ifail)
      Write (nout, *)
      Flush (nout)

!     Reduce A to upper Hessenberg form H = (Q**H)*A*Q

      Call zgehrd(n, 1, n, a, lda, tau, work, lwork, info)

!     Copy A into Z
      z(1:n, 1:n) = a(1:n, 1:n)

!     Form Q explicitly, storing the result in Z
      Call zunghr(n, 1, n, z, ldz, tau, work, lwork, info)

!     Calculate the Schur factorization of H = Y*T*(Y**H) and form
!     Q*Y explicitly, storing the result in Z

!     Note that A = Z*T*(Z**H), where Z = Q*Y

      Call zhseqr('Schur form', 'Vectors', n, 1, n, a, lda, w, z, ldz, work, &
        lwork, info)

!     Compute A - Z*T*Z^H from Schur factorization of A, and store in matrix D
      alpha = cmplx(1, kind=dp)
      beta = cmplx(0, kind=dp)
      Call zgemm('N', 'N', n, n, n, alpha, z, ldz, a, lda, beta, c, ldc)
      alpha = cmplx(-1, kind=dp)
      beta = cmplx(1, kind=dp)
      Call zgemm('N', 'C', n, n, n, alpha, c, ldc, z, ldz, beta, d, ldd)

!     Find norm of matrix D and print warning if it is too large
      norm = zlange('O', ldd, n, d, ldd, rwork)
      If (norm>epsilon(1.0E0_dp)**0.5_dp) Then
        Write (nout, *) 'Norm of A-(Z*T*Z^H) is much greater than 0.'
        Write (nout, *) 'Schur factorization has failed.'
      Else
!       Print eigenvalues.
        Write (nout, *) 'Eigenvalues'
        Write (nout, 100)(w(i), i=1, n)
      End If

100   Format ((3X,4(' (',F7.4,',',F7.4,')',:)))

    End Program


	SUBROUTINE DESPLN ( np, xpt, ypt, chord, xtng, ytng, npt,
     +			    xcv, ycv, iret )
C************************************************************************
C* DESPLN								*
C*									*
C* This subroutine evalutes a smooth curve using cubic splines.		*
C*									*
C* DESPLN ( NP, XPT, YPT, CHORD, XTNG, YTNG, NPT, XCV, YCV, IRET )	*
C*									*
C* Input parameters:							*
C*	NP		INTEGER		Number of input points		*
C*	XPT (NP)	REAL		X input coordinates		*
C*	YPT (NP)	REAL		Y input coordinates		*
C*	CHORD (NP)	REAL		Chord lengths			*
C*	XTNG (NP)	REAL		X comp of tangent vectors	*
C*	YTNG (NP)	REAL		Y comp of tangent vectors	*
C*	NPT (NP)	INTEGER		Number of points per segment	*
C*									*
C* Output parameters:							*
C*	XCV (NOUT)	REAL		X evaluated coordinates		*
C*	YCV (NOUT)	REAL		Y evaluated coordinates		*
C*	IRET		INTEGER		Return code			*
C*									*
C**									*
C* S. Jacobs/NCEP	 2/98						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	INTEGER		npt (*)
	REAL		xpt (*), ypt (*), chord(*), xtng (*), ytng (*),
     +			xcv (*), ycv (*)
C------------------------------------------------------------------------
	iret = 0
C
	k = 1
	DO  i = 1, np-1
C
C*	    Compute the coefficents for the polynomial.
C
	    f11 = xpt(i)
	    f12 = ypt(i)
C
	    f21 = xtng(i)
	    f22 = ytng(i)
C
	    q   = 1 / chord(i)
	    qs  = q ** 2
C
	    q1  = q  * 3.0 * ( xpt(i+1) - xpt(i) )
	    f31 = q  * ( q1 - 2.0*xtng(i) - xtng(i+1) )
	    q1  = q  * 3.0 * ( ypt(i+1) - ypt(i) )
	    f32 = q  * ( q1 - 2.0*ytng(i) - ytng(i+1) )
C
	    q1  = q  * 2.0 * ( xpt(i) - xpt(i+1) )
	    f41 = qs * ( q1 + xtng(i) + xtng(i+1) )
	    q1  = q  * 2.0 * ( ypt(i) - ypt(i+1) )
	    f42 = qs * ( q1 + ytng(i) + ytng(i+1) )
C
C*	    Compute the points along the smooth curve.
C
	    xcv(k) = xpt(i)
	    ycv(k) = ypt(i)
	    k = k + 1
	    IF  ( npt(i) .ne. 0 )  THEN
		delt = chord(i) / FLOAT(npt(i)+1)
		tt = 0.0
		DO  j = 1, npt(i)
		    tt = tt + delt
		    xcv(k) = f11 + f21*tt + f31*(tt**2) + f41*(tt**3)
		    ycv(k) = f12 + f22*tt + f32*(tt**2) + f42*(tt**3)
		    k = k + 1
		END DO
	    END IF
	END DO
C
	xcv(k) = xpt(np)
	ycv(k) = ypt(np)
C*
	RETURN
	END


! this subroutine is used to calculate surface state using             !
! green's function method  ---  J.Phys.F.Met.Phys.15(1985)851-858      !
! Using eq.(11) and eq.(13) (16), (17)
! History:
!         by Quan Sheng Wu on Oct/17/2012                                !
!+---------+---------+---------+---------+---------+---------+--------+!
  subroutine surfgreen_1985(omega,GLL,GRR,GB,H00,H01,ones)
     use para
     implicit none

     ! inout variables
     ! the factor 2 is induced by spin
     ! energy hbar omega
     real(Dp),intent(in) :: omega

     ! H00 Hamiltonian between nearest neighbour-quintuple-layers
     complex(Dp),intent(in) :: H00(Ndim,Ndim)

     ! H01 Hamiltonian between next-nearest neighbour-quintuple-layers
     complex(Dp),intent(in) :: H01(Ndim,Ndim)

     ! temp hamiltonian

     complex(Dp),intent(in)   :: ones(Ndim,Ndim)

     ! surface green function
     complex(Dp),intent(inout)  :: GLL(Ndim,Ndim)
     complex(Dp),intent(inout)  :: GRR(Ndim,Ndim)

     !> bulk green's function
     complex(Dp),intent(inout)  :: GB(Ndim,Ndim)

     ! >> local variables
     ! iteration number
     integer :: iter

     ! maximun iteration
     integer ,parameter:: itermax=100

     ! accuracy control
     real(Dp) :: accuracy=1e-16

     ! a real type temp variable
     real(Dp) :: real_temp

     ! omegac=omega(i)+I * eta
     complex(Dp) :: omegac

     ! some variables in Eq.(11)
     complex(Dp), allocatable :: alphai(:, :)
     complex(Dp), allocatable :: betai(:, :)
     complex(Dp), allocatable :: epsiloni(:, :)
     complex(Dp), allocatable :: epsilons(:, :)
     complex(Dp), allocatable :: epsilons_t(:, :)

     complex(Dp), allocatable :: mat1 (:, :)
     complex(Dp), allocatable :: mat2 (:, :)

     ! g0= inv(w-e_i)
     complex(Dp), allocatable :: g0 (:, :)

     ! allocate some variables
     allocate(alphai(Ndim, Ndim))
     allocate(betai (Ndim, Ndim))
     allocate(epsiloni (Ndim, Ndim))
     allocate(epsilons (Ndim, Ndim))
     allocate(epsilons_t(Ndim, Ndim))
     allocate(mat1(Ndim, Ndim))
     allocate(mat2(Ndim, Ndim))
     allocate(g0(Ndim, Ndim))

     epsiloni= H00
     epsilons= H00
     epsilons_t= H00
     alphai  = H01
     betai   = conjg(transpose(H01))
    !print *, sqrt(sum(abs(H00)**2)), 'H00'

     ! w+i*0^+
     omegac= dcmplx(omega, eta)
    !print *, omegac

     ! begin iteration
     do iter=1, itermax

        g0= omegac*ones- epsiloni
        call inv(Ndim, g0, ones)

        ! a_i-1*(w-e_i-1)^-1
        call mat_mul(Ndim, alphai, g0, mat1 )

        ! b_i-1*(w-e_i-1)^-1
        call mat_mul(Ndim, betai, g0, mat2 )

        ! a_i-1*(w-e_i-1)^-1*b_i-1
        call mat_mul(Ndim, mat1, betai, g0)
        epsiloni= epsiloni+ g0
       !print *, sqrt(sum(abs(epsiloni)**2)), 'ei'
        ! es_i= es_i-1 + a_i-1*(w-e_i-1)^-1*b_i-1
        epsilons= epsilons+ g0
       !print *, sqrt(sum(abs(epsilons)**2)), 'es'
       !pause

        ! b_i-1*(w-e_i-1)^-1*a_i-1
        call mat_mul(Ndim, mat2, alphai, g0)
        epsiloni= epsiloni+ g0
        ! es_i= es_i-1 + a_i-1*(w-e_i-1)^-1*b_i-1
        epsilons_t= epsilons_t+ g0

        ! a_i= a_i-1*(w-e_i-1)^-1*a_i-1
        call mat_mul(Ndim, mat1, alphai, g0)
        alphai= g0
        ! b_i= b_i-1*(w-e_i-1)^-1*b_i-1
        call mat_mul(Ndim, mat2, betai, g0)
        betai= g0

       !real_temp=maxval(abs(alphai))
        real_temp=sum(abs(alphai))
       !if (cpuid.eq.0) print *, iter, real_temp
        if (real_temp.le.accuracy) exit

     enddo ! end of iteration

     ! calculate surface green's function
     GLL= omegac*ones- epsilons
     call inv(Ndim, GLL, ones)

     GRR= omegac*ones- epsilons_t
     call inv(Ndim, GRR, ones)

     GB = omegac*ones- epsiloni
     call inv(Ndim, GB, ones)

     return
  end subroutine surfgreen_1985

!+---------+---------+---------+---------+---------+---------+--------+!
! this subroutine is used to calculate surface state using             !
! green's function method  ---  J.Phys.F.Met.Phys.14(1984)1205-1215    !
! Quick iterative scheme for the calculation of transfer matrices:
! application to Mo (100)
! History:
!         by Quan Sheng Wu on 4/20/2010                                !
!            mpi version      4/21/2010
!            little change to cpu version in Zurich Swiss Jan 25 2015
!+---------+---------+---------+---------+---------+---------+--------+!
  subroutine surfgreen_1984(omega,GLL,GRR,H00,H01,ones)

     use wmpi
     use para
     implicit none

     ! general loop index
     integer :: i,j

     ! iteration loop index
     integer :: it

     ! iteration number
     integer :: iter

     ! maximun iteration
     integer ,parameter :: itermax=100

     ! accuracy control
     real(Dp),parameter :: accuracy=1e-6

     ! a real type temp variable
     real(Dp) :: real_temp

     ! frequency
     real(Dp),intent(in) :: omega

     ! energy energy=omega(i)+I * eta
     complex(Dp) :: energy

     ! surface green fuction  an output variable
     complex(Dp),intent(out)  :: GLL(Ndim,Ndim)
     complex(Dp),intent(out)  :: GRR(Ndim,Ndim)

     ! H00 Hamiltonian between nearest neighbour-quintuple-layers
     ! the factor 2 is induced by spin
     complex(Dp),intent(in)  :: H00(Ndim,Ndim)

     ! H01 Hamiltonian between next-nearest neighbour-quintuple-layers
     complex(Dp),intent(in)  :: H01(Ndim,Ndim)

     ! unit matrix ones
     complex(Dp),intent(in)  :: ones(Ndim,Ndim)

     complex(Dp),allocatable  :: H01dag(:,:)

     !> surface hamiltonian
     complex(Dp),allocatable  :: Hs(:,:)

     ! temp hamiltonian
     complex(Dp),allocatable  :: t0(:,:)
     complex(Dp),allocatable  :: Tmatrix(:,:)
     complex(Dp),allocatable  :: Tmatrixt(:,:)
     complex(Dp),allocatable  :: t0tilde(:,:)
     complex(Dp),allocatable  :: tnew(:,:)
     complex(Dp),allocatable  :: tnewtilde(:,:)
     complex(Dp) ,allocatable :: told(:,:)
     complex(Dp),allocatable  :: toldtilde(:,:)
     complex(Dp),allocatable  :: temp(:,:)
     complex(Dp),allocatable  :: Tmat_temp(:,:)
     complex(Dp),allocatable  :: Tmat_tempt(:,:)

     real(Dp),allocatable     :: abs_told(:,:)

     ! allocate variables
     allocate(Hs(ndim,ndim))
     allocate(t0(ndim,ndim))
     allocate(Tmatrix(ndim,ndim))
     allocate(Tmatrixt(ndim,ndim))
     allocate(t0tilde(ndim,ndim))
     allocate(tnew(ndim,ndim))
     allocate(tnewtilde(ndim,ndim))
     allocate(told(ndim,ndim))
     allocate(toldtilde(ndim,ndim))
     allocate(temp(ndim,ndim))
     allocate(Tmat_temp(ndim,ndim))
     allocate(Tmat_tempt(ndim,ndim))
     allocate(abs_told(ndim,ndim))

     allocate(H01dag(ndim,ndim))

     Hs=0.0d0
     t0=0.0d0
     t0tilde=0.0d0
     told=0.0d0
     toldtilde=0.0d0
     tnew=0.0d0
     tnewtilde=0.0d0
     Tmatrix=0.0d0
     Tmatrixt=0.0d0
     temp=0.0d0
     abs_told=0.0d0
     Tmat_temp=0.0d0
	  GLL=0d0
	  GRR=0d0
     Tmat_tempt=0.0d0
     H01dag=0.0d0

     ! H01dag=H01^dag
     do i=1,ndim
        do j=1,ndim
           H01dag(i,j)=conjg(H01(j,i))
        enddo
     enddo

     energy=omega+zi*eta
     temp=energy*ones-H00

     call inv(ndim,temp)
     t0= matmul(temp,H01dag)
     t0tilde= matmul(temp,H01)
     told=t0
     toldtilde=t0tilde

     ! begin iteration
     iter=0
     Tmatrix=0.0d0
     Tmat_temp=ones
     Tmatrixt=0.0d0
     Tmat_tempt=ones
     ITER1 : do it=1,itermax
        iter=iter+1

        temp=ones-matmul(told,toldtilde)-matmul(toldtilde,told)
        call inv(ndim,temp)

        tnew=matmul(temp,told)
        tnew=matmul(tnew,told)
        tnewtilde=matmul(temp,toldtilde)
        tnewtilde=matmul(tnewtilde,toldtilde)

        Tmat_temp=matmul(Tmat_temp,toldtilde)
        Tmatrix=Tmatrix+matmul(Tmat_temp,tnew)

		  Tmat_tempt=matmul(Tmat_tempt,told)
        Tmatrixt=Tmatrixt+matmul(Tmat_tempt,tnewtilde)

        told=tnew
        toldtilde=tnewtilde

        do i=1,ndim
           do j=1,ndim
              abs_told(i,j)=abs(told(i,j))+abs(toldtilde(i,j))
           enddo
        enddo
        real_temp=maxval(abs_told)
        if (real_temp.le.accuracy) exit ITER1

     end do ITER1

     !print *,'iter,acc',iter,real_temp

     !> set up surface hamiltonian
     !> usually Hs= H00
     !> but you can add static potential on the surface
     Hs= H00
     do i=1, ndim
        Hs(i, i)=Hs(i, i)+ surf_onsite
     enddo

     Tmatrix=t0+Tmatrix
     temp=energy*ones-Hs-matmul(H01,Tmatrix)
     call inv(ndim,temp)

     ! g_00=(epsilon-Hs -H01*T)^-1
     GLL(1:ndim,1:ndim)=temp

     Tmatrixt=t0tilde+Tmatrixt
     temp=energy*ones-Hs -matmul(conjg(transpose(H01)),Tmatrixt)
     call inv(ndim,temp)

     ! g_00=(epsilon-Hs -H01*T)^-1
     GRR(1:ndim,1:ndim)=temp

     return
  end subroutine surfgreen_1984


demonstration of the em algorithm for fitting two lines to a bunch of points in the e step we try to estimate the probability that each point is actually on each of the lines then in the m step we redraw the lines to maxmimize the likelihood of the points rob malouf malouf let rug nl 25 may 2000 alfa informatica university of groningen postbus 716 9737nt groningen this program uses the pgplot subroutine library available at ftp astro caltech edu pub pgplot program em1 character key real x 10 y 10 model 2 2 yd 10 w1 10 w2 10 r1 10 r2 10 c real parameter s2 0.1 integer seed 1 set up display if pgopen xwindow lt 1 stop set up data call system_clock count seed 1 call random_seed put seed call random_number model x 1 2 3 4 5 6 7 8 9 1 y 1 5 x 1 5 model 1 1 model 1 2 y 6 10 x 6 10 model 2 1 model 2 2 y 1 5 x 1 5 1 y 6 10 x 6 10 initialize model call random_number model do while true e step r1 model 1 1 x model 1 2 y r2 model 2 1 x model 2 2 y w1 exp r1 r1 s2 exp r1 r1 s2 exp r2 r2 s2 w2 exp r2 r2 s2 exp r1 r1 s2 exp r2 r2 s2 display results call pgsubp 1 3 call pgsubp 1 2 call pgsci 1 call pgenv 0 1 minval y maxval y 0 0 call pglab x y em algorithm call pgsci 2 call pgpt 10 x y 2 call pgsci 3 yd x model 1 1 model 1 2 call pgline 10 x yd call pgsci 4 yd x model 2 1 model 2 2 call pgline 10 x yd call pgsci 1 call pgenv 0 1 0 1 0 0 call pgsci 2 call pgbin 10 x w1 true call pgbcht 10 1 w1 label 0 1 1 2 call pgsci 1 call pgenv 0 1 0 1 0 0 call pgsci 2 call pgbin 10 x w2 false call pgbcht 10 1 w2 label 0 1 1 2 call pgclos m step c 1 sum w1 x x sum w1 sum w1 x sum w1 x model 1 1 c sum w1 sum w1 x y sum w1 x sum w1 y model 1 2 c sum w1 x x sum w1 y sum w1 x sum w1 x y c 1 sum w2 x x sum w2 sum w2 x sum w2 x model 2 1 c sum w2 sum w2 x y sum w2 x sum w2 y model 2 2 c sum w2 x x sum w2 y sum w2 x sum w2 x y end do end program em1


      function shield(reyn)
c
c     + + + PURPOSE + + +
c
c     Function SHIELD generates parameters (shield parameters)
c     by interpolating values from a table (shield diagram)
c     for given Reynolds numbers.
c
c     Called from: SRS TRNCAP, YALIN
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real reyn
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     reyn -
c
c     + + + COMMON BLOCKS + + +
c
c     + + + LOCAL VARIABLES + + +
c
      real y(8), r(8), shield, slope, ycr
      integer i
c
c     + + + LOCAL DEFINITIONS + + +
c
c     Real Variables
c
c     y(8)   -
c     r(8)   -
c     shield -
c     slope  -
c     ycr    -
c
c     Integer Variables
c
c     i -
c
c     + + + SAVES + + +
c
      save
c
c     + + + SUBROUTINES CALLED + + +
c
c     + + + DATA INITIALIZATIONS + + +
c
      data y /0.0772, 0.0579, 0.04, 0.035, 0.034, 0.045, 0.055, 0.057/
      data r /1.0, 2.0, 4.0, 8.0, 12.0, 100.0, 400.0, 1000.0/
c
c     + + + END SPECIFICATIONS + + +
c
c
      if (reyn.lt.r(1)) then
        i = 2
        slope = (alog(y(i))-alog(y(i-1))) / (alog(r(i))-alog(r(i-1)))
        ycr = alog(y(1)) - slope * (alog(r(1))-alog(reyn))
      else if (reyn.gt.r(8)) then
        i = 8
        slope = (alog(y(i))-alog(y(i-1))) / (alog(r(i))-alog(r(i-1)))
        ycr = y(8) + slope * (alog(reyn)-alog(r(8)))
c
      else
c
        do 10 i = 2, 8
c
          if (reyn.ge.r(i-1).and.reyn.le.r(i)) then
            slope = (alog(y(i))-alog(y(i-1))) / (alog(r(i))-
     1          alog(r(i-1)))
            ycr = alog(y(i-1)) + slope * (alog(reyn)-alog(r(i-1)))
            go to 20
          end if
c
   10   continue
c
      end if
c
   20 shield = exp(ycr)
c
      return
      end


module mod_datetime

  use iso_fortran_env, only: real64

  implicit none

  private
  public :: current_time, datetime, get_date_from_cli, timedelta

  type :: datetime
    integer :: year, month, day
    integer :: hour = 0, minute = 0, second = 0
  contains
    procedure, pass(d1) :: datetime_minus_datetime
    generic :: operator(-) => datetime_minus_datetime
  end type datetime

  type :: timedelta
    integer :: days = 0, hours = 0, minutes = 0, seconds = 0
  end type timedelta

contains

  pure elemental type(timedelta) function datetime_minus_datetime(d1, d2) result(t)

    class(datetime),intent(in) :: d1, d2
    real(real64) :: days_diff, ndays1, ndays2, sgn
    integer :: days, hours, minutes, seconds, year

    real, parameter :: d2h = 24.       ! day -> hour
    real, parameter :: h2d = 1. / d2h  ! hour -> day
    real, parameter :: d2m = d2h * 60  ! day -> minute
    real, parameter :: m2d = 1. / d2m  ! minute -> day
    real, parameter :: s2d = m2d / 60. ! second -> day
    real, parameter :: d2s = 1. / s2d  ! day -> second

    ndays1 = 1.0_real64 &
           * sum([(days_in_year(year), year = 1, d1 % year - 1)])&
           + yearday(d1 % year, d1 % month, d1 % day)            &
           + d1 % hour * h2d                                     &
           + d1 % minute * m2d                                   &
           + d1 % second * s2d

    ndays2 = 1.0_real64 &
           * sum([(days_in_year(year), year = 1, d2 % year - 1)])&
           + yearday(d2 % year, d2 % month, d2 % day)            &
           + d2 % hour * h2d                                     &
           + d2 % minute * m2d                                   &
           + d2 % second * s2d

    days_diff = ndays1 - ndays2

    sgn = sign(1.0_real64, days_diff)

    days = int(abs(days_diff))
    hours = int((abs(days_diff) - days) * d2h)
    minutes = int((abs(days_diff) - days - hours * h2d) * d2m)
    seconds = int((abs(days_diff) - days - hours * h2d &
                 - minutes * m2d) * d2s)

    t = timedelta(sgn * days, sgn * hours, sgn * minutes, sgn * seconds)

  end function datetime_minus_datetime

  pure elemental integer function days_in_month(month, year)
    ! Given input month and year,
    ! returns the number of days in the month.
    integer, intent(in) :: month, year
    integer, parameter :: days(*) = [31, 28, 31, 30, 31, 30, &
                                     31, 31, 30, 31, 30, 31]
    if (month < 1 .or. month > 12) then
      days_in_month = 0
    else if (month == 2 .and. is_leap_year(year)) then
      days_in_month = 29
    else
      days_in_month = days(month)
    end if
  end function days_in_month

  pure elemental integer function days_in_year(year)
    ! Given input year, returns the number of days in year.
    integer, intent(in) :: year
    if (is_leap_year(year)) then
      days_in_year = 366
    else
      days_in_year = 365
    end if
  end function days_in_year

  subroutine get_date_from_cli(date)
    ! Reads year, month, and day from the command line
    ! and returns the corresponding datetime instance.
    type(datetime), intent(out) :: date
    character(len=4) :: year_arg
    character(len=2) :: month_arg, day_arg
    integer :: year, month, day

    if (command_argument_count() < 3) then
      stop 'Usage: countdown YEAR MONTH DAY'
    end if

    call get_command_argument(1, year_arg)
    call get_command_argument(2, month_arg)
    call get_command_argument(3, day_arg)

    read(year_arg, *) year
    read(month_arg, *) month
    read(day_arg, *) day

    if (year < 1) then
      stop 'YEAR must be >= 1'
    else if (month < 1 .or. month > 12) then
      stop 'MONTH must be >= 1 and <= 12'
    else if (day < 1 .or. day > days_in_month(month, year)) then
      stop 'invalid value for DAY'
    end if

    date = datetime(year, month, day, 0, 0, 0)

  end subroutine get_date_from_cli

  pure elemental logical function is_leap_year(year)
    ! Returns .true. if input year is a leap year,
    ! and .false. otherwise.
    integer, intent(in) :: year
    is_leap_year = (mod(year, 4) == 0 .and. .not. mod(year, 100) == 0)&
              .or. (mod(year, 400) == 0)
  end function is_leap_year

  type(datetime) function current_time() result(res)
    integer :: values(8)
    call date_and_time(values=values)
    res = datetime(year = values(1), month = values(2),&
                   day = values(3), hour = values(5),&
                   minute = values(6), second = values(7))
  end function current_time

  pure elemental integer function yearday(year, month, day)
    ! Given input year, month, and day,
    ! returns the number of day in the year.
    integer, intent(in) :: year, month, day
    integer :: m
    yearday = sum([(days_in_month(m, year), m = 1, month - 1)]) + day
  end function yearday

end module mod_datetime


! computing pi
      program pi
      integer i, n
      parameter(n=1000)
      real*8 v(n), x, gsum, w
!hpf$ distribute v(block)
      w = 1.0/real(n)
      gsum = 0.0
!fcd$ time
!hpf$ independent, new(x), reduction(gsum)
      do i=1, n
         x = (i-0.5)*w
         v(i)=4.0/(1.0+x*x)
         gsum=gsum+v(i)
      enddo
!fcd$ end time('pi computation')
      print *, 'computed pi value is ', gsum*w
      end


      double precision function tripleYlmint(l1,l2,l3,m1,m2)
! evaluates \int d\Omega Y_{l1}^{m1} Y_{l2}^{m2} Y_{l3}^{m3}
! where m3=-m1-m2
! Requires functions lnfactorial and lngamma
      implicit none
      integer l1,l2,l3,m1,m2
      double precision wig1,wig2,xterm,pi
      parameter (pi=3.1415926535897932384626433832795028841972d0)
      double precision wigner3j
      external wigner3j
      tripleYlmint=0.d0
      if (l3.lt.abs(l1-l2).or.l3.gt.l1+l2) return
      if (m1.lt.-l1.or.m1.gt.l1) return
      if (m2.lt.-l2.or.m2.gt.l2) return
      wig1=wigner3j(l1,l2,l3,0,0)
      wig2=wigner3j(l1,l2,l3,m1,m2)
      xterm=sqrt(dble((2*l1+1)*(2*l2+1)*(2*l3+1))/(4.d0*pi))
      tripleYlmint=xterm*wig1*wig2
      return
      end

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

      double precision function wigner3j(j1,j2,j3,m1,m2)
! evaluates | j1 j2 j3 |
!           | m1 m2 m3 |
! where m3=-m1-m2
      implicit none
      integer j1,j2,j3,m1,m2,m3
      integer it,itmax,itmin
      double precision xterm1,xterm2,sterm
      double precision triangle
      double precision lnfactorial
      external lnfactorial
      m3=-m1-m2
      wigner3j=0.d0
      if (j3.lt.abs(j1-j2).or.j3.gt.j1+j2) return
      if (m1.lt.-j1.or.m1.gt.j1) return
      if (m2.lt.-j2.or.m2.gt.j2) return
      if (m3.lt.-j3.or.m3.gt.j3) return
      triangle=(lnfactorial(j1+j2-j3)+lnfactorial(j1-j2+j3)  &
&             +lnfactorial(-j1+j2+j3)-lnfactorial(j1+j2+j3+1))/2.d0
      xterm1=(lnfactorial(j1+m1)+lnfactorial(j1-m1)  &
&            +lnfactorial(j2+m2)+lnfactorial(j2-m2)  &
&            +lnfactorial(j3+m3)+lnfactorial(j3-m3))/2.d0
      xterm2=0.d0
      itmin=max(0,j2-j3-m1,j1-j3+m2)
      itmax=min(j1+j2-j3,j1-m1,j2+m2)
      do it=itmin,itmax
        sterm=exp(triangle+xterm1-lnfactorial(it)  &
&                -lnfactorial(j3-j2+it+m1)-lnfactorial(j3-j1+it-m2)  &
&                -lnfactorial(j1+j2-j3-it)-lnfactorial(j1-it-m1)  &
&                -lnfactorial(j2-it+m2))
        xterm2=xterm2+((-1)**it)*sterm
      enddo
      wigner3j=((-1)**(j1-j2-m3))*xterm2
      return
      end

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

      function spharm(ll,mm,rr)
! Spherical harmonic Y_ll^mm for radius vector rr
! cosine of polar angle theta = rr(3)/|rr|
! azimuthal angle phi = atan2(rr(2),rr(1))
      implicit none
      double complex :: spharm
      double precision :: rr(3)
      integer :: ll,mm
      double precision :: costheta,cosphi,sinphi,rmag
      double complex :: expphi
      integer :: im,mmm
      double precision :: fact,prefact,pi,lpolyn
      parameter (pi=3.1415926535897932384626433832795028841972d0)
      external lpolyn

      mmm=abs(mm)
      if (ll.lt.mmm) then
        write(6,*) 'bad input parameters in function spharm'
        stop
      endif
      fact=1.d0
      do im=ll-mmm+1,ll+mmm
        fact=fact*im
      enddo
      costheta=rr(3)/norm2(rr)
      rmag=sqrt(dot_product(rr(1:2),rr(1:2)))
      if (rmag.le.0.d0) then
        if (mmm.eq.0) then
          expphi=(1.d0,0.d0)
        else
          expphi=(0.d0,0.d0)
        endif
      else
        cosphi=rr(1)/rmag
        sinphi=rr(2)/rmag
        expphi=cosphi+(0.d0,1.d0)*sinphi
      endif
      prefact=sqrt((2.d0*ll+1.d0)/(fact*4.d0*pi))
      spharm=prefact*lpolyn(ll,mmm,costheta)*expphi**mmm
      if (mm.lt.0) spharm=conjg(spharm)*(-1)**mmm

      return
      end

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

      function lpolyn(ll,mm,xx)
! Legendre Polynomial P_ll^mm (xx)
      implicit none
      double precision lpolyn,xx
      integer ll,mm
      double precision term,fact,lpstart,lpl,lplm1,lplm2
      integer im,il

      if (ll.lt.mm.or.abs(xx).gt.1.d0) then
        write(6,*) 'bad input parameters for function lpolyn'
        stop
      endif
      term=sqrt(1.d0-xx*xx)
      lpstart=1.d0
      do im=1,mm
        lpstart=-lpstart*term*(2*im-1)
      enddo
      if (ll.eq.mm) then
        lpolyn=lpstart
      else
        lplm1=lpstart
        lplm2=0.d0
        do il=mm+1,ll
          lpl=(xx*(2*il-1)*lplm1-(il+mm-1)*lplm2)/dble(il-mm)
          lplm2=lplm1
          lplm1=lpl
        enddo
        lpolyn=lpl
      endif

      return
      end

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

      double precision function lngamma(xx)
      implicit double precision (a-h,o-z)
      double precision xx,x, cc(6), gam, sumg, work, sq2pi
      integer i
      data cc/76.18009172947146d0,-86.50532032941677d0,  &
&             24.01409824083091d0,-1.231739572450155d0,  &
&             0.1208650973866179d-2,-0.5395239384953d-5/
      x=xx-1.d0
      sq2pi=2.5066282746310005d0
      sumg=1.000000000190015d0
      do i=1,6
        sumg=sumg+cc(i)/(x+i)
      enddo
      work=x+5.5
      lngamma=(x+0.5)*log(work)-work+log(sq2pi*sumg)
      return
      end

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

      double precision function lnfactorial(ii)
      implicit none
      integer ii
      double precision factstore(0:100),lngamma
      external lngamma
      save factstore
      data factstore/101*-1.d0/
      if (ii.le.100) then
        if (factstore(ii).lt.0.d0) factstore(ii)=lngamma(dble(ii+1))
        lnfactorial=factstore(ii)
      else
        lnfactorial=lngamma(dble(ii+1))
      endif
      return
      end

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

      function sphbesselj(xx,nn)
      implicit none
      double precision sphbesselj,xx
      integer nn
      integer ii,np,sigfig
      double precision tiny,dj0,dj1,djnn,djn,djnp1,djnm1,scale

      if (nn.lt.0) then
        write(6,*) 'bad argument for order n of j_n(xx) in sphbesselj'
        write(6,*) 'nn = ',nn
        stop
      endif
      sigfig=12
      tiny=1.d-10
      if (xx.lt.tiny) then
        dj0=1.d0-xx**2/6.d0
      else
        dj0=sin(xx)/xx
      endif
      if (nn.eq.0) then
        sphbesselj=dj0
        return
      endif
      if (xx.lt.tiny) then
        sphbesselj=1.d0
        do ii=1,nn
          sphbesselj=sphbesselj*xx/dble(2*ii+1)
        enddo
      elseif (xx.lt.2*nn) then
        djn=tiny
        djnp1=0.d0
        np=int(sqrt(dble(nn*sigfig**2)))+1
        do ii=nn+np,1,-1
          djnm1=(2*ii+1)*djn/xx-djnp1
          if (ii.eq.nn) djnn=djn
          djnp1=djn
          djn=djnm1
        enddo
        scale=djn/dj0
        sphbesselj=djnn/scale
      else
        if (xx.lt.tiny) then
          dj1=xx/3.d0-4.d0*xx**3/30.d0
        else
          dj1=sin(xx)/(xx**2)-cos(xx)/xx
        endif
        djnm1=dj0
        djn=dj1
        do ii=1,nn-1
          djnp1=(2*ii+1)*djn/xx-djnm1
          djnm1=djn
          djn=djnp1
        enddo
        sphbesselj=djn
      endif

      return
      end


	FUNCTION PC_PSYM  ( tb, tt, delh, psb )
C************************************************************************
C* PC_PSYM								*
C*									*
C* This function computes the Montgomery stream function.		*
C*									*
C*  REAL PC_PSYM  ( TB, TT, DELH, PSB )					*
C*									*
C* Input parameters:							*
C*	TB		REAL		Bottom temperature		*
C*	TT		REAL		Top temperature			*
C*	DELH		REAL		Incremental dry hydrostatic z	*
C*	PSB		REAL		Bottom psi			*
C*									*
C* Output parameters:							*
C*	PC_PSYM		REAL		Montgomery stream function	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	11/84						*
C* M. desJardins/GSFC	 9/88						*
C* T. Piper/GSC		11/98	Updated prolog				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C
C*	NOTE:  The values of CP and G are divided by 100. in order
C*	       to make the Montgomery Stream Function (PSYM) smaller
C*	       than 10**6.
C
	PARAMETER	( CP = RDGAS / RKAPPA / 100. )
	PARAMETER	( G = GRAVTY / 100. )
C*
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ( .not. ERMISS (tb) ) .and. ( .not. ERMISS (tt) ) .and.
     +	      ( .not. ERMISS (delh) ) .and. ( .not. ERMISS (psb) ) )
     +								THEN
	    PC_PSYM = psb + ( CP * ( tt - tb ) + G * delh )
	  ELSE
	    PC_PSYM = RMISSD
	END IF
C*
	RETURN
	END


function alin(xcur, n,x0,dx,fun)
real fun(n)
do i=1,n-1
	x1=x0+dx*(i-0.5)
	if(i.eq.1)x1=x0
	x2=x0+dx*(i+0.5)
	if((x1-xcur)*(x2-xcur).gt.0.)cycle
	f1=fun(i)
	f2=fun(i+1)
	alin=f1+((f2-f1)/(x2-x1))*(xcur-x1)
	return
end do
alin=0.
return
end

function alin2d(x,y, x0,nx,dx,y0,ny,dy,fun)
real fun(nx,ny)
do ix=1,nx-1
	x1=x0+dx*(ix-0.5)
	if(ix.eq.1)x1=x0
	x2=x0+dx*(ix+0.5)
	if(ix.eq.nx-1)x2=x0+dx*(ix+1)
	if((x1-x)*(x2-x).gt.0.)cycle
	do iy=1,ny-1
		y1=y0+dy*(iy-0.5)
		if(iy.eq.1)y1=y0
		y2=y0+dy*(iy+0.5)
		if(iy.eq.ny-1)y2=y0+dy*(iy+1)
		if((y1-y)*(y2-y).gt.0.)cycle
		f11=fun(ix,iy)
		f12=fun(ix,iy+1)
		f21=fun(ix+1,iy)
		f22=fun(ix+1,iy+1)
		f1=f11+((f12-f11)/(y2-y1))*(y-y1)
		f2=f21+((f22-f21)/(y2-y1))*(y-y1)
		alin2d=f1+((f2-f1)/(x2-x1))*(x-x1)
		return
	end do
end do
alin=0.
return
end


c=======================================================================
       subroutine hpd(n,alpha,x,alow,aupp)
c=======================================================================
c      computing 100(1-alpha)% HPD and credible intervals for x
c      use Chen-Shao HPD Estimation Algorithm
c      (see page 219 of Monte Carlo Methods in Bayesian Computation,
c      Springer-Verlag, 2000)
c      ming-hui chen
c      july 23, 2001 at wpi
c      input:
c            alpha: confidence level,  0 < alpha < 1
c            n = mcmc sample size
c            x(n): a univariate vector of mcmc sample
c      output:
c            (alow(1),aupp(1)): 100(1-alpha)% HPD interval
c            (alow(2),aupp(2)): 100(1-alpha)% Bayesian credible interval
c
       implicit real*8 (a-h,o-z)
       real*8 x(n)
       real*8 aupp(2),alow(2)

       whpd=0.d0
       aupp1=0.d0
       alow1=0.d0

       q1=(alpha/2.0d0)*float(n)
       q2=(1.0d0-alpha/2.0d0)*float(n)
       nq1=nint(q1)
       nq2=nint(q2)
       nq=nq2-nq1
       do 100 i=1,n-1
          do 110 j=i+1,n
             if (x(i) .gt. x(j)) then
                temp=x(i)
                x(i)=x(j)
                x(j)=temp
             end if
 110   continue
 100   continue
       do 120 j=1,n-nq
              pdiff1=x(j)
              pdiff2=x(j+nq)
              wb=pdiff2-pdiff1
              if (j .eq. 1) then
                 whpd=wb
                 aupp1=pdiff2
                 alow1=pdiff1
               else
                 if (whpd .gt. wb) then
                    whpd=wb
                    aupp1=pdiff2
                    alow1=pdiff1
                 end if
              end if
 120   continue
       alow(1)=alow1
       aupp(1)=aupp1
       alow(2)=x(nq1)
       aupp(2)=x(nq2)

       return
       end


      SUBROUTINE CROTG( A, B, C, S )
*
*  -- Automatically Tuned Linear Algebra Software (ATLAS)
*     (C) Copyright 2000 All Rights Reserved
*
*  -- ATLAS routine -- F77 Interface -- Version 3.9.24 -- December 25, 2000
*
*  Author         : Antoine P. Petitet
*  Originally developed at the University of Tennessee,
*  Innovative Computing Laboratory,  Knoxville TN, 37996-1301, USA.
*
*  ---------------------------------------------------------------------
*
*  -- Copyright notice and Licensing terms:
*
*  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 distri-
*     bution.
*  3. The name of the University,  the ATLAS group,  or the names of its
*     contributors  may not be used to endorse or promote products deri-
*     ved from this software without specific written permission.
*
*  -- Disclaimer:
*
*  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 UNIVERSITY
*  OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,  INDIRECT, INCIDENTAL, SPE-
*  CIAL, 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 THEO-
*  RY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT  (IN-
*  CLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
*  THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*  ---------------------------------------------------------------------
*
*     .. Scalar Arguments ..
      REAL               C
      COMPLEX            A, B, S
*     ..
*
*  Purpose
*  =======
*
*  CROTG  constructs a Givens plane rotation. Given the scalars a and b,
*  this routine computes the following quantities:
*
*  if |a| = 0, then c = 0, s = 1, and r = b;
*  and otherwise:
*     norm = sqrt( |a|^2 + |b|^2 );
*     c    = |a| / norm;
*     s    = a * conjg( b ) / ( |a| * norm );
*     r    = a / ( |a| * norm );
*
*  Arguments
*  =========
*
*  A       (input/output)                COMPLEX
*          On entry, A specifies the scalar a. On exit, A is overwritten
*          by the scalar r defined above.
*
*  B       (input)                       COMPLEX
*          On entry, B  specifies the scalar b. Unchanged on exit.
*
*  C       (output)                      REAL
*          On exit, C  specifies the scalar c defined above.
*
*  S       (output)                      COMPLEX
*          On exit, S  specifies the scalar s defined above.
*
*  Further Details
*  ===============
*
*  For further information on the Level 1 BLAS specification, see:
*
*  ``A Proposal for Standard Linear Algebra Subprograms''  by R. Hanson,
*  F. Krogh and C. Lawson, ACM SIGNUM Newsl., 8(16), 1973,
*
*  ``Basic Linear Algebra Subprograms for Fortran Usage''  by C. Lawson,
*  R. Hanson, D. Kincaid and F. Krogh,  ACM Transactions on Mathematical
*  Software, 5(3) pp 308-323, 1979.
*
*  For further information on the Level 2 BLAS specification, see:
*
*  ``An  Extended Set of  FORTRAN  Basic Linear Algebra Subprograms'' by
*  J. Dongarra,  J. Du Croz,  S. Hammarling and R. Hanson,  ACM Transac-
*  tions on Mathematical Software, 14(1) pp 1-17, 1988.
*
*  ``Algorithm 656: An extended Set of Basic Linear Algebra Subprograms:
*  Model Implementation and Test Programs''  by J. Dongarra, J. Du Croz,
*  S. Hammarling and R. Hanson,  ACM  Transactions on Mathematical Soft-
*  ware, 14(1) pp 18-32, 1988.
*
*  For further information on the Level 3 BLAS specification, see:
*
*  ``A Set of Level 3 Basic Linear Algebra Subprograms'' by J. Dongarra,
*  J. Du Croz, I. Duff and S. Hammarling, ACM Transactions on Mathemati-
*  cal Software, 16(1), pp 1-17, 1990.
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           ATL_F77WRAP_CROTG
*     ..
*     .. Executable Statements ..
*
      CALL ATL_F77WRAP_CROTG( A, B, C, S )
*
      RETURN
*
*     End of CROTG
*
      END


module num_env
  implicit none
  private
  public pi
  public bico
  public deg
  public fact
  public inv2
  public rad
  public shft
  public swap

  real, parameter :: pi = 4. * atan(1.)

  interface swap
    procedure iswap, rswap
  end interface

contains
  pure function bico(n, k)
    integer, intent(in) :: n, k
    integer :: bico

    bico = fact(n) / (fact(k) * fact(n-k))
  end function

  elemental function deg(r) result(d)
    real, intent(in) :: r
    real :: d

    d = r * 180. / pi
  end function

  pure function fact(n)
    integer, intent(in) :: n
    integer :: i, fact

    fact = product([(i, i=1,n)])
  end function

  pure subroutine inv2(a)
    real, intent(inout) :: a(2, 2)
    real :: b(2, 2)
    real :: detinv

    detinv = 1. / (a(1, 1) * a(2, 2) - a(1, 2) * a(2, 1))

    b(1, 1) = +detinv * a(2, 2)
    b(2, 1) = -detinv * a(2, 1)
    b(1, 2) = -detinv * a(1, 2)
    b(2, 2) = +detinv * a(1, 1)
    a = b
  end subroutine

  elemental function rad(d) result(r)
    real, intent(in) :: d
    real :: r

    r = d * pi / 180.
  end function

  pure subroutine shft(a, b, c, d)
    real, intent(out) :: a
    real, intent(inout) :: b, c
    real, intent(in) :: d

    a = b
    b = c
    c = d
  end subroutine

  pure subroutine iswap(a, b)
    integer, intent(inout) :: a, b
    integer :: c

    c = a
    a = b
    b = c
  end subroutine

  pure subroutine rswap(a, b)
    real, intent(inout) :: a, b
    real :: c

    c = a
    a = b
    b = c
  end subroutine
end module

module bez
  use num_env, only: bico, fact, inv2, pi
  implicit none
  private
  public bezarc
  public bezcrv
  public bezfit
  public bezlin
  public bezsim

contains
  pure subroutine bezarc(a, b, p)
    real, intent(in) :: a(:), b(:)
    real, intent(out) :: p(:, :)
    real, parameter :: k = 4. / 3. * (sqrt(2.) - 1.)
    integer :: i, m, n
    real :: br(2), dx(2)
    real :: beta, cosb, sinb, r, rot(2, 2)

    n = size(p, 2)
    if (mod(n, 2) /= 0) error stop

    m = n / 2
    dx = b - a
    beta = .5 * pi - atan(dx(2) / dx(1))
    cosb = cos(beta)
    sinb = sin(beta)
    rot(1, 1) = cosb
    rot(1, 2) = -sinb
    rot(2, 1) = sinb
    rot(2, 2) = cosb
    br = matmul(rot, dx) + a

    cosb = cos(.25 * pi)
    sinb = cosb
    r = abs(a(2) - br(2)) / (2. * sinb)
    do concurrent(i = 1:m-1)
      p(:, i) = a
    end do
    dx =  k * r * [sinb, cosb]
    call inv2(rot)
    p(:, m) = matmul(rot, dx) + a
    p(:, m+1) = matmul(rot, br + dx - a) + a
    do concurrent(i = m+2:n)
      p(:, i) = b
    end do
  end subroutine

  pure function bezcrv(t, p) result(c)
    real, intent(in) :: t, p(:, :)
    real :: c(size(p, 1))
    integer :: i, n

    c = 0
    if(t < 0 .or. t > 1) error stop
    n = size(p, 2) - 1
    do i = 0, n
      c = c + b(t, i, n) * p(:, i+1)
    end do

  contains
    pure function b(t, i, n)
      real, intent(in) :: t
      integer, intent(in) :: i, n
      real :: b

      b = bico(n, i) * t**i * (1 - t)**(n - i)
    end function
  end function

  pure recursive function bezfit(x, tol) result(p)
    real, intent(in) :: x(:, :), tol
    real :: a(size(x, 1)), a1, a2, a12, d, t, t1
    real, allocatable :: p(:, :), q(:, :), r(:, :)
    real, dimension(2) :: c1, c2, c12
    integer :: i, k, n

    n = size(x, 2)
    if (n < 3) error stop
    k = n - 1
    allocate(p(2, 4))
    p(:, 1) = x(:, 1)
    p(:, 4) = x(:, n)

    a1 = 0
    a2 = 0
    a12 = 0
    c1 = 0
    c2 = 0
    do i = 0, k
      t = real(i) / k
      t1 = 1. - t
      a1 = a1 + t**2 * t1**4
      a2 = a2 + t**4 * t1**2
      a12 = a12 + t**3 * t1**3
      c12 = x(:, i + 1) - t1**3 * p(1, :) - t**3 * p(:, 4)
      c1 = c1 + 3. * t * t1**2 * c12
      c2 = c2 + 3. * t**2 * t1 * c12
    end do
    a1 = 9. * a1
    a2 = 9. * a2
    a12 = 9. * a12
    d = (a1 * a2 - a12 * a12)
    p(:, 2) = (a2 * c1 - a12 * c2) / d
    p(:, 3) = (a1 * c2 - a12 * c1) / d

    do concurrent(i = 0:k)
      t = real(i) / k
      a(i+1) = norm2(x(:, i+1) - bezcrv(t, p))
    end do
    if (all(a < tol)) return

    k = maxloc(a, 1)
    if (k < 3 .or. n - k < 2) return

    q = bezfit(x(:, :k), tol)
    r = bezfit(x(:, k:), tol)
    n = size(q, 1)
    k = size(r, 1)
    deallocate(p)
    allocate(p(n+k-1, 2))
    p(:, :n) = q
    p(:, n:) = r
    deallocate(q)
    deallocate(r)
  end function

  pure subroutine bezlin(a, b, p)
    real, intent(in) :: a(:), b(:)
    real, intent(out) :: p(:, :)
    real :: dx(size(a))
    integer :: i, j, n

    dx = b - a
    n = size(p, 2) - 1
    do i = 0, n
      j = i + 1
      p(:, j) = dx * real(i) / n + a
    end do
  end subroutine

  pure function bezsim(p, q) result(lambda)
    real, intent(in), dimension(:, :) :: p, q
    real :: lambda
    integer :: i, n

    n = size(p, 2)
    if(n /= size(q, 2)) error stop
    lambda = 0
    do i = 1, n
      lambda = lambda + hypot(p(:, i) - q(:, i))
    end do
    lambda = lambda / n
  end function
end module

module fmin
  use num_env, only: shft, swap
  implicit none
  private
  public amoeba
  public brent
  public mnbrak

contains
  subroutine amoeba(fcn, x, fn, tol, stat)
    interface
      function fcn(x)
        real, intent(in) :: x(:)
        real :: fcn
      end function
    end interface
    real, intent(inout) :: x(:)
    real, intent(out) :: fn
    real, optional, intent(in) :: tol
    integer, optional, intent(out) :: stat
    real :: c, alpha, beta, gamma, delta, &
            f(size(x)+1), fc, fe, fr, ftmp, &
            xx(size(x), size(x)+1), xc(size(x)), &
            xe(size(x)), xr(size(x)), xtmp(size(x)), &
            ident(size(x), size(x)), p(size(x)), p1, p2, facc
    integer :: i, j, k, itmax, n

    n = size(x)
    alpha = 1.
    beta = 1. + 2. / n
    gamma = .75 - 1. / (2 * n)
    delta = 1. - 1. / n
    c = 1.5
    p1 = c * (sqrt(n + 1.) + n - 1.) / (sqrt(2.) * n)
    p2 = c * (sqrt(n + 1.) - 1.) / (sqrt(2.) * n)
    p = p2
    ident = 0
    do concurrent(i = 1:n)
      ident(i, i) = 1
    end do
    xx(:, 1) = x
    do concurrent(i = 2:n+1)
      xx(:, i) = x + p + (p1 - p2) * ident(:, i-1)
    end do
    do j = 1, n+1
      f(j) = fcn(xx(:, j))
    end do
    facc = merge(tol, sqrt(epsilon(1.)), present(tol))
    if(present(stat)) stat = 0
    itmax = n * 200
    do i = 1, itmax
      do j = 2, n+1
        k = j - 1
        ftmp = f(j)
        xtmp = xx(:, j)
        do while(k >= 1 .and. f(k) > ftmp)
          f(k+1) = f(k)
          xx(:, k+1) = xx(:, k)
          k = k - 1
        end do
        f(k+1) = ftmp
        xx(:, k+1) = xtmp
      end do
      x = sum(xx(:, 1:n), 2) / n
      xr = x + alpha * (x - xx(:, n+1))
      fr = fcn(xr)
      if(fr >= f(1) .and. fr <= f(n)) then
        xx(:, n+1) = xr
        f(n+1) = fr
      else if(fr < f(1)) then
        xe = x + beta * (xr - x)
        fe = fcn(xe)
        if(fe < f(1)) then
          xx(:, n+1) = xe
          f(n+1) = fe
        else
          xx(:, n+1) = xr
          f(n+1) = fr
        end if
      else if(fr > f(n)) then
        if(fr >= f(n+1)) then
          xc = x + gamma * (xx(:, n+1) - x)
        else
          xc = x + gamma * (xr - x)
        end if
        fc = fcn(xc)
        if(fc < f(n+1)) then
          xx(:, n+1) = xc
          f(n+1) = fc
        else
          do j = 2, n+1
            xx(:, j) = delta * (xx(:, j) - xx(:, 1)) + xx(:, 1)
            f(j) = fcn(xx(:, j))
          end do
        end if
      end if
      fn = f(1)
      if(sqrt(sum(((f - fcn(x))**2) / n)) < facc) return
    end do
    if(present(stat)) stat = -1
  end subroutine

  function brent(ax, bx, cx, func, tol, xmin, stat)
    real, intent(in) :: ax, bx, cx, tol
    real, intent(out) :: xmin
    integer, optional, intent(out) :: stat
    real :: brent
    interface
      function func(x)
        real, intent(in) :: x
        real :: func
      end function
    end interface
    real, parameter :: cgold = 0.3819660, zeps = 1.0e-3 * epsilon(ax)
    integer, parameter :: itmax = 100
    integer :: i
    real :: a, b, d, e, etemp, fu, fv, fw, fx, p, q, r, tol1, tol2, u, v, w, x, xm

    if(present(stat)) stat = 0
    brent = bx
    a = min(ax, cx)
    b = max(ax, cx)
    v = bx
    w = v
    x = v
    e = 0.
    fx = func(x)
    fv = fx
    fw = fx
    do i = 1, itmax
      xm = .5 * (a + b)
      tol1 = tol * abs(x) + zeps
      tol2 = 2. * tol1
      if(abs(x - xm) <= (tol2 - .5 * (b - a))) then
        xmin = x
        brent = fx
        return
      end if
      if(abs(e) > tol1) then
        r = (x - w) * (fx - fv)
        q = (x - v) * (fx - fw)
        p = (x - v) * q - (x - w) * r
        q = 2. * (q - r)
        if(q > 0) p = -p
        q = abs(q)
        etemp = e
        e = d
        if(abs(p) >= abs(.5 * q * etemp) .or. &
          p <= q * (a - x) .or. p >= q * (b - x)) then
          e = merge(a - x, b - x, x >= xm)
          d = cgold * e
        else
          d = p / q
          u = x + d
          if(u - a < tol2 .or. b - u < tol2) d = sign(tol1, xm - x)
        end if
      else
        e = merge(a - x, b - x, x >= xm)
        d = cgold * e
      end if
      u = merge(x + d, x + sign(tol1, d), abs(d) >= tol1)
      fu = func(u)
      if(fu <= fx) then
        if(u >= x) then
          a = x
        else
          b = x
        end if
        call shft(v, w, x, u)
        call shft(fv, fw, fx, fu)
      else
        if(u < x) then
          a = u
        else
          b = u
        end if
        if(fu <= fw .or. w == x) then
          v = w
          fv = fw
          w = u
          fw = fu
        else if(fu <= fv .or. v == x .or. v == w) then
          v = u
          fv = fu
        end if
      end if
    end do
    if(present(stat)) stat = -1
  end function

  subroutine mnbrak(ax, bx, cx, fa, fb, fc, func)
    real, intent(inout) :: ax, bx
    real, intent(out) :: cx, fa, fb, fc
    interface
      function func(x)
        real, intent(in) :: x
        real :: func
      end function
    end interface
    real, parameter :: gold = 1.618034, glimit = 100.0
    real :: fu, q, r, u, ulim

    fa = func(ax)
    fb = func(bx)
    if(fb > fa) then
      call swap(ax, bx)
      call swap(fa, fb)
    end if
    cx = bx + gold * (bx - ax)
    fc = func(cx)
    do
      if(fb < fc) return
      r = (bx - ax) * (fb - fc)
      q = (bx - cx) * (fb - fa)
      u = bx - ((bx - cx) * q - (bx - ax) * r) / (2. * sign(max(abs(q - r), tiny(1.)), q - r))
      ulim = bx + glimit * (cx - bx)
      if((bx - u) * (u - cx) > 0.) then
        fu = func(u)
        if(fu < fc) then
          ax = bx
          fa = fb
          bx = u
          fb = fu
          return
        else if(fu > fb) then
          cx = u
          fc = fu
          return
        end if
        u = cx + gold * (cx - bx)
        fu = func(u)
      else if((cx - u) * (u - ulim) > 0.) then
        fu = func(u)
        if(fu < fc) then
          bx = cx
          cx = u
          u = cx + gold * (cx - bx)
          call shft(fb, fc, fu, func(u))
        end if
      else if((u - ulim) * (ulim - cx) >= 0.) then
        u = ulim
        fu = func(u)
      else
        u = cx + gold * (cx - bx)
        fu = func(u)
      end if
      call shft(ax, bx, cx, u)
      call shft(fa, fb, fc, fu)
    end do
  end subroutine
end module

module intgrt
  implicit none
  private
  public simpr

contains
  function simpr(fcn, a, b, n) result(s)
    interface
      function fcn(x)
        real, intent(in) :: x
        real :: fcn
      end function
    end interface
    real, intent(in) :: a, b
    integer, optional, intent(in) :: n
    real :: f0, fn, fs0, fs1, h, s, x0, x1
    integer :: i, k

    k = merge(n, 3, present(n))
    h = (b - a) / k
    f0 = fcn(a)
    fn = fcn(b)
    fs0 = 0
    fs1 = 0
    x0 = a
    do i = 1, k
      x1 = x0 + h
      if(i < k) fs0 = fs0 + fcn(x1)
      fs1 = fs1 + fcn((x0 + x1) / 2.)
      x0 = x1
    end do
    s = h / 6. * (f0 + 2. * fs0 + fn + 4. * fs1)
  end function
end module

module intp1d
  implicit none
  private
  public interp

contains
  pure function interp(x, xp, fp) result(y)
    real, intent(in) :: x, xp(:), fp(:)
    integer :: i, j, n
    real :: y

    n = size(xp)
    y = fp(1)
    if(x < xp(1)) return
    do i = 1, n - 1
      j = i + 1
      if(x >= xp(i) .and. x < xp(j)) then
        y = fp(i) + (x - xp(i)) * (fp(j) - fp(i)) / (xp(j) - xp(i))
        return
      end if
    end do
    if(x > xp(n)) y = fp(n)
  end function
end module

module rtfind
  implicit none
  private
  public rtnewt
  public zbrent

  integer, parameter :: itmax = 1000

contains
  pure subroutine rtnewt(funcd, p, x0, x, tol, stat)
    interface
      pure subroutine funcd(x, p, fval, fderiv)
        real, intent(in) :: x, p(:)
        real, intent(out) :: fval, fderiv
      end subroutine
    end interface
    real, intent(in) :: p(:), x0
    real, intent(out) :: x
    real, optional, intent(in) :: tol
    integer, optional, intent(out) :: stat
    real :: df, dx, f, xacc
    integer :: j

    if(present(stat)) stat = 0
    xacc = merge(tol, sqrt(epsilon(1.)), present(tol))
    x = x0
    do j = 1, itmax
      call funcd(x, p, f, df)
      dx = f / df
      x = x - dx
      if(abs(dx) < xacc) return
    end do
    if(present(stat)) stat = -1
  end subroutine

  pure subroutine zbrent(fcn, x1, x2, b, tol, stat)
    interface
      pure function fcn(x)
        real, intent(in) :: x
        real :: fcn
      end function
    end interface
    real, intent(in) :: x1, x2
    real, intent(out) :: b
    real, optional, intent(in) :: tol
    integer, optional, intent(out) :: stat
    integer :: i
    real :: a, c, d, e, fa, fb, fc, min1, min2, &
            p, q, r, s, xacc, xm

    if(present(stat)) stat = 0
    a = x1
    b = x2
    c = 0
    d = 0
    e = 0
    fa = fcn(a)
    fb = fcn(b)
    if(fa * fb > 0) then
      if(present(stat)) stat = -1
      return
    end if
    fc = fb
    do i = 1, itmax
      if(fb * fc > 0) then
        c = a
        fc = fa
        d = b - a
        e = d
      end if
      if(abs(fc) < abs(fa)) then
        a = b
        b = c
        c = a
        fa = fb
        fb = fc
        fc = fa
      end if
      xacc = 2. * epsilon(x1) * abs(b) + .5 * merge(tol, sqrt(epsilon(1.)), present(tol))
      xm = .5 * (c - b)
      if(abs(xm) <= xacc .or. fb == 0.) return
      if(abs(e) >= xacc .and. abs(fa) > abs(fb)) then
        s = fb / fa
        if(a == b) then
          p = 2. * xm * s
          q = 1. - s
        else
          q = fa / fc
          r = fb / fc
          p = s * (2. * xm * q * (q - r) - (b - a) * (r - 1.))
          q = (q - 1.) * (r - 1.) * (s - 1.)
        end if
        if(p > 0) q = -q
        p = abs(p)
        min1 = 3. * xm * q - abs(xacc*q)
        min2 = abs(e*q)
        if(2.*p < min(min1, min2)) then
          e = d
          d = p / q
        else
          d = xm
          e = d
        end if
      else
        d = xm
        e = d
      end if
      a = b
      fa = fb
      if(abs(d) > xacc) then
        b = b + d
      else
        b = b + sign(xacc, xm)
      end if
      fb = fcn(b)
    end do
    if(present(stat)) stat = -2
  end subroutine
end module

module spcfnc
  implicit none
  private
  public hyp2f1

contains
  elemental function hyp2f1(a, b, c, z) result(f1)
    real, intent(in) :: a, b, c, z
    integer, parameter :: itmax = 1000
    real :: aa, bb, cc, f1, fac, temp
    integer :: n

    fac = 1.
    temp = fac
    aa = a
    bb = b
    cc = c
    do n = 1, itmax
      fac = fac * ((aa * bb) / cc) * z / n
      f1 = temp + fac
      if(f1 == temp) return
      temp = f1
      aa = aa + 1.
      bb = bb + 1.
      cc = cc + 1.
    end do
  end function
end module


MODULE quad_prec_complex
! Quadruple-precision complex arithmetic.
! This should compile and run correctly using any compiler on which the
! module quadruple_precision runs correctly.   There should be no need
! for different versions for different compilers.

! Programmer : Alan Miller, CSIRO Mathematical & Information Sciences
! e-mail: alan @ vic.cmis.csiro.au   URL:  www.ozemail.com.au/~milleraj
! Fax: (+61) 3-9545-8080

! Latest revision - 11 November 1999

USE quadruple_precision
IMPLICIT NONE

TYPE  :: qc
  TYPE (quad) :: qr, qi                ! quad_real, quad_imaginary
END TYPE qc

INTERFACE OPERATOR (+)
  MODULE PROCEDURE qc_add
END INTERFACE

INTERFACE OPERATOR (-)
  MODULE PROCEDURE qc_sub
  MODULE PROCEDURE negate_qc
END INTERFACE

INTERFACE OPERATOR (*)
  MODULE PROCEDURE qc_mult
END INTERFACE

INTERFACE OPERATOR (/)
  MODULE PROCEDURE qc_div
END INTERFACE

INTERFACE ABS
  MODULE PROCEDURE qc_abs
END INTERFACE

INTERFACE CMPLX
  MODULE PROCEDURE qc_cmplx
END INTERFACE

INTERFACE CONJG
  MODULE PROCEDURE qc_conjg
END INTERFACE

INTERFACE AIMAG
  MODULE PROCEDURE qc_aimag
END INTERFACE

INTERFACE SQRT
  MODULE PROCEDURE qc_sqrt
END INTERFACE

INTERFACE LOG
  MODULE PROCEDURE qc_log
END INTERFACE

INTERFACE EXP
  MODULE PROCEDURE qc_exp
END INTERFACE

CONTAINS

FUNCTION qc_add(x, y) RESULT(z)
! Quadruple-precision complex addition

TYPE (qc), INTENT(IN) :: x, y
TYPE (qc)             :: z

z % qr = x % qr + y % qr
z % qi = x % qi + y % qi

RETURN
END FUNCTION qc_add

FUNCTION qc_sub(x, y) RESULT(z)
! Quadruple-precision complex subtraction

TYPE (qc), INTENT(IN) :: x, y
TYPE (qc)             :: z

z%qr = x%qr - y%qr
z%qi = x%qi - y%qi

RETURN
END FUNCTION qc_sub

FUNCTION negate_qc(x) RESULT(z)
! Quadruple-precision complex negate sign

TYPE (qc), INTENT(IN) :: x
TYPE (qc)             :: z

z%qr = - x%qr
z%qi = - x%qi

RETURN
END FUNCTION negate_qc

FUNCTION qc_mult(x, y) RESULT(z)
! Quadruple-precision complex multiplication

TYPE (qc), INTENT(IN) :: x, y
TYPE (qc)             :: z

z%qr = x%qr * y%qr - x%qi * y%qi
z%qi = x%qi * y%qr + x%qr * y%qi

RETURN
END FUNCTION qc_mult

FUNCTION qc_div(x, y) RESULT(z)
! Quadruple-precision complex division

TYPE (qc), INTENT(IN) :: x, y
TYPE (qc)             :: z

TYPE (quad) :: t, d

IF ( ABS(y%qr%hi) > ABS(y%qi%hi) ) THEN
  t = y%qi / y%qr
  d = y%qr + t * y%qi
  z%qr = (x%qr + t * x%qi) / d
  z%qi = (x%qi - t * x%qr) / d
ELSE
  t = y%qr / y%qi
  d = y%qi + t * y%qr
  z%qr = (t * x%qr + x%qi) / d
  z%qi = (t * x%qi - x%qr) / d
END IF

RETURN
END FUNCTION qc_div

FUNCTION qc_cmplx(xr, xi) RESULT(z)
! Convert pair of quad.precision numbers to qc.

TYPE (quad), INTENT(IN) :: xr, xi
TYPE (qc)               :: z

z%qr = xr
z%qi = xi

RETURN
END FUNCTION qc_cmplx

FUNCTION qc_aimag(x) RESULT(z)
! Convert pair of quad.precision numbers to qc.

TYPE (qc), INTENT(IN)   :: x
TYPE (quad)             :: z

z = x%qi

RETURN
END FUNCTION qc_aimag

FUNCTION qc_conjg(x) RESULT(z)
! Quadruple-precision complex square root

TYPE (qc), INTENT(IN) :: x
TYPE (qc)             :: z

z%qr = x%qr
z%qi = - x%qi

RETURN
END FUNCTION qc_conjg

FUNCTION qc_sqrt(x) RESULT(z)
! Quadruple-precision complex square root

TYPE (qc), INTENT(IN) :: x
TYPE (qc)             :: z

! Local variables
TYPE (quad)           :: r
REAL (dp), PARAMETER  :: vsmall = TINY(1.0_dp)

r = SQRT(x%qr **2 + x%qi **2)
IF (r%hi < vsmall) THEN
  z%qr = 0.0_dp
  z%qi = 0.0_dp
  RETURN
END IF

z%qr = SQRT( SCALE( r + ABS(x%qr), -1 ) )
z%qi = ABS( SCALE( x%qi, -1 ) ) / z%qr
IF (x%qr%hi < 0.0_dp) THEN
  r = z%qr
  z%qr = z%qi
  z%qi = r
END IF
IF (x%qi%hi < 0.0_dp) z%qi = - z%qi

RETURN
END FUNCTION qc_sqrt

FUNCTION qc_abs(x) RESULT(z)
! Quadruple-precision complex absolute (modulus)
! SQRT( x%qr **2 + x%qi **2 ) avoiding overflow
! Using either:   X^2 + Y^2 = X^2.(1 + (Y/X)^2)
!           or:             = Y^2.(1 + (X/Y)^2)

TYPE (qc), INTENT(IN) :: x
TYPE (quad)           :: z

TYPE (quad) :: a

IF ( ABS(x%qr%hi) > ABS(x%qi%hi) ) THEN
  a = x%qi / x%qr
  z = ABS( x%qr ) * SQRT( quad(1.0_dp, 0.0_dp) + a**2 )
ELSE IF ( x%qi%hi == 0.0_dp ) THEN
  z = 0.0_dp
ELSE
  a = x%qr / x%qi
  z = ABS( x%qi ) * SQRT( quad(1.0_dp, 0.0_dp) + a**2 )
END IF

RETURN
END FUNCTION qc_abs

FUNCTION qc_exp(x) RESULT(z)
! Quadruple-precision complex exponential

TYPE (qc), INTENT(IN) :: x
TYPE (qc)             :: z

TYPE (quad)           :: expx

expx = EXP(x%qr)
z%qr = expx * COS(x%qi)
z%qi = expx * SIN(x%qi)

RETURN
END FUNCTION qc_exp

FUNCTION qc_log(x) RESULT(z)
! Quadruple-precision complex logarithm

TYPE (qc), INTENT(IN) :: x
TYPE (qc)             :: z

z%qr = LOG( ABS(x) )
z%qi = ATAN2( x%qi, x%qr )

RETURN
END FUNCTION qc_log

END MODULE quad_prec_complex


   program triangle
!=======================================================================
!
!  Create triangle mesh for three different triangles
!   * 90-45-45
!   * 90-60-30
!   * 60-60-60
!
!  Usage:
!   > triangle [size]
!
!   where [size] is the number of points along an edge
!
!=======================================================================
      use mod_vtklib3
      implicit none

      integer :: ia
      integer :: iorder=3    ! triangles
      integer :: jjmax
      integer :: nnode=0     ! number of nodes
      integer :: nelem=0     ! number of elements

      real(8), parameter :: root3=sqrt(3.0d0)

      real(8), allocatable :: xi(:,:)    ! (3,nnode)
      integer, allocatable :: gg(:,:)    ! (iorder,nelem)

      integer, allocatable :: ibc(:)     ! (nnode) boundary condition
      integer, allocatable :: matl(:)    ! (nelem) material number

      character(len=100) :: fname='tri1.vtk'
      character(len=10)  :: line

!--- read command line for size

      jjmax=10      ! number of points on edge, default

      ia=iargc()
      if (ia.gt.0) then
        call getarg(1,line)
        read (line,*) jjmax
      endif

!--- allocate arrays

      allocate (xi(3,jjmax*jjmax))   ! allocation bigger than it has to be
      allocate (gg(3,jjmax*jjmax))   ! allocation bigger than it has to be

      allocate (matl(jjmax*jjmax))
      allocate (ibc(jjmax*jjmax))

      matl(:)=1

!--- build equilateral triangular mesh

      nelem=0
      nnode=0
      gg=0
      ibc=0

      call build_equilateral(jjmax, xi, gg, ibc, nelem, nnode)

      fname='tri1.vtk'
      write (*,'(/,2a)') ' creating vtk file: ', trim(fname)

      open (22,file=fname)
      call vtk_tri1(22, nnode, nelem, iorder, xi, gg)
      call vtk_tri2(22, nnode, ibc,   'bc',       'n')  ! nodal data
      call vtk_tri2(22, nelem, matl,  'material', 'e')   ! element data
      close (22)

!--- build isosceles triangular mesh

      nelem=0
      nnode=0
      gg=0
      ibc=0

      call build_isosceles(jjmax, xi, gg, ibc, nelem, nnode)

      fname='tri2.vtk'
      write (*,'(/,2a)') ' creating vtk file: ', trim(fname)

      open (22,file=fname)
      call vtk_tri1(22, nnode, nelem, iorder, xi, gg)
      call vtk_tri2(22, nnode, ibc,   'bc',       'n')  ! nodal data
      call vtk_tri2(22, nelem, matl,  'material', 'e')   ! element data
      close (22)

!--- build 30/60/90 triangular mesh

      nelem=0
      nnode=0
      gg=0
      ibc=0

      call build_306090(jjmax, xi, gg, ibc, nelem, nnode)

      fname='tri3.vtk'
      write (*,'(/,2a)') ' creating vtk file: ', trim(fname)

      open (22,file=fname)
      call vtk_tri1(22, nnode, nelem, iorder, xi, gg)
      call vtk_tri2(22, nnode, ibc,   'bc',       'n')  ! nodal data
      call vtk_tri2(22, nelem, matl,  'material', 'e')   ! element data
      close (22)

!--- finish

      deallocate (xi,gg)
      deallocate (ibc)
      deallocate (matl)
      end

!=======================================================================
      subroutine build_equilateral(jjmax, xi, gg, ibc, nelem, nnode)
      implicit none
      integer, intent(in)  :: jjmax    ! number of points per side
      integer, intent(out) :: nelem    ! number of elements
      integer, intent(out) :: nnode    ! number of nodes
      real(8), intent(out) :: xi(3,jjmax*jjmax)  ! xyz points
      integer, intent(out) :: gg(3,jjmax*jjmax)  ! element map
      integer, intent(out) :: ibc(jjmax*jjmax)   ! boundary condition map

      integer :: i, j, ii
      real(8) :: delx
      real(8) :: dely
      real(8) :: x, y, x1

      write (*,*)
      write (*,*) 'building equilateral triangle mesh'
      write (*,*) 'number of points along edge ', jjmax

      delx=1.0d0/dble(jjmax-1)
      dely=delx*sqrt(3.0d0)/2.0d0

      y=0.0d0

      x1=0.0d0
      x=0.0d0
      y=0.0d0
      do j=1, jjmax
        x=x1
        ii=jjmax+1-j
        do i=1,ii

           nnode=nnode+1
           xi(1,nnode)=x
           xi(2,nnode)=y
           xi(3,nnode)=0.0d0
           x=x+delx
           if (i.eq.1 .or. i.eq.ii .or. j.eq.1) then
             ibc(nnode)=3
           else
             ibc(nnode)=0
           endif

           if (i.lt.ii) then
             nelem=nelem+1
             gg(1,nelem)=nnode
             gg(2,nelem)=nnode+1
             gg(3,nelem)=nnode+ii
           endif
           if (i.lt.ii-1) then
             nelem=nelem+1
             gg(1,nelem)=nnode+1
             gg(2,nelem)=nnode+ii+1
             gg(3,nelem)=nnode+ii
           endif

        enddo
        y=y+dely
        x1=x1+delx*0.5d0    ! increment half width for start of next time
      enddo

      write (*,*) 'final nnode ', nnode
      write (*,*) 'final nelem ', nelem

!!    write (*,*) 'sqrt3/2 = ', sqrt(3.0d0)/2.0d0
!!    write (*,*) 'final x = ', xi(1,nnode)
!!    write (*,*) 'final y = ', xi(2,nnode)

      x=xi(1,nnode)
      y=xi(2,nnode)
      if (abs(x-0.5d0)            .gt.1.0d-8) stop 'error in final mesh x value'
      if (abs(y-sqrt(3.0d0)/2.0d0).gt.1.0d-8) stop 'error in final mesh y value'

      return
      end subroutine build_equilateral

!=======================================================================
      subroutine build_isosceles(jjmax, xi, gg, ibc, nelem, nnode)
      implicit none
      integer, intent(in)  :: jjmax    ! number of points per side
      integer, intent(out) :: nelem    ! number of elements
      integer, intent(out) :: nnode    ! number of nodes
      real(8), intent(out) :: xi(3,jjmax*jjmax)  ! xyz points
      integer, intent(out) :: gg(3,jjmax*jjmax)  ! element map
      integer, intent(out) :: ibc(jjmax*jjmax)   ! boundary condition map

      integer :: i, j, ii
      real(8) :: delx
      real(8) :: dely
      real(8) :: x, y

      write (*,*)
      write (*,*) 'building isosceles triangle mesh'
      write (*,*) 'number of points along edge ', jjmax

      delx=1.0d0/dble(jjmax-1)
      dely=delx

      y=0.0d0

      x=0.0d0
      y=0.0d0
      do j=1, jjmax
        x=0.0d0
        ii=jjmax+1-j
        do i=1,ii

           nnode=nnode+1
           xi(1,nnode)=x
           xi(2,nnode)=y
           xi(3,nnode)=0.0d0
           x=x+delx
           if (i.eq.1 .or. i.eq.ii .or. j.eq.1) then
             ibc(nnode)=3
           else
             ibc(nnode)=0
           endif

           if (i.lt.ii) then
             nelem=nelem+1
             gg(1,nelem)=nnode
             gg(2,nelem)=nnode+1
             gg(3,nelem)=nnode+ii
           endif
           if (i.lt.ii-1) then
             nelem=nelem+1
             gg(1,nelem)=nnode+1
             gg(2,nelem)=nnode+ii+1
             gg(3,nelem)=nnode+ii
           endif

        enddo
        y=y+dely
      enddo

      write (*,*) 'final nnode ', nnode
      write (*,*) 'final nelem ', nelem

!!    write (*,*) 'final x = ', xi(1,nnode)
!!    write (*,*) 'final y = ', xi(2,nnode)

      x=xi(1,nnode)
      y=xi(2,nnode)
      if (abs(x)      .gt.1.0d-8) stop 'error in final mesh x value'
      if (abs(y-1.0d0).gt.1.0d-8) stop 'error in final mesh y value'

      return
      end subroutine build_isosceles

!=======================================================================
      subroutine build_306090(jjmax, xi, gg, ibc, nelem, nnode)
      implicit none
      integer, intent(in)  :: jjmax    ! number of points per side
      integer, intent(out) :: nelem    ! number of elements
      integer, intent(out) :: nnode    ! number of nodes
      real(8), intent(out) :: xi(3,jjmax*jjmax)  ! xyz points
      integer, intent(out) :: gg(3,jjmax*jjmax)  ! element map
      integer, intent(out) :: ibc(jjmax*jjmax)   ! boundary condition map

      integer :: i, j, ii
      real(8) :: delx
      real(8) :: dely
      real(8) :: x, y

      real(8), parameter :: root3=sqrt(3.0d0)

      write (*,*)
      write (*,*) 'building 30-60-90 triangle mesh'
      write (*,*) 'number of points along edge ', jjmax

      delx=1.0d0/dble(jjmax-1)
      dely=delx*root3

      y=0.0d0
      do j=1, jjmax
        x=0.0d0
        ii=jjmax+1-j
        do i=1,ii

           nnode=nnode+1
           xi(1,nnode)=x
           xi(2,nnode)=y
           xi(3,nnode)=0.0d0
           x=x+delx
           if (i.eq.1 .or. i.eq.ii .or. j.eq.1) then
             ibc(nnode)=3
           else
             ibc(nnode)=0
           endif

           if (i.lt.ii) then
             nelem=nelem+1
             gg(1,nelem)=nnode
             gg(2,nelem)=nnode+1
             gg(3,nelem)=nnode+ii
           endif
           if (i.lt.ii-1) then
             nelem=nelem+1
             gg(1,nelem)=nnode+1
             gg(2,nelem)=nnode+ii+1
             gg(3,nelem)=nnode+ii
           endif

        enddo
        y=y+dely
      enddo

      write (*,*) 'final nnode ', nnode
      write (*,*) 'final nelem ', nelem

!!    write (*,*) 'sqrt3   = ', root3
!!    write (*,*) 'final x = ', xi(1,nnode)
!!    write (*,*) 'final y = ', xi(2,nnode)

      x=xi(1,nnode)
      y=xi(2,nnode)
      if (abs(x)            .gt.1.0d-8) stop 'error in final mesh x value'
      if (abs(y-sqrt(3.0d0)).gt.1.0d-8) stop 'error in final mesh y value'

      return
      end subroutine build_306090
!=======================================================================


!**********************************************************************************************************************************
!
!  PROGRAM:    Compare_LAPACK_MUMPS.f90
!
!  PURPOSE:  Compares a solve of a system of equations by LAPACK and MUMPS.
!
!

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

PROGRAM Compare_LAPACK_MUMPS

    USE NWTC_Library
    USE NWTC_LAPACK
    USE MUMPS
    IMPLICIT NONE

    ! Variables

      ! File name
   CHARACTER(*),PARAMETER :: InputFilePath='C:\Users\bjonkman\Documents\DATA\DesignCodes\simulators\FAST\SVNdirectory\branches\FAST_MUMPS\CertTest\Test21'
   CHARACTER(1024)        :: InputFileRoot
   CHARACTER(1024)        :: InputFileName
   CHARACTER(10)          :: TmpLine

   INTEGER(IntKi)    :: ErrStat
   CHARACTER(1024)   :: ErrMsg

   integer           :: i, j, K, iTest, i_rhs, N, NZ
   integer           :: UnIn, UnOut, UnOut2
   REAL              :: time_begin,  time_end
   REAL              :: time_begin2, time_end2
   REAL              :: init_time, init_time2
   REAL              :: total_time, total_time2

   real,   allocatable :: full_jac(:,:), rhs(:)
   integer,allocatable :: ipiv(:)

   type(SMUMPS_STRUC) :: mumps_par

   !...............................................................................................................................
   ! Initialize the library
   !...............................................................................................................................

   CALL NWTC_Init(  )

   UnOut  = -1
   UnOut2 = -1
   CALL GetNewUnit( UnOut )
   CALL OpenFOutFile( UnOut, 'LAPACK_MUMPS_timings.txt' )

   CALL GetNewUnit(   UnOut2 )
   CALL OpenFOutFile( UnOut2, 'LAPACK_MUMPS_table.txt' )

   !...............................................................................................................................
   ! Initialize MUMPS
   !...............................................................................................................................
   CALL CPU_TIME(time_begin)

      CALL NWTC_SMUMPS_Init( mumps_par, ErrStat, ErrMsg )

   CALL CPU_TIME ( time_end )

   WRITE(UnOut,'(A,ES15.7,A,ES15.7,A)') 'Initialization: MUMPS = ', time_end - time_begin, ' seconds' !; LAPACK = ', time_end2 - time_begin2, ' seconds.'

   UnIn = -1
   do iTest = 27,19,-1

      CALL WrScr( 'Test'//TRIM(num2lstr(iTest)) )

   WRITE(UnOut,'(A)' )  '-----------------------------------------------------------------'

      !...............................................................................................................................
      ! Read the input files for matrix A
      !...............................................................................................................................

      if (iTest==26) then
         InputFileRoot = TRIM(InputFilePath)//'/10/Test21'
      elseif (iTest==27) then
         InputFileRoot = TRIM(InputFilePath)//'/05/Test21'
      else
         InputFileRoot = InputFilePath//'/Test'//TRIM(num2lstr(iTest))
      end if

      !......................
      CALL GetNewUnit( UnIn )
      InputFileName = TRIM(InputFileRoot)//'.0.Jacobian.Sparse'
      CALL OpenFInpFile( UnIn, TRIM(InputFileName) )

      READ(UnIn, *) N, NZ
      read(UnIn,*) tmpLine

         CALL NWTC_SMUMPS_CreateMatrix(mumps_par,n, ErrStat, ErrMsg, nz)
         mumps_par%NZ = nz

      DO I = 1, mumps_par%NZ
         READ(UnIn,*) mumps_par%IRN(I),mumps_par%JCN(I),mumps_par%A(I)
      END DO

      CLOSE(UnIn)

      !......................
      InputFileName = TRIM(InputFileRoot)//'.0.Jacobian'
      CALL OpenFInpFile( UnIn, TRIM(InputFileName) )

         ALLOCATE( full_jac ( mumps_par%N,  mumps_par%N ) )
         ALLOCATE( ipiv (     mumps_par%N               ) )
         ALLOCATE( rhs  (     mumps_par%N               ) )

      read(UnIn,*) tmpLine
      DO I = 1, mumps_par%N
        read(UnIn,*) full_jac(i,:)
      END DO
      CLOSE(UnIn)

      !......................
      InputFileName = TRIM(InputFileRoot)//'.0.RHS'
      CALL OpenFInpFile( UnIn, TRIM(InputFileName) )
      !......................

      !CALL WrScr( '  finished reading matrices' )

      !...............................................................................................................................
      ! Factor matrix A
      !...............................................................................................................................

         ! MUMPS

   CALL CPU_TIME(time_begin)
      CALL NWTC_SMUMPS_AnalyzeAndFactor(mumps_par, ErrStat, ErrMsg)
   CALL CPU_TIME ( time_end )
         if (ErrStat /= ErrID_None) THEN
            DEALLOCATE( full_jac )
            DEALLOCATE( ipiv     )
            DEALLOCATE( rhs      )
            CALL WrScr(TRIM(ErrMsg))
            CALL NWTC_SMUMPS_DestroyMatrix(mumps_par)
            CYCLE
         end if

   init_time =  time_end  - time_begin

         ! LAPACK

   CALL CPU_TIME(time_begin2)
      CALL LAPACK_getrf( M=mumps_par%N, N=mumps_par%N, A=FULL_JAC, IPIV=ipiv, ErrStat=ErrStat, ErrMsg=ErrMsg )
   CALL CPU_TIME ( time_end2 )
         if (ErrStat /= ErrID_None) CALL WrScr(TRIM(ErrMsg))

   init_time2 =  time_end2  - time_begin2

         ! Compare results
   WRITE(UnOut,'( 2(A,ES15.7) )') 'Test'//trim(num2lstr(iTest))//' factorization times: MUMPS = ', init_time, &
                                                                            ' seconds; LAPACK = ', init_time2

      !CALL WrScr( '  finished factoring matrices' )

      !...............................................................................................................................
      ! solve Ax=b
      !...............................................................................................................................
      READ(UnIn,*,iostat=ErrStat) mumps_par%RHS

      i_rhs = 0
      total_time  = 0.
      total_time2 = 0.

      do while (ErrStat == 0  )
         rhs = mumps_par%RHS
         i_rhs = i_rhs + 1
         !call wrscr('RHS'//trim(num2lstr(i_rhs)) )

         ! MUMPS

   CALL CPU_TIME(time_begin)
         CALL NWTC_SMUMPS_Solve(mumps_par, ErrStat, ErrMsg)
   CALL CPU_TIME ( time_end )
   total_time = total_time + time_end  - time_begin
         if (ErrStat /= ErrID_None) CALL WrScr(TRIM(ErrMsg))
         ! LAPACK

   CALL CPU_TIME(time_begin2)
         CALL LAPACK_getrs( TRANS='N', N=mumps_par%N, A=FULL_JAC, IPIV=ipiv, B=rhs, ErrStat=ErrStat, ErrMsg=ErrMsg )
   CALL CPU_TIME ( time_end2 )
   total_time2 = total_time2 + time_end2  - time_begin2
         if (ErrStat /= ErrID_None) CALL WrScr(TRIM(ErrMsg))

   WRITE(UnOut,'( 3(A,ES15.7) )') 'Test'//trim(num2lstr(iTest))//' solve times: MUMPS = ', time_end  - time_begin, &
                                                                    ' seconds; LAPACK = ', time_end2 - time_begin2, &
                                                         ' seconds. Norm of difference = ', TwoNorm( rhs - mumps_par%rhs )

         READ(UnIn,*,iostat=ErrStat) mumps_par%RHS

      end do !while there is a line in the file

   WRITE(UnOut,'( 2(A,ES15.7),A,I5 )') 'Test'//trim(num2lstr(iTest))//' solve times: MUMPS = ', total_time, &
                                                                         ' seconds; LAPACK = ', total_time2, &
                                                                  ' seconds. Number of solves = ', i_rhs

   WRITE(UnOut2, '( 3(I15,1x), 8(ES15.7,1x), I15, 2(1x,ES15.7) )') &
                        iTest, mumps_par%n, mumps_par%nz, 100.0*mumps_par%nz/(mumps_par%n**2), &
                        0.0, 0.0, 0.0,                                                    & !time savings columns
                        init_time, init_time2,                                            & !init time
                        total_time/i_rhs, total_time2/i_rhs,                              & !solve time (calculated)
                        i_rhs, total_time, total_time2

      !...............................................................................................................................
      ! Deallocate arrays and close open files
      !...............................................................................................................................

      CLOSE(UnIn)

      DEALLOCATE( full_jac )
      DEALLOCATE( ipiv     )
      DEALLOCATE( rhs      )

   CALL CPU_TIME(time_begin)
      CALL NWTC_SMUMPS_DestroyMatrix(mumps_par)
   CALL CPU_TIME ( time_end )
   !WRITE (UnOut,*) 'MUMPS exit time: ', time_end - time_begin, ' seconds'
   WRITE(UnOut,* )  !blank line

   end do ! next test case

   CLOSE( UnOut  )
   CLOSE( UnOut2 )
   CALL NWTC_SMUMPS_End(mumps_par)

END PROGRAM Compare_LAPACK_MUMPS


Real Function w1535(dmass)
  Save
  avmass = 0.938868
  pimass = 0.137265
  aux = 0.25*(dmass**2-avmass**2-pimass**2)**2 - (avmass*pimass)**2
  If (aux>0.) Then
     qavail = sqrt(aux/dmass**2)
  Else
     qavail = 1.E-06
  End If
  w1535 = 0.15*qavail/0.467
  Return
End Function w1535