subroutine secpred()

    use constants_module
    use arrays_module
    use var_module
    use arrays_section_module
    use xsec_attribute_module

    implicit none

    ! Locals
    integer :: i, pp, tableLength
    real(kind=4) :: beds, fs, hy, yyn, yyn_1, temp1, temp2, new_I2
    real(kind=4) :: xt, q_sk_multi, currentQ
    real(kind=4) :: r_interpol, r_interpo_nn

    !change 20191122
    ci1=0
    ci2=0

    do i=ncomp,1,-1

        if(i .lt. ncomp) then
            downstreamI2Tablep = I2Tablep
            downstreamSquareDepth = currentSquareDepth
            yyn_1 = yyn
        end if
! ----------------------------------------------------
        elevTable = xsec_tab(1,:,i)
        areaTable = xsec_tab(2,:,i)
        pereTable = xsec_tab(3,:,i)
        rediTable = xsec_tab(4,:,i)
        convTable = xsec_tab(5,:,i)
        topwTable = xsec_tab(6,:,i)
        nwi1Table = xsec_tab(7,:,i)
        dPdATable = xsec_tab(8,:,i)
        currentSquareDepth=(elevTable-z(i))**2
        I2Tablep = xsec_tab(9,:,i)
        I2Tablec = xsec_tab(10,:,i)

!      interpolate the cross section attributes based on predicted area
        xt=areap(i)

        ! NEW CHANGE: 20191119
        ! To get rid of negative predicted area
        if (areap(i) .le. TOLERANCE) then
            yyn = elevTable(1)+(elevTable(2)-elevTable(1))/100*5
            !areap(i) = 0.01
            print*, 'At i = ', i , ' pred area is negative'
        else
            yyn    =r_interpol(areaTable,elevTable,nel,xt)
        end if

        depth(i) = yyn - z(i)
        xt = yyn

        pere(i)=r_interpol(elevTable,pereTable,nel,xt)
        hy     =r_interpol(elevTable,rediTable,nel,xt)
        co(i)  =r_interpol(elevTable,convTable,nel,xt)
        bo(i)  =r_interpol(elevTable,topwTable,nel,xt)
!        ci1(i) =r_interpol(areaTable,nwi1Table,nel,xt)
        ci1(i) =r_interpol(currentSquareDepth,nwi1Table,nel,(depth(i))**2)
        dpda(i)=r_interpol(elevTable,dPdATable,nel,xt)

        currentQ = qp(i)

        q_sk_multi = 1.0
        do pp = 1, size(Q_sk_tableEntry)
            if (  ( eachQSKtableNodeRange(1,pp) - i) * ( eachQSKtableNodeRange(2,pp) - i) .le. 0 ) then
				tableLength = Q_sk_tableEntry(pp)
                q_sk_multi = r_interpo_nn(Q_Sk_Table(1,1:tableLength,pp),Q_Sk_Table(2,1:tableLength,pp),tableLength,currentQ)
            end if
        end do
        co(i) = q_sk_multi*co(i)

! ----------------------------------------------------
        if(i .lt. ncomp) then

! I2 opposite direction calculated as interpolation start
        xt=areap(i+1)
        temp1 = r_interpol(currentSquareDepth,I2Tablec,nel,(yyn-z(i))**2)
        temp2 = r_interpol(downstreamSquareDepth,downstreamI2Tablep, nel,(yyn_1-z(i+1))**2)
        new_I2 = (temp1+temp2)/2.0
! I2 opposite direction calculated as interpolation end

            if(ityp(i) == 1) then
                ci2(i)=new_I2
                beds=(z(i)-z(i+1))/dx(i)
                fs=f*0.5*qp(i)*abs(qp(i))/(co(i)**2)+f*0.5*qp(i+1)*abs(qp(i+1))/(co(i+1)**2)
                aso(i)=(areap(i)+areap(i+1))/2.0*(beds-fs)
                gso(i)=grav*(beds-fs)
                dbdx(i)=(bo(i+1)-bo(i))/dx(i)
            end if
        end if

        !!! new for dkdh
   !     do pp = 2,nel
   !         if (yyn .le. elevTable(pp)) then
   !             dkdh(i)  =(convTable(pp)-convTable(pp-1))/(elevTable(pp)-elevTable(pp-1))
   !             EXIT
   !         endif
   !     end do
    end do

end subroutine secpred


!
!     -------------------------------------------------------------
!      S I X J 1
!     -------------------------------------------------------------
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 6j COEFFICIENT         *
!                                                                  *
!     | I/2  J/2  K/2 |                                            *
!     | L/2  M/2   1  |               [B.M.X.  75].                *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vilnius,  Lithuania                             March 1995   *
!
      SUBROUTINE SIXJ1(I, J, K, L, M, ITIK, SI)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:06:26  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ixjtik_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I
      INTEGER  :: J
      INTEGER  :: K
      INTEGER  :: L
      INTEGER  :: M
      INTEGER , INTENT(IN) :: ITIK
      REAL(DOUBLE) , INTENT(OUT) :: SI
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: IFA
      REAL(DOUBLE) :: AS, AKA, A, B, C
!-----------------------------------------------
      SI = ZERO
      IF (ITIK /= 0) THEN
!
!     CHESKED TRIANGULAR CONDITIONS
!
         IF (IXJTIK(I,J,K,L,M,2) == 0) RETURN
      ENDIF
      IFA = (I + J + K)/2
      AS = DBLE(IFA)
      AKA = ONE
      IF (MOD(IFA,2) /= 0) AKA = -AKA
      A = DBLE(K)
      B = DBLE(J)
      C = DBLE(I)
      IF (I < M) THEN
         IF (J < L) THEN
!              M > I,   L > J.
            SI = AKA*DSQRT((AS + TWO)*(AS + THREE)*(AS - A + ONE)*(AS - A + TWO&
               )/((B + ONE)*(B + TWO)*(B + THREE)*(C + ONE)*(C + TWO)*(C + &
               THREE)))
         ELSE IF (J == L) THEN
!              M > I,  L = J.
            SI = (-AKA)*DSQRT(TWO*(AS + TWO)*(AS - C)*(AS - B + ONE)*(AS - A + &
               ONE)/(B*(B + ONE)*(B + TWO)*(C + ONE)*(C + TWO)*(C + THREE)))
         ELSE
!              M > I,  L < J.
            SI = AKA*DSQRT((AS - C - ONE)*(AS - C)*(AS - B + ONE)*(AS - B + TWO&
               )/((B - ONE)*B*(B + ONE)*(C + ONE)*(C + TWO)*(C + THREE)))
         ENDIF
      ELSE IF (I == M) THEN
         IF (J < L) THEN
!              M = L,  L > J.
            SI = (-AKA)*DSQRT((AS + TWO)*(AS - C + ONE)*(AS - B)*(AS - A + ONE)&
               *TWO/((B + ONE)*(B + TWO)*(B + THREE)*C*(C + ONE)*(C + TWO)))
         ELSE IF (J == L) THEN
!              M = I,  L = J.
            SI = (-AKA)*((B*B + C*C - A*A)*HALF + B + C - A)/DSQRT(B*(B + ONE)*&
               (B + TWO)*C*(C + ONE)*(C + TWO))
         ELSE
!              M = I,  L < J.
            SI = AKA*DSQRT((AS + ONE)*(AS - C)*(AS - B + ONE)*(AS - A)*TWO/((B&
                - ONE)*B*(B + ONE)*C*(C + ONE)*(C + TWO)))
         ENDIF
      ELSE
         IF (J < L) THEN
!              M < I,   L > J.
            SI = AKA*DSQRT((AS - C + ONE)*(AS - C + TWO)*(AS - B - ONE)*(AS - B&
               )/((B + ONE)*(B + TWO)*(B + THREE)*(C - ONE)*C*(C + ONE)))
         ELSE IF (J == L) THEN
!              M < I,   L = J.
            SI = AKA*DSQRT((AS + ONE)*(AS - C + ONE)*(AS - B)*(AS - A)*TWO/(B*(&
               B + ONE)*(B + TWO)*(C - ONE)*C*(C + ONE)))
         ELSE
!              M < I,   L < J.
            SI = AKA*DSQRT(AS*(AS + ONE)*(AS - A - ONE)*(AS - A)/((B - ONE)*B*(&
               B + ONE)*(C - ONE)*C*(C + ONE)))
         ENDIF
      ENDIF
      RETURN
      END SUBROUTINE SIXJ1


      subroutine dgefa(a,lda,n,ipvt,info)
      integer lda,n,ipvt(1),info
      double precision a(lda,1)
c
c     dgefa factors a double precision matrix by gaussian elimination.
c
c     dgefa is usually called by dgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
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     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgesl or dgedi will divide by zero
c                     if called.  use  rcond  in dgeco for a reliable
c                     indication of singularity.
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,dscal,idamax
c
c     internal variables
c
      double precision t
      integer idamax,j,k,kp1,l,nm1
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = idamax(n-k+1,a(k,k),1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0d0) go to 40
c
c           interchange if necessary
c
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0d0/a(k,k)
            call dscal(n-k,t,a(k+1,k),1)
c
c           row elimination with column indexing
c
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0d0) info = n
      return
      end


module oumods
  use, intrinsic :: iso_c_binding
  implicit integer(c_int) (i-k), integer(c_int) (m,n), &
       & real(c_double) (a-h), real(c_double) (l), real(c_double) (o-z)

       TYPE :: ex_type
       INTEGER :: A = 0
     CONTAINS
       FINAL :: del_ex_type
       PROCEDURE :: sub => ex_sub
     END TYPE ex_type

contains
  subroutine zI12(t,c,alpha,beta,r)
    complex(c_double_complex) c,r,    x,y,z
     z = c*t
     y = exp(z)
     x = (2.0_c_double * cosh((z - cmplx(0._c_double,3.14159265358979324_c_double, kind(1._c_double))) &
          & /2._c_double )) / (c / exp((z + cmplx(0._c_double,3.14159265358979324_c_double,kind(1._c_double)))/2._c_double))
     r = beta*r+alpha*((t*y - x)/c)
  end subroutine
end module


!=============================================================================!
        subroutine rhsBC(rl, vl, vml)
!
!  Satisfy the boundary conditions
!
!=============================================================================!
        use global
        use stencil
        use pot
        implicit none

        real :: rl(ndof,nx,ny), vl(ndof,nx,ny), vml(ndof,nx,ny)

        real, allocatable :: p(:), pnorm(:)

        integer :: i, j
!=============================================================================!
!       L I N E A R   B O U N D A R Y   C O N D I T I O N S
!=============================================================================!
        if (linear.eq.1) then

        if (yper) then

          rl(:,:,ny) = zero

        else                    ! yper

!=============================================================================!
!       W a l l
!=============================================================================!
        if (Navier) then

!.... density boundary condition

          if (wall.eq.1) then
            rl(1,:,1) = gc1 * vl(1,:,1) + gc2 * vl(1,:,2) + &
                        gc3 * vl(1,:,3) + gc4 * vl(1,:,4) + &
                        gc5 * vl(1,:,5)
          end if

!.... linear extrapolation of rho at the wall

          if (wall.eq.2) then
            rl(1,:,1) = vl(1,:,1) - two * vl(1,:,2) + vl(1,:,3)
          end if

!.... no-slip boundary condition

          rl(2:ndof-1,:,1)  = zero

!.... isothermal wall

          if (wallt.eq.0) rl(ndof,:,1) = zero

!.... adiabatic boundary condition

          if (wallt.eq.1) then
            rl(ndof,:,1) = gc1 * vl(ndof,:,1) + gc2 * vl(ndof,:,2) + &
                           gc3 * vl(ndof,:,3) + gc4 * vl(ndof,:,4) + &
                           gc5 * vl(ndof,:,5)
          end if

        else            ! inviscid wall

          allocate( p(nx), pnorm(nx) )
          call lwallbc(vl, vml, p, pnorm)
          do i = 1, nx
            rl(1,i,1) = ( gc1 * vl(1,i,1) + gc2 * vl(1,i,2) + &
                          gc3 * vl(1,i,3) + gc4 * vl(1,i,4) + &
                          gc5 * vl(1,i,5) ) / deta - Pnorm(i)
          end do
          deallocate( p, pnorm )

          do i = 1, nx
            if ( abs(bnb(i,2)) .ge. abs(bnb(i,1)) ) then
              rl(2,i,1) = bnb(i,2) * rl(2,i,1) - bnb(i,1) * rl(3,i,1)
              rl(3,i,1) = -( bnb(i,1) * vl(2,i,1) + bnb(i,2) * vl(3,i,1) )
            else
              rl(3,i,1) = bnb(i,2) * rl(2,i,1) - bnb(i,1) * rl(3,i,1)
              rl(2,i,1) = -( bnb(i,1) * vl(2,i,1) + bnb(i,2) * vl(3,i,1) )
            end if
          end do

        end if          ! Navier
!=============================================================================!
!       T o p
!=============================================================================!

!.... freestream zero disturbance boundary conditions

          if (top.eq.0) then
            rl(:,:,ny) = zero
          end if

        end if                  ! yper

        if (xper) then
          rl(:,nx,:) = zero
        else                    ! xper

!=============================================================================!
!       L e f t   B o u n d a r y
!=============================================================================!
        if (left.eq.0) then

          rl(:,1,:)  = zero

        else if (left.eq.1) then

          rl(1,1,nbl+1:ny) = vl(1,1,nbl+1:ny) - &
                  (gamma * Ma * vml(1,1,nbl+1:ny) * &
                  sqrt(vml(5,1,nbl+1:ny)) * vl(2,1,nbl+1:ny) - &
                  vml(1,1,nbl+1:ny) * vl(5,1,nbl+1:ny)) / vml(5,1,nbl+1:ny)

!         rl(:,1,1:nbl) = vl(:,1,1:nbl) - vl(:,2,1:nbl)

        else if (left.eq.2) then

          do j = 1, ny
!           rl(1,1,j) = gc1 * vl(1,1,j) + gc2 * vl(1,2,j)  + &
!                       gc3 * vl(1,3,j) + gc4 * vl(1,4,j)  + &
!                       gc5 * vl(1,5,j)

            rl(2,1,j) = gc1 * vl(2,1,j) + gc2 * vl(2,2,j)  + &
                        gc3 * vl(2,3,j) + gc4 * vl(2,4,j)  + &
                        gc5 * vl(2,5,j)

            rl(3,1,j) = zero

            rl(4,1,j) = gc1 * vl(4,1,j) + gc2 * vl(4,2,j)  + &
                        gc3 * vl(4,3,j) + gc4 * vl(4,4,j)  + &
                        gc5 * vl(4,5,j)

            rl(5,1,j) = gc1 * vl(5,1,j) + gc2 * vl(5,2,j)  + &
                        gc3 * vl(5,3,j) + gc4 * vl(5,4,j)  + &
                        gc5 * vl(5,5,j)
          end do

        else if (left.eq.7) then           ! symmetry boundary
          rl(3,1,:) = zero
        end if

!=============================================================================!
!       R i g h t   B o u n d a r y
!=============================================================================!
        if (right.eq.0) then

          rl(:,nx,:) = zero

        else if (right.eq.1) then

          rl(1,nx,nbl+1:ny) = vl(1,nx,nbl+1:ny) - &
                  (gamma * Ma * vml(1,nx,nbl+1:ny) * &
                  sqrt(vml(5,nx,nbl+1:ny)) * vl(2,nx,nbl+1:ny) - &
                  vml(1,nx,nbl+1:ny) * vl(5,nx,nbl+1:ny)) /vml(5,nx,nbl+1:ny)

!         rl(:,nx,1:nbl) = vl(:,nx,1:nbl) - vl(:,nx-1,1:nbl)

        end if

        end if                  ! xper

!=============================================================================!
!       N O N L I N E A R   B O U N D A R Y   C O N D I T I O N S
!=============================================================================!
        else                    ! linear = 0

        if (yper) then

          rl(:,:,ny) = zero

        else                    ! yper

!=============================================================================!
!       W a l l
!=============================================================================!
        if (Navier) then

!.... no-slip boundary condition

          rl(2:ndof-1,:,1) = zero

!.... density boundary condition

          if (wall.eq.1) then
            rl(1,:,1) = gc1 * vl(1,:,1) + gc2 * vl(1,:,2) + &
                        gc3 * vl(1,:,3) + gc4 * vl(1,:,4) + &
                        gc5 * vl(1,:,5)
          end if

!.... Wall normal momentum equation

          if (wall.eq.2) then
            allocate( p(nx), pnorm(nx) )
            call wallbc(vl, p, pnorm)
            do i = 1, nx
              rl(1,i,1) = ( gc1 * vl(1,i,1) + gc2 * vl(1,i,2) + &
                            gc3 * vl(1,i,3) + gc4 * vl(1,i,4) + &
                            gc5 * vl(1,i,5) ) / deta -          &
                            gamma * Ma**2 * Pnorm(i) / vl(5,i,1)
            end do
            deallocate( p, pnorm )
          end if

!.... Third order extrapolation to the wall for density
!.... (in computational space)

          if (wall.eq.3) then
            rl(1,:,1) = vl(1,:,1) - (4.0*vl(1,:,2) - 6.0*vl(1,:,3) + &
                                     4.0*vl(1,:,4) -     vl(1,:,5) )
          end if

!.... isothermal wall

          if (wallt.eq.0) then
            rl(ndof,:,1) = vl(ndof,:,1) - ( one + pt5 * gamma1 * Ma**2 * &
                           (one + tan(alpha)**2) * sqrt(Pr) )
          end if

!.... adiabatic boundary condition

          if (wallt.eq.1) then
            rl(ndof,:,1) = gc1 * vl(ndof,:,1) + gc2 * vl(ndof,:,2) + &
                           gc3 * vl(ndof,:,3) + gc4 * vl(ndof,:,4) + &
                           gc5 * vl(ndof,:,5)
          end if

        else    ! inviscid

!.... rl(2,:,1) = wall tangent momentum
!.... rl(3,:,1) = wall normal velocity

          if (.false.) then
            rl(2,:,1) =  ( bnb(:,2) * rl(2,:,1) - bnb(:,1) * rl(3,:,1) )
            rl(3,:,1) = -( bnb(:,1) * rl(2,:,1) + bnb(:,2) * rl(3,:,1) )
          end if

!.... Add density extrapolation

          if (wall.eq.3) then

          end if

        end if  ! Navier
!=============================================================================!
!       T o p
!=============================================================================!
        if (Ma.gt.one) then

          rl(1,:,ny) = zero             ! set all variables
          rl(2,:,ny) = zero
          rl(3,:,ny) = zero
          rl(4,:,ny) = zero
          rl(5,:,ny) = zero

        else    ! Ma

          if (top.eq.0) then
            call ReimannRHS( nx, vl(:,:,ny), vl(:,:,ny-1), vl(:,:,ny-2), &
                             bnt, x(:,ny), y(:,ny), rl(:,:,ny), &
                             rhobt, ubt, vbt, wbt, tbt, pbt, cbt )
          end if

        end if                  ! Ma

        end if                  ! yper

!=============================================================================!

        if (xper) then

          rl(:,nx,:) = zero

        else                    ! xper

!=============================================================================!
!       L e f t  B o u n d a r y
!=============================================================================!

        if (Ma.lt.one) then

!.... first-order Riemann

          if (left.eq.0) then
            call ReimannRHS( ny, vl(:,1,:), vl(:,2,:), vl(:,3,:), &
                             bnl, x(1,:), y(1,:), rl(:,1,:), &
                             rhobl, ubl, vbl, wbl, tbl, pbl, cbl )
          end if

!.... Symmetry plane

          if (left.eq.2) then
            do j = 1, ny
              rl(1,1,j) = gc1 * vl(1,1,j) + gc2 * vl(1,2,j)  + &
                          gc3 * vl(1,3,j) + gc4 * vl(1,4,j)  + &
                          gc5 * vl(1,5,j)

              rl(2,1,j) = gc1 * vl(2,1,j) + gc2 * vl(2,2,j)  + &
                          gc3 * vl(2,3,j) + gc4 * vl(2,4,j)  + &
                          gc5 * vl(2,5,j)

              rl(3,1,j) = zero
              rl(4,1,j) = gc1 * vl(4,1,j) + gc2 * vl(4,2,j)  + &
                          gc3 * vl(4,3,j) + gc4 * vl(4,4,j)  + &
                          gc5 * vl(4,5,j)
              rl(5,1,j) = gc1 * vl(5,1,j) + gc2 * vl(5,2,j)  + &
                          gc3 * vl(5,3,j) + gc4 * vl(5,4,j)  + &
                          gc5 * vl(5,5,j)
            end do
          end if

!.... Symmetry boundary

          if (left.eq.7) then
            rl(3,1,:) = zero
          end if

        end if  ! Ma

        if (.false.) then

!.... Zero'th order extrapolation in the viscous layers

          if (extrap.eq.0) then
            rl(1,1,1:nbl) = vl(1,1,1:nbl) - vl(1,2,1:nbl)
            rl(2,1,1:nbl) = vl(2,1,1:nbl) - vl(2,2,1:nbl)
            rl(3,1,1:nbl) = vl(3,1,1:nbl) - vl(3,2,1:nbl)
            rl(4,1,1:nbl) = vl(4,1,1:nbl) - vl(4,2,1:nbl)
            rl(5,1,1:nbl) = vl(5,1,1:nbl) - vl(5,2,1:nbl)

!.... First-order extrapolation in the viscous layers

          else if (extrap.eq.1) then
            rl(:,1,1:nbl) = vl(:,1,1:nbl) - &
                            ( two * vl(:,2,1:nbl) - vl(:,3,1:nbl) )

!.... Second-order extrapolation in the viscous layers (no good)

          else if (extrap.eq.2) then
            rl(:,1,1:nbl) = vl(:,1,1:nbl) - &
                            ( three * vl(:,2,1:nbl) - three * vl(:,3,1:nbl) + &
                              vl(:,4,1:nbl) )
          end if

        end if
!=============================================================================!
!       R i g h t  B o u n d a r y
!=============================================================================!

        if (Ma.lt.one) then

!.... First-order Riemann

          if (right.eq.0) then
            call ReimannRHS( ny, vl(:,nx,:), vl(:,nx-1,:), vl(:,nx-2,:), &
                             bnr, x(nx,:), y(nx,:), rl(:,nx,:), &
                             rhobr, ubr, vbr, wbr, tbr, pbr, cbr )
          end if

!.... Symmetry boundary

          if (right.eq.7) then
            rl(3,nx,:) = zero
          end if

        end if          ! Ma

!.... Zero'th order extrapolation in the viscous layers

        if (extrap.eq.0) then
          rl(:,nx,1:nbl) = vl(:,nx,1:nbl) - vl(:,nx-1,1:nbl)

!.... First-order extrapolation in the viscous layers

        else if (extrap.eq.1) then
          rl(:,nx,1:nbl) = vl(:,nx,1:nbl) - &
                          ( two * vl(:,nx-1,1:nbl) - vl(:,nx-2,1:nbl) )
        end if

        if (right.eq.8) then            ! hold initial condition
          rl(:,nx,:) = zero
        end if

        end if                  ! xper

        end if                  ! linear

        return
        end


      SUBROUTINE cdfchn(which,p,q,x,df,pnonc,status,bound)
C**********************************************************************
C
C      SUBROUTINE CDFCHN( WHICH, P, Q, X, DF, PNONC, STATUS, BOUND )
C               Cumulative Distribution Function
C               Non-central Chi-Square
C
C
C                              Function
C
C
C     Calculates any one parameter of the non-central chi-square
C     distribution given values for the others.
C
C
C                              Arguments
C
C
C     WHICH --> Integer indicating which of the next three argument
C               values is to be calculated from the others.
C               Input range: 1..4
C               iwhich = 1 : Calculate P and Q from X and DF
C               iwhich = 2 : Calculate X from P,DF and PNONC
C               iwhich = 3 : Calculate DF from P,X and PNONC
C               iwhich = 3 : Calculate PNONC from P,X and DF
C                    INTEGER WHICH
C
C     P <--> The integral from 0 to X of the non-central chi-square
C            distribution.
C            Input range: [0, 1-1E-16).
C                    DOUBLE PRECISION P
C
C     Q <--> 1-P.
C            Q is not used by this subroutine and is only included
C            for similarity with other cdf* routines.
C                    DOUBLE PRECISION Q
C
C     X <--> Upper limit of integration of the non-central
C            chi-square distribution.
C            Input range: [0, +infinity).
C            Search range: [0,1E100]
C                    DOUBLE PRECISION X
C
C     DF <--> Degrees of freedom of the non-central
C             chi-square distribution.
C             Input range: (0, +infinity).
C             Search range: [ 1E-100, 1E100]
C                    DOUBLE PRECISION DF
C
C     PNONC <--> Non-centrality parameter of the non-central
C                chi-square distribution.
C                Input range: [0, +infinity).
C                Search range: [0,1E4]
C                    DOUBLE PRECISION PNONC
C
C     STATUS <-- 0 if calculation completed correctly
C               -I if input parameter number I is out of range
C                1 if answer appears to be lower than lowest
C                  search bound
C                2 if answer appears to be higher than greatest
C                  search bound
C                    INTEGER STATUS
C
C     BOUND <-- Undefined if STATUS is 0
C
C               Bound exceeded by parameter number I if STATUS
C               is negative.
C
C               Lower search bound if STATUS is 1.
C
C               Upper search bound if STATUS is 2.
C
C
C                              Method
C
C
C     Formula  26.4.25   of   Abramowitz   and   Stegun,  Handbook  of
C     Mathematical  Functions (1966) is used to compute the cumulative
C     distribution function.
C
C     Computation of other parameters involve a search for a value that
C     produces  the desired  value  of P.   The search relies  on  the
C     monotinicity of P with the other parameter.
C
C
C                            WARNING
C
C     The computation time  required for this  routine is proportional
C     to the noncentrality  parameter  (PNONC).  Very large  values of
C     this parameter can consume immense  computer resources.  This is
C     why the search range is bounded by 10,000.
C
C**********************************************************************
C     .. Parameters ..
      DOUBLE PRECISION tent4
      PARAMETER (tent4=1.0D4)
      DOUBLE PRECISION tol
      PARAMETER (tol=1.0D-8)
      DOUBLE PRECISION atol
      PARAMETER (atol=1.0D-50)
      DOUBLE PRECISION zero,one,inf
      PARAMETER (zero=1.0D-100,one=1.0D0-1.0D-16,inf=1.0D100)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION bound,df,p,pnonc,q,x
      INTEGER status,which
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION ccum,cum,fx
      LOGICAL qhi,qleft
C     ..
C     .. External Subroutines ..
      EXTERNAL cumchn,dinvr,dstinv
C     ..
      IF (x.GT.inf) THEN
          x = inf
      END IF
      IF (df.GT.inf) THEN
          df = inf
      END IF
      IF (pnonc.GT.tent4) THEN
          pnonc = tent4
      END IF

      IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30
      IF (.NOT. (which.LT.1)) GO TO 10
      bound = 1.0D0
      GO TO 20

   10 bound = 4.0D0
   20 status = -1
      RETURN

   30 IF (which.EQ.1) GO TO 70
      IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.one))) GO TO 60
      IF (.NOT. (p.LT.0.0D0)) GO TO 40
      bound = 0.0D0
      GO TO 50

   40 bound = one
   50 status = -2
      RETURN

   60 CONTINUE
   70 IF (which.EQ.2) GO TO 90
      IF (x.GE.0.0D0) GO TO 80
      bound = 0.0D0
      status = -4
      RETURN

   80 CONTINUE
   90 IF (which.EQ.3) GO TO 110
      IF (df.GT.0.0D0) GO TO 100
      bound = 0.0D0
      status = -5
      RETURN

  100 CONTINUE
  110 IF (which.EQ.4) GO TO 130
      IF (pnonc.GE.0.0D0) GO TO 120
      bound = 0.0D0
      status = -6
      RETURN

  120 CONTINUE
  130 IF ((1).EQ. (which)) THEN
          CALL cumchn(x,df,pnonc,p,q)
          status = 0

      ELSE IF ((2).EQ. (which)) THEN
          x = 5.0D0
          CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,x,fx,qleft,qhi)
  140     IF (.NOT. (status.EQ.1)) GO TO 150
          CALL cumchn(x,df,pnonc,cum,ccum)
          fx = cum - p
          CALL dinvr(status,x,fx,qleft,qhi)
          GO TO 140

  150     IF (.NOT. (status.EQ.-1)) GO TO 180
          IF (.NOT. (qleft)) GO TO 160
          status = 1
          bound = 0.0D0
          GO TO 170

  160     status = 2
          bound = inf
  170     CONTINUE
  180     CONTINUE

      ELSE IF ((3).EQ. (which)) THEN
          df = 5.0D0
          CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,df,fx,qleft,qhi)
  190     IF (.NOT. (status.EQ.1)) GO TO 200
          CALL cumchn(x,df,pnonc,cum,ccum)
          fx = cum - p
          CALL dinvr(status,df,fx,qleft,qhi)
          GO TO 190

  200     IF (.NOT. (status.EQ.-1)) GO TO 230
          IF (.NOT. (qleft)) GO TO 210
          status = 1
          bound = zero
          GO TO 220

  210     status = 2
          bound = inf
  220     CONTINUE
  230     CONTINUE

      ELSE IF ((4).EQ. (which)) THEN
          pnonc = 5.0D0
          CALL dstinv(0.0D0,tent4,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,pnonc,fx,qleft,qhi)
  240     IF (.NOT. (status.EQ.1)) GO TO 250
          CALL cumchn(x,df,pnonc,cum,ccum)
          fx = cum - p
          CALL dinvr(status,pnonc,fx,qleft,qhi)
          GO TO 240

  250     IF (.NOT. (status.EQ.-1)) GO TO 280
          IF (.NOT. (qleft)) GO TO 260
          status = 1
          bound = zero
          GO TO 270

  260     status = 2
          bound = tent4
  270     CONTINUE
  280 END IF

      RETURN

      END


c ======================================================================
c+
c NAME
c         correlate
c
c PURPOSE
c         Read in two catalogs and compute their correlation function.
c
c USAGE
c         correlate.exe
c
c INPUTS
c    A.txt
c    B.txt          2 x 4 column (x,y,e1,e2) ascii text catalogues
c    nbin           no. of bins in binning grid
c    rmax           maximum radius for binning grid
c    q              quiet operation
c
c COMMENTS
c   Best to have x and y (and so rmax) in arcsec.
c
c EXAMPLES
c   echo "stars.txt\ngalaxies.txt\n50\n100.0" |  correlate.exe
c
c OUTPUTS
c   outfiles:       3 column ascii text catalogues (r, corr, error)
c     tt.txt
c     tx.txt
c     xx.txt
c     Xiplus.txt
c     Ximinus.txt
c     Xicross.txt
c
c BUGS
c
c REVISION HISTORY:
c   2006-06-13 Marshall (KIPAC)
c
c-
c ==============================================================================

      program correlate

      implicit none

	integer nbin,nA,nB,vb
      real rmax
      character*200 catA,catB

      call options(catA,catB,nbin,rmax,vb)
      call nlines(catA,catB,nA,nB,vb)
	call driver(catA,catB,nA,nB,nbin,rmax,vb)

      end

c ==============================================================================

	subroutine options(catA,catB,nbin,rmax,vb)

      implicit none

	integer nbin,vb
      real rmax
      character*200 catA,catB

c ------------------------------------------------------------------------------

      write(*,'(a,)') 'Enter catalogue A: '
      read(*,*) catA
      write(*,'(a,)') 'Enter catalogue B: '
      read(*,*) catB
      write(*,'(a,)') 'Enter no. of bins: '
      read(*,*) nbin
      write(*,'(a,)') 'Enter maximimum radius of binning grid: '
      read(*,*) rmax
      write(*,'(a,)') 'Enter verbosity (1 or 0): '
      read(*,*) vb

	return
      end

c ==============================================================================

	subroutine nlines(catA,catB,nA,nB,vb)

      implicit none

	integer nA,nB,vb,i,j
      character*200 catA,catB
      character*80 record

c ------------------------------------------------------------------------------

      open(unit=9,file=catA,form='formatted',status='old')
      nA = 0
      do i=1,100000000
        read(9,'(a)',end=10) record
        nA = nA + 1
      enddo
 10   close(9)
      if (vb.eq.1) write(*,*) 'Read in ',nA,' lines from ',catA

      open(unit=9,file=catB,form='formatted',status='old')
      nB = 0
      do i=1,100000000
        read(9,'(a)',end=20) record
        nB = nB + 1
      enddo
 20   close(9)
      if (vb.eq.1) write(*,*) 'Read in ',nB,' lines from ',catB

	return
      end

c ==============================================================================

	subroutine driver(catA,catB,nA,nB,nbin,rmax,vb)

      implicit none

	integer nbin,nA,nB,vb
      real rmax
      character*200 catA,catB

      integer i,j,k,ohmygod,count,percent
      real xA(nA),yA(nA),e1A(nA),e2A(nA)
      real xB(nB),yB(nB),e1B(nB),e2B(nB)
      real dr,rbin(nbin)
      real r,dx,dy,cosphi,sinphi,cosphisq,sinphisq
      real cos2phi,sin2phi,cos2phisq,sin2phisq,cos2phisin2phi
      real tt,tx,xx
      real sumtt(nbin),sumsqtt(nbin)
      real meantt(nbin),errtt(nbin),errsqtt(nbin)
      real sumtx(nbin),sumsqtx(nbin)
      real meantx(nbin),errtx(nbin),errsqtx(nbin)
      real sumxx(nbin),sumsqxx(nbin)
      real meanxx(nbin),errxx(nbin),errsqxx(nbin)
      real meanXiplus(nbin),errXiplus(nbin)
      real meanXiminus(nbin),errXiminus(nbin)
      real meanXicross(nbin),errXicross(nbin)
      real totalNum(nbin)

c ------------------------------------------------------------------------------

c Set up binning grid:

c The length of each bin (dr) = total length / number of bins

      dr = rmax / float(nbin)

c rbin contains midpoints of bins, stats need zeroing

      do k=1,nbin
        rbin(k) = dr*(k - 0.5)
        sumtt(k) = 0.0
        sumsqtt(k) = 0.0
        sumtx(k) = 0.0
        sumsqtx(k) = 0.0
        sumxx(k) = 0.0
        sumsqxx(k) = 0.0
        totalNum(k) = 0.0
      enddo

c Open up files and read in data:

      open(unit=9,file=catA,form='formatted',status='old')
      do i=1,nA
        read(9,*) xA(i),yA(i),e1A(i),e2A(i)
      enddo
      close(9)
      open(unit=9,file=catB,form='formatted',status='old')
      do j=1,nB
        read(9,*) xB(j),yB(j),e1B(j),e2B(j)
      enddo
      close(9)

c ------------------------------------------------------------------------------

c Do calculations:

      ohmygod = nA*nB
      count = 0

      if (vb.eq.1) write(*,*) 'Correlating ',ohmygod,' pairs...'

	do i=1,nA
        do 10 j=1,nB

          count = count + 1

c         Compute r:

          dx = abs(xA(i) - xB(j))
          dy = abs(yA(i) - yB(j))
          r = sqrt(dx*dx + dy*dy);

          if (r.eq.0.0.or.r.gt.rmax) goto 10

c         Which bin do they go into?

          k = int(r/dr) + 1

c         Inner products: E-mode and B-mode with angles involved:

          cosphi = dx / r
          sinphi = dy / r

          cosphisq = cosphi*cosphi
          sinphisq = sinphi*sinphi
          cos2phi = cosphisq - sinphisq
          sin2phi = 2 * sinphi * cosphi
          cos2phisq = cos2phi*cos2phi
          sin2phisq = sin2phi*sin2phi
          cos2phisin2phi = cos2phi*sin2phi

c         Correlation functions from Schneider's notes -
c         build up averages as we go:

          tt =   (cos2phisq * (e1A(i)*e1B(j)))
     &         + (sin2phisq * (e2A(i)*e2B(j)))
     &         + (cos2phisin2phi * (e2A(i)*e1B(j) + e1A(i)*e2B(j)))
          sumtt(k) = sumtt(k) + tt
          sumsqtt(k) = sumsqtt(k) + tt*tt

          xx =   (cos2phisq * (e2A(i)*e2B(j)))
     &         + (sin2phisq * (e1A(i)*e1B(j)))
     &         - (cos2phisin2phi * (e1A(i)*e2B(j) + e2A(i)*e1B(j)))
          sumxx(k) = sumxx(k) + xx
          sumsqxx(k) = sumsqxx(k) + xx*xx

          tx =   (cos2phisq * (e1A(i)*e2B(j)))
     &         - (sin2phisq * (e2A(i)*e1B(j)))
     &         - (cos2phisin2phi * (e1A(i)*e1B(j) - e2A(i)*e2B(j)))
          sumtx(k) = sumtx(k) + tx
          sumsqtx(k) = sumsqtx(k) + tx*tx

          totalNum(k) = totalNum(k) + 1

  10    continue

        percent = int(100*count/ohmygod)
        if (vb.eq.1) write(*,*) percent,'% completed'

      enddo

c ------------------------------------------------------------------------------

c Open output for writing binned correlation function:

      open(unit=9,file='tt.txt',form='formatted',status='unknown')
      open(unit=10,file='tx.txt',form='formatted',status='unknown')
      open(unit=11,file='xx.txt',form='formatted',status='unknown')
      open(unit=12,file='Xiplus.txt',form='formatted',status='unknown')
      open(unit=13,file='Ximinus.txt',form='formatted',status='unknown')
      open(unit=14,file='Xicross.txt',form='formatted',status='unknown')

C Write out stats:

      do k=1,nbin

        if (totalNum(k).gt.1) then

c         Calculate mean and squared error on mean, for tt, tx, xx:
          meantt(k)  = sumtt(k) / totalNum(k)
          errsqtt(k) = (sumsqtt(k)/totalNum(k) - meantt(k)*meantt(k)) /
     &                                (totalNum(k)-1.0)
          errtt(k) = sqrt(errsqtt(k))

          meantx(k)  = sumtx(k) / totalNum(k)
          errsqtx(k) = (sumsqtx(k)/totalNum(k) - meantx(k)*meantx(k)) /
     &                                (totalNum(k)-1.0)
          errtx(k) = sqrt(errsqtx(k))

          meanxx(k)  = sumxx(k) / totalNum(k)
          errsqxx(k) = (sumsqxx(k)/totalNum(k) - meanxx(k)*meanxx(k)) /
     &                                (totalNum(k)-1.0)
          errxx(k) = sqrt(errsqxx(k))

c         Now form three correlation functions:

          meanXiplus(k) = meantt(k) + meanxx(k)
          errXiplus(k) = sqrt(errsqtt(k) + errsqxx(k))
          meanXiminus(k) = meantt(k) - meanxx(k)
          errXiminus(k) = sqrt(errsqtt(k) + errsqxx(k))
          meanXicross(k) = meantx(k)
          errXicross(k) = errtx(k)

c         Append to file:

          r = rbin(k)

          write(9,'(f10.1,3x,e13.6,3x,e13.6)')  r,meantt(k),errtt(k)
          write(10,'(f10.1,3x,e13.6,3x,e13.6)') r,meantx(k),errtx(k)
          write(11,'(f10.1,3x,e13.6,3x,e13.6)') r,meanxx(k),errxx(k)
          write(12,'(f10.1,3x,e13.6,3x,e13.6)') r,meanXiplus(k),errXiplus(k)
          write(13,'(f10.1,3x,e13.6,3x,e13.6)') r,meanXiminus(k),errXiminus(k)
          write(14,'(f10.1,3x,e13.6,3x,e13.6)') r,meanXicross(k),errXicross(k)

        endif

      enddo

c Shut up shop:

      close(9)
      close(10)
      close(11)
      close(12)
      close(13)
      close(14)

c ------------------------------------------------------------------------------

      return
      end

c ==============================================================================


! The Computer Language Benchmarks Game
! https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
!
!   Translated from Mark C. Lewis nbody.java by Simon Geard
!   Revised by Mike Garrahan
!
! ifort -O3 -xHost -o nbody nbody.f90
! gFortran
!   https://benchmarksgame-team.pages.debian.net/benchmarksgame/program/nbody-gfortran-3.html
! - single-core: gfortran -O3 -o fnbody nbody.f90; time ./fnbody 50000000

program nbody
  implicit none
  integer, parameter :: dp = selected_real_kind(15, 307)

  real(dp), parameter :: TSTEP = 0.01d0
  real(dp), parameter :: PI = 3.141592653589793d0
  real(dp), parameter :: SOLAR_MASS = 4 * PI * PI
  real(dp), parameter :: DAYS_PER_YEAR = 365.24d0

  integer, parameter :: NB = 5
  integer, parameter :: NPAIR = NB * (NB - 1) / 2

  real(dp) :: x(3,NB), v(3,NB), mass(NB)
  real(dp) :: e

  integer :: nstep, i
  character(len=8) :: argv

  call getarg(1, argv)
  read (argv,*) nstep

  call init(x, v, mass)

  e = energy(x, v, mass)
  write (*,'(f12.9)') e

  do i = 1, nstep
     call advance(x, v, mass)
  end do

  e = energy(x, v, mass)
  write (*,'(f12.9)') e

contains

  subroutine advance(x, v, mass)
    real(dp), intent(inout) :: x(3,NB), v(3,NB)
    real(dp), intent(in) :: mass(NB)

    real(dp) :: r(3,NPAIR), rmag(3)
    real(dp) :: distance(NPAIR), mag(NPAIR)
    integer :: i, j, k

    k = 1
    do i = 1, NB - 1
       do j = i + 1, NB
          r(:,k) = x(:,i) - x(:,j)
          k = k + 1
       end do
    end do

    distance = sqrt(sum(r**2, dim=1))
    mag = TSTEP / distance**3

    k = 1
    do i = 1, NB - 1
       do j = i + 1, NB
          rmag = mag(k) * r(:,k)
          v(:,i) = v(:,i) - mass(j) * rmag
          v(:,j) = v(:,j) + mass(i) * rmag
          k = k + 1
       end do
    end do

    x = x + TSTEP * v
  end subroutine advance

  function energy(x, v, mass)
    real(dp) :: energy
    real(dp), intent(in) :: x(3,NB), v(3,NB), mass(NB)

    real(dp) :: r(3), distance, ke, pe
    integer :: i, j

    ke = 0.5d0 * dot_product(mass, sum(v**2, dim=1))
    pe = 0.0d0
    do i = 1, NB - 1
       do j = i + 1, NB
          r = x(:,i) - x(:,j)
          distance = sqrt(sum(r**2))
          pe = pe - mass(i) * mass(j) / distance
       end do
    end do
    energy = ke + pe
  end function energy

  subroutine init(x, v, mass)
    real(dp), intent(out) :: x(3,NB), v(3,NB), mass(NB)
    integer, parameter :: SUN = 1, JUPITER = 2, SATURN = 3, &
         URANUS = 4, NEPTUNE = 5
    real(dp) :: momentum(3)

    x(:,JUPITER) = (/ &
         4.84143144246472090d+00, &
        -1.16032004402742839d+00, &
        -1.03622044471123109d-01 /)
    v(:,JUPITER) = (/ &
         1.66007664274403694d-03, &
         7.69901118419740425d-03, &
        -6.90460016972063023d-05 /)
    mass(JUPITER) = &
         9.54791938424326609d-04

    x(:,SATURN) = (/ &
         8.34336671824457987d+00, &
         4.12479856412430479d+00, &
        -4.03523417114321381d-01 /)
    v(:,SATURN) = (/ &
        -2.76742510726862411d-03, &
         4.99852801234917238d-03, &
         2.30417297573763929d-05 /)
    mass(SATURN) = &
         2.85885980666130812d-04

    x(:,URANUS) = (/ &
         1.28943695621391310d+01, &
        -1.51111514016986312d+01, &
        -2.23307578892655734d-01 /)
    v(:,URANUS) = (/ &
         2.96460137564761618d-03, &
         2.37847173959480950d-03, &
        -2.96589568540237556d-05 /)
    mass(URANUS) = &
         4.36624404335156298d-05

    x(:,NEPTUNE) = (/ &
         1.53796971148509165d+01, &
        -2.59193146099879641d+01, &
         1.79258772950371181d-01 /)
    v(:,NEPTUNE) = (/ &
         2.68067772490389322d-03, &
         1.62824170038242295d-03, &
        -9.51592254519715870d-05 /)
    mass(NEPTUNE) = &
         5.15138902046611451d-05

    x(:,SUN) = 0.0d0
    v(:,SUN) = 0.0d0
    mass(SUN) = 1.0d0

    v = v * DAYS_PER_YEAR
    mass = mass * SOLAR_MASS

    momentum = matmul(v, mass)
    v(:,SUN) = v(:,SUN) - momentum / mass(SUN)
  end subroutine init

end program nbody


      PROGRAM XCLUST
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*  VERSION 3.02  MARCH 1997                                           *
C*  * Minor change to FORMAT statement 6080                            *
C*                                                                     *
C***********************************************************************
C
C  EXAMPLE PROGRAM FOR CLUSTER ANALYSIS.  THE PROGRAM READS IN
C  ATTRIBUTES FOR A NUMBER OF SITES, TRANSFORMS THE ATTRIBUTES, FORMS
C  CLUSTERS BY WARD'S METHOD, PRINTS INFORMATION ABOUT THE CLUSTERS,
C  AND REFINES THE CLUSTERS USING THE K-MEANS ALGORITHM.
C    THE ANALYSIS FOLLOWS HOSKING AND WALLIS ("REGIONAL FREQUENCY
C  ANALYSIS: AN APPROACH BASED ON L-MOMENTS", CAMBRIDGE UNIV. PRESS,
C  1997, SEC. 9.2).
C
C  PARAMETERS OF PROGRAM:
C  MAXNS  - MAXIMUM NUMBER OF SITES
C  NATMAX - MAXIMUM NUMBER OF ATTRIBUTES
C  INFILE - STREAM NUMBER TO WHICH INPUT FILE IS ATTACHED
C  KOUT   - STREAM NUMBER TO WHICH OUTPUT FILE IS ATTACHED
C
C  ROUTINES USED: CLUAGG,CLUINF,CLUKM,KMNS,OPTRA,QTRAN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER (MAXNS=104,NATMAX=10,INFILE=7,KOUT=6)
C
      PARAMETER (NWORK=MAXNS*(MAXNS-1)/2,NRWORK=NWORK)
      CHARACTER*12 ID(MAXNS)
      INTEGER MERGE(2,MAXNS),IWORK(MAXNS),NREC(MAXNS),
     *  IASSGN(MAXNS),LIST(MAXNS),NUM(MAXNS)
      DOUBLE PRECISION X(MAXNS,NATMAX),WGSS(MAXNS),WORK(NWORK),
     *  WEIGHT(NATMAX),XMOM(5,MAXNS),Z(NATMAX),CENT(NATMAX,MAXNS)
      REAL RWORK(NRWORK)
      DATA ZERO/0D0/,ONE/1D0/,THREE/3D0/
C
      N=104
      READ(INFILE,*)
C
C         FOR EACH DATA POINT ...
C
      DO 10 I=1,N
C
C         ... READ THE DATA ...
C
      READ(INFILE,5000)ID(I),XLAT,XLONG,AREA,ELEV
C
C         ... AND COMPUTE THE TRANSFORMED ATTRIBUTES
C
      X(I,1)=DLOG(AREA)
      X(I,2)=DSQRT(ELEV)
      X(I,3)=XLAT
      X(I,4)=XLONG
C
C         END OF LOOP OVER DATA POINTS
C
   10 CONTINUE
C
C         SET WEIGHTS FOR EACH ATTRIBUTE
C
      NATT=4
      WEIGHT(1)=THREE
      WEIGHT(2)=ONE
      WEIGHT(3)=ONE
      WEIGHT(4)=ONE
C
C         FOR EACH ATTRIBUTE ...
C
      DO 40 J=1,NATT
C
C         ... CALCULATE ITS STANDARD DEVIATION ACROSS THE DATA POINTS ...
C
      SUM1=ZERO
      SUM2=ZERO
      DO 20 I=1,N
      SUM1=SUM1+X(I,J)
      SUM2=SUM2+X(I,J)**2
   20 CONTINUE
      SD=DSQRT((SUM2-SUM1*SUM1/N)/(N-ONE))
C
C         ... DIVIDE THE WEIGHT BY THIS STANDARD DEVIATION ...
C
      WEIGHT(J)=WEIGHT(J)/SD
C
C         ... AND APPLY THE WEIGHT TO EACH DATA POINT
C
      DO 30 I=1,N
   30 X(I,J)=X(I,J)*WEIGHT(J)
C
C         END OF LOOP OVER ATTRIBUTES
C
   40 CONTINUE
C
C         WARD'S ALGORITHM
C
      NX=MAXNS
      NW=NWORK
      CALL CLUAGG(3,X,NX,N,NATT,MERGE,WGSS,IWORK,WORK,NW)
      WRITE(KOUT,6000)
      DO 50 I=1,N-1
      WRITE(KOUT,6010)I,N-I,MERGE(1,I),MERGE(2,I),WGSS(I)
   50 CONTINUE
C
C         PRINT INFORMATION ABOUT THE 7-CLUSTER GROUPING
C
      NCLUST=7
      CALL CLUINF(NCLUST,N,MERGE,IASSGN,LIST,NUM)
      WRITE(KOUT,6020)
      WRITE(KOUT,6030)(IASSGN(I),I=1,N)
      WRITE(KOUT,6040)
      IORIG=0
      DO 60 ICL=1,NCLUST
      NN=NUM(ICL)
      WRITE(KOUT,6050)ICL,NN
      WRITE(KOUT,6060)(IABS(LIST(I)),I=IORIG+1,IORIG+NN)
      IORIG=IORIG+NN
   60 CONTINUE
C
C         ADJUST CLUSTERS BY K-MEANS ALGORITHM
C
      MAXIT=10
      CALL CLUKM(X,NX,N,NATT,NCLUST,IASSGN,LIST,NUM,SS,MAXIT,IWORK,
     *  RWORK,NRWORK)
C
C         PRINT INFORMATION ABOUT ADJUSTED CLUSTERS
C
      WRITE(KOUT,6070)SS
      WRITE(KOUT,6020)
      WRITE(KOUT,6030)(IASSGN(I),I=1,N)
      WRITE(KOUT,6040)
      IORIG=0
      DO 70 ICL=1,NCLUST
      NN=NUM(ICL)
      WRITE(KOUT,6050)ICL,NN
      WRITE(KOUT,6060)(IABS(LIST(I)),I=IORIG+1,IORIG+NN)
      IORIG=IORIG+NN
   70 CONTINUE
C
C         FIND CLUSTER CENTERS, IN SPACE OF TRANSFORMED ATTRIBUTES
C
      WRITE(KOUT,6080)
      DO 80 ICL=1,NCLUST
      DO 80 IATT=1,NATT
   80 CENT(IATT,ICL)=ZERO
      ICL=1
      DO 100 I=1,N
      L=LIST(I)
      ISITE=IABS(L)
      DO 90 IATT=1,NATT
      CENT(IATT,ICL)=CENT(IATT,ICL)+X(ISITE,IATT)
   90 CONTINUE
      IF(L.LT.0)ICL=ICL+1
  100 CONTINUE
      DO 110 ICL=1,NCLUST
      NN=NUM(ICL)
      DO 110 IATT=1,NATT
  110 CENT(IATT,ICL)=CENT(IATT,ICL)/NN
C
C         TRANSFORM BACK TO ORIGINAL ATTRIBUTES
C
      DO 120 ICL=1,NCLUST
      Z(1)=DEXP(CENT(1,ICL)/WEIGHT(1))
      Z(2)=(CENT(2,ICL)/WEIGHT(2))**2
      Z(3)=CENT(3,ICL)/WEIGHT(3)
      Z(4)=CENT(4,ICL)/WEIGHT(4)
      WRITE(KOUT,6090)ICL,(Z(J),J=1,NATT)
  120 CONTINUE
C
      STOP
C
 5000 FORMAT(A8,4F8.0)
 6000 FORMAT(' MERGING SEQUENCE FROM WARD''S ALGORITHM'//
     * 8X,'NUMBER OF    MERGED       SUM OF'/
     * ' STAGE  CLUSTERS    CLUSTERS      SQUARES'/)
 6010 FORMAT(1X,I3,I9,I10,I5,F12.2)
 6020 FORMAT(/' ASSIGNMENT OF SITES TO CLUSTERS')
 6030 FORMAT(1X,10I4)
 6040 FORMAT(//' CLUSTER MEMBERSHIP')
 6050 FORMAT(/' CLUSTER',I4,'  HAS',I4,' MEMBERS:')
 6060 FORMAT(1X,10I4)
 6070 FORMAT(///' ADJUSTED CLUSTERS FROM K-MEANS ALGORITHM'/
     *  ' (SUM OF SQUARES =',F12.2,')')
 6080 FORMAT(/' CLUSTER CENTERS'/
     *  '          AREA      ELEV       LAT      LONG')
 6090 FORMAT(1X,I3,6F10.2)
C
      END


c     ##########################################################
c     # Program for vector limiting for cutcells               #
c     #                                                        #
c     ##########################################################

      subroutine vector_lim_allineq(num_neighb,neighb_x,neighb_y,
     &    neighb_u,center_x,center_y,center_u,output_debug,row_A,
     & Phi_x,Phi_y,LP_Dx,LP_Dy,LP_success,LS_Dx,LS_Dy,bxpt,bypt,
     & do_pos_constr,my_iters)

c :::::::::::::::::::::::::::: VECTOR_LIM ::::::::::::::::::::::
c
c    This routine does:
c     * set up the 2d LP
c             - build the matrix A and rhs b
c             - initialize x0 and c appropriately
c             - call the subroutine 'Simplex_allineq' -- that's Simplex in allineq form
c
c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c     uses the restrictive constraints (don't overshoot and correct direction)
c :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
c
c  INPUT:
c     * num_neighb: number of neighboring cells used for limiting
c     * neighb_x(num_neighb), neighb_y(num_neighb): x- and y-coordinates of neighbors
c     * neighb_u(num_neighb): cell value of neighbors
c     * center_x,center_y,center_u: data for central cell
c     * output_debug: how much output do you want?
c     * row_A,column_A: dimension of constraint matrix A in LP
c     * LS_Dx,LS_Dy: least square gradient
c     * bxpt,bypt: x- & y-coord of the boundary edge midpoint
c     * do_pos_constr: if true, then add pos constraint for boundary edge midpoint
c
c  OUTPUT:
c     * Phi_x,Phi_y: scalar factors that limit LS_Dx to LP_Dx (same for y)
c     * LP_Dx,LP_Dy: results of LP: limited slopes
c     * LP_success: was the Simplex algorithm successful?
c     * my_iters: number of iterations needed in the Simplex-algorithm
c
c :::::::::::::::::::::::::::::::::::::::;:::::::::::::::::::::::

c     ::::::::::::::::::::::::::::
c     Declare variables
c     ::::::::::::::::::::::::::::

      implicit none  ! force yourself to properly declare all var

c     Input
      integer num_neighb
      double precision neighb_x(num_neighb), neighb_y(num_neighb)
      double precision neighb_u(num_neighb)
      double precision center_x, center_y, center_u
      logical output_debug
      integer row_A ! number of constraints in LP, ie number of rows in matrix
      ! number of rows: 2
      double precision LS_Dx, LS_Dy, bxpt, bypt
      logical do_pos_constr

c     Output
      double precision Phi_x, Phi_y
      double precision LP_Dx, LP_Dy
      logical LP_success
      integer my_iters

c     Local variables: check num_neighb not too big
      integer max_num_neighb
c      parameter (max_num_neighb = 5)
      parameter (max_num_neighb = 8)
      logical output_debug_here
      logical temp_output

c     Local variables: for least square problem
c      double precision S(num_neighb,2) ! matrix for LS problem
c      double precision S_rhs(num_neighb),rhs_LS(2) ! rhs's for LS problem
c      double precision LS_Dx, LS_Dy    ! solution of LS problem
c      double precision normal_matrix(2,2) ! S'*S
c      character   TRANSA, TRANSB
c      integer ind_perm(2)  ! permutation array coming back from solving matrix
c      integer INFO ! was subroutine of LAPACK successful?

c     Local variables: Formulating the 2d LP
      double precision A(row_A,2)   ! matrix of constraints for LP
      double precision b(row_A)  ! rhs for LP
      double precision x0(2)  ! number of unknowns
      integer W(2) ! working set
      double precision c(2) ! vector c in objective function
      double precision x(2)  ! solution vector of LP

c     Local variables: Loop variables
      integer i,j

c     ::::::::::::::::::::::::::::
c     Declare finished
c     ::::::::::::::::::::::::::::

 902     format (A,'\t',2(E25.15))
 901     format (A,'\t',3e25.15)
 903     format (A,'\t',3(e25.15,'\t'))
 904     format (A,'\t',4(e25.15,'\t'))

c     Check whether num_neighb < max_num_neighb
      if (num_neighb .GT. max_num_neighb) then
         write(*,*) "\n##########\n"
         write(*,901) "num_neighb too big: num_neighb is\t", num_neighb
         write(*,*) "\n##########\n"
         return
      endif

      if (output_debug) then
         write(*,*) "############\n Given data \n ############"
         if (num_neighb .EQ. 3) then
            write(*,903) "neighb_x", neighb_x
            write(*,903) "neighb_y", neighb_y
            write(*,903) "neighb_u", neighb_u
         elseif (num_neighb .EQ. 4) then
            write(*,904) "neighb_x", neighb_x
            write(*,904) "neighb_y", neighb_y
            write(*,904) "neighb_u", neighb_u
         endif
         write(*,902) "center_x, center_y", center_x, center_y
         write(*,901) "center_u", center_u
      endif

c     #####################################
c     Set up and solve least square problem
c     #####################################

cccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     LS solution is passed in
c
cccccccccccccccccccccccccccccccccccccccccccccccccccc

cc     IN future: try to do that by hand
c
c      do 20 i = 1, num_neighb
c         S(i,1) = neighb_x(i) - center_x
c         S(i,2) = neighb_y(i) - center_y
c  20  continue
c      do 30 i = 1, num_neighb
c         S_rhs(i) = neighb_u(i) - center_u
c  30  continue
c      if (output_debug) then
c         write(*,*) "############\n LS problem \n ############"
c         do 31 i = 1, num_neighb
c            write(*,902) "S", (S(i,j),j=1,2)
c 31      continue
c         if (num_neighb .EQ. 3) then
c            write(*,903) "RHS of LS problem", S_rhs
c         elseif (num_neighb .EQ. 4) then
c            write(*,904) "RHS of LS problem", S_rhs
c         endif
c      endif
c
cc     calculate S'*S
c      TRANSA = 'T'
c      TRANSB = 'N'
c      call DGEMM ( TRANSA, TRANSB, 2, 2, num_neighb, 1.0d0, S,
c     &        num_neighb,S, num_neighb, 0.0d0, normal_matrix,2 )
c
c      if (output_debug) then
c          do 32 i = 1, 2
c            write(*,902) "S'*S", (normal_matrix(i,j),j=1,2)
c 32      continue
c      endif
c
cc     calculate S'*r
c      rhs_LS(1) = 0.0d0
c      rhs_LS(2) = 0.0d0
c      do 33 i = 1, num_neighb
c         rhs_LS(1) = rhs_LS(1) + S(i,1)*S_rhs(i)
c         rhs_LS(2) = rhs_LS(2) + S(i,2)*S_rhs(i)
c 33   continue
c      if (output_debug) then
c         write(*,902) "S'*RHS", rhs_LS
c      endif
c
cc     dgesv: lapack routine for solving Ax=b for x
cc            On exit, if INFO = 0, then (LS_Dx,LS_Dy) = rhs_LS
c      call DGESV( 2,1,normal_matrix,2,ind_perm,rhs_LS,2, INFO)
cc     NOTE: normal_matrix and rhs_LS are lost after this call
c
c      if (INFO.EQ.0) then
c         LS_Dx = rhs_LS(1)
c         LS_Dy = rhs_LS(2)
c      else
c         write(*,*) "\n Error in subroutine dgesv ",
c     &      "when solving LS problem !!!!!!!!!!!!\n"
c         write(*,*) "Info comes back to", INFO
c         stop
c      endif
c      if (output_debug) then
c         write(*,902) "Solution of LS problem", LS_Dx, LS_Dy
c      endif

c     #######################
c     Formulate 2d LP
c     #######################

         if (output_debug) then
            write(*,*) "############\n Formulate 2d LP \n ############"
         endif

c            ::::::::::::::::::::::
c            initialize A and b
c            ::::::::::::::::::::::

c            Initialize with 0
             do 60 j = 1, 2
                do 70 i = 1, row_A
                   A(i,j) = 0.0d0
  70            continue
  60         continue
             do 80 i = 1, row_A
                b(i) = 0.0d0
  80         continue
c            Add identity matrix in A and the 1's for <=1 condition
             A(1,1) = 1.0d0
             A(2,2) = 1.0d0
             A(3,1) = -1.0d0
             A(4,2) = -1.0d0
             b(3) = -1.0d0
             b(4) = -1.0d0

c            Add data constraints
             do 100 i = 1, num_neighb
                if ((neighb_u(i)-center_u).GT.0) then
                   A(2*i+3,1) = -LS_Dx*(neighb_x(i)-center_x)
                   A(2*i+3,2) = -LS_Dy*(neighb_y(i)-center_y)
                   A(2*i+4,1) = LS_Dx*(neighb_x(i)-center_x)
                   A(2*i+4,2) = LS_Dy*(neighb_y(i)-center_y)
                   b(2*i+3) = center_u-neighb_u(i)
                   b(2*i+4) = 0.0d0
               else
                   A(2*i+3,1) = LS_Dx*(neighb_x(i)-center_x)
                   A(2*i+3,2) = LS_Dy*(neighb_y(i)-center_y)
                   A(2*i+4,1) = -LS_Dx*(neighb_x(i)-center_x)
                   A(2*i+4,2) = -LS_Dy*(neighb_y(i)-center_y)
                   b(2*i+3) = neighb_u(i) - center_u
                   b(2*i+4) = 0.0d0
               endif
  100        continue

c          positivity constraint:
            if (do_pos_constr) then
                  A(row_A,1) = LS_Dx*(bxpt-center_x)
                  A(row_A,2) = LS_Dy*(bypt-center_y)
                  b(row_A) = - center_u
            endif

            x0(1) = 0.0d0
            x0(2) = 0.0d0
            c(1) = -abs(LS_Dx)
            c(2) = -abs(LS_Dy)
            x(1) = 0.0d0
            x(2) = 0.0d0
            W(1) = 1
            W(2) = 2

            temp_output = output_debug   ! more output asked for
            LP_success = .FALSE.

c          call 'Simplex_allineq' solver

           if (output_debug) then
            write(*,*) "\n########\n Call Simplex allineq\n#######\n"
           endif

           my_iters = 50  ! should be set to the correct value in Simplex_allineq if that routine was successful

            call Simplex_allineq(row_A,A, b, c,
     &        x0,W,temp_output,x,LP_success,my_iters)
c            write(*,*) "LP_success",LP_success

            if (LP_success) then
               LP_Dx = LS_Dx*x(1)
               LP_Dy = LS_Dy*x(2)
               Phi_x = x(1)
               Phi_y = x(2)
c               write(*,902) "limited slopes", LP_Dx, LP_Dy
c               write(*,*) "\n ###################### \n"
            endif

      return
      end


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail,com)

! 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 and documentation.

! 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.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE ROT_COMP_ELEM_AXES ( IPLY, THETA, DIRECTION )

! Rotates axes of a ply material and CTE matrices in ply coords to coords along and perpendicular to element material axes, or
! vice versa, depending on input arg DIRECTION

! Ref 1: "Stress Tensor coord transform.doc" my derivation documented in a WORD file located in \MYSTRAN\Documentation (this would
! be T1P in the code below)

! Ref 2: "Practical Analysis of Composites" by J.N. Reddy and A. Miravete, CRC Press, 1995 section 3.3. Eqn 7 in Ref 2 is matrix T1
! whereas my matrix is T1P (in the code below). Note that Ref 2 stress tensor definition and mine have a different order:

!      -------------------------------------------------------------------------
!     | Ref 2 stress tensor for matrix T1 | MYSTRAN stress tensor for matrix T1P|
!     |-----------------------------------|-------------------------------------|
!     |         sig-1 = sig-xx            |            sig-1 = sig-xx           |
!     |         sig-2 = sig-yy            |            sig-2 = sig-yy           |
!     |         sig-3 = sig-zz            |            sig-3 = sig-zz           |
!     |         sig-4 = sig-yz            |            sig-4 = sig-xy           |
!     |         sig-5 = sig-zx            |            sig-5 = sig-yz           |
!     |         sig-6 = sig-xy            |            sig-6 = sig-zx           |
!      -------------------------------------------------------------------------

! Thus, rows and cols 4 and 6 are transposed between Ref 2 matrix T1 and the code here for matrix T1P

! Terms from T1 transform the stresses (in vector, not tensor format) and material matrix and terms from T1' transform strains (in
! vector, not tensor format)

! Note that we can get these terms from the T1 matrix in Ref 2 (rather than the procedure outlined in subr ROT_AXES_MATL_TO_LOC)
! since the transformation here involves only one coord transformation, not 2 in subr ROT_AXES_MATL_TO_LOC (which rotates from
! material to local via basic system since we can't go directly from material to local in that case)

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  ERR, F04, F06, WRT_LOG
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR, MEMATC
      USE TIMDAT, ONLY                :  TSEC
      USE CONSTANTS_1, ONLY           :  CONV_DEG_RAD, ZERO, HALF, ONE, TWO, FOUR
      USE DEBUG_PARAMETERS, ONLY      :  DEBUG
      USE MODEL_STUF, ONLY            :  ALPVEC, EB, EM, ET, EBM, INTL_MID, MTRL_TYPE, STRESS, STRAIN, T1P, T1M, T1T, T2P, T2M, T2T

      USE SUBR_BEGEND_LEVELS, ONLY    :  ROT_COMP_ELEM_AXES_BEGEND

      USE ROT_COMP_ELEM_AXES_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'ROT_COMP_ELEM_AXES'
      CHARACTER(LEN=*), INTENT(IN)    :: DIRECTION         ! =1-2, rotate from ply to elem mat'l axes (when gen ABD matrices)
!                                                            =2-1, rotate stress from elem mat'l to ply axes (when recov stresses)

      INTEGER(LONG), INTENT(IN)       :: IPLY              ! Ply number
      INTEGER(LONG)                   :: I,J               ! DO loop indices
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = ROT_COMP_ELEM_AXES_BEGEND

      REAL(DOUBLE), INTENT(IN)        :: THETA             ! Orient angle of long dir of ply i wrt matl axis for the composite elem
      REAL(DOUBLE)                    :: ALP3(3,MEMATC)    ! The 3 rows of ALPVEC for membrane strains
      REAL(DOUBLE)                    :: C,S,SC            ! COS, SIN, SIN*COS of RADIANS_ROT
      REAL(DOUBLE)                    :: C2,S2             ! C*C, S*S
      REAL(DOUBLE)                    :: RADIANS_ROT       ! Angle (radians) to rotate from elem material axes to ply axes
      REAL(DOUBLE)                    :: DUM1(3)           ! Intermediate matrix
      REAL(DOUBLE)                    :: DUM2(3)           ! Intermediate matrix
      REAL(DOUBLE)                    :: DUM3(3)           ! Intermediate matrix
      REAL(DOUBLE)                    :: DUM33(3,3)        ! Intermediate matrix
      REAL(DOUBLE)                    :: DUM22(2,2)        ! Intermediate matrix
      REAL(DOUBLE)                    :: DUM3M(3,MEMATC)   ! Intermediate matrix
      REAL(DOUBLE)                    :: STRESS1(3)        ! Rows 1-3 of STRESS
      REAL(DOUBLE)                    :: STRESS2(3)        ! Rows 4-6 of STRESS
      REAL(DOUBLE)                    :: STRESS3(3)        ! Rows 7-9 of STRESS
      REAL(DOUBLE)                    :: STRAIN1(3)        ! Rows 1-3 of STRAIN
      REAL(DOUBLE)                    :: STRAIN2(3)        ! Rows 4-6 of STRAIN
      REAL(DOUBLE)                    :: STRAIN3(3)        ! Rows 7-9 of STRAIN
      REAL(DOUBLE)                    :: T1Mt(3,3)         ! Transpose of T1M
      REAL(DOUBLE)                    :: T1Tt(2,2)         ! Transpose of T1T
      REAL(DOUBLE)                    :: T1T3(3,3)         ! T1T expanded to 3x3
      REAL(DOUBLE)                    :: T2T3(3,3)         ! T2T expanded to 3x3

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Calc T1P matrix from eqn 3.3-7 in Ref 1. (with order 1,2,3,4,5,6 changed to 1,2,3,6,4,5 to account for the fact that Ref (1) has
! the 6 position for xy stress whereas it is the 4th position here)

      RADIANS_ROT = CONV_DEG_RAD*THETA                     ! THETA is angle (deg) from elem matl axis to ply K longitudinal axis
      C  = DCOS(RADIANS_ROT)
      S  = DSIN(RADIANS_ROT)
      SC = S*C
      C2 = C*C
      S2 = S*S

! Transformation matrix T1P is 6x6 for transforming 3D solid material matrices from ply coords to element coords. Notice that this
! is the same as matrix T1 in Ref 2 except that the ordering of rows and cols is different since my definition of the stress tensor
! has a different ordering than Ref 2

      T1P(1,1) =  C2    ;  T1P(1,2) =  S2    ;  T1P(1,3) =  ZERO  ;  T1P(1,4) = -TWO*SC   ;  T1P(1,5) =  ZERO  ;  T1P(1,6) =  ZERO

      T1P(2,1) =  S2    ;  T1P(2,2) =  C2    ;  T1P(2,3) =  ZERO  ;  T1P(2,4) =  TWO*S*C  ;  T1P(2,5) =  ZERO  ;  T1P(2,6) =  ZERO

      T1P(3,1) =  ZERO  ;  T1P(3,2) =  ZERO  ;  T1P(3,3) =  ONE   ;  T1P(3,4) =  ZERO     ;  T1P(3,5) =  ZERO  ;  T1P(3,6) =  ZERO

      T1P(4,1) =  SC    ;  T1P(4,2) = -SC    ;  T1P(4,3) =  ZERO  ;  T1P(4,4) =  C2 - S2  ;  T1P(4,5) =  ZERO  ;  T1P(4,6) =  ZERO

      T1P(5,1) =  ZERO  ;  T1P(5,2) =  ZERO  ;  T1P(5,3) =  ZERO  ;  T1P(5,4) =  ZERO     ;  T1P(5,5) =  C     ;  T1P(5,6) =  S

      T1P(6,1) =  ZERO  ;  T1P(6,2) =  ZERO  ;  T1P(6,3) =  ZERO  ;  T1P(6,4) =  ZERO     ;  T1P(6,5) = -S     ;  T1P(6,6) =  C

! T1M and T1T are portions of T1P for membrane and transverse shear (for 2D shell elements)

      T1M(1,1) = T1P(1,1)   ;   T1M(1,2) = T1P(1,2)   ;   T1M(1,3) = T1P(1,4)
      T1M(2,1) = T1P(2,1)   ;   T1M(2,2) = T1P(2,2)   ;   T1M(2,3) = T1P(2,4)
      T1M(3,1) = T1P(4,1)   ;   T1M(3,2) = T1P(4,2)   ;   T1M(3,3) = T1P(4,4)

      T1T(1,1) = T1P(5,5)   ;   T1T(1,2) = T1P(6,5)
      T1T(2,1) = T1P(5,6)   ;   T1T(2,2) = T1P(6,6)

! Transformation matrix T2P is the inverse of T1P.

      T2P(1,1) =  C2    ;  T2P(1,2) =  S2    ;  T2P(1,3) =  ZERO  ;  T2P(1,4) =  TWO*SC   ;  T2P(1,5) =  ZERO  ;  T2P(1,6) =  ZERO

      T2P(2,1) =  S2    ;  T2P(2,2) =  C2    ;  T2P(2,3) =  ZERO  ;  T2P(2,4) = -TWO*S*C  ;  T2P(2,5) =  ZERO  ;  T2P(2,6) =  ZERO

      T2P(3,1) =  ZERO  ;  T2P(3,2) =  ZERO  ;  T2P(3,3) =  ONE   ;  T2P(3,4) =  ZERO     ;  T2P(3,5) =  ZERO  ;  T2P(3,6) =  ZERO

      T2P(4,1) = -SC    ;  T2P(4,2) =  SC    ;  T2P(4,3) =  ZERO  ;  T2P(4,4) =  C2 - S2  ;  T2P(4,5) =  ZERO  ;  T2P(4,6) =  ZERO

      T2P(5,1) =  ZERO  ;  T2P(5,2) =  ZERO  ;  T2P(5,3) =  ZERO  ;  T2P(5,4) =  ZERO     ;  T2P(5,5) =  C     ;  T2P(5,6) = -S

      T2P(6,1) =  ZERO  ;  T2P(6,2) =  ZERO  ;  T2P(6,3) =  ZERO  ;  T2P(6,4) =  ZERO     ;  T2P(6,5) =  S     ;  T2P(6,6) =  C

!  T2M and T2T are portions of T2P for membrane and transverse shear (for 2D shell elements)

      T2M(1,1) = T2P(1,1)   ;   T2M(1,2) = T2P(1,2)   ;   T2M(1,3) = T2P(1,4)
      T2M(2,1) = T2P(2,1)   ;   T2M(2,2) = T2P(2,2)   ;   T2M(2,3) = T2P(2,4)
      T2M(3,1) = T2P(4,1)   ;   T2M(3,2) = T2P(4,2)   ;   T2M(3,3) = T2P(4,4)

      T2T(1,1) = T2P(5,5)   ;   T2T(1,2) = T2P(5,6)
      T2T(2,1) = T2P(6,5)   ;   T2T(2,2) = T2P(6,6)

! Do transformation

      IF      (DIRECTION == '1-2') THEN                    ! Transform material and CTE matrices from ply to elem material axes
                                                           ! (1) Membrane matl matrix
         DO I=1,3
            DO J=1,3
               T1Mt(I,J) = T1M(J,I)
            ENDDO
         ENDDO

         DO I=1,2
            DO J=1,2
               T1Tt(I,J) = T1T(J,I)
            ENDDO
         ENDDO

         DO I=1,3                                          ! Transform ALPVEC rows for ply membrane from ply to elem axes
            DO J=1,MEMATC
               ALP3(I,J) = ALPVEC(I,J)
            ENDDO
         ENDDO

         CALL MATMULT_FFF ( T1M   , EM  , 3, 3, 3, DUM33 ) ! (1) Transform EM  membrane matl matrix from ply to elem coords
         CALL MATMULT_FFF ( DUM33 , T1Mt, 3, 3, 3, EM)

         CALL MATMULT_FFF ( T1M   , EB  , 3, 3, 3, DUM33 ) ! (2) Transform EB  bending matl matrix from ply to elem coords
         CALL MATMULT_FFF ( DUM33 , T1Mt, 3, 3, 3, EB)

         CALL MATMULT_FFF ( T1T   , ET  , 2, 2, 2, DUM22 ) ! (3) Transform TM  transverse shear matl matrix from ply to elem coords
         CALL MATMULT_FFF ( DUM22 , T1Tt, 2, 2, 2, ET)

         CALL MATMULT_FFF ( T1M   , EBM , 3, 3, 3, DUM33 ) ! (4) Transform EBM bending/membrane matl matrix from ply to elem coords
         CALL MATMULT_FFF ( DUM33 , T1Mt, 3, 3, 3, EBM)

         CALL MATMULT_FFF_T ( T2M, ALP3, 3, 3, MEMATC, DUM3M )

         DO I=1,6
            DO J=1,MEMATC
               ALPVEC(I,J) = ZERO
            ENDDO
         ENDDO
         DO I=1,3
            DO J=1,MEMATC
               ALPVEC(I,J) = DUM3M(I,J)
            ENDDO
         ENDDO

      ELSE IF (DIRECTION == '2-1') THEN                    ! Transform stresses in elem material axes to ply axes

         DO I=1,3                                          ! Initialize T2T3, T2T3
            DO J=1,3
               T1T3(I,J) = ZERO
               T2T3(I,J) = ZERO
            ENDDO
         ENDDO

         DO I=1,2                                          ! Load all 2x2 of T1T into upper 2x2 of T1T3
            DO J=1,2
!zzzz          T1T3  = T1T(I,J)
               T1T3(I,J)  = T1T(I,J)
            ENDDO
         ENDDO
         T1T3(3,3)  = ZERO

         DO I=1,2                                          ! Load all 2x2 of T2T into upper 2x2 of T2T3
            DO J=1,2
!zzzz          T2T3  = T2T(I,J)
               T2T3(I,J)  = T2T(I,J)
            ENDDO
         ENDDO
         T2T3(3,3)  = ZERO

         DO I=1,3                                          ! Transform axes on stress (in vector form) from elem to ply axes
            DUM1(I) = STRESS(I)
            DUM2(I) = STRESS(I+3)
            DUM3(I) = STRESS(I+6)
         ENDDO

         CALL MATMULT_FFF ( T2M , DUM1, 3, 3, 1, STRESS1 )
         CALL MATMULT_FFF ( T2M , DUM2, 3, 3, 1, STRESS2 )
         CALL MATMULT_FFF ( T2T3, DUM3, 3, 3, 1, STRESS3 )

         DO I=1,3
            STRESS(I)   = STRESS1(I)
            STRESS(I+3) = STRESS2(I)
            STRESS(I+6) = STRESS3(I)
         ENDDO

         DO I=1,3                                          ! Transform axes on strain (in vector form) from elem to ply axes
            DUM1(I) = STRAIN(I)
            DUM2(I) = STRAIN(I+3)
            DUM3(I) = STRAIN(I+6)
         ENDDO

         CALL MATMULT_FFF_T ( T1M , DUM1, 3, 3, 1, STRAIN1 )
         CALL MATMULT_FFF_T ( T1M , DUM2, 3, 3, 1, STRAIN2 )
         CALL MATMULT_FFF_T ( T1T3, DUM3, 3, 3, 1, STRAIN3 )

         DO I=1,3
            STRAIN(I)   = STRAIN1(I)
            STRAIN(I+3) = STRAIN2(I)
            STRAIN(I+6) = STRAIN3(I)
         ENDDO

      ELSE

         FATAL_ERR = FATAL_ERR
         WRITE(ERR,1962) SUBR_NAME, DIRECTION
         WRITE(F06,1962) SUBR_NAME, DIRECTION
         CALL OUTA_HERE ( 'Y' )

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
 1962 FORMAT(' *ERROR  1962: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' INPUT ARGUMENT "DIRECTION" MUST BE = "1-2" OR "2-1" BUT VALUE IS ',A)

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

      END SUBROUTINE ROT_COMP_ELEM_AXES


      subroutine pvAfill(m1sq,N)
C    N is the offset in the storage
      implicit none
      include 'pvAnames.f'
      include 'TRconstants.f'
      include 'TRonshellcutoff.f'
      include 'pvAv.f'
      include 'TRscale.f'
      integer N,Np,ep,j
      double precision m1sq
      double complex trI1
      logical,save::first=.true.
      logical,save::scaleset=.false.
      double precision,save::id(0:2),idp2(0:2)
!$omp threadprivate(scaleset,first,id,idp2)

      if (first) then
      first=.false.
C--id=1/D
      id(0)=0.25d0
      id(1)=id(0)*0.5d0
      id(2)=id(1)*0.5d0
C--idp2=1/[D+2]
      idp2(0)=1d0/6d0
      idp2(1)=idp2(0)/3d0
      idp2(2)=idp2(1)/3d0
      endif

      if (scaleset .neqv. .true.) then
      scaleset=.true.
      if ((scale .eq. -1d12) .and. (musq .eq. -1d12)) then
      write(6,*) 'Did you forget to call setmudim?'
      write(6,*) 'Setting scale to scale=1d0'
      scale=1d0
      musq=1d0
      endif
      endif

      if (abs(m1sq/musq) .lt. onshellcutoff) then
c      write(6,*) 'setting zero mass, tadpole to zero'
c      write(6,*) 'm1sq=',m1sq
      do Np=N+1,N+Naa
      do ep=-2,0
      Av(Np,ep)=czip
      enddo
      enddo

      return

      else

      do ep=-2,0
      Av(aa0+N,ep)=trI1(m1sq,musq,ep)
      enddo

C Id,A00(m1?)=m1^2*A0(m1)/D;
      do ep=-2,0
        Av(aa00+N,ep)=czip
          do j=0,ep+2
          Av(aa00+N,ep)=Av(aa00+N,ep)+m1sq*Av(aa0+N,ep-j)*id(j)
          enddo
      enddo
C Id,A0000(m1?)=m1^2*A00(m1)/[D+2];
      do ep=-2,0
      Av(aa0000+N,ep)=czip
          do j=0,ep+2
          Av(aa0000+N,ep)=Av(aa0000+N,ep)+m1sq*Av(aa00+N,ep-j)*idp2(j)
          enddo
      enddo
      endif

      return
      end


fir_sim/dspba_library_package.vhd
fir_sim/dspba_library.vhd
fir_sim/auk_dspip_math_pkg_hpfir.vhd
fir_sim/auk_dspip_lib_pkg_hpfir.vhd
fir_sim/auk_dspip_avalon_streaming_controller_hpfir.vhd
fir_sim/auk_dspip_avalon_streaming_sink_hpfir.vhd
fir_sim/auk_dspip_avalon_streaming_source_hpfir.vhd
fir_sim/auk_dspip_roundsat_hpfir.vhd
fir_sim/altera_avalon_sc_fifo.v
fir_sim/fir_rtl_core.vhd
fir_sim/fir_ast.vhd
fir_sim/fir.vhd
fir_sim/fir_nativelink.tcl
fir_sim/fir_msim.tcl
fir_sim/fir_tb.vhd
fir_sim/fir_mlab.m
fir_sim/fir_model.m
fir_sim/fir_coef_int.txt
fir_sim/fir_input.txt
fir_sim/fir_param.txt


!> @file pyvariables.f90
!> @brief A MODULE that keeps all the global SPECvariables for other interfaced fortran SUBROUTINE
!> @author Zhisong Qu (zhisong.qu@anu.edu.au)

!> Defines the types used in the fortran module
MODULE SPECtypedefns
  INTEGER, PARAMETER :: REAL_KIND = 8
END MODULE SPECtypedefns

!> Defines all the constants
MODULE SPECconstants

  USE SPECtypedefns, only : REAL_KIND

  IMPLICIT NONE

  REAL(KIND=REAL_KIND), PARAMETER :: zero       =    0.0
  REAL(KIND=REAL_KIND), PARAMETER :: one        =    1.0
  REAL(KIND=REAL_KIND), PARAMETER :: two        =    2.0
  REAL(KIND=REAL_KIND), PARAMETER :: three      =    3.0
  REAL(KIND=REAL_KIND), PARAMETER :: four       =    4.0
  REAL(KIND=REAL_KIND), PARAMETER :: five       =    5.0
  REAL(KIND=REAL_KIND), PARAMETER :: six        =    6.0
  REAL(KIND=REAL_KIND), PARAMETER :: seven      =    7.0
  REAL(KIND=REAL_KIND), PARAMETER :: eight      =    8.0
  REAL(KIND=REAL_KIND), PARAMETER :: nine       =    9.0
  REAL(KIND=REAL_KIND), PARAMETER :: ten        =   10.0

  REAL(KIND=REAL_KIND), PARAMETER :: eleven     =   11.0
  REAL(KIND=REAL_KIND), PARAMETER :: twelve     =   12.0

  REAL(KIND=REAL_KIND), PARAMETER :: hundred    =  100.0
  REAL(KIND=REAL_KIND), PARAMETER :: thousand   = 1000.0

  REAL(KIND=REAL_KIND), PARAMETER :: half       =   one / two
  REAL(KIND=REAL_KIND), PARAMETER :: third      =   one / three
  REAL(KIND=REAL_KIND), PARAMETER :: quart      =   one / four
  REAL(KIND=REAL_KIND), PARAMETER :: fifth      =   one / five
  REAL(KIND=REAL_KIND), PARAMETER :: sixth      =   one / six

  REAL(KIND=REAL_KIND), PARAMETER :: pi2        =   6.28318530717958623
  REAL(KIND=REAL_KIND), PARAMETER :: pi         =   pi2 / two
  REAL(KIND=REAL_KIND), PARAMETER :: mu0        =   2.0E-07 * pi2
  REAL(KIND=REAL_KIND), PARAMETER :: goldenmean =   1.618033988749895 ! golden mean = ( one + sqrt(five) ) / two ;

  REAL(KIND=REAL_KIND), PARAMETER :: version    =   3.0

END MODULE SPECconstants

!> The variables to be used in fortran, should be initialized in Python
MODULE SPECvariables

  USE SPECtypedefns, only : REAL_KIND

  ! some general variables that exist in SPEC input and output
  INTEGER                         :: Igeometry
  INTEGER                         :: Mvol
  INTEGER                         :: Ntor
  INTEGER                         :: Mpol
  INTEGER                         :: Nfp
  INTEGER                         :: mn
  LOGICAL                         :: NOTstellsym
  INTEGER, ALLOCATABLE            :: im(:), in1(:)           ! Fourier modes;
  REAL(KIND=REAL_KIND),ALLOCATABLE:: iRbc(:,:) , iZbs(:,:)   ! interface surface geometry;     stellarator symmetric;
  REAL(KIND=REAL_KIND),ALLOCATABLE:: iRbs(:,:) , iZbc(:,:)   ! interface surface geometry; non-stellarator symmetric;
  REAL(KIND=REAL_KIND)            :: rpol, rtor

  ! variables for the volume we are interested in
  INTEGER                         :: ivol       ! which volume we are stuyding
  INTEGER                         :: Lrad       ! what is the radial resolution for that volume
  LOGICAL                         :: Lcoordinatesingularity
  REAL(KIND=REAL_KIND),ALLOCATABLE:: Ate(:,:), Aze(:,:), Ato(:,:), Azo(:,:)

CONTAINS

END MODULE SPECvariables


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE CALTIM (WHONLY, TMIN, TMAX, DELT, NINTV,
     &   NSTEPS, TIMES, WHOTIM, NPTIMS, IPTIMS)
C=======================================================================

C   --*** CALTIM *** (TIMSEL) Calculate the selected times
C   --   Written by Amy Gilkey - revised 11/10/87
C   --
C   --CALTIM calculates the selected times based on the time
C   --parameters.  The calculation is done only if the number of selected
C   --times is less than 0.
C   --
C   --Parameters:
C   --   WHONLY - IN - true iff only whole times may be selected
C   --   TMIN - IN - the minimum selected time
C   --   TMAX - IN - the maximum selected time
C   --   DELT - IN - the interval between selected times
C   --      0 < - user selected times mode
C   --      0 = - all available times mode
C   --      0 > - uniform time interval mode (dependent on NINTV if <> 0)
C   --   NINTV - IN - in user selected times mode, the number of times;
C   --      in uniform time interval mode, negative if zero interval
C   --   NSTEPS - IN - the number of time steps
C   --   TIMES - IN - the database times
C   --   WHOTIM - IN - true iff TIMES(i) is whole (versus history) time step
C   --   NPTIMS - IN/OUT - the number of selected times; the
C   --      calculation is done only if this is negative
C   --   IPTIMS - IN/OUT - the selected time steps

C   --Routines Called:
C   --   LOCREA - (ETCLIB) Locate closest value
C   --   NUMEQL - (ETCLIB) Count the number of equal values

      LOGICAL WHONLY
      REAL TMIN, TMAX, DELT
      INTEGER NINTV
      INTEGER NSTEPS
      REAL TIMES(*)
      LOGICAL WHOTIM(*)
      INTEGER NPTIMS
      INTEGER IPTIMS(*)

      LOGICAL DOSORT

      IF (NPTIMS .GE. 0) RETURN

      IF (.NOT. WHONLY) THEN
         NSTEPX = NSTEPS
      ELSE
         NSTEPX = NUMEQL (.TRUE., NSTEPS, WHOTIM)
      END IF

      DOSORT = .FALSE.

      IF (NSTEPX .EQ. 0) THEN

C      --Check for no time steps

         NPTIMS = 0
         TMIN = 0.0
         TMAX = 0.0
         DELT = 0.0
         NINTV = 0

      ELSE IF (DELT .GT. 0.0) THEN

C      --Select database time steps between TMIN and TMAX at interval DELT

         IF (TMIN .GT. TMAX) THEN
            NPTIMS = 0

         ELSE IF (TMIN .EQ. TMAX) THEN
            IF (.NOT. WHONLY) THEN
               IPTIMS(1) = LOCREA (TMIN, NSTEPS, TIMES)
            ELSE
               IPTIMS(1) = LOCRL (TMIN, NSTEPS, WHOTIM, TIMES)
            END IF
            NPTIMS = 1

         ELSE
            IF (NINTV .GT. 0) THEN
               IS = 1
               IE = NINTV
               DELT = (TMAX - TMIN) / NINTV
            ELSE IF (NINTV .LT. 0) THEN
               IS = 0
               IE = - NINTV - 1
               IF (NINTV .NE. -1) DELT = (TMAX - TMIN) / (-NINTV-1)
            ELSE
               IS = 0
               TIMMAX = TMAX + 0.01*DELT
               IE = INT ((TIMMAX - TMIN) / DELT)
            END IF
            ILAST = 0
            N = 0

            DO 100 I = IS, IE
               T = TMIN + DELT*I
               IF (.NOT. WHONLY) THEN
                  ITHIS = LOCREA (T, NSTEPS, TIMES)
               ELSE
                  ITHIS = LOCRL (T, NSTEPS, WHOTIM, TIMES)
               END IF
               IF (ILAST .NE. ITHIS) THEN
                  IWHERE = LOCINT (ITHIS, N, IPTIMS)
                  IF (IWHERE .LE. 0) THEN
                     N = N + 1
                     IPTIMS(N) = ITHIS
                     IF (ILAST .GE. ITHIS) DOSORT = .TRUE.
                     ILAST = ITHIS
                  END IF
               END IF
  100       CONTINUE
            NPTIMS = N
         END IF

      ELSE IF (DELT .EQ. 0.0) THEN

C      --Select all the database time steps between TMIN and TMAX

         N = 0
         IF (.NOT. WHONLY) THEN
            ISTIM = LOCREA (TMIN, NSTEPS, TIMES)
            IETIM = LOCREA (TMAX, NSTEPS, TIMES)
         ELSE
            ISTIM = LOCRL (TMIN, NSTEPS, WHOTIM, TIMES)
            IETIM = LOCRL (TMAX, NSTEPS, WHOTIM, TIMES)
         END IF
         TIMMIN = TIMES(ISTIM)
         TIMMAX = TIMES(IETIM)
         DO 110 ITHIS = 1, NSTEPS
            IF ((TIMES(ITHIS) .GE. TIMMIN)
     &         .AND. (TIMES(ITHIS) .LE. TIMMAX)) THEN
               N = N + 1
               IPTIMS(N) = ITHIS
            END IF
  110    CONTINUE
         NPTIMS = N

      ELSE

C      --Select the database time steps nearest a specified list of times
C      --(in IPTIMS)

         ILAST = 0
         DO 120 I = 1, NINTV
            ITHIS = IPTIMS(I)
            IF (ILAST .GE. ITHIS) DOSORT = .TRUE.
            ILAST = ITHIS
  120    CONTINUE
         NPTIMS = NINTV
      END IF

C   --Sort the selected time steps numbers (in IPTIMS)

      IF (DOSORT) THEN
         ILAST = 0
         N = 0
         DO 140 I = 1, NPTIMS
            ITHIS = IPTIMS(I)
            IXTHIS = I
            DO 130 J = I+1, NPTIMS
               IF (IPTIMS(J) .LT. ITHIS) THEN
                  ITHIS = IPTIMS(J)
                  IXTHIS = J
               END IF
  130       CONTINUE
            IPTIMS(IXTHIS) = IPTIMS(I)
            IF (ILAST .NE. ITHIS) THEN
               N = N + 1
               IPTIMS(N) = ITHIS
               ILAST = ITHIS
            END IF
  140    CONTINUE
         NPTIMS = N
      END IF

      RETURN
      END


      subroutine clebsch
c=======================
      implicit real*8 (a-h,o-z)
c
      include 'cgc.h'
!     dimension u1(50),ind1(50)
!     dimension u2(50),ind2(50)
!     common/cgc/u1,u2,ind1,ind2
      data tiny/1.0d-15/
c
c clebsch-gordan rectangular matrices to transform from (lm) to
c (kappa,my) basis
c
      do 1 i=1,500
      u1(i)=0.d0
      u2(i)=0.d0
      ind1(i)=1
      ind2(i)=1
    1 continue

      inr=0
      do 33 l=0,12
         twolp1=dfloat(2*l+1)
         do 3 m=-l,l
            inr=inr+1
!           write(6,*) 'inr',inr
c
c j=l-1/2
c
            kap=l
            if(kap.eq.0) goto 2
c
c ms=-1/2
c
            ir=2*kap*kap+kap+m
            u1(ir)=dsqrt((l+m)/twolp1)
            ind1(ir)=inr
c
c ms=+1/2
c
            ir=2*kap*kap+kap+m+1
            u2(ir)=-dsqrt((l-m)/twolp1)
            ind2(ir)=inr
    2       continue
c
c j=l+1/2
c
            kap=-l-1
c
c ms=-1/2
c
            ir=2*kap*kap+kap+m
            u1(ir)=dsqrt((l-m+1)/twolp1)
            ind1(ir)=inr
c
c ms=+1/2
c
            ir=2*kap*kap+kap+m+1
            u2(ir)=dsqrt((l+m+1)/twolp1)
            ind2(ir)=inr
c
    3 continue
   33 continue
c
c      write(6,*)
       do ir=1,inr
         if(dabs(u1(ir)).lt.tiny) ind1(ir)=1
c        write(6,'(i3,2x,i3,2x,f20.10)') ir,ind1(ir),u1(ir)
       end do
c      write(6,*)
       do ir=1,inr
         if(dabs(u2(ir)).lt.tiny) ind2(ir)=1
c        write(6,'(i3,2x,i3,2x,f20.10)') ir,ind2(ir),u2(ir)
       end do
c
      return
      end
      subroutine ruthi(kap,my,ii,norder)
c=====================
c     find index for (kapa-my)-representation
c
      dimension kapdex(50),mydex(50)
      data kapdex/-1,-1,1,1,-2,-2,-2,-2,2,2,2,2,-3,-3,-3,-3,-3,-3
     * ,3,3,3,3,3,3,-4,-4,-4,-4,-4,-4,-4,-4,
     * 4,4,4,4,4,4,4,4,-5,-5,-5,-5,-5,-5,-5,-5,-5,-5/
      data mydex/-1,1,-1,1,-3,-1,1,3,-3,-1,1,3,-5,-3,-1,1,3,5,
     * -5,-3,-1,1,3,5,-7,-5,-3,-1,1,3,5,7,
     * -7,-5,-3,-1,1,3,5,7,-9,-7,-5,-3,-1,1,3,5,7,9/
c
      do 100 i=1,norder
      if(kapdex(i).eq.kap) go to 150
  100 continue
      go to 500
  150 do 170 j=i,norder
      if(mydex(j).eq.my) go to 200
  170 continue
      go to 500
c
  200 ii=j
      return
  500 stop
      end


!!# FUNCTION MODULE: <FUN_xyAVERAGEY>
MODULE FUN_xyAVERAGEY

!!## PURPOSE
!! Averages the function $Y$ in 2D.

!!## METHOD

!!## AUTHORS
!! [waw] W. A. Wieselquist

!!## MODIFIED
!! 14 April 2007 [waw]

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## PROCEDURE OVERLOADING
INTERFACE xyAVERAGEY_Ls
 MODULE PROCEDURE xyAVERAGEY_Ls_Rsp
 MODULE PROCEDURE xyAVERAGEY_Ls_Rdp
ENDINTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyAVERAGEY_Ls
PUBLIC :: xyAVERAGEY_Ls_Rsp
PUBLIC :: xyAVERAGEY_Ls_Rdp

!!## CONTAINED PROCEDURES
CONTAINS

!!### FUNCTION <xyAVERAGEY_Ls_Rsp>
FUNCTION xyAVERAGEY_Ls_Rsp( Ls ) RESULT(AVERAGEY)
!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-A-FUN_xyAVERAGEY_Ls.f90.hdr"
!!--begin--
INCLUDE "05-A-FUN_xyAVERAGEY_Ls.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <xyAVERAGEY_Ls_Rdp>
FUNCTION xyAVERAGEY_Ls_Rdp( Ls ) RESULT(AVERAGEY)
!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-A-FUN_xyAVERAGEY_Ls.f90.hdr"
!!--begin--
INCLUDE "05-A-FUN_xyAVERAGEY_Ls.f90.bdy"
!!--end--
END FUNCTION

END MODULE


module stats
    implicit none
    save
    private
    public :: f, g, h, &
              setf, setg, seth, &
              iteration, armijo, norm, angle, &
              initstat, printheader, printstat, setmethod

    interface
        function f_t(x)
            double precision, intent(in) :: x(:)
            double precision             :: f_t
        end function f_t

        subroutine g_t(gx, x)
            double precision, intent(in)  :: x(:)
            double precision, intent(out) :: gx(:)
        end subroutine g_t

        subroutine h_t(hx, x)
            double precision, intent(in)  :: x(:)
            double precision, intent(out) :: hx(:, :)
        end subroutine h_t
    end interface

    procedure (f_t), pointer :: f_ptr => null()
    procedure (g_t), pointer :: g_ptr => null()
    procedure (h_t), pointer :: h_ptr => null()

    integer          :: nit, narm, nnor, nang
    integer          :: nf, ng, nh
    character(len=8) :: method

    double precision, allocatable :: gx(:)

contains
    subroutine initstat()
        nit = 0
        narm = 0
        nnor = 0
        nang = 0
        nf   = 0
        nh   = 0
        ng   = 0

        method = ""
        f_ptr => null()
        g_ptr => null()
        h_ptr => null()
    end subroutine initstat

    subroutine setf(p)
        procedure (f_t) :: p
        f_ptr => p
    end subroutine setf

    subroutine setg(p)
        procedure (g_t) :: p
        g_ptr => p
    end subroutine setg

    subroutine seth(p)
        procedure (h_t) :: p
        h_ptr => p
    end subroutine seth

    function f(x)
        double precision, intent(in) :: x(:)
        double precision             :: f

        nf = nf + 1

        if (nf > 1000000) then
            print '(a18, a10)', method, "FC"
            call exit(1)
        end if

        f = f_ptr(x)
    end function f

    subroutine g(gx, x)
        double precision, intent(in)  :: x(:)
        double precision, intent(out) :: gx(:)

        ng = ng + 1

        call g_ptr(gx, x)
    end subroutine g

    subroutine h(hx, x)
        double precision, intent(in)  :: x(:)
        double precision, intent(out) :: hx(:, :)

        nh = nh + 1

        call h_ptr(hx, x)
    end subroutine h

    subroutine iteration()
        nit = nit + 1
    end subroutine iteration

    subroutine armijo()
        narm = narm + 1
    end subroutine armijo

    subroutine norm()
        nnor = nnor + 1
    end subroutine norm

    subroutine angle()
        nang = nang + 1
    end subroutine angle

    subroutine printheader()
        print '(a34, 2a10, a12, a13, 2a10, a11)', "‖∇f*‖", "it", "f", "∇f", "∇²f", &
                                                           "armijo", "norma", "ângulo"
    end subroutine printheader

    subroutine printstat(x)
        double precision :: x(:)

        allocate(gx(size(x)))

        call g_ptr(gx, x)
        print '(a18, e10.2, 7i10)', method, norm2(gx), nit, nf, ng, nh, narm, nnor, nang

        deallocate(gx)
    end subroutine printstat

    subroutine setmethod(name)
        character(len=*) :: name

        method = name
    end subroutine setmethod

end module stats


c###convh.for
      SUBROUTINE  CONVH( GD,PHE,DEL,HP,RAY,CH,PTOT )
C--------------------------------
C
C     THIS SUBROUTINE CALCULATES THE GEOMETRICAL CONVERGENCE FACTOR
C
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RZ, VOFL
      DENOM = AMAX1(ABS(SIN(GD)) , .000001)
      PSI   = PIO2 - DEL - PHE
      GM = GD - 2.*PSI
      GM = AMAX1(GM,0.001)
C.....GROUP PATH
      PTOT = 2.*RAY +(RZ+HP)*GM
      SMALLC = (PTOT/RZ)*COS(DEL)/DENOM
      CH  = 10.*ALOG10(SMALLC)
C.....AT ANTIPODAL
      CH  =AMIN1(CH,15.)
      RETURN
      END
C--------------------------------


      subroutine posgw  (month,jday,tu,nc,nl,
     a                   asol,phi0,avis,phiv,xlon,xlat)
      logical ier
      real tu,asol,phi0,avis,phiv,xlon,xlat,yr,xr
      real alti,re,aaa,rp,pi,cdr,crd,deltax,deltay
      real x,y,rs,tanx,tany,val1,val2,yk,cosx2,sn
      real zt,xt,yt,teta,ylat,ylon,gam
      integer month,jday,nc,nl,iwr

      common/sixs_ier/iwr,ier

c     goes west definition

      yr=float(nl)-8665.5
      xr=float(nc)-6498.5
      alti=42147.0-6378.155
      re=6378.155
      aaa=1./297.
      rp=re/(1.+aaa)
      pi=3.1415926
      cdr=pi/180.
      crd=180./pi
      deltax=18.0/12997.0
      deltay=20.0/17331.0
      x=xr*deltax*cdr
      y=yr*deltay*cdr
      rs=re+alti
      tanx=tan(x)
      tany=tan(y)
      val1=1.0+(tanx**2)
      val2=1.0+(tany*(1.0+aaa))**2
      yk=rs/re
      cosx2=1./(val1*val2)
      if((1./cosx2).gt.((yk**2)/(yk**2-1.))) goto 1000
      sn=(rs-(re*(sqrt((yk**2)-(yk**2-1.)*(1./cosx2)))))/(1./cosx2)
      zt=rs-sn
      xt=-(sn*tanx)
      yt=sn*tany/cos(x)
      teta=asin(yt/rp)
      ylat=(atan(((tan(teta))*rp)/re))
      ylon=atan(xt/zt)
      goto 1001
 1000 call print_error(
     s 'no possibility to compute lat. and long.')
      return
 1001 xlat=ylat*crd
      xlon=ylon*crd-135.

      call possol(month,jday,tu,xlon,xlat,
     a            asol,phi0)
      if(ier)return

      ylon=xlon*pi/180.+135.*cdr
      ylat=xlat*pi/180.
      gam=sqrt(((1./cosx2)-1.)*cosx2)
      avis=asin((1.+alti/re)*(gam))
      avis=avis*180./pi
      phiv=atan2(tan(ylon),sin(ylat))+pi
      phiv=phiv*180./pi
      return
      end


module xorshift_m
  use, intrinsic :: iso_fortran_env
  use random_base_m
  implicit none
  private
  real(real64), parameter :: to_real64 = 1 / (real(huge(1_int32), real64) + 1)

  public :: xor96
  !> `xor96`: From [https://ja.wikipedia.org/wiki/Xorshift].
  type, extends(random_base_t) :: xor96
     private
     integer :: x, y, z
   contains
     procedure, pass :: set_seed   => set_seed_xor96
     procedure, pass :: get_rand   => get_rand_xor96
     procedure, pass :: random_arr => random_arr_xor96
  end type xor96

contains

  !> `set_seed_xor96`: Set seed of xorshift.
  subroutine set_seed_xor96(this, iseed)
    class(xor96), intent(inout) :: this
    integer     , intent(in)    :: iseed
    this%x = 123456789
    this%y = 362436069
    this%z = ieor(521288629, iseed)
  end subroutine set_seed_xor96

  !> `get_rand_xor96`: Return random number of xorshift.
  real(real64) function get_rand_xor96(this)
    class(xor96), intent(inout) :: this
    integer                     :: tx, ty, tz
    tx = ieor(this%x, ishft(this%x, 3))
    ty = ieor(this%y, ishft(this%y, -19))
    tz = ieor(this%z, ishft(this%z, 6))
    this%x = this%y
    this%y = this%z
    this%z = ieor(ieor(tx, ty), tz)
    get_rand_xor96 = (this%z*to_real64 + 1.0_real64)/2.0_real64 ! [0, 1)
    return
  end function get_rand_xor96

  !> `random_arr_xor96`: Return random numbers of xorshift by argument `arr`.
  subroutine random_arr_xor96(this, arr)
    class(xor96), intent(inout) :: this
    real(real64), intent(out)   :: arr(:)
    integer                     :: i
    do i = 1, size(arr)
       arr(i) = this%get_rand()
    end do
  end subroutine random_arr_xor96

end module xorshift_m


! { dg-do compile }
! { dg-options "-O -ffast-math -fdump-tree-original -fdump-tree-optimized" }

! Verify we associate properly during folding
! Verify we propagate constants in the presence of PAREN_EXPR

function test(a)
  real b, c, d
  c = a
  d = 5
  b = (c + 5 - c)
  b = (c + d - c)
  test = a + b - 5
end

! { dg-final { scan-tree-dump "b = 5" "original" } }
! { dg-final { scan-tree-dump "c_. = .a" "optimized" } }
! { dg-final { scan-tree-dump "return c_.;" "optimized" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-final { cleanup-tree-dump "optimized" } }


!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
PROGRAM LA_SGTSVX_ET_EXAMPLE
!  .. USE STATEMENTS
   USE LA_PRECISION, ONLY: WP => SP
   USE F95_LAPACK, ONLY: LA_GTSVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. PARAMETERS ..
      CHARACTER(LEN=*), PARAMETER :: FMT = '(8(1X,F10.3))'
   INTEGER, PARAMETER :: NIN=5, NOUT=6
!  .. LOCAL SCALARS ..
   INTEGER :: I, J, IFAIL, N, NRHS
   REAL(WP) :: RCOND
!  .. LOCAL ARRAYS ..
   INTEGER, ALLOCATABLE :: IPIV(:)
   REAL(WP), ALLOCATABLE :: DL(:), D(:), DU(:), B(:,:), &
             X(:,:), DLF(:), DF(:), DUF(:), DU2(:)
   REAL(WP), ALLOCATABLE :: DDL(:), DD(:), DDU(:), BB(:,:), FERR(:), BERR(:)
!  .. EXECUTABLE STATEMENTS ..
   WRITE (NOUT,*) 'SGTSVX ET_Example Program Results.'
   READ ( NIN, * )   ! SKIP HEADING IN DATA FILE
   READ ( NIN, * ) N, NRHS
   PRINT *, 'N = ', N, ' NRHS = ', NRHS
   ALLOCATE ( DL(N-1), DDL(N-1), D(N), DD(N), DU(N-1), DDU(N-1), B(N,NRHS), BB(N,NRHS), &
         X(N,NRHS), IPIV(N), DLF(N-1), DF(N), DUF(N-1), DU2(N-2), FERR(NRHS), BERR(NRHS) )
!
        READ (NIN, *) DDU(:), DD(:), DDL(:)

      BB(1,:) = DD(1) + DDU(1)
!     BB(2:N-1,:) = DDL(1:N-2) + DD(2:N-1) + DDU(2:N-1)
      DO I = 2, N-1
         BB(I,:) = DDL(I-1) + DD(I) + DDU(I)
      ENDDO
      BB(N,:) = DDL(N-1) + DD(N-1)
      DO I = 1, NRHS
         BB(:,I) = BB(:,I)*I
      ENDDO
   DL = DDL; D = DD; DU = DDU; B = BB
      WRITE(NOUT,*) 'The matrix A:'
      WRITE (NOUT,*) 'DU '; WRITE (NOUT,FMT) DU
      WRITE (NOUT,*) 'D  '; WRITE (NOUT,FMT) D
      WRITE (NOUT,*) 'DL '; WRITE (NOUT,FMT) DL
      WRITE(NOUT,*) 'The RHS matrix B:'
      DO J = 1, NRHS
        WRITE (NOUT,*) 'RHS', J; WRITE (NOUT,FMT) B(:,J)
      ENDDO
!
   WRITE ( NOUT, * )'---------------------------------------------------------'
   WRITE ( NOUT, * )
   WRITE ( NOUT, * )'Details of LA_SSGTSVX LAPACK Subroutine Results.'
   WRITE ( NOUT, * )
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GTSVX(DL, D, DU, B, X )'
   DL = DDL; D = DD; DU = DDU; B = BB
   CALL LA_GTSVX(DL, D, DU, B, X )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GTSVX:'
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GTSVX(DL, D, DU, B(1:N,1), X(1:N,1) )'
   DL = DDL; D = DD; DU = DDU; B = BB
   CALL LA_GTSVX(DL, D, DU, B(1:N,1), X(1:N,1) )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GTSVX:'
   WRITE (NOUT,FMT) X(:,1)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GTSVX(DL, D, DU, B, X, IPIV=IPIV)'
   DL = DDL; D = DD; DU = DDU; B = BB
   CALL LA_GTSVX(DL, D, DU, B, X, IPIV=IPIV )
   WRITE(NOUT,*) 'Pivots ', IPIV
   WRITE(NOUT,*)
   WRITE(NOUT,*) ' CALL LA_GTSVX(DL, D, DU, B(1:N,1), X(1:N,1), INFO=IFAIL )'
   DL = DDL; D = DD; DU = DDU; B = BB
   CALL LA_GTSVX(DL, D, DU, B(1:N,1), X(1:N,1), INFO=IFAIL )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GTSVX, INFO = ', IFAIL
   WRITE (NOUT,FMT) X(1:N,1)
!
   WRITE(NOUT,*)
   WRITE(NOUT,*) 'CALL LA_GTSVX(DL, D, DU, B, X, DLF, DF, DUF, DU2, ', &
                 'IPIV, ''N'', ''N'', FERR, BERR, RCOND, IFAIL )'
   DL = DDL; D = DD; DU = DDU; B = BB; X = HUGE(1.0_WP)
   CALL LA_GTSVX(DL, D, DU, B, X, DLF, DF, DUF, DU2, IPIV, 'N', 'N', &
                   FERR, BERR, RCOND, IFAIL )
   WRITE(NOUT,*)'   X - the solution vectors computed by LA_GTSVX, INFO = ', &
                 IFAIL, ' RCOND = ', RCOND
   DO J = 1, NRHS; WRITE (NOUT,FMT) X(:,J); END DO
!
END PROGRAM LA_SGTSVX_ET_EXAMPLE