c
      module mod_user_routines
c
      contains
c
      subroutine buildVoigtCMat(lameShear, lameLambda, cOut, cInvOut)
      implicit none
      double precision, intent(in) :: lameShear, lameLambda
      double precision, intent(inout) :: cOut(6,6), cInvOut(6,6)
c     Builds the elastic stiffness matrix into, cOut, as well as its
c     inverse, cInvOut. NOTE, the matrix assumes ENGINEERING strains to
c     stresses! A factor of 2 has been added since engineering
c     shear strains are not used. In other words, Voigt notation is
c     adopted.
      integer :: m, n, np
      double precision :: young, poiss
      np = 3
      young = (lameShear*(3.D0*lameLambda+2.D0*lameShear))/
     &        (lameLambda+lameShear)
      poiss = lameLambda/(2.D0*(lameLambda+lameShear))
c      lameShear = young/(2.D0*(1.D0+poiss))
c      lameLambda = young*poiss/((1.D0+poiss)*(1.D0-2.D0*poiss))

      cOut = 0.D0
      do m=1,np
        do n=1,np
          if (m .ne. n) cOut(m,n) = lameLambda
        end do
        cOut(m,m) = 2.D0*lameShear + lameLambda
        cOut(m+3,m+3) = lameShear !NOTE: Lack of 2 here
      end do

      cInvOut = 0.D0
      do m=1,np
        do n=1,np
          if (m .ne. n) cInvOut(m,n) = -poiss/young
        end do
        cInvOut(m,m) = 1.D0/young
        cInvOut(m+3,m+3) = (2.D0/young)*(1.D0 + poiss) !NOTE: The 2
      end do
      end subroutine buildVoigtCMat
c
      subroutine buildMandelCMat(lameShear, lameLambda, cOut, cInvOut)
      implicit none
      double precision, intent(in) :: lameShear, lameLambda
      double precision, intent(inout) :: cOut(6,6), cInvOut(6,6)
c     Builds the elastic stiffness matrix into, cOut, as well as its
c     inverse, cInvOut. NOTE, the matrix assumes TENSOR strains to
c     stresses! A factor of 2 has been added since engineering
c     shear strains are not used. In other words, Mandel notation is
c     adopted.
      integer :: m, n, np
      double precision :: young, poiss
      np = 3
      young = (lameShear*(3.D0*lameLambda+2.D0*lameShear))/
     &        (lameLambda+lameShear)
      poiss = lameLambda/(2.D0*(lameLambda+lameShear))
c      lameShear = young/(2.D0*(1.D0+poiss))
c      lameLambda = young*poiss/((1.D0+poiss)*(1.D0-2.D0*poiss))

      cOut = 0.D0
      do m=1,np
        do n=1,np
          if (m .ne. n) cOut(m,n) = lameLambda
        end do
        cOut(m,m) = 2.D0*lameShear + lameLambda
        cOut(m+3,m+3) = 2.D0*lameShear !NOTE: There's a 2 here
      end do

      cInvOut = 0.D0
      do m=1,np
        do n=1,np
          if (m .ne. n) cInvOut(m,n) = -poiss/young
        end do
        cInvOut(m,m) = 1.D0/young
        cInvOut(m+3,m+3) = (1.D0/young)*(1.D0 + poiss) !NOTE: Lack of 2
      end do
      end subroutine buildMandelCMat

      subroutine buildP4Mat(P4Out)
      implicit none
      double precision, intent(inout) :: P4Out(6,6)
c     Builds the rank-4 deviatoric projection tensor. The output is in
c     P4Out(1:6,1:6). This tensor, when multiplied by a Voigt or Mandel
c     vector representing a rank-2 tensor, say vec(1:6), results in an
c     Voigt or Mandel vector, respectively that corresponds to the
c     deviatoric components of the original rank-2 tensor.
      integer :: m, n, np

      np = 3
      P4Out = 0.D0
      do m=1,np
        do n=1,np
          if (m .ne. n) P4Out(m,n) = -1.D0/3.D0
        end do
        P4Out(m,m) = 2.D0/3.D0
        P4Out(m+3,m+3) = 1.D0
      end do
      end subroutine buildP4Mat
c
      subroutine mandel2Matrix(manVecIn, matOut)
      implicit none
c     Takes a Mandel vector and converts it back into a 3 X 3 matrix
c     with the SQRT(2) factor taken out of the deviatoric terms. Warp3D
c     follows the same conventions as Abaqus Standard. More
c     specifically, the order of stress/strain components are:
c     1 - xx
c     2 - yy
c     3 - zz
c     4 - xy
c     5 - xz
c     6 - yz
c     Shear strains are taken to be TENSOR COMPONENTS! The user may
c     need to divide the shear strains by a factor of 2.0 before using
c     this routine if the shear strains were originally given as
c     engineering components.
      double precision, parameter :: SQRT2=1.414213562373095048801688724
      double precision, intent(in) :: manVecIn(6)
      double precision, intent(inout) :: matOut(3,3)
c
      matOut(1,1) = manVecIn(1)
      matOut(2,2) = manVecIn(2)
      matOut(3,3) = manVecIn(3)
      matOut(1,2) = manVecIn(4)/SQRT2
      matOut(2,1) = manVecIn(4)/SQRT2
      matOut(1,3) = manVecIn(5)/SQRT2 ! Abaqus Standard stores
      matOut(3,1) = manVecIn(5)/SQRT2 ! the shear components in a
      matOut(2,3) = manVecIn(6)/SQRT2 ! different order than Abaqus
      matOut(3,2) = manVecIn(6)/SQRT2 ! Explicit. WATCH OUT
      end subroutine mandel2Matrix
c
      subroutine matrix2Mandel(matIn, manVecOut)
      implicit none
c     Takes a 3 X 3 symmetric matrix and converts into a Mandel vector
c     by adding a SQRT(2) to the shear terms. Warp3D follows the same
c     conventions as Abaqus Standard. More specifically, the order of
c     stress/strain components are:
c     1 - xx
c     2 - yy
c     3 - zz
c     4 - xy
c     5 - xz
c     6 - yz
c     Shear strains are taken to be TENSOR COMPONENTS! The user may
c     need to divide the shear strains by a factor of 2.0 before using
c     this routine if the shear strains were originally given as
c     engineering components.
      double precision, parameter :: SQRT2=1.414213562373095048801688724
      double precision, intent(in) :: matIn(3,3)
      double precision, intent(inout) :: manVecOut(6)
c
      manVecOut(1) = matIn(1,1)
      manVecOut(2) = matIn(2,2)
      manVecOut(3) = matIn(3,3)       ! Abaqus Standard stores
      manVecOut(4) = matIn(1,2)*SQRT2 ! the shear components in a
      manVecOut(5) = matIn(1,3)*SQRT2 ! different order than Abaqus
      manVecOut(6) = matIn(2,3)*SQRT2 ! Explicit. WATCH OUT
      end subroutine matrix2Mandel
c
      subroutine mandelMat2VoigtMat(matIn, matOut)
      implicit none
c     Takes a matrix in Mandel notation and converts it to Voigt (for
c     what is usually done with the kinematic terms).
      double precision, parameter :: SQRT2=1.414213562373095048801688724
      double precision, intent(in) :: matIn(6,6)
      double precision, intent(inout) :: matOut(6,6)
      integer :: m, n
      double precision :: matTemp(6,6)
c
      matOut = 0.D0
      matTemp = 0.D0
      do n=1,3
        do m=1,3
          matTemp(m,n) = matIn(m,n)
        end do
      end do

      do n=4,6
        do m=1,3
          matTemp(m,n) = matIn(m,n)/SQRT2
        end do
      end do

      do n=1,3
        do m=4,6
          matTemp(m,n) = matIn(m,n)/SQRT2
        end do
      end do

      do n=4,6
        do m=4,6
          matTemp(m,n) = matIn(m,n)/2.D0
        end do
      end do

      matOut(:,:) = matTemp(1:6,1:6)
      end subroutine mandelMat2VoigtMat
c
      subroutine voigtMat2MandelMat(matIn, matOut)
      implicit none
c     Takes a matrix in Voigt notation (for the kinematic terms) and
c     converts it to Mandel
      double precision, parameter :: SQRT2=1.414213562373095048801688724
      double precision, intent(in) :: matIn(6,6)
      double precision, intent(inout) :: matOut(6,6)
      double precision :: matTemp(6,6)
      integer :: m, n

      matOut = 0.D0
      matTemp = 0.D0
      do n=1,3
        do m=1,3
          matTemp(m,n) = matIn(m,n)
        end do
      end do

      do n=4,6
        do m=1,3
          matTemp(m,n) = matIn(m,n)*SQRT2
        end do
      end do

      do n=1,3
        do m=4,6
          matTemp(m,n) = matIn(m,n)*SQRT2
        end do
      end do

      do n=4,6
        do m=4,6
          matTemp(m,n) = matIn(m,n)*2.D0
        end do
      end do

      matOut(:,:) = matTemp(1:6,1:6)
      end subroutine voigtMat2MandelMat
c
      subroutine mandelVec2VoigtVec(vecIn, vecOut, useTwo)
      implicit none
c     Takes a vector in Mandel notation and converts it to a Voigt
c     vector. When useTwo < 1, then it is assumed that the Voigt vector
c     is stored in tensor components. Hence, only a factor of sqrt(2)
c     is needed on the shear terms. If useTwo >= 1, then a factor of two
c     will be included on the shear terms to accomodate for engineering
c     (kinematic) components.
      double precision, parameter :: SQRT2=1.414213562373095048801688724
      integer, intent(in) :: useTwo
      double precision, intent(in) :: vecIn(6)
      double precision, intent(inout) :: vecOut(6)
c
      vecOut = vecIn
      if (useTwo .lt. 1) then
        vecOut(4) = vecOut(4)/SQRT2
        vecOut(5) = vecOut(5)/SQRT2
        vecOut(6) = vecOut(6)/SQRT2
      else
        vecOut(4) = (2.0*vecOut(4))/SQRT2
        vecOut(5) = (2.0*vecOut(5))/SQRT2
        vecOut(6) = (2.0*vecOut(6))/SQRT2
      end if
      end subroutine mandelVec2VoigtVec
c
      subroutine voigtVec2MandelVec(vecIn, vecOut, useTwo)
      implicit none
c     Takes a vector in Voigt notation and converts it to a Mandel
c     vector. When useTwo < 1, then it is assumed that the Voigt vector
c     is stored in tensor components. Hence, only a factor of sqrt(2)
c     is needed on the shear terms. If useTwo >= 1, then a factor of two
c     will be included on the shear terms to accomodate for engineering
c     (kinematic) components.
      double precision, parameter :: SQRT2=1.414213562373095048801688724
      integer, intent(in) :: useTwo
      double precision, intent(in) :: vecIn(6)
      double precision, intent(inout) :: vecOut(6)
c
      vecOut = vecIn
      if (useTwo .lt. 1) then
        vecOut(4) = vecOut(4)*SQRT2
        vecOut(5) = vecOut(5)*SQRT2
        vecOut(6) = vecOut(6)*SQRT2
      else
        vecOut(4) = (vecOut(4)/2.0)*SQRT2
        vecOut(5) = (vecOut(5)/2.0)*SQRT2
        vecOut(6) = (vecOut(6)/2.0)*SQRT2
      end if
      end subroutine voigtVec2MandelVec
c
      subroutine lubksb(a, np, indx, b)
      implicit none
      integer, intent(in) :: np, indx(np)
      double precision, intent(in) :: a(np,np)
      double precision, intent(inout) :: b(np)
c     Solves the set of np linear equations A · X = B. Here a is input,
c     not as the matrix A but rather as its LU decomposition, determined
c     by the routine ludcmp. indx is input as the permutation vector
c     returned by ludcmp. b(1:n) is input as the right-hand side vector
c     B, and returns with the solution vector X. a, n, np, and indx are
c     not modified by this routine and can be left in place for
c     successive calls with different right-hand sides b. This routine
c     takes into account the possibility that b will begin with many
c     zero elements, so it is efficient for use in matrix inversion.
c
      integer :: i, ii, j, ll, n
      double precision :: summ
c
      n = np
c     When ii is set to a positive value, it will become the index
c     of the first nonvanishing element of b. We now do the forward
c     substitution while also unscrambling the permutation as we go
      ii = 0
      do i=1,n
        ll = indx(i)
        summ = b(ll)
        b(ll) = b(i)
        if (ii .ne. 0) then
          do j=ii,i-1
            summ = summ - a(i,j)*b(j)
          end do
        else if (summ .ne. 0.) then
          ii = i   ! A nonzero element is encountered, so from now on
        endif      ! we will have to do the sums in the loop above.
        b(i) = summ
      end do
c
      do i=n,1,-1  ! Now do the backsubstitution
        summ = b(i)
        do j=i+1,n
          summ = summ - a(i,j)*b(j)
        end do
        b(i) = summ/a(i,i) ! Store a component of the solution vector X
      end do
      end subroutine lubksb
c
      subroutine ludcmp(a, np, indx, d, singFlag)
      implicit none
      integer, intent(in) :: np
      integer, intent(inout) :: indx(np), singFlag
      double precision, intent(inout) :: a(np,np), d
c
c     Largest expected n, and a small number.
      integer, parameter :: NMAX = 500
      double precision, parameter :: TINY = 1.0e-20
c
c     Given a matrix a(1:np,1:np), with physical dimension np by np,
c     this routine replaces it by the LU decomposition of a rowwise
c     permutation of itself. a and n are input. a is output, arranged as
c     in equation (2.3.14) above; indx(1:n) is an output vector that
c     records the row permutation effected by the partial pivoting; d is
c     output as ±1 depending on whether the number of row interchanges
c     was even or odd, respectively. This routine is used in combination
c     with lubksb to solve linear equations or invert a matrix. See
c     Numerical Recipes in FORTRAN 77 for more details on the algorithms

      integer :: i, imax, j, k, n
      double precision :: aamax, dum, summ, vv(NMAX)
c     vv stores the implicit scaling of each row.
c
      n = np
      d = 1.        ! No row interchanges yet.
      singFlag = 0  ! Set to 1 if singular
      do i=1,n  ! Loop over rows to get the implicit scaling information
        aamax = 0.
        do j=1,n
          if (abs(a(i,j)) .gt. aamax) aamax = abs(a(i,j))
        end do
c
        if (aamax .eq. 0.) then ! No nonzero largest element.
          !write (59,*) 'singular matrix in ludcmp'
          singFlag = 1
          return ! Exit subroutine and delete element
          !read (*,*)
        endif
        vv(i) = 1./aamax  ! Save scaling
      end do
c
      do j=1,n ! This is the loop over columns in Crout's method
        do i=1,j-1
          summ=a(i,j)
          do k=1,i-1
            summ = summ - a(i,k)*a(k,j)
          end do
          a(i,j) = summ
        end do
c
        aamax = 0. ! Initialize for the search for largest pivot element
        do i=j,n
          summ = a(i,j)
          do k=1,j-1
            summ = summ - a(i,k)*a(k,j)
          end do
          a(i,j) = summ
          dum = vv(i)*abs(summ)     ! Figure of merit for the pivot.
          if (dum .ge. aamax) then  ! Is it better than the best so far?
            imax = i
            aamax = dum
          endif
        end do
c
        if (j .ne. imax) then       ! Do we need to interchange rows?
          do k=1,n               ! Yes, do so...
            dum = a(imax,k)
            a(imax,k) = a(j,k)
            a(j,k) = dum
          end do
          d = -d                    ! ...and change the parity of d.
          vv(imax) = vv(j)          ! Also interchange the scale factor.
        endif
        indx(j) = imax
        if (a(j,j) .eq. 0.) a(j,j) = TINY
c       If the pivot element is zero, the matrix is singular (at least
c       to the precision of the algorithm). For some applications on
c       singular matrices, it is desirable to substitute TINY for zero.
        if (j .ne. n) then ! Now, finally, divide by the pivot element
          dum = 1./a(j,j)
          do i=j+1,n
            a(i,j) = a(i,j)*dum
          end do
        endif
      end do ! Go back for the next column in the reduction.
      end subroutine ludcmp
c
      subroutine calcinv(aMat, np, singFlag, aInv, aLU)
      implicit none
      integer, intent(in) :: np

      integer, intent(inout) :: singFlag
      double precision, intent(in) :: aMat(np,np)
      double precision, intent(inout), optional :: aLU(np,np)
      double precision, intent(inout) :: aInv(np,np)
c     Take the inverse of aMat by solving a linear system equal to the
c     identity matrix. The inverse is calculated using the LU-
c     decomposition method, which uses ludcmp(...). The resultant LU-
c     decomposed matrix is outputted in aLU. Amat is of size
c     np by np, and the inverse is returned in aInv. If aMat is
c     singular, and thus no inverse exists, singFlag will be equal to
c     1; implying that if singFlag == 0, the inverse was a success.
      integer :: i, m
      integer :: indx(np)
      double precision :: d, aLU_cp(np,np)

      aInv = 0.
      aLU_cp = aMat
      singFlag = 0.
      m = np

      call ludcmp(aLU_cp, m, indx, d, singFlag)
      if (present(aLU)) then
        aLU = aLU_cp
      end if
      if (singFlag .eq. 1) then
        return
      end if

      call eyeMat(aInv, m)
      do i=1,m
        call lubksb(aLU_cp, m, indx, aInv(1,i))
      end do
      end subroutine calcinv
c
      subroutine luinv(aLU, np, indx, aInv)
      implicit none
      integer, intent(in) :: np, indx(np)
      double precision, intent(in) :: aLU(np,np)
      double precision, intent(inout) :: aInv(np,np)
c     Calculates the inverse of aLU and outputs it in aInv. aLU must
c     already be decomposed into an LU-matrix; use ludcmp(...) to do so.
c     indx is an array of integers also outputted by ludcmp(...) that is
c     required here. The size of aLU is expected to np by np, and it is
c     assumed that aLU is invertible (not singular).
      integer :: i, m
      double precision :: aLU_cp(np,np)
      m = np

      aLU_cp = aLU
      call eyeMat(aInv, m)
      do i=1,m
        call lubksb(aLU_cp, m, indx, aInv(1,i))
      end do
      end subroutine luinv
c
      subroutine ludet(aLU, np, d, aDet)
      implicit none
      integer, intent(in) :: np
      double precision, intent(in) :: aLU(np,np), d
      double precision, intent(inout) :: aDet
c     Works with the output of ludcmp(a, np, indx, d) where matrix
c     a(1:np) gets destroyed and replaced with a row-permutation of the
c     LU-decomposition of matrix a(1:np), denoted as input here,
c     aLU(1:np). Then, d (+1 or -1) is also calculated based on if the
c     number of row permutations are even or odd. This algorithm
c     attempts to locally  scale the diagonals of aLU while calculating
c     the determinant in order to prevent an overflow. The resultant
c     determinant is stored into aDet.
c
      integer :: i, m
      double precision :: rho, K, u(np), uMag, nn
c
      m = np
      uMag = 0.
      do i=1,m ! Collect the diagonal components of aLU
        u(i) = aLU(i,i)
      end do
      call vecmag(u, m, uMag)
c
      rho = 1.
      do i=1,m
        rho = rho*(u(i)/uMag)
      end do
      rho = d*rho
c
      nn = np
      K = 0.
      do i=1,m
        K = K + log(uMag)
      end do
      K = exp((1./nn)*K)
c
      aDet = rho*(K**np)
c
c     Original, simpler method, but could cause overflow
c      m = np
c      aDet = d
c      do i=1,m
c        aDet = aDet*aLU(i,i)
c      end do
      end subroutine ludet
c
      subroutine calcdet(Amat, np, Adet)
      implicit none
      integer, intent(in) :: np
      double precision, intent(in) :: Amat(np,np)
      double precision, intent(inout) :: Adet
c     This is a quicker method of calculating the determinant of
c     either 1) a scaler value (np = 1); 2) a 2D matrix (np = 2);
c     or 3) a 3D matrix (np = 3). Otherwise, the determinant will be
c     calculated from an scaled LU-decomposition method. The
c     resultant determinant is stored in Adet.
c
      integer :: i, m, failFlag, indxVec(np)
      double precision :: d, Amat_cp(np,np)
      m = np
      Adet = 0.
c
      if (np .eq. 1) then
        Adet = Amat(1,1)
      elseif (np .eq. 2) then
        Adet = Amat(1,1)*Amat(2,2) - Amat(1,2)*Amat(2,1)
      elseif (np .eq. 3) then
        Adet = -Amat(1,3)*Amat(2,2)*Amat(3,1) +
     1         Amat(1,2)*Amat(2,3)*Amat(3,1) +
     2         Amat(1,3)*Amat(2,1)*Amat(3,2) -
     3         Amat(1,1)*Amat(2,3)*Amat(3,2) -
     4         Amat(1,2)*Amat(2,1)*Amat(3,3) +
     5         Amat(1,1)*Amat(2,2)*Amat(3,3)
      else
        Amat_cp = Amat ! Make a copy
        call ludcmp(Amat_cp, np, indxVec, d, failFlag)
        call ludet(Amat_cp, np, d, Adet)
      endif
      end subroutine calcdet
c
      subroutine getInvar(Amat, np, InvarVec)
      implicit none
      integer, intent(in) :: np
      double precision, intent(in) :: Amat(np,np)
      double precision, intent(inout) :: InvarVec(3)
c     Calculates the 3 invariants of matrix Amat(1:np,1:np), and stores
c     them into InvarVec(1:3); InvarVec(1) = I1, InvarVec(2) = I2, and
c     InvarVec(3) = I3.
c
      integer :: i, j, m
      double precision :: I1, I2, summ, I3, Amattr(np,np)
c
      m = np
      I1 = 0.
      I2 = 0.
      I3 = 0.
c
      do i=1,m  ! I1 = trace[Amat]
        I1 = I1 + Amat(i,i)
      end do
c
      call matrixtrnps(Amat, m, m, Amattr)
      call matdbldotmat(Amat, Amattr, m, summ)
      I2 = 0.5*(I1*I1 - summ)
c
      call calcdet(Amat, np, I3)
c
      InvarVec(1) = I1
      InvarVec(2) = I2
      InvarVec(3) = I3
      end subroutine getInvar
c
      subroutine eyeMat(IMat, np)
      implicit none
c     Function eye(np) creates an np by np identity matrix into
c     IMat(1:np, 1:np), which gets destroyed in the process.
      integer, intent(in) :: np
      double precision, intent(inout) :: IMat(np,np)
      integer i, m
c
      IMat = 0.D0
      m = np
      do i=1,m
        IMat(i,i) = 1.D0
      end do
      end subroutine eyeMat
c
      subroutine vecdotvec(a, b, np, c)
      implicit none
      integer, intent(in) :: np
      double precision, intent(in) :: a(np), b(np)
      double precision, intent(inout) :: c
c     The inner dot product between vector a(1:np) and b(1:np), and
c     stores it into c.
c      integer :: i, m
c      m = np
      c = 0.
c
c     do i=1,m
c       c = c + a(i)*b(i)
c     end do
c
      c = dot_product(a,b)
      end subroutine vecdotvec
c
      subroutine vecoutervec(a, b, np, c)
      implicit none
      integer, intent(in) :: np
      double precision, intent(in) :: a(np), b(np)
      double precision, intent(inout) :: c(np,np)
c     Two vectors, a(1:np) and b(1:np), are multiplied using the outer
c     product in order to produce a matrix, c(1:np, 1:np).
      integer :: i, j, m
      c = 0.D0
      m = np
      do j=1,m
        do i=1,m
          c(i,j) = a(i)*b(j)
        end do
      end do
      end subroutine vecoutervec
c
      subroutine vecmag(bvec, np, bmag)
      implicit none
      integer, intent(in) :: np
      double precision, intent(in) :: bvec(np)
      double precision, intent(inout) :: bmag
c     Calculates the vector magnitude of bvec(1:np) and stores it
c     into bmag
c      integer :: i, m
c      m = np
      bmag = 0.

c     do i=1,m
c       bmag = bmag + bvec(i)*bvec(i)
c     end do
c     bmag = sqrt(bmag)
c
      bmag = norm2(bvec)
      end subroutine vecmag
c
      subroutine matFrobeniusnorm(Amat, np, L2Out)
      implicit none
c     Calculate the Frobenius norm of matrix Amat, and output in L2Out
      integer, intent(in) :: np
      double precision, intent(in) :: Amat(np,np)
      double precision, intent(inout) :: L2Out
c
      integer :: i, j, m
      double precision :: summ
c
      L2Out = 0.D0
      summ = 0.D0
      m = np
      do i=1,m
        do j=1,m
          summ = summ + Amat(j,i)**2
        end do
      end do
c
      L2Out = sqrt(summ)
      end subroutine matFrobeniusnorm
c
      subroutine matdotvec(Amat, bvec, np, cvec)
      implicit none
      integer, intent(in) :: np
      double precision, intent(in) :: Amat(np,np), bvec(np)
      double precision, intent(inout) :: cvec(np)
c     Calculates A [dot] b = c, or index notation, c_i = A_ij * b_j
c      integer :: i, j, m
c
c      m = np
      cvec = 0.
c     do j=1,m
c       do i=1,m
c         cvec(i) = cvec(i) + Amat(i,j)*bvec(j)
c       end do
c     end do
c
      cvec = MATMUL(Amat, bvec)
      end subroutine matdotvec
c
      subroutine vecdotmat(Amat, bvec, np, cvec)
      implicit none
      integer, intent(in) :: np
      double precision, intent(in) :: Amat(np,np), bvec(np)
      double precision, intent(inout) :: cvec(np)
c     Calculates b [dot] A = c, or index notation, c_j = A_ij * b_i
c      integer :: i, j, m
c      m = np

      cvec = 0.
c     do j=1,m
c       do i=1,m
c         cvec(j) = cvec(j) + Amat(i,j)*bvec(i)
c       end do
c     end do
      cvec = MATMUL(bvec, Amat)
      end subroutine vecdotmat
c
      subroutine matdotmat(Amat, Bmat, np, Cmat)
      implicit none
      integer, intent(in) :: np
      double precision, intent(in) ::  Amat(np,np), Bmat(np,np)
      double precision, intent(inout) :: Cmat(np,np)
c     Calculates the inner product between two square matrices,
c     Amat and Bmat. The resultant matrix is, Cmat(1:np,1:np).
c     In index notation, C_ij = A_ik * B_kj, where it is implied
c     that there is a sum on k.
c
c      integer :: i, j, k, m
c      m = np
      Cmat = 0.D0
c
c     do j=1,m
c       do k=1,m
c         do i=1,m
c           Cmat(i,j) = Cmat(i,j) + Amat(i,k)*Bmat(k,j)
c         end do
c       end do
c     end do
c
      Cmat = matmul(Amat, Bmat)
      end subroutine matdotmat
c
      subroutine matdbldotmat(Amat, Bmat, np, c)
      implicit none
      integer, intent(in) :: np
      double precision, intent(in) ::  Amat(np,np), Bmat(np,np)
      double precision, intent(inout) :: c
c     Calculates the double-dot product between two square matrices,
c     Amat and Bmat. The resultant scalar is, c. In index notation,
c     c = A_ij * B_ij, where it is implied that there is a sum on both
c     i and j. Note that no transposes are taken.
c
      integer :: i, j, m
      m = np
      c = 0.D0
c
      do j=1,m
        do i=1,m
          c = c + Amat(i,j)*Bmat(i,j)
        end do
      end do
      end subroutine matdbldotmat
c
      subroutine matrixtrnps(Amat, rp, cp, Amattr)
      implicit none
      integer, intent(in) :: rp, cp
      double precision, intent(in) :: Amat(rp,cp)
      double precision, intent(inout) :: Amattr(cp,rp)
c     Transposes matrix Amat(1:rp,1:cp) and places it into
c     Amattr(1:cp,1:rp)... i.e., Amattr_ij = Amat_ji
c
c      integer :: i, j, m, n
c
      Amattr = 0.D0
c     m = rp
c     n = cp
c     do i=1,m
c       do j=1,n
c         Amattr(j,i) = Amat(i,j)
c       end do
c     end do
      Amattr = transpose(Amat)
      end subroutine matrixtrnps
c
      subroutine calcPrinVals(Amat, eigsOut)
      implicit none
      double precision, intent(in) :: Amat(3,3)
      double precision, intent(inout) :: eigsOut(3)
c     Calculate the principal values of a 3D symmetric stress or
c     strain tensor. Amat is the input tensor, assumed to be 3 by 3.
c     The principal values (i.e., eigenvalues) are calculated
c     manually from the cubic equation based on the invariants. The
c     three eigenvalues are outputted in eigsOut in descending order.
      integer :: i, j
      double precision, parameter :: PI=3.1415926535897932384626433832
      double precision :: Qc, Rc, I1, I2, I3, RoverQ, theta,
     & e1, e2, e3, tempA
      double precision :: invarVec(3)
c
      eigsOut = 0.
      do i=1,3
        do j=1,3
c         Check to ensure symmetry
          if (Amat(i,j) .ne. Amat(j,i)) return
        end do
      end do
c
      call getInvar(Amat, 3, invarVec)
      I1 = invarVec(1)
      I2 = invarVec(2)
      I3 = invarVec(3)
c
      Qc = (3.0*I2 - I1**2)/9.0
      Rc = (2.0*I1**3 - 9.0*I1*I2 + 27.0*I3)/54.0
      RoverQ = Rc/(sqrt(-Qc**3))
      theta = acos(RoverQ)
c
      e1 = 2.0*sqrt(-Qc)*cos(theta/3.0) + I1/3.0
      e2 = 2.0*sqrt(-Qc)*cos((theta + 2.0*PI)/3.0) + I1/3.0
      e3 = 2.0*sqrt(-Qc)*cos((theta + 4.0*PI)/3.0) + I1/3.0
      eigsOut(1) = e1
      eigsOut(2) = e2
      eigsOut(3) = e3
c
      do i=2,3
        tempA = eigsOut(i)
        j = i - 1
        do while (j .ge. 1)
          if (eigsOut(j) .ge. tempA) exit
          eigsOut(j+1) = eigsOut(j)
          j = j - 1
        end do
        eigsOut(j+1) = tempA
      end do
c
      end subroutine calcPrinVals
c
      subroutine tred2(a, np, d, e)
      integer, intent(in) :: np
      double precision, intent(inout) :: a(np,np), d(np), e(np)
c     Householder reduction of a real, symmetric np by np matrix a. On
c     output, a is replaced by the orthogonal matrix Q effecting the
c     transformation. d returns the diagonal elements of the tridiagonal
c     matrix, and e the off-diagonal elements, with e(1) = 0. This
c     function assumes the user wishes to calculate the eigenvalues and
c     eigenvectors.
      integer :: i, j, k, l, n
      double precision :: f, g, h, hh, scale
c
      n = np
      do i=n,2,-1
        l = i - 1
        h = 0.
        scale=0.
        if (l .gt. 1) then
          do k=1,l
            scale = scale + abs(a(i,k))
          end do
          if (scale .eq. 0.) then
            e(i) = a(i,l)
          else
            do k=1,l
              a(i,k) = a(i,k)/scale
              h = h + a(i,k)**2
            end do
            f = a(i,l)
            g = -sign(sqrt(h),f)
            e(i) = scale*g
            h = h - f*g
            a(i,l) = f - g
            f = 0.
            do j=1,l
              a(j,i) = a(i,j)/h
              g = 0.
              do k=1,j
                g = g + a(j,k)*a(i,k)
              end do
              do k=j+1,l
                g = g + a(k,j)*a(i,k)
              end do
              e(j) = g/h
              f = f + e(j)*a(i,j)
            end do
            hh=f/(h + h)
            do j=1,l
              f = a(i,j)
              g = e(j) - hh*f
              e(j) = g
              do k=1,j
                a(j,k) = a(j,k) - f*e(k) - g*a(i,k)
              end do
            end do
          end if
        else
          e(i) = a(i,l)
        end if
        d(i) = h
      end do
      d(1)=0.
      e(1)=0.
      do i=1,n
        l = i - 1
        if (d(i) .ne. 0.) then
          do j=1,l
            g = 0.
            do k=1,l
              g = g + a(i,k)*a(k,j)
            end do
            do k=1,l
              a(k,j) = a(k,j) - g*a(k,i)
            end do
          end do
        endif
        d(i) = a(i,i)
        a(i,i) = 1.
        do j = 1,l
          a(i,j) = 0.
          a(j,i) = 0.
        end do
      end do
      end subroutine tred2
c
      double precision function pythag(a, b)
      double precision, intent(in) :: a, b
c     finds dsqrt(a**2+b**2) without overflow or destructive underflow
      double precision :: p, r, s, t, u
      p = dmax1(dabs(a),dabs(b))
      if (p .eq. 0.0d0) go to 20
      r = (dmin1(dabs(a),dabs(b))/p)**2
   10 continue
         t = 4.0d0 + r
         if (t .eq. 4.0d0) go to 20
         s = r/t
         u = 1.0d0 + 2.0d0*s
         p = u*p
         r = (s/u)**2 * r
      go to 10
   20 pythag = p
      return
      end
c
      subroutine tqli(d, e, np, z)
      integer, intent(in) :: np
      double precision, intent(inout) :: d(np), e(np), z(np,np)
c     QL algorithm with implicit shifts, to determine the eigenvalues
c     and eigenvectors of a REAL, SYMMETRIC, TRIDIAGONAL matrix. This
c     function works with the output of tred2(...). d is a vector of
c     length np. On input, its first np elements of the tridiagonal
c     matrix. On output, it returns the eigenvalues. The vector e inputs
c     the sub-diagonal elements of the tridiagonal matrix, with e(1)
c     arbitrary. On output, e is destroyed. This function assumes the
c     user wishes to calculate the eigenvalues and eigenvectors. The
c     tridiagonal output matrix from tred2(...), called Q, is expected
c     as input for z(np,np). As output, z returns the eigenvectors in
c     each column. That is, the kth column of z returns the normalized
c     eigenvector corresponding to d(k).
      integer :: i, iter, k, l, m, n
      double precision :: b, c, dd, f, g, p, r, s
      n = np
      do i=2,n
        e(i-1)=e(i)
      end do
      e(n)=0.
      do l=1,n
        iter = 0
    1   do m = l,n-1
          dd = abs(d(m)) + abs(d(m+1))
          if (abs(e(m)) + dd .eq. dd) go to 2
        end do
        m = n
    2   if (m .ne. l) then
          if (iter .eq. 30) then
c           pause 'too many iterations in tqli'
          end if
          iter = iter + 1
          g = (d(l+1) - d(l)) / (2.*e(l))
          r = pythag(g, 1.D0)
          g = d(m) - d(l) + e(l)/(g + sign(r,g))
          s = 1.
          c = 1.
          p = 0.
          do i=m-1,l,-1
            f = s*e(i)
            b = c*e(i)
            r = pythag(f, g)
            e(i+1) = r
            if (r .eq. 0.) then
              d(i+1) = d(i+1)-p
              e(m) = 0.
              go to 1
            end if
            s = f/r
            c = g/r
            g = d(i+1) - p
            r = (d(i) - g)*s + 2.*c*b
            p = s*r
            d(i+1) = g + p
            g=c*r - b
            do k=1,n
              f = z(k,i+1)
              z(k,i+1) = s*z(k,i) + c*f
              z(k,i) = c*z(k,i) - s*f
            end do
          end do
          d(l) = d(l) - p
          e(l) = g
          e(m) = 0.
          go to 1
        end if
      end do
      end subroutine tqli
c
      subroutine eigSys(aMat, np, eigVals, eigVecs)
      integer, intent(in) :: np
      double precision, intent(in) :: aMat(np,np)
      double precision, intent(inout) :: eigVals(np), eigVecs(np,np)
c     Calculates the eigenvalues and normalized eigenvectors of matrix
c     aMat(np,np), which must be a real, symmetric matrix. The
c     eigenvalues are returned in eigVals(np) in descending order. The
c     corresponding eigenvectors are returned in the columns of eigVecs,
c     such that the kth column of eigVecs returns the normalized
c     eigenvector corresponding to eigVals(k). This function acts as the
c     driver function for calling tred2(...) and tqli(...). Note, that
c     transpose(eigVecs) * aMat * eigVecs  will diagonlize aMat into
c     its eigenvalues.
      integer i, j, k, n
      double precision :: offDiag(np), p
c
      n = np
      eigVals = 0.
      eigVecs = aMat
c
      call tred2(eigVecs, n, eigVals, offDiag)
      call tqli(eigVals, offDiag, n, eigVecs)
c
c     Sort eigenvalues and corresponding eigenvectors
      do i=1,n-1
        k = i
        p = eigVals(i)
        do j=i+1,n
          if (eigVals(j) .ge. p) then
            k = j
            p = eigVals(j)
          end if
        end do
        if (k .ne. i) then
          eigVals(k) = eigVals(i)
          eigVals(i) = p
          do j=1,n
            p = eigVecs(j,i)
            eigVecs(j,i) = eigVecs(j,k)
            eigVecs(j,k) = p
          end do
        end if
      end do

      end subroutine eigSys
c
      end module mod_user_routines


ELEMENTAL FUNCTION func_normal_PDF(x, mean, stddev) RESULT(ans)
    ! NOTE: See https://en.wikipedia.org/wiki/Normal_distribution

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    REAL(kind = REAL64)                                                         :: ans
    REAL(kind = REAL64), INTENT(in)                                             :: mean
    REAL(kind = REAL64), INTENT(in)                                             :: stddev
    REAL(kind = REAL64), INTENT(in)                                             :: x

    ! Declare internal variables ...
    REAL(kind = REAL64)                                                         :: tmp

    ! Calculate short-hand ...
    tmp = (x - mean) / (stddev * SQRT(2.0e0_REAL64))

    ! Calculate PDF ...
    ans = EXP(-(tmp ** 2)) / (stddev * SQRT(2.0e0_REAL64 * const_pi))
END FUNCTION func_normal_PDF


module bsplines

use types, only: dp
use lapack, only: dgesv, dgbsv
use utils, only: stop_error
implicit none
private
public bspline, bspline_der, bspline_der2

contains

pure recursive function bspline(t, i, k, r) result(B)
! Returns values of a B-spline.
! There are set of `n` B-splines of order `k`. The mesh is composed of `n+k`
! knots, stored in the t(:) array.
real(dp), intent(in) :: t(:) ! {t_i}, i = 1, 2, ..., n+k
integer, intent(in) :: i ! i = 1..n ?
integer, intent(in) :: k ! Order of the spline k = 1, 2, 3, ...
real(dp), intent(in) :: r(:) ! points to evaluate the spline at
real(dp) :: B(size(r))
if (k == 1) then
    if ((t(size(t)) - t(i+1)) < tiny(1._dp) .and. &
        (t(i+1) - t(i)) > tiny(1._dp)) then
        ! If this is the last non-zero knot span, include the right end point,
        ! to ensure that the last basis function goes to 1.
        where (t(i) <= r .and. r <= t(i+1))
            B = 1
        else where
            B = 0
        end where
    else
        ! Otherwise exclude the right end point
        where (t(i) <= r .and. r < t(i+1))
            B = 1
        else where
            B = 0
        end where
    end if
else
    B = 0
    if (t(i+k-1)-t(i) > tiny(1._dp)) then
        B = B + (r-t(i)) / (t(i+k-1)-t(i)) * bspline(t, i, k-1, r)
    end if
    if (t(i+k)-t(i+1) > tiny(1._dp)) then
        B = B + (t(i+k)-r) / (t(i+k)-t(i+1)) * bspline(t, i+1, k-1, r)
    end if
end if
end function

pure function bspline_der(t, i, k, r) result(B)
! Returns values of a derivative of a B-spline.
! There are set of `n` B-splines of order `k`. The mesh is composed of `n+k`
! knots, stored in the t(:) array.
real(dp), intent(in) :: t(:) ! {t_i}, i = 1, 2, ..., n+k
integer, intent(in) :: i ! i = 1..n ?
integer, intent(in) :: k ! Order of the spline k = 1, 2, 3, ...
real(dp), intent(in) :: r(:) ! points to evaluate the spline at
real(dp) :: B(size(r))
if (k == 1) then
    B = 0
else
    B = 0
    if (t(i+k-1)-t(i) > tiny(1._dp)) then
        B = B + (k-1) / (t(i+k-1)-t(i)) * bspline(t, i, k-1, r)
    end if
    if (t(i+k)-t(i+1) > tiny(1._dp)) then
        B = B - (k-1) / (t(i+k)-t(i+1)) * bspline(t, i+1, k-1, r)
    end if
end if
end function

pure function bspline_der2(t, i, k, r) result(B)
! Returns values of a second derivative of a B-spline.
! There are set of `n` B-splines of order `k`. The mesh is composed of `n+k`
! knots, stored in the t(:) array.
real(dp), intent(in) :: t(:) ! {t_i}, i = 1, 2, ..., n+k
integer, intent(in) :: i ! i = 1..n ?
integer, intent(in) :: k ! Order of the spline k = 1, 2, 3, ...
real(dp), intent(in) :: r(:) ! points to evaluate the spline at
real(dp) :: B(size(r))
if (k == 1) then
    B = 0
else
    B = 0
    if (t(i+k-1)-t(i) > tiny(1._dp)) then
        B = B + (k-1) / (t(i+k-1)-t(i)) * bspline_der(t, i, k-1, r)
    end if
    if (t(i+k)-t(i+1) > tiny(1._dp)) then
        B = B - (k-1) / (t(i+k)-t(i+1)) * bspline_der(t, i+1, k-1, r)
    end if
end if
end function

end module


! Created by EverLookNeverSee@GitHub on 6/6/20
! For more information see FCS/img/Exercise_08_d.png

function fact(n) result(factorial)
    integer, intent(in) :: n
    integer :: i
    real :: factorial, temp
    if (n < 0) then
        factorial = -1.0    ! error
        else if(n == 0) then
        factorial = 1.0     ! factorial of zero
        else
        temp = 1.0
        do i = 2, n
            temp = temp * i
        end do
        factorial = temp
    end if
end function fact

program main
    implicit none
    ! x --> given value that we're gonna calculate its arcsin
    ! total --> sum of the elements in series
    ! previous --> sum of elements in previous step
    ! fact --> declaration of fact function
    ! Ea --> approximation error
    ! declaring and initializing variables
    integer :: k = 0
    real :: x = 0.5, total = 0.0, Ea, previous, fact
    do
        ! Adding up first element of series -> `x` itself
        if (k == 0) then
            total = total + x
            k = k + 1
        else ! Calculating and adding up rest of elements of series
            previous = total
            total = total + (fact(2 * k) * x ** (2 * k + 1) &
                    / (2 ** (2 * k) * fact(k) ** 2 * (2 * k + 1)))
            Ea = total - previous
            ! Exit whenever approximation error is less than 10e-10
            if (Ea < 10e-10) then
                exit
            else  ! keep going to calculate and add up next element of series
                k = k + 1
                cycle
            end if
        end if
    end do
    ! printing and comparing results
    print *, "Total(aka arcsin):", total
    print *, "Fortran intrinsic arcsin function:", ASIN(x)
end program main


module linalg
  contains
  ! FlK: math helpers
  !> Determinant of a 3x3 matrix, doubles
  pure function determinant_3x3_real(a) result(det)
    real*8, dimension(3,3), intent(in) :: a
    real*8 :: det
    !
    det = a(1,1)*(a(2,2)*a(3,3) - a(3,2)*a(2,3)) &
        + a(1,2)*(a(3,1)*a(2,3) - a(2,1)*a(3,3)) &
        + a(1,3)*(a(2,1)*a(3,2) - a(3,1)*a(2,2))
  end function

  !> Trace of a 3x3 matrix, doubles
  pure function trace_3x3_real(a) result(trace)
    real*8, dimension(3,3), intent(in) :: a
    real*8 :: trace
    !
    trace = (a(1,1) + a(2,2) + a(3,3)) / 3.d0
  end function

  !> Frobenius norm of a 3x3 matrix, doubles
  pure function frobnorm_3x3_real(a) result(frob)
    real*8, dimension(3,3), intent(in) :: a
    real*8 :: frob
    !
    frob = sqrt(trace_3x3_real(matmul(a, transpose(a))))
  end function

  !> Inverse of 3x3 matrix
  pure function matinv3x3(A) result(B)
    real(8), intent(in) :: A(3,3)   !! Matrix
    real(8)             :: B(3,3)   !! Inverse matrix
    real(8)             :: detinv

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

    ! Calculate the inverse of the matrix
    B(1,1) = +detinv * (A(2,2)*A(3,3) - A(2,3)*A(3,2))
    B(2,1) = -detinv * (A(2,1)*A(3,3) - A(2,3)*A(3,1))
    B(3,1) = +detinv * (A(2,1)*A(3,2) - A(2,2)*A(3,1))
    B(1,2) = -detinv * (A(1,2)*A(3,3) - A(1,3)*A(3,2))
    B(2,2) = +detinv * (A(1,1)*A(3,3) - A(1,3)*A(3,1))
    B(3,2) = -detinv * (A(1,1)*A(3,2) - A(1,2)*A(3,1))
    B(1,3) = +detinv * (A(1,2)*A(2,3) - A(1,3)*A(2,2))
    B(2,3) = -detinv * (A(1,1)*A(2,3) - A(1,3)*A(2,1))
    B(3,3) = +detinv * (A(1,1)*A(2,2) - A(1,2)*A(2,1))
  end function
end module linalg


program LU
use procedures
implicit none

real(kind=8), allocatable, dimension(:,:) :: a, m, b_test, x_test, a_test
real(kind=8), allocatable, dimension(:) :: b, x, y
real(kind=8) :: some_number
integer :: n, i, j, io

write(*,*)

! Determine dimensions of a and b;
open (unit=2, file='a.txt', status='old', action='read')
n = 0
do
   read(2,*,iostat=io) some_number
   if (io /= 0) exit
      n = n + 1
end do
write(*,*) "number of equations and variables: ", n
write(*,*)
allocate(a(n,n), b(n), b_test(n,1), x_test(n,1), a_test(n,n))

! Assign the elements of a and b:
rewind(2)
do i = 1, n
   read(2,*) (a(i,j), j = 1,n)
end do
close(2)

open (unit=3, file='b.txt', status='old', action='read')
read(3,*) (b(j), j = 1,n)
close(3)

write(*,*) "the matrix a:"
call writes2d(a)
write(*,*) "the matrix b:"
call writes1d(b)

! Save the elements of a:
do i = 1, n
   do j = 1, n
      a_test(i,j) = a(i,j)
   end do
end do

! Perform the Gauss Elimination:
call Gauss_Elimination(a, n, m)

! Perform Forward and Back Substitution:
call Forward_Substitution(m, b, n, y)
write(*,*)
write(*,*) "-----------------------------------"
write(*,*) "[L][Y] = [b]: "
write(*,*) "-----------------------------------"
call writes1d(y)
call Back_Substitution(a, y, n, x)
write(*,*)
write(*,*) "-----------------------------------"
write(*,*) "[U][X] = [b]: "
write(*,*) "-----------------------------------"
call writes1d(x)

! Test the result:
do i = 1, n
   x_test(i,1) = x(i)
end do
b_test = matmul(a_test,x_test)
write(*,*)
write(*,*) "-----------------------------------"
write(*,*) "[a][x] = "
call writes2d (b_test)
call writes1d(b)
write(*,*) "-----------------------------------"

end program LU


module mod_determinant
#include <messenger.h>
    use mod_kinds,      only: rk,ik,rdouble,rsingle
    use mod_constants,  only: ONE
    implicit none

contains

    !>  Compute and return the determinant of a 3x3 matrix.
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/14/2017
    !!
    !!
    !----------------------------------------------------------
    function det_3x3(mat) result(det)
        real(rk),   intent(in)  :: mat(3,3)

        real(rk)    :: det

        det = mat(1,1)*mat(2,2)*mat(3,3) - mat(1,2)*mat(2,1)*mat(3,3) - &
              mat(1,1)*mat(2,3)*mat(3,2) + mat(1,3)*mat(2,1)*mat(3,2) + &
              mat(1,2)*mat(2,3)*mat(3,1) - mat(1,3)*mat(2,2)*mat(3,1)

    end function det_3x3
    !**********************************************************

end module mod_determinant


program gaussseli
    ! This program simply takes in an nxn matrix, and an nx1 matrix, converts into a reduced row echelon form using gauss jordan pivoting,
    ! ,then calculates the determinant of nxn, if determinant is non-singular the program proceeds to calculate inverse
    ! and solution of (nXn) x = (nX1) form equation (i.e. Ax=b)
    !Various parts of the code are highlighted by comments as to what they do.
    implicit none
    integer :: n,i,k,j
    real , allocatable :: A(:,:), temp(:)
    real :: q, ep=10**(-7)
    print*, "Give the dimension of matrix A in form AX=b"
    read*, n
    allocate(A(n,n+1+n), temp(n+n+1))   !Allocate nxn for original matrix, nx1 for b, nxn for I all concatenated
    !!!!!!!!!!!!!!!!!!!!!!!!!!!! READING MATRIX FROM USER !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    print*, "Give the rows of matrix A"
    do i=1,n
        read*, A(i,1:n)
    enddo
    print*,"Give values of b"
    do i=1,n
        read*, A(i,n+1)
    enddo
    !!!!!!!!!!!!! MATRIX FORM IS A(augmented) = A(read)|b(read)|I CONCATENATED AND PROCESSED TOGETHER THROUGHOUT !!!!!!!!!!!!!!
    do i=1,n
        A(i,n+i+1) =1   !getting the identity of the third part in matrix
    enddo
    print*, "MATRIX = A | b | Identity"
    do i=1,n
        print*,A(i,:)
    enddo
    print*, "================================================"
    !!!!!!!!!!!!!!!! CONVERTING THE MATRIX TO UPPER TRIANGULAR REDUCED ECHELON !!!!!!!!!!!!!!!!!!!
    do k = 1,n
        do i=k,n
            if (abs(A(i,k)) .gt. abs(A(k,k))) then
                temp = A(k,:) ; A(k,:) = A (i,:); A(i,:) = temp    !swapping higher terms to higher position in matrix
            endif
        enddo
        do j=k+1,n
            q=(A(j,k))/A(k,k)
            do i=k,n+n+1
                A(j,i) = A(j,i) - q* A(k,i)       !finally making the lower triangular terms zero
            enddo
        enddo
    enddo
    !!!!!!!!!!!!!!!!!!!!!!!!! CONVERSION DONE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    print*, "The modified/augmented matrix:"
    do i=1,n
        print*,A(i,:)
    enddo
    print*, "====================================================="
    !!!!!!!!!! CHECK DETERMINANT AFTER REDUCING IT TO UPPER TRIANGULAR !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    print*, "Checking determinant"
    q = 1    ! determinant
    do i=1,n
        q = q * A(i,i)      !determinant is simply the product of diagonal elements in upper diagonal
    enddo
    print*, "The determinant is:", q
    If (abs(q) .le. ep) then
        print*, "Determinant is SINGULAR, unsolvable"
        STOP
    endif
    print*, "====================================================="
    !!!!!!!!!!!!!!!!!!!!!!!!!!!CALCULATE FINAL RESULT!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    temp =0
    temp(n) = (A(n,n+1))/A(n,n)
    do i = n-1,1,-1
        q=0
        do j=i+1,n
            q = q + A(i,j)*temp(j)
        enddo
        temp(i)= (A(i,n+1) -q)/A(i,i)
    enddo
    print*, "The solutions are", temp(1:n)
    print*, "========================================================="
    !!!!!!!!!!!!!!!!!!!!!!!!!!!! COMPUTE INVERSE NOW !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    print*, "The inverse of A is"
    do i = n,1,-1
        A(i,:) = A(i,:)/A(i,i)
    enddo
    do i = n,1,-1
        do j=1,i-1
            A(j,:) = A(j,:) - A(i,:)*A(j,i)
        enddo
    enddo
    do i=1,n
        print*,A(i,n+2:)
    enddo
    print*, "========================================================="
end program gaussseli


! Function for matrix product C=A*B
! Optimized memory access pattern is considered.
! In Fortran matrices should be accessed column by column.
! Igor Lopes, February 2015
SUBROUTINE MATPRD(A,B,C,NROWA,NCOLA,NCOLB)
    IMPLICIT NONE
    ! Parameter
    REAL(8) R0 /0.0D0/
    ! Arguments
    INTEGER :: NROWA , NCOLA , NCOLB
    REAL(8), DIMENSION(NROWA,NCOLA)  :: A
    REAL(8), DIMENSION(NCOLA, NCOLB) :: B
    REAL(8), DIMENSION(NROWA,NCOLB)  :: C
    ! Locals
    INTEGER I, J, K
    ! Begin algorithm
    C=R0
    DO J=1,NCOLB
	    DO K=1,NCOLA
		    DO I=1,NROWA
			    C(I,J)=C(I,J)+A(I,K)*B(K,J)
		    ENDDO
	    ENDDO
    ENDDO
END SUBROUTINE


	FUNCTION PR_VAPR  ( dwpc )
C************************************************************************
C* PR_VAPR								*
C*									*
C* This function computes VAPR from DWPC.  The following equation is	*
C* used:								*
C*									*
C*     VAPR = 6.112 * EXP [ (17.67 * DWPC) / (DWPC + 243.5) ]		*
C*									*
C* Bolton.								*
C*									*
C* This function will compute VAPS if TMPC is input.			*
C*									*
C* REAL PR_VAPR  ( DWPC )						*
C*									*
C* Input parameters:							*
C*	DWPC		REAL		Dewpoint in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_VAPR		REAL		Vapor pressure in millibars	*
C**									*
C* Log:									*
C* P. Kocin/914		1980						*
C* M. Goodman/RDS	 4/84	Updated prologue and added PR_TMCK	*
C* I. Graffman/RDS	11/84	Updated to use Bolton eqn.		*
C* G. Huffman/GSC	 8/88	Documentation; test for low DWPC	*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( dwpc ) .or. ( dwpc .lt. -240. ) )  THEN
	    PR_VAPR = RMISSD
	  ELSE
	    PR_VAPR = 6.112 * EXP (( 17.67 * dwpc ) / ( dwpc + 243.5 ))
	END IF
C*
	RETURN
	END


submodule (stdlib_quadrature) stdlib_quadrature_trapz
    use stdlib_error, only: check
    implicit none

contains

    pure module function trapz_dx_sp(y, dx) result(integral)
        real(sp), dimension(:), intent(in) :: y
        real(sp), intent(in) :: dx
        real(sp) :: integral

        integer :: n

        n = size(y)

        select case (n)
        case (0:1)
            integral = 0.0_sp
        case (2)
            integral = 0.5_sp*dx*(y(1) + y(2))
        case default
            integral = dx*(sum(y(2:n-1)) + 0.5_sp*(y(1) + y(n)))
        end select
    end function trapz_dx_sp

    pure module function trapz_dx_dp(y, dx) result(integral)
        real(dp), dimension(:), intent(in) :: y
        real(dp), intent(in) :: dx
        real(dp) :: integral

        integer :: n

        n = size(y)

        select case (n)
        case (0:1)
            integral = 0.0_dp
        case (2)
            integral = 0.5_dp*dx*(y(1) + y(2))
        case default
            integral = dx*(sum(y(2:n-1)) + 0.5_dp*(y(1) + y(n)))
        end select
    end function trapz_dx_dp

    pure module function trapz_dx_qp(y, dx) result(integral)
        real(qp), dimension(:), intent(in) :: y
        real(qp), intent(in) :: dx
        real(qp) :: integral

        integer :: n

        n = size(y)

        select case (n)
        case (0:1)
            integral = 0.0_qp
        case (2)
            integral = 0.5_qp*dx*(y(1) + y(2))
        case default
            integral = dx*(sum(y(2:n-1)) + 0.5_qp*(y(1) + y(n)))
        end select
    end function trapz_dx_qp

    module function trapz_x_sp(y, x) result(integral)
        real(sp), dimension(:), intent(in) :: y
        real(sp), dimension(:), intent(in) :: x
        real(sp) :: integral

        integer :: i
        integer :: n

        n = size(y)
        call check(size(x) == n, "trapz: Arguments `x` and `y` must be the same size.")

        select case (n)
        case (0:1)
            integral = 0.0_sp
        case (2)
            integral = 0.5_sp*(x(2) - x(1))*(y(1) + y(2))
        case default
            integral = 0.0_sp
            do i = 2, n
                integral = integral + (x(i) - x(i-1))*(y(i) + y(i-1))
            end do
            integral = 0.5_sp*integral
        end select
    end function trapz_x_sp

    module function trapz_x_dp(y, x) result(integral)
        real(dp), dimension(:), intent(in) :: y
        real(dp), dimension(:), intent(in) :: x
        real(dp) :: integral

        integer :: i
        integer :: n

        n = size(y)
        call check(size(x) == n, "trapz: Arguments `x` and `y` must be the same size.")

        select case (n)
        case (0:1)
            integral = 0.0_dp
        case (2)
            integral = 0.5_dp*(x(2) - x(1))*(y(1) + y(2))
        case default
            integral = 0.0_dp
            do i = 2, n
                integral = integral + (x(i) - x(i-1))*(y(i) + y(i-1))
            end do
            integral = 0.5_dp*integral
        end select
    end function trapz_x_dp

    module function trapz_x_qp(y, x) result(integral)
        real(qp), dimension(:), intent(in) :: y
        real(qp), dimension(:), intent(in) :: x
        real(qp) :: integral

        integer :: i
        integer :: n

        n = size(y)
        call check(size(x) == n, "trapz: Arguments `x` and `y` must be the same size.")

        select case (n)
        case (0:1)
            integral = 0.0_qp
        case (2)
            integral = 0.5_qp*(x(2) - x(1))*(y(1) + y(2))
        case default
            integral = 0.0_qp
            do i = 2, n
                integral = integral + (x(i) - x(i-1))*(y(i) + y(i-1))
            end do
            integral = 0.5_qp*integral
        end select
    end function trapz_x_qp

    pure module function trapz_weights_sp(x) result(w)
        real(sp), dimension(:), intent(in) :: x
        real(sp), dimension(size(x)) :: w

        integer :: i
        integer :: n

        n = size(x)

        select case (n)
        case (0)
            ! no action needed
        case (1)
            w(1) = 0.0_sp
        case (2)
            w = 0.5_sp*(x(2) - x(1))
        case default
            w(1) = 0.5_sp*(x(2) - x(1))
            w(n) = 0.5_sp*(x(n) - x(n-1))
            do i = 2, size(x)-1
                w(i) = 0.5_sp*(x(i+1) - x(i-1))
            end do
        end select
    end function trapz_weights_sp

    pure module function trapz_weights_dp(x) result(w)
        real(dp), dimension(:), intent(in) :: x
        real(dp), dimension(size(x)) :: w

        integer :: i
        integer :: n

        n = size(x)

        select case (n)
        case (0)
            ! no action needed
        case (1)
            w(1) = 0.0_dp
        case (2)
            w = 0.5_dp*(x(2) - x(1))
        case default
            w(1) = 0.5_dp*(x(2) - x(1))
            w(n) = 0.5_dp*(x(n) - x(n-1))
            do i = 2, size(x)-1
                w(i) = 0.5_dp*(x(i+1) - x(i-1))
            end do
        end select
    end function trapz_weights_dp

    pure module function trapz_weights_qp(x) result(w)
        real(qp), dimension(:), intent(in) :: x
        real(qp), dimension(size(x)) :: w

        integer :: i
        integer :: n

        n = size(x)

        select case (n)
        case (0)
            ! no action needed
        case (1)
            w(1) = 0.0_qp
        case (2)
            w = 0.5_qp*(x(2) - x(1))
        case default
            w(1) = 0.5_qp*(x(2) - x(1))
            w(n) = 0.5_qp*(x(n) - x(n-1))
            do i = 2, size(x)-1
                w(i) = 0.5_qp*(x(i+1) - x(i-1))
            end do
        end select
    end function trapz_weights_qp

end submodule stdlib_quadrature_trapz


! $UWHPSC/codes/openmp/jacobi1d_omp1.f90
!
! Jacobi iteration illustrating fine grain parallelism with OpenMP.
!
! Several omp parallel do loops are used.  Each time threads will be
! forked and the compiler will decide how to split up the loop.

program jacobi1d_omp1
    use omp_lib
    implicit none
    integer :: n, nthreads
    real(kind=8), dimension(:), allocatable :: x,u,uold,f
    real(kind=8) :: alpha, beta, dx, tol, dumax
    real(kind=8), intrinsic :: exp
    real(kind=8) :: t1,t2
    integer :: i,iter,maxiter

    ! Specify number of threads to use:
    nthreads = 2
    !$ call omp_set_num_threads(nthreads)
    !$ print "('Using OpenMP with ',i3,' threads')", nthreads

    print *, "Input n ... "
    read *, n

    ! allocate storage for boundary points too:
    allocate(x(0:n+1), u(0:n+1), uold(0:n+1), f(0:n+1))

    open(unit=20, file="heatsoln.txt", status="unknown")

    call cpu_time(t1)

    ! grid spacing:
    dx = 1.d0 / (n+1.d0)

    ! boundary conditions:
    alpha = 20.d0
    beta = 60.d0

    !$omp parallel do
    do i=0,n+1
        ! grid points:
        x(i) = i*dx
        ! source term:
        f(i) = 100.*exp(x(i))
        ! initial guess:
        u(i) = alpha + x(i)*(beta-alpha)
        enddo

    ! tolerance and max number of iterations:
    tol = 0.1 * dx**2
    print *, "Convergence tolerance: tol = ",tol
    maxiter = 100000
    print *, "Maximum number of iterations: maxiter = ",maxiter

    ! Jacobi iteratation:

    uold = u  ! starting values before updating

    do iter=1,maxiter
        dumax = 0.d0
        !$omp parallel do reduction(max : dumax)
        do i=1,n
            u(i) = 0.5d0*(uold(i-1) + uold(i+1) + dx**2*f(i))
            dumax = max(dumax, abs(u(i)-uold(i)))
            enddo
        if (mod(iter,10000)==0) then
            print *, iter, dumax
            endif
        ! check for convergence:
        if (dumax .lt. tol) exit

        !$omp parallel do
        do i=1,n
            uold(i) = u(i)   ! for next iteration
            enddo
        enddo

        call cpu_time(t2)
        print '("CPU time = ",f12.8, " seconds")', t2-t1

        print *, "Total number of iterations: ",iter

    write(20,*) "          x                  u"
    do i=0,n+1
        write(20,'(2e20.10)'), x(i), u(i)
        enddo

    print *, "Solution is in heatsoln.txt"

    close(20)

end program jacobi1d_omp1


module factorial_mod
implicit none
contains
pure function factorial(n) result(fac)
! n unchanged upon return
integer, value :: n
integer        :: fac
if (n < 2) then
   fac = 1
   return
end if
fac = n
do
   n = n - 1
   if (n < 2) return
   fac = fac * n
end do
end function factorial
!
function factorial_impure(n) result(fac)
! poor style -- n changed upon return
integer :: n
integer :: fac
if (n < 2) then
   fac = 1
   return
end if
fac = n
do
   n = n - 1
   if (n < 2) return
   fac = fac * n
end do
end function factorial_impure
end module factorial_mod
!
program test_factorial
use factorial_mod
implicit none
integer :: n = 4
print*,factorial(n) ! 24
print*,n ! 4
print*,factorial_impure(n) ! 24
print*,n ! 1
end program test_factorial


c####&

c Matrix operation subroutines

c --- generic real matrix linear combination. xA+yB=C, all mXn
      subroutine rmatlincomb(x,A,y,B,C,m,n)

        implicit none
        integer i,j,m,n
        real x,A(m,n),y,B(m,n),C(m,n)

        do i=1,m
          do j=1,n
            C(i,j)=x*A(i,j)+y*B(i,j)
          end do
        end do

      end

c --- generic compled matrix linear combination. xA+yB=C, all mXn
      subroutine cmatlincomb(x,A,y,B,C,m,n)

        implicit none
        integer i,j,m,n
        complex x,A(m,n),y,B(m,n),C(m,n)

        do i=1,m
          do j=1,n
            C(i,j)=x*A(i,j)+y*B(i,j)
          end do
        end do

      end

c --- Generic real matrix-constant multiply. A=c*A, A:mxn
      subroutine rmatconst(A,c,m,n)

        implicit none
        integer m,n,i,j
        real A(m,n),c

        do i=1,m
          do j=1,n
            A(i,j)=c*A(i,j)
          end do
        end do

      end

c --- Generic complex matrix-constant multiply. A=c*A, A:mxn
      subroutine cmatconst(A,c,m,n)

        implicit none
        integer m,n,i,j
        complex A(m,n),c

        do i=1,m
          do j=1,n
            A(i,j)=c*A(i,j)
          end do
        end do

      end

c --- Generic real matrix multiplication, A*B=C. A:mXn, B:nXo, C:mXo
      subroutine rmatmul(a,b,c,m,n,o)

        implicit none
        integer n,m,o,i,j,k
        real a(m,n),b(n,o),c(m,o)

        do i=1,m
          do j=1,o
            c(i,j)=0
            do k=1,n
              c(i,j)=c(i,j)+a(i,k)*b(k,j)
            end do
          end do
        end do

      end

c --- Generic complex matrix multiplication, A*B=C. A:mXn, B:nXo, C:mXo
      subroutine cmatmul(a,b,c,m,n,o)

        implicit none
        integer n,m,o,i,j,k
        complex a(m,n),b(n,o),c(m,o)

        do i=1,m
          do j=1,o
            c(i,j)=0
            do k=1,n
              c(i,j)=c(i,j)+a(i,k)*b(k,j)
            end do
          end do
        end do

      end

c --- Generic real matrix-vector multiply, Ax=y. A:mXn,x:n,y:m
      subroutine rmatvec(a,x,y,m,n)

        implicit none
        integer m,n,i,j
        real a(m,n),x(n),y(m)

        do i=1,m
          y(i)=0
          do j=1,n
            y(i)=y(i)+a(i,j)*x(j)
          end do
        end do

      end

c --- Generic complex matrix-vector multiply, Ax=y. A:mXn,x:n,y:m
      subroutine cmatvec(a,x,y,m,n)

        implicit none
        integer m,n,i,j
        complex a(m,n),x(n),y(m)

        do i=1,m
          y(i)=0
          do j=1,n
            y(i)=y(i)+a(i,j)*x(j)
          end do
        end do

      end

c --- 3x3 real matrix linear combination. xA+yB=C
      subroutine rmatlincomb3(x,A,y,B,C)

        implicit none
        integer i,j
        real x,A(3,3),y,B(3,3),C(3,3)

        do i=1,3
          do j=1,3
            C(i,j)=x*A(i,j)+y*B(i,j)
          end do
        end do

      end

c --- 3x3 complex matrix linear combination. xA+yB=C
      subroutine cmatlincomb3(x,A,y,B,C)

        implicit none
        integer i,j
        complex x,A(3,3),y,B(3,3),C(3,3)

        do i=1,3
          do j=1,3
            C(i,j)=x*A(i,j)+y*B(i,j)
          end do
        end do

      end

c --- 3x3 matrix-constant multiply. A=c*A
      subroutine rmatconst3(A,c)

        implicit none
        real A(3,3),c
        integer i,j

        do i=1,3
          do j=1,3
            A(i,j)=c*A(i,j)
          end do
        end do

      end

c --- 3x3 complex matrix-constant multiply. A=c*A
      subroutine cmatconst3(A,c)

        implicit none
        complex A(3,3),c
        integer i,j

        do i=1,3
          do j=1,3
            A(i,j)=c*A(i,j)
          end do
        end do

      end

c --- 3x3 real matrix multiplication, A*B=C
      subroutine rmatmul3(a,b,c)

        implicit none
        real a(3,3),b(3,3),c(3,3)
        integer i,j,k

        do i=1,3
          do j=1,3
            c(i,j)=0
            do k=1,3
              c(i,j)=c(i,j)+a(i,k)*b(k,j)
            end do
          end do
        end do

      end

c --- 3x3 complex matrix multiplication, A*B=C
      subroutine cmatmul3(a,b,c)

        implicit none
        complex a(3,3),b(3,3),c(3,3)
        integer i,j,k

        do i=1,3
          do j=1,3
            c(i,j)=0
            do k=1,3
              c(i,j)=c(i,j)+a(i,k)*b(k,j)
            end do
          end do
        end do

      end

c --- 3x3 real matrix-vector multiplication,Ax=y
      subroutine rmatvec3(a,x,y)

        implicit none
        real a(3,3),x(3),y(3)
        integer i,j

        do i=1,3
          y(i)=0
          do j=1,3
            y(i)=y(i)+a(i,j)*x(j)
          end do
        end do

      end

c --- 3x3 complex matrix-vector multiplication,Ax=y
      subroutine cmatvec3(a,x,y)

        implicit none
        complex a(3,3),x(3),y(3)
        integer i,j

        do i=1,3
          y(i)=0
          do j=1,3
            y(i)=y(i)+a(i,j)*x(j)
          end do
        end do

      end

c --- 3x3 real/complex matrix-vector multiplication, complex output
      subroutine rcmatvec3(a,x,y)

        implicit none
        real a(3,3)
        complex x(3),y(3)
        integer i,j

        do i=1,3
          y(i)=0
          do j=1,3
            y(i)=y(i)+cmplx(a(i,j))*x(j)
          end do
        end do

      end

c --- 3x3 complex/real matrix-vector multiplication, real output
      subroutine crmatvec3(a,x,y)

        implicit none
        complex a(3,3)
        real x(3),y(3)
        integer i,j

        do i=1,3
          y(i)=0
          do j=1,3
            y(i)=y(i)+real(a(i,j))*x(j)
          end do
        end do

      end

c --- 3x3 real vector-matrix multiplication, x'A=y
      subroutine rvecmat3(x,a,y)

        implicit none
        real x(3),a(3,3),y(3)
        integer i,j

        do i=1,3
          y(i)=0
          do j=1,3
            y(i)=y(i)+x(j)*a(j,i)
          end do
        end do

      end

c --- 3x3 complex vector-matrix multiplication, x'A=y
      subroutine cvecmat3(x,a,y)

        implicit none
        complex x(3),a(3,3),y(3)
        integer i,j

        do i=1,3
          y(i)=0
          do j=1,3
            y(i)=y(i)+x(j)*a(j,i)
          end do
        end do

      end

c --- Real dot product, 3-vectors, z=x.y
       real function rdot3(x,y)

        implicit none
        real x(3),y(3)

        rdot3=x(1)*y(1)+x(2)*y(2)+x(3)*y(3)

      end

c --- Complex dot product, 3-vectors, z=x.y
      complex function cdot3(x,y)

        implicit none
        complex x(3),y(3)

        cdot3=conjg(x(1))*y(1)+conjg(x(2))*y(2)+conjg(x(3))*y(3)

      end

c --- Real 3x3 matrix inverse. ai=a^(-1)
c     Adapted from Thompson's routine; based on cofactors.
      subroutine rmatinv3(a,ai)

        implicit none
        real a(3,3),ai(3,3),co(3,3),det
        integer i,j

        co(1,1)=(a(2,2)*a(3,3)-a(2,3)*a(3,2))
        co(1,2)=-(a(2,1)*a(3,3)-a(2,3)*a(3,1))
        co(1,3)=(a(2,1)*a(3,2)-a(2,2)*a(3,1))
        co(2,1)=-(a(1,2)*a(3,3)-a(1,3)*a(3,2))
        co(2,2)=(a(1,1)*a(3,3)-a(1,3)*a(3,1))
        co(2,3)=-(a(1,1)*a(3,2)-a(1,2)*a(3,1))
        co(3,1)=(a(1,2)*a(2,3)-a(1,3)*a(2,2))
        co(3,2)=-(a(1,1)*a(2,3)-a(1,3)*a(2,1))
        co(3,3)=(a(1,1)*a(2,2)-a(1,2)*a(2,1))
        det=a(1,1)*co(1,1)+a(1,2)*co(1,2)+a(1,3)*co(1,3)
        do i=1,3
          do j=1,3
            ai(i,j)=co(j,i)/det
          end do
        end do

      end

c --- Complex 3x3 matrix inverse. ai=a^(-1)
c     Adapted from Thompson's routine; based on cofactors.
      subroutine cmatinv3(a,ai)

        implicit none
        complex a(3,3),ai(3,3),co(3,3),det
        integer i,j

        co(1,1)=(a(2,2)*a(3,3)-a(2,3)*a(3,2))
        co(1,2)=-(a(2,1)*a(3,3)-a(2,3)*a(3,1))
        co(1,3)=(a(2,1)*a(3,2)-a(2,2)*a(3,1))
        co(2,1)=-(a(1,2)*a(3,3)-a(1,3)*a(3,2))
        co(2,2)=(a(1,1)*a(3,3)-a(1,3)*a(3,1))
        co(2,3)=-(a(1,1)*a(3,2)-a(1,2)*a(3,1))
        co(3,1)=(a(1,2)*a(2,3)-a(1,3)*a(2,2))
        co(3,2)=-(a(1,1)*a(2,3)-a(1,3)*a(2,1))
        co(3,3)=(a(1,1)*a(2,2)-a(1,2)*a(2,1))
        det=a(1,1)*co(1,1)+a(1,2)*co(1,2)+a(1,3)*co(1,3)
        do i=1,3
          do j=1,3
            ai(i,j)=co(j,i)/det
          end do
        end do

      end

c --- Generic real matrix transpose, B=transpose of A. A: mxn,B:nxm
      subroutine rtransp(A,B,m,n)

        implicit none
        integer m,n,i,j
        real a(m,n),b(n,m)

        do i=1,m
          do j=1,n
            b(j,i)=a(i,j)
          end do
        end do

      end

c --- Generic complex matrix transpose, B=transpose of A. A: mxn,B:nxm
      subroutine ctransp(A,B,m,n)

        implicit none
        integer m,n,i,j
        complex a(m,n),b(n,m)

        do i=1,m
          do j=1,n
            b(j,i)=a(i,j)
          end do
        end do

      end

c --- 3x3 real matrix transpose, B=transpose of A.
      subroutine rtransp3(A,B)

        implicit none
        integer i,j
        real a(3,3),b(3,3)

        do i=1,3
          do j=1,3
            b(j,i)=a(i,j)
          end do
        end do

      end

c --- 3x3 complex matrix transpose, B=transpose of A.
      subroutine ctransp3(A,B)

        implicit none
        integer i,j
        complex a(3,3),b(3,3)

        do i=1,3
          do j=1,3
            b(j,i)=a(i,j)
          end do
        end do

      end

c --- Real matrix copy, arbitrary dimensions. A is copied to B, both mXn
      subroutine rmatcopy(a,b,m,n)

        implicit none
        integer m,n,i,j
        real a(m,n),b(m,n)

        do i=1,m
          do j=1,n
            b(i,j)=a(i,j)
          end do
        end do

      end

c --- Complex matrix copy, arbitrary dimensions. A is copied to B, both mXn
      subroutine cmatcopy(a,b,m,n)

        implicit none
        integer m,n,i,j
        complex a(m,n),b(m,n)

        do i=1,m
          do j=1,n
            b(i,j)=a(i,j)
          end do
        end do

      end

c --- 3x3 real matrix copy. A is copied to B.
      subroutine rmatcopy3(a,b)

        implicit none
        integer i,j
        real a(3,3),b(3,3)

        do i=1,3
          do j=1,3
            b(i,j)=a(i,j)
          end do
        end do

      end

c --- 3x3 complex matrix copy. A is copied to B.
      subroutine cmatcopy3(a,b)

        implicit none
        integer i,j
        complex a(3,3),b(3,3)

        do i=1,3
          do j=1,3
            b(i,j)=a(i,j)
          end do
        end do

      end

c --- Real vector copy, arbitrary dimention. x is copied to y, dimension n
      subroutine rveccopy(x,y,n)

        implicit none
        integer n,i
        real x(n),y(n)

        do i=1,n
          y(i)=x(i)
        end do

      end

c --- Complex vector copy, arbitrary dimention. x is copied to y, dimension n
      subroutine cveccopy(x,y,n)

        implicit none
        integer n,i
        complex x(n),y(n)

        do i=1,n
          y(i)=x(i)
        end do

      end

c --- Extract column vector v from real matrix A.
c     v=A(i1:i2,k), A:mXn, v:i2-i1+1
      subroutine rextractvec(a,v,i1,i2,k,m,n)

        implicit none
        integer i1,i2,k,m,n,i
        real a(m,n),v(i2-i1+1)

        do i=i1,i2
          v(i-i1+1)=a(i,k)
        end do

      end

c --- Extract column vector v from complex matrix A.
c     v=A(i1:i2,k), A:mXn, v:i2-i1+1
      subroutine cextractvec(a,v,i1,i2,k,m,n)

        implicit none
        integer i1,i2,k,m,n,i
        complex a(m,n),v(i2-i1+1)

        do i=i1,i2
          v(i-i1+1)=a(i,k)
        end do

      end

c --- Extract submatrix B from real matrix A. B=A(i1:i2,j1:j2). A is mxn
      subroutine rextractblock(a,b,i1,i2,j1,j2,m,n)

        implicit none
        integer i1,i2,j1,j2,m,n,ii,jj
        real a(m,n),b(i2-i1+1,j2-j1+1)

        do ii=i1,i2
          do jj=j1,j2
            b(ii-i1+1,jj-j1+1)=a(ii,jj)
          end do
        end do

      end

c --- Extract submatrix B from complex matrix A. B=A(i1:i2,j1:j2). A is mxn
      subroutine cextractblock(a,b,i1,i2,j1,j2,m,n)

        implicit none
        integer i1,i2,j1,j2,m,n,ii,jj
        complex a(m,n),b(i2-i1+1,j2-j1+1)

        do ii=i1,i2
          do jj=j1,j2
            b(ii-i1+1,jj-j1+1)=a(ii,jj)
          end do
        end do

      end

c --- Find index and value of highest-magnitude (absolute-value max)
c     element in real vector v. v:m elements. In case of equality,
c     finds first element.
      subroutine rmax_vec_abs(v,index,value,m)

        implicit none
        integer index,m,j
        real v(m),value

        value=abs(v(1))
        index=1
        do j=2,m
          if (abs(v(j)) .gt. value) then
            value=abs(v(j))
            index=j
          end if
        end do

      end

c --- Find index and value of highest-magnitude (absolute-value max)
c     element in complex vector v. v:m elements. In case of equality,
c     finds first element.
      subroutine cmax_vec_abs(v,index,value,m)

        implicit none
        integer index,m,j
        complex v(m)
        real value

        value=abs(v(1))
        index=1
        do j=2,m
          if (abs(v(j)) .gt. value) then
            value=abs(v(j))
            index=j
          end if
        end do

      end

c --- Normalize a real 3-vector to 1. y=x/||x||
      subroutine rnorm3(x,y)

        implicit none
        real x(3),y(3),norm

        norm=sqrt(x(1)*x(1)+x(2)*x(2)+x(3)*x(3))
        if (norm .ne. 0) then
          y(1)=x(1)/norm
          y(2)=y(2)/norm
          y(3)=y(3)/norm
c        else
c          write (*,*) 'rnorm3: Norm is zero'
        end if

      end

c --- Normalize a complex 3-vector to 1. y=x/||x||
      subroutine cnorm3(x,y)

        implicit none
        complex x(3),y(3),norm

        norm=sqrt(x(1)*x(1)+x(2)*x(2)+x(3)*x(3))
        if (norm .ne. 0) then
          y(1)=x(1)/norm
          y(2)=y(2)/norm
          y(3)=y(3)/norm
        end if

      end

c --- Print a generic real MxN matrix.
      subroutine rprintmat(A,m,n)

        implicit none
        integer m,n,i,j
        real A(m,n)
        character*9 fmt
        parameter (fmt='(G14.6,$)')

        do i=1,m
          do j=1,n
            write(*,fmt) A(i,j)
          end do
          write(*,*)
        end do

      end

c --- Print a generic complex MxN matrix.
      subroutine cprintmat(A,m,n)

        implicit none
        integer m,n,i,j
        complex A(m,n)

        do i=1,m
          do j=1,n
            write(*,'(X,''('',G14.6,'','',G14.6,'')'',$)')
     &             real(A(i,j)),aimag(A(i,j))
          end do
          write(*,*)
        end do

      end


! calculates the overlap area between a given wake and a rotor area
subroutine overlap_area_func(turbine_y, turbine_z, rotor_diameter, &
                            wake_center_y, wake_center_z, wake_diameter, &
                            wake_overlap)

    implicit none

    ! define precision to be the standard for a double precision ! on local system
    integer, parameter :: dp = kind(0.d0)

    ! in
    real(dp), intent(in) :: turbine_y, turbine_z, rotor_diameter
    real(dp), intent(in) :: wake_center_y, wake_center_z, wake_diameter

    ! out
    real(dp), intent(out) :: wake_overlap

    ! local
    real(dp), parameter :: pi = 3.141592653589793_dp, tol = 0.000001_dp
    real(dp) :: OVdYd, OVr, OVRR, OVL, OVz

    ! load intrinsic functions
    intrinsic acos, sqrt

    print *, turbine_y, turbine_z, rotor_diameter, &
                            wake_center_y, wake_center_z, wake_diameter, &
                            wake_overlap

    ! distance between wake center and rotor center
    if (wake_center_z .gt. turbine_z + tol or wake_center_z .lt. turbine_z - tol) then
        OVdYd = sqrt((wake_center_y-turbine_y)**2_dp + (wake_center_z - turbine_z)**2_dp)
    else
        OVdYd = abs(wake_center_y-turbine_y)
    end if
    !print *, "OVdYd: ", OVdYd
    ! find rotor radius
    OVr = rotor_diameter/2.0_dp
    !print *, "OVr: ", OVr

    ! find wake radius
    OVRR = wake_diameter/2.0_dp
    !print *, "OVRR: ", OVRR

    ! make sure the distance from wake center to turbine hub is positive
    ! OVdYd = abs(OVdYd) !!! commented out since change to 2D distance (y,z) will always be positive

    ! calculate the distance from the wake center to the line perpendicular to the
    ! line between the two circle intersection points
    if (OVdYd >= 0.0_dp + tol) then ! check case to avoid division by zero
!     if (OVdYd >= 0.0_dp) then ! check case to avoid division by zero
        OVL = (-OVr*OVr+OVRR*OVRR+OVdYd*OVdYd)/(2.0_dp*OVdYd)
    else
        OVL = 0.0_dp
    end if

    OVz = OVRR*OVRR-OVL*OVL

    ! Finish calculating the distance from the intersection line to the outer edge of the wake
    if (OVz > 0.0_dp + tol) then TODO
!     if (OVz > 0.0_dp) then
        OVz = sqrt(OVz)
    else
        OVz = 0.0_dp
    end if

    !print *, "OVRR, OVL, OVRR, OVr, OVdYd, OVz ", OVRR, OVL, OVRR, OVr, OVdYd, OVz

    if (OVdYd < (OVr+OVRR)) then ! if the rotor overlaps the wake
        !print *, "OVL: ", OVL
        if (OVL < OVRR .and. (OVdYd-OVL) < OVr) then
!         if (OVdYd > 0.0_dp + tol) then
!         if ((OVdYd > 0.0_dp) .and. (OVdYd > (OVRR - OVr))) then
            ! print *, "acos(OVL/OVRR), acos((OVdYd-OVL)/OVr), OVRR, OVL, OVr, OVdYd, OVL/OVRR, (OVdYd-OVL)/OVr ", &
!     & acos(OVL/OVRR), acos((OVdYd-OVL)/OVr), OVRR, OVL, OVr, OVdYd, OVL/OVRR, (OVdYd-OVL)/OVr
            wake_overlap = OVRR*OVRR*acos(OVL/OVRR) + OVr*OVr*acos((OVdYd-OVL)/OVr) - OVdYd*OVz
        else if (OVRR > OVr) then
            wake_overlap = pi*OVr*OVr
            !print *, "wake ovl: ", wake_overlap
        else
            wake_overlap = pi*OVRR*OVRR
        end if
    else
        wake_overlap = 0.0_dp
    end if
    print *, "wake overlap in func: ", wake_overlap/(pi*OVr**2)
    print *, "wake overlap in func: ", wake_overlap/(pi*OVRR**2)
    if ((wake_overlap/(pi*OVr**2) > 1.0_dp) .or. (wake_overlap/(pi*OVRR**2) > 1.0_dp)) then
        print *, "wake overlap in func: ", wake_overlap
        STOP 1
    end if

end subroutine overlap_area_func


program tarefa7
    ! Definindo valor de pi
    pi = 4e0*atan(1e0)

    ! Variável inteira id que recebe o número da dimensão
    print *, 'Digite o número de dimensões d:'
    read (*,*) id

    ! Número M aleátorios
    print *, ''
    print *, 'Digite o número de iterações M:'
    read (*,*) M

    ! Contador N de pontos dentro da d-esfera
    N = 0

    ! loop de ;m iterações
    do i = 1, M
        ! Variável que irá armazenar o modulo ao quadrado de cada ponto
        rmod = 0
        ! Coordenadas aleátorias do ponto
        do j = 1, id
            rmod = rmod + rand()**2
        end do
        ! Soma +1 em N, se o ponto estiver dentro da d-esfera
        if (rmod.le.1e0) then
            N = N + 1
        end if
    end do

    ! Volume obtido pelo metodo de monte carlo
    Vmc = (float(N)/float(M)) * 2e0**id

    ! aqui é feita uma mudança de variável para facilitar
    ! arg = d/2 + 1
    ! dgamma(arg) = (arg-1)*dgamma(arg-1)
    arg = (id/2e0 + 1e0)
    dgamma = 1e0

    arg = arg - 1e0
    ! O Cálculo da função gamma é reproativo,
    ! então precisa verificar se a última iteração será gamma(1) ou gamma(1/2)
    do while (arg.gt.0e0)
        if (arg.ge.1e0) then
            dgamma = arg*dgamma
            arg = arg - 1e0
        else
            dgamma = arg*sqrt(pi)*dgamma
            arg = 0e0
        end if
    end do

    ! Cálculo do volume de d-esfera de raio 1
    Vd = pi**(id/2e0) / dgamma

    ! Imprime os volumes da tela
    print '(A,F0.6)', 'Volume por Monte Carlo: ', Vmc
    print '(A,F0.6)', 'Volume por n-esferas:   ', Vd

end program tarefa7


!============================================================
!> Inverse matrix
!! Method: Based on Doolittle LU factorization for Ax=b
!! Original code by Alex G. December 2009
!! modified by Jongchan Kim 2018
!!-----------------------------------------------------------
!! input ...
!! a(n,n) - array of coefficients for matrix A
!! n      - dimension
!! output ...
!! a(n,n) - inverse matrix of A
!! comments ...
!! the original matrix a(n,n) will be destroyed
!! during the calculation
!!===========================================================
subroutine matInverse(a,n)

    implicit none
    integer :: n
    real(8) :: a(n,n)
    real(8) :: L(n,n), U(n,n), b(n), d(n), x(n)
    real(8) :: coeff
    integer :: i, j, k

    ! step 0: initialization for matrices L and U and b
    ! Fortran 90/95 aloows such operations on matrices
    L=0.d0
    U=0.d0
    b=0.d0

    ! step 1: forward elimination
    do k=1, n-1
        do i=k+1,n
            coeff=a(i,k)/a(k,k)
            L(i,k) = coeff
            do j=k+1,n
                a(i,j) = a(i,j)-coeff*a(k,j)
            end do
        end do
    end do

    ! Step 2: prepare L and U matrices
    ! L matrix is a matrix of the elimination coefficient
    ! + the diagonal elements are 1.0
    do i=1,n
        L(i,i) = 1.d0
    end do
    ! U matrix is the upper triangular part of A
    do j=1,n
        do i=1,j
            U(i,j) = a(i,j)
        end do
    end do

    ! Step 3: compute columns of the inverse matrix C
    do k=1,n
        b(k)=1.d0
        d(1) = b(1)
        ! Step 3a: Solve Ld=b using the forward substitution
        do i=2,n
            d(i)=b(i)
            do j=1,i-1
                d(i) = d(i) - L(i,j)*d(j)
            end do
        end do
        ! Step 3b: Solve Ux=d using the back substitution
        x(n)=d(n)/U(n,n)
        do i = n-1,1,-1
            x(i) = d(i)
            do j=n,i+1,-1
                x(i)=x(i)-U(i,j)*x(j)
            end do
            x(i) = x(i)/u(i,i)
        end do
        ! Step 3c: fill the solutions x(n) into column k of C
        do i=1,n
            a(i,k) = x(i)
        end do
        b(k)=0.d0
    end do
end subroutine matInverse


! Objetivo: Obter as raizes reais e complexas da equação
! (terceiro grau) variando o termo independente dentro
! do intervalo de 5 a 7. Em seguida, verificar resultado.

PROGRAM raizes_reais_complexas
	USE nrtype
! Declaracao de variaveis
	IMPLICIT none
	REAL, PARAMETER :: coefic_a = -6., coefic_b = 11., coefic_a_div = coefic_a/3.
	REAL, PARAMETER :: coefic_c_inicial = 5., coefic_c_final = 7.
	REAL :: raiz_1, raiz_2, raiz_3, raiz_real1, &
		raiz_real2, raiz_real3, coefic_c = coefic_c_inicial
	REAL :: raiz_img2, raiz_img3
	REAL :: R, A, B, R_exp2, soma_ab, dif_ab
	REAL :: theta
	INTEGER, PARAMETER :: dados_reais = 7, dados_complexos = 8, &
		num_pontos = 1000
	INTEGER, PARAMETER :: dados_cx = 9
	INTEGER :: num_repetir
	REAL, PARAMETER :: incremento_c = (coefic_c_final - &
		coefic_c_inicial)/REAL(num_pontos)
	REAL :: x_da_curva, c_da_curva
	REAL, PARAMETER :: Q = coefic_a_div**2 - coefic_b/3., Q_exp3 = Q**3
	REAL, PARAMETER :: parte_R = (coefic_a_div**3) - coefic_a*coefic_b/6.
	REAL, PARAMETER :: doisraiz_q = -2.*SQRT(Q), div_1_3 = 1./3., &
				raiz3_div2 = 0.5*SQRT(3.)

! Os valores (iniciais e finais) de x foram calculados
! por uma calculadora grafica
	REAL, PARAMETER :: x_inicial = 0.48, x_final = 3.52, incremento_x &
		= (x_final - x_inicial)/REAL(num_pontos)
! Abrindo os arquivos de saida (fora do loop)
	OPEN(dados_reais, FILE="dados_reais.dat")
   	OPEN(dados_complexos, FILE="dados_complexos.dat")
! Separando a parte dependente de C para otimizar o loop
	DO num_repetir = 0, num_pontos
		R = parte_R - 0.5*coefic_c
		R_exp2 = R**2
! Primeiro Caso
		IF (R_exp2 <= Q_exp3) THEN
			theta = ACOS(R/SQRT(Q_exp3))
			raiz_1 = doisraiz_q*COS(theta/3.) - (coefic_a_div)
			raiz_2 = doisraiz_q*COS((theta + TWOPI)/3.) - &
				(coefic_a_div)
			raiz_3 = doisraiz_q*COS((theta - TWOPI)/3.) - &
				(coefic_a_div)
! Escrevendo dentro dos arquivos de saida
			WRITE(dados_reais,*) coefic_c, raiz_1
		 	WRITE(dados_reais,*) coefic_c, raiz_2
		 	WRITE(dados_reais,*) coefic_c, raiz_3
! Segundo Caso
		ELSE
			A = -SIGN(1.0,R)*(ABS(R) + SQRT(R_exp2 - Q_exp3))**div_1_3
			IF (A /= 0.) THEN
				B = Q/A
			ELSE
				B = 0.
			END IF
! Determinando as partes imaginarias e reais de cada raiz
			soma_ab = A + B
			dif_ab = A - B
			raiz_real1 = soma_ab - coefic_a_div
			raiz_real2 = -0.5*soma_ab - coefic_a_div
			raiz_img2 = raiz3_div2*dif_ab
			raiz_real3 = raiz_real2
			raiz_img3 = -raiz_img2
! Escrevendo dentro dos arquivos de saida
			WRITE(dados_reais,*) coefic_c, raiz_real1
			WRITE(dados_complexos,*) raiz_real2, raiz_img2
		 	WRITE(dados_complexos,*) raiz_real3, raiz_img3
		END IF
! Modificando o valor de c no intervalo proposto
		coefic_c = coefic_c + incremento_c
	END DO
! Fechando os arquivos de saida
	CLOSE(dados_reais)
	CLOSE(dados_complexos)
! Abrindo arquivo de saida
	OPEN(dados_cx, FILE="dados_cx.dat")
	x_da_curva = x_inicial
	DO num_repetir = 1, num_pontos
		c_da_curva = x_da_curva*(coefic_b + (x_da_curva* &
			(x_da_curva + coefic_a)))
! Modificando o valor de x no intervalo proposto
		x_da_curva = x_da_curva + incremento_x
! Escrevendo dentro do arquivo de saida
		WRITE(dados_cx,*) c_da_curva , x_da_curva
	END DO
! Fechando arquivo de saida
	CLOSE(dados_cx)
END PROGRAM raizes_reais_complexas


!QUADRARIC EQUATION SOLVING

program Quadratic_Root
    implicit none

    real :: a, b, c, discriminant, real_part, imaginary_part;
    print *, "Enter the value of a , b and c?"
    READ *, a, b, c;
    discriminant = b*b - 4*a*c

    print *, "Roots are"

    if (discriminant > 0) then

        real_part = -b/(2.0*a)
        imaginary_part = SQRT(discriminant)/(2.0*a)

        print '(f4.2,A2,f4.2,A5,f4.2,A2,f4.2)', real_part, "+", imaginary_part, " and ", real_part, "-", imaginary_part
    else if (discriminant == 0) then

        real_part = -b/(2.0*a)
        imaginary_part = SQRT(discriminant)/(2.0*a)

        print '(f4.2,A5,f4.2)', real_part, " and ", real_part

    else if (discriminant < 0) then

        real_part = -b/(2.0*a)
        imaginary_part = SQRT(-discriminant)/(2.0*a)

        print '(f5.2,A4,f5.2,A5,f4.2,A4,f4.2)', real_part, " + i", imaginary_part, " and ", real_part, " - i", imaginary_part

    end if

end program Quadratic_Root


MODULE Gauss

   USE PrecTypes
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! Name:   Gauss
   ! Parent: General
   ! Status: Current
   ! Owner:  Toshiro Matsumoto
   ! Text:   Coordinates and weights of Gaussian quadrature formula.
   ! Revision Date: 16-Jul-2009
   ! -------------------------------------------------------------------------

   ! Offset numbers used in the arrays zt() and wt()
   INTEGER(I4B) :: ngs(6) =(/ 0, 0, 2, 5, 9, 14 /)

   ! Coordinates of the integration points
   REAL(DP) :: zt(20) = (/   &
      !
      ! 2-point formula
      -0.577350269189626E0_DP,  &  ! = zt( 1 + ngs(2) )
       0.577350269189626E0_DP,  &  ! = zt( 2 + ngs(2) )
      !
      ! 3-point formula
      -0.774596669241483E0_DP,  &  ! = zt( 1 + ngs(3) )
       0.000000000000000E0_DP,  &  ! = zt( 2 + ngs(3) )
       0.774596669241483E0_DP,  &  ! = zt( 3 + ngs(3) )
      !
      ! 4-point formula
      -0.861136311594053E0_DP,  &  ! = zt( 1 + ngs(4) )
      -0.339981043584856E0_DP,  &  ! = zt( 2 + ngs(4) )
       0.339981043584856E0_DP,  &  ! = zt( 3 + ngs(4) )
       0.861136311594053E0_DP,  &  ! = zt( 4 + ngs(4) )
      !
      ! 5-point formula
      -0.906179845938664E0_DP,  &  ! = zt( 1 + ngs(5) )
      -0.538469310105683E0_DP,  &  ! = zt( 2 + ngs(5) )
       0.000000000000000E0_DP,  &  ! = zt( 3 + ngs(5) )
       0.538469310105683E0_DP,  &  ! = zt( 4 + ngs(5) )
       0.906179845938664E0_DP,  &  ! = zt( 5 + ngs(5) )
      !
      ! 6-point formula
      -0.932469514203152E0_DP,  &  ! = zt( 1 + ngs(6) )
      -0.661209386466265E0_DP,  &  ! = zt( 2 + ngs(6) )
      -0.238619186083197E0_DP,  &  ! = zt( 3 + ngs(6) )
       0.238619186083197E0_DP,  &  ! = zt( 4 + ngs(6) )
       0.661209386466265E0_DP,  &  ! = zt( 5 + ngs(6) )
       0.932469514203152E0_DP   &  ! = zt( 6 + ngs(6) )
   /)

   !  Weights to multiply to the function values at the integration points
   REAL(DP) :: wt(20) =(/   &
      ! 2-point formula
      0.100000000000000E1_DP,  &  ! = wt( 1 + ngs(2) )
      0.100000000000000E1_DP,  &  ! = wt( 2 + ngs(2) )
      !
      ! 3-point formula
      0.555555555555556E0_DP,  &  ! = wt( 1 + ngs(3) )
      0.888888888888889E0_DP,  &  ! = wt( 2 + ngs(3) )
      0.555555555555556E0_DP,  &  ! = wt( 3 + ngs(3) )
      !
      ! 4-point formula
      0.347854845137454E0_DP,  &  ! = wt( 1 + ngs(4) )
      0.652145154862546E0_DP,  &  ! = wt( 2 + ngs(4) )
      0.652145154862546E0_DP,  &  ! = wt( 3 + ngs(4) )
      0.347854845137454E0_DP,  &  ! = wt( 4 + ngs(4) )
      !
      ! 5-point formula
      0.236926885056189E0_DP,  &  ! = wt( 1 + ngs(5) )
      0.478628670499366E0_DP,  &  ! = wt( 2 + ngs(5) )
      0.568888888888889E0_DP,  &  ! = wt( 3 + ngs(5) )
      0.478628670499366E0_DP,  &  ! = wt( 4 + ngs(5) )
      0.236926885056189E0_DP,  &  ! = wt( 5 + ngs(5) )
      !
      ! 6-point formula
      0.171324492379170E0_DP,  &  ! = wt( 1 + ngs(6) )
      0.360761573048139E0_DP,  &  ! = wt( 2 + ngs(6) )
      0.467913934572691E0_DP,  &  ! = wt( 3 + ngs(6) )
      0.467913934572691E0_DP,  &  ! = wt( 4 + ngs(6) )
      0.360761573048139E0_DP,  &  ! = wt( 5 + ngs(6) )
      0.171324492379170E0_DP   &  ! = wt( 6 + ngs(6) )
   /)

END MODULE Gauss


!  function curl3D1(f1,f2,f3,dx1,dx2,dx3)
!
!    !------------------------------------------------------------
!    !-------COMPUTE A 3D CURL, X1 COMPONENT.  IT IS EXPECTED THAT
!    !-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!    !-------THEY ARE PASSED INTO THIS ROUTINE.  DX(I) IS PRESUMED
!    !-------TO BE THE *BACKWARD* DIFFERENCE AT POINT I.
!    !-------
!    !-------THE F1 COMPONENT AND DIFF COULD BE OMITTED.
!    !------------------------------------------------------------
!
!    real(wp), dimension(:,:,:), intent(in) :: f1,f2,f3
!    real(wp), dimension(1:size(f1,1)), intent(in) :: dx1
!    real(wp), dimension(1:size(f1,2)), intent(in) :: dx2
!    real(wp), dimension(1:size(f1,3)), intent(in) :: dx3
!
!    integer :: ix1,ix2,ix3,lx1,lx2,lx3
!
!    real(wp), dimension(1:size(f1,1),1:size(f1,2),1:size(f1,3)) :: curl3D1
!
!    lx1=size(f1,1)
!    lx2=size(f1,2)
!    lx3=size(f1,3)
!
!    if (lx2>1) then
!      do ix3=1,lx3
!        do ix1=1,lx1
!          curl3D1(ix1,1,ix3)=(f3(ix1,2,ix3)-f3(ix1,1,ix3))/dx2(2)   !fwd diff
!          curl3D1(ix1,2:lx2-1,ix3)=(f3(ix1,3:lx2,ix3)-f3(ix1,1:lx2-2,ix3)) &
!                                       /(dx2(3:lx2)+dx2(2:lx2-1))
!          curl3D1(ix1,lx2,ix3)=(f3(ix1,lx2,ix3)-f3(ix1,lx2-1,ix3))/dx2(lx2)    !bwd diff
!        end do
!      end do
!    else
!      curl3D1=0d0
!    end if
!
!    do ix2=1,lx2
!      do ix1=1,lx1
!        curl3D1(ix1,ix2,1)=curl3D1(ix1,ix2,1)-(f2(ix1,ix2,2)-f2(ix1,ix2,1))/dx3(2)
!        curl3D1(ix1,ix2,2:lx3-1)=curl3D1(ix1,ix2,2:lx3-1)- &
!                                 (f2(ix1,ix2,3:lx3)-f2(ix1,ix2,1:lx3-2)) &
!                                     /(dx3(3:lx3)+dx3(2:lx3-1))
!        curl3D1(ix1,ix2,lx3)=curl3D1(ix1,ix2,lx3)-(f2(ix1,ix2,lx3)-f2(ix1,ix2,lx3-1))/dx3(lx3)
!      end do
!    end do
!
!  end function curl3D1
!
!
!  function curl3D2(f1,f2,f3,dx1,dx2,dx3)
!
!    !------------------------------------------------------------
!    !-------COMPUTE A 3D CURL, X2 COMPONENT.  IT IS EXPECTED THAT
!    !-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!    !-------THEY ARE PASSED INTO THIS ROUTINE.  DX(I) IS PRESUMED
!    !-------TO BE THE *BACKWARD* DIFFERENCE AT POINT I
!    !-------
!    !-------THE F2 COMPONENT AND DIFF COULD BE OMITTED.
!    !-------ARE THE SIGNS RIGHT?
!    !------------------------------------------------------------
!
!    real(wp), dimension(:,:,:), intent(in) :: f1,f2,f3
!    real(wp), dimension(1:size(f1,1)), intent(in) :: dx1
!    real(wp), dimension(1:size(f1,2)), intent(in) :: dx2
!    real(wp), dimension(1:size(f1,3)), intent(in) :: dx3
!
!    integer :: ix1,ix2,ix3,lx1,lx2,lx3
!
!    real(wp), dimension(1:size(f1,1),1:size(f1,2),1:size(f1,3)) :: curl3D2
!
!    lx1=size(f1,1)
!    lx2=size(f1,2)
!    lx3=size(f1,3)
!
!    do ix2=1,lx2
!      do ix1=1,lx1
!        curl3D2(1,ix2,ix3)=(f3(2,ix2,ix3)-f3(1,ix2,ix3))/dx1(2)   !fwd diff
!        curl3D2(2:lx1-1,ix2,ix3)=(f3(3:lx1,ix2,ix3)-f3(1:lx1-2,ix2,ix3)) &
!                                     /(dx1(3:lx1)+dx1(2:lx1-1))
!        curl3D2(lx1,ix2,ix3)=(f3(lx1,ix2,ix3)-f3(lx1-1,ix2,ix3))/dx1(lx1)    !bwd diff
!      end do
!    end do
!
!    do ix2=1,lx2
!      do ix1=1,lx1
!        curl3D2(ix1,ix2,1)=curl3D2(ix1,ix2,1)-(f1(ix1,ix2,2)-f1(ix1,ix2,1))/dx3(2)
!        curl3D2(ix1,ix2,2:lx3-1)=curl3D2(ix1,ix2,2:lx3-1)- &
!                                 (f1(ix1,ix2,3:lx3)-f1(ix1,ix2,1:lx3-2)) &
!                                     /(dx3(3:lx3)+dx3(2:lx3-1))
!        curl3D2(ix1,ix2,lx3)=curl3D2(ix1,ix2,lx3)-(f1(ix1,ix2,lx3)-f1(ix1,ix2,lx3-1))/dx3(lx3)
!      end do
!    end do
!
!  end function curl3D2
!
!
!  function curl3D3(f1,f2,f3,dx1,dx2,dx3)
!
!    !------------------------------------------------------------
!    !-------COMPUTE A 3D CURL, X3 COMPONENT.  IT IS EXPECTED THAT
!    !-------GHOST CELLS WILL HAVE BEEN TRIMMED FROM ARRAYS BEFORE
!    !-------THEY ARE PASSED INTO THIS ROUTINE.  DX(I) IS PRESUMED
!    !-------TO BE THE *BACKWARD* DIFFERENCE AT POINT I
!    !-------
!    !-------THE F3 COMPONENT AND DIFF COULD BE OMITTED.
!    !------------------------------------------------------------
!
!    real(wp), dimension(:,:,:), intent(in) :: f1,f2,f3
!    real(wp), dimension(1:size(f1,1)), intent(in) :: dx1
!    real(wp), dimension(1:size(f1,2)), intent(in) :: dx2
!    real(wp), dimension(1:size(f1,3)), intent(in) :: dx3
!
!    integer :: ix1,ix2,ix3,lx1,lx2,lx3
!
!    real(wp), dimension(1:size(f1,1),1:size(f1,2),1:size(f1,3)) :: curl3D3
!
!    lx1=size(f1,1)
!    lx2=size(f1,2)
!    lx3=size(f1,3)
!
!    do ix2=1,lx2
!      do ix1=1,lx1
!        curl3D3(1,ix2,ix3)=(f2(2,ix2,ix3)-f2(1,ix2,ix3))/dx1(2)   !fwd diff
!        curl3D3(2:lx1-1,ix2,ix3)=(f2(3:lx1,ix2,ix3)-f2(1:lx1-2,ix2,ix3)) &
!                                     /(dx1(3:lx1)+dx1(2:lx1-1))
!        curl3D3(lx1,ix2,ix3)=(f2(lx1,ix2,ix3)-f2(lx1-1,ix2,ix3))/dx1(lx1)    !bwd diff
!      end do
!    end do
!
!    if (lx2>1) then
!      do ix3=1,lx3
!        do ix1=1,lx1
!          curl3D3(ix1,1,ix3)=curl3D3(ix1,1,ix3)-(f1(ix1,2,ix3)-f1(ix1,1,ix3))/dx2(2)   !fwd diff
!          curl3D3(ix1,2:lx2-1,ix3)=curl3D3(ix1,2:lx2-1,ix3)- &
!                                    (f1(ix1,3:lx2,ix3)-f1(ix1,1:lx2-2,ix3)) &
!                                       /(dx2(3:lx2)+dx2(2:lx2-1))
!          curl3D3(ix1,lx2,ix3)=curl3D3(ix1,lx2,ix3)-(f1(ix1,lx2,ix3)-f1(ix1,lx2-1,ix3))/dx2(lx2)    !bwd diff
!        end do
!      end do
!    end if
!
!  end function curl3D3


   PROGRAM mean_R
   IMPLICIT NONE

   INTEGER (KIND=8),PARAMETER::n=5

   INTEGER (KIND=8):: i
   REAL    (KIND=8):: Ra_av,Rb_av,Rd_av,R_av,WS_av,Kad,Kab
   REAL    (KIND=8):: Ra_dev,Rb_dev,Rd_dev,R_dev
   REAL    (KIND=8),DIMENSION(n):: Ra,Rb,Rd,R,WS

!!!=======================================================================================
!!!=======================================================================================
   OPEN(unit=11,file='average.dat')
   OPEN(unit=12,file='average_av.dat')
   OPEN(unit=13,file='Ra_dev.dat')
   OPEN(unit=14,file='Rd_dev.dat')

!!! Tinh gia tri trung binh
   Ra_av=0. ; Rb_av=0. ; Rd_av=0. ; R_av=0.

   DO i=1,n
      READ(11,*)Kad,Kab,Ra(i),Rb(i),Rd(i),R(i),WS(i)
      Ra_av=Ra_av+Ra(i)
      Rb_av=Rb_av+Rb(i)
      Rd_av=Rd_av+Rd(i)
      R_av=R_av+R(i)
      WS_av=WS_av+abs(WS(i))
   END DO

   Ra_av=Ra_av/n ; Rb_av=Rb_av/n ; Rd_av=Rd_av/n ; R_av=R_av/n ; WS_av=WS_av/n

!!! Tinh standard deviation
   Ra_dev=0.
   DO i=1,n
      Ra_dev=Ra_dev+(Ra(i)-Ra_av)**2.
   END DO
   Ra_dev=sqrt(Ra_dev/n)

   Rb_dev=0.
   DO i=1,n
      Rb_dev=Rb_dev+(Rb(i)-Rb_av)**2.
   END DO
   Rb_dev=sqrt(Rb_dev/n)

   Rd_dev=0.
   DO i=1,n
      Rd_dev=Rd_dev+(Rd(i)-Rd_av)**2.
   END DO
   Rd_dev=sqrt(Rd_dev/n)

   R_dev=0.
   DO i=1,n
      R_dev=R_dev+(R(i)-R_av)**2.
   END DO
   R_dev=sqrt(R_dev/n)

   WRITE(12,*)Kad,1./Kab,Ra_av,Rb_av,Rd_av,R_av,R_av-R_dev,R_av+R_dev,WS_av
   WRITE(13,*)Kad,1./Kab,Ra_av,Ra_av-Ra_dev,Ra_av+Ra_dev,Rb_av,Rb_av-Rb_dev,Rb_av+Rb_dev
   WRITE(14,*)Kad,1./Kab,Rd_av,Rd_av-Rd_dev,Rd_av+Rd_dev

   CLOSE(11)
   CLOSE(12)
   CLOSE(13)
   CLOSE(14)

   END PROGRAM mean_R


! Objetivo: Reproduzir o gráfico da funcao gama

PROGRAM grafico_gama
	USE nrtype
	USE nrutil
	USE nr, ONLY: gammln
	IMPLICIT none
	INTEGER :: cont_pontos, variacao_x_positivo
	INTEGER, PARAMETER :: saida_gama = 9, total_pontos = 1000
	INTEGER, PARAMETER :: x_positivo = total_pontos/2
	REAL :: x, pi_x, x_mais_1
	REAL, PARAMETER :: x_inicial = -5.25, x_final = 5.25
	REAL, PARAMETER :: incremento_x=(x_final-x_inicial)/(total_pontos)
	REAL, DIMENSION(-x_positivo:x_positivo) :: funcao_gama

	x = 0.0
	DO variacao_x_positivo = 1, x_positivo
		x = x+incremento_x
		x_mais_1 = 1.0+x
! funcao gama para abscissas positivas
		funcao_gama(variacao_x_positivo) = exp(gammln(x_mais_1))
		pi_x = pi*x
! Pela formula de reflexao para abscissas negativas
		funcao_gama (-variacao_x_positivo) = pi_x/(funcao_gama&
					(variacao_x_positivo)*sin(pi_x))
	END DO
	x = x_inicial
! Quando o argumento for igual a zero
	funcao_gama(0) = 1.0
	OPEN(unit=saida_gama, file="dados_gama.dat")
	DO cont_pontos = -x_positivo, x_positivo
		WRITE(saida_gama,fmt=*) x, funcao_gama(cont_pontos)
		x = x+incremento_x
	END DO
	CLOSE(unit=saida_gama)
END PROGRAM grafico_gama


FUNCTION polyarea(x, y, nb) RESULT(fn_val)

! Code converted using TO_F90 by Alan Miller
! Date: 2000-07-04  Time: 12:24:06

IMPLICIT NONE

REAL, INTENT(IN)     :: x(:)
REAL, INTENT(IN)     :: y(:)
INTEGER, INTENT(IN)  :: nb
REAL                 :: fn_val

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

!   GIVEN A SEQUENCE OF NB POINTS (X(I),Y(I)),  polyarea COMPUTES THE AREA
! BOUNDED BY THE CLOSED POLYGONAL CURVE WHICH PASSES THROUGH THE POINTS IN
! THE ORDER THAT THEY ARE INDEXED.  THE FINAL POINT OF THE CURVE IS ASSUMED
! TO BE THE FIRST POINT GIVEN.  THEREFORE, IT NEED NOT BE LISTED AT THE END
! OF X AND Y.  THE CURVE IS NOT REQUIRED TO BE SIMPLE.  e.g. It may cross over
! itself.

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

INTEGER  :: i, n, nm1
REAL     :: a

n = nb
IF (x(1) == x(n) .AND. y(1) == y(n)) n = n - 1

SELECT CASE (n)
  CASE (:2)
     fn_val = 0.0

  CASE (3)
     fn_val= 0.5*((x(2) - x(1))*(y(3) - y(1)) - (x(3) - x(1))*(y(2) - y(1)))

  CASE DEFAULT
    nm1 = n - 1
    a = x(1)*(y(2) - y(n)) + x(n)*(y(1) - y(nm1))
    DO  i = 2, nm1
      a = a + x(i)*(y(i+1) - y(i-1))
    END DO
    fn_val = 0.5*a
END SELECT

RETURN
END FUNCTION polyarea


	FUNCTION PR_TMFC  ( tmpf )
C************************************************************************
C* PR_TMFC								*
C*									*
C* This function computes TMPC from TMPF.  The following equation is	*
C* used:			 					*
C*									*
C*                TMPC = ( TMPF - 32 ) * 5 / 9				*
C*									*
C* REAL PR_TMFC  ( TMPF )						*
C*									*
C* Input parameters:							*
C*	TMPF		REAL		Temperature in Fahrenheit	*
C*									*
C* Output parameters:							*
C*	PR_TMFC		REAL		Temperature in Celsius		*
C**									*
C* Log:									*
C* J. Woytek/GSFC	10/82	Original source code			*
C* M. desJardins/GSFC	 4/86	Added PARAMETER statement		*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 8/88	Modified documentation			*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
	PARAMETER	( RPRM = 5. / 9. )
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( tmpf ) )  THEN
	    PR_TMFC = RMISSD
	  ELSE
	    PR_TMFC = ( tmpf - 32.0 ) * RPRM
	END IF
C*
	RETURN
	END


Program Cholesky_decomp
! *************************************************!
! LBH @ ULPGC 06/03/2014
! Compute the Cholesky decomposition for a matrix A
! after the attached
! http://rosettacode.org/wiki/Cholesky_decomposition
! note that the matrix A is complex since there might
! be values, where the sqrt has complex solutions.
! Here, only the real values are taken into account
!*************************************************!
implicit none

INTEGER, PARAMETER :: m=3 !rows
INTEGER, PARAMETER :: n=3 !cols
COMPLEX, DIMENSION(m,n) :: A
REAL, DIMENSION(m,n) :: L
REAL :: sum1, sum2
INTEGER i,j,k

! Assign values to the matrix
A(1,:)=(/ 25,  15,  -5 /)
A(2,:)=(/ 15,  18,   0 /)
A(3,:)=(/ -5,   0,  11 /)
! !!!!!!!!!!!another example!!!!!!!
! A(1,:) = (/ 18,  22,   54,   42 /)
! A(2,:) = (/ 22,  70,   86,   62 /)
! A(3,:) = (/ 54,  86,  174,  134 /)
! A(4,:) = (/ 42,  62,  134,  106 /)

! Initialize values
L(1,1)=real(sqrt(A(1,1)))
L(2,1)=A(2,1)/L(1,1)
L(2,2)=real(sqrt(A(2,2)-L(2,1)*L(2,1)))
L(3,1)=A(3,1)/L(1,1)
! for greater order than m,n=3 add initial row value
! for instance if m,n=4 then add the following line
! L(4,1)=A(4,1)/L(1,1)

do i=1,n
    do k=1,i
        sum1=0
        sum2=0
        do j=1,k-1
        if (i==k) then
            sum1=sum1+(L(k,j)*L(k,j))
            L(k,k)=real(sqrt(A(k,k)-sum1))
        elseif (i > k) then
            sum2=sum2+(L(i,j)*L(k,j))
            L(i,k)=(1/L(k,k))*(A(i,k)-sum2)
        else
            L(i,k)=0
        end if
        end do
    end do
end do

! write output
do i=1,m
    print "(3(1X,F6.1))",L(i,:)
end do

End program Cholesky_decomp