c ======================================================================
c User Subroutine VUMAT for Johnson-Cook model.
c All rights of reproduction or distribution in any form are reserved.
c By Irfan Habeeb CN (PhD, Technion - IIT)
c ======================================================================
      subroutine vumat(
C Read only -
     1     nblock, ndir, nshr, nstatev, nfieldv, nprops, lanneal,
     2     stepTime, totalTime, dt, cmname, coordMp, charLength,
     3     props, density, strainInc, relSpinInc,
     4     tempOld, stretchOld, defgradOld, fieldOld,
     5     stressOld, stateOld, enerInternOld, enerInelasOld,
     6     tempNew, stretchNew, defgradNew, fieldNew,
C Write only -
     7     stressNew, stateNew, enerInternNew, enerInelasNew)
C
      include 'vaba_param.inc'
C
      dimension props(nprops), density(nblock), coordMp(nblock,*),
     1     charLength(nblock), strainInc(nblock,ndir+nshr),
     2     relSpinInc(nblock,nshr), tempOld(nblock),
     3     stretchOld(nblock,ndir+nshr),
     4     defgradOld(nblock,ndir+nshr+nshr),
     5     fieldOld(nblock,nfieldv), stressOld(nblock,ndir+nshr),
     6     stateOld(nblock,nstatev), enerInternOld(nblock),
     7     enerInelasOld(nblock), tempNew(nblock),
     8     stretchNew(nblock,ndir+nshr),
     9     defgradNew(nblock,ndir+nshr+nshr),
     1     fieldNew(nblock,nfieldv),
     2     stressNew(nblock,ndir+nshr), stateNew(nblock,nstatev),
     3     enerInternNew(nblock), enerInelasNew(nblock)

      character*80 cmname
      integer k, k1, k2, iter
      real*8 E, nu, A, B, C, m, n, rate0, Tr, Tm, rho, TQ, Cp, WH,
     1 sigeqv, f, epbar, ep, dep, eprateN, sighyd, sigyT, sigyN, dPwork,
     2 trInc, fT, fs, fN, fNs, sigdotp, epbarN, tempT, tempN, dWork,
     3 mu, alamda, tol,
     4 cmat(6,6), sTrial(6), sNew(6), devS(6), sTem(6), rd(6),
     5 L(6,6), sOld(6), sT(6), np(6)

c input parameters
      E = props(1)				! Young's modulus
      nu = props(2)				! Poisson's ratio
      A = props(3)				! JC parameters
      B = props(4)
      C = props(5)
      n = props(6)
      m = props(7)
      rate0 = props(8)
      Tr = props(9)				! reference temperature
      Tm = props(10)			! melting temperature
      rho = props(11)			! density
      TQ = props(12)			! Taylor-Q heat ener. from plastic deform.
      Cp = props(13)			! specific heat
      WH = props(14)			! work - heat conversion factor

c tolerance of the effe. stress, strain accuracy: ep ~ 1e-9
      tol = E*1e-9 									! strain accuracy or 1e-9
      Niter = 50                  	! max number of N-R iterations

c lame's parameters
      mu = E/(2.d0*(1.d0+nu))
      alamda = E*nu/((1.d0 + nu) * (1.d0 - 2.d0*nu))

c stiffness matrix
			cmat = 0.d0
			do k1 = 1, ndir
				do k2 = 1, ndir
					cmat(k1, k2) = alamda
				end do
				cmat(k1, k1) = alamda + 2.d0*mu
			end do
			do k1 = ndir+1, ndir+nshr
				cmat(k1, k1) = 2.d0*mu
			end do

C -------------------- simulation first step & later -------------------
      do 30 k = 1, nblock
      if (stateOld(k, 1) .eq. 0.d0) then
        go to 10
      else
        go to 20
      end if
C----------------------------- initial state ---------------------------
 10   trInc = sum(strainInc(k, 1:3))
			do k1 = 1, ndir
				stressNew(k, k1) = stressOld(k, k1) + alamda*trInc +
     1		2.d0*mu*strainInc(k, k1)
		 	end do
		 	do k1 = ndir+1, ndir+nshr
		 		stressNew(k, k1) = stressOld(k, k1) +
     1		2.d0*mu*strainInc(k, k1)
     	end do

      stateNew(k, 1) = 1.d0           ! initiation check
      stateNew(k, 2) = 0.d0           ! plastic strain
      stateNew(k, 3) = Tr           	! initial temperature
      stateNew(k, 4) = 0.d0           ! yield stress
      stateNew(k, 5) = 0.d0						! plastic strain incre. last step
      stateNew(k, 6) = 1							! number of iterations
      tempNew(k) = Tr
      go to 30
C-------------------------- 2nd step and later -------------------------
 20   epbar = stateOld(k, 2)
      tempT = stateOld(k, 3)
      sigyT = stateOld(k, 4)
      sOld(1:6) = stressOld(k, 1:6)
      trInc = sum(strainInc(k, 1:3))

      do k1 = 1, ndir
        sT(k1) = stressOld(k,k1) +alamda*trInc +2.d0*mu*strainInc(k, k1)
      end do
      do k1 = ndir+1, ndir+nshr
        sT(k1) = stressOld(k, k1) + 2.d0*mu*strainInc(k, k1)
      end do

c to get the vector for radial reduction
      sighyd = sum(sT(1:ndir))/3.d0
      devS(1:ndir) = sT(1:ndir) - sighyd
      devS(ndir+1:ndir+nshr) = sT(ndir+1:ndir+nshr)

c equivalent stress
      sigeqv = sqrt(3.d0/2.d0 *(devS(1)**2.d0 + devS(2)**2.d0 +
     1 devS(3)**2.d0 + 2.d0*devS(4)**2.d0 + 2.d0*devS(5)**2.d0 +
     2 2.d0*devS(6)**2.d0 ))

c rd is constant over the iterations
			if (sigeqv .gt. 0.d0) then
      	rd = (3.d0*devS)/(2.d0*sigeqv)
      else
      	rd = 0.d0
      end if
			sTem = matmul(cmat, rd)

c initial value of the plastic strain increment and the bounds
      ep = 0.d0											! initial plast. strain incre.
      epmin = 0.d0
      epmax = sigeqv/(2.d0*mu) !max(1.d-5, 3.d0*1.d-5)

c NR - iteration starts
      iter = 0											! number of iterations
      do while (iter .lt. Niter)
        iter = iter + 1
        if (iter .gt. Niter-1.) then
          print*, 'too many iterations, iter = ', iter
          call XPLB_EXIT
        end if

        epbarN = epbar + ep
        eprateN = ep/dt
        tempN = tempT 						! temperature is updated at the end

c updating stress
        sNew = sT - ep*sTem
        sighyd = sum(sNew(1:ndir))/3.d0

c deviatoric stress
        devS(1:ndir) = sNew(1:ndir) - sighyd
        devS(ndir+1:ndir+nshr) = sNew(ndir+1:ndir+nshr)

c equivalent stress
        sigeqv = sqrt(3.d0/2.d0 *(devS(1)**2.d0 + devS(2)**2.d0 +
     1  devS(3)**2.d0 + 2.d0*devS(4)**2.d0 + 2.d0*devS(5)**2.d0 +
     2  2.d0*devS(6)**2.d0 ))

c evaluating new yield stress for the increment 'ep'
	 			call func_syield(A, B, epbarN, n, Tr, Tm, tempN, m, C, eprateN,
     1			rate0, sigyN)
        if (sigyN .lt. sigyT) sigyN = sigyT

        f = sigeqv - sigyN
        if (abs(f) .lt. tol) exit 			! out of the iteration

c elastic criteria, ep = 0 & f < 0
        if ((ep .eq. 0.d0) .and. (f .lt. 0.d0)) go to 12

c rearranging the margins and new plastic strain increm.
        if ((f .ge. 0.d0) .and. (ep .ge. epmin)) epmin = ep
        if ((f .lt. 0.d0) .and. (ep .lt. epmax)) epmax = ep
        ep = 0.5d0 * (epmax + epmin)

c restoring the plastic strain increment from the last step
        if (iter .eq. 1) ep = stateOld(k, 5)
      end do

 12   stressNew(k, 1:6) = sNew(1:6)

c work, plastic work and temp
      dWork = dot_product( 0.5d0*(sOld(1:6) + sNew(1:6)),
     1  strainInc(k, 1:6))
      dPwork = 0.5d0 * ep * sigeqv
      enerInternNew(k) = enerInternOld(k) + dWork/rho
      enerInelasNew(k) = enerInelasOld(k) + dPwork/rho

c updating state variables
 			stateNew(k, 1) = 1.d0							! to flag the initial step
			stateNew(k, 2) = epbarN						! plastic strain
			stateNew(k, 3) = tempT + WH*TQ*dPwork/rho/Cp	! temperature
			stateNew(k, 4) = sigyN						! yield stress
			stateNew(k, 5) = ep 							! plastic strain incre.
			stateNew(k, 6) = stateOld(k, 6) + iter ! number of iterations

 30   continue
      return
      end

c ----------------------------------------------------------------------
      subroutine func_syield(A, B, epbar, n, Tr, Tm, T, m, C, rate,
     1 rate0, sigbar)
		  include 'vaba_param.inc'
		  real*8 A, B, epbar, n, Tr, Tm, T, theta, m, C, rate, rate0, sigbar

		  if (T < Tr) then
		  	theta = 0.d0
		  else if (T > Tm) then
		  	theta = 1.d0
		  else
		  	theta = (T - Tr)/(Tm - Tr)
		  end if

		  if (rate == 0.d0) then
		  	rate = rate0
		  end if

		  sigbar = (A + B*epbar**n)*(1.d0 - theta**m)*
     1 (1.d0 + C*log(rate/rate0))
		  end subroutine
c ----------------------------------------------------------------------


 program poisk_P2_R_tot
 implicit none
 integer :: i
 integer, PARAMETER :: M=1000000
Double Precision, PARAMETER :: two_pii = 6.2831853071796, pii = 3.1415926536, c_cgs=2.99792458D+10, e_cgs=4.8032068D-10,&
                    four_pii= 12.566370614359D0,  &
                    eight_pii= 25.132741228718, &
                    mp_cgs=1.6726231D-24, sp_ht_rel=5.0D0/3.0D0, &
                    kb_cgs=1.380658D-16
Double Precision, PARAMETER :: c2_cgs       = c_cgs**2.0D0   ! Speed of light squared, cm^2/s^2
Double Precision, PARAMETER :: mpc2_cgs     = mp_cgs*c_cgs**2.0D0    ! Rest mass of proton, ergs
Double Precision, PARAMETER :: mpc_cgs      = mp_cgs*c_cgs
Double Precision, PARAMETER :: Gam0=5.0D0/3.0D0
Double Precision, PARAMETER :: delta_W=2.0D0, alpha_W=delta_W/(delta_W-1.0D0)
Double Precision, PARAMETER :: InterstellarMagneticField=8.0D-3, &
    UpstreamNumberDensity=3.0D0, &
    gamma_sh=1.5D0, &
    !gamma_sh=2.0D0, &
    UpstreamFlowSpeed=c_cgs*(1.0D0-1.0D0/gamma_sh**2.0D0)**0.5D0, &
    UpstreamTemperature=1.0D+6
double precision, parameter :: P_w_Up=InterstellarMagneticField**2.0D0/eight_pii
double precision, parameter :: P_th_Up=UpstreamNumberDensity*kb_cgs*UpstreamTemperature
  Double Precision :: Rtot_new, P2_Pxx, P2_En, T_2
  Double Precision :: Rtot_new_a, Rtot_new_b
  Double Precision :: betta0
  Double Precision :: Gam2,Qesc_Pxx, Qesc_En
  Double Precision :: P_w0, P_w2
  Double Precision :: P_th0
  Double Precision :: PP, EE
  Double Precision :: x1, x2
  Double Precision, PARAMETER :: x_m=100, x_h=x_m/M

  betta0=UpstreamFlowSpeed/c_cgs

  P_w0=P_w_Up/(mpc2_cgs*UpstreamNumberDensity)
  P_th0=P_th_Up/(mpc2_cgs*UpstreamNumberDensity)

  Gam2=1.56548D0
 ! Gam2=1.5147D0
  write(*,*) 'Gam2 0=', Gam2
  Qesc_Pxx=0.0D0
  Qesc_En=0.0D0

   Rtot_new_a=2.0D0
   Rtot_new_b=8.0D0
   Rtot_new=(Rtot_new_a+Rtot_new_b)/2.0D0
   DO i=1,100
      P_w2=P_w0*gamma_sh**alpha_W*(Rtot_new**2.0D0-betta0**2.0D0)**(3.0D0/4.0D0)
      P2_Pxx=(1.0D0/(Gam2/((Gam2-1.0D0)*gamma_sh**2.0D0*(Rtot_new**2.0D0-betta0**2.0D0))+ &
              1.0D0/(gamma_sh**2.0D0*betta0**2.0D0)))* &
              (1.0D0-1.0D0/(gamma_sh*DSQRT(Rtot_new**2.0D0-betta0**2.0D0))+Qesc_Pxx+ &
              P_th0*(Gam0/(Gam0-1.0D0)+1.0D0/(gamma_sh**2.0D0*betta0**2.0D0))+ &
              P_w0*(delta_W+1.0D0/(gamma_sh**2.0D0*betta0**2.0D0))- &
              P_w2*(delta_W/(gamma_sh**2.0D0*(Rtot_new**2.0D0-betta0**2.0D0)) &
					+1.0D0/(gamma_sh**2.0D0*betta0**2.0D0)))
      P2_En=((Gam2-1.0D0)*gamma_sh**2.0D0*(Rtot_new**2.0D0-betta0**2.0D0)/(Rtot_new*Gam2))* &
              (1.0D0-Rtot_new/(gamma_sh*DSQRT(Rtot_new**2.0D0-betta0**2.0D0))+Qesc_En+ &
              P_th0*Gam0/(Gam0-1.0D0)+ &
              P_w0*delta_W-P_w2*delta_W*Rtot_new/(gamma_sh**2.0D0*(Rtot_new**2.0D0-betta0**2.0D0)))

       IF ((P2_En-P2_Pxx).GT.0.0D0) then
            Rtot_new_b=Rtot_new
            Rtot_new=(Rtot_new_a+Rtot_new_b)/2.0D0
       else IF ((P2_En-P2_Pxx).LT.0.0D0) then
            Rtot_new_a=Rtot_new
            Rtot_new=(Rtot_new_a+Rtot_new_b)/2.0D0
       else
            exit
       end IF

   end DO

   T_2=P2_Pxx/(gamma_sh*(Rtot_new**2.0D0-betta0**2.0D0)**0.5D0)

  PP=0.0D0
  EE=0.0D0
  DO i=1, M
    x2=x_h*i
    x1=x_h*(i-1)
    PP=PP+0.5D0*x_h*(x1**2.0D0*Dexp(-(1.0D0+x1**2.0D0)**0.5D0/T_2) + &
        x2**2.0D0*Dexp(-(1.0D0+x2**2.0D0)**0.5D0/T_2))
    EE=EE+0.5D0*x_h*(((1.0D0+x1**2.0D0)**0.5D0-1.0D0)*x1**2.0D0*Dexp(-(1.0D0+x1**2.0D0)**0.5D0/T_2) + &
        ((1.0D0+x2**2.0D0)**0.5D0-1.0D0)*x2**2.0D0*Dexp(-(1.0D0+x2**2.0D0)**0.5D0/T_2))
  end DO

  Gam2=1.0D0+T_2*PP/EE

 write(*,*) 'P2_Pxx=', P2_Pxx
 write(*,*) 'P2_En=', P2_En
 write(*,*) 'T_2', T_2
 write(*,*) 'Rtot_new=', Rtot_new
 write(*,*) EE, T_2*PP
 write(*,*) 'Gam2=', Gam2

! PAUSE

 end program poisk_P2_R_tot


SUBROUTINE LAGDER(N,X,Y,DER)
  IMPLICIT NONE
  REAL*8, intent(in) :: X(N),Y(N)
  INTEGER, intent(in):: N
  REAL*8, intent(out):: DER
  ! locals
  INTEGER:: i, j, k
  REAL*8 :: ade, anu, de, xu
  XU=X(1)
  DE=0.D0
  DO K=2,N
     DE=DE+1.D0/(XU-X(K))
  ENDDO
  DE=DE*Y(1)

  DO I=2,N
     ANU=1.D0
     DO J=2,N
        IF(J.EQ.I) CYCLE
        ANU=ANU*(XU-X(J))
     ENDDO
     ADE=1.D0
     DO J=1,N
        IF(J.EQ.I) CYCLE
        ADE=ADE*(X(I)-X(J))
     ENDDO
     DE=DE+Y(I)*ANU/ADE
  ENDDO
  DER=DE
  RETURN
END SUBROUTINE LAGDER


module double_merge_sort_int32
    use,intrinsic :: iso_fortran_env
    implicit none

contains
    subroutine double_merge_sort(ar1, ar2)
        integer(int32),intent(inout):: ar1(:), ar2(:)
        integer(int32):: tmp1(size(ar1)),tmp2(size(ar2))
        integer(int32):: i, n, d, hd

        n = size(ar1)
        do i=1,n-1,2
            if (ar1(i+1) < ar1(i))then
                call swap(ar1(i), ar1(i+1))
                call swap(ar2(i), ar2(i+1))
            end if
        end do
        hd=2
        d=4
        do while(hd < n)
            do i=1,n-d,d
                call merge_sub(ar1(i:i+d-1), ar2(i:i+d-1), tmp1, tmp2, hd, hd+1, d)
            end do
            i = ((n+d-1)/d-1)*d+1
            if (i+hd <= n) then
                call merge_sub(ar1(i:), ar2(i:), tmp1, tmp2, hd, hd+1, n-i+1)
            end if
            hd=d
            d=d*2
        end do
    end subroutine

    subroutine merge_sub(ar1, ar2, tmp1, tmp2, n1, i2, n2)
        integer(int32),intent(inout):: ar1(:), tmp1(:), ar2(:), tmp2(:)
        integer(int32),value:: n1, i2, n2
        integer(int32):: i,i1

        i1=1
        tmp1(i1:n1) = ar1(i1:n1)
        tmp2(i1:n1) = ar2(i1:n1)
        do i=1,n2
            if (n1 < i1) then
                return
            else if (n2 < i2) then
                ar1(i:)=tmp1(i1:n1)
                ar2(i:)=tmp2(i1:n1)
                return
            else
                if (ar1(i2) <= tmp1(i1)) then
                    ar1(i) = ar1(i2)
                    ar2(i) = ar2(i2)
                    i2=i2+1
                else
                    ar1(i) = tmp1(i1)
                    ar2(i) = tmp2(i1)
                    i1=i1+1
                end if
            end if
        end do
    end subroutine

    subroutine swap(x, y)
        integer(int32),intent(inout):: x, y
        integer(int32):: t1, t2

            t1 = x
            t2 = y
            x = t2
            y = t1
    end subroutine
end module double_merge_sort_int32

module double_merge_sort_int64
    use,intrinsic :: iso_fortran_env
    implicit none

contains
    subroutine double_merge_sort(ar1, ar2)
        integer(int64),intent(inout):: ar1(:), ar2(:)
        integer(int64):: tmp1(size(ar1)),tmp2(size(ar2))
        integer(int32):: i, n, d, hd

        n = size(ar1)
        do i=1,n-1,2
            if (ar1(i+1) < ar1(i))then
                call swap(ar1(i), ar1(i+1))
                call swap(ar2(i), ar2(i+1))
            end if
        end do
        hd=2
        d=4
        do while(hd < n)
            do i=1,n-d,d
                call merge_sub(ar1(i:i+d-1), ar2(i:i+d-1), tmp1, tmp2, hd, hd+1, d)
            end do
            i = ((n+d-1)/d-1)*d+1
            if (i+hd <= n) then
                call merge_sub(ar1(i:), ar2(i:), tmp1, tmp2, hd, hd+1, n-i+1)
            end if
            hd=d
            d=d*2
        end do
    end subroutine

    subroutine merge_sub(ar1, ar2, tmp1, tmp2, n1, i2, n2)
        integer(int64),intent(inout):: ar1(:), tmp1(:), ar2(:), tmp2(:)
        integer(int32),value:: n1, i2, n2
        integer(int32):: i,i1

        i1=1
        tmp1(i1:n1) = ar1(i1:n1)
        tmp2(i1:n1) = ar2(i1:n1)
        do i=1,n2
            if (n1 < i1) then
                return
            else if (n2 < i2) then
                ar1(i:)=tmp1(i1:n1)
                ar2(i:)=tmp2(i1:n1)
                return
            else
                if (ar1(i2) <= tmp1(i1)) then
                    ar1(i) = ar1(i2)
                    ar2(i) = ar2(i2)
                    i2=i2+1
                else
                    ar1(i) = tmp1(i1)
                    ar2(i) = tmp2(i1)
                    i1=i1+1
                end if
            end if
        end do
    end subroutine

    subroutine swap(x, y)
        integer(int64),intent(inout):: x, y
        integer(int64):: t1, t2

            t1 = x
            t2 = y
            x = t2
            y = t1
    end subroutine
end module double_merge_sort_int64

module double_merge_sort_char
    use,intrinsic :: iso_fortran_env
    implicit none
contains
    subroutine double_merge_sort(ar1, ar2)
        character(*),intent(inout):: ar1(:)
        integer(int32),intent(inout):: ar2(:)
        character(:),allocatable:: tmp1(:)
        integer(int32),allocatable:: tmp2(:)
        integer(int32):: i, n, d, hd

        allocate(tmp1, mold=ar1)
        allocate(tmp2, mold=ar2)
        n = size(ar1)
        do i=1,n-1,2
            if (ar1(i+1) < ar1(i))then
                call swap_char(ar1(i), ar1(i+1))
                call swap_int(ar2(i), ar2(i+1))
            end if
        end do
        hd=2
        d=4
        do while(hd < n)
            do i=1,n-d,d
                call merge_sub(ar1(i:i+d-1), ar2(i:i+d-1), tmp1, tmp2, hd, hd+1, d)
            end do
            i = ((n+d-1)/d-1)*d+1
            if (i+hd <= n) then
                call merge_sub(ar1(i:), ar2(i:), tmp1, tmp2, hd, hd+1, n-i+1)
            end if
            hd=d
            d=d*2
        end do
    end subroutine

    subroutine merge_sub(ar1, ar2, tmp1, tmp2, n1, i2, n2)
        character(*),intent(inout):: ar1(:), tmp1(:)
        integer(int32),intent(inout):: ar2(:), tmp2(:)
        integer(int32),value:: n1, i2, n2
        integer(int32):: i,i1

        i1=1
        tmp1(i1:n1) = ar1(i1:n1)
        tmp2(i1:n1) = ar2(i1:n1)
        do i=1,n2
            if (n1 < i1) then
                return
            else if (n2 < i2) then
                ar1(i:)=tmp1(i1:n1)
                ar2(i:)=tmp2(i1:n1)
                return
            else
                if (ar1(i2) <= tmp1(i1)) then
                    ar1(i) = ar1(i2)
                    ar2(i) = ar2(i2)
                    i2=i2+1
                else
                    ar1(i) = tmp1(i1)
                    ar2(i) = tmp2(i1)
                    i1=i1+1
                end if
            end if
        end do
    end subroutine

    subroutine swap_char(x, y)
        character(*),intent(inout):: x, y
        character(:),allocatable:: t1, t2

            t1 = x
            t2 = y
            x = t2
            y = t1
    end subroutine

    subroutine swap_int(x, y)
        integer(int32),intent(inout):: x, y
        integer(int32):: t1, t2

            t1 = x
            t2 = y
            x = t2
            y = t1
    end subroutine
end module double_merge_sort_char

module double_merge_sort_mod
    use,intrinsic :: iso_fortran_env
    use double_merge_sort_int32, dms32 => double_merge_sort
    use double_merge_sort_int64, dms64 => double_merge_sort
    use double_merge_sort_char,  dmsch => double_merge_sort
    interface double_merge_sort
        module procedure dms32, dms64, dmsch
    end interface
end module


!!## SUBROUTINE MODULE: <SUB_pQuadrature_dGL>
MODULE SUB_pQuadrature_dGL
!!### PURPOSE
!! Set up an polar angle $[0,\Pi]$
!! Quadrature using the double Gauss-Legendre quadrature set.

!!### EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!### EXTERNAL PROCEDURES
USE SUB_Quadrature_GL                          !!((05-B-SUB_Quadrature_GL.f90))
USE SUB_CLEAR                                  !!((04-A-SUB_CLEAR.f90))
USE FUN_Reverse                                !!((04-A-FUN_Reverse.f90))

!!### DEFAULT IMPLICIT
IMPLICIT NONE

!!### DEFAULT ACCESS
PRIVATE

!!### PROCEDURE LISTING
INTERFACE pQuadrature_dGL
 MODULE PROCEDURE pQuadrature_dGL_Rsp
 MODULE PROCEDURE pQuadrature_dGL_Rdp
END INTERFACE

!!### PUBLIC ACCESS LIST
PUBLIC :: pQuadrature_dGL

!!### MODULE PROCEDURES
CONTAINS

!!### PURE SUBROUTINE: pQuadrature_dGL_Rsp
PURE SUBROUTINE pQuadrature_dGL_Rsp( pOrder , xp,wp , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-B-SUB_pQuadrature_dGL.f90.hdr"
!!--begin--
INCLUDE "06-B-SUB_pQuadrature_dGL.f90.bdy"
!!--end--
END SUBROUTINE

!!### PURE SUBROUTINE: pQuadrature_dGL_Rdp
PURE SUBROUTINE pQuadrature_dGL_Rdp( pOrder , xp,wp , errint , errmsg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-B-SUB_pQuadrature_dGL.f90.hdr"
!!--begin--
INCLUDE "06-B-SUB_pQuadrature_dGL.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE


program compute_pi
    use myenv
    double precision :: psum,x,w
    integer me,nimg,i
    double precision :: pi[*] ! only use pi[1]
    double precision :: part[*]
    integer :: n[*] ! only use n[1]
    character(len=max_name_length) :: nodename[*]
    nimg = num_images()
    me = this_image()
    call  myhostname (nodename)
!    write(*,*)me,nodename
    sync all
    pi = 0.d0
    if (me==1) then
        write(6,*) 'Enter number of intervals'
        read(*,*)n
        write(6,*) 'number of intervals = ',n
    endif
    sync all
    w = 1.d0/n[1]; psum = 0.d0
    do i= me,(n[1]),nimg
        x = w * (i - 0.5d0); psum = psum +4.d0/(1.d0+x*x)
    enddo
    part[me]=psum
    critical
!        write(*,*)"me=",me
        pi[1] = pi[1] + (w * psum)
    end critical
    sync all
    if (me==1) then
            write(6,*) 'computed pi =',pi
            write(6,*) 'images =',nimg
    endif
    sync all
    if ( me == 1) then
     do i=1,nimg
       write(*,*)i,nodename[i]
     enddo
     endif
end


! { dg-do run }
!
! Contributed by mrestelli@gmail.com
! Adapated by Andre Vehreschild  <vehre@gcc.gnu.org>
! Test that fix for PR69296 is working.

program p
 implicit none

 integer :: j, a(2,6), i(3,2)

  a(1,:) = (/ (     j , j=1,6) /)
  a(2,:) = (/ ( -10*j , j=1,6) /)

  i(:,1) = (/ 1 , 3 , 5 /)
  i(:,2) = (/ 4 , 5 , 6 /)

  associate( ai => a(:,i(:,1)) )
    if (any(shape(ai) /= [2, 3])) call abort()
    if (any(reshape(ai, [6]) /= [1 , -10, 3, -30, 5, -50])) call abort()
  end associate

end program p


program tarefab1

    ! Número de passos N
    parameter (N = 1000)
    ! vetor posição
    dimension iposicao(-N:N)

    ! definindo arquivo de saida
    open(10, file='saida-b1-10407962')

    ! recebe a probabilidade p de ir para a direita
    write(*,*) "valor p:"
    read(*,*) p

    ! recebe o número de andarilhos M
    print *, "número de andarilhos M:"
    read(*,*) M

    ! defini inicialmente como zero as variáveis
    iposicao = 0
    iandarilho = 0
    soma = 0
    soma2 = 0

    ! loop dos andarilhos
    do j = 1, M
        ! zera a posição do andarilho
        ix = 0

        ! loop dos passos
        do i = 1, N

            ! condicional para direção do passo
            if (rand().lt.p) then
                ! <= p, vai para direita
                ix = ix + 1
            else
                ! > p, vai para esquerda
                ix = ix - 1
            end if
        end do

        ! soma 1 andarilhos na posição que parou
        iposicao(ix) = iposicao(ix) + 1

        ! soma para <x>
        soma = soma + ix
        ! soma2 para <x**2>
        soma2 = soma2 + ix**2
    end do

    ! loop para salvar as posições no arquivo de saida
    do i = -N, N

        ! condicional para o caso de não tiver andarilho na posição
        ! não salva no arquivo
        if ( iposicao(i).ne.0 ) then
            write(10,'(I0," ",I0)') i, iposicao(i)
        end if
    end do

    ! escreve no terminal o número de passos, <x> e <x**2>
    write(*,'("N: ",I0,"  <x>: ",1F0.3," <x**2>: ",1F0.3)') N, abs(soma)/M, abs(soma2)/M

    ! fecha o arquivo de saida
    close(10)

 end program tarefab1


 implicit none

 integer :: i,a,b,c,p
 character(32) :: bits

 print*,'Give integer a'; read*,a
 print*,'Give integer b'; read*,b
 print*,'Bit position p for single-bit functions on a'; read*,p

 print*,'a          : ',bits(a),'  =  ',a
 print*,'b          : ',bits(b),'  =  ',b
 c=ibset(a,p); print*,'ibset(a,p) : ',bits(c),'  =  ',c
 c=ibclr(a,p); print*,'ibclr(a,p) : ',bits(c),'  =  ',c
 c=ishft(a,p); print*,'ishft(a,p) : ',bits(c),'  =  ',c
 c=iand(a,b);  print*,'iand(a,b)  : ',bits(c),'  =  ',c
 c=ior(a,b);   print*,'ior(a,b)   : ',bits(c),'  =  ',c
 c=ieor(a,b);  print*,'ieor(a,b)  : ',bits(c),'  =  ',c

 end

 function bits(int)

 implicit none

 integer :: i,int
 character(32) :: bits

 bits='00000000000000000000000000000000'
 do i=0,31
   if (btest(int,i)) bits(32-i:32-i)='1'
 end do

 end function bits


      module MOD_INVTRI
      contains
C**********  MODULNAME: INVTRI    ******* 24/03/87  21.15.14.******    41 KARTEN
      PURE SUBROUTINE INVTRI (A,B,C,Q,N)
C TRIDIAGONALE MATRIX   -A(L)   B(L)  -C(L)
C  RECHTE SEITE Q(L)
C  LOESUNG AUF VEKTOR Q(L)
C  ACHTUNG -- AUCH C(L) WIRD VERAENDERT --
!      IMPLICIT REAL*8(A-H,O-Z)
	implicit none
	!global variables
      integer,intent(in) :: N
      real*8,dimension(N),intent(in) :: A,B
	real*8,intent(inout),dimension(N) :: C,Q
	!local variables
	integer :: I,L,NM
	real*8  :: AI,CI,HI,QI, H
!      DIMENSION A(N),B(N),C(N),Q(N)
c      DIMENSION AHELP(200),BHELP(200)
c      IF (N .GT. 200) then
c         write (6,*) ' INVTRI dimension insufficient'
c         STOP 'ERROR'
c      endif
      CI=C(1)/B(1)
      C(1)=CI
      QI=Q(1)/B(1)
      Q(1)=QI
      NM=N-1
      IF (N.EQ.1) RETURN
      IF (N.EQ.2) GOTO 3
      DO 1 I=2,NM
      AI=A(I)
      H=B(I)-AI*CI
      CI=C(I)/H
      C(I)=CI
      QI=(Q(I)+QI*AI)/H
    1 Q(I)=QI
    3 QI=(Q(N)+QI*A(N))/(B(N)-CI*A(N))
      Q(N)=QI
C**  THE BACKWARD ELIMINATION MAY BE SPEEDED UP BY CRAY VECTOR ROUTINE FOLR
c      DO 4 L=2,N
c      AHELP(L)=-C(N+1-L)
c    4 BHELP(L)= Q(N+1-L)
c      BHELP(1)=Q(N)
c      CALL FOLR(N,AHELP,1,BHELP,1)
c      DO 5 L=1,N
c    5 Q(N+1-L)=BHELP(L)
c      RETURN
C***  DEAD BRANCH: RECURSION BY HAND (CAN NOT BE AUTO-VECTORIZED)
c     activated for PC version
      DO 2 I=1,NM
      L=N-I
      QI=Q(L)+C(L)*QI
    2 Q(L)=QI
      RETURN
      END  subroutine
      end module


!! CONTROLA LAS CONDICIONES DE FRONTERA !!

subroutine boundaries_calc

    use arrays
    use global

    implicit none

    !modos R, L y extrapolacion de 2 orden (en la frontera)
    Rmode     = 0.5d0*(Pi - Psi)
    Rmode(0)  = 3.0d0*Rmode(1) - 3.0d0*Rmode(2) + Rmode(3)
    Rmode(Nx) = 3.0d0*Rmode(Nx-1) - 3.0d0*Rmode(Nx-2) + Rmode(Nx-3)
    Lmode     = 0.5d0*(Pi + Psi)
    Lmode(0)  = 3.0d0*Lmode(1) - 3.0d0*Lmode(2) + Lmode(3)
    Lmode(Nx) = 3.0d0*Lmode(Nx-1) - 3.0d0*Lmode(Nx-2) + Lmode(Nx-3)

    !Condiciones de frontera
    if (Boundaries.eq.0) then       !cd. onda saliente
        Psi(0)  = Lmode(0)
        Psi(Nx) = -Rmode(Nx)
        Pi(0)   = Lmode(0)
        Pi(Nx)  = Rmode(Nx)
    else if (Boundaries.eq.1) then  !cd. onda reflexiva
        Psi(0)  = -Psi(1)
        Psi(Nx) = -Psi(Nx-1)
        Pi(0)   = -Pi(1)
        Pi(Nx)  = -Pi(Nx-1)
    else if (Boundaries.eq.2) then  !cd. onda periodica
        Psi(0)  = Psi(Nx-1)
        Psi(Nx) = Psi(1)
        Pi(0)   = Pi(Nx-1)
        Pi(Nx)  = Pi(1)
    else if (Boundaries.eq.3) then  !cd. agujero negro (desaparece)
        Psi(0)  = 3.0d0*Psi(1) - 3.0d0*Psi(2) + Psi(3)
        Psi(Nx) = -Rmode(Nx)
        Pi(0)   = 3.0d0*Pi(1)  - 3.0d0*Pi(2)  + Pi(3)
        Pi(Nx)  = Rmode(Nx)
    else
        print*, 'NOT IMPLEMENTED YET'
    end if

end subroutine boundaries_calc


!-------------------------------------------------------------------------------
! Copyright (c) 2021, Whitman T. Dailey
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!-------------------------------------------------------------------------------
Module Statistics

    Use Kinds, Only: dp
    Implicit None
    Private
    Public :: Do_stats
    Public :: Std_Err
    Public :: std_devs_for_95CI
    Public :: aMean
    Public :: gMean
    Public :: Check_normal_AD
    Public :: Check_exponential_AD
    Public :: Check_uniform_AD

    Interface Std_Err
        Module Procedure Std_Err_real_N
        Module Procedure Std_Err_int4_N
        Module Procedure Std_Err_int8_N
        Module Procedure Std_Err_W
    End Interface

    Real(dp), Parameter :: std_devs_for_95CI = 1.9599639845400542355245944305205515279555500778695483984769526464_dp

Contains

Elemental Function Std_Err_W(W,W_sq,mu,mu_sq) Result(s_mu)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: s_mu
    Real(dp), Intent(In) :: W  !sum of weights for N estimates
    Real(dp), Intent(In) :: W_sq  !sum of squared weights for N estimates
    Real(dp), Intent(In) :: mu  !sum of N estimates
    Real(dp), Intent(In) :: mu_sq  !sum of squares of N estimates
    Real(dp) :: x,y

    x = mu_sq - (mu**2 / W)
    y = W - (W_sq / W)
    If (x.LT.0._dp .OR. y.LE.0._dp) Then !default to a 100% rel std err, but make negative to flag
        s_mu = -mu / W
        Return
    End If
    s_mu = Sqrt( x / (W * y) )
End Function Std_Err_W

Elemental Function Std_Err_real_N(N,mu,mu_sq) Result(s_mu)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: s_mu
    Real(dp), Intent(In) :: N  !n is passed as a real representation of the integer quantity to accomodate numbers > Huge(n)
    Real(dp), Intent(In) :: mu  !sum of N estimates
    Real(dp), Intent(In) :: mu_sq  !sum of squares of N estimates
    Real(dp) :: x

    If (N .LE. 1._dp) Then !default to a 100% rel std err
        s_mu = mu / N
    Else  !otherwise, 2 or more trials were performed, compute standard error
        x = mu_sq - (mu**2 / N)
        If (x .LT. 0._dp) Then !default to a 100% rel std err, but make negative to flag
            s_mu = -mu / N
            Return
        End If
        s_mu = Sqrt( x / (N * (N - 1._dp)) )
    End If
End Function Std_Err_real_N

Elemental Function Std_Err_int4_N(N,mu,mu_sq) Result(s_mu)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: s_mu
    Integer(4), Intent(In) :: N  !number of trials
    Real(dp), Intent(In) :: mu  !sum of N estimates
    Real(dp), Intent(In) :: mu_sq  !sum of squares of N estimates

    s_mu = Std_Err_real_N(Real(N,dp),mu,mu_sq)
End Function Std_Err_int4_N

Elemental Function Std_Err_int8_N(N,mu,mu_sq) Result(s_mu)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: s_mu
    Integer(8), Intent(In) :: N  !number of trials
    Real(dp), Intent(In) :: mu  !sum of N estimates
    Real(dp), Intent(In) :: mu_sq  !sum of squares of N estimates

    s_mu = Std_Err_real_N(Real(N,dp),mu,mu_sq)
End Function Std_Err_int8_N

Subroutine Do_stats(values,mu,sigma,CI_high,CI_low,normality_basic,normality_AD)
    Use Kinds, Only: dp
    Implicit None
    Real(dp), Intent(In) :: values(:)
    Real(dp), Intent(Out) :: mu
    Real(dp), Intent(Out) :: sigma
    Real(dp), Intent(Out) :: CI_high(1:5),CI_low(1:5)
    Logical, Intent(Out) :: normality_basic,normality_AD(1:4)
    Real(dp), Parameter :: confidence_for_interval(1:5) = (/ 0.99_dp , 0.95_dp , 0.9_dp, 0.8_dp , 0.5_dp /)
    Integer :: i

    mu = aMean(values)
    sigma = Std_Dev(values)
    Do i = 1,5
        Call Confidence_Interval_by_bootstrap(values,1._dp-confidence_for_interval(i),CI_high(i),CI_low(i))
    End Do
    normality_basic = Check_normal_BOE(values)
    Call Check_normal_AD(values,normality_AD)
End Subroutine Do_Stats

Function Check_normal_BOE(x) Result(is_normal)
    Use Kinds, Only: dp
    Implicit None
    Logical :: is_normal
    Real(dp), Intent(In) :: x(:)  !sample to be checked for normal distribution
    Real(dp) :: mu,sigma

    is_normal = .TRUE.
    mu = aMean(x)
    sigma = Std_Dev(x)
    If (Abs((MaxVal(x)-mu)) .GT. 3._dp*sigma) is_normal = .FALSE.
    If (Abs((MinVal(x)-mu)) .GT. 3._dp*sigma) is_normal = .FALSE.
End Function Check_normal_BOE

Subroutine Check_normal_AD(x,is_normal,AD_stat)
    !Tests for normality using the Anderson-Darling test
    Use Kinds, Only: dp
    Use Sorting, Only: Quick_Sort
    Implicit None
    Real(dp), Intent(In) :: x(:)  !sample to be checked for normal distribution
    Logical :: is_normal(1:4)  !normality flags for 10, 5, 2.5, 1 percent significance levels
    Real(dp), Intent(Out), Optional :: AD_stat
    Real(dp) :: x_bar,s  !sample mean and standard deviation
    Integer :: n,i
    Real(dp), Allocatable :: z(:)
    Real(dp) :: AD  !test statistic
    Real(dp), Parameter :: AD_crit(1:4) = (/ 0.631_dp, & !10%
                                           & 0.752_dp, & !5%
                                           & 0.873_dp, & !2.5%
                                           & 1.035_dp /) !1%

    is_normal = .TRUE.  !Null hypothesis
    !use sample mean and sample standard dev as estimates to the population statistics
    x_bar = aMean(x)
    s = Std_Dev(x)
    !convert x to z-scores and sort
    n = Size(x)
    Allocate(z(1:n))
    z = (x - x_bar) / s  !compute z-scores for each sample point
    Call Quick_Sort(z)  !sort ascending
    !Compute the test statistic
    AD = 0._dp
    Do i = 1,n
        AD = AD + Real(2*i - 1,dp)*(Log(Std_Normal_CDF(z(i))) + Log(1._dp - Std_Normal_CDF(z(n+1-i))))
    End Do
    AD = (-Real(n,dp) - (AD / Real(n,dp))) * (1._dp + 0.75_dp/Real(n,dp) + 2.25_dp/Real(n**2,dp))
    !compare to critical values
    Where (AD .GT. AD_crit) is_normal = .FALSE. !Reject null hypothesis
    If (Present(AD_stat)) AD_stat = AD
End Subroutine Check_normal_AD

Elemental Function Std_Normal_CDF(z)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: Std_Normal_CDF
    Real(dp), Intent(In) :: z
    Real(dp), Parameter :: sqrt2 = Sqrt(2._dp)

    Std_Normal_CDF = 0.5_dp * (1._dp + ERF(z / sqrt2))
End Function Std_Normal_CDF

Subroutine Check_exponential_AD(x,is_exponential,AD_stat)
    !Tests for normality using the Anderson-Darling test
    Use Kinds, Only: dp
    Use Sorting, Only: Quick_Sort
    Implicit None
    Real(dp), Intent(In) :: x(:)  !sample to be checked for normal distribution
    Logical :: is_exponential(1:4)  !normality flags for 10, 5, 2.5, 1 percent significance levels
    Real(dp), Intent(Out), Optional :: AD_stat
    Integer :: n,i
    Real(dp), Allocatable :: z(:)
    Real(dp) :: s  !estimated scale parameter of the exponential distribution
    Real(dp) :: AD  !test statistic
    Real(dp), Parameter :: AD_crit(1:4) = (/ 1.070_dp, & !10%
                                           & 1.326_dp, & !5%
                                           & 1.587_dp, & !2.5%
                                           & 1.943_dp /) !1%

    is_exponential = .TRUE.  !Null hypothesis
    ! Estimate the scale parameter of the distribution
    s = aMean(x)
    ! Create a sorted copy of the sample
    n = Size(x)
    Allocate(z(1:n))
    z = x
    Call Quick_Sort(z)
    !Compute the test statistic
    AD = 0._dp
    Do i = 1,n
        AD = AD + Real(2*i - 1,dp)*(Log(Exponential_CDF(z(i),s)) + Log(1._dp - Exponential_CDF(z(n+1-i),s)))
    End Do
    AD = (-Real(n,dp) - (AD / Real(n,dp))) * (1._dp + 0.75_dp/Real(n,dp) + 2.25_dp/Real(n**2,dp))
    !compare to critical values
    Where (AD .GT. AD_crit) is_exponential = .FALSE. !Reject null hypothesis
    If (Present(AD_stat)) AD_stat = AD
End Subroutine Check_exponential_AD

Elemental Function Exponential_CDF(z,s)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: Exponential_CDF
    Real(dp), Intent(In) :: z
    Real(dp), Intent(In) :: s

    Exponential_CDF = 1._dp - Exp(-z*s)
End Function Exponential_CDF

Subroutine Check_uniform_AD(x,is_uniform,AD_stat)
    !Tests for normality using the Anderson-Darling test
    Use Kinds, Only: dp
    Use Sorting, Only: Quick_Sort
    Implicit None
    Real(dp), Intent(In) :: x(:)  !sample to be checked for uniform distribution
    Logical :: is_uniform(1:4)  !normality flags for 10, 5, 2.5, 1 percent significance levels
    Real(dp), Intent(Out), Optional :: AD_stat
    Integer :: n,i
    Real(dp), Allocatable :: z(:)
    Real(dp) :: AD  !test statistic
    Real(dp), Parameter :: AD_crit(1:4) = (/ 1.933_dp, & !10%
                                           & 2.492_dp, & !5%
                                           & 3.070_dp, & !2.5%
                                           & 3.853_dp /) !1%

    is_uniform = .TRUE.  !Null hypothesis
    ! Create a sorted copy of the sample
    n = Size(x)
    Allocate(z(1:n))
    z = x
    Call Quick_Sort(z)
    !Compute the test statistic
    AD = 0._dp
    Do i = 1,n
        AD = AD + Real(2*i - 1,dp)*(Log(z(i)) + Log(1._dp - z(n+1-i)))
    End Do
    AD = (-Real(n,dp) - (AD / Real(n,dp))) * (1._dp + 0.75_dp/Real(n,dp) + 2.25_dp/Real(n**2,dp))
    !compare to critical values
    Where (AD .GT. AD_crit) is_uniform = .FALSE. !Reject null hypothesis
    If (Present(AD_stat)) AD_stat = AD
End Subroutine Check_uniform_AD

Subroutine Confidence_Interval_by_bootstrap(x,a,CI_high,CI_low,RNG_seed)
    Use Kinds, Only: dp
    Use Sorting, Only: Quick_Sort
    Implicit None
    Real(dp), Intent(In) :: x(:)  !sample to be bootstrapped for confdence interval
    Real(dp), Intent(In) :: a  !alpha for desired confidence
    Real(dp), Intent(Out) :: CI_high,CI_low
    Integer, Intent(In), Optional :: RNG_seed
    Integer :: n  !number of elements in x
    !TODO Check different numbers of bootstraps against execution time, or consider as a user input
    Integer, Parameter :: n_bootstraps = 2**20  !for now, see TODO above
    Real(dp) :: bootstrapped_means(1:n_bootstraps)
    Real(dp), Allocatable :: bootstrap(:)
    Integer :: i
    Integer :: CI_high_index,CI_low_index
    Integer :: s
    Integer, Allocatable :: ss(:)
    Real(dp), Allocatable :: r(:)

    If (Present(RNG_seed)) Then
        Call RANDOM_SEED(size=s)
        Allocate(ss(1:s))
        ss = RNG_seed
        Call RANDOM_SEED(put=ss)
    Else
        Call RANDOM_SEED()
    End If
    n = Size(x)
    Allocate(bootstrap(n))
    Allocate(r(n))
    Do i = 1,n_bootstraps
        !create a bootstrapped sample
        Call RANDOM_NUMBER(r)
        bootstrap = x(Floor(Real(n,dp)*r) + 1)
        bootstrapped_means(i) = aMean(bootstrap)
    End Do
    !Sort the computed means
    Call Quick_Sort(bootstrapped_means)
    !Select the appropriate means as bounds to theconfidence interval
    CI_high_index = Ceiling((1._dp - a/2._dp) * Real(n_bootstraps,dp))
    CI_low_index = Ceiling((a/2._dp) * Real(n_bootstraps,dp))
    CI_high = bootstrapped_means(CI_high_index)
    CI_low = bootstrapped_means(CI_low_index)
End Subroutine Confidence_Interval_by_bootstrap

Pure Function aMean(x) Result(x_bar)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: x_bar
    Real(dp), Intent(In) :: x(:)

    If (Size(x) .GT. 0) Then
        x_bar = Sum(x) / Real(Size(x),dp)
    Else
        x_bar = 0._dp
    End If
End Function aMean

Pure Function gMean(x) Result(x_bar)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: x_bar
    Real(dp), Intent(In) :: x(:)

    x_bar = Exp(aMean(Log(x + 1._dp))) - 1._dp
End Function gMean

Pure Function Variance(x) Result(s_squared)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: s_squared
    Real(dp), Intent(In) :: x(:)
    Real(dp) :: x_bar

    x_bar = aMean(x)
    s_squared = Sum((x-x_bar)**2) / Real((Size(x)-1),dp)
End Function Variance

Pure Function Std_Dev(x) Result(s)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: s
    Real(dp), Intent(In) :: x(:)

    s = Sqrt(Variance(x))
End Function Std_Dev

End Module Statistics


program residuo_ppal

use datasissim_interface
use residuo_interface

implicit none

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

real :: deter

integer :: n, i, j

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

n = 6

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

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

!call datasissim(a, b, u)

do i=1,n
  do j =1,n
    if(i == j) then
      a(i,i) = 2
    else
      a(i,j) = j - i
    end if
  end do
  print *, a(i,:)
end do

do i =1,n
  b(i) = 2*i
end do
print *, b(:)
u(1) = -1
u(2) = -1
u(3) = -0.5
u(4) = 0.5
u(5) = 0.5
u(6) = 1

call residuo(a, b, u, r)

if (allocated(a)) deallocate(a)

if (allocated(b)) deallocate(b)

if (allocated(u)) deallocate(u)

if(allocated(r)) deallocate(r)

end program


      SUBROUTINE MB03WX( N, P, T, LDT1, LDT2, WR, WI, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the eigenvalues of a product of matrices,
C     T = T_1*T_2*...*T_p, where T_1 is an upper quasi-triangular
C     matrix and T_2, ..., T_p are upper triangular matrices.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix T.  N >= 0.
C
C     P       (input) INTEGER
C             The number of matrices in the product T_1*T_2*...*T_p.
C             P >= 1.
C
C     T       (input) DOUBLE PRECISION array, dimension (LDT1,LDT2,P)
C             The leading N-by-N part of T(*,*,1) must contain the upper
C             quasi-triangular matrix T_1 and the leading N-by-N part of
C             T(*,*,j) for j > 1 must contain the upper-triangular
C             matrix T_j, j = 2, ..., p.
C             The elements below the subdiagonal of T(*,*,1) and below
C             the diagonal of T(*,*,j), j = 2, ..., p, are not
C             referenced.
C
C     LDT1    INTEGER
C             The first leading dimension of the array T.
C             LDT1 >= max(1,N).
C
C     LDT2    INTEGER
C             The second leading dimension of the array T.
C             LDT2 >= max(1,N).
C
C     WR, WI  (output) DOUBLE PRECISION arrays, dimension (N)
C             The real and imaginary parts, respectively, of the
C             eigenvalues of T. The eigenvalues are stored in the same
C             order as on the diagonal of T_1. If T(i:i+1,i:i+1,1) is a
C             2-by-2 diagonal block with complex conjugated eigenvalues
C             then WI(i) > 0 and WI(i+1) = -WI(i).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, February 1999.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Eigenvalue, eigenvalue decomposition, periodic systems,
C     real Schur form, triangular form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      INTEGER          INFO, LDT1, LDT2, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION T( LDT1, LDT2, * ), WI( * ), WR( * )
C     .. Local Scalars ..
      INTEGER          I, I1, INEXT, J
      DOUBLE PRECISION A11, A12, A21, A22, CS, SN, T11, T12, T22
C     .. External Subroutines ..
      EXTERNAL         DLANV2, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        MAX
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( P.LT.1 ) THEN
         INFO = -2
      ELSE IF( LDT1.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDT2.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB03WX', -INFO )
         RETURN
      END IF
C
      INEXT = 1
      DO 30 I = 1, N
         IF( I.LT.INEXT )
     $      GO TO 30
         IF( I.NE.N ) THEN
            IF( T( I+1, I, 1 ).NE.ZERO ) THEN
C
C              A pair of eigenvalues. First compute the corresponding
C              elements of T(I:I+1,I:I+1).
C
               INEXT = I + 2
               I1  = I + 1
               T11 = ONE
               T12 = ZERO
               T22 = ONE
C
               DO 10 J = 2, P
                  T22 = T22*T( I1, I1, J )
                  T12 = T11*T( I,  I1, J ) + T12*T( I1, I1, J )
                  T11 = T11*T( I,  I,  J )
   10          CONTINUE
C
               A11 = T( I,  I, 1 )*T11
               A12 = T( I,  I, 1 )*T12 + T( I,  I1, 1 )*T22
               A21 = T( I1, I, 1 )*T11
               A22 = T( I1, I, 1 )*T12 + T( I1, I1, 1 )*T22
C
               CALL DLANV2( A11, A12, A21, A22, WR( I ), WI( I ),
     $                      WR( I1 ), WI( I1 ), CS, SN )
               GO TO 30
            END IF
         END IF
C
C        Simple eigenvalue. Compute the corresponding element of T(I,I).
C
         INEXT = I + 1
         T11 = ONE
C
         DO 20 J = 1, P
            T11 = T11*T( I, I, J )
   20    CONTINUE
C
         WR( I ) = T11
         WI( I ) = ZERO
   30 CONTINUE
C
      RETURN
C *** Last line of MB03WX ***
      END


      DOUBLE PRECISION FUNCTION DASINH(X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2001-05-25 DASINH  Krogh Minor change for making .f90 version.
C>> 1996-04-01 DASINH Krogh  Converted to Fortran 77 from SFTRAN.
C>> 1995-10-24 DASINH Krogh  Removed blanks in numbers for C conversion.
C>> 1994-10-19 DASINH Krogh  Changes to use M77CON
C>> 1994-04-19 DASINH CLL Edited type stmts to make DP & SP similar.
C>> 1992-03-13 DASINH FTK  Removed implicit statements.
C>> 1986-03-18 DASINH Lawson  Initial code.
C--D replaces "?": ?ACOSH,?ACSCH,?ACTNH,?ASECH,?ASINH,?ATANH
C--&               ?HYPC, ?HYPS, ?HYPH, ?HYPER, ?ERM1
C
C     This program unit has six entry points for computing
C     the six inverse hyperbolic functions.
C     Using the SFTRAN3 preprocessor.
C     Uses D1MACH(3) to obtain machine precision.
C     All critical constants are given correctly rounded
C     to 25 decimal places. Accuracy of the subprogram
C     adapts to the machine precision up to 25 decimal
C     places precision.
C
C     -----------------------------------------------------------
C
C--   Begin mask code changes
C     The single precision code was tested in May 1983, on a
C     Univac 1100 using the JPL program ST4 that compares a
C     single precision function with a double precision function.
C     Each function was tested on at least 6000 points. Max
C     relative errors are expressed as a multiple of R1MACH(3),
C     which for the Univac 1100 is 2**(-27) = 0.745E-8 .
C
C     FUNCTION            RANGE                MAX REL ERROR
C     --------            -----                -------------
C      SASINH       ALL X                           2.4
C
C      SACOSH       1.0 .LE. X .LE. 1.03            LARGE
C                   1.03 .LE. X .LE. 1.21           3.4
C                   1.21 .LE. X                     2.3
C
C      SATANH       ABS(X) .LE. 0.44                3.2
C                   0.44 .LE. ABS(X) .LE. 0.92      5.1
C                   0.92 .LE. ABS(X) .LE. 1.0       LARGE
C
C      SACSCH       ABS(X) .NE. 0                   3.4
C
C      SASECH       0.0 .LT. X .LE. 0.24            2.0
C                   0.24 .LE. X .LE. 0.68           3.0
C                   0.68 .LE. X .LE. 0.88           10.0
C                   0.88 .LE. X .LE. 1.0            LARGE
C
C      SACTNH       1.0 .LE. ABS(X) .LE. 1.16       LARGE
C                   1.16 .LE. ABS(X) .LE. 2.20      7.1
C                   2.20 LE. ABS(X)                 3.7
C
C     -----------------------------------------------------------
C
C     The D.P. and S.P. codes have each been tested using
C     identities such as X - SINH( ASINH(X) ) = 0. The
C     D.P. codes have about the same accuracy relative to
C     D1MACH(3) as do the S.P. codes relative to R1MACH(3).
C
C--   End mask code changes
C     Error Messages
C     1) Arg .LT. 1                        ( IN DACOSH )
C     2) Arg .LT. or .EQ. to 1             ( IN DATANH )
C     3) ABS(Arg) .LT. or .EQ. to 1        ( IN DACTNH )
C     4) Arg .EQ. 0                        ( IN DACSCH )
C     5) Arg .LT. or .EQ. 0 or Arg .GT. 1  ( IN DASECH )
C
C     -----------------------------------------------------------
C
C     C.L.Lawson and Stella Chan,JPL,Feb 23,1983.
C
      DOUBLE PRECISION X
      EXTERNAL DHYPS
      DOUBLE PRECISION DHYPS
C
C     Begin computation for DASINH(x)
C     Defined for all x.The value u ranges from negative infinity to
C     positive infinity as x ranges from negative infinity to positive i

C
      IF (X .EQ. 0.D0) THEN
        DASINH=0.D0
      ELSE
        DASINH = SIGN(DHYPS(ABS(X)), X)
      END IF
      RETURN
      END
C
C
      DOUBLE PRECISION FUNCTION DACOSH(X)
C
C     Defined (double-valued) for all X greater than or equal to 1.
C     We compute the nonnegative value U ranging from zero to infinity
C     as X ranges from 1 to infinity.The second value would be -U.
      DOUBLE PRECISION X
      EXTERNAL DHYPC
      DOUBLE PRECISION DHYPC
C
      IF (X .LT. 1.D0) THEN
        DACOSH=0.D0
        CALL DERM1('DACOSH',1,0,'ARG.LT.1','ARG',X,'.')
      ELSE
        DACOSH = DHYPC(X)
      END IF
      RETURN
      END
C
C
      DOUBLE PRECISION FUNCTION DATANH(X)
C
C     Defined for -1 < x < +1. The value U ranges from negative
C     infinity to positive infinity.
      DOUBLE PRECISION X
      EXTERNAL DHYPH
      DOUBLE PRECISION DHYPH
C
      IF (ABS(X) .GE. 1.D0) THEN
        DATANH=0.D0
        CALL DERM1('DATANH',2,0,'ABS(ARG).GE.1','ARG',X,'.')
      ELSE IF (X .EQ. 0.D0) THEN
        DATANH=0.D0
      ELSE
        DATANH = SIGN(DHYPH(ABS(X)), X)
      END IF
      RETURN
      END
C
C
      DOUBLE PRECISION FUNCTION DACTNH(X)
C
C     Defined for ABS(X) > 1. The value U ranges from zero to negative
C     infinity as X ranges from negative infinity to -1,and from
C     positive infinity to zero as X ranges from 1 to positive
C     infinity.
      DOUBLE PRECISION X
      EXTERNAL DHYPH
      DOUBLE PRECISION DHYPH
C
      IF (ABS(X) .LE. 1.D0) THEN
        DACTNH=0.D0
        CALL DERM1('DACTNH',3,0,'ABS(ARG).LE.1','ARG',X,'.')
      ELSE
        DACTNH = SIGN(DHYPH(1.D0 / ABS(X)), X)
      END IF
      RETURN
      END
C
C
      DOUBLE PRECISION FUNCTION DACSCH(X)
C
C     Defined for all X not equal to 0. The value varies from
C     zero to negative infinity as X ranges from negative
C     infinity to zero,jumps from negative infinity to positive
C     infinity at zero, and varies from positive infinity to
C     zero as X ranges from zero to positive infinity.
      DOUBLE PRECISION X
      EXTERNAL DHYPS
      DOUBLE PRECISION DHYPS
C
      IF (X .EQ. 0.D0) THEN
        DACSCH=0.D0
        CALL DERM1('DACSCH',4,0,'ARG.EQ.0','ARG',X,'.')
      ELSE
        DACSCH = SIGN(DHYPS(1.D0 / ABS(X)), X)
      END IF
      RETURN
      END
C
C
      DOUBLE PRECISION FUNCTION DASECH(X)
C
C     Defined  (double valued) for X greater than zero and X less than
C     or equal to 1.D0. We compute the nonnegative value that varies
C     from infinity to zero as X varies from zero to 1.D0. The other
C     value would be the negative of this.
      DOUBLE PRECISION X
      EXTERNAL DHYPC
      DOUBLE PRECISION DHYPC
C
      IF (X .LE. 0.D0 .OR. X .GT. 1.D0) THEN
        DASECH=0.D0
        CALL DERM1('DASECH',5,0,'ARG.GT.1 OR ARG.LE.0','ARG',X,'.')
      ELSE
        DASECH = DHYPC(1.D0 / X)
      END IF
      RETURN
      END
C
C
      DOUBLE PRECISION FUNCTION DHYPS(P)
C
C     Here P > 0.
C     We break the p range into three intervals separated by CUT2
C     and HICUT. In the middle range between CUT2 and HICUT we use
C           DHYPS=LOG(P+SQRT(1+P**2))
C     CUT2 is set to 1.176 to keep the argument of LOG() greater
C     than e = 2.718 to avoid amplification of relative error by LOG().
C       We set HICUT = 10.**16 assuming that all machines on which
C     this code is to run have overflow limit greater than 10.**32
C     and precision not greater than 32 decimal places. Thus we
C     assume that HICUT**2 would not overflow and HICUT**2 plus or
C     minus 1.D0 would evaluate to HICUT**2.
C     The idea of using DHYPS = LOG(P) + LOG(2) for P .GT. HICUT is
C     copied from an ASINH subroutine due to WAYNE FULLERTON.
C
      DOUBLE PRECISION P
      EXTERNAL DHYPER
      DOUBLE PRECISION CU, CUT2, DHYPER, HICUT, LOGE2
      DATA CUT2, HICUT / 1.176D0, 1.D16 /
      DATA LOGE2 / 0.6931471805599453094172321D0 /
C
      IF (P .GT. HICUT) THEN
        DHYPS = LOG(P) + LOGE2
      ELSE
        CU=SQRT(1.D0+P**2)
        IF (P .LT. CUT2) THEN
          DHYPS = DHYPER(P, CU)
        ELSE
          DHYPS = LOG(P + CU)
        END IF
      END IF
      RETURN
      END
C
C
      DOUBLE PRECISION FUNCTION DHYPC(P)
C
C     Here P .GE. 1.
C     See comments in function DHYPS
C     The mid-range formula for DACOSH is:
C         U=LOG(P+SQRT(P**2-1))
C
      DOUBLE PRECISION P
      EXTERNAL DHYPER
      DOUBLE PRECISION CUT2, DHYPER, HICUT, LOGE2, SU
      DATA CUT2, HICUT / 1.176D0, 1.D16 /
      DATA LOGE2 / 0.6931471805599453094172321D0 /
C
      IF (P .GT. HICUT) THEN
        DHYPC = LOG(P) + LOGE2
      ELSE
        SU = SQRT( (P-1.D0)*(P+1.D0) )
        IF (SU .LT. CUT2) THEN
          DHYPC = DHYPER(SU, P)
        ELSE
          DHYPC = LOG(SU + P)
        END IF
      END IF
      RETURN
      END
C
C
      DOUBLE PRECISION FUNCTION DHYPH(Q)
C
C     Here Q satisfies 0 < Q < 1.
C     When Q exceeds CUT1 = 0.463 then (1+Q)/(1-Q) > e = 2.718,
C     and this is large enough to be used as an argument
C     to LOG() without amplification of relative error.
C     When Q is less than CUT1 we transform Q to COSH(U)
C     and SINH(U) and use procedure (LOW RANGE).
C
C     The simple formulas for CU and SU would be
C           CU = 1.D0 / SQRT(1.D0 - Q**2)
C     and   SU = Q / SQRT(1.D0 - Q**2)
C     The more complicated formulas used here have less
C     accumulation of round-of error since
C     0.0 .LT. TERM .LT. 0.1283
C
      DOUBLE PRECISION Q
      EXTERNAL DHYPER
      DOUBLE PRECISION CUT1, DHYPER, DIF, QSQ, TERM
      DATA CUT1 / 0.463D0 /
C
      IF (Q .LT. CUT1) THEN
        QSQ = Q * Q
        DIF = 1.D0 - QSQ
        TERM = QSQ / (DIF + SQRT(DIF))
        DHYPH = DHYPER(Q + Q*TERM, 1.D0 + TERM)
      ELSE
        DHYPH = 0.5D0 * LOG((1.D0+Q)/(1.D0-Q))
      END IF
      RETURN
      END
C
C  do (LOW RANGE) ==> DYPER(SU, CU)
C
      DOUBLE PRECISION FUNCTION DHYPER(SU, CU)
C
C     This procedure controls computation of U, given
C     SU=SINH(U) and CU=COSH(U).These will satisfy
C          0 .LE. SU .LE. 1.176
C     AND  0 .LE. CU .LE. 1.5437
C     so the result, U , will satisfy
C          0 .LE. U .LE. 1.00052
C
C
C     Here the argument R satisfies 0 .LE. R .LE. SINH(0.125) = 0.125326
C
C     ------------------------------------------------------------------
C
C     On the first call to this procedure the value NMAX
C     will be set and saved.
C     FOR MACHINE PRECISION BETWEEN  4.43062 AND  6.45985 USE NMAX =  2
C     FOR MACHINE PRECISION BETWEEN  6.45985 AND  8.43090 USE NMAX =  3
C     FOR MACHINE PRECISION BETWEEN  8.43090 AND 10.36773 USE NMAX =  4
C     FOR MACHINE PRECISION BETWEEN 10.36773 AND 12.28199 USE NMAX =  5
C     FOR MACHINE PRECISION BETWEEN 12.28199 AND 14.18024 USE NMAX =  6
C     FOR MACHINE PRECISION BETWEEN 14.18024 AND 16.06654 USE NMAX =  7
C     FOR MACHINE PRECISION BETWEEN 16.06654 AND 17.94359 USE NMAX =  8
C     FOR MACHINE PRECISION BETWEEN 17.94359 AND 19.81325 USE NMAX =  9
C     FOR MACHINE PRECISION BETWEEN 19.81325 AND 21.67688 USE NMAX = 10
C     FOR MACHINE PRECISION BETWEEN 21.67688 AND 23.53550 USE NMAX = 11
C     FOR MACHINE PRECISION BETWEEN 23.53550 AND 25.38987 USE NMAX = 12
C
      DOUBLE PRECISION SU, CU
      EXTERNAL D1MACH
      DOUBLE PRECISION B1,B2,C(0:13),CV(8),D1MACH,R,RSQ,SV(8),U,V(8)
      INTEGER I, II, NMAX
      LOGICAL FIRST
      SAVE FIRST, NMAX
C
C     Coeffs for DASINH series. C(0) is half of its true value.
C     This series will be used only for arguments, R , in the
C     range 0 .LE. R .LE. SINH(0.125) = 0.125326 .
C
      DATA   C( 0)/0.5D0/
      DATA   C( 1) /-.1666666666666666666666667D+00/
      DATA   C( 2) /+.7500000000000000000000000D-01/
      DATA   C( 3) /-.4464285714285714285714286D-01/
      DATA   C( 4) /+.3038194444444444444444444D-01/
      DATA   C( 5) /-.2237215909090909090909091D-01/
      DATA   C( 6) /+.1735276442307692307692308D-01/
      DATA   C( 7) /-.1396484375000000000000000D-01/
      DATA   C( 8) /+.1155180089613970588235294D-01/
      DATA   C( 9) /-.9761609529194078947368421D-02/
      DATA   C(10) /+.8390335809616815476190476D-02/
      DATA   C(11) /-.7312525873598845108695652D-02/
      DATA   C(12) /+.6447210311889648437500000D-02/
      DATA   C(13) /-.5740037670841923466435185D-02/
C
C     SV(I) = SINH(V(I))
C     CV(I) = COSH(V(I))
C
      DATA   V( 1) /+.1250000000000000000000000D+00/
      DATA  SV( 1) /+.1253257752411154569820575D+00/
      DATA  CV( 1) /+.1007822677825710859846950D+01/
      DATA   V( 2) /+.2500000000000000000000000D+00/
      DATA  SV( 2) /+.2526123168081683079141252D+00/
      DATA  CV( 2) /+.1031413099879573176159295D+01/
      DATA   V( 3) /+.3750000000000000000000000D+00/
      DATA  SV( 3) /+.3838510679136145687542957D+00/
      DATA  CV( 3) /+.1071140346704586767299498D+01/
      DATA   V( 4) /+.5000000000000000000000000D+00/
      DATA  SV( 4) /+.5210953054937473616224256D+00/
      DATA  CV( 4) /+.1127625965206380785226225D+01/
      DATA   V( 5) /+.6250000000000000000000000D+00/
      DATA  SV( 5) /+.6664922644566160822726066D+00/
      DATA  CV( 5) /+.1201753692975606324229229D+01/
      DATA   V( 6) /+.7500000000000000000000000D+00/
      DATA  SV( 6) /+.8223167319358299807036616D+00/
      DATA  CV( 6) /+.1294683284676844687841708D+01/
      DATA   V( 7) /+.8750000000000000000000000D+00/
      DATA  SV( 7) /+.9910066371442947560531743D+00/
      DATA  CV( 7) /+.1407868656822803158638471D+01/
      DATA   V( 8) /+.1000000000000000000000000D+01/
      DATA  SV( 8) /+.1175201193643801456882382D+01/
      DATA  CV( 8) /+.1543080634815243778477906D+01/
      DATA B1,B2 / 0.52344D0, 4.4306D0 /
c
      data FIRST / .true. /
c
      IF (FIRST) THEN
        FIRST = .FALSE.
C     The following linear expression approximate the NMAX
C     selection criteria described above. The expression
C     never sets NMAX too small but will set NMAX too
C     large, by one, in boundary cases.
        NMAX = 2 + INT(B1 * (-log10(D1MACH(3)) - B2))
        NMAX = MAX(2,MIN(NMAX,12))
      END IF
c
      IF (SU .LE. SV(1)) THEN
        R = SU
      ELSE
        II = MIN ( 7,INT(SU/SV(1)) )
        IF (SU .LT. SV(II)) II = II - 1
C
C     Here we transform to an argument, R , in the range
C     0 .LE. R .LE. SINH(0.125). The simple formula would
C     be :     R = SU * CV(II) - SV(II) * CU
C     However we transform this to extract the factor
C     (SU - SV(II)) for better control of round-off error.
C
        R = (SU-SV(II))*(CV(II)-(SV(II)+SU)*SV(II)/(CV(II)+CU))
      END IF
C
      RSQ = R*R
      U = C(NMAX)
      DO 110 I = NMAX-1, 0, -1
        U = RSQ * U  + C(I)
  110 CONTINUE
      DHYPER = R * (U + 0.5D0)
      IF (SU .GT. SV(1)) DHYPER = V(II) + DHYPER
      return
      end


      SUBROUTINE POISTG (NPEROD,N,MPEROD,M,A,B,C,IDIMY,Y,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C
C     SUBROUTINE POISTG SOLVES THE LINEAR SYSTEM OF EQUATIONS
C
C       A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J)
C       + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J)
C
C       FOR I=1,2,...,M AND J=1,2,...,N.
C
C     THE INDICES I+1 AND I-1 ARE EVALUATED MODULO M, I.E.
C     X(0,J) = X(M,J) AND X(M+1,J) = X(1,J), AND X(I,0) MAY BE EQUAL TO
C     X(I,1) OR -X(I,1) AND X(I,N+1) MAY BE EQUAL TO X(I,N) OR -X(I,N)
C     DEPENDING ON AN INPUT PARAMETER.
C
C
C     * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C             * * * * * *   ON INPUT    * * * * * *
C
C   NPEROD
C     INDICATES THE VALUES WHICH X(I,0) AND X(I,N+1) ARE ASSUMED
C     TO HAVE.
C     = 1 IF X(I,0) = -X(I,1) AND X(I,N+1) = -X(I,N)
C     = 2 IF X(I,0) = -X(I,1) AND X(I,N+1) =  X(I,N)
C     = 3 IF X(I,0) =  X(I,1) AND X(I,N+1) =  X(I,N)
C     = 4 IF X(I,0) =  X(I,1) AND X(I,N+1) = -X(I,N)
C
C   N
C     THE NUMBER OF UNKNOWNS IN THE J-DIRECTION.  N MUST
C     BE GREATER THAN 2.
C
C   MPEROD
C     = 0 IF A(1) AND C(M) ARE NOT ZERO
C     = 1 IF A(1) = C(M) = 0
C
C   M
C     THE NUMBER OF UNKNOWNS IN THE I-DIRECTION.  M MUST
C     BE GREATER THAN 2.
C
C   A,B,C
C     ONE-DIMENSIONAL ARRAYS OF LENGTH M THAT SPECIFY THE COEFFICIENTS
C     IN THE LINEAR EQUATIONS GIVEN ABOVE.  IF MPEROD = 0 THE ARRAY
C     ELEMENTS MUST NOT DEPEND ON THE INDEX I, BUT MUST BE CONSTANT.
C     SPECIFICALLY, THE SUBROUTINE CHECKS THE FOLLOWING CONDITION
C
C           A(I) = C(1)
C           B(I) = B(1)
C           C(I) = C(1)
C
C     FOR I = 1, 2, ..., M.
C
C   IDIMY
C     THE ROW (OR FIRST) DIMENSION OF THE TWO-DIMENSIONAL ARRAY Y AS
C     IT APPEARS IN THE PROGRAM CALLING POISTG.  THIS PARAMETER IS
C     USED TO SPECIFY THE VARIABLE DIMENSION OF Y.  IDIMY MUST BE AT
C     LEAST M.
C
C   Y
C     A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C     RIGHT SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN ABOVE.
C     Y MUST BE DIMENSIONED AT LEAST M X N.
C
C   W
C     A ONE-DIMENSIONAL WORK ARRAY THAT MUST BE PROVIDED BY THE USER
C     FOR WORK SPACE.  W MAY REQUIRE UP TO 9M + 4N + M(INT(LOG2(N)))
C     LOCATIONS.  THE ACTUAL NUMBER OF LOCATIONS USED IS COMPUTED BY
C     POISTG AND RETURNED IN LOCATION W(1).
C
C
C             * * * * * *   ON OUTPUT     * * * * * *
C
C   Y
C     CONTAINS THE SOLUTION X.
C
C   IERROR
C     AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.  EXCEPT
C     FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED.
C     = 0  NO ERROR
C     = 1  IF M .LE. 2
C     = 2  IF N .LE. 2
C     = 3  IDIMY .LT. M
C     = 4  IF NPEROD .LT. 1 OR NPEROD .GT. 4
C     = 5  IF MPEROD .LT. 0 OR MPEROD .GT. 1
C     = 6  IF MPEROD = 0 AND
C          A(I) .NE. C(1) OR B(I) .NE. B(1) OR C(I) .NE. C(1)
C          FOR SOME I = 1, 2, ..., M.
C       = 7 IF MPEROD .EQ. 1 .AND. (A(1).NE.0 .OR. C(M).NE.0)
C
C   W
C     W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C
C     * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   A(M),B(M),C(M),Y(IDIMY,N),
C     ARGUMENTS      W(SEE ARGUMENT LIST)
C
C     LATEST         JUNE 1, 1977
C     REVISION
C
C     SUBPROGRAMS    POISTG,POSTG2,COSGEN,MERGE,TRIX,TRI3,PIMACH
C     REQUIRED
C
C     SPECIAL        NONE
C     CONDITIONS
C
C     COMMON         NONE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     ROLAND SWEET
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        WRITTEN BY ROLAND SWEET IN 1973
C                    REVISED BY ROLAND SWEET IN 1977
C
C     ALGORITHM      THIS SUBROUTINE IS AN IMPLEMENTATION OF THE
C                    ALGORITHM PRESENTED IN THE REFERENCE.
C
C     SPACE          3297(DECIMAL) = 6341(OCTAL) LOCATIONS ON THE
C     REQUIRED       NCAR CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE POISTG IS ROUGHLY PROPORTIONAL
C                    TO M*N*LOG2(N).  SOME TYPICAL VALUES ARE LISTED
C                    IN THE TABLE BELOW.  MORE COMPREHENSIVE TIMING
C                    CHARTS MAY BE FOUND IN THE REFERENCE.
C                       TO MEASURE THE ACCURACY OF THE ALGORITHM A
C                    UNIFORM RANDOM NUMBER GENERATOR WAS USED TO CREATE
C                    A SOLUTION ARRAY X FOR THE SYSTEM GIVEN IN THE
C                    'PURPOSE' WITH
C
C                       A(I) = C(I) = -0.5*B(I) = 1,       I=1,2,...,M
C
C                    AND, WHEN MPEROD = 1
C
C                       A(1) = C(M) = 0
C                       B(1) = B(M) =-1.
C
C                    THE SOLUTION X WAS SUBSTITUTED INTO THE GIVEN SYS-
C                    TEM AND, USING DOUBLE PRECISION, A RIGHT SIDE Y WAS
C                    COMPUTED.  USING THIS ARRAY Y SUBROUTINE POISTG WAS
C                    CALLED TO PRODUCE AN APPROXIMATE SOLUTION Z.  THEN
C                    THE RELATIVE ERROR, DEFINED AS
C
C                       E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J)))
C
C                    WHERE THE TWO MAXIMA ARE TAKEN OVER ALL I=1,2,...,M
C                    AND J=1,2,...,N, WAS COMPUTED.  THE VALUE OF E IS
C                    GIVEN IN THE TABLE BELOW FOR SOME TYPICAL VALUES OF
C                    M AND N.
C
C
C                       M (=N)    MPEROD    NPEROD    T(MSECS)    E
C                       ------    ------    ------    --------  ------
C
C                         31        0-1       1-4        45     9.E-13
C                         31        1         1          21     4.E-13
C                         31        1         3          41     3.E-13
C                         32        0-1       1-4        51     3.E-12
C                         32        1         1          32     3.E-13
C                         32        1         3          48     1.E-13
C                         33        0-1       1-4        42     1.E-12
C                         33        1         1          30     4.E-13
C                         33        1         3          34     1.E-13
C                         63        0-1       1-4       186     3.E-12
C                         63        1         1          91     1.E-12
C                         63        1         3         173     2.E-13
C                         64        0-1       1-4       209     4.E-12
C                         64        1         1         128     1.E-12
C                         64        1         3         199     6.E-13
C                         65        0-1       1-4       143     2.E-13
C                         65        1         1         160     1.E-11
C                         65        1         3         138     4.E-13
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                    ALL MACHINE DEPENDENT CONSTANTS ARE LOCATED IN THE
C                    FUNCTION PIMACH.
C
C     REQUIRED       COS
C     RESIDENT
C     ROUTINES
C
C     REFERENCE      SCHUMANN, U. AND R. SWEET,"A DIRECT METHOD FOR
C                    THE SOLUTION OF POISSON"S EQUATION WITH NEUMANN
C                    BOUNDARY CONDITIONS ON A STAGGERED GRID OF
C                    ARBITRARY SIZE," J. COMP. PHYS. 20(1976),
C                    PP. 171-182.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      DIMENSION       Y(IDIMY,1)
      DIMENSION       W(1)       ,B(1)       ,A(1)       ,C(1)
      IERROR = 0
      IF (M .LE. 2) IERROR = 1
      IF (N .LE. 2) IERROR = 2
      IF (IDIMY .LT. M) IERROR = 3
      IF (NPEROD.LT.1 .OR. NPEROD.GT.4) IERROR = 4
      IF (MPEROD.LT.0 .OR. MPEROD.GT.1) IERROR = 5
      IF (MPEROD .EQ. 1) GO TO 103
      DO 101 I=1,M
         IF (A(I) .NE. C(1)) GO TO 102
         IF (C(I) .NE. C(1)) GO TO 102
         IF (B(I) .NE. B(1)) GO TO 102
  101 CONTINUE
      GO TO 104
  102 IERROR = 6
      RETURN
  103 IF (A(1).NE.0. .OR. C(M).NE.0.) IERROR = 7
  104 IF (IERROR .NE. 0) RETURN
      IWBA = M+1
      IWBB = IWBA+M
      IWBC = IWBB+M
      IWB2 = IWBC+M
      IWB3 = IWB2+M
      IWW1 = IWB3+M
      IWW2 = IWW1+M
      IWW3 = IWW2+M
      IWD = IWW3+M
      IWTCOS = IWD+M
      IWP = IWTCOS+4*N
      DO 106 I=1,M
         K = IWBA+I-1
         W(K) = -A(I)
         K = IWBC+I-1
         W(K) = -C(I)
         K = IWBB+I-1
         W(K) = 2.-B(I)
         DO 105 J=1,N
            Y(I,J) = -Y(I,J)
  105    CONTINUE
  106 CONTINUE
      NP = NPEROD
      MP = MPEROD+1
      GO TO (110,107),MP
  107 CONTINUE
      GO TO (108,108,108,119),NPEROD
  108 CONTINUE
      CALL POSTG2 (NP,N,M,W(IWBA),W(IWBB),W(IWBC),IDIMY,Y,W,W(IWB2),
     1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
     2             W(IWP))
      IPSTOR = W(IWW1)
      IREV = 2
      IF (NPEROD .EQ. 4) GO TO 120
  109 CONTINUE
      GO TO (123,129),MP
  110 CONTINUE
C
C     REORDER UNKNOWNS WHEN MP =0
C
      MH = (M+1)/2
      MHM1 = MH-1
      MODD = 1
      IF (MH*2 .EQ. M) MODD = 2
      DO 115 J=1,N
         DO 111 I=1,MHM1
            MHPI = MH+I
            MHMI = MH-I
            W(I) = Y(MHMI,J)-Y(MHPI,J)
            W(MHPI) = Y(MHMI,J)+Y(MHPI,J)
  111    CONTINUE
         W(MH) = 2.*Y(MH,J)
         GO TO (113,112),MODD
  112    W(M) = 2.*Y(M,J)
  113    CONTINUE
         DO 114 I=1,M
            Y(I,J) = W(I)
  114    CONTINUE
  115 CONTINUE
      K = IWBC+MHM1-1
      I = IWBA+MHM1
      W(K) = 0.
      W(I) = 0.
      W(K+1) = 2.*W(K+1)
      GO TO (116,117),MODD
  116 CONTINUE
      K = IWBB+MHM1-1
      W(K) = W(K)-W(I-1)
      W(IWBC-1) = W(IWBC-1)+W(IWBB-1)
      GO TO 118
  117 W(IWBB-1) = W(K+1)
  118 CONTINUE
      GO TO 107
  119 CONTINUE
C
C     REVERSE COLUMNS WHEN NPEROD = 4.
C
      IREV = 1
      NBY2 = N/2
      NP = 2
  120 DO 122 J=1,NBY2
         MSKIP = N+1-J
         DO 121 I=1,M
            A1 = Y(I,J)
            Y(I,J) = Y(I,MSKIP)
            Y(I,MSKIP) = A1
  121    CONTINUE
  122 CONTINUE
      GO TO (108,109),IREV
  123 CONTINUE
      DO 128 J=1,N
         DO 124 I=1,MHM1
            MHMI = MH-I
            MHPI = MH+I
            W(MHMI) = .5*(Y(MHPI,J)+Y(I,J))
            W(MHPI) = .5*(Y(MHPI,J)-Y(I,J))
  124    CONTINUE
         W(MH) = .5*Y(MH,J)
         GO TO (126,125),MODD
  125    W(M) = .5*Y(M,J)
  126    CONTINUE
         DO 127 I=1,M
            Y(I,J) = W(I)
  127    CONTINUE
  128 CONTINUE
  129 CONTINUE
C
C     RETURN STORAGE REQUIREMENTS FOR W ARRAY.
C
      W(1) = IPSTOR+IWP-1
      RETURN
      END


c     DRSGAMMA
c>> 1996-07-12 DRSGAMMA Krogh  Minor changes for conversion to C.
c>> 1994-10-19 DRSGAMMA Krogh  Changes to use M77CON
c>> 1992-06-11 DRSGAMMA Krogh   Changed "duplication" identity.
c>> 1991-10-21 DRSGAMMA CLL
c>> 1987-12-09 DRSGAMMA Lawson  Initial Code.
c
c--S replaces "?": DR?GAMMA, ?GAMMA, ?LGAMA
      external SGAMMA, SLGAMA
      real             SGAMMA, SLGAMA
      real             LGAM, GAM, PI, X(12), Z
      integer I
c
      data X /-1.5e0, -0.5e0, 0.5e0,  1.0e0,  1.5e0,  2.0e0,
     *          3.0e0, 4.0e0, 5.0e0, 10.0e0, 20.0e0, 30.0e0 /
      data PI / 3.1415926535897932385e0 /
c
      print '(''   X'',9X,''SGAMMA'',10X,''SLGAMA'',10X,''Z''/1x)'
c
      do 10 I = 1, 12
        GAM = SGAMMA(X(I))
        Z = (2.e0 * SQRT(PI) * GAM) / ((2.0e0**X(I)) *
     1    SGAMMA(0.5e0*X(I)) * SGAMMA(0.5e0*X(I)+.5e0)) - 1.e0
        if(X(I) .lt. 0.0e0) then
          print '(1x,F4.1,3X,G15.8, 13x ,1X,E13.2)', X(I), GAM,  Z
        else
          LGAM = SLGAMA(X(I))
          print '(1x,F4.1,3X,G15.8,F13.5,1X,E13.2)', X(I), GAM, LGAM, Z
        endif
   10 continue
      end


! =====================================================================
! function P2XV
!
! This functions computes the expectation value of the angular position
! operator squared.
! ---------------------------------------------------------------------
      double precision function P2XV(nRP,nR,nP,P,RdRP,U)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: P(nP)
      double precision :: RdRP(nR)
      double complex :: U(nRP)

      integer :: i
      integer :: j
      integer :: k

      P2XV = 0.0d0

      k = 0
      do j = 1, nP
         do i = 1, nR
            k = k + 1
            P2XV = P2XV + (P(j)*cdabs(U(k)))**2*RdRP(i)
         enddo
      enddo

      return
      end
! =====================================================================


SUBROUTINE ZHEGST_F95( A, B, ITYPE, UPLO, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: HEGST_F77 => LA_HEGST
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
   INTEGER, INTENT(IN), OPTIONAL :: ITYPE
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   COMPLEX(WP), INTENT(INOUT) :: A(:,:)
   COMPLEX(WP), INTENT(IN) :: B(:,:)
!-----------------------------------------------------------------
!
! Purpose
! =======
!
! LA_SYGST / LA_HEGST reduces a real symmetric-definite or complex
! Hermitian-definite generalized eigenproblem to standard form.
!
! If ITYPE = 1, the problem is A*x = lambda*B*x,
! and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H)
!
! If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
! B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L.
!
! B must have been previously factorized as U**H*U or L*L**H
! by LA_POTRF.
!
! =======
!
!    SUBROUTINE LA_SYGST / LA_HEGST( A, B, ITYPE, UPLO, INFO )
!       CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!       INTEGER, INTENT(IN), OPTIONAL :: ITYPE
!       INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       <type(<wp>), INTENT(IN) :: B(:,:)
!       <type(<wp>), INTENT(INOUT) :: A(:,:)
!    where
!       <wp>   ::= KIND(1.0) | KIND(1.0D0)
!       <type> ::= REAL | COMPLEX
!
! Defaults
! ========
!
! 1. If ITYPE is not present then ITYPE = 1 is assumed.
!
! 2. If UPLO is not present then UPLO = 'U' is assumed.
!
! Arguments
! =========
!
! A       (input/output) either REAL or COMPLEX square array,
!         shape (:,:), size(A,1) == size(A,2) >= 0.
!         On entry, the symmetric (Hermitian) matrix A.
!            If UPLO = 'U', the upper triangular part of A contains
!               the upper triangular part of the matrix A, and the
!               strictly lower triangular part of A is not referenced.
!            If UPLO = 'L', the lower triangular part of A contains
!               the lower triangular part of the matrix A, and the
!               strictly upper triangular part of A is not referenced.
!         On exit, if INFO = 0, the transformed matrix, stored in the
!            same format as A.
!
! B       (input) either REAL or COMPLEX square array,
!         shape (:,:), size(B,1) == size(A,1).
!         The triangular factor from the Cholesky factorization of B,
!         as returned by LA_POTRF.
!
! ITYPE   Optional, (input) INTEGER
!         If ITYPE is present then:
!            = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H);
!            = 2 or 3: compute U*A*U**H or L**H*A*L.
!         otherwise ITYPE = 1 is assumed.
!
! UPLO    Optional, (input) CHARACTER*1
!         If UPLO is present then:
!            = 'U':  Upper triangle of A is stored and B is factored as
!                    U**H*U;
!            = 'L':  Lower triangle of A is stored and B is factored as
!                    L*L**H.
!         otherwise UPLO = 'U' is assumed.
!
! INFO    Optional, (output) INTEGER
!         If INFO is present:
!            = 0: successful exit
!            < 0: if INFO = -i, the i-th argument had an illegal value
!         If INFO is not present and an error occurs, then the program
!            is terminated with an error message.
!
!------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_SHEST'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LUPLO
   INTEGER :: LINFO, N, LD, LITYPE
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC PRESENT, SIZE, MAX
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; N = SIZE(A,1); LD = MAX(1,N)
   IF( PRESENT(ITYPE) )THEN; LITYPE = ITYPE; ELSE; LITYPE = 1; END IF
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
!  .. TEST THE ARGUMENTS
   IF( SIZE( A, 2 ) /= N .OR. N < 0 )THEN; LINFO = -1
   ELSE IF( SIZE( B, 1 ) /= N .OR. SIZE( B, 2 ) /= N )THEN; LINFO = -2
   ELSE IF( LITYPE < 1 .OR. LITYPE > 3 )THEN; LINFO = -3
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -4
   ELSE IF( N > 0 )THEN
!  .. CALL LAPACK77 ROUTINE
      CALL HEGST_F77( LITYPE, LUPLO, N, A, LD, B, LD, LINFO )
   ENDIF
   CALL ERINFO(LINFO,SRNAME,INFO)
END SUBROUTINE ZHEGST_F95


c
c-----------------------------------------------------------------------
c
c
      subroutine p18tru(x,y,rho,u,v,p)
      implicit double precision(a-h,o-z)
      common/p18c/ delta,pmu0,theta1
c
c     # For the point (x,y), compute the true solution at this point for
c     # simple wave flow around a bend as in Whitham, p. 204
c
      pi2 = datan(1.d0)*2.d0
      delta = dsqrt(2.4d0/0.4d0)
      amach = 1.30255d0
      q0 = 1.d0
      a0 = q0/amach
      p0 = 9.04545d0
      rho0 = 1.4d0*p0/a0**2
      dmu0 = dasin(1.d0/amach)
      pmu0 = delta*datan(delta*dtan(dmu0)) - dmu0
c
c     # compute the wall location xw so that (xw,yw) and (x,y) are on
c     # the same characteristic.  Then the solution at (x,y) is equal
c     # to the solution at (xw,yw)
c
      xw = p18xw(x,y)
      theta = p18th(xw)
      dmu = p18mu(theta)
      aratio = dsqrt((1.d0+0.4d0/(2.d0*dsin(dmu0)**2)) /
     &        (1.d0+0.4d0/(2.d0*dsin(dmu)**2)))
      q = a0*aratio/dsin(dmu)
      aa = a0*aratio
      p = p0*((1.d0+0.4d0/(2.d0*dsin(dmu0)**2)) /
     &        (1.d0+0.4d0/(2.d0*dsin(dmu)**2)))**(1.4d0/0.4d0)
      rho = 1.4d0*p/aa**2
      u = q*dcos(theta)
      v = q*dsin(theta)
c     rho = 1.d0
c     u = 3.d0*x + 4.d0*y
c     v = 0.d0
c     p = 4.
      return
      end


PROGRAM generate_coords
IMPLICIT NONE
  REAL :: x = 0, y ! Coordinates to write to a file
  REAL, PARAMETER :: a = 9.81, b = 5.37 ! Acceleration due to gravity in m/s**2 and initial velocity in m/s
  REAL :: inc = 0.1 ! Time increment
  REAL :: noise ! Randomly generated value to add
  REAL, PARAMETER :: DISTORTION = 0.05
  INTEGER :: index, status, lines = 10000
  CHARACTER(LEN = 85) :: msg

  OPEN(UNIT=1, FILE='coords.dat', STATUS='NEW', ACTION='WRITE', IOSTAT=status, IOMSG=msg)
  DO index = 0, lines
    noise = (RAND() * DISTORTION) - (DISTORTION / 2.0)
    x = (x + inc) * (1.0 + noise)
    noise = (RAND() * DISTORTION) - (DISTORTION / 2.0)
    y = (a * x + b) * (1.0 + noise)
    WRITE(1, '(F14.8,1X,F14.8)', IOSTAT=status) x, y
  END DO
  CLOSE(1)
END PROGRAM generate_coords


!==========================================================================
module gsw_mod_freezing_poly_coefficients
!==========================================================================

use gsw_mod_kinds

implicit none

real (r8), parameter :: c0  =  0.017947064327968736_r8
real (r8), parameter :: c1 =  -6.076099099929818_r8
real (r8), parameter :: c2 =   4.883198653547851_r8
real (r8), parameter :: c3 =  -11.88081601230542_r8
real (r8), parameter :: c4 =   13.34658511480257_r8
real (r8), parameter :: c5 =  -8.722761043208607_r8
real (r8), parameter :: c6 =   2.082038908808201_r8
real (r8), parameter :: c7 =  -7.389420998107497_r8
real (r8), parameter :: c8 =  -2.110913185058476_r8
real (r8), parameter :: c9 =   0.2295491578006229_r8
real (r8), parameter :: c10 = -0.9891538123307282_r8
real (r8), parameter :: c11 = -0.08987150128406496_r8
real (r8), parameter :: c12 =  0.3831132432071728_r8
real (r8), parameter :: c13 =  1.054318231187074_r8
real (r8), parameter :: c14 =  1.065556599652796_r8
real (r8), parameter :: c15 = -0.7997496801694032_r8
real (r8), parameter :: c16 =  0.3850133554097069_r8
real (r8), parameter :: c17 = -2.078616693017569_r8
real (r8), parameter :: c18 =  0.8756340772729538_r8
real (r8), parameter :: c19 = -2.079022768390933_r8
real (r8), parameter :: c20 =  1.596435439942262_r8
real (r8), parameter :: c21 =  0.1338002171109174_r8
real (r8), parameter :: c22 =  1.242891021876471_r8

! Note that a = 0.502500117621_r8/gsw_sso
real (r8), parameter :: a = 0.014289763856964_r8
real (r8), parameter :: b = 0.057000649899720_r8

real (r8), parameter :: t0 = 0.002519_r8
real (r8), parameter :: t1 = -5.946302841607319_r8
real (r8), parameter :: t2 =  4.136051661346983_r8
real (r8), parameter :: t3 = -1.115150523403847e1_r8
real (r8), parameter :: t4 =  1.476878746184548e1_r8
real (r8), parameter :: t5 = -1.088873263630961e1_r8
real (r8), parameter :: t6 =  2.961018839640730_r8
real (r8), parameter :: t7 = -7.433320943962606_r8
real (r8), parameter :: t8 = -1.561578562479883_r8
real (r8), parameter :: t9 =  4.073774363480365e-2_r8
real (r8), parameter :: t10 =  1.158414435887717e-2_r8
real (r8), parameter :: t11 = -4.122639292422863e-1_r8
real (r8), parameter :: t12 = -1.123186915628260e-1_r8
real (r8), parameter :: t13 =  5.715012685553502e-1_r8
real (r8), parameter :: t14 =  2.021682115652684e-1_r8
real (r8), parameter :: t15 =  4.140574258089767e-2_r8
real (r8), parameter :: t16 = -6.034228641903586e-1_r8
real (r8), parameter :: t17 = -1.205825928146808e-2_r8
real (r8), parameter :: t18 = -2.812172968619369e-1_r8
real (r8), parameter :: t19 =  1.877244474023750e-2_r8
real (r8), parameter :: t20 = -1.204395563789007e-1_r8
real (r8), parameter :: t21 =  2.349147739749606e-1_r8
real (r8), parameter :: t22 =  2.748444541144219e-3_r8

end module

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