module KNN_clustering
    use utils_module, only: dp

    implicit none
    contains

    !> This function returns a clustering from a similarity matrix based on
    !! 'nearest neighbor' clustering.
    !!
    !! Points belong to the same cluster if they are in either of each others k
    !! nearest neighbor sets.
    !!
    !! The algorithm computes the k nearest neihbor sets from the similarity
    !! matrix, and then tests
    recursive function NN_clustering(similarity_matrix,num_clusters) result(cluster_list)
        use utils_module, only: relabel
        use abort_module, only: halt_program
        implicit none

        real(dp), intent(in), dimension(:,:) :: similarity_matrix

        integer, dimension(size(similarity_matrix,1)) :: cluster_list
        integer, intent(out):: num_clusters

        integer :: num_clusters_new

        integer, dimension(size(similarity_matrix,1)) :: cluster_list_old
        integer :: num_clusters_old

        integer, dimension(size(similarity_matrix,1),size(similarity_matrix,1)) :: knn

        integer :: k
        integer :: nlive
        integer :: n
        integer :: i_cluster
        integer :: i_point

        integer, allocatable, dimension(:) :: points

        ! Get the number of points to be clustered
        nlive=size(similarity_matrix,1)

        ! 10 degrees of separation are usually fine, we'll expand this if necessary
        k = min(nlive,10)

        ! compute the k nearest neighbors for each point
        knn(:k,:) = compute_knn(similarity_matrix,k)

        ! Set up the cluster list
        cluster_list_old = [( i_point,i_point=1,nlive )]
        num_clusters_old = nlive

        do n=2,k

            cluster_list = do_clustering_k( knn(:n,:) )     ! Get a raw clustering

            ! Re-label the cluster list using integers 1,2,3,....
            cluster_list = relabel(cluster_list,num_clusters)

            if(num_clusters<=0) then
                call halt_program("Cluster error: cannot have fewer than 1 clusters")
            else if( num_clusters == 1 ) then
                return  ! If we're down to a single cluster, then just return
            else if( all( cluster_list == cluster_list_old ) ) then
                exit ! check that the clustering hasn't changed since the last pass
            else if(n==k) then
                ! If we need to cluster further, then expand the knn list
                k=min(k*2,nlive)
                knn(:k,:) = compute_knn(similarity_matrix,k)
            end if

            ! Save the old cluster list for later.
            cluster_list_old = cluster_list
            num_clusters_old = num_clusters

        end do

        ! If we've found clusters, then search within these clusters
        if(num_clusters>1) then
            i_cluster=1
            do while(i_cluster<=num_clusters)
                ! Get the indices of cluster i_cluster
                call get_indices_of_cluster(cluster_list,points,i_cluster)

                ! Call this function again on the similarity sub matrix, adding an offset
                cluster_list(points) = num_clusters + NN_clustering(similarity_matrix(points,points),num_clusters_new)

                ! If we didn't find any new clusters, then move on to the next one
                if(num_clusters_new==1) i_cluster=i_cluster+1

                ! re-label the clusters
                cluster_list = relabel(cluster_list,num_clusters)
            end do
        end if

    end function NN_clustering

    function do_clustering_k(knn) result(c)
        implicit none

        integer, dimension(:,:) :: knn
        integer, dimension(size(knn,2)) :: c

        integer :: i,j

        ! Set up the cluster list
        c = [( i,i=1,size(knn,2)  )]

        do i=1,size(knn,2)
            do j=i+1,size(knn,2)

                ! If they're not in the same cluster already...
                if(c(i)/=c(j)) then
                    ! ... check to see if they are within each others k nearest neihbors...
                    if( neighbors( knn(:,i),knn(:,j) ) ) then

                        ! If they are then relabel cluster_i and cluster_j to the smaller of the two
                        where(c==c(i).or.c==c(j))
                            c=min(c(i),c(j))
                        end where

                    end if
                end if

            end do
        end do

    end function do_clustering_k

    function compute_knn(similarity_matrix,k) result(knn)
        implicit none

        !> The data to compute on
        real(dp), intent(in),dimension(:,:) :: similarity_matrix

        !> The number of nearest neighbors to compute
        integer, intent(in) :: k

        ! The indices of the k nearest neighbors to output
        integer, dimension(k,size(similarity_matrix,1)) :: knn

        integer :: nPoints,i,j

        integer :: insert_index(1)

        real(dp), dimension(k) :: distance2s

        nPoints = size(similarity_matrix,1)

        knn=0

        do i=1,nPoints
            ! Find the k nearest neighbors for each point
            distance2s = huge(1d0)
            do j=1,nPoints
                ! If the distance between i and j is too large to be considered,
                ! this returns 0
                ! otherwise this returns the position to insert
                insert_index = minloc(distance2s, mask=distance2s>similarity_matrix(i,j))
                ! If it needs to be inserted, insert into both the integer
                ! array, and the local distance2s array
                if(insert_index(1)/=0) then
                    distance2s(insert_index(1):) =  eoshift( distance2s(insert_index(1):), -1,dim=1,boundary=similarity_matrix(i,j))
                    knn(insert_index(1):,i) =  eoshift( knn(insert_index(1):,i) ,-1 ,dim=1, boundary=j)
                end if
            end do

        end do

    end function compute_knn

    ! Return whether they're each others n nearest neighbor list
    function neighbors(knn1,knn2) result(same_list)
        implicit none
        integer,intent(in), dimension(:) :: knn1
        integer,intent(in), dimension(:) :: knn2

        logical :: same_list

        ! Check to see if they're in each others neighbors lists
        same_list= any(knn1==knn2(1)) .or. any(knn2==knn1(1))

    end function neighbors

    ! Return the number of matches in the n nearest neighbor list
    function matches(knn1,knn2)
        implicit none
        integer,intent(in), dimension(:) :: knn1
        integer,intent(in), dimension(:) :: knn2

        integer :: matches

        integer i,j

        matches = count( [( [( knn1(i)==knn2(j), i=1,size(knn1) )], j=1,size(knn2) )] )

    end function matches

    !> This subroutine returns points: an allocated array of indices of the points in cluster_list
    !! which belong to i_cluster
    subroutine get_indices_of_cluster(cluster_list,points,i_cluster)
        implicit none
        integer, dimension(:), intent(in)                 :: cluster_list
        integer, intent(out), allocatable, dimension(:)   :: points
        integer, intent(in)                               :: i_cluster

        integer :: nlive,npoints,j

        nlive = count(cluster_list==i_cluster)

        if(allocated(points)) deallocate(points)

        allocate( points(nlive) )

        npoints=0
        do j=1,size(cluster_list)
            if(cluster_list(j)==i_cluster) then
                npoints = npoints+1
                points(npoints) = j
            end if
        end do

    end subroutine get_indices_of_cluster

end module KNN_clustering

module cluster_module
    use utils_module, only: dp
    implicit none
    contains

    function do_clustering(settings,RTI,sub_dimensions)
        use settings_module,   only: program_settings
        use run_time_module,   only: run_time_info,add_cluster
        use calculate_module,  only: calculate_similarity_matrix
        use KNN_clustering,    only: NN_clustering
        implicit none

        !> Program settings
        type(program_settings), intent(in) :: settings
        !> The evidence storage
        type(run_time_info), intent(inout) :: RTI
        !> Dimensions to cluster on
        integer,dimension(:),optional,intent(in) :: sub_dimensions
        !> Whether or not a cluster has been found
        logical :: do_clustering

        ! Similarity matrix
        real(dp),dimension(sum(RTI%nlive),sum(RTI%nlive)) :: similarity_matrix
        integer,dimension(sum(RTI%nlive)) :: clusters

        integer :: num_clusters
        integer :: num_old_clusters

        ! number of live points
        integer :: nlive

        integer :: i_cluster

        ! Initially no clusters found
        do_clustering=.false.

        ! Get the number of old clusters
        num_old_clusters=RTI%ncluster

        i_cluster = 1
        do while(i_cluster<=num_old_clusters)

            nlive = RTI%nlive(i_cluster) ! Get the number of live points in a temp variable

            if(nlive>2) then
                ! Calculate the similarity matrix for this cluster
                if(present(sub_dimensions)) then
                    similarity_matrix(:nlive,:nlive) =&
                        calculate_similarity_matrix(RTI%live(sub_dimensions,:nlive,i_cluster))
                else
                    similarity_matrix(:nlive,:nlive) =&
                        calculate_similarity_matrix(RTI%live(settings%h0:settings%h1,:nlive,i_cluster))
                end if

                clusters(:nlive) = NN_clustering(similarity_matrix(:nlive,:nlive),num_clusters)

                ! Do clustering on this
                if ( num_clusters>1 ) then
                    ! If we find a cluster
                    do_clustering=.true.

                    ! we split this cluster into n, and put the others at the end
                    call add_cluster(settings,RTI,i_cluster,clusters(:nlive),num_clusters)

                else
                    i_cluster=i_cluster+1
                end if
            else
                i_cluster=i_cluster+1
            end if

        end do

    end function do_clustering

end module cluster_module


      SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB)
      INTEGER LDA,N,IPVT(1),JOB
      DOUBLE PRECISION A(LDA,1),B(1)
C
C     DGESL SOLVES THE DOUBLE PRECISION SYSTEM
C     A * X = B  OR  TRANS(A) * X = B
C     USING THE FACTORS COMPUTED BY DGECO OR DGEFA.
C
C     ON ENTRY
C
C        A       DOUBLE PRECISION(LDA, N)
C                THE OUTPUT FROM DGECO OR DGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM DGECO OR DGEFA.
C
C        B       DOUBLE PRECISION(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0
C        OR DGEFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL DGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL DGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
C
C     SUBROUTINES AND FUNCTIONS
C
C     BLAS DAXPY,DDOT
C
C     INTERNAL VARIABLES
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,L,NM1
C
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL DAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            T = DDOT(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END


      DOUBLE PRECISION FUNCTION QUAGUM(F,PARA)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  QUANTILE FUNCTION OF THE GUMBEL DISTRIBUTION
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(2)
      DATA ZERO/0D0/,ONE/1D0/
      U=PARA(1)
      A=PARA(2)
      IF(A.LE.ZERO)GOTO 1000
      IF(F.LE.ZERO.OR.F.GE.ONE)GOTO 1010
      QUAGUM=U-A*DLOG(-DLOG(F))
      RETURN
C
 1000 WRITE(6,7000)
      QUAGUM=ZERO
      RETURN
 1010 WRITE(6,7010)
      QUAGUM=ZERO
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE QUAGUM : PARAMETERS INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE QUAGUM :',
     *  ' ARGUMENT OF FUNCTION INVALID')
      END


!> Pressure subroutines.
!!
!! @author Prashant Valluri, Lennon O Naraigh, Iain Bethune,
!! Toni Collis, David Scott, Peter Spelt.
!! @copyright (c) 2013-2015, Prashant Valluri, Lennon O Naraigh,
!! Iain Bethune, Toni Collis, David Scott, Peter Spelt.
!! This program is distributed under the BSD License See LICENSE.txt
!! for details.

module pressure

  implicit none

contains

  subroutine get_source_pres(rhs,u3,v3,w3,ex,ey,sx,sy,maxn,dx,dy,dz,dt)

    implicit none

    ! Arguments
    integer,intent(in) :: ex,ey,sx,sy,maxn

    double precision,intent(in) :: dx,dy,dz,dt
    double precision,intent(inout) :: rhs(sx-1:ex+1,sy-1:ey+1,0:maxn)
    double precision,intent(in) :: u3(sx-1:ex+1,sy-1:ey+1,0:maxn-2)
    double precision,intent(in) :: v3(sx-1:ex+1,sy-1:ey+1,0:maxn-2)
    double precision,intent(in) :: w3(sx-1:ex+1,sy-1:ey+1,0:maxn-1)

    ! Local variables
    integer :: i,j,k

    !$omp parallel default(shared), private(i,j,k)

    !$omp workshare
    rhs=0.d0
    !$omp end workshare

    !$omp do
    do k=1,maxn-1
       do j=sy,ey
          do i=sx,ex
             rhs(i,j,k)=((u3(i,j-1,k-1)-u3(i-1,j-1,k-1))/dx)+ ((v3(i,j,k-1)-v3(i,j-1,k-1))/dy)+ &
                  ((w3(i,j-1,k)-w3(i,j-1,k-1))/dz)
          end do
       end do
    end do
    !$omp end do

    !$omp workshare
    rhs=rhs/dt
    !$omp end workshare

    !$omp end parallel

    return
  end subroutine get_source_pres

  subroutine  get_uvw_pres(u3,v3,w3,p,ex,ey,sx,sy,maxn,ex_max,dx,dy,dz,dt,u_inlet)

    implicit none

    ! Arguments
    integer,intent(in) :: ex,ey,sx,sy,maxn,ex_max

    double precision,intent(in) :: dx,dy,dz,dt
    double precision,intent(in) :: p(sx-1:ex+1,sy-1:ey+1,0:maxn)
    double precision,intent(inout) :: u3(sx-1:ex+1,sy-1:ey+1,0:maxn-2)
    double precision,intent(inout) :: v3(sx-1:ex+1,sy-1:ey+1,0:maxn-2)
    double precision,intent(inout) :: w3(sx-1:ex+1,sy-1:ey+1,0:maxn-1)
    double precision,intent(in) :: u_inlet(0:maxn-2)

    ! Local variables
    integer :: i,j,k
    integer :: sx_loc,ex_loc

    if(sx==1)then
       sx_loc=sx-1
    else
       sx_loc=sx
    end if

    if(ex==ex_max)then
       ex_loc=ex+1
    else
       ex_loc=ex
    end if

    !$omp parallel default(shared), private(i,j,k)
    !$omp do
    do k=0,maxn-2
       do j=sy,ey
          do i=sx_loc,ex_loc

             if(i==0)then
                u3(i,j,k)=u_inlet(k)
             elseif(i==ex_max+1)then
                ! last u3 point is completely fictitious and exists only for accounting reasons.
                u3(i,j,k)=0.d0
             else
                u3(i,j,k)=u3(i,j,k)-(dt/dx)*(p(i+1,j+1,k+1)-p(i,j+1,k+1))
             end if

          end do
       end do
    end do
    !$omp end do

    !$omp do
    do k=0,maxn-2
       do j=sy,ey
          do i=sx_loc,ex_loc

             v3(i,j,k)=v3(i,j,k)-(dt/dy)*(p(i,j+1,k+1)-p(i,j,k+1))

          end do
       end do
    end do
    !$omp end do

    !$omp do
    do k=0,maxn-1
       do j=sy,ey
          do i=sx_loc,ex_loc

             w3(i,j,k)=w3(i,j,k)-(dt/dz)*(p(i,j+1,k+1)-p(i,j+1,k))

          end do
       end do
    end do
    !$omp end do
    !$omp end parallel

  end subroutine get_uvw_pres

end module pressure


      subroutine hfti (a,mda,m,n,b,mdb,nb,tau,krank,rnorm,h,g,ip)
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12
c     to appear in 'solving least squares problems', prentice-hall, 1974
c	   solve least squares problem using algorithm, hfti.
c
      dimension a(mda,n),b(mdb,nb),h(n),g(n),rnorm(nb)
      integer ip(n)
      double precision sm,dzero
      szero=0.
      dzero=0.d0
      factor=0.001
c
      k=0
c     1. Set μ := min(m,n).
      ldiag=min0(m,n)
      if (ldiag.le.0) go to 270
c     2. For j := 1 ,..., μ, do Steps 3-12.
	  do 80 j=1,ldiag
c     3. If j = 1 go to Step 7.
	  if (j.eq.1) go to 20
c
c     update squared column lengths and find lmax
c     4. For l := j, ..., n, set h(l) := h(l) - a(j-1,l)^2.
	  lmax=j
	      do 10 l=j,n
	      h(l)=h(l)-a(j-1,l)**2
c     5. Determine λ such that h(λ) := max{h(l): j <= l <= n}.
	      if (h(l).gt.h(lmax)) lmax=l
   10	      continue
c     6. If (hmax + (10^-3)h(λ)) > hmax, go to Step 9.
	  if(diff(hmax+factor*h(lmax),hmax)) 20,20,50
c
c     compute squared column lengths and find lmax
c     7. For l := j, ..., n, set h(l) := sum(a(i,l)^2), j <= i <= m
   20	  lmax=j
	      do 40 l=j,n
	      h(l)=0.
		  do 30 i=j,m
   30		  h(l)=h(l)+a(i,l)**2
c     8. Determine λ such that h(λ) := max{h(l): j <= l <= n}. Set hmax := h(λ)
	      if (h(l).gt.h(lmax)) lmax=l
   40	      continue
	  hmax=h(lmax)
c    ..
c     lmax has been determined
c
c     do column interchanges if needed.
c     9. Set p(j) := λ. If p(j) = j, go to Step 11.
   50	  continue
	  ip(j)=lmax
	  if (ip(j).eq.j) go to 70
c     10. Interchange columns j and λ of A and set h(λ) := h(j)
	      do 60 i=1,m
	      tmp=a(i,j)
	      a(i,j)=a(i,lmax)
   60	      a(i,lmax)=tmp
	  h(lmax)=h(j)
c
c     compute the j-th transformation and apply it to a and b.
c    ..
c       print 69, "call h12(1,", j, ",", j, "+1,", m, ",a(1,", j,       &
c    &   "),1,h(", j, "),a(1,", j, "+1),1,", mda, ",", n, "-", j, ")"
c  69   format(9(A,I3),A)
c     11. Execute algorithm H1(j, j+1, m, a(1,j), h(j), a(1,j+1), n-j).
        do 68 i=1,n
        print 65, h(i)
   65   format(F9.2)
   68   continue

   70	  call h12 (1,j,j+1,m,a(1,j),1,h(j),a(1,j+1),1,mda,n-j)

c       print 69, "call h12(2,", j, ",", j, "+1,", m, ",a(1,", j,       &
c    &   "),1,h(", j, "),b,1,",mdb, ",", mdb, ")"
c  79   format(7(A,I3),A)
c     12. Execute algorithm H2(j, j+1, m, a(1,j), h(j), b, 1).
   80	  call h12 (2,j,j+1,m,a(1,j),1,h(j),b,1,mdb,nb)
c
c     determine the pseudorank, k, using the tolerance, tau.
c     13. The pseudorank k must now be determined. Note that the diagonal
c         elements of R (stored in a(1,1) through a(μ,μ)) are non-
c         increasing in magnitude. For example, the Fortran subroutine
c         HFTI chooses k as the largest index j such that |a(j,j)| > τ.
c         If all |a(j,j)| <= τ, the pseudorank k is set to zero, the
c         solution vector x is set to zero, and the algorithm is
c         terminated.
	  do 90 j=1,ldiag
	  if (abs(a(j,j)).le.tau) go to 100
   90	  continue
      k=ldiag
      go to 110
  100 k=j-1
  110 kp1=k+1
c
c     compute the norms of the residual vectors.
c
      if (nb.le.0) go to 140
	  do 130 jb=1,nb
	  tmp=szero
	  if (kp1.gt.m) go to 130
	      do 120 i=kp1,m
  120	      tmp=tmp+b(i,jb)**2
  130	  rnorm(jb)=sqrt(tmp)
  140 continue
c					    special for pseudorank = 0
      if (k.gt.0) go to 160
      if (nb.le.0) go to 270
	  do 150 jb=1,nb
	      do 150 i=1,n
  150	      b(i,jb)=szero
      go to 270
c
c     if the pseudorank is less than n compute householder
c     decomposition of first k rows.
c     14. If k = n, go to Step 17.
  160 if (k.eq.n) go to 180
c     15. Here, k < n. Next, determine the orthogonal transformations K(i),
c         whose product constitutes K of the equation:
c         [R(1,1):R(1,2)]K = [W: 0]
	  do 170 ii=1,k
	  i=kp1-ii

c       print 169, "call h12(1,", i, ",", kp1,",", n, ",a(", i,         &
c    &   ",1)", mda, ",g(", i, "),a,", mda, ",1,", i, "-1)"
c 169   format(8(A,I3),A)
  170	  call h12 (1,i,kp1,n,a(i,1),mda,g(i),a,mda,1,i-1)
  180 continue
c
c
      if (nb.le.0) go to 270
	  do 260 jb=1,nb
c
c     solve the k by k triangular system.
c    ..
	      do 210 l=1,k
	      sm=dzero
	      i=kp1-l
	      if (i.eq.k) go to 200
	      ip1=i+1
		  do 190 j=ip1,k
  190		  sm=sm+a(i,j)*dble(b(j,jb))
  200	      sm1=sm
  210	      b(i,jb)=(b(i,jb)-sm1)/a(i,i)
c
c     complete computation of solution vector.
c    ..
	  if (k.eq.n) go to 240
	      do 220 j=kp1,n
  220	      b(j,jb)=szero
	      do 230 i=1,k
c           print 169, "call h12(2,", i, ",", kp1,",", n, ",a(", i,     &
c    &      ",1)", mda, ",g(", i, "),b(1,", jb, ",1,", mdb, ",1)"
  230	      call h12 (2,i,kp1,n,a(i,1),mda,g(i),b(1,jb),1,mdb,1)
c
c      re-order the solution vector to compensate for the
c      column interchanges.
c    ..
  240	      do 250 jj=1,ldiag
	      j=ldiag+1-jj
	      if (ip(j).eq.j) go to 250
	      l=ip(j)
	      tmp=b(l,jb)
	      b(l,jb)=b(j,jb)
	      b(j,jb)=tmp
  250	      continue
  260	  continue
c    ..
c     the solution vectors, x, are now
c     in the first  n  rows of the array b(,).
c
  270 krank=k
      return
      end


	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
	REAL XL1(2000),XL2(2000),XL3(2000),XS1(2000),XS2(2000),XS3(2000)
	REAL BUF(12),COEFFS(6,2000),BUFLINE(20000),BUFSAMP(20000)
C								statement func
	XSECT(XL,XLT,XLB,XST,XSB) = ((XLB-XL)*XST + (XL-XLT)*XSB) /
     +				    (XLB-XLT)
C								open input
	CALL XVUNIT(INUNIT,'INP',1,ISTAT,' ')
	CALL XVOPEN(INUNIT,ISTAT,'OPEN_ACT','SA','IO_ACT','SA',' ')
C						    		get size field
	CALL XVSIZE(ISL,ISS,NL,NS,NTRI,NSIN)
	IEL = ISL + NL - 1
C								open output
	CALL XVUNIT(IOUTUNIT,'OUT',1,ISTAT,' ')
	CALL XVOPEN(IOUTUNIT,ISTAT,'OPEN_ACT','SA','IO_ACT','SA',
     +		  'U_NL',NL,'U_NS',NS,'U_NB',2,'U_ORG','BIL',
     +		  'OP','WRITE','O_FORMAT','REAL','U_FORMAT','REAL', ' ')
C								get triangles
	DO I=1,NTRI
	    CALL XVREAD(INUNIT,BUF,ISTAT,' ')
	    XL1(I) = BUF(1)
	    XS1(I) = BUF(2)
	    XL2(I) = BUF(3)
	    XS2(I) = BUF(4)
	    XL3(I) = BUF(5)
	    XS3(I) = BUF(6)
	    COEFFS(1,I) = BUF(7)
	    COEFFS(2,I) = BUF(8)
	    COEFFS(3,I) = BUF(9)
	    COEFFS(4,I) = BUF(10)
	    COEFFS(5,I) = BUF(11)
	    COEFFS(6,I) = BUF(12)
	END DO
C							      build output image
	DO LINE=ISL,IEL
	    XLINE = LINE
	    CALL MVE(7,NS,0.0,BUFLINE,0,1)		! zero out line buffer
	    CALL MVE(7,NS,0.0,BUFSAMP,0,1)		! zero out sample buffer
	    DO I=1,NTRI
		IF (XL1(I) .GT. XLINE) GO TO 500
		IF (XL3(I) .GE. XLINE) THEN
		    A = XSECT(XLINE,XL1(I),XL3(I),XS1(I),XS3(I))
		    IF (XL2(I) .GT. XLINE .OR.
     +		       (XL2(I).EQ.XLINE .AND. XL3(I).EQ.XLINE) ) THEN
			B = XSECT(XLINE,XL1(I),XL2(I),XS1(I),XS2(I))
		    ELSE
			B = XSECT(XLINE,XL2(I),XL3(I),XS2(I),XS3(I))
		    END IF
C					A and B are the sample locations where
C					Line "LINE" intersects triangle "I"
C
		    IST = MAX(MIN(A,B,FLOAT(NS))+1.0, 1.0)
		    LAST = MIN(MAX(A,B,1.0), FLOAT(NS))
		    BUFLINE(IST) = COEFFS(1,I)*XLINE +
     +					 COEFFS(2,I)*IST + COEFFS(3,I)
		    BUFSAMP(IST) = COEFFS(4,I)*XLINE +
     +					 COEFFS(5,I)*IST + COEFFS(6,I)
		    DO J=IST+1,LAST
			BUFLINE(J) = BUFLINE(J-1) + COEFFS(2,I)
			BUFSAMP(J) = BUFSAMP(J-1) + COEFFS(5,I)
		    END DO
		END IF
	    END DO
  500	    CONTINUE
	    CALL XVWRIT(IOUTUNIT,BUFLINE,ISTAT,' ')
	    CALL XVWRIT(IOUTUNIT,BUFSAMP,ISTAT,' ')
	END DO
	RETURN
	END


c
c-----------------------------------------------------------------------
c main program: fastmain  -  fast fourier transforms
c authors:      g. d. bergland and m. t. dolan
c               bell laboratories, murray hill, new jersey 07974
c
c input:        the program calls on a random number
c               generator for input and checks dft and
c               idft with a 32-point sequence
c-----------------------------------------------------------------------
c
      dimension x(32), y(32), b(34)
c
c generate random numbers and store array in b so
c the same sequence can be used in all tests.
c note that b is dimensioned to size n+2.
c
c iw is a machine dependent write device number
c
      iw = i1mach(2)
c
      do 10 i=1,32
        x(i) = uni(0)
        b(i) = x(i)
  10  continue
      m = 5
      n = 2**m
      np1 = n + 1
      np2 = n + 2
      knt = 1
c
c test fast-fsst then ffa-ffs
c
      write (iw,9999)
  20  write (iw,9998) (b(i),i=1,n)
      if (knt.eq.1) call fast(b, n)
      if (knt.eq.2) call ffa(b, n)
      write (iw,9997) (b(i),i=1,np1,2)
      write (iw,9996) (b(i),i=2,np2,2)
      if (knt.eq.1) call fsst(b, n)
      if (knt.eq.2) call ffs(b, n)
      write (iw,9995) (b(i),i=1,n)
      knt = knt + 1
      if (knt.eq.3) go to 40
c
      write (iw,9994)
      do 30 i=1,n
        b(i) = x(i)
  30  continue
      go to 20
c
c test fft842 with real input then complex
c
  40  write (iw,9993)
      do 50 i=1,n
        b(i) = x(i)
        y(i) = 0.
  50  continue
  60  write (iw,9992) (b(i),i=1,n)
      write (iw,9991) (y(i),i=1,n)
      call fft842(0, n, b, y)
      write (iw,9997) (b(i),i=1,n)
      write (iw,9996) (y(i),i=1,n)
      call fft842(1, n, b, y)
      write (iw,9990) (b(i),i=1,n)
      write (iw,9989) (y(i),i=1,n)
      knt = knt + 1
      if (knt.eq.5) go to 80
c
      write (iw,9988)
      do 70 i=1,n
        b(i) = x(i)
        y(i) = uni(0)
  70  continue
      go to 60
c
9999  format (19h1test fast and fsst)
9998  format (20h0real input sequence/(4e17.8))
9997  format (29h0real components of transform/(4e17.8))
9996  format (29h0imag components of transform/(4e17.8))
9995  format (23h0real inverse transform/(4e17.8))
9994  format (17h1test ffa and ffs)
9993  format (37h1test fft842 with real input sequence/(4e17.8))
9992  format (34h0real components of input sequence/(4e17.8))
9991  format (34h0imag components of input sequence/(4e17.8))
9990  format (37h0real components of inverse transform/(4e17.8))
9989  format (37h0imag components of inverse transform/(4e17.8))
9988  format (40h1test fft842 with complex input sequence)
  80  stop
      end


      double complex function cli2(x)
c--complex dilogarithm (spence-function)
      implicit double precision (a-h,o-z)
      double complex x,y,li2taylor
      double precision zeta2,zeta3
      common/const/zeta2,zeta3
      logical first
      data first/.true./
      save first

      if (first) then
      first=.false.
      call bernini
      endif

      zero=1.d-8
      xr=dble(x)
      xi=dimag(x)
      r2=xr*xr+xi*xi
      cli2=dcmplx(0d0,0d0)
      if(r2.le.zero)then
        cli2=x+x**2/4.d0
        return
      endif
      rr=xr/r2
      if ((r2.eq.1.d0) .and. (xi.eq.0.d0)) then
        if (xr.eq.1.d0) then
          cli2=dcmplx(zeta2)
        else
          cli2=-dcmplx(zeta2/2.d0)
        endif
        return
      elseif ((r2.gt.1.d0) .and. (rr.gt.0.5d0)) then
        y=(x-1.d0)/x
        cli2=li2taylor(y)+zeta2-cdlog(x)*cdlog(1.d0-x)+0.5d0*cdlog(x)**2
        return
      elseif ((r2.gt.1.d0) .and. (rr.le.0.5d0))then
        y=1.d0/x
        cli2=-li2taylor(y)-zeta2-0.5d0*cdlog(-x)**2
        return
      elseif ((r2.le.1.d0) .and. (xr.gt.0.5d0)) then
        y=1.d0-x
        cli2=-li2taylor(y)+zeta2-cdlog(x)*cdlog(1.d0-x)
       return
      elseif ((r2.le.1.d0) .and. (xr.le.0.5d0)) then
        y=x
        cli2=li2taylor(y)
        return
      endif
      end

      double complex function li2taylor(x)
c--taylor-expansion for complex dilogarithm (spence-function)
      implicit double precision (a-h,o-z)
      parameter(nber=18)
      double precision b2(nber)
      double complex x,z
      common/bernoulli/b2

      n=nber-1
      z=-cdlog(1.d0-x)
      li2taylor=b2(nber)
      do 111 i=n,1,-1
        li2taylor=z*li2taylor+b2(i)
111   continue
      li2taylor=z**2*li2taylor+z
      return
      end

      double precision function facult(n)
c--double precision version of faculty
      implicit double precision (a-h,o-z)
      facult=1.d0
      if(n.eq.0)return
      do 999 i=1,n
        facult=facult*dfloat(i)
999   continue
      return
      end

      subroutine bernini
c--initialization of coefficients for polylogarithms
      implicit none
      include 'constants.f'
      integer nber,i
      parameter(nber=18)
      double precision b(nber),b2(nber),zeta2,zeta3,facult
      common/bernoulli/b2
      common/const/zeta2,zeta3

      b(1)=-1.d0/2.d0
      b(2)=1.d0/6.d0
      b(3)=0.d0
      b(4)=-1.d0/30.d0
      b(5)=0.d0
      b(6)=1.d0/42.d0
      b(7)=0.d0
      b(8)=-1.d0/30.d0
      b(9)=0.d0
      b(10)=5.d0/66.d0
      b(11)=0.d0
      b(12)=-691.d0/2730.d0
      b(13)=0.d0
      b(14)=7.d0/6.d0
      b(15)=0.d0
      b(16)=-3617.d0/510.d0
      b(17)=0.d0
      b(18)=43867.d0/798.d0
      zeta2=pi**2/6.d0
      zeta3=1.202056903159594d0

      do 995 i=1,nber
        b2(i)=b(i)/facult(i+1)
995   continue

      return
      end


      SUBROUTINE NOONMID1(T50,POS,VEL,KCOORD,
     *    TPNOON,TPMIDNT,TNNOON,TNMIDNT,KALGOR,NOWSTAT,LUERR,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C GIVEN A TIME AND A S/C STATE VECTOR, THIS ROUTINE COMPUTES THE
C TIMES OF THE PREVIOUS AND NEXT NOON AND MIDNIGHT. ANALYTICAL
C EXPRESSIONS ARE USED WITH THE SUN FIXED AT T50 AND KEPLERIAN MOTION
C ASSUMED.
C
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C T50       1   R*8  I  THE TIME FOR WHICH THE S/C STATE IS SUPPLIED.
C                       IN SECONDS SINCE 1/1/50, 0.0 HRS
C
C                       'PREVIOUS' NOON/MIDNIGHT MEANS EARLIER THAN T50,
C                       'NEXT' MEANS AFTER.
C
C POS       3   R*8  I  THE S/C POSITION VECTOR AT TIME T50. IN KM.
C
C VEL       3   R*8  I  THE S/C VELOCITY VECTOR AT TIME T50. IN KM.
C
C KCOORD    1   I*4  I  FLAG INDICATING THE COORDINATE SYSTEM IN WHICH
C                       POS AND VEL ARE EXPRESSED.
C
C                        = 1, GEOCENTRIC, MEAN EQTR AND EQNX OF 1950.0
C                        = 2, GEOCENTRIC, MEAN EQTR AND EQNX OF DATE
C                        = 3, GEOCENTRIC, TRUE EQTR AND EQNX OF DATE
C                        = OTHERWISE, ERROR. IERR = 1 IS SET.
C
C TPNOON    1  R*8   O  TIME OF THE PREVIOUS NOON. IN SECONDS SINCE
C                       1/1/50, 0.0 HRS.
C
C TPMIDNT   1  R*8   O  TIME OF THE PREVIOUS MIDNIGHT. IN SECONDS SINCE
C                       1/1/50, 0.0 HRS.
C
C TNNOON    1  R*8   O  TIME OF THE NEXT NOON. IN SECONDS SINCE
C                       1/1/50, 0.0 HRS.
C
C TNMIDNT   1  R*8   O  TIME OF THE NEXT MIDNIGHT. IN SECONDS SINCE
C                       1/1/50, 0.0 HRS.
C
C KALGOR    1  I*4   I  FLAG DEFINING THE MEANING OF NOON AND MIDNIGHT.
C
C                       =1, NOON IS HALFWAY IN TIME BETWEEN SUNRISE
C                           AND SUNSET. MIDNIGHT IS HALFWAY IN TIME
C                           BETWEEN SUNSET AND SUNRISE.
C                       = OTHERWISE, ERROR. AUTOMATIC PROGRAM STOP.
C
C NOWSTAT   1  I*4   O  DAY/NIGHT STATUS AT TIME T50.
C
C                       = 1, IN FULL SUN OR PENUMBRA(=PART SHADOW)
C                       = 2, IN UMBRA(=FULL SHADOW)
C
C LUERR     1  I*4   I  FORTRAN UNIT NUMBER FOR ERROR MESSAGES.
C
C IERR      1  I*4   O  ERROR RETURN FLAG.
C
C                       = 0, NO ERROR.
C
C                       =-1, MINOR ERROR. S/C DOES NOT HAVE ORBIT NIGHT,
C                            AT LEAST NOT WITHIN ONE ORBITAL PERIOD OF
C                            T50. OUTPUT TIMES SET TO T50.
C
C                       = 1, MAJOR ERROR. DO NOT USE RESULTS. ALL OTHER
C                            OUTPUT QUANTITIES SET TO ZERO.
C
C***********************************************************************
C
C BY C PETRUZZO, GSFC/742. 5/85
C      MODIFIED.....
C
C***********************************************************************
C
      REAL*8 POS(3),VEL(3)
C
      IBUG = 0
      LUBUG = 19
C
C THERE IS ONLY ONE DEFINITION CURRENTLY AVAILABLE FOR NOON AND
C MIDNIGHT. FUTURE MODS WILL ALLOW OTHER DEFINITIONS.
C
      IF(KALGOR.NE.1) STOP 'NOONMID1 ERROR END. SEE CODE.'
C
C
C INITIALIZE
C
      IERR = 0
      ERTHMU = CONST(56)
      PD = PERIOD(ERTHMU,POS,VEL)
C
C
C GET THE APPROX TIMES OF THE PREVIOUS AND NEXT SUNRISES AND
C SUNSETS, AND THE DAY/NIGHT STATUS AT T50. THE SUN POSITION IS FIXED
C AT TIME T50.
C
      CALL TSHADOW1(T50,POS,VEL,KCOORD,
     *       TPRISE,TPSET,TNRISE,TNSET,NOWSTAT,LUERR,IER1)
      IF(IER1.NE.0) THEN  ! -1= NO ORBIT NIGHT, +1= MAJOR ERROR.
        IERR = IER1
        IF(IERR.EQ.1) THEN
          IF(LUERR.GT.0) WRITE(LUERR,1001)
 1001     FORMAT(/,' NOONMID1. ERROR RETURN FROM TSHADOW1.')
          END IF
        GO TO 9999
        END IF
C
C
C SET THE OUTPUT TIMES.
C
      IF(KALGOR.EQ.1) THEN
        IF(NOWSTAT.EQ.1) THEN   ! IN ORBIT DAY
          TNMIDNT = (TNSET + TNRISE) / 2.D0
          TPMIDNT = (TPSET + TPRISE) / 2.D0
          TEMP = (TPRISE + TNSET) / 2.D0
          IF(T50.LT.TEMP) THEN
            TNNOON = TEMP
            TPNOON = TNNOON - PD
          ELSE
            TPNOON = TEMP
            TNNOON = TPNOON + PD
            END IF
        ELSE                    ! IN ORBIT NIGHT
          TNNOON = (TNRISE + TNSET) / 2.D0
          TPNOON = (TPRISE + TPSET) / 2.D0
          TEMP = (TPSET + TNRISE) / 2.D0
          IF(T50.LT.TEMP) THEN
            TNMIDNT = TEMP
            TPMIDNT = TEMP - PD
          ELSE
            TPMIDNT = TEMP
            TNMIDNT = TEMP + PD
            END IF
          END IF
        END IF
C
C
 9999 CONTINUE
C
C WRAP IT UP
C
      IF(IERR.EQ.0) THEN             ! NO ERRORS
        CONTINUE
      ELSE IF(IERR.EQ.-1) THEN       ! NO ORBIT NIGHT
        NOWSTAT = 1
        TPNOON =  T50
        TPMIDNT = T50
        TNNOON =  T50
        TPMIDNT = T50
      ELSE IF(IERR.EQ.1) THEN        ! MAJOR ERROR
        NOWSTAT = 0
        TPNOON =  0.D0
        TPMIDNT = 0.D0
        TNNOON =  0.D0
        TPMIDNT = 0.D0
      ELSE
        STOP 'NOONMID1 CODING ERROR. BAD IERR VALUE. STOP.'
        END IF
C
      RETURN
      END


      SUBROUTINE INTH (DP,DQ,DV,DR)
!
! INTEGRATION PAR LA METHODE DE ADAMS A 5 POINTS DE LA GRANDE COMPOSANTE
! DP ET DE LA PETITE COMPOSANTE DQ AU POINT DR,DV ETANT LE POTENTIEL EN
! CE POINT
! **********************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
!     IMPLICIT REAL (D)
      COMMON/PS1/DEP(5),DEQ(5),DB,DVC,DSAL,DK,DM
      save  /PS1/
!
! DEP,DEQ DERIVEES DE DP ET DQ   DB=ENERGIE/DVC    DVC VITESSE DE LA
! LUMIERE EN U.A.   DSAL=2.*DVC   DK NOMBRE QUANTIQUE KAPPA
! DM=PAS EXPONENTIEL/720.
! DKOEF1=405./502., DKOEF2=27./502.
! *********************************************************************
      DATA DKOEF1/.9462151394422310D0/,DKOEF2/.5378486055776890D-1/

      DPR=DP+DM*((251.*DEP(1)+2616.*DEP(3)+1901.*DEP(5))-(1274.*DEP(2)+2774.*DEP(4)))
      DQR=DQ+DM*((251.*DEQ(1)+2616.*DEQ(3)+1901.*DEQ(5))-(1274.*DEQ(2)+2774.*DEQ(4)))

      DO 13 I=2,5
      DEP(I-1)=DEP(I)
 13   DEQ(I-1)=DEQ(I)

      DSUM=(DB-DV/DVC)*DR

      DEP(5)=-DK*DPR + (DSAL*DR+DSUM)*DQR
      DEQ(5)= DK*DQR -  DSUM*DPR

      DP=DP+DM*((106.*DEP(2)+646.*DEP(4)+251.*DEP(5))-(19.*DEP(1)+264.*DEP(3)))
      DQ=DQ+DM*((106.*DEQ(2)+646.*DEQ(4)+251.*DEQ(5))-(19.*DEQ(1)+264.*DEQ(3)))
      DP = DKOEF1 * DP + DKOEF2 * DPR
      DQ = DKOEF1 * DQ + DKOEF2 * DQR
      DEP(5) = -DK * DP + (DSAL*DR+DSUM)*DQ
      DEQ(5) =  DK * DQ - DSUM * DP
      RETURN
      END


SUBROUTINE SS_2TrigLinear(eNum)
   USE PrecTypes
   USE GlobalData
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! NAME:   SS_2TrigLinear
   ! PARENT: StressStrain
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Calculate strain, stress components, and von Mises stress for a
   !         trianglular linear element.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER, INTENT(IN) :: eNum         ! element number
   REAL(dp) :: dudx, dudy              ! displacement gradients
   REAL(dp) :: dvdx, dvdy              ! displacement gradients
   REAL(dp) :: u1,v1                   ! displacement components of point 1 of the triangle
   REAL(dp) :: u2,v2                   ! displacement components of point 2 of the triangle
   REAL(dp) :: u3,v3                   ! displacement components of point 3 of the triangle
   REAL(dp) :: a1, a2, a3
   REAL(dp) :: b1, b2, b3
   REAL(dp) :: c1, c2, c3
   REAL(dp) :: Delta, Delta2
   REAL(dp) :: coef, coef2
   REAL(dp) :: Yng, Pssn, a            ! Young's modulus, Poisson's ratio, linear thermal expansion coefficient of this element
   INTEGER  :: n1, n2, n3              ! Node numbers defining the element
   REAL(dp) :: x1, y1, x2, y2, x3, y3
   REAL(dp) :: xg, yg, Tg              ! The coordinates and the temperature of the center of geometry of the element
   REAL(dp) :: ex, ey, exy             ! Direct strains in x and y directions and engineering shear strain
   REAL(dp) :: sx, sy, sxy, sz         ! Direct stresses in x and y directions and shear stress

   Yng  = E( emtype(eNum) )            ! Young's modulus
   Pssn = v( emtype(eNum) )            ! Poisson's ratio

   IF (pcode == 3) a = alpha( emtype(eNum) )    ! Linear thermal expansion coefficient

   n1 = elm(eNum,1)
   n2 = elm(eNum,2)
   n3 = elm(eNum,3)

   ! The coordinates of node 1 of the triangular element
   x1 = x( n1 )
   y1 = y( n1 )

   ! The coordinates of node 2 of the triangular element
   x2 = x( n2 )
   y2 = y( n2 )

   ! The coordinates of node 3 of the triangular element
   x3 = x( n3 )
   y3 = y( n3 )

   a1 = x2*y3 - x3*y2;   b1 = y2 - y3;   c1 = x3 - x2
   a2 = x3*y1 - x1*y3;   b2 = y3 - y1;   c2 = x1 - x3
   a3 = x1*y2 - x2*y1;   b3 = y1 - y2;   c3 = x2 - x1

   Delta2 = a1 + a2 + a3     ! Twice of the area of the triangular element
   Delta  = Delta2 * 0.5_dp  ! Area of the triangular element

   ! Displacement components of each vertex point of the triangle
   u1 = u(n1,1)
   v1 = u(n1,2)
   u2 = u(n2,1)
   v2 = u(n2,2)
   u3 = u(n3,1)
   v3 = u(n3,2)

   dudx = (b1*u1 + b2*u2 + b3*u3) / Delta2
   dvdy = (c1*v1 + c2*v2 + c3*v3) / Delta2
   dudy = (c1*u1 + c2*u2 + c3*u3) / Delta2
   dvdx = (b1*v1 + b2*v2 + b3*v3) / Delta2

   ! Strain components
   strain(eNum,1,1) = dudx
   strain(eNum,1,2) = dvdy
   strain(eNum,1,3) = dudy + dvdx

   ex  = strain(eNum,1,1)
   ey  = strain(eNum,1,2)
   exy = strain(eNum,1,3)

   ! Stress components
   coef  = Yng / (1.0_dp - 2.0_dp*Pssn)                        !  <=  E / (1-2v)
   coef2 = coef / (1.0_dp+Pssn)                                !  <=  E / ((1-2v)*(1+v))
   stress(eNum,1,1) = coef2 * ( (1.0_dp-Pssn)*ex + Pssn*ey )
   stress(eNum,1,2) = coef2 * ( Pssn*ex + (1.0_dp-Pssn)*ey )
   stress(eNum,1,3) = 0.5_dp * Yng / (1.0_dp+Pssn) * exy

   ! Ou-of-plane stress σz is also calculated for plane strain case.
   IF (plane == 1) THEN
      stress(eNum,1,4) = coef2*Pssn*(ex+ey)
   END IF

   ! -------------------------------------------------
   ! Effect of the thermal strain is also added for linear thermoelastic problems
   IF (pcode == 3) THEN
      xg = (x1 + x2 + x3)/3.0_dp
      yg = (y1 + y2 + y3)/3.0_dp
      Tg = T(n1)*(a1 + b1*xg + c1*yg) &
         + T(n2)*(a2 + b2*xg + c2*yg) &
         + T(n3)*(a3 + b3*xg + c3*yg)
      Tg = Tg / Delta2
      stress(eNum,1,1) = stress(eNum,1,1) - a*coef*Tg
      stress(eNum,1,2) = stress(eNum,1,2) - a*coef*Tg

      ! For plane strain case, the effect of the thermal strain to the out-of-plane stress is calculated.
      IF (plane == 1) THEN
         stress(eNum,1,4) = stress(eNum,1,4) - a*coef*Tg
      END IF
   END IF

   ! -------------------------------------------------
   ! Out-of-plane strain εz is also calculated for plane stress case.
   IF (plane == 2) THEN

      !　εz = - v/(1-2v) *（εx＋εy）
      coef = Pssn/(1.0_dp - 2.0_dp*Pssn)
      strain(eNum,1,4) = - coef * (strain(eNum,1,1) + strain(eNum,1,2))

      IF (pcode == 3) THEN
         xg = (x1 + x2 + x3)/3.0_dp
         yg = (y1 + y2 + y3)/3.0_dp
         Tg = T(n1)*(a1 + b1*xg + c1*yg) &
            + T(n2)*(a2 + b2*xg + c2*yg) &
            + T(n3)*(a3 + b3*xg + c3*yg)
         Tg = Tg / Delta2
         !　εz = - v/(1-2v) *（εx＋εy）+ (1+v)/(1-2v)*α*T
         strain(eNum,1,4) = strain(eNum,1,4) + (1.0_dp+Pssn)/(1-2.0_dp*Pssn)*a*Tg
      END IF

   END IF

   ! von Mises stress
   ! Plane strain case
   IF (plane==1) THEN
         sx  = stress(eNum,1,1)
         sy  = stress(eNum,1,2)
         sxy = stress(eNum,1,3)
         sz  = stress(eNum,1,4)
         Mises(eNum,1) = sx*sx+sy*sy+sz*sz+3.0_dp*sxy*sxy-sx*sy-sx*sz-sy*sz
         Mises(eNum,1) = sqrt( Mises(eNum,1) )
   ! Plane stress case
   ELSE IF (plane==2) THEN
         sx  = stress(eNum,1,1)
         sy  = stress(eNum,1,2)
         sxy = stress(eNum,1,3)
         Mises(eNum,1) = sx*sx+sy*sy+3.0_dp*sxy*sxy-sx*sy
         Mises(eNum,1) = sqrt( Mises(eNum,1) )
   END IF

   RETURN
END SUBROUTINE SS_2TrigLinear


module inputs
!Inputs to the program.

implicit none

	!m_1(2) = Mass of nucleon 1(2) in MeV
	real(8), parameter, public :: m_1 = 938.926d0
	real(8), parameter, public :: m_2 = 938.926d0

	!q = |q| Momentum variable.
	!n_theta = Number of Gauss-Legendre nodes to evaluate V (the potential) at i.e. the "b" in Ax = b.
	!T = Isospin. The value is 0 or 1
	real(8), parameter, public :: q = 375.2851d0
	integer, parameter, public :: n_theta = 40
	integer, parameter, public :: T = 1

	!Pcm = bvec{P}-->P z-hat. By definition it's one half the CM momentum.
	!k_fermi = The Fermi momentum. Units are [fm^(-1)]
	!Q_pauli = 0 for medium and 1 for free space.
	real(8), parameter, public :: Pcm = q
	real(8), parameter, public :: k_fermi = 1.4d0
	real(8), parameter, public :: Q_pauli = 0.0d0

	!n_V_avg = Number of integrating nodes for the phi integrated potential on [0,2pi].
	!n_0_2q,n_2q_inf = Number of integrating nodes for the integral over momentum (k variable). The interval is [0,2q] and [2q,inf] respectivly.
	!	See Eq. 15 of T matrix rev. report. **MAKE SURE n_0_2q IS EVEN**
	!n_theta_k = Number of integrating nodes for the integral over momentum (theta_k) space on [0,pi].
	integer, parameter, public :: n_V_avg = 20
	integer, parameter, public :: n_0_2q = 30
	integer, parameter, public :: n_2q_inf = 100
	integer, parameter, public :: n_theta_k = 80

	!Cutoff_inf = Value for infinity i.e. the [2q,infinity] integral.
	real(8), parameter, public :: cutoff_inf = 2000.0d0

end module


program get_lists
    character(len=100) :: fileBase,fileExt,fCount,fileName
    integer :: i
    real(8) :: rN

    fileBase="newfile_"
    fileExt=".dat"

    do i=1, 20
        if (i < 9) then !change this as required valid for numbers below 99!
            fCount = "(A8,I1)"
!since there are 8 characters in name of my file base so I used A8
        else
            fCount = "(A8,I2)"
        endif
	write (fileBase,fCount) fileBase,i
        fileName=trim(fileBase) // fileExt
        print *, " ", fileName   !if required
	open(1, file=fileName)
	CALL RANDOM_NUMBER(rN)
!if you want to see the value of random number
print*,rN

	write(1,*) rN
	close(1)
    enddo

end program get_lists

! compile using gfortran getlists.f90 -o getlists.exe
! run using ./getlists.exe


PROGRAM t_random

!     Test of module RANDOM
!     Latest revision - 4 January 1999
!     Programmer - Alan.Miller @ vic.cmis.csiro.au

USE random

IMPLICIT NONE

CHARACTER (LEN = 2)   :: option
INTEGER, ALLOCATABLE  :: ix(:), seed(:)
REAL, ALLOCATABLE     :: x(:), xmean(:), cov(:), chol_f(:)
INTEGER               :: i, n, ndf, n_binom, k, ier, pos1, pos2, which
REAL                  :: average, stdvn, shape, a, b, mu, p, pop_mean, pop_sd,   &
                         one = 1.0, zero = 0.0, sk, two = 2.0, pcntile(9), &
                         middle, xmax, xmin
LOGICAL               :: first

INTERFACE
  SUBROUTINE statistics(x, n, mean, median, xmax, xmin, stdev, percentile)
    IMPLICIT NONE
    INTEGER, INTENT(IN)         :: n
    REAL, INTENT(IN)            :: x(n)
    REAL, OPTIONAL, INTENT(OUT) :: mean, median, xmax, xmin, stdev, percentile(9)
  END SUBROUTINE statistics
END INTERFACE

!     Set the random number seed.

CALL RANDOM_SEED(size=k)
ALLOCATE (seed(k))
WRITE(*, '(1x, a, i4, a)') 'Enter ', k, ' integers as random number seeds: '
READ(*, *) seed
CALL RANDOM_SEED(put=seed)

DO
  WRITE(*, *)' 1.  Normal (Gaussian)                  2.  Gamma'
  WRITE(*, *)' 3.  Exponential                        4.  Beta'
  WRITE(*, *)' 5.  t                                  6.  Multivariate normal'
  WRITE(*, *)' 7.  Generalized inverse Gaussian       8.  Poisson'
  WRITE(*, *)' 9.  Binomial                          10.  Negative binomial'
  WRITE(*, *)'11.  von Mises                         12.  Cauchy'
  WRITE(*, *)'13.  Weibull                           14.  Chi-squared'
  WRITE(*, *)'15.  Random order of integers'
  WRITE(*, *)
  WRITE(*, *)' Q   Quit'
  WRITE(*, *)
  WRITE(*, *)'            Enter your choice: '
  READ(*, '(a)') option

  option = ADJUSTL(option)
  IF (option .EQ. 'q ' .OR. option .EQ. 'Q ') STOP

  SELECT CASE (option)
    CASE ('1 ')
      WRITE(*, *) 'Distribution:  Normal (Gaussian)'
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      DO i = 1, n
        x(i) = random_normal()
      END DO
      CALL statistics(x, n, average, middle, xmax, xmin, stdvn, pcntile)
      WRITE(*, '(1x, a, f9.4, 2x, a, f9.4, 2x, a, f9.4)')                    &
               'Mean = ', average, 'Median = ', middle, 'Sample st.dev. = ', stdvn
      WRITE(*, '(1x, a, f9.4, 2x, a, f9.4)')                                 &
               'Smallest x = ', xmin, 'Largest x = ', xmax
      WRITE(*, 900) pcntile
      900 FORMAT("     10%     20%     30%     40%     50%     60%     70%     80%     90% "/ &
                 9f8.2)
      WRITE(*, *)
      DEALLOCATE (x)

    CASE ('2 ')
      WRITE(*, *) 'Distribution:  Gamma'
      WRITE(*, *) 'Enter +ve value for shape parameter: '
      READ(*, *) shape
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      first = .true.
      DO i = 1, n
        x(i) = random_gamma(shape, first)
        first = .false.
      END DO
      CALL statistics(x, n, average, middle, stdev=stdvn)
      DEALLOCATE (x)
      WRITE(*, *)'Mean = ', average, '  Median = ', middle, '  Std.devn. = ', stdvn
      pop_mean = shape
      pop_sd = SQRT(shape)
      WRITE(*, '(1x, a, 2g14.6)') 'Population mean & st.devn. = ', pop_mean,  &
                                   pop_sd
      WRITE(*, *)

    CASE ('3 ')
      WRITE(*, *) 'Distribution:  Exponential'
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      DO i = 1, n
        x(i) = random_exponential()
      END DO
      CALL statistics(x, n, average, stdev=stdvn, percentile=pcntile)
      DEALLOCATE (x)
      WRITE(*, *)'Mean = ', average, '  Std.devn. = ', stdvn
      pop_mean = one
      pop_sd = one
      WRITE(*, '(1x, a, 2g14.6)') 'Population mean & st.devn. = ', pop_mean,  &
                                   pop_sd
      WRITE(*, 900) pcntile
      WRITE(*, *)

    CASE ('4 ')
      WRITE(*, *) 'Distribution:  Beta'
      WRITE(*, *) 'Enter values of a, b: '
      READ(*, *) a, b
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      first = .true.
      DO i = 1, n
        x(i) = random_beta(a, b, first)
        first = .false.
      END DO
      CALL statistics(x, n, average, stdev=stdvn, percentile=pcntile)
      DEALLOCATE (x)
      WRITE(*, *)'Mean = ', average, '  Std.devn. = ', stdvn
      pop_mean = a/(a+b)
      pop_sd = SQRT(a*b/(a+b+1)) / (a+b)
      WRITE(*, '(1x, a, 2g14.6)') 'Population mean & st.devn. = ', pop_mean,  &
                                   pop_sd
      WRITE(*, 900) pcntile
      WRITE(*, *)

    CASE ('5 ')
      WRITE(*, *) 'Distribution:  t'
      WRITE(*, *) 'How many degrees of freedom?: '
      READ(*, *) ndf
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      DO i = 1, n
        x(i) = random_t(ndf)
      END DO
      CALL statistics(x, n, average, stdev=stdvn, percentile=pcntile)
      DEALLOCATE (x)
      WRITE(*, *)'Mean = ', average, '  Std.devn. = ', stdvn
      IF (ndf .GT. 2) THEN
        pop_mean = zero
        pop_sd = SQRT(ndf / REAL(ndf-2))
        WRITE(*, '(a, 2g14.6)') ' Population mean & st.devn. = ', pop_mean, &
                                pop_sd
      END IF
      WRITE(*, 900) pcntile
      WRITE(*, *)

    CASE ('6 ')
      WRITE(*, *) 'Distribution:  Multivariate normal'
      WRITE(*, *) 'Enter no. of variables: '
      READ(*, *) k
      n = k*(k+1)/2
      ALLOCATE ( x(k), xmean(k), cov(n), chol_f(n) )
      WRITE(*, *) 'Enter means of the variables: '
      READ(*, *) xmean
      WRITE(*, *) 'Enter the covariance matrix, row-by-row'
      pos2 = 0
      DO i = 1, k
        pos1 = pos2 + 1
        pos2 = pos2 + i
        WRITE(*, '(1x, a, i2, a, i2, a, i2, a)') 'Row ', i, ' Columns ', 1,   &
                                                 ' - ', i, ' : '
        READ(*, *) cov(pos1:pos2)
      END DO
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      first = .true.
      DO i = 1, n
        CALL random_mvnorm(k, xmean, cov, chol_f, first, x, ier)
        IF (ier .NE. 0) THEN
          WRITE(*, *) '** Covariance matrix is not +ve definite **'
          EXIT
        END IF
        first = .false.
        WRITE(*, '(1x, i5, 10f7.3/ (6x, 10f7.3))') i, x
      END DO
      DEALLOCATE (x, xmean, cov, chol_f)
      WRITE(*, *)

    CASE ('7 ')
      WRITE(*, *) 'Distribution:  Generalized inverse Gaussian'
      WRITE(*, *) 'Enter values of h, b: '
      READ(*, *) a, b
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      first = .true.
      DO i = 1, n
        x(i) = random_inv_gauss(a, b, first)
        first = .false.
      END DO
      CALL statistics(x, n, average, stdev=stdvn, percentile=pcntile)
      DEALLOCATE (x)
      WRITE(*, *)'Mean = ', average, '  Std.devn. = ', stdvn
      WRITE(*, 900) pcntile
      WRITE(*, *)

    CASE ('8 ')
      WRITE(*, *) 'Distribution:  Poisson'
      WRITE(*, *) 'Enter +ve value for mean: '
      READ(*, *) mu
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      first = .true.
      DO i = 1, n
        x(i) = random_Poisson(mu, first)
        first = .false.
      END DO
      CALL statistics(x, n, average, middle, xmax, xmin, stdvn, pcntile)
      DEALLOCATE (x)
      WRITE(*, *)'Mean = ', average, '  Std.devn. = ', stdvn
      pop_mean = mu
      pop_sd = SQRT(mu)
      WRITE(*, '(1x, a, 2g14.6)') 'Population mean & st.devn. = ', pop_mean,  &
                                   pop_sd
      WRITE(*, '(1x, a, f9.4, 2x, a, f9.4)')                                 &
               'Smallest x = ', xmin, 'Largest x = ', xmax
      WRITE(*, 900) pcntile
      WRITE(*, *)

    CASE ('9 ')
      WRITE(*, *) 'Distribution:  Binomial'
      DO
        WRITE(*, *) 'Enter 1 or 2: '
        READ(*, *) which
        IF (which == 1 .OR. which == 2) EXIT
      END DO
      WRITE(*, *) 'Enter parameters N & p: '
      READ(*, *) n_binom, p
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      first = .true.
      IF (which == 1) THEN
        DO i = 1, n
          x(i) = random_binomial1(n_binom, p, first)
          first = .false.
        END DO
      ELSE
        DO i = 1, n
          x(i) = random_binomial2(n_binom, p, first)
          first = .false.
        END DO
      END IF
      CALL statistics(x, n, average, middle, xmax, xmin, stdvn, pcntile)
      DEALLOCATE (x)
      WRITE(*, *)'Mean = ', average, '  Std.devn. = ', stdvn
      pop_mean = n_binom * p
      pop_sd = SQRT(pop_mean * (one-p))
      WRITE(*, '(1x, a, 2g14.6)') 'Population mean & st.devn. = ', pop_mean,  &
                                   pop_sd
      WRITE(*, '(1x, a, f9.4, 2x, a, f9.4)')                                 &
               'Smallest x = ', xmin, 'Largest x = ', xmax
      WRITE(*, 900) pcntile
      WRITE(*, *)

    CASE ('10')
      WRITE(*, *) 'Distribution:  Negative binomial'
      WRITE(*, *) 'Enter parameters k & p: '
      READ(*, *) sk, p
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      first = .true.
      DO i = 1, n
        x(i) = random_neg_binomial(sk, p)
        first = .false.
      END DO
      CALL statistics(x, n, average, middle, xmax, xmin, stdvn, pcntile)
      DEALLOCATE (x)
      WRITE(*, *)'Mean = ', average, '  Std.devn. = ', stdvn
      pop_mean = sk * p / (one-p)
      pop_sd = SQRT(pop_mean / (one-p))
      WRITE(*, '(1x, a, 2g14.6)') 'Population mean & st.devn. = ', pop_mean,  &
                                   pop_sd
      WRITE(*, '(1x, a, f9.4, 2x, a, f9.4)')                                 &
               'Smallest x = ', xmin, 'Largest x = ', xmax
      WRITE(*, 900) pcntile
      WRITE(*, *)

    CASE ('11')
      WRITE(*, *) 'Distribution:  von Mises'
      WRITE(*, *) 'Enter +ve value for scale parameter: '
      READ(*, *) sk
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      first = .true.
      DO i = 1, n
        x(i) = random_von_Mises(sk, first)
        first = .false.
      END DO
      CALL statistics(x, n, average, middle, xmax, xmin, stdvn, pcntile)
      DEALLOCATE (x)
      WRITE(*, '(1x, a, f9.4, 2x, a, f9.4, 2x, a, f9.4)')                    &
               'Mean = ', average, 'Median = ', middle, 'Sample st.dev. = ', stdvn
      WRITE(*, '(1x, a, f9.4, 2x, a, f9.4)')                                 &
               'Smallest x = ', xmin, 'Largest x = ', xmax
      WRITE(*, 900) pcntile
      WRITE(*, *)

    CASE ('12')
      WRITE(*, *) 'Distribution: Cauchy'
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE ( x(n) )
      DO i = 1, n
        x(i) = random_Cauchy()
      END DO
      CALL statistics(x, n, average, middle, xmax, xmin, percentile=pcntile)
      WRITE(*, '(1x, a, f9.4, 2x, a, f9.4)')                                 &
               'Mean = ', average, 'Median = ', middle
      WRITE(*, '(1x, a, f9.4, 2x, a, f9.4)')                                 &
               'Smallest x = ', xmin, 'Largest x = ', xmax
      WRITE(*, 900) pcntile
      WRITE(*, *)
      DEALLOCATE ( x )

    CASE ('13')
      WRITE(*, *) 'Distribution:  Weibull'
      WRITE(*, *) 'Enter +ve value for scale parameter: '
      READ(*, *) sk
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE (x(n))
      DO i = 1, n
        x(i) = random_Weibull(sk)
      END DO
      CALL statistics(x, n, average, middle, stdev=stdvn)
      DEALLOCATE (x)
      WRITE(*, *)'Mean = ', average, '  Median = ', middle, '  Std.devn. = ', stdvn
      pop_mean = EXP( lngamma( DBLE(one/sk + one) ) )
      pop_sd = SQRT( lngamma( DBLE(two/sk + one) - pop_mean**2) )
      WRITE(*, '(1x, a, 2g14.6)') 'Population mean & st.devn. = ', pop_mean,  &
                                   pop_sd
      WRITE(*, *)

    CASE ('14')
      WRITE(*, *) 'Distribution: Chi-squared'
      WRITE(*, *) 'Enter number of degrees of freedom (integer): '
      READ(*, *) ndf
      WRITE(*, *) 'How many random deviates?: '
      READ(*, *) n
      ALLOCATE ( x(n) )
      first = .true.
      DO i = 1, n
        x(i) = random_chisq(ndf, first)
        first = .false.
      END DO
      CALL statistics(x, n, average, middle, xmax, xmin, stdvn, pcntile)
      WRITE(*, *)'Mean = ', average, '  Median = ', middle, '  Std.devn. = ', stdvn
      pop_mean = ndf
      pop_sd = SQRT(two * ndf)
      WRITE(*, '(1x, a, 2g14.6)') 'Population mean & st.devn. = ', pop_mean,  &
                                   pop_sd
      WRITE(*, '(1x, a, f9.4, 2x, a, f9.4)')                                 &
               'Smallest x = ', xmin, 'Largest x = ', xmax
      WRITE(*, 900) pcntile
      WRITE(*, *)
      DEALLOCATE ( x )

    CASE ('15')
      WRITE(*, *) 'Random order of integers 1 .. N'
      WRITE(*, *) 'Enter N: '
      READ(*, *) n
      ALLOCATE ( ix(n) )
      CALL random_order(ix, n)
      WRITE(*, '(1x, 15I5)') ix
      WRITE(*, *)
      DEALLOCATE ( ix )

    CASE DEFAULT
      WRITE(*, *) 'Option ', option, ' not allowed'
  END SELECT

END DO

STOP
END PROGRAM t_random

SUBROUTINE statistics(x, n, mean, median, xmax, xmin, stdev, percentile)
!     Calculate the requested statistics for the sample x(1), ..., x(n).
!     The percentiles estimated are 10%  , 20%  , ..., 90%.

IMPLICIT NONE

INTEGER, INTENT(IN)         :: n
REAL, INTENT(IN)            :: x(n)
REAL, OPTIONAL, INTENT(OUT) :: mean, median, xmax, xmin, stdev, percentile(9)

INTERFACE
  SUBROUTINE qsort(a, n, t)
    IMPLICIT NONE
    INTEGER, INTENT(IN)     :: n
    REAL, INTENT(IN OUT)    :: a(:)
    INTEGER, INTENT(IN OUT) :: t(:)
  END SUBROUTINE qsort
END INTERFACE

!     Local variables

INTEGER, ALLOCATABLE        :: original_pos(:)
REAL, ALLOCATABLE           :: xx(:)
INTEGER                     :: i, j
REAL                        :: pos, remainder, half = 0.5, one = 1.0

!     n must be > 0

IF (n <= 0) THEN
  WRITE(*, *)'N must be > 0, value of n input to subroutine statistics = ', n
  RETURN
END IF

!     If requested, calculate the mean & standard deviation

IF (PRESENT(mean) .OR. PRESENT(stdev)) THEN
  mean = SUM(x)/n
  IF(PRESENT(stdev)) THEN
    stdev = SUM( (x-mean)**2 )
    IF (n > 1) stdev = SQRT(stdev/(n-1))
  END IF
END IF

!     If median or percentiles have been requested, copy x to xx and sort.

IF (PRESENT(median) .OR. PRESENT(percentile)) THEN
  ALLOCATE (xx(n), original_pos(n))
  xx = x
  DO i = 1, n
    original_pos(i) = i
  END DO
  CALL qsort(xx, n, original_pos)

  IF (PRESENT(median)) THEN
    IF (n == 2*(n/2)) THEN
      i = n/2
      median = half * (xx(i) + xx(i+1))
    ELSE
      i = (n+1)/2
      median = xx(i)
    END IF
  END IF

  IF (PRESENT(percentile)) THEN
    DO i = 1, 9
      pos = i * REAL(n+1) / 10.
      j = pos
      remainder = pos - j
      percentile(i) = (one - remainder)*xx(j) + remainder*xx(j+1)
    END DO
  END IF
END IF

IF (PRESENT(xmin) .OR. PRESENT(xmax)) THEN
  xmin = MINVAL(x)
  xmax = MAXVAL(x)
END IF

RETURN
END SUBROUTINE statistics

SUBROUTINE qsort(a, n, t)

!     NON-RECURSIVE STACK VERSION OF QUICKSORT FROM N. WIRTH'S PASCAL
!     BOOK, 'ALGORITHMS + DATA STRUCTURES = PROGRAMS'.
!     ALSO CHANGES THE ORDER OF THE ASSOCIATED ARRAY T.
!     30 stacks are enough for about 150,000 < n < 200,000

! Corrected by Jaoa Martins, Oeiras, Portugal
! Latest revision - 4 January 1999

IMPLICIT NONE
INTEGER, INTENT(IN)     :: n
REAL, INTENT(IN OUT)    :: a(:)
INTEGER, INTENT(IN OUT) :: t(:)

!     Local Variables

INTEGER   :: k, low, high, low0, high0, s, stackl(30), stackr(30), ww
REAL      :: w, x

    stackl(1) = 1
    stackr(1) = n
    s = 1
    low0 = 1
    high0 = n

10  low = low0
    high = high0
    k = (low + high)/2
    x = a(k)

    DO WHILE (low < high)
      DO WHILE (a(low) < x)
        low = low + 1
      END DO
      DO WHILE (a(high) > x)
        high = high - 1
      END DO

      IF (low <= high) THEN
        w = a(low)
        ww = t(low)
        a(low) = a(high)
        t(low) = t(high)
        a(high) = w
        t(high) = ww
      END IF
    END DO

    IF (low0 < high) THEN
      stackl(s) = high
      stackr(s) = high0
      high0 = stackl(s) - 1
      low0 = low0 - 1
      IF (low0 <= 0) low0 = 1
      s = s + 1
      GO TO 10
    END IF

    IF (low < high0) THEN
      low0 = low + 1
      GO TO 10
    END IF

    IF (s > 1) THEN
      s = s - 1
      low0 = stackl(s)
      high0 = stackr(s)
      GO TO 10
    END IF

RETURN
END SUBROUTINE qsort


module make_grav_module

  use bl_types

  implicit none

  private

  public :: make_grav_cell, make_grav_edge, make_grav_edge_uniform

contains

  subroutine make_grav_cell(grav_cell,rho0)

    use bl_constants_module
    use geometry, only: spherical, nr_fine, r_cc_loc, r_edge_loc, &
         nlevs_radial, nr, numdisjointchunks, &
         r_start_coord, r_end_coord
    use probin_module, only: grav_const, base_cutoff_density, &
         do_planar_invsq_grav, planar_invsq_mass, do_2d_planar_octant, ref_ratio
    use fundamental_constants_module, only: Gconst
    use restrict_base_module

    ! compute the base state gravitational acceleration at the cell
    ! centers.  The base state uses 0-based indexing, so grav_cell
    ! does too.

    real(kind=dp_t), intent(  out) :: grav_cell(:,0:)
    real(kind=dp_t), intent(in   ) ::      rho0(:,0:)

    ! Local variables
    integer                      :: r, n, i
    real(kind=dp_t), allocatable :: m(:,:)
    real(kind=dp_t)              :: term1, term2

    if (spherical .eq. 0) then

       if (do_planar_invsq_grav)  then

          ! we are doing a plane-parallel geometry with a 1/r**2
          ! gravitational acceleration.  The mass is assumed to be
          ! at the origin.  The mass in the computational domain
          ! does not contribute to the gravitational acceleration.
          do n=1,nlevs_radial
             do r = 0, nr(n)-1
                grav_cell(n,r) = -Gconst*planar_invsq_mass / r_cc_loc(n,r)**2
             enddo
          enddo

       else if (do_2d_planar_octant .eq. 1) then

          ! compute gravity as in the spherical case

          allocate(m(nlevs_radial,0:nr_fine-1))

          n = 1
          m(n,0) = FOUR3RD*M_PI*rho0(n,0)*r_cc_loc(n,0)**3
          grav_cell(n,0) = -Gconst * m(n,0) / r_cc_loc(n,0)**2

          do r=1,nr(n)-1

             ! the mass is defined at the cell-centers, so to compute
             ! the mass at the current center, we need to add the
             ! contribution of the upper half of the zone below us and
             ! the lower half of the current zone.

             ! don't add any contributions from outside the star --
             ! i.e.  rho < base_cutoff_density
             if (rho0(n,r-1) > base_cutoff_density) then
                term1 = FOUR3RD*M_PI*rho0(n,r-1) * &
                     (r_edge_loc(n,r) - r_cc_loc(n,r-1)) * &
                     (r_edge_loc(n,r)**2 + &
                     r_edge_loc(n,r)*r_cc_loc(n,r-1) + &
                     r_cc_loc(n,r-1)**2)
             else
                term1 = ZERO
             endif

             if (rho0(n,r) > base_cutoff_density) then
                term2 = FOUR3RD*M_PI*rho0(n,r  )*&
                     (r_cc_loc(n,r) - r_edge_loc(n,r  )) * &
                     (r_cc_loc(n,r)**2 + &
                     r_cc_loc(n,r)*r_edge_loc(n,r  ) + &
                     r_edge_loc(n,r  )**2)
             else
                term2 = ZERO
             endif

             m(n,r) = m(n,r-1) + term1 + term2

             grav_cell(n,r) = -Gconst * m(n,r) / r_cc_loc(n,r)**2

          enddo

          do n = 2, nlevs_radial
             do i=1,numdisjointchunks(n)

                if (r_start_coord(n,i) .eq. 0) then
                   m(n,0) = FOUR3RD*M_PI*rho0(n,0)*r_cc_loc(n,0)**3
                   grav_cell(n,0) = -Gconst * m(n,0) / r_cc_loc(n,0)**2
                else
                   r = r_start_coord(n,i)
                   m(n,r) = m(n-1,r/ref_ratio-1)

                   ! the mass is defined at the cell-centers, so to compute
                   ! the mass at the current center, we need to add the
                   ! contribution of the upper half of the zone below us and
                   ! the lower half of the current zone.

                   ! don't add any contributions from outside the star --
                   ! i.e.  rho < base_cutoff_density
                   if (rho0(n-1,r/ref_ratio-1) > base_cutoff_density) then
                      term1 = FOUR3RD*M_PI*rho0(n-1,r/ref_ratio-1) * &
                           (r_edge_loc(n-1,r/ref_ratio) - r_cc_loc(n-1,r/ref_ratio-1)) * &
                           (r_edge_loc(n-1,r/ref_ratio)**2 + &
                           r_edge_loc(n-1,r/ref_ratio)*r_cc_loc(n-1,r/ref_ratio-1) + &
                           r_cc_loc(n-1,r/ref_ratio-1)**2)
                   else
                      term1 = ZERO
                   endif

                   if (rho0(n,r) > base_cutoff_density) then
                      term2 = FOUR3RD*M_PI*rho0(n,r  )*&
                           (r_cc_loc(n,r) - r_edge_loc(n,r  )) * &
                           (r_cc_loc(n,r)**2 + &
                           r_cc_loc(n,r)*r_edge_loc(n,r  ) + &
                           r_edge_loc(n,r  )**2)
                   else
                      term2 = ZERO
                   endif

                   m(n,r) = m(n,r) + term1 + term2

                   grav_cell(n,r) = -Gconst * m(n,r) / r_cc_loc(n,r)**2

                end if

                do r=r_start_coord(n,i)+1,r_end_coord(n,i)

                   ! the mass is defined at the cell-centers, so to compute
                   ! the mass at the current center, we need to add the
                   ! contribution of the upper half of the zone below us and
                   ! the lower half of the current zone.

                   ! don't add any contributions from outside the star --
                   ! i.e.  rho < base_cutoff_density
                   if (rho0(n,r-1) > base_cutoff_density) then
                      term1 = FOUR3RD*M_PI*rho0(n,r-1) * &
                           (r_edge_loc(n,r) - r_cc_loc(n,r-1)) * &
                           (r_edge_loc(n,r)**2 + &
                           r_edge_loc(n,r)*r_cc_loc(n,r-1) + &
                           r_cc_loc(n,r-1)**2)
                   else
                      term1 = ZERO
                   endif

                   if (rho0(n,r) > base_cutoff_density) then
                      term2 = FOUR3RD*M_PI*rho0(n,r  )*&
                           (r_cc_loc(n,r) - r_edge_loc(n,r  )) * &
                           (r_cc_loc(n,r)**2 + &
                           r_cc_loc(n,r)*r_edge_loc(n,r  ) + &
                           r_edge_loc(n,r  )**2)
                   else
                      term2 = ZERO
                   endif

                   m(n,r) = m(n,r-1) + term1 + term2

                   grav_cell(n,r) = -Gconst * m(n,r) / r_cc_loc(n,r)**2

                end do
             enddo
          end do

          call restrict_base(grav_cell,.true.)
          call fill_ghost_base(grav_cell,.true.)

       else

          ! constant gravity
          grav_cell = grav_const

       endif

    else  ! spherical = 1

       allocate(m(1,0:nr_fine-1))

       m(1,0) = FOUR3RD*M_PI*rho0(1,0)*r_cc_loc(1,0)**3
       grav_cell(1,0) = -Gconst * m(1,0) / r_cc_loc(1,0)**2

       do r=1,nr_fine-1

          ! the mass is defined at the cell-centers, so to compute
          ! the mass at the current center, we need to add the
          ! contribution of the upper half of the zone below us and
          ! the lower half of the current zone.

          ! don't add any contributions from outside the star --
          ! i.e.  rho < base_cutoff_density
          if (rho0(1,r-1) > base_cutoff_density) then
             term1 = FOUR3RD*M_PI*rho0(1,r-1) * &
                  (r_edge_loc(1,r) - r_cc_loc(1,r-1)) * &
                  (r_edge_loc(1,r)**2 + &
                   r_edge_loc(1,r)*r_cc_loc(1,r-1) + &
                   r_cc_loc(1,r-1)**2)
          else
             term1 = ZERO
          endif

          if (rho0(1,r) > base_cutoff_density) then
             term2 = FOUR3RD*M_PI*rho0(1,r  )*&
                  (r_cc_loc(1,r) - r_edge_loc(1,r  )) * &
                  (r_cc_loc(1,r)**2 + &
                   r_cc_loc(1,r)*r_edge_loc(1,r  ) + &
                   r_edge_loc(1,r  )**2)
          else
             term2 = ZERO
          endif

          m(1,r) = m(1,r-1) + term1 + term2

          grav_cell(1,r) = -Gconst * m(1,r) / r_cc_loc(1,r)**2

       enddo

       deallocate(m)

    end if

  end subroutine make_grav_cell

  subroutine make_grav_edge(grav_edge,rho0)

    use bl_constants_module
    use geometry, only: spherical, r_edge_loc, nr_fine, nlevs_radial, nr, &
         numdisjointchunks, r_start_coord, r_end_coord
    use probin_module, only: grav_const, base_cutoff_density, &
         do_planar_invsq_grav, planar_invsq_mass, do_2d_planar_octant, ref_ratio
    use fundamental_constants_module, only: Gconst
    use restrict_base_module

    ! compute the base state gravity at the cell edges (grav_edge(1)
    ! is the gravitational acceleration at the left edge of zone 1).
    ! The base state uses 0-based indexing, so grav_edge does too.

    real(kind=dp_t), intent(  out) :: grav_edge(:,0:)
    real(kind=dp_t), intent(in   ) ::      rho0(:,0:)

    ! Local variables
    integer                      :: r, n, i
    real(kind=dp_t)              :: mencl
    real(kind=dp_t), allocatable :: m(:,:)

    if (spherical .eq. 0) then

       if (do_planar_invsq_grav)  then

          ! we are doing a plane-parallel geometry with a 1/r**2
          ! gravitational acceleration.  The mass is assumed to be
          ! at the origin.  The mass in the computational domain
          ! does not contribute to the gravitational acceleration.
          do n=1,nlevs_radial
             do r = 0, nr(n)-1
                grav_edge(n,r) = -Gconst*planar_invsq_mass / r_edge_loc(n,r)**2
             enddo
          enddo

       else if (do_2d_planar_octant .eq. 1) then

          ! compute gravity as in spherical geometry

          allocate(m(nlevs_radial,0:nr_fine))

          grav_edge(1,0) = zero
          m(1,0) = ZERO

          do r=1,nr(1)-1

             ! only add to the enclosed mass if the density is
             ! > base_cutoff_density
             if (rho0(1,r-1) > base_cutoff_density) then
                m(1,r) = m(1,r-1) + FOUR3RD*M_PI * &
                     (r_edge_loc(1,r) - r_edge_loc(1,r-1)) * &
                     (r_edge_loc(1,r)**2 + &
                     r_edge_loc(1,r)*r_edge_loc(1,r-1) + &
                     r_edge_loc(1,r-1)**2) * rho0(1,r-1)
             else
                m(1,r) = m(1,r-1)
             endif

             grav_edge(1,r) = -Gconst * m(1,r) / r_edge_loc(1,r)**2

          end do

          do n = 2, nlevs_radial
             do i=1,numdisjointchunks(n)

                if (r_start_coord(n,i) .eq. 0) then

                   m(n,0) = ZERO

                else

                   m(n,r_start_coord(n,i)) = m(n-1,r_start_coord(n,i)/ref_ratio)
                   grav_edge(n,r_start_coord(n,i)) = grav_edge(n-1,r_start_coord(n,i)/ref_ratio)

                end if

                do r=r_start_coord(n,i)+1,r_end_coord(n,i)+1

                   ! only add to the enclosed mass if the density is
                   ! > base_cutoff_density
                   if (rho0(n,r-1) > base_cutoff_density) then
                      m(n,r) = m(n,r-1) + FOUR3RD*M_PI * &
                           (r_edge_loc(n,r) - r_edge_loc(n,r-1)) * &
                           (r_edge_loc(n,r)**2 + &
                           r_edge_loc(n,r)*r_edge_loc(n,r-1) + &
                           r_edge_loc(n,r-1)**2) * rho0(n,r-1)
                   else
                      m(n,r) = m(n,r-1)
                   endif

                   grav_edge(n,r) = -Gconst * m(n,r) / r_edge_loc(n,r)**2

                end do
             enddo
          end do

          deallocate(m)

          call restrict_base(grav_edge,.false.)
          call fill_ghost_base(grav_edge,.false.)

       else

          ! constant gravity
          grav_edge = grav_const

       endif

    else

       grav_edge(1,0) = zero
       mencl = ZERO

       do r=1,nr_fine-1

          ! only add to the enclosed mass if the density is
          ! > base_cutoff_density
          if (rho0(1,r-1) > base_cutoff_density) then
             mencl = mencl + FOUR3RD*M_PI * &
                  (r_edge_loc(1,r) - r_edge_loc(1,r-1)) * &
                  (r_edge_loc(1,r)**2 + &
                   r_edge_loc(1,r)*r_edge_loc(1,r-1) + &
                   r_edge_loc(1,r-1)**2) * rho0(1,r-1)
          endif

          grav_edge(1,r) = -Gconst * mencl / r_edge_loc(1,r)**2

       end do

    end if

  end subroutine make_grav_edge

  subroutine make_grav_edge_uniform(grav_edge_fine,rho0_fine)

    ! a special version of the make_grav_edge routine that takes a
    ! uniformly-gridded, single level density array at the finest base
    ! state resolution and returns the uniformly-gridded, single-level
    ! gravity at the same resolution

    use bl_constants_module
    use geometry, only: spherical, r_edge_loc, nr_fine, nlevs_radial, nr
    use probin_module, only: grav_const, base_cutoff_density, &
         do_planar_invsq_grav, planar_invsq_mass, do_2d_planar_octant
    use fundamental_constants_module, only: Gconst

    ! compute the base state gravity at the cell edges (grav_edge(1)
    ! is the gravitational acceleration at the left edge of zone 1).
    ! The base state uses 0-based indexing, so grav_edge does too.

    real(kind=dp_t), intent(  out) :: grav_edge_fine(0:)
    real(kind=dp_t), intent(in   ) ::      rho0_fine(0:)

    ! Local variables
    integer                      :: r
    real(kind=dp_t)              :: mencl

    if (spherical .eq. 0) then

       if (do_planar_invsq_grav)  then

          ! we are doing a plane-parallel geometry with a 1/r**2
          ! gravitational acceleration.  The mass is assumed to be
          ! at the origin.  The mass in the computational domain
          ! does not contribute to the gravitational acceleration.
          do r = 0, nr(nlevs_radial)-1
             grav_edge_fine(r) = -Gconst*planar_invsq_mass / &
                  r_edge_loc(nlevs_radial,r)**2
          enddo

       else if (do_2d_planar_octant .eq. 1) then

          ! compute gravity as in spherical geometry
          grav_edge_fine(0) = ZERO
          mencl = ZERO

          do r=1,nr_fine-1

             ! only add to the enclosed mass if the density is
             ! > base_cutoff_density
             if (rho0_fine(r-1) > base_cutoff_density) then
                mencl = mencl + FOUR3RD*M_PI * &
                     (r_edge_loc(nlevs_radial,r) - r_edge_loc(nlevs_radial,r-1)) * &
                     (r_edge_loc(nlevs_radial,r)**2 + &
                     r_edge_loc(nlevs_radial,r)*r_edge_loc(nlevs_radial,r-1) + &
                     r_edge_loc(nlevs_radial,r-1)**2) * rho0_fine(r-1)
             endif

             grav_edge_fine(r) = -Gconst * mencl / r_edge_loc(nlevs_radial,r)**2

          end do

       else

          ! constant gravity
          grav_edge_fine(:) = grav_const

       endif

    else

       grav_edge_fine(0) = ZERO
       mencl = ZERO

       do r=1,nr_fine-1

          ! only add to the enclosed mass if the density is
          ! > base_cutoff_density
          if (rho0_fine(r-1) > base_cutoff_density) then
             mencl = mencl + FOUR3RD*M_PI * &
                  (r_edge_loc(nlevs_radial,r) - r_edge_loc(nlevs_radial,r-1)) * &
                  (r_edge_loc(nlevs_radial,r)**2 + &
                   r_edge_loc(nlevs_radial,r)*r_edge_loc(nlevs_radial,r-1) + &
                   r_edge_loc(nlevs_radial,r-1)**2) * rho0_fine(r-1)
          endif

          grav_edge_fine(r) = -Gconst * mencl / r_edge_loc(nlevs_radial,r)**2

       end do

    end if

  end subroutine make_grav_edge_uniform

end module make_grav_module


*dk,extract_plane
      subroutine extract_plane(cmoout,cmoin,npoints,ntets,a,b,c,d,ierr1)
C
C #####################################################################
C
C     PURPOSE -
C
C        Extracts a plane defined by the parameters a,b,c, and d.
C        The plane has an outward unit normal (a,b,c).
C
C
C     INPUT ARGUMENTS -
C
C        cmoout    - THE MESH OBJECT TO HOLD THE RESULT
C        cmoin     - THE INCOMING MESH OBJECT
C        npoints   - NUMBER OF POINTS
C        ntets     - NUMBER OF TETS
C        a,b,c,d   - COEFFICIENTS IN THE PLANE EQUATION
C                      ax + by + cz + d = 0
C
C     OUTPUT ARGUMENTS -
C
C        ierr1   - ERROR RETURNED (ZERO IF NO ERRORS)
C
C     CHANGE HISTORY -
C
C        $Log: extract_plane.f,v $
C        Revision 2.00  2007/11/05 19:45:54  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.21   02 Oct 2007 12:40:28   spchu
CPVCS    original version
C
C ######################################################################
C
      implicit real*8 (a-h, o-z)
C
C   Definitions for incoming (existing) cmo
C
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      dimension xic(1000000), yic(1000000), zic(1000000)
C
      pointer (ipdist, dist)
      dimension dist(1000000)
C
      character*132 logmess
      character*(*) cmoin, cmoout
      character*32 isubname
C
      isubname = 'extract_plane'
      ierr1 = 0
C
C   Get the existing cmo
C
C
      call mmgetblk('dist',isubname,ipdist,npoints,2,icscode)
C
      call cmo_get_info('xic',cmoin,ipxic,lenxic,icmotype,ierror)
      call cmo_get_info('yic',cmoin,ipyic,lenyic,icmotype,ierror)
      call cmo_get_info('zic',cmoin,ipzic,lenzic,icmotype,ierror)
C
C   dist is the signed distance of each node from the plane
C
      epsilone = 1.0e-10
      do i=1,npoints
         dist(i) = a*xic(i) + b*yic(i) + c*zic(i) + d
         if (abs(dist(i)) .lt. epsilone) dist(i) = 0.0
      enddo
C
C   Do an isosurface on dist = 0.0.
C
      value = 0.0
      call isosurface(ipdist,value,npoints,ntets,cmoin,cmoout,ierr1)
C
      call mmrelprt(isubname,icscode)
C
      return
      end