c fishpk29 from portlib                                  12/30/83
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                        f i s h p a k                          *
c     *                                                               *
c     *                                                               *
c     *     a package of fortran subprograms for the solution of      *
c     *                                                               *
c     *      separable elliptic partial differential equations        *
c     *                                                               *
c     *                  (version 3.1 , october 1980)                  *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *        john adams, paul swarztrauber and roland sweet         *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the national center for atmospheric research          *
c     *                                                               *
c     *                boulder, colorado  (80307)  u.s.a.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the national science foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c     program to illustrate the use of hwscsp
c
      program thwscsp
      dimension       f(48,33)   ,bdtf(33)   ,w(775)     ,r(33)      ,
     1                theta(48)
      dimension bdts(1), bdrs(1), bdrf(1)
c
      pi = pimach(dum)
      intl = 0
      ts = 0.
      tf = pi/2.
      m = 36
      mbdcnd = 6
      rs = 0.
      rf = 1.
      n = 32
      nbdcnd = 5
      elmbda = 0.
      idimf = 48
c
c     generate and store grid points for the purpose of computing the
c     boundary data and the right side of the equation.
c
      mp1 = m+1
      dtheta = tf/float(m)
      do 101 i=1,mp1
         theta(i) = float(i-1)*dtheta
  101 continue
      np1 = n+1
      dr = 1./float(n)
      do 102 j=1,np1
         r(j) = float(j-1)*dr
  102 continue
c
c     generate normal derivative data at equator
c
      do 103 j=1,np1
         bdtf(j) = 0.
  103 continue
c
c     compute boundary data on the surface of the sphere
c
      do 104 i=1,mp1
         f(i,n+1) = cos(theta(i))**4
  104 continue
c
c     compute right side of equation
c
      do 106 i=1,mp1
         ci4 = 12.*cos(theta(i))**2
         do 105 j=1,n
            f(i,j) = ci4*r(j)**2
  105    continue
  106 continue
c
      call hwscsp (intl,ts,tf,m,mbdcnd,bdts,bdtf,rs,rf,n,nbdcnd,bdrs,
     1             bdrf,elmbda,f,idimf,pertrb,ierror,w)
c
c     compute discretization error
c
      err = 0.
      do 108 i=1,mp1
         ci4 = cos(theta(i))**4
         do 107 j=1,n
            z = abs(f(i,j)-ci4*r(j)**4)
            if (z .gt. err) err = z
  107    continue
  108 continue
      iw = int(w(1))
      print 1001 , ierror,err,iw
c
c     the following program illustrates the use of hwscsp to solve
c     a three dimensional problem which has longitudnal dependence
c
      mbdcnd = 2
      nbdcnd = 1
      dphi = pi/72.
      elmbda = -2.*(1.-cos(dphi))/dphi**2
c
c     compute boundary data on the surface of the sphere
c
      do 109 i=1,mp1
         f(i,n+1) = sin(theta(i))
  109 continue
c
c     compute right side of the equation
c
      do 111 j=1,n
         do 110 i=1,mp1
            f(i,j) = 0.
  110    continue
  111 continue
c
      call hwscsp (intl,ts,tf,m,mbdcnd,bdts,bdtf,rs,rf,n,nbdcnd,bdrs,
     1             bdrf,elmbda,f,idimf,pertrb,ierror,w)
c
c     compute discretization error   (fourier coefficients)
c
      err = 0
      do 113 i=1,mp1
         si = sin(theta(i))
         do 112 j=1,np1
            z = abs(f(i,j)-r(j)*si)
            if (z .gt. err) err = z
  112    continue
  113 continue
c
      iw = int(w(1))
      print 1002 , ierror,err,iw
      stop
c
 1001 format (1h1,20x,27hsubroutine hwscsp example 1///
     1        10x,46hthe output from the ncar control data 7600 was//
     2        32x,10hierror = 0/
     3        18x,34hdiscretization error = 7.99842e-04/
     4        12x,32hrequired length of w array = 775//
     5        10x,32hthe output from your computer is//
     6        32x,8hierror =,i2/18x,22hdiscretization error =,e12.5/
     7        12x,28hrequired length of w array =,i4)
 1002 format (1h1,20x,27hsubroutine hwscsp example 2///
     1        10x,46hthe output from the ncar control data 7600 was//
     2        32x,10hierror = 0/
     3        18x,34hdiscretization error = 5.86824e-05/
     4        12x,32hrequired length of w array = 775//
     5        10x,32hthe output from your computer is//
     6        32x,8hierror =,i2/18x,22hdiscretization error =,e12.5/
     7        12x,28hrequired length of w array =,i4)
c
      end


! Identity matrix distribution
!
! Write a program that distributes an identity matrix over the processes.  The
! dimension and the number of processes are given.  Distribute by rows (in
! Fortran).  The program reads the matrix size S, takes the number of processes
! N, and calculates how many rows each process must have.  Better if subarrays,
! local to each rank, use through indexing.  At the end, rank 0 collects the
! matrix rows from the other ranks and prints the entire matrix.
!
! Compile and run:
!
!     $ mpifort -O0 -Wall -Wextra -fcheck=bounds -fbacktrace identity_matrix.f90
!     $ mpirun -np 3 --oversubscribe ./a.out
!
! Enter size 10.
program identity_matrix
    use mpi_f08
    implicit none
    type(MPI_Comm) :: comm
    type(MPI_Status) :: status
    integer :: my_rank, n_ranks
    integer :: ib, ie, i, s, rank
    integer, allocatable :: e(:, :)
    integer(kind=MPI_ADDRESS_KIND) :: lb, integer_extent
    type(MPI_Datatype) :: a_tmp_row, a_row

    call MPI_Init()
    comm = MPI_COMM_WORLD
    call MPI_Comm_rank(comm, my_rank)
    call MPI_Comm_size(comm, n_ranks)

    if (my_rank == 0) read *, s
    call MPI_Bcast(s, 1, MPI_INTEGER, 0, comm)

    call partition(my_rank, n_ranks, s, ib, ie)

    allocate(e(ib:ie, s), source=0)
    do i = ib, ie
        e(i, i) = 1
    end do

    call MPI_Type_get_extent(MPI_INTEGER, lb, integer_extent)
    call MPI_Type_vector(s, 1, ie - ib + 1, MPI_INTEGER, a_tmp_row)
    call MPI_Type_create_resized(a_tmp_row, lb, integer_extent, a_row)
    call MPI_Type_commit(a_row)

    if (my_rank == 0) then
        ! Rank 0 prints its own matrix,
        print "(a, i0)", "Rank ", my_rank
        do i = ib, ie
            print "(*(i1, 1x))", e(i, :)
        end do
        print *
        ! then receives rows from the other processes and prints them.
        do rank = 1, n_ranks - 1
            call partition(rank, n_ranks, s, ib, ie)
            call MPI_Recv(e(1, 1), ie - ib + 1, a_row, rank, 0, comm, status)
            print "(a, i0)", "Rank ", rank
            do i = 1, ie - ib + 1
                print "(*(i1, 1x))", e(i, :)
            end do
            print *
        end do
    else
        call MPI_Send(e(ib, 1), ie - ib + 1, a_row, 0, 0, comm)
    end if

    call MPI_Type_free(a_row)
    deallocate(e)

    call MPI_Finalize()

contains

    subroutine partition(id, n_ids, size, b, e)
        integer, intent(in)    :: id, n_ids, size
        integer, intent(inout) :: b, e
        integer :: remainder, quotient

        remainder = modulo(size, n_ids)
        quotient  = (size - remainder) / n_ids
        b = 1 + quotient * (id    ) + min(remainder, id    )
        e =     quotient * (id + 1) + min(remainder, id + 1)
        return
    end subroutine partition

end program identity_matrix


c     program DRDSVDRS
c>> 1996-06-25 DRDSVDRS   Krogh Changes for conversion to C.
c>> 1996-05-28 DRDSVDRS   Krogh Added external statement.
c>> 1994-10-19 DRDSVDRS   Krogh  Changes to use M77CON
c>> 1992-03-18 DRDSVDRS   CLL Added "c" to "program" line above.
c>> 1992-03-12 DRDSVDRS   CLL
c     Demo driver for DSVDRS and DCOV3, Singular Value Decomposition
c     and Covariance matrix.
c
c     The sample data was computed as
c     y = 0.5 + 0.25 * sin(2*pi*x) + 0.125 * exp(-x)
c     rounded to four decimal places.
c     ------------------------------------------------------------------
c--D replaces "?": DR?SVDRS, ?SVDRS, ?COV3, ?DOT, ?NRM2
c     ------------------------------------------------------------------
      external DDOT, DNRM2
      double precision DDOT, DNRM2
      integer MMAX, NMAX
      parameter(MMAX = 11, NMAX = 3)
      double precision A(MMAX,NMAX), B(MMAX), C(NMAX), DOF, PI, RNORM
      double precision SING(NMAX), STDDEV
      double precision VAR, WORK(2*NMAX), X(MMAX),Y(MMAX)
      integer I, IERR, J, M, N
c
      data X / 0.0d0,  0.1d0,  0.2d0,  0.3d0,  0.4d0,  0.5d0,
     *                 0.6d0,  0.7d0,  0.8d0,  0.9d0,  1.0d0/
      data Y / 0.6250d0,0.7601d0,0.8401d0,0.8304d0,0.7307d0,0.5758d0,
     *                0.4217d0,0.3243d0,0.3184d0,0.4039d0,0.5460d0/
c     ------------------------------------------------------------------
      M = MMAX
      N = NMAX
      print*,' DRDSVDRS..    Demo driver for DSVDRS and DCOV3.'
c
      PI = 4.0d0 * atan(1.0d0)
      do 10 I = 1, M
         A(I,1) = 1.0d0
         A(I,2) = sin(2.0d0 * PI * X(I))
         A(I,3) = exp(-X(I))
         B(I) = Y(I)
   10 continue

      call DSVDRS(A, MMAX, M, N, B, MMAX, 1, SING, WORK)
c
      print '(/'' Computed singular values:''/(1x,5g14.6))',
     *   (SING(I),I=1,N)
      print '(/'' V matrix:'')'
      do 15 I = 1, N
         print '(1x,3f12.6)', (A(I,J),J=1,N)
   15 continue
c
      RNORM = DNRM2(M-N, B(N+1), 1)
      DOF = M - N
      VAR = RNORM**2 / DOF
      STDDEV = sqrt(VAR)
      print '(/a,f10.6)', ' Estimated Std. Dev. of data error =',STDDEV
c
c     Writing the singular value decomposition of A as
c              A = U * S * Transpose(V),
c     the solution of the least-squares problem A*c ~ b will be
c              c  = V * Inverse(S) *Transpose(U) * b.
c     We now have V in A(), S in SING(), and the product, Transpose(U)*b
c     in B().  So we can now compute c, as long as all singular values
c     are nonzero.
c     SING() contains the singular values as nonnegative
c     numbers in nonincreasing order, so we only need to test SING(N).
c
      if(SING(N) .ne. 0.0d0) then
         do 20 I = 1,N
            B(I) = B(I) / SING(I)
   20    continue
         do 30 I = 1,N
            C(I) = DDOT(N, A(I,1), MMAX, B, 1)
   30    continue

         print '(1x,''Solution coefficients   ='',3f10.6)',
     *      (C(J),J=1,N)
      end if
c
c                      Compute covariance matrix.
c
      call DCOV3(A, MMAX, N, SING, VAR, WORK, IERR)
      print '(/'' After DCOV3, IERR = '',i4)',IERR
      if(IERR .eq. 0) then
         print '(/'' Covariance matrix:'')'
         do 40 I = 1, N
            print '(1x,3g14.6)', (A(I,J),J=1,N)
   40    continue
      end if
      end


!     Generate hdif.gr3 (or hvis.gr3) with hdif=L_h^2 * gamma/dt (where
!     gamma is a dimensionless constant between [0,0.25), and L_h is a length scale)
!     Works for mixed tri/quads.
!     Inputs: screen (gamma1,dt; hdif_max); hgrid.gr3
!     Output: hdif.gr3

!     ifort -Bstatic -O3 -o gen_hdif gen_hdif.f90
!     pgf90 -O2 -mcmodel=medium -Mbounds -O2 -o gen_hdif gen_hdif.f90

      implicit real*8(a-h,o-z)
      parameter(mnp=500000)
      parameter(mne=1000000)
      parameter(mnei=30)
      integer :: i34(mne),elnode(4,mne)
      dimension x(mnp),y(mnp),dp(mnp),area(mne)
      dimension nne(mnp),indel(mnei,mnp),hdif(mnp),hdif_e(mne),rlh(4)

      print*, 'Input gamma \in [0,0.25) and time step:' !stricter than necessary as dt' in transport is smaller
      read*, gamma1,dt
      if(gamma1>=0.25.or.gamma1<0) then
        print*, 'Choose a smaller gamma: ',gamma1
        stop
      endif
      print*, 'Input max. hdif:'
      read*, hdif_max

      open(14,file='hgrid.gr3')
      open(13,file='hdif.gr3')
      read(14,*)
      read(14,*) ne,np
      if(ne>mne.or.np>mnp) then
        write(*,*)'Increase mne/mnp',mne,mnp,ne,np
        stop
      endif

      do i=1,np
        read(14,*) j,x(i),y(i) !,dp(i)
      enddo !i=1,np
      do i=1,ne
        read(14,*) j,i34(i),elnode(1:i34(i),i)
        n1=elnode(1,i)
        n2=elnode(2,i)
        n3=elnode(3,i)
        area(i)=signa(x(n1),x(n2),x(n3),y(n1),y(n2),y(n3))
        if(area(i)<=0) then
          write(*,*)'Negative area at',i
          stop
        endif

        if(i34(i)==4) then
          n4=elnode(4,i)
          area(i)=area(i)+signa(x(n1),x(n3),x(n4),y(n1),y(n3),y(n4))
        endif

!        write(13,*)i,dmin1(hdif_max,gamma1*area(i))
!        hdif_e(i)=gamma1*area(i)/dt

        !Side length
        do j=1,i34(i)
          nd=elnode(j,i)
          j2=j+1
          if(j2>i34(i)) j2=j2-i34(i)
          nd2=elnode(j2,i)
          rlh(j)=sqrt((x(nd2)-x(nd))**2+(y(nd2)-y(nd))**2)
        enddo !j
        rlh_min=minval(rlh(1:i34(i)))
        hdif_e(i)=gamma1*rlh_min**2/dt
      enddo !i=1,ne

!     Neighborhood
      nne=0
      do i=1,ne
        do j=1,i34(i)
          nd=elnode(j,i)
          nne(nd)=nne(nd)+1
          if(nne(nd)>mnei) then
            write(*,*)'Too many neighbors',nd
            stop
          endif
          indel(nne(nd),nd)=i
        enddo
      enddo

      hdif=0
      do i=1,np
        do j=1,nne(i)
          ie=indel(j,i)
          hdif(i)=hdif(i)+hdif_e(ie)/nne(i)
        enddo !j
        hdif(i)=dmin1(hdif(i),hdif_max)
      enddo !i

      write(13,*)'gamma1= ',real(gamma1), ' ,dt= ',real(dt),' ,hdif_max= ',real(hdif_max)
!'
      write(13,*)ne,np
      do i=1,np
        write(13,*)i,real(x(i)),real(y(i)),real(hdif(i))
      enddo !i
      do i=1,ne
        write(13,*) i,i34(i),elnode(1:i34(i),i)
      enddo !i

      print*, 'Min. diffusivity/viscosity= ',minval(hdif(1:np))

      stop
      end

      function signa(x1,x2,x3,y1,y2,y3)
!...  Compute signed area formed by pts 1,2,3
      implicit real*8(a-h,o-z)

      signa=((x1-x3)*(y2-y3)-(x2-x3)*(y1-y3))/2

      return
      end


!*==dlagv2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A,B) where B is upper triangular.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLAGV2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
!                          CSR, SNR )
!
!       .. Scalar Arguments ..
!       INTEGER            LDA, LDB
!       DOUBLE PRECISION   CSL, CSR, SNL, SNR
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
!      $                   B( LDB, * ), BETA( 2 )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLAGV2 computes the Generalized Schur factorization of a real 2-by-2
!> matrix pencil (A,B) where B is upper triangular. This routine
!> computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
!> SNR such that
!>
!> 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
!>    types), then
!>
!>    [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
!>    [  0  a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
!>
!>    [ b11 b12 ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]
!>    [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ],
!>
!> 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
!>    then
!>
!>    [ a11 a12 ] := [  CSL  SNL ] [ a11 a12 ] [  CSR -SNR ]
!>    [ a21 a22 ]    [ -SNL  CSL ] [ a21 a22 ] [  SNR  CSR ]
!>
!>    [ b11  0  ] := [  CSL  SNL ] [ b11 b12 ] [  CSR -SNR ]
!>    [  0  b22 ]    [ -SNL  CSL ] [  0  b22 ] [  SNR  CSR ]
!>
!>    where b11 >= b22 > 0.
!>
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA, 2)
!>          On entry, the 2 x 2 matrix A.
!>          On exit, A is overwritten by the ``A-part'' of the
!>          generalized Schur form.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          THe leading dimension of the array A.  LDA >= 2.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is DOUBLE PRECISION array, dimension (LDB, 2)
!>          On entry, the upper triangular 2 x 2 matrix B.
!>          On exit, B is overwritten by the ``B-part'' of the
!>          generalized Schur form.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          THe leading dimension of the array B.  LDB >= 2.
!> \endverbatim
!>
!> \param[out] ALPHAR
!> \verbatim
!>          ALPHAR is DOUBLE PRECISION array, dimension (2)
!> \endverbatim
!>
!> \param[out] ALPHAI
!> \verbatim
!>          ALPHAI is DOUBLE PRECISION array, dimension (2)
!> \endverbatim
!>
!> \param[out] BETA
!> \verbatim
!>          BETA is DOUBLE PRECISION array, dimension (2)
!>          (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
!>          pencil (A,B), k=1,2, i = sqrt(-1).  Note that BETA(k) may
!>          be zero.
!> \endverbatim
!>
!> \param[out] CSL
!> \verbatim
!>          CSL is DOUBLE PRECISION
!>          The cosine of the left rotation matrix.
!> \endverbatim
!>
!> \param[out] SNL
!> \verbatim
!>          SNL is DOUBLE PRECISION
!>          The sine of the left rotation matrix.
!> \endverbatim
!>
!> \param[out] CSR
!> \verbatim
!>          CSR is DOUBLE PRECISION
!>          The cosine of the right rotation matrix.
!> \endverbatim
!>
!> \param[out] SNR
!> \verbatim
!>          SNR is DOUBLE PRECISION
!>          The sine of the right rotation matrix.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup doubleOTHERauxiliary
!
!> \par Contributors:
!  ==================
!>
!>     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
!
!  =====================================================================
      SUBROUTINE DLAGV2(A,Lda,B,Ldb,Alphar,Alphai,Beta,Csl,Snl,Csr,Snr)
      IMPLICIT NONE
!*--DLAGV2160
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Lda , Ldb
      DOUBLE PRECISION Csl , Csr , Snl , Snr
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , Alphai(2) , Alphar(2) , B(Ldb,*) ,    &
     &                 Beta(2)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0)
!     ..
!     .. Local Scalars ..
      DOUBLE PRECISION anorm , ascale , bnorm , bscale , h1 , h2 , h3 , &
     &                 qq , r , rr , safmin , scale1 , scale2 , t ,     &
     &                 ulp , wi , wr1 , wr2
!     ..
!     .. External Subroutines ..
      EXTERNAL DLAG2 , DLARTG , DLASV2 , DROT
!     ..
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH , DLAPY2
      EXTERNAL DLAMCH , DLAPY2
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , MAX
!     ..
!     .. Executable Statements ..
!
      safmin = DLAMCH('S')
      ulp = DLAMCH('P')
!
!     Scale A
!
      anorm = MAX(ABS(A(1,1))+ABS(A(2,1)),ABS(A(1,2))+ABS(A(2,2)),      &
     &        safmin)
      ascale = ONE/anorm
      A(1,1) = ascale*A(1,1)
      A(1,2) = ascale*A(1,2)
      A(2,1) = ascale*A(2,1)
      A(2,2) = ascale*A(2,2)
!
!     Scale B
!
      bnorm = MAX(ABS(B(1,1)),ABS(B(1,2))+ABS(B(2,2)),safmin)
      bscale = ONE/bnorm
      B(1,1) = bscale*B(1,1)
      B(1,2) = bscale*B(1,2)
      B(2,2) = bscale*B(2,2)
!
!     Check if A can be deflated
!
      IF ( ABS(A(2,1))<=ulp ) THEN
         Csl = ONE
         Snl = ZERO
         Csr = ONE
         Snr = ZERO
         A(2,1) = ZERO
         B(2,1) = ZERO
         wi = ZERO
!
!     Check if B is singular
!
      ELSEIF ( ABS(B(1,1))<=ulp ) THEN
         CALL DLARTG(A(1,1),A(2,1),Csl,Snl,r)
         Csr = ONE
         Snr = ZERO
         CALL DROT(2,A(1,1),Lda,A(2,1),Lda,Csl,Snl)
         CALL DROT(2,B(1,1),Ldb,B(2,1),Ldb,Csl,Snl)
         A(2,1) = ZERO
         B(1,1) = ZERO
         B(2,1) = ZERO
         wi = ZERO
!
      ELSEIF ( ABS(B(2,2))<=ulp ) THEN
         CALL DLARTG(A(2,2),A(2,1),Csr,Snr,t)
         Snr = -Snr
         CALL DROT(2,A(1,1),1,A(1,2),1,Csr,Snr)
         CALL DROT(2,B(1,1),1,B(1,2),1,Csr,Snr)
         Csl = ONE
         Snl = ZERO
         A(2,1) = ZERO
         B(2,1) = ZERO
         B(2,2) = ZERO
         wi = ZERO
!
      ELSE
!
!        B is nonsingular, first compute the eigenvalues of (A,B)
!
         CALL DLAG2(A,Lda,B,Ldb,safmin,scale1,scale2,wr1,wr2,wi)
!
         IF ( wi==ZERO ) THEN
!
!           two real eigenvalues, compute s*A-w*B
!
            h1 = scale1*A(1,1) - wr1*B(1,1)
            h2 = scale1*A(1,2) - wr1*B(1,2)
            h3 = scale1*A(2,2) - wr1*B(2,2)
!
            rr = DLAPY2(h1,h2)
            qq = DLAPY2(scale1*A(2,1),h3)
!
            IF ( rr>qq ) THEN
!
!              find right rotation matrix to zero 1,1 element of
!              (sA - wB)
!
               CALL DLARTG(h2,h1,Csr,Snr,t)
!
            ELSE
!
!              find right rotation matrix to zero 2,1 element of
!              (sA - wB)
!
               CALL DLARTG(h3,scale1*A(2,1),Csr,Snr,t)
!
            ENDIF
!
            Snr = -Snr
            CALL DROT(2,A(1,1),1,A(1,2),1,Csr,Snr)
            CALL DROT(2,B(1,1),1,B(1,2),1,Csr,Snr)
!
!           compute inf norms of A and B
!
            h1 = MAX(ABS(A(1,1))+ABS(A(1,2)),ABS(A(2,1))+ABS(A(2,2)))
            h2 = MAX(ABS(B(1,1))+ABS(B(1,2)),ABS(B(2,1))+ABS(B(2,2)))
!
            IF ( (scale1*h1)>=ABS(wr1)*h2 ) THEN
!
!              find left rotation matrix Q to zero out B(2,1)
!
               CALL DLARTG(B(1,1),B(2,1),Csl,Snl,r)
!
            ELSE
!
!              find left rotation matrix Q to zero out A(2,1)
!
               CALL DLARTG(A(1,1),A(2,1),Csl,Snl,r)
!
            ENDIF
!
            CALL DROT(2,A(1,1),Lda,A(2,1),Lda,Csl,Snl)
            CALL DROT(2,B(1,1),Ldb,B(2,1),Ldb,Csl,Snl)
!
            A(2,1) = ZERO
            B(2,1) = ZERO
!
         ELSE
!
!           a pair of complex conjugate eigenvalues
!           first compute the SVD of the matrix B
!
            CALL DLASV2(B(1,1),B(1,2),B(2,2),r,t,Snr,Csr,Snl,Csl)
!
!           Form (A,B) := Q(A,B)Z**T where Q is left rotation matrix and
!           Z is right rotation matrix computed from DLASV2
!
            CALL DROT(2,A(1,1),Lda,A(2,1),Lda,Csl,Snl)
            CALL DROT(2,B(1,1),Ldb,B(2,1),Ldb,Csl,Snl)
            CALL DROT(2,A(1,1),1,A(1,2),1,Csr,Snr)
            CALL DROT(2,B(1,1),1,B(1,2),1,Csr,Snr)
!
            B(2,1) = ZERO
            B(1,2) = ZERO
!
         ENDIF
!
      ENDIF
!
!     Unscaling
!
      A(1,1) = anorm*A(1,1)
      A(2,1) = anorm*A(2,1)
      A(1,2) = anorm*A(1,2)
      A(2,2) = anorm*A(2,2)
      B(1,1) = bnorm*B(1,1)
      B(2,1) = bnorm*B(2,1)
      B(1,2) = bnorm*B(1,2)
      B(2,2) = bnorm*B(2,2)
!
      IF ( wi==ZERO ) THEN
         Alphar(1) = A(1,1)
         Alphar(2) = A(2,2)
         Alphai(1) = ZERO
         Alphai(2) = ZERO
         Beta(1) = B(1,1)
         Beta(2) = B(2,2)
      ELSE
         Alphar(1) = anorm*wr1/scale1/bnorm
         Alphai(1) = anorm*wi/scale1/bnorm
         Alphar(2) = Alphar(1)
         Alphai(2) = -Alphai(1)
         Beta(1) = ONE
         Beta(2) = ONE
      ENDIF
!
!
!     End of DLAGV2
!
      END SUBROUTINE DLAGV2


      subroutine global_local(i,xg,yg,zg,xl,yl,zl)
c s kelkar March 24, 06
c map from global coordinates to local coordinates, origin at
c corn(i,1:3) and scale axis by ddx(i),ddy(i), ddz(i) where
c i is a node# in the coarse grid, corn gives the lower, left, back
c corner of the brick shaped control volume ofi, and dx,dy,dz
c are the x,y,z cell sizes.
c********************************************************************
c INPUT VARIABLES
c
c OUTOUT VARIABLES
c
c INTERNAL VARIABLES
c********************************************************************
c INPUT
c     i   : node id in the coarse grid
c     xg,yg,zg:  coordinates in the global system
c     corn(i,1:3): coordinates in the global system
c                  of the corner to be used as the origin
c     dx(i),dy(i),dz(i): cell sizes in the global system
c OUTOUT
c     xl,yl,zl: node coordinates in the local system

      use comparttr_sg
      use comunits

      implicit none

      integer i

      real*8 xg,yg,zg,xl,yl,zl,dx,dy,dz

      dx=dxyz(i,1)
      dy=dxyz(i,2)
      dz=dxyz(i,3)

      if(dx*dy*dz.eq.0.) then
         write(error_unit_number,*)' zero cell size in global_local',
     1        'for cell# ',i
         write(error_unit_number,*)'STOP'
         stop
      else
         xl=(xg-corn(i,1))/dx
         yl=(yg-corn(i,2))/dy
         zl=(zg-corn(i,3))/dz
      endif

      return

      end

c........................................................................


PROGRAM hello

  USE mpi

  INTEGER, PARAMETER:: dp=KIND(0.d0)

  INTEGER ::  ierr, comm_size, comm_rank, length
  REAL(dp) :: RESULT
  CHARACTER (len=MPI_MAX_PROCESSOR_NAME) :: proc_name

  CALL MPI_Init(ierr)
  CALL MPI_Comm_size(MPI_COMM_WORLD, comm_size, ierr)
  CALL MPI_Comm_rank(MPI_COMM_WORLD, comm_rank, ierr)
  CALL MPI_Get_processor_name(proc_name, length, ierr)

  WRITE(*,*) "Hello World from process = ", comm_rank, " on processor ", proc_name

  RESULT = EXP(REAL(comm_rank, dp))

  WRITE(*,*) "Exp(", comm_rank, ") = ", RESULT

  CALL MPI_Barrier(MPI_COMM_WORLD, ierr);
  IF (comm_rank == 0) THEN
     WRITE(*,*) "Number of mpi processes = ", comm_size
  ENDIF
  CALL MPI_Finalize(ierr);

END PROGRAM hello


subroutine holoPy(x)
    implicit none
    real, parameter :: pi=3.141592653589793238460
      complex, dimension(:) :: x
      call fft(x)

end

recursive subroutine fft(x,y)
    !integer,       parameter :: dp=selected_real_kind(15,300)

    complex, dimension(:), intent(in)   :: x
    complex, dimension(:), optional, intent(out)  :: y
    complex                               :: t
    integer                                        :: N
    integer                                        :: i
    complex, dimension(:), allocatable    :: even, odd

    N=size(x)

    !if(N .le. 1) return

    allocate(odd((N+1)/2))
    allocate(even(N/2))

    ! divide
    odd =x(1:N:2)
    even=x(2:N:2)
    print*,odd,even

    ! conquer
    call fft(odd)
    call fft(even)
!
!    ! combine
!    do i=1,N/2
!
!
!    t=exp(cmplx(0.0_dp,-2.0_dp*pi*real(i-1,dp)/real(N,dp),KIND=DP))*even(i)
!    x(i)     = odd(i) + t
!    x(i+N/2) = odd(i) - t
!    end do
!
!    deallocate(odd)
!    deallocate(even)
    end subroutine fft


program cfd
! Run the 2d cfd simulation

use parameters
use diff
use save
use actuator
use boundary
implicit none

integer,parameter :: seed = 86456
integer :: ix, iy, it, ii

! gamma: how much upwinding will we use?
! pow:   temporary variable for power
! powtotal: a aggregator for power
real :: gamma, pow, powtotal

! u,v:     velocities
! ua,va:   velocity averages (temp)
! ud,vd:   velocity derivatives (temp)
! uvx, uvy,u2x,u2y: variables for the advective term in the NS equation
! p:       pressure
! rhs:     rhs for the pressure solver
real, allocatable,dimension(:,:) :: u,v,p,ua,va,ud,vd,uvx,uvy,u2x,v2y,rhs

call save_parameters()

allocate( u(nnx,nny), &
          v(nnx,nny), &
          p(nnx,nny), &
          ua(nnx,nny), &
          va(nnx,nny), &
          ud(nnx,nny), &
          vd(nnx,nny), &
          uvx(nnx,nny), &
          uvy(nnx,nny), &
          u2x(nnx,nny), &
          v2y(nnx,nny), &
          rhs(nnx,nny) &
)

! create random initial pertubation
call srand(seed)
do ix=1,nnx
    do iy=1,nny
        p(ix,iy) = rand()/1000.0
    end do
end do

! seed u and v off this initial pertubation
u = p
v = p
call ddy(u,1.0)
call ddx(v,1.0)
u = u + uvel
p = p*0.0
powtotal = 0
call initialize_actuator()

time_step: do it=1,nts

    call apply_boundary(u,v,1,it)

    !! Calculate the uvx and uvy with upwinding
    gamma = min(1.2*dt*max(maxval(abs(u))/hx,maxval(abs(v))/hy),1.0);
    ua = u; call yavg(ua); ua = cshift(ua,shift=-1,dim=2);
    ud = u; call ddy(ud,2.0); ud = cshift(ud,shift=-1,dim=2);
    va = v; call xavg(va); va = cshift(va,shift=-1,dim=1);
    vd = v; call ddx(vd,2.0); vd = cshift(vd,shift=-1,dim=1);

    uvx = (ua * va) - (gamma * abs(ua) * vd)
    call ddx(uvx,hx);

    uvy = (ua * va) - (gamma * abs(va) * ud)
    call ddy(uvy,hy);

    !! Calculate the u2x and v2y terms
    ua = u; call xavg(ua);
    ud = u; call ddx(ud,2.0);
    va = v; call yavg(va);
    vd = v; call ddy(vd,2.0);

    u2x = ua*ua - gamma*abs(ua)*ud
    call ddx(u2x,hx); u2x = cshift(u2x,shift=-1,dim=1)

    v2y = va*va - gamma*abs(va)*vd
    call ddy(v2y,hy); v2y = cshift(v2y,shift=-1,dim=2)

    !! update the u and v variables
    u = u - dt*(uvy+u2x)
    v = v - dt*(uvx+v2y)

    !! Iteratively solve for pressure
    call apply_boundary(u,v,1,it)

    ud = u; call ddx(ud,hx)
    vd = v; call ddy(vd,hy)
    rhs = ud + vd
    iterate_pressure: do ii=1,niter
        p = 0.25*(myiter(p,hm) - hx*hy*rhs)
    end do iterate_pressure
    ud = cshift(p,shift=-1,dim=1); call ddx(ud,hx)
    vd = cshift(p,shift=-1,dim=2); call ddy(vd,hy)
    u = u - ud
    v = v - vd

    !! Apply actuator force
    call update_actuator(u)
    call apply_actuator(u,dt,hx,pow)

    !! driving pressure gradient
    u = u + dt*dpg
    powtotal = powtotal + pow*dt

    !! Save the information if requested
    if (mod(it,write_freq) == 0) then
        call save_vel(it,u,v)
        call save_pow(it,pow)
    end if

end do time_step

print *, 'Total Power Produced: ', powtotal

end program


      subroutine stVenantKirchhoff_elasticity(matData,F,stre,cc,finite)

      implicit none

      integer          finite,
     *                 i, round
      double precision matData(*), F(3,*), stre(*), cc(6,*),
     *                 mu, K, Lamb, b(6), fact,
     *                 det_u, r1dJ, J

      if (finite.eq.0) then
        call small_strain_elasticity(matData,F,stre,cc)
        return
      endif

      K    = matData(1)
      mu   = matData(2)
      Lamb = K - (mu + mu) / 3.d0

      call calcB(b,F)

      J    = det_u(F)
      r1dJ = 1.d0 / J

      fact = r1dJ * (Lamb * 0.5d0 * (b(1)+b(2)+b(3)-3.d0) - mu)

      call set_s_f(stre,b,fact)

      fact = r1dJ * mu

      call mult_s_ss_af(stre,b,b,fact)

      fact = r1dJ * Lamb

      call mult_4_ss_f(cc,b,b,fact)

      fact = r1dJ * (mu + mu)

      cc(1,1) = cc(1,1) + fact * b(1)*b(1)
      cc(1,2) = cc(1,2) + fact * b(4)*b(4)
      cc(1,3) = cc(1,3) + fact * b(6)*b(6)
      cc(2,1) = cc(1,2)
      cc(2,2) = cc(2,2) + fact * b(2)*b(2)
      cc(2,3) = cc(2,3) + fact * b(5)*b(5)
      cc(3,1) = cc(1,3)
      cc(3,2) = cc(2,3)
      cc(3,3) = cc(3,3) + fact * b(3)*b(3)

      cc(1,4) = cc(1,4) + fact * b(1)*b(4)
      cc(1,5) = cc(1,5) + fact * b(4)*b(6)
      cc(1,6) = cc(1,6) + fact * b(1)*b(6)
      cc(2,4) = cc(2,4) + fact * b(2)*b(4)
      cc(2,5) = cc(2,5) + fact * b(2)*b(5)
      cc(2,6) = cc(2,6) + fact * b(4)*b(5)
      cc(3,4) = cc(3,4) + fact * b(5)*b(6)
      cc(3,5) = cc(3,5) + fact * b(3)*b(5)
      cc(3,6) = cc(3,6) + fact * b(3)*b(6)

      cc(4,1) = cc(1,4)
      cc(5,1) = cc(1,5)
      cc(6,1) = cc(1,6)
      cc(4,2) = cc(2,4)
      cc(5,2) = cc(2,5)
      cc(6,2) = cc(2,6)
      cc(4,3) = cc(3,4)
      cc(5,3) = cc(3,5)
      cc(6,3) = cc(3,6)

      fact = fact * 0.5d0

      cc(4,4) = cc(4,4) + fact * (b(1)*b(2) + b(4)*b(4))
      cc(4,5) = cc(4,5) + fact * (b(2)*b(6) + b(4)*b(5))
      cc(4,6) = cc(4,6) + fact * (b(1)*b(5) + b(4)*b(6))
      cc(5,4) = cc(4,5)
      cc(5,5) = cc(5,5) + fact * (b(2)*b(3) + b(5)*b(5))
      cc(5,6) = cc(5,6) + fact * (b(3)*b(4) + b(5)*b(6))
      cc(6,4) = cc(4,6)
      cc(6,5) = cc(5,6)
      cc(6,6) = cc(6,6) + fact * (b(1)*b(3) + b(6)*b(6))

      return

      end


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZARNAR (Zomplex Auxiliary Routine Normalized ARgument)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine sorts the eigenvalues and optionally eigenvectors of a
! unitary matrix. The eigenpairs are sorted in ascending order of the
! argument of the eigenvalue.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  A,B            REAL(8)
!                    real and imaginary part of complex number
!
! OUTPUT VARIABLES:
!
!  ARG            REAL(8)
!                    arg of A + Bi in the interval [0,2pi)
!
!  INFO           INTEGER
!                    INFO = 0 implies successful computation
!                    INFO = -1 implies A is invalid
!                    INFO = -2 implies B is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZARNAR(A,B,ARG,INFO)

  ! input variables
  real(8), intent(in) :: A, B
  real(8), intent(inout) :: ARG
  integer, intent(inout) :: INFO

  ! compute variables
  real(8), parameter :: PI = 3.14159265358979323846264338327950d0

  ! initialize INFO
  INFO = 0

  ! check error in debug mode
  if (DEBUG) then

    ! check A
    call DARNAN(A,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"A is invalid",INFO,-1)
      return
    end if
    call DARINF(A,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"A is invalid",INFO,-1)
      return
    end if

    ! check B
    call DARNAN(B,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"B is invalid",INFO,-2)
      return
    end if
    call DARINF(B,INFO)
    if (INFO.NE.0) then
      call UARERR(__FILE__,__LINE__,"B is invalid",INFO,-2)
      return
    end if

  end if

  ! compute arg 1
  if ((abs(A).EQ.0d0).AND.(abs(B).EQ.0d0)) then
    ARG = 0d0

  ! abs(A) > abs(B)
  else if (abs(A) > abs(B)) then

    ! compute ARG between [-pi/2,pi/2]
    ARG = atan(abs(B/A))

  ! abs(A) < abs(B)
  else

    ! compute ARG between [-pi/2,pi/2]
    ARG = atan(abs(A/B))
    ARG = PI/2d0 - ARG

  end if

  ! correct for [0,2pi)
  ! second quadrant
  if ((B >= 0).AND.(A < 0)) then
    ARG = PI-ARG

  ! third quadrant
  else if ((B < 0).AND.(A < 0)) then
    ARG = PI+ARG

  ! fourth quadrant
  else if ((B < 0).AND.(A > 0)) then
    ARG = 2d0*PI-ARG
  end if

end subroutine ZARNAR


MODULE GravitySolutionModule_Newtonian_PointMass_Old

  USE KindModule, ONLY: &
    DP
  USE UnitsModule, ONLY: &
    GravitationalConstant, &
    UnitsDisplay
  USE ProgramHeaderModule, ONLY: &
    nX, nNodesX
  USE UtilitiesModule, ONLY: &
    NodeNumberX
  USE MeshModule, ONLY: &
    MeshX, &
    NodeCoordinate
  USE GeometryFieldsModule, ONLY: &
    uGF, iGF_Phi_N

  IMPLICIT NONE
  PRIVATE

  REAL(DP) :: PointMass

  PUBLIC :: InitializeGravitySolver_Newtonian_PointMass
  PUBLIC :: FinalizeGravitySolver_Newtonian_PointMass
  PUBLIC :: SolveGravity_Newtonian_PointMass

CONTAINS

  SUBROUTINE InitializeGravitySolver_Newtonian_PointMass &
               ( PointMass_Option )

    REAL(DP), INTENT(in), OPTIONAL :: PointMass_Option

    PointMass = 1.0_DP
    IF( PRESENT( PointMass_Option ) ) &
      PointMass = PointMass_Option

    WRITE(*,*)
    WRITE(*,'(A7,A12,ES10.4E2,A1,A)') &
      '', 'PointMass = ', PointMass / UnitsDisplay % MassUnit, &
      '', UnitsDisplay % MassLabel

  END SUBROUTINE InitializeGravitySolver_Newtonian_PointMass

  SUBROUTINE FinalizeGravitySolver_Newtonian_PointMass

    PointMass = 1.0_DP

  END SUBROUTINE FinalizeGravitySolver_Newtonian_PointMass

  SUBROUTINE SolveGravity_Newtonian_PointMass

    INTEGER  :: iX1, iX2, iX3
    INTEGER  :: iNodeX1, iNodeX2, iNodeX3, iNode
    REAL(DP) :: X1

    DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)
        DO iX1 = 1, nX(1)

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

                X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )

                iNode = NodeNumberX( iNodeX1, iNodeX2, iNodeX3 )

                uGF(iNode,iX1,iX2,iX3,iGF_Phi_N) &
                  = - GravitationalConstant * PointMass / X1

              END DO
            END DO
          END DO

        END DO
      END DO
    END DO

    CALL SetBoundaryConditions

  END SUBROUTINE SolveGravity_Newtonian_PointMass

  SUBROUTINE SetBoundaryConditions

    CALL SetBoundaryConditions_X1

  END SUBROUTINE SetBoundaryConditions

  SUBROUTINE SetBoundaryConditions_X1

    INTEGER  :: iX2, iX3
    INTEGER  :: iNodeX1, iNodeX2, iNodeX3, iNodeX
    REAL(DP) :: X1

    DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)

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

              iNodeX = NodeNumberX( iNodeX1, iNodeX2, iNodeX3 )

              ! --- Inner Boundary: Dirichlet ---

              X1 = NodeCoordinate( MeshX(1), 0, iNodeX1 )

              uGF(iNodeX,0,iX2,iX3,iGF_Phi_N) &
                = - PointMass / X1

              ! --- Outer Boundary: Dirichlet ---

              X1 = NodeCoordinate( MeshX(1), nX(1)+1, iNodeX1 )

              uGF(iNodeX,nX(1)+1,iX2,iX3,iGF_Phi_N) &
                = - PointMass / X1

            END DO
          END DO
        END DO

      END DO
    END DO

  END SUBROUTINE SetBoundaryConditions_X1

END MODULE GravitySolutionModule_Newtonian_PointMass_Old


      subroutine intrsc(x1,y1,x2,y2,x3,y3,x4,y4,x0,y0)
      a1=y2-y1
      b1=x1-x2
      a2=y4-y3
      b2=x3-x4
C
      d=a1*b2-a2*b1
C.....test: are the lines collinear to each other  ?
      if(abs(d).le.1.e- 8) goto 1
      c1=x2*y1-x1*y2
      c2=x4*y3-x3*y4
C.....compute the intersection point "x0,y0".
      x0=(c2*b1-b2*c1)/d
      y0=(c1*a2-c2*a1)/d
C.....test: does the point "x0,y0" belong to both line segments ?
      if(x0.lt.amax1(amin1(x1,x2),amin1(x3,x4))) goto 1
      if(x0.gt.amin1(amax1(x1,x2),amax1(x3,x4))) goto 1
      if(y0.lt.amax1(amin1(y1,y2),amin1(y3,y4))) goto 1
      if(y0.gt.amin1(amax1(y1,y2),amax1(y3,y4))) goto 1
      return
1     continue
C....in unnormal situation: a half of the element of the "screen".
      x0=0.5*(x3+x4)
      y0=0.5*(y3+y4)
      return
      end


program gen_table
implicit none
!real,parameter :: delr=0.002,rcut=1.0
DOUBLE PRECISION, parameter :: delr=0.0005D0, rcut=3.0D0
DOUBLE PRECISION :: r
integer :: nbins,j

nbins=int( (rcut+1)/delr) + 1
open(unit=6,file='table_A_B.xvg')

do j=0,nbins
    r=delr*j

    ! for table_A_A
    IF (r < 0.96D0) THEN
        write(6,*) r*1.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 10**5, 10**5
    else if (r <= 1.57D0) then
        !write(6,*) r*1.0D0, 0.0D0, 0.0D0, (-4.0D0)/(r**6), (-24.0D0)/(r**7), &
        !        4.0D0/(r**12)-(4.0D0/(1.57D0**12)-4.0D0/(1.57D0**6)), 48.0D0/(r**13)  ! A-A or B-B
        write(6,*) r*1.0D0, 0.0D0, 0.0D0, (-4.0D0)/((r/1.03D0)**6), (-24.0D0)/((r/1.03D0)**7), &
                4.0D0/((r/1.03D0)**12)-(4.0D0/((1.57D0/1.03D0)**12)-4.0D0/((1.57D0/1.03D0)**6)),&
                48.0D0/((r/1.03D0)**13)   ! A-B
    ELSE
        write(6,*) r*1.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0
    ENDIF

end do

close(6)

End program


      SUBROUTINE SGESV_F95( A, B, IPIV, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!     .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE LA_AUXMOD, ONLY: ERINFO
      USE F77_LAPACK, ONLY: GESV_F77 => LA_GESV
!     .. "Implicit Statement" ..
      IMPLICIT NONE
!     .. "Scalar Arguments" ..
      INTEGER, INTENT(OUT), OPTIONAL :: INFO
!     .. "Array Arguments" ..
      INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:)
      REAL(WP), INTENT(INOUT) :: A(:,:), B(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_GESV computes the solution to a real or complex linear system of
! equations A*X = B, where A is a square matrix and X and B are
! rectangular matrices or vectors. Gaussian elimination with row
! interchanges is used to factor A as A = P*L*U , where P is a permutation
! matrix, L is unit lower triangular, and U is upper triangular. The
! factored form of A is then used to solve the above system.
!
! =========
!
!       SUBROUTINE LA_GESV( A, B, IPIV=ipiv, INFO=info )
!          <type>(<wp>), INTENT(INOUT) :: A(:,:), <rhs>
!          INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:)
!          INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!          <type> ::= REAL | COMPLEX
!          <wp>   ::= KIND(1.0) | KIND(1.0D0)
!          <rhs>  ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! A      (input/output) REAL or COMPLEX square array, shape (:,:).
!        On entry, the matrix A.
!        On exit, the factors L and U from the factorization A = P*L*U;
!        the unit diagonal elements of L are not stored.
! B      (input/output) REAL or COMPLEX array, shape (:,:) with
!        size(B,1) = size(A,1) or shape (:) with size(B) = size(A,1).
!        On entry, the matrix B.
!        On exit, the solution matrix X .
! IPIV   Optional (output) INTEGER array, shape (:) with size(IPIV) =
!        size(A,1).
!        The pivot indices that define the permutation matrix P; row i of
!        the matrix was interchanged with row IPIV(i).
! INFO   Optional (output) INTEGER
!        = 0 : successful exit.
!        < 0 : if INFO = -i, the i-th argument has an illegal value.
!        > 0 : if INFO = i, then U(i,i) = 0. The factorization has been
!        completed, but the factor U is singular, so the solution could
!        not be computed.
!        If INFO is not present and an error occurs, then the program is
!        terminated with an error message.
!----------------------------------------------------------------------
!     .. "Parameters" ..
      CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GESV'
!     .. LOCAL SCALARS ..
      INTEGER :: LINFO, ISTAT, ISTAT1, SIPIV
!     .. "Local Pointers" ..
      INTEGER, POINTER :: LPIV(:)
!     .. "Intrinsic Functions" ..
      INTRINSIC SIZE, PRESENT, MAX
!     .. "Executable Statements" ..
      LINFO = 0; ISTAT = 0
      IF( PRESENT(IPIV) )THEN
         SIPIV = SIZE(IPIV)
      ELSE
         SIPIV = SIZE(A,1)
      END IF
!     .. "Test the arguments" ..
      IF( SIZE( A, 2 ) /= SIZE(A,1) .OR. SIZE(A,1) < 0 ) THEN
         LINFO = -1
      ELSE IF( SIZE( B, 1 ) /= SIZE(A,1) .OR. SIZE(B,2) < 0 ) THEN
         LINFO = -2
      ELSE IF( SIPIV /= SIZE(A,1) )THEN
            LINFO = -3
      ELSE IF ( SIZE(A,1) > 0 ) THEN
         IF( PRESENT(IPIV) )THEN
            LPIV => IPIV
         ELSE
            ALLOCATE( LPIV(SIZE(A,1)), STAT = ISTAT )
         END IF
         IF ( ISTAT == 0 ) THEN
!        .. "Call LAPACK77 routine" ..
            CALL GESV_F77( SIZE(A,1), SIZE(B,2), A, MAX(1,SIZE(A,1)), LPIV, B, MAX(1,SIZE(A,1)), &
                           LINFO )
         ELSE
            LINFO = -100
         END IF
         IF( .NOT.PRESENT(IPIV) )THEN
            DEALLOCATE(LPIV, STAT = ISTAT1 )
         END IF
      END IF
      CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
      END SUBROUTINE SGESV_F95


!==========================================
! rng.f90
! Author: Devansh Shukla
!------------------------------------------
program rng_generator
    implicit none
    ! Define the variables
    integer :: A=0, C=0, M=0, x_0=0, x_1=0, i=0, n=10
    character(len=*), parameter :: fmt="(xI2,I6,I6)"
    ! Open data file
    open(unit=8, file="random_no.dat")
    ! Get input from user
    print *, "Enter A, C, M, x0"
    read *, A, C, M, x_0
    print *, "Enter no of random numbers(n)"
    read *, n
    print *, "-----------------"

    print "(xA2x, A6, xxA6)", "i", "I(i)", "I(i+1)"
    ! Compute
    do i = 0, n, 1
        ! Compute the pseudorandom number according to the
        ! given formula
        x_1 = mod(A*x_0 + C, M)
        write (*, fmt) i, x_0, x_1
        ! Writing the computed parameters to the data file
        write (8, fmt) i, x_0, x_1
        x_0 = x_1
    end do
    print *, "-----------------"
    ! Close file
    close(8)

end program rng_generator


SUBROUTINE stability(kv,gv,kdiag,tol,limit,iters,evec,eval)
!
! This subroutine computes the smallest eigenvalue in a beam
! stability analysis.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(IN)::limit,kdiag(:)
 INTEGER,INTENT(OUT)::iters
 INTEGER::neq
 REAL(iwp),INTENT(IN OUT)::kv(:),gv(:),tol,eval
 REAL(iwp),INTENT(OUT)::evec(:)
 REAL(iwp)::big,zero=0.0_iwp,one=1.0_iwp
 LOGICAL::converged
 REAL(iwp),ALLOCATABLE::x0(:),x1(:)
 neq=UBOUND(kdiag,1)
 ALLOCATE(x0(0:neq),x1(0:neq))
 CALL sparin(kv,kdiag)
 iters=0
 x0=zero
 x0(1)=1.0_iwp
 DO
   iters=iters+1
   CALL linmul_sky(gv,x0,x1,kdiag)
   CALL spabac(kv,x1,kdiag)
   big=MAXVAL(x1(1:))
   IF(ABS(MINVAL(x1(1:)))>big)big=MINVAL(x1(1:))
   x1=x1/big
   converged=(MAXVAL(ABS(x1(1:)-x0(1:)))/MAXVAL(ABS(x1(1:)))<tol)
   x0=x1
   IF(converged.OR.iters==limit)EXIT
 END DO
 x1(1:)=x1(1:)/SQRT(SUM(x1(1:)**2))
 evec=x1
 eval=one/big
RETURN
CONTAINS
SUBROUTINE sparin(kv,kdiag)
!
! This subroutine performs Cholesky factorisation on a symmetric
! skyline global matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::kv(:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,ki,l,kj,j,ll,m,k
 REAL(iwp)::x
 n=UBOUND(kdiag,1)
 kv(1)=SQRT(kv(1))
 DO i=2,n
   ki=kdiag(i)-i
   l=kdiag(i-1)-ki+1
   DO j=l,i
     x=kv(ki+j)
     kj=kdiag(j)-j
     IF(j/=1)THEN
       ll=kdiag(j-1)-kj+1
       ll=max(l,ll)
       IF(ll/=j)THEN
         m=j-1
         DO k=ll,m
           x=x-kv(ki+k)*kv(kj+k)
         END DO
       END IF
     END IF
     kv(ki+j)=x/kv(kj+j)
   END DO
   kv(ki+i)=SQRT(x)
 END DO
RETURN
END SUBROUTINE sparin
SUBROUTINE spabac(kv,loads,kdiag)
!
! This subroutine performs Cholesky forward and back-substitution
! on a symmetric skyline global matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:)
 REAL(iwp),INTENT(IN OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,ki,l,m,j,it,k
 REAL(iwp)::x
 n=UBOUND(kdiag,1)
 loads(1)=loads(1)/kv(1)
 DO i=2,n
   ki=kdiag(i)-i
   l=kdiag(i-1)-ki+1
   x=loads(i)
   IF(l/=i)THEN
     m=i-1
     DO j=l,m
       x=x-kv(ki+j)*loads(j)
     END DO
   END IF
   loads(i)=x/kv(ki+i)
 END DO
 DO it=2,n
   i=n+2-it
   ki=kdiag(i)-i
   x=loads(i)/kv(ki+i)
   loads(i)=x
   l=kdiag(i-1)-ki+1
   IF(l/=i)THEN
     m=i-1
     DO k=l,m
       loads(k)=loads(k)-x*kv(ki+k)
     END DO
   END IF
 END DO
 loads(1)=loads(1)/kv(1)
RETURN
END SUBROUTINE spabac
SUBROUTINE linmul_sky(kv,disps,loads,kdiag)
!
! This subroutine forms the product of symmetric matrix stored as
! a skyline and a vector.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kv(:),disps(0:)
 REAL(iwp),INTENT(OUT)::loads(0:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,j,low,lup,k
 REAL(iwp)::x,zero=0.0_iwp
 n=UBOUND(disps,1)
 DO i=1,n
   x=zero
   lup=kdiag(i)
   IF(i==1)low=lup
   IF(i/=1)low=kdiag(i-1)+1
   DO j=low,lup
     x=x+kv(j)*disps(i+j-lup)
   END DO
   loads(i)=x
   IF(i==1)CYCLE
   lup=lup-1
   DO j=low,lup
     k=i+j-lup-1
     loads(k)=loads(k)+kv(j)*disps(i)
   END DO
 END DO
RETURN
END SUBROUTINE linmul_sky
END SUBROUTINE stability


! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
! HOHQMesh contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
!    https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
! * `fmin`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `spline`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `seval`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
!
! --- End License
!
!////////////////////////////////////////////////////////////////////////
!
!      Interpolation.F95
!      Created: 2009-12-15 15:36:24 -0500
!      By: David Kopriva
!
!
!      Contains:
!
!               SUBROUTINE InterpolatingPolynomialVector( x, N, nodes, weights, p )
!               REAL(KIND=RP) FUNCTION EvaluateLagrangePolyDerivative( j, x, N, nodes)
!
!               ALGORITHM 30: SUBROUTINE BarycentricWeights( N, x, w )
!               ALGORITHM 31: REAL(KIND=RP) FUNCTION LagrangeInterpolation( x, N, nodes, values, weights)
!               ALGORITHM 32: SUBROUTINE PolynomialInterpolationMatrix( N, M, oldNodes, weights, newNodes, T)
!               ALGORITHM 33: SUBROUTINE InterpolateToNewPoints( N, M, T, f, fInterp )
!               ALGORITHM 34: REAL(KIND=RP) FUNCTION LagrangeInterpolatingPolynomial( j, x, N, nodes )
!               ALGORITHM 35:
!
!
!////////////////////////////////////////////////////////////////////////
!
!
!  ******
   MODULE PolynomialInterpolationModule
!  ******
!
     USE SMConstants
     IMPLICIT NONE

     INTEGER, PARAMETER :: MXV_DIRECT = 1, MXV_TRANSPOSE = 2
!
!    ========
     CONTAINS
!    ========
!
!    /////////////////////////////////////////////////////////////////
!
      REAL(KIND=RP) FUNCTION LagrangeInterpolatingPolynomial( j, x, N, nodes ) RESULT(p)
!
!---------------------------------------------------------------------
! Compute L_j(x) of degree N whose zeros are at the nodes using direct
! evaluation.
!---------------------------------------------------------------------
!
      INTEGER                      , INTENT(IN) :: j     !! Which polynomial
      INTEGER                      , INTENT(IN) :: N     !! Polynomial order
      REAL(KIND=RP)                , INTENT(IN) :: x     !! evaluation point
      REAL(KIND=RP), DIMENSION(0:N), INTENT(IN) :: nodes !! Interpolation nodes
!
!     ---------------
!     Local Variables
!     ---------------
!
      INTEGER :: k

      IF ( j == 0 )     THEN
         p = (x - nodes(1))/(nodes(j) - nodes(1))
         DO k = 2, N
            p = p*(x - nodes(k))/(nodes(j) - nodes(k))
         END DO
      ELSE
         p = (x - nodes(0))/(nodes(j) - nodes(0))
         DO k = 1, j-1
            p = p*(x - nodes(k))/(nodes(j) - nodes(k))
         END DO
         DO k = j+1, N
            p = p*(x - nodes(k))/(nodes(j) - nodes(k))
         END DO
      END IF
   END FUNCTION LagrangeInterpolatingPolynomial
!
!    /////////////////////////////////////////////////////////////////
!
      SUBROUTINE InterpolatingPolynomialVector( x, N, nodes, weights, p )
!
!---------------------------------------------------------------------
! Compute L_j(x), j = 0, ..., N of degree N whose zeros are at the nodes
! using barycentric form.
!---------------------------------------------------------------------
!
      INTEGER                      , INTENT(IN)  :: N       !! Polynomial order
      REAL(KIND=RP)                , INTENT(IN)  :: x       !! evaluation point
      REAL(KIND=RP), DIMENSION(0:N), INTENT(IN)  :: nodes   !! Interpolation nodes
      REAL(KIND=RP), DIMENSION(0:N), INTENT(IN)  :: weights !! Barycentric weights
      REAL(KIND=RP), DIMENSION(0:N), INTENT(INOUT) :: p
!
!     ---------------
!     Local Variables
!     ---------------
!
      INTEGER       :: j
      LOGICAL       :: xMatchesNode
      REAL(KIND=RP) :: d, t
!
!     ---------
!     Externals
!     ---------
!
      LOGICAL, EXTERNAL :: AlmostEqual
!
!     -------------------------------------
!     See if the evaluation point is a node
!     -------------------------------------
!
      xMatchesNode = .false.
      DO j = 0, N
         p(j) = 0.0_RP
         IF( AlmostEqual( x, nodes(j) ) )     THEN
            p(j) = 1.0_RP
            xMatchesNode = .true.
         END IF
      END DO
      IF( xMatchesNode )     RETURN
!
!     ------------------------------
!     Evaluation point is not a node
!     ------------------------------
!
      d = 0.0_RP
      DO j = 0, N
         t = weights(j)/( x - nodes(j) )
         p(j) = t
         d = d + t
      END DO
      DO j = 0, N
         p(j) = p(j)/d
      END DO

   END SUBROUTINE InterpolatingPolynomialVector
!
! /////////////////////////////////////////////////////////////////////
!
!---------------------------------------------------------------------
!!    Compute at x the derivative of the lagrange polynomial L_j(x) of
!!    degree N whose zeros are given by the nodes(i)
!---------------------------------------------------------------------
!
      REAL(KIND=RP) FUNCTION EvaluateLagrangePolyDerivative( j, x, N, nodes)
!
!     ---------
!     Arguments
!     ---------
!
      INTEGER, INTENT(IN)                       :: j !! Which poly
      INTEGER, INTENT(IN)                       :: N !! Order
      REAL(KIND=RP), DIMENSION(0:N), INTENT(IN) :: nodes !! Nodes
      REAL(KIND=RP)                , INTENT(IN) :: x !! Eval Pt
!
!     ---------------
!     Local Variables
!     ---------------
!
      INTEGER       :: l, m
      REAL(KIND=RP) :: hp, poly
!
      hp = 0.0_RP
      DO l = 0,N
         IF(l == j)     CYCLE
         poly = 1.0_RP
         DO m = 0,N
            IF (m == l)     CYCLE
            IF (m == j)     CYCLE
            poly = poly*(x - nodes(m))/(nodes(j) - nodes(m))
         END DO
         hp = hp + poly/(nodes(j) - nodes(l))
      END DO
      EvaluateLagrangePolyDerivative = hp
!
      END FUNCTION EvaluateLagrangePolyDerivative
!
!////////////////////////////////////////////////////////////////////////
!
!     ----------------------------------------------------------------
!!    Compute the barycentric weights for polynomial interpolation
!     ----------------------------------------------------------------
!
      SUBROUTINE BarycentricWeights( N, x, w )
!
!     ---------
!     Arguments
!     ---------
!
      INTEGER :: N
      REAL(KIND=RP), DIMENSION(0:N), INTENT(IN)  :: x
      REAL(KIND=RP), DIMENSION(0:N), INTENT(OUT) :: w
!
!     ---------------
!     Local Variables
!     ---------------
!
      INTEGER :: j, k
!
      w = 1.0_RP
      DO j = 1, N
         DO k = 0, j-1
            w(k) = w(k)*(x(k) - x(j))
            w(j) = w(j)*(x(j) - x(k))
         END DO
      END DO
      w = 1.0_RP/w

      END SUBROUTINE BarycentricWeights
!
!     ////////////////////////////////////////////////////////////////
!
!     ------------------------------------------------------------------
!!    Compute the value of the interpolant using the barycentric formula
!     ------------------------------------------------------------------
!
      REAL(KIND=RP) FUNCTION LagrangeInterpolation( x, N, nodes, values, weights)
!
!     ---------
!     Arguments
!     ---------
!
      REAL(KIND=RP)                 :: x
      INTEGER                       :: N
      REAL(KIND=RP), DIMENSION(0:N) :: nodes
      REAL(KIND=RP), DIMENSION(0:N) :: values
      REAL(KIND=RP), DIMENSION(0:N) :: weights
!
!     ---------------
!     Local Variables
!     ---------------
!
      INTEGER       :: j
      REAL(KIND=RP) :: t, numerator, denominator

      LOGICAL, EXTERNAL :: AlmostEqual

      numerator   = 0.0_RP
      denominator = 0.0_RP
      DO j = 0, N
         IF( AlmostEqual( x, nodes(j) ) )    THEN
            LagrangeInterpolation = values(j)
            RETURN
         END IF
         t = weights(j)/( x - nodes(j) )
         numerator = numerator + t*values(j)
         denominator = denominator + t
      END DO
      LagrangeInterpolation = numerator/denominator

      END FUNCTION LagrangeInterpolation
!
!     ////////////////////////////////////////////////////////////////
!
!     ------------------------------------------------------------------
!!    Compute the value of the interpolant using the barycentric formula
!     ------------------------------------------------------------------
!
      REAL(KIND=RP) FUNCTION LagrangeInterpolantDerivative( x, N, nodes, values, weights)
!
!     ---------
!     Arguments
!     ---------
!
      REAL(KIND=RP)                 :: x
      INTEGER                       :: N
      REAL(KIND=RP), DIMENSION(0:N) :: nodes
      REAL(KIND=RP), DIMENSION(0:N) :: values
      REAL(KIND=RP), DIMENSION(0:N) :: weights
!
!     ---------------
!     Local Variables
!     ---------------
!
      INTEGER       :: j, i
      REAL(KIND=RP) :: t, numerator, denominator
      REAL(KIND=RP) :: p
      LOGICAL       :: atNode

      LOGICAL, EXTERNAL :: AlmostEqual

!
!     --------------------------
!     See if the point is a node
!     --------------------------
!
      atNode = .FALSE.
      numerator   = 0.0_RP
      DO j = 0, N
         IF( AlmostEqual( x, nodes(j) ) )    THEN
            atNode      = .TRUE.
            p           = values(j)
            denominator = -weights(j)
            i           = j
            EXIT
         END IF
      END DO

      IF ( atNode )     THEN
         DO j = 0, N
            IF( j == i )    CYCLE
            numerator = numerator + weights(j)*(p - values(j))/( x - nodes(j) )
         END DO
      ELSE
         p = LagrangeInterpolation( x, N, nodes, values, weights)
         denominator = 0.0_RP
         DO j = 0, N
            t = weights(j)/( x - nodes(j) )
            numerator = numerator + t*(p - values(j))/( x - nodes(j) )
            denominator = denominator + t
         END DO
      END IF
      LagrangeInterpolantDerivative = numerator/denominator

      END FUNCTION LagrangeInterpolantDerivative
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE InterpolateToNewPoints( N, M, T, f, fInterp )
!
!-------------------------------------------------------------------
!!    Use matrix Multiplication to interpolate between two sets of
!!    nodes.
!-------------------------------------------------------------------
!
!
!     ---------
!     Arguments
!     ---------
!
      INTEGER                          , INTENT(IN)  :: N, M
      REAL(KIND=RP), DIMENSION(0:M,0:N), INTENT(IN)  :: T
      REAL(KIND=RP), DIMENSION(0:N)    , INTENT(IN)  :: f
      REAL(KIND=RP), DIMENSION(0:M)    , INTENT(OUT) :: fInterp
!
!     ---------------
!     Local Variables
!     ---------------
!
      INTEGER       :: i,j
      REAL(KIND=RP) :: tmp

      DO i = 0, M
         tmp = 0.0_RP
         DO j = 0, N
            tmp = tmp + T(i,j)*f(j)
         END DO
         fInterp(i) = tmp
      END DO

      END SUBROUTINE InterpolateToNewPoints
!
!
!  **********
   END MODULE PolynomialInterpolationModule
!  **********


SUBROUTINE vmflow(stress,dsbar,vmfl)
!
! This subroutine forms the von-Mises flow vector.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::stress(:),dsbar
 REAL(iwp),INTENT(OUT)::vmfl(:)
 REAL(iwp)::sigm,onept5=1.5_iwp,two=2.0_iwp,d3=3.0_iwp
 sigm=(stress(1)+stress(2)+stress(4))/d3
 vmfl(1)=stress(1)-sigm
 vmfl(2)=stress(2)-sigm
 vmfl(3)=stress(3)*two
 vmfl(4)=stress(4)-sigm
 vmfl=vmfl*onept5/dsbar
RETURN
END SUBROUTINE vmflow


MODULE rsquared
IMPLICIT NONE

INTEGER, SAVE :: ifault

PUBLIC :: ifault, qr2

CONTAINS

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

! The following code for calculating quantiles of R^2 (qr2.for)
! is by the author of AS 261 and uses an improved algorithm.

FUNCTION qr2(m, size, rho2, p) RESULT(quantile)

!  Computes the quantile of the distribution of the square of the
!  sample multiple correlation coefficient for given number of
!  random variables M, sample size SIZE, square of the population
!  multiple correlation coefficient RHO2, and lower tail area P

!  Reference:
!  Ding, C.G. (1996) `On the computation of the distribution of
!  the square of the sample multiple correlation coefficient',
!  Comput. Statist. & Data Analysis, vol. 22, 345-350.

!  IFAULT is a fault indicator:
!  = 1 if there is no convergence after 10 Newton's iterations
!  = 2 if any of the input values is illegal
!  = 0 otherwise

!  No auxiliary algorithm is required

!  ELF90 compatible version by Alan Miller
!  N.B. The error indicator (ifault) has been put into the module contents
!       as functions can only return one result in ELF90.
!  Latest revision - 20 May 1997

INTEGER, INTENT(IN) :: m, size
REAL, INTENT(IN)    :: rho2, p
REAL                :: quantile

! Local variables
REAL               :: n, a, b, ab, ga, q0, yp, y, coeff, q, s, t, cdf, pdf,  &
                      gb, gab, v, bndcdf, bndpdf, ynew, diff
INTEGER            :: na, i, nab, nb, iter
REAL, PARAMETER    :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0,   &
                      eps = 1.E-06, delta = 1.E-04, rp = 1.772453850905516028
INTEGER, PARAMETER :: itrmax = 10

quantile = p

!        Test for admissibility of arguments

ifault = 2
IF (m <= 1 .OR. size <= m .OR. rho2 < zero .OR.  &
    rho2 > one .OR. p < zero .OR. p > one) RETURN
ifault = 0
IF (p == zero .OR. p == one) RETURN

!        Calculate the constants needed for each Newton's iteration

a = (m - 1) / two
b = (size - m) / two
ab = (size - 1) / two
IF (MOD(m + 1, 2) == 0) THEN
  na = a + half
  ga = one
  DO i = 1, na
    ga = ga * i
  END DO
ELSE
  na = a + one
  ga = rp
  DO i = 1, na
    ga = ga * (i - half)
  END DO
END IF
IF (MOD(size - m, 2) == 0) THEN
  nb = b - half
  gb = one
  DO i = 1, nb
    gb = gb * i
  END DO
ELSE
  nb = b
  gb = rp
  DO i = 1, nb
    gb = gb * (i - half)
  END DO
END IF
IF (MOD(size - 1, 2) == 0) THEN
  nab = ab - half
  gab = one
  DO i = 1, nab
    gab = gab * i
  END DO
ELSE
  nab = ab
  gab = rp
  DO i = 1, nab
    gab = gab * (i - half)
  END DO
END IF
q0 = (one - rho2) ** ab
coeff = gab / ga / gb

!        Use 0.5 as a starting value for Newton's iterations

y = half

!        Perform Newton's iterations

DO iter = 1, itrmax

!        Evaluate the first terms of the series for CDF (distribution
!        function) and PDF (density)

  n = one
  yp = one - y
  t = coeff * y ** a * yp ** b
  s = a * t / y / yp
  q = q0
  v = q
  cdf = v * t
  pdf = q * s

!        Check if a + n > (a + b + n)y

  80 IF (a + n > (a + b + n) * y) GO TO 90

!        Evaluate the next terms of two series and then the
!        partial sums

  q = q * (a + b + n - one) * rho2 / n
  v = v + q
  s = t * (a + b + n - one) / yp
  t = t * y * (a + b + n - one) / (a + n)
  cdf = cdf + v * t
  pdf = pdf + q * s
  n = n + one
  GO TO 80

!        Find the error bounds and check for convergence for both
!        series

  90 bndcdf = t * y * (a + b + n - one) / (a + n - (a + b + n) * y)
  bndpdf = t * (a + b + n - one) * (one - v) / yp
  100 IF (bndcdf <= eps .AND. bndpdf <= eps) GO TO 110

!        Continue to update the terms and then accumulate

  q = q * (a + b + n - one) * rho2 / n
  v = v + q
  IF (bndcdf <= eps) THEN
    s = s * y * (a + b + n - one) / (a + n - one)
    pdf = pdf + q * s
    n = n + one
    bndpdf = s * y * (a + b + n - one) * (one - v) / (a + n - one)
    GO TO 100
  ELSE IF (bndpdf <= eps) THEN
    t = t * y * (a + b + n - one) / (a + n)
    cdf = cdf + v * t
    n = n + one
    bndcdf = t * y * (a+b+n-one) / (a+n - (a+b+n)*y)
    GO TO 100
  ELSE
    s = t * (a + b + n - one) / yp
    t = t * y * (a + b + n - one) / (a + n)
    cdf = cdf + v * t
    pdf = pdf + q * s
    n = n + one
    GO TO 90
  END IF

!        Obtain a new Y and make changes if it is illegal

  110 diff = (cdf - p) / pdf
  ynew = y - diff
  IF (ynew <= zero) THEN
    y = y / two
  ELSE IF (ynew >= one) THEN
    y = (y + one) / two
  ELSE
    y = ynew
  END IF

!        Check for convergence of Newton's iterations

  IF (ABS(diff) <= delta * y) THEN
    quantile = y
    RETURN
  END IF
END DO
ifault = 1
RETURN
END FUNCTION qr2

END MODULE rsquared

PROGRAM main

!        This is a driver program that calls QR2 and produces output

USE rsquared
IMPLICIT NONE

INTEGER :: m, size, icode, k
REAL    :: rho2, p, y

10 WRITE (*, 11)
11 FORMAT (/' ENTER M (>1), N (>M), RHO2 (BETWEEN 0 AND 1), and',  &
           /' P (BETWEEN 0 AND 1) FOR QR2 ==> ')
READ (*,*) m, size, rho2, p
y = qr2(m, size, rho2, p)
icode = ifault + 1
SELECT CASE (icode)
  CASE (1)
    WRITE (*, 21) m, size, rho2, p, y
    21 FORMAT (/' qr2(', i3, ',', i3, ',', g13.4, ',', g13.4, ') = ', g13.5)
  CASE (2)
    WRITE (*, 31)
    31 FORMAT (/' NO convergence after 10 Newton ITERATIONS')
  CASE (3)
    WRITE (*, 41)
    41 FORMAT (/' THE INPUT VALUE IS ILLEGAL!')
END SELECT
WRITE (*, 61)
61 FORMAT (/ ' ENTER 1 TO CONTINUE OR 0 TO QUIT ==> ')
READ (*,*) k
IF (k == 1) GO TO 10

STOP
END PROGRAM main


      program main
c
c ... array declarations.
c
      implicit double precision (a-h, o-z)
      dimension coef(120,5), rhs(100), u(100), wksp(600), ubar(1),
     a     rparm(30)
      integer jcoef(5), iwksp(300), iparm(30), p(100), ip(100)
      integer patt(2)
      external sor, sor7
c
      ndim = 120
      mdim = 5
      nw = 600
      inw = 300
c
c ... generate coef, jcoef, and rhs.
c
      nx = 10
      ny = 10
      nz = 1
      n = nx*ny
      h = 1.0d0/dble(nx + 1)
      maxnz = 3
      do i = 1,n
         coef(i,1) = 6.0d0
         coef(i,2) = -1.0d0
         coef(i,3) = -2.0d0
         rhs(i) = 0.0d0
      enddo
      k = 0
      do j = 1,ny
         y = dble(j)*h
         do i = 1,nx
            x = dble(i)*h
            k = k + 1
            if (j .eq. 1) then
               rhs(k) = rhs(k) + 2.0d0
            endif
            if (j .eq. ny) then
               rhs(k) = rhs(k) + 2.0d0*(1.0d0 + x)
               coef(k,3) = 0.0d0
            endif
            if (i .eq. 1) then
               rhs(k) = rhs(k) + 1.0d0
            endif
            if (i .eq. nx) then
               rhs(k) = rhs(k) + 1.0d0 + y
               coef(k,2) = 0.0d0
            endif
         enddo
      enddo
      jcoef(1) = 0
      jcoef(2) = 1
      jcoef(3) = nx
      call dfault (iparm,rparm)
c
c ... now, reset some default values.
c
      iparm(3) = 3
      iparm(14) = 1
      iparm(19) = nx
c
c ... generate an initial guess for u and call nspcg.
c
      call vfill (n,u,0.0d0)
c
      nxp = 1
      nyp = 2
      nzp = 1
      patt(1) = 1
      patt(2) = 2
      call color (nxp,nyp,nzp,nx,ny,nz,patt,p)
      call nspcg (sor7,sor,ndim,mdim,n,maxnz,coef,jcoef,p,ip,
     a            u,ubar,rhs,wksp,iwksp,nw,inw,iparm,rparm,ier)
      stop
      end


FUNCTION isPerfect(n)
  LOGICAL :: isPerfect
  INTEGER, INTENT(IN) :: n
  INTEGER :: i, factorsum

  isPerfect = .FALSE.
  factorsum = 1
  DO i = 2, INT(SQRT(REAL(n)))
     IF(MOD(n, i) == 0) factorsum = factorsum + i + (n / i)
  END DO
  IF (factorsum == n) isPerfect = .TRUE.
END FUNCTION isPerfect


program calculator
  real :: a, b, calcResult
  character*3 :: operation

  print *, "Hello Fortran! Which Operation?(add, sub, mul, div)"
  read *, operation

  print *, "Which X?"
  read *, a

  print *, "Which Y?"
  read *, b

  if (operation .EQ. 'add') then
    calcResult  = a + b

  else if (operation .EQ. 'sub') then
    calcResult  = a - b

  else if (operation .EQ. 'mul') then
    calcResult  = a * b

  else if (operation .EQ. 'div') then
    if ( b .EQ. 0) then
      print *, "Error: Division with Zero."
    else
      calcResult  = a / b
    end if

  end if

  print *, "Result is: "
  print *, calcResult
end program calculator


      PROGRAM numint

      IMPLICIT none
      INTEGER NMAX
      PARAMETER (NMAX=100000)
      REAL*8 x(NMAX),f(NMAX),fint(NMAX),dx
      CHARACTER*30 ifile,ofile
      LOGICAL ex
      INTEGER i,ntot

C----
C Get file names from command line
C----
      call gcmdln(ifile,ofile)
      inquire(file=ifile,EXIST=ex)
      if (.not.ex) then
          write(*,*) 'No input file:',ifile
          call usage()
      endif

C----
C Read data series
C----
      open(unit=11,file=ifile,status='old')
      i = 1
  101 read(11,*,end=102) x(i),f(i)
          i = i + 1
          goto 101
  102 continue
      ntot = i - 1

C----
C Trapezoidal integration
C----
      fint(1) = 0.0d0
      do 103 i = 2,ntot
          dx = x(i) - x(i-1)
          fint(i) = fint(i-1) + dx*0.5d0*(f(i)+f(i-1))
  103 continue

C----
C Write integrated data series
C----
      open(unit=12,file=ofile,status='unknown')
      do 104 i = 1,ntot
          write(12,*) x(i),fint(i)
  104 continue
      END

C======================================================================C

      SUBROUTINE gcmdln(ifile,ofile)
      IMPLICIT none
      CHARACTER*30 tag,ifile,ofile
      INTEGER i,narg

      ifile = 'numint.in'
      ofile = 'numint.out'

      narg = iargc()
      if (narg.eq.0) call usage()
      i = 0
  101 i = i + 1
      if (i.gt.narg) goto 102
          call getarg(i,tag)
          if (tag(1:2).eq.'-h'.or.tag(1:2).eq.'-?') then
              call usage()
          elseif (tag(1:2).eq.'-f') then
              i = i + 1
              call getarg(i,ifile)
          elseif (tag(1:2).eq.'-o') then
              i = i + 1
              call getarg(i,ofile)
          endif
          goto 101
  102 continue

      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE usage()
      IMPLICIT none
      write(*,*)
     1 'Usage: numint -f [IFILE] -o [OFILE] -h/-?'
      write(*,*)
     1 '  -f [IFILE] (Default numint.in) name of input file'
      write(*,*)
     1 '  -o [OFILE] (Default numint.out) name of output file'
      write(*,*)
     1 '  -h/-?    Online help (this screen)'
      write(*,*)
      write(*,*)
     1 'numint numerically integrates a time series using trapezoidal',
     2 ' integration'
      write(*,*)
      write(*,*)
     1 '  Input files'
      write(*,*)
     1 '    numint.in: data series'
      write(*,*)
     1 '      t1 f(t1)'
      write(*,*)
     1 '         :'
      write(*,*)
      write(*,*)
     1 '  Output files'
      write(*,*)
     1 '    numint.out: integral of data series (starting from first',
     2                   ' entry)'
      write(*,*)
     1 '      t1 F(t1)'
      write(*,*)
     1 '         :'
      STOP
      END


!===================================================================
!   Randomly places parcels with variable volume in the domain
!===================================================================

program ranpar

 !Import parameters and constants:
use constants

implicit none

 !Total number of parcels:
integer:: n

 !Parcel positions (x,z) and area fractions:
double precision:: x(nm),z(nm),v(nm)

 !Other variables:
double precision:: vrange,fac
integer, dimension(:), allocatable :: seed
integer:: i,k,ngen

!---------------------------------------------------------------------
! Generate parcel positions and volumes:
write(*,*) ' Enter the average number of parcels per grid cell:'
read(*,*) fac
n=nint(fac*dble(ncell))

write(*,*) ' We assume any parcel area is equally probable.'
write(*,*) ' Enter A_max/A_min:'
read(*,*) vrange

write(*,*) ' Enter an integer seed for the random number generator:'
read(*,*) ngen
call random_seed(size=k)
allocate(seed(1:k))
seed(:)=ngen
do i=1,ngen
  call random_seed(put=seed)
enddo

vrange=vrange-1.d0
do i=1,n
  call random_number(fac)
  x(i)=ellx*fac+xmin
  call random_number(fac)
  z(i)=ellz*fac+zmin
  call random_number(fac)
  v(i)=vrange*fac+1.d0
enddo

! Re-normalise so that sum(v) = ncell = nx*nz:
fac=dble(ncell)/sum(v(1:n))
v(1:n)=fac*v(1:n)

!---------------------------------------------------------------------
! Write parcel positions and area fractions (of grid cell volume):
open(80,file='ini_parcels.asc',status='replace')
write(80,*) n
do i=1,n
  write(80,*) x(i),z(i),v(i)
enddo
close(80)

write(*,*)
write(*,*) ' The initial parcels are in ini_parcels.asc'
write(*,*)

 !End main program
end program ranpar


*dk, guass_elim_lg
        subroutine guass_elim_lg(flag,n,LDA,epsilon,A,b,x
     &                            ,wrkmat,ierror)

C #####################################################################
C
C     PURPOSE -
C
C        solve general Ax=b using Gaussian elimination.
C        (A can be singular and non-symmetric, but must be square).
C
C     INPUT ARGUMENTS -
C
C        A - the array to invert
C        LDA - MAX first dimension of A to get storage correct
C        n - dimension of problem: A(1:n,1:n)*x(1:n)=b(1:n)
C        b - the (input) b vector in Ax=b
C        epsilon - relative accuracy
C             The average eigenvalue of b is computed as |Ab|/|b|,
C             and hence |x|~|b|/(|Ab|/|b|). Corrections dx to the estimate along
C             eigendirections of A with significantly smaller eigenvalues
C             give large changes to x for negligible improvement to |Ax-b|.
C             epsilon is used for the relative tests as appropriate.
C        flag - switch to indicate whether to calculate solution of
C               (1) Ax=b
C               (2) (A^2+eps^2*I)x=Ab where I(i,j)=(1 if i=j, 0 otherwise)
C                   [solve (A+i*eps)x=b in sense of Hadamard principle part]
C
C     OUTPUT ARGUMENTS -
C
C        x - the (output) solution vector x to Ax=b
C        ierror - set on return to
C                -1         if A=0 and b.ne.0
C                 0         if (|Ax-b|/|b|)^2 < epsilon,
C                 1+min((|Ax-b|/|b|)^2/(10*epsilon),1000000)
C                           otherwise
C                 |Ax-b|/|b| < epsilon should also hold
C                 but using this softer test for the error return.
C
C     WORKSPACE ARGUMENTS -
C
C        wrkmat - nxn matrix workspace (contents ignored)
C
C     SPELLING NOTES -
C
C        oops: Gauss is spelled "gauss" not "guass",
C        but since I checked in in that way I guess it'll stay ...
C
C     PROGRAMMING NOTES -
C
C        The basic code is a straightforward implementation of
C        Gaussian elimination. The modifications here are
C        giving the user the choice to solve (A^2+eps*I)x=Ab
C        (Hadamard principle part) for (nearly) singular matricies,
C        and putting in the epsilon tests (and calculating the scale
C        for epsilon). As it is a principle part, flag=2 approaches
C        epsilon=0 as a well defined limit, whereas flag=1 can be
C        "unpredictable" especially for the nearly singular case.
C
C        For nearly singular matricies where "wild" contributions (essentially
C        unrestricted small eigenvalue components) to x are undesireable,
C        using flag=2 and epsilon "relatively large" (1.e-2 to 1.e-4)
C        is recommended. This also works pretty well for the non-singular cases.
C
C        Using flag=1 (straightforward Ax=b solution)
C        has accuracy problems in certain cases, eg for the 2x2 problem
C           ( 0 1 ) (x1)   ( 1 )           (x1)   (0.999977878280)
C           ( 1 0 ) (x2) = ( 1 )  one gets (x2) = (0.999999999999) for epsilon=1.e-12;
C        flag=2 is more stable, although for large matricies it is slightly
C        more inefficient since the matrix has to be squared. (There is one
C        other "N^3" loop in this code, so it is not a huge overhead compare to
C        flag=1 -- the coding presumption is that the dimension of the matrix A
C        is typically n=3 and not n=1000...)
C        However, note that for flag=1 "often" |Ax-b|/|b| << epsilon,
C        whereas for flag=2 |Ax-b|/|b| ~ epsilon "almost always".
C
C        Although not coded here, a "best" epsilon could also be selected
C        by minimizing a functional showing a minimum and having the
C        appropriate symmetry properties, such as
C            chisq=|x|^2*(Tr A^2 + 3 eps^2)^2
C        or looking to see if/where |x|-|b|/(|Ab|/|b|) change sign.
C        (These are 2 empirical tests that worked fairly well for
C        the set of small matricies I looked at, which came from
C        typical cases projecting face velocity onto node velocity.)
C
C        Also compare solv_Mxb_schmidt_hilbert_lg (forms inverse with Schmidt-Hilbert).
C        For large matrices, using an iterative sparse solver such as GMRES is recommended
C
C     CHANGE HISTORY -
C
C        $Log: guass_elim_lg.f,v $
C        Revision 2.00  2007/11/03 00:49:10  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.7   17 Feb 2001 14:19:24   jtg
CPVCS    fixed log line; Rev 1.6=correctly did Rev 1.5
CPVCS
CPVCS       Rev 1.5   Wed Mar 08 15:40:30 2000   dcg
CPVCS    change debug flag so that error messages are not written
CPVCS    return flag will have error status
CPVCS
CPVCS       Rev 1.2   Mon Dec 13 10:47:16 1999   jtg
CPVCS    Noted Gauss is spelled wrong
CPVCS
CPVCS       Rev 1.1   Wed Dec 01 15:43:52 1999   jtg
CPVCS    set local_debug to 0
CPVCS
CPVCS       Rev 1.0   Wed Dec 01 14:35:32 1999   jtg
CPVCS    Initial revision.
C
C ######################################################################

        implicit none

        integer n,LDA,flag,ierror

        real*8 x(n),b(n),A(LDA,n),wrkmat(n,n)
     &        ,epsilon

        integer i,j,k,local_debug
        real*8 eps,b2,Ab2,xxx
        character*132 cbuf

c ---------------------------------------------------------------
        local_debug=0

c ...............................
c fill wrkmat,x from A,b

        if (flag.eq.2) then
           ! set wrkmat=A^2, x=Ab
           ! obviously wrkmat and A, and x and b, need to be separate storage
           ! locations for this flag case.
           do i=1,n
              x(i)=0.d0
              do j=1,n
                 x(i)=x(i)+A(i,j)*b(j)
                 wrkmat(i,j)=0.d0
                 do k=1,n
                    wrkmat(i,j)=wrkmat(i,j)+A(i,k)*A(k,j)
                 enddo
              enddo
           enddo
        else
           ! set wrkmat=A, x=b
           ! except for the final test comparing |Ax-b|/|b|,
           ! wrkmat and A, and x and b, could have been indentical storage locations.
           do i=1,n
              x(i)=b(i)
              do j=1,n
                 wrkmat(i,j)=A(i,j)
              enddo
           enddo
        endif

c ...............................
c figure out eps from epsilon and |Ab|/|b|
c eps is used to screen out singular components

c calculate scale of A and b
        Ab2=0.d0
        b2=0.d0
        do i=1,n
           b2=b2+x(i)*x(i)
           xxx=0.d0
           do j=1,n
              xxx=xxx+wrkmat(i,j)*x(j)
           enddo
           Ab2=Ab2+xxx*xxx
        enddo

c abort if solution trivial (b=0), or no soln possible (A=0)
        if (b2.eq.0.d0 .or. Ab2.eq.0.d0) then
           do i=1,n
              x(i)=0.d0
           enddo
           goto 100
        endif

c set absolute eps for iteration, update diagonal for flag=2
        xxx=sqrt(Ab2/b2)
        eps=epsilon*xxx
        if (flag.eq.2) then
           ! vs using xxx=Tr(wrkmat)/dble(n) (average eigenvalue of A^2)
           ! if along small eigenvalue direction, I am presuming current
           ! xxx=sqrt(Ab2/b2) (average eigenvalue component in Ab) better ...
           xxx=eps*epsilon   ! wrkmat = ( A^2 + epsilon^2 * scale(A^2) )
           do i=1,n
              wrkmat(i,i)=wrkmat(i,i)+xxx
           enddo
           ! solve as for unsquared case, but with smaller epsilon?
           ! which version to use ... does it make a difference?
           ! eps=eps
           eps=1.d-4*eps
           ! eps=epsilon*eps
        endif

c ...............................
c solve using Gaussian elimination,
c testing the diagonals of A against eps to avoid dividing by zero

        do k=1,n-1
           do i=k+1,n
              xxx=wrkmat(k,k)
              if (abs(xxx).gt.eps) then
                 xxx=1.d0/xxx
              elseif (xxx.lt.0.d0.and.flag.ne.2) then
                 xxx=-1.d0/eps
              else
                 xxx=1.d0/eps
              endif
              xxx=xxx*wrkmat(i,k)
              x(i)=x(i)-x(k)*xxx
              do j=k+1,n
                 wrkmat(i,j)=wrkmat(i,j)-wrkmat(k,j)*xxx
              enddo
           enddo
        enddo

        do i=n,1,-1
           do j=i+1,n
              x(i)=x(i)-wrkmat(i,j)*x(j)
           enddo
           xxx=wrkmat(i,i)
           if (abs(xxx).gt.eps) then
              xxx=1.d0/xxx
           elseif (xxx.lt.0.d0.and.flag.ne.2) then
              xxx=-1.d0/eps
           else
              xxx=1.d0/eps
           endif
           x(i)=x(i)*xxx
        enddo

c ...............................
c test how good a solution and update ierror
c have to redo b2 since for flag=2 it is |Ab| rather than |b|

100     ierror=0

        b2=0.d0
        Ab2=0.d0
        do i=1,n
           xxx=-b(i)
           do j=1,n
              xxx=xxx+A(i,j)*x(j)
           enddo
           Ab2=Ab2+xxx*xxx
           b2=b2+b(i)*b(i)
        enddo

        if (local_debug.ne.0) then
           write(*,'(a,4g20.10)') 'gauss_elim_lg: |Ax-b|,|b|,epsilon='
     &            ,sqrt(Ab2),sqrt(b2),(sqrt(Ab2)/sqrt(b2))/epsilon
     &            ,epsilon
        endif

        if (b2.ne.0.d0) then
           ! actually, should test sqrt(Ab2/b2) against epsilon,
           ! but since this is a "hard error flag" (0 vs non-zero), use epsilon instead
           xxx=Ab2/b2
           if (epsilon.ne.0.d0) xxx=xxx/epsilon
           if (xxx.gt.1.d0) then
              if (xxx.gt.10000000.d0) then
                 ierror=1000000
              else
                 ierror=1+int(xxx*0.1d0)
              endif
           endif
        elseif (Ab2.ne.0.d0) then
           ierror=-1
        endif

        if (ierror.ne.0.and.local_debug.ne.0) then
           write(cbuf,'(a,3g15.5)')
     &          'gauss_elim_lg warning: (||Ax-b|/|b|)^2 > epsilon;'
     &          //' |Ax-b|,|b|,epsilon=',sqrt(Ab2),sqrt(b2),epsilon
           call writloga('default',0,cbuf,0,i)
        endif

c ...............................
        return
        end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc


!
!  Find statistics of mean and covariance matrix of underlying latent vector.
!

!   covinverse is the estimated inverse of the covariance matrix of the underlying latent vector corresponding to beta.

!	covlin is the estimated covariance matrix of the linear component of beta.
!	covlinquad is the estimated covariance matrix of the linear and quadratic components of beta.
!   covmatrix is the estimated covariance matrix of the underlying latent vector corresponding to beta.
!	covquad is the estimated covariance matrix of the quadratic component of beta.
!	meanvec is the estimated mean of the underlying latent vector.

!   covcovmatrix is the estimated covariance matrix of covmatrix.
!   covmeanvec is the estimated covariance matrix of meanvec.
!   Note that this routine is for the case of an underlying normal latent vector.
subroutine covmatstat(covinverse,covlin, covlinquad,covmatrix,covquad,meanvec,covcovmatrix,covmeanvec)
implicit none
interface

!	Asymptotic covariance matrix of matrix inverse of symmetric matrix.
!	Input is matrix mat, its inverse matinv and its covariance matrix covmat.
!	Output is the asymptotic covariance matrix of matinv.
	function covmatinv(mat,matinv,covmat)
		implicit none
		real(kind=8),intent(in)::mat(:,:),matinv(:,:),covmat(:,:,:,:)
		real(kind=8)::covmatinv(size(mat,1),size(mat,1),size(mat,1),size(mat,1))
	end function covmatinv
!   Expand covariance matrix of matrix from compact format.
	function expandcovmat(n,covmat)
		implicit none
		integer,intent(in)::n
		real(kind=8),intent(in)::covmat(:,:)
		real(kind=8)::expandcovmat(n,n,n,n)
	end function expandcovmat
!	convert an n by n symmetric matrix from compact to regular form.
	function expandmat(n,compmat)
		implicit none
		integer,intent(in)::n
		real(kind=8),intent(in)::compmat(:)
		real(kind=8)::expandmat(n,n)
	end function expandmat

!		This program uses the modified Cholesky decomposition
!		in lu to solve the equation lusolve = b.

	subroutine makesym(matrix)
!	Symmetrize n by n matrix based on lower triangle.
		implicit none
		real(kind=8),intent(inout)::matrix(:,:)
	end subroutine makesym

end interface
real(kind=8),intent(in)::covinverse(:,:),covlin(:,:),covlinquad(:,:),covmatrix(:,:),covquad(:,:),meanvec(:)
real(kind=8),intent(out)::covcovmatrix(:,:,:,:),covmeanvec(:,:)
!   dimlatin is the dimension of the underlying covariance matrix.

!   row counts elements of latent vectors.
!   row1 counts elements of latent vectors.

integer::dimlatin,row,row1
!   covmeanvec1,covmeanvec2, and covmeanvec3 are components of covmeanvec.
!   covquade is the expanded covariance matrix of the quadratic component of beta.

real(kind=8)::covmeanvec1(size(covmatrix,1),size(covmatrix,1)),&
	covmeanvec2(size(covmatrix,1),size(covmatrix,1),size(covmatrix,1)),&
	covmeanvec3(size(covmatrix,1),size(covmatrix,1)),&
	covquade(size(covmatrix,1),size(covmatrix,1),size(covmatrix,1),size(covmatrix,1))

!   Find dimension of underlying latent vector.
dimlatin=size(covmatrix,1)

!	Covariance matrix of linear part.

covquade=expandcovmat(dimlatin,covquad)
covcovmatrix=covmatinv(covinverse,covmatrix,covquade)
do row=1,dimlatin

	covmeanvec1(row,:)=matmul(expandmat(dimlatin,covlinquad(row,:)),meanvec)
	do row1=1,dimlatin
		covmeanvec2(row,:,row1)=matmul(covquade(row,:,row1,:),meanvec)
		covmeanvec3(row,row1)=sum(covmeanvec2(row,:,row1)*meanvec)
	end do
end do

do row=1,dimlatin
	do row1=1,row
		covmeanvec(row,row1)=covlin(row,row1)-covmeanvec1(row,row1)-covmeanvec1(row1,row)+covmeanvec3(row,row1)
	end do
end do
call makesym(covmeanvec)
covmeanvec=matmul(covinverse,matmul(covmeanvec,covinverse))
end subroutine covmatstat


C
C	$Id: csareas.f,v 1.5 2008-07-27 03:10:05 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      DOUBLE PRECISION FUNCTION CSAREAS (V1,V2,V3)
      DOUBLE PRECISION V1(3), V2(3), V3(3)
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   06/22/98
C
C   This function returns the area of a spherical triangle
C on the unit sphere.
C
C
C On input:
C
C       V1,V2,V3 = Arrays of length 3 containing the Carte-
C                  sian coordinates of unit vectors (the
C                  three triangle vertices in any order).
C                  These vectors, if nonzero, are implicitly
C                  scaled to have length 1.
C
C Input parameters are not altered by this function.
C
C On output:
C
C       CSAREAS = Area of the spherical triangle defined by
C               V1, V2, and V3 in the range 0 to 2*PI (the
C               area of a hemisphere).  CSAREAS = 0 (or 2*PI)
C               if and only if V1, V2, and V3 lie in (or
C               close to) a plane containing the origin.
C
C Modules required by CSAREAS:  None
C
C Intrinsic functions called by CSAREAS:  ACOS, SQRT
C
C***********************************************************
C
      DOUBLE PRECISION A1, A2, A3, CA1, CA2, CA3, S12, S23,
     .                 S31, U12(3), U23(3), U31(3)
      INTEGER          I
C
C Local parameters:
C
C A1,A2,A3 =    Interior angles of the spherical triangle
C CA1,CA2,CA3 = cos(A1), cos(A2), and cos(A3), respectively
C I =           DO-loop index and index for Uij
C S12,S23,S31 = Sum of squared components of U12, U23, U31
C U12,U23,U31 = Unit normal vectors to the planes defined by
C                 pairs of triangle vertices
C
C
C Compute cross products Uij = Vi X Vj.
C
      U12(1) = V1(2)*V2(3) - V1(3)*V2(2)
      U12(2) = V1(3)*V2(1) - V1(1)*V2(3)
      U12(3) = V1(1)*V2(2) - V1(2)*V2(1)
C
      U23(1) = V2(2)*V3(3) - V2(3)*V3(2)
      U23(2) = V2(3)*V3(1) - V2(1)*V3(3)
      U23(3) = V2(1)*V3(2) - V2(2)*V3(1)
C
      U31(1) = V3(2)*V1(3) - V3(3)*V1(2)
      U31(2) = V3(3)*V1(1) - V3(1)*V1(3)
      U31(3) = V3(1)*V1(2) - V3(2)*V1(1)
C
C Normalize Uij to unit vectors.
C
      S12 = 0.D0
      S23 = 0.D0
      S31 = 0.D0
      DO 2 I = 1,3
        S12 = S12 + U12(I)*U12(I)
        S23 = S23 + U23(I)*U23(I)
        S31 = S31 + U31(I)*U31(I)
    2   CONTINUE
C
C Test for a degenerate triangle associated with collinear
C   vertices.
C
      IF (S12 .EQ. 0.D0  .OR.  S23 .EQ. 0.D0  .OR.
     .    S31 .EQ. 0.D0) THEN
        CSAREAS = 0.D0
        RETURN
      ENDIF
      S12 = SQRT(S12)
      S23 = SQRT(S23)
      S31 = SQRT(S31)
      DO 3 I = 1,3
        U12(I) = U12(I)/S12
        U23(I) = U23(I)/S23
        U31(I) = U31(I)/S31
    3   CONTINUE
C
C Compute interior angles Ai as the dihedral angles between
C   planes:
C           CA1 = cos(A1) = -<U12,U31>
C           CA2 = cos(A2) = -<U23,U12>
C           CA3 = cos(A3) = -<U31,U23>
C
      CA1 = -U12(1)*U31(1)-U12(2)*U31(2)-U12(3)*U31(3)
      CA2 = -U23(1)*U12(1)-U23(2)*U12(2)-U23(3)*U12(3)
      CA3 = -U31(1)*U23(1)-U31(2)*U23(2)-U31(3)*U23(3)
      IF (CA1 .LT. -1.D0) CA1 = -1.D0
      IF (CA1 .GT. 1.D0) CA1 = 1.D0
      IF (CA2 .LT. -1.D0) CA2 = -1.D0
      IF (CA2 .GT. 1.D0) CA2 = 1.D0
      IF (CA3 .LT. -1.D0) CA3 = -1.D0
      IF (CA3 .GT. 1.D0) CA3 = 1.D0
      A1 = ACOS(CA1)
      A2 = ACOS(CA2)
      A3 = ACOS(CA3)
C
C Compute CSAREAS = A1 + A2 + A3 - PI.
C
      CSAREAS = A1 + A2 + A3 - ACOS(-1.D0)
      IF (CSAREAS .LT. 0.D0) CSAREAS = 0.D0
      RETURN
      END


module energies

! Calculates Hydrogen nonrelativistic and relativistic energies (exact),
! Thomas-Fermi (TF) energies (only very approximate), TF potential and charge
! density (very accurate).

use types, only: dp
use utils, only: stop_error
use constants, only: pi
implicit none
private
public E_nl, thomas_fermi_potential, get_tf_energies, get_hydrogen_energies, &
    thomas_fermi_density

contains

real(dp) function E_nl(c, n, l, Z, relat)
! Calculates exact energy for the radial Schroedinger/Dirac equations
real(dp), intent(in) :: c ! speed of light in atomic units
integer, intent(in) :: n, l, Z, relat
! quantum numbers (n, l), atomic number (z)
! relat == 0 ... Schroedinger equation
! relat == 2 ... Dirac equation, spin up
! relat == 3 ... Dirac equation, spin down

integer :: kappa
real(dp) :: beta
if (.not. (l >= 0)) call stop_error("'l' must be positive or zero")
if (.not. (n > l)) call stop_error("'n' must be greater than 'l'")
if (l == 0 .and. relat == 3) call stop_error("Spin must be up for l==0.")
if (relat == 0) then
    E_nl = - Z**2 / (2.0_dp * n**2)
else
    if (relat == 2) then
        kappa = -l - 1
    else
        kappa = l
    end if
    beta = sqrt(kappa**2 - (Z/c)**2)
    E_nl = c**2/sqrt(1 + (Z/c)**2/(n - abs(kappa) + beta)**2) - c**2
end if
end function

function thomas_fermi_potential(R, Z, cut) result(V)
! Generalized Thomas-Fermi atomic potential
real(dp), intent(in) :: R(:) ! Radial grid
integer, intent(in) :: Z     ! Atomic number
logical, intent(in), optional :: cut ! Cut the potential, default .true.
real(dp) :: x(size(R)), Z_eff(size(R)), V(size(R))
real(dp) :: alpha, beta, gamma

x = R * (128*Z/(9*pi**2)) ** (1.0_dp/3)
! Z_eff(x) = Z * phi(x), where phi(x) satisfies the Thomas-Fermi equation:
!   phi'' = phi**(3/2) / sqrt(x)
! with boundary conditions:
!   phi(0)  = 1
!   phi(oo) = 0
! There is no analytic solution, but one can solve this approximately. We use:
! http://arxiv.org/abs/physics/0511017
alpha = 0.7280642371_dp
beta = -0.5430794693_dp
gamma = 0.3612163121_dp
Z_eff = Z * (1 + alpha*sqrt(x) + beta*x*exp(-gamma*sqrt(x)))**2 * &
    exp(-2*alpha*sqrt(x))
! This keeps all the eigenvalues of the radial problem negative:
if (.not. present(cut)) where (Z_eff < 1) Z_eff = 1
V = -Z_eff / r
end function

function thomas_fermi_density(R, Z) result(rho)
! Generalized Thomas-Fermi atomic potential
real(dp), intent(in) :: R(:) ! Radial grid
integer, intent(in) :: Z     ! Atomic number
real(dp) :: V(size(R)), rho(size(R))
V = thomas_fermi_potential(R, Z, .false.)
rho = -1 / (3*pi**2) * (-2*V)**(3._dp/2)
end function

function get_tf_energies(Z, no, fo) result(E)
integer, intent(in) :: Z, no(:)
real(dp), intent(in) :: fo(:)
real(dp) :: E(size(no))

integer :: Zeff, i
Zeff = Z + 1
do i = 1, size(no)
    if (i > 1) then
        if (no(i) < no(i-1)) call stop_error("State order wrong")
    end if
    Zeff = Zeff - int(fo(i))
    if (Zeff <= 0) call stop_error("Negative ions not allowed")
    E(i) = -(1.0_dp * Zeff / no(i))**2/2
end do
end function

function get_hydrogen_energies(Z, no) result(E)
integer, intent(in) :: Z, no(:)
real(dp) :: E(size(no))
integer :: i
do i = 1, size(no)
    E(i) = -1.0_dp * Z**2 / (2*no(i)**2)
end do
end function

end module


      SUBROUTINE svdvar(v,ma,np,w,cvm,ncvm)
      INTEGER ma,ncvm,np,MMAX
      REAL cvm(ncvm,ncvm),v(np,np),w(np)
      PARAMETER (MMAX=20)
      INTEGER i,j,k
      REAL sum,wti(MMAX)
      do 11 i=1,ma
        wti(i)=0.
        if(w(i).ne.0.) wti(i)=1./(w(i)*w(i))
11    continue
      do 14 i=1,ma
        do 13 j=1,i
          sum=0.
          do 12 k=1,ma
            sum=sum+v(i,k)*v(j,k)*wti(k)
12        continue
          cvm(i,j)=sum
          cvm(j,i)=sum
13      continue
14    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/svdvar.for