c	Copyright (c) 2015 James A. Grogan
c
c       Permission is hereby granted, free of charge, to any person obtaining a copy
c       of this software and associated documentation files (the "Software"), to deal
c       in the Software without restriction, including without limitation the rights
c       to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
c       copies of the Software, and to permit persons to whom the Software is
c       furnished to do so, subject to the following conditions:
c
c       The above copyright notice and this permission notice shall be included in
c       call copies or substantial portions of the Software.
c
c       THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
c       IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
c       FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
c       AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
c       LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
c       OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
c       THE SOFTWARE.
c
c       Author: J. Grogan
c       Initial Version: 2010

	Program Balloon_Wrap
!
!	Program to map an unfolded ballon geometry onto a folded configuration (Based on Laroche Paper)
!	Input: File containing nodal coords of ballon geometry (Abaqus INP Format)
!	Output: File containing nodal coords of mapped ballon geometry (Abaqus INP Format)
!
	real pi,x_cor,y_cor,z_cor,theta,radius,theta_hat,rad_hat,alpha,beta,phi
    real inner_radius,outer_radius,num_folds,multiplier
    integer node_num
    logical outer_flap
!
	open(unit=10,file='in.dat',status='old')
	open(unit=11,file='out.dat',status='unknown')
!
	pi=acos(-1.)
	inner_radius=0.25
    outer_radius=0.43
    num_folds=3.
    phi=(2*pi)/num_folds
    outer_flap=.false.
!
	do i=1,  9821
  		read(10,*)node_num,x_cor,y_cor,z_cor
  		theta=(atan2(z_cor,x_cor))
        radius=sqrt(z_cor*z_cor+x_cor*x_cor)
!
  		if(theta<0.)then
    		theta=theta+2*pi
  		endif
!
		beta=(phi/2.)*(1.+(2*radius)/(inner_radius+outer_radius))
        alpha=((outer_radius+inner_radius)/(2*radius))*beta
!
		do j=1,num_folds
        	if((theta>=(j-1)*phi).and.(theta<=(alpha+(j-1)*phi)))then
            	multiplier=j-1
                outer_flap=.true.
            elseif((theta>=(alpha+(j-1)*phi)).and.(theta<=(j*phi)))then
                multiplier=j
                outer_flap=.false.
            endif
        enddo
!
		if(outer_flap)then
            theta_hat=(beta/alpha)*(theta-multiplier*phi)+multiplier*phi
            rad_hat=inner_radius+((outer_radius-inner_radius)/beta)*(theta_hat-multiplier*phi)
        else
          	theta_hat=((beta-phi)/(phi-alpha))*(multiplier*phi-theta)+multiplier*phi
            rad_hat=inner_radius+((outer_radius-inner_radius)/(beta-phi))*(theta_hat-multiplier*phi)
        endif
!
     	write(11,*)node_num,',',rad_hat*cos(theta_hat),',',y_cor,',',rad_hat*sin(theta_hat)
    enddo
end program


      subroutine picc(c1,c2,n)
       common/gfgmp/p1(2),p2(2)
       dimension c1(3),c2(3)
      r1=abs(c1(3))
      r2=abs(c2(3))
        d=sqrt((c2(1)-c1(1))**2+(c2(2)-c1(2))**2)
      n=0
      if(d.lt.1e-6.or.d.gt.r1+r2+1.e-6) return
      x=(r1**2-r2**2+d**2)/(2*d)
      st=(c2(2)-c1(2))/d
       ct=(c2(1)-c1(1))/d
       a=r1*r1-x*x
       if(abs(a).lt.1.e-5) goto 1
       if(a.lt.0.) return
       h=sqrt(a)
       n=2
      p1(1)=x*ct-h*st+c1(1)
      p1(2)=x*st+h*ct+c1(2)
       p2(1)=x*ct+h*st+c1(1)
       p2(2)=x*st-h*ct+c1(2)
       return
  1   n=1
        p1(1)=x*ct+c1(1)
       p1(2)=x*st+c1(2)
         p2(1)=p1(1)
         p2(2)=p1(2)
      return
       end


C
C
*+ make_clbm

      subroutine make_clbm(beam,m,n,cbsig1,cbsig2,a,bmax,ibc,jbc,i1,i2,
     +                     j1,j2,sratio,status)
C     -----------------------------------------------------------------
C
C Calculate the clean beam for the restore process
C
C Input
C   M,N       -        I4       -      size beam
C   CBSIG1/2  -        R4       -      beam size (grid-points)
C   A         -        R4       -      position-angle (radians)
C   BMAX      -        R4       -      beam height
C
C Returned
C   BEAM      -        R4(array)-      beam array
C   I/JBC     -        I4       -      beam centre
C   I1,I2     -        I4       -      region on beam to use (I)
C   J1,J2     -        I4       -                "           (J)
C   SRATIO    -        R4       -      beam normalization factor
C
C This routine calculates the clean beam for the restoring process.
C The beam is made to be gaussian, and circular in the aperture
C projection.  CBSIG1,2 are the values of sigma for this beam, and are
C in units of grid-points.
C
C Also, the routine calculates the factor by which sums of numbers on a CLEAN
C map have to be multiplied in order to get the flux density (SRATIO).
C
*-
      integer     status, m, n, i1, i2, j1, j2, ibc, jbc
      real*4      beam(m,n), a, bmax, cbsig1, cbsig2, sratio
      real*4      cb1, cb2, x1, x2, bsum
      integer     na1, na2, i, j

C calculate geometrical quantities for the gaussian
      ibc = n/2
      jbc = m/2

      cb1=1.0/(cbsig1*cbsig1*2.0)
      cb2=1.0/(cbsig2*cbsig2*2.0)
      na1=6.324*cbsig1+2.5
      na2=6.324*cbsig2+2.5
      i1=ibc-max(na1,na2)
      i2=ibc+max(na1,na2)
      j1=jbc-max(na2,na1)
      j2=jbc+max(na2,na1)
C zero old array
      do j=1,n
        do i=1,m
          beam(i,j)=0.0
        end do
      end do

C Calculate beam
      bsum=0.0
      do j=j1,j2
        do i=i1,i2
          x1 = float(i-ibc)*cos(A) + float(j-jbc)*sin(A)
          x2 = float(j-jbc)*cos(A) - float(i-ibc)*sin(A)
          x1 = x1 * x1 * cb1
          x2 = x2 * x2 * cb2
          beam(i,j) = bmax*exp(-x1-x2)
          bsum=bsum+beam(i,j)
        end do
      end do

C determine normalization factor
      sratio=bmax/bsum

      end


! This file is part of HolmMHD
! Copyright (C) 2019 Daniel Verscharen (d.verscharen@ucl.ac.uk)
!All rights reserved.
!
!Redistribution and use in source and binary forms, with or without
!modification, are permitted provided that the following conditions are met:
!
!1. Redistributions of source code must retain the above copyright notice, this
!   list of conditions and the following disclaimer.
!2. Redistributions in binary form must reproduce the above copyright notice,
!   this list of conditions and the following disclaimer in the documentation
!   and/or other materials provided with the distribution.
!
!THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
!ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
!WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
!DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
!ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
!(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
!LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
!ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
!(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
!SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!The views and conclusions contained in the software and documentation are those
!of the authors and should not be interpreted as representing official policies,
!either expressed or implied, of the HolmMHD project.

subroutine check_dt(U,P,rho,B)
use globals
implicit none
include "mpif.h"      !Include MPI library variables

! Make sure that the Courant criterion is always and everywhere fulfilled:
double precision :: wvel(3,-1:Nx+2,-1:Ny+2,-1:Nz+2),dtnew
double precision :: P(-1:Nx+2,-1:Ny+2,-1:Nz+2),rho(-1:Nx+2,-1:Ny+2,-1:Nz+2)
double precision :: U(3,-1:Nx+2,-1:Ny+2,-1:Nz+2),B(3,-2:Nx+2,-2:Ny+2,-2:Nz+2)
integer :: i,j,k

! Every process does this:
dtnew=dt
do i=1,Nx
do j=1,Ny
do k=1,Nz
	call calc_wvel(wvel,i,j,k,U,P,rho,B)
	dtnew=min(dtnew,1.d0/(wvel(1,i,j,k)/dx+wvel(2,i,j,k)/dy+wvel(3,i,j,k)/dz))
enddo
enddo
enddo

! Now bring all processes together:
call mpi_allreduce(dtnew,dt,1,MPI_DOUBLE_PRECISION,MPI_MIN,MPI_COMM_WORLD,ierror)

end subroutine

!ftp://ftp.sam.math.ethz.ch/pub/sam-reports/reports/reports2009/2009-33.pdf
subroutine calc_wvel(wvel,i,j,k,U,P,rho,B)
use globals
implicit none

integer :: i,j,k
double precision :: B(3,-2:Nx+2,-2:Ny+2,-2:Nz+2), U(3,-1:Nx+2,-1:Ny+2,-1:Nz+2)
double precision :: rho(-1:Nx+2,-1:Ny+2,-1:Nz+2), P(-1:Nx+2,-1:Ny+2,-1:Nz+2)
double precision :: wvel(3,-1:Nx+2,-1:Ny+2,-1:Nz+2)
double precision :: Binter(3)
double precision :: cs,vA

call B_interpol(B,Binter,i,j,k)

cs=sqrt(gamma*P(i,j,k)/rho(i,j,k))
vA=sqrt(Binter(1)*Binter(1)+Binter(2)*Binter(2)+Binter(3)*Binter(3))/sqrt(4.d0*M_PI*rho(i,j,k))

wvel(1,i,j,k)=sqrt((cs*cs+vA*vA)**2-4.d0*cs*cs*Binter(1)*Binter(1)/(4.d0*M_PI*rho(i,j,k)))
wvel(1,i,j,k)=sqrt(0.5d0*(wvel(1,i,j,k)+cs*cs+vA*vA))+abs(U(1,i,j,k))

wvel(2,i,j,k)=sqrt((cs*cs+vA*vA)**2-4.d0*cs*cs*Binter(2)*Binter(2)/(4.d0*M_PI*rho(i,j,k)))
wvel(2,i,j,k)=sqrt(0.5d0*(wvel(2,i,j,k)+cs*cs+vA*vA))+abs(U(2,i,j,k))

wvel(3,i,j,k)=sqrt((cs*cs+vA*vA)**2-4.d0*cs*cs*Binter(3)*Binter(3)/(4.d0*M_PI*rho(i,j,k)))
wvel(3,i,j,k)=sqrt(0.5d0*(wvel(3,i,j,k)+cs*cs+vA*vA))+abs(U(3,i,j,k))

end subroutine


! Fast Fourier/Cosine/Sine Transform
!     dimension   :three
!     data length :power of 2
!     decimation  :frequency
!     radix       :split-radix, row-column
!     data        :inplace
!     table       :use
! subroutines
!     cdft3d: Complex Discrete Fourier Transform
!     rdft3d: Real Discrete Fourier Transform
!     ddct3d: Discrete Cosine Transform
!     ddst3d: Discrete Sine Transform
! necessary package
!     fftsg.f  : 1D-FFT package
!
!
! -------- Complex DFT (Discrete Fourier Transform) --------
!     [definition]
!         <case1>
!             X(k1,k2,k3) = sum_j1=0^n1-1 sum_j2=0^n2-1 sum_j3=0^n3-1
!                               x(j1,j2,j3) *
!                               exp(2*pi*i*j1*k1/n1) *
!                               exp(2*pi*i*j2*k2/n2) *
!                               exp(2*pi*i*j3*k3/n3),
!                               0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!         <case2>
!             X(k1,k2,k3) = sum_j1=0^n1-1 sum_j2=0^n2-1 sum_j3=0^n3-1
!                               x(j1,j2,j3) *
!                               exp(-2*pi*i*j1*k1/n1) *
!                               exp(-2*pi*i*j2*k2/n2) *
!                               exp(-2*pi*i*j3*k3/n3),
!                               0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!         (notes: sum_j=0^n-1 is a summation from j=0 to n-1)
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call cdft3d(n1max, n2max, 2*n1, n2, n3, 1, a, t, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call cdft3d(n1max, n2max, 2*n1, n2, n3, -1, a, t, ip, w)
!     [parameters]
!         n1max  :row1 size of the 3D array (integer)
!         n2max  :row2 size of the 3D array (integer)
!         2*n1   :data length (integer)
!                 n1 >= 1, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 1, n2 = power of 2
!         n3     :data length (integer)
!                 n3 >= 1, n3 = power of 2
!         a(0:2*n1-1,0:n2-1,0:n3-1)
!                :input/output data (real*8)
!                 input data
!                     a(2*j1,j2,j3) = Re(x(j1,j2,j3)),
!                     a(2*j1+1,j2,j3) = Im(x(j1,j2,j3)),
!                     0<=j1<n1, 0<=j2<n2, 0<=j3<n3
!                 output data
!                     a(2*k1,k2,k3) = Re(X(k1,k2,k3)),
!                     a(2*k1+1,k2,k3) = Im(X(k1,k2,k3)),
!                     0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!         t(0:*) :work area (real*8)
!                 length of t >= max(8*n2, 8*n3)
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1, n2, n3))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1/2, n2/2, n3/2)
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call cdft3d(n1max, n2max, 2*n1, n2, n3, -1, a, t, ip, w)
!         is
!             call cdft3d(n1max, n2max, 2*n1, n2, n3, 1, a, t, ip, w)
!             do j3 = 0, n3 - 1
!                 do j2 = 0, n2 - 1
!                     do j1 = 0, 2 * n1 - 1
!                         a(j1,j2,j3) = a(j1,j2,j3) * (1.0d0/n1/n2/n3)
!                     end do
!                 end do
!             end do
!         .
!
!
! -------- Real DFT / Inverse of Real DFT --------
!     [definition]
!         <case1> RDFT
!             R(k1,k2,k3) = sum_j1=0^n1-1 sum_j2=0^n2-1 sum_j3=0^n3-1
!                               a(j1,j2,j3) *
!                               cos(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2 +
!                                   2*pi*j3*k3/n3),
!                               0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!             I(k1,k2,k3) = sum_j1=0^n1-1 sum_j2=0^n2-1 sum_j3=0^n3-1
!                               a(j1,j2,j3) *
!                               sin(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2 +
!                                   2*pi*j3*k3/n3),
!                               0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!         <case2> IRDFT (excluding scale)
!             a(k1,k2,k3) = (1/2) * sum_j1=0^n1-1 sum_j2=0^n2-1 sum_j3=0^n3-1
!                               (R(j1,j2,j3) *
!                               cos(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2 +
!                                   2*pi*j3*k3/n3) +
!                               I(j1,j2,j3) *
!                               sin(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2 +
!                                   2*pi*j3*k3/n3)),
!                               0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!         (notes: R(mod(n1-k1,n1),mod(n2-k2,n2),mod(n3-k3,n3)) = R(k1,k2,k3),
!                 I(mod(n1-k1,n1),mod(n2-k2,n2),mod(n3-k3,n3)) = -I(k1,k2,k3),
!                 0<=k1<n1, 0<=k2<n2, 0<=k3<n3)
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call rdft3d(n1max, n2max, n1, n2, n3, 1, a, t, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call rdft3d(n1max, n2max, n1, n2, n3, -1, a, t, ip, w)
!     [parameters]
!         n1max  :row1 size of the 3D array (integer)
!         n2max  :row2 size of the 3D array (integer)
!         n1     :data length (integer)
!                 n1 >= 2, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 2, n2 = power of 2
!         n3     :data length (integer)
!                 n3 >= 2, n3 = power of 2
!         a(0:n1-1,0:n2-1,0:n3-1)
!                :input/output data (real*8)
!                 <case1>
!                     output data
!                         a(2*k1,k2,k3) = R(k1,k2,k3)
!                                 = R(n1-k1,mod(n2-k2,n2),mod(n3-k3,n3)),
!                         a(2*k1+1,k2,k3) = I(k1,k2,k3)
!                                 = -I(n1-k1,mod(n2-k2,n2),mod(n3-k3,n3)),
!                             0<k1<n1/2, 0<=k2<n2, 0<=k3<n3,
!                         a(0,k2,k3) = R(0,k2,k3)
!                                    = R(0,n2-k2,mod(n3-k3,n3)),
!                         a(1,k2,k3) = I(0,k2,k3)
!                                    = -I(0,n2-k2,mod(n3-k3,n3)),
!                         a(1,n2-k2,k3) = R(n1/2,k2,mod(n3-k3,n3))
!                                       = R(n1/2,n2-k2,k3),
!                         a(0,n2-k2,k3) = -I(n1/2,k2,mod(n3-k3,n3))
!                                       = I(n1/2,n2-k2,k3),
!                             0<k2<n2/2, 0<=k3<n3,
!                         a(0,0,k3) = R(0,0,k3)
!                                   = R(0,0,n3-k3),
!                         a(1,0,k3) = I(0,0,k3)
!                                   = -I(0,0,n3-k3),
!                         a(0,n2/2,k3) = R(0,n2/2,k3)
!                                      = R(0,n2/2,n3-k3),
!                         a(1,n2/2,k3) = I(0,n2/2,k3)
!                                      = -I(0,n2/2,n3-k3),
!                         a(1,0,n3-k3) = R(n1/2,0,k3)
!                                      = R(n1/2,0,n3-k3),
!                         a(0,0,n3-k3) = -I(n1/2,0,k3)
!                                      = I(n1/2,0,n3-k3),
!                         a(1,n2/2,n3-k3) = R(n1/2,n2/2,k3)
!                                         = R(n1/2,n2/2,n3-k3),
!                         a(0,n2/2,n3-k3) = -I(n1/2,n2/2,k3)
!                                         = I(n1/2,n2/2,n3-k3),
!                             0<k3<n3/2,
!                         a(0,0,0) = R(0,0,0),
!                         a(1,0,0) = R(n1/2,0,0),
!                         a(0,0,n3/2) = R(0,0,n3/2),
!                         a(1,0,n3/2) = R(n1/2,0,n3/2),
!                         a(0,n2/2,0) = R(0,n2/2,0),
!                         a(1,n2/2,0) = R(n1/2,n2/2,0),
!                         a(0,n2/2,n3/2) = R(0,n2/2,n3/2),
!                         a(1,n2/2,n3/2) = R(n1/2,n2/2,n3/2)
!                 <case2>
!                     input data
!                         a(2*j1,j2,j3) = R(j1,j2,j3)
!                                 = R(n1-j1,mod(n2-j2,n2),mod(n3-j3,n3)),
!                         a(2*j1+1,j2,j3) = I(j1,j2,j3)
!                                 = -I(n1-j1,mod(n2-j2,n2),mod(n3-j3,n3)),
!                             0<j1<n1/2, 0<=j2<n2, 0<=j3<n3,
!                         a(0,j2,j3) = R(0,j2,j3)
!                                    = R(0,n2-j2,mod(n3-j3,n3)),
!                         a(1,j2,j3) = I(0,j2,j3)
!                                    = -I(0,n2-j2,mod(n3-j3,n3)),
!                         a(1,n2-j2,j3) = R(n1/2,j2,mod(n3-j3,n3))
!                                       = R(n1/2,n2-j2,j3),
!                         a(0,n2-j2,j3) = -I(n1/2,j2,mod(n3-j3,n3))
!                                       = I(n1/2,n2-j2,j3),
!                             0<j2<n2/2, 0<=j3<n3,
!                         a(0,0,j3) = R(0,0,j3)
!                                   = R(0,0,n3-j3),
!                         a(1,0,j3) = I(0,0,j3)
!                                   = -I(0,0,n3-j3),
!                         a(0,n2/2,j3) = R(0,n2/2,j3)
!                                      = R(0,n2/2,n3-j3),
!                         a(1,n2/2,j3) = I(0,n2/2,j3)
!                                      = -I(0,n2/2,n3-j3),
!                         a(1,0,n3-j3) = R(n1/2,0,j3)
!                                      = R(n1/2,0,n3-j3),
!                         a(0,0,n3-j3) = -I(n1/2,0,j3)
!                                      = I(n1/2,0,n3-j3),
!                         a(1,n2/2,n3-j3) = R(n1/2,n2/2,j3)
!                                         = R(n1/2,n2/2,n3-j3),
!                         a(0,n2/2,n3-j3) = -I(n1/2,n2/2,j3)
!                                         = I(n1/2,n2/2,n3-j3),
!                             0<j3<n3/2,
!                         a(0,0,0) = R(0,0,0),
!                         a(1,0,0) = R(n1/2,0,0),
!                         a(0,0,n3/2) = R(0,0,n3/2),
!                         a(1,0,n3/2) = R(n1/2,0,n3/2),
!                         a(0,n2/2,0) = R(0,n2/2,0),
!                         a(1,n2/2,0) = R(n1/2,n2/2,0),
!                         a(0,n2/2,n3/2) = R(0,n2/2,n3/2),
!                         a(1,n2/2,n3/2) = R(n1/2,n2/2,n3/2)
!                 ---- output ordering ----
!                     call rdft3d(n1max, n2max, n1, n2, n3, 1, a, t, ip, w)
!                     call rdft3dsort(n1max, n2max, n1, n2, n3, 1, a)
!                     ! stored data is a(0:n1-1,0:n2-1,0:n3+1):
!                     ! a(2*k1,k2,k3) = R(k1,k2,k3),
!                     ! a(2*k1+1,k2,k3) = I(k1,k2,k3),
!                     ! 0<=k1<=n1/2, 0<=k2<n2, 0<=k3<n3.
!                     ! the stored data is larger than the input data!
!                 ---- input ordering ----
!                     call rdft3dsort(n1max, n2max, n1, n2, n3, -1, a)
!                     call rdft3d(n1max, n2max, n1, n2, n3, -1, a, t, ip, w)
!         t(0:*) :work area (real*8)
!                 length of t >= max(8*n2, 8*n3)
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1/2, n2, n3))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1/4, n2/2, n3/2) + n1/4
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call rdft3d(n1max, n2max, n1, n2, n3, 1, a, t, ip, w)
!         is
!             call rdft3d(n1max, n2max, n1, n2, n3, -1, a, t, ip, w)
!             do j3 = 0, n3 - 1
!                 do j2 = 0, n2 - 1
!                     do j1 = 0, n1 - 1
!                         a(j1,j2,j3) = a(j1,j2,j3) * (2.0d0/n1/n2/n3)
!                     end do
!                 end do
!             end do
!         .
!
!
! -------- DCT (Discrete Cosine Transform) / Inverse of DCT --------
!     [definition]
!         <case1> IDCT (excluding scale)
!             C(k1,k2,k3) = sum_j1=0^n1-1 sum_j2=0^n2-1 sum_j3=0^n3-1
!                               a(j1,j2,j3) *
!                               cos(pi*j1*(k1+1/2)/n1) *
!                               cos(pi*j2*(k2+1/2)/n2) *
!                               cos(pi*j3*(k3+1/2)/n3),
!                               0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!         <case2> DCT
!             C(k1,k2,k3) = sum_j1=0^n1-1 sum_j2=0^n2-1 sum_j3=0^n3-1
!                               a(j1,j2,j3) *
!                               cos(pi*(j1+1/2)*k1/n1) *
!                               cos(pi*(j2+1/2)*k2/n2) *
!                               cos(pi*(j3+1/2)*k3/n3),
!                               0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call ddct3d(n1max, n2max, n1, n2, n3, 1, a, t, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call ddct3d(n1max, n2max, n1, n2, n3, -1, a, t, ip, w)
!     [parameters]
!         n1max  :row1 size of the 3D array (integer)
!         n2max  :row2 size of the 3D array (integer)
!         n1     :data length (integer)
!                 n1 >= 2, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 2, n2 = power of 2
!         n3     :data length (integer)
!                 n3 >= 2, n3 = power of 2
!         a(0:n1-1,0:n2-1,0:n3-1)
!                :input/output data (real*8)
!                 output data
!                     a(k1,k2,k3) = C(k1,k2,k3),
!                         0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!         t(0:*) :work area (real*8)
!                 length of t >= max(4*n2, 4*n3)
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1/2, n2/2, n3/2))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1*3/2, n2*3/2, n3*3/2)
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call ddct3d(n1max, n2max, n1, n2, n3, -1, a, t, ip, w)
!         is
!             do j3 = 0, n3 - 1
!                 do j2 = 0, n2 - 1
!                     a(0, j2, j3) = a(0, j2, j3) * 0.5d0
!                 end do
!                 do j1 = 0, n1 - 1
!                     a(j1, 0, j3) = a(j1, 0, j3) * 0.5d0
!                 end do
!             end do
!             do j2 = 0, n2 - 1
!                 do j1 = 0, n1 - 1
!                     a(j1, j2, 0) = a(j1, j2, 0) * 0.5d0
!                 end do
!             end do
!             call ddct3d(n1max, n2max, n1, n2, n3, 1, a, t, ip, w)
!             do j3 = 0, n3 - 1
!                 do j2 = 0, n2 - 1
!                     do j1 = 0, n1 - 1
!                         a(j1,j2,j3) = a(j1,j2,j3) * (8.0d0/n1/n2/n3)
!                     end do
!                 end do
!             end do
!         .
!
!
! -------- DST (Discrete Sine Transform) / Inverse of DST --------
!     [definition]
!         <case1> IDST (excluding scale)
!             S(k1,k2,k3) = sum_j1=1^n1 sum_j2=1^n2 sum_j3=1^n3
!                               A(j1,j2,j3) *
!                               sin(pi*j1*(k1+1/2)/n1) *
!                               sin(pi*j2*(k2+1/2)/n2) *
!                               sin(pi*j3*(k3+1/2)/n3),
!                               0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!         <case2> DST
!             S(k1,k2,k3) = sum_j1=0^n1-1 sum_j2=0^n2-1 sum_j3=0^n3-1
!                               a(j1,j2,j3) *
!                               sin(pi*(j1+1/2)*k1/n1) *
!                               sin(pi*(j2+1/2)*k2/n2) *
!                               sin(pi*(j3+1/2)*k3/n3),
!                               0<k1<=n1, 0<k2<=n2, 0<k3<=n3
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call ddst3d(n1max, n2max, n1, n2, n3, 1, a, t, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call ddst3d(n1max, n2max, n1, n2, n3, -1, a, t, ip, w)
!     [parameters]
!         n1max  :row1 size of the 3D array (integer)
!         n2max  :row2 size of the 3D array (integer)
!         n1     :data length (integer)
!                 n1 >= 2, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 2, n2 = power of 2
!         n3     :data length (integer)
!                 n3 >= 2, n3 = power of 2
!         a(0:n1-1,0:n2-1,0:n3-1)
!                :input/output data (real*8)
!                 <case1>
!                     input data
!                         a(mod(j1,n1),mod(j2,n2),mod(j3,n3)) = A(j1,j2,j3),
!                             0<j1<=n1, 0<j2<=n2, 0<j3<=n3
!                     output data
!                         a(k1,k2,k3) = S(k1,k2,k3),
!                             0<=k1<n1, 0<=k2<n2, 0<=k3<n3
!                 <case2>
!                     output data
!                         a(mod(k1,n1),mod(k2,n2),mod(k3,n3)) = S(k1,k2,k3),
!                             0<k1<=n1, 0<k2<=n2, 0<k3<=n3
!         t(0:*) :work area (real*8)
!                 length of t >= max(4*n2, 4*n3)
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1/2, n2/2, n3/2))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1*3/2, n2*3/2, n3*3/2)
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call ddst3d(n1max, n2max, n1, n2, n3, -1, a, t, ip, w)
!         is
!             do j3 = 0, n3 - 1
!                 do j2 = 0, n2 - 1
!                     a(0, j2, j3) = a(0, j2, j3) * 0.5d0
!                 end do
!                 do j1 = 0, n1 - 1
!                     a(j1, 0, j3) = a(j1, 0, j3) * 0.5d0
!                 end do
!             end do
!             do j2 = 0, n2 - 1
!                 do j1 = 0, n1 - 1
!                     a(j1, j2, 0) = a(j1, j2, 0) * 0.5d0
!                 end do
!             end do
!             call ddst3d(n1max, n2max, n1, n2, n3, 1, a, t, ip, w)
!             do j3 = 0, n3 - 1
!                 do j2 = 0, n2 - 1
!                     do j1 = 0, n1 - 1
!                         a(j1,j2,j3) = a(j1,j2,j3) * (8.0d0/n1/n2/n3)
!                     end do
!                 end do
!             end do
!         .
!
!
      subroutine cdft3d(n1max, n2max, n1, n2, n3, isgn, a,
     &    t, ip, w)
      integer n1max, n2max, n1, n2, n3, isgn, ip(0 : *), n
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : n3 - 1),
     &    t(0 : *), w(0 : *)
      n = 2 * max(n2, n3)
      n = max(n, n1)
      if (n .gt. 4 * ip(0)) then
          call makewt(n / 4, ip, w)
      end if
      call xdft3da_sub(n1max, n2max, n1, n2, n3, 0,
     &    isgn, a, t, ip, w)
      call cdft3db_sub(n1max, n2max, n1, n2, n3,
     &    isgn, a, t, ip, w)
      end
!
      subroutine rdft3d(n1max, n2max, n1, n2, n3, isgn, a,
     &    t, ip, w)
      integer n1max, n2max, n1, n2, n3, isgn, ip(0 : *),
     &    n, nw, nc
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : n3 - 1),
     &    t(0 : *), w(0 : *)
      n = 2 * max(n2, n3)
      n = max(n, n1)
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n1 .gt. 4 * nc) then
          nc = n1 / 4
          call makect(nc, ip, w(nw))
      end if
      if (isgn .lt. 0) then
          call rdft3d_sub(n1max, n2max, n1, n2, n3, isgn, a)
          call cdft3db_sub(n1max, n2max, n1, n2, n3,
     &        isgn, a, t, ip, w)
          call xdft3da_sub(n1max, n2max, n1, n2, n3, 1,
     &        isgn, a, t, ip, w)
      else
          call xdft3da_sub(n1max, n2max, n1, n2, n3, 1,
     &        isgn, a, t, ip, w)
          call cdft3db_sub(n1max, n2max, n1, n2, n3,
     &        isgn, a, t, ip, w)
          call rdft3d_sub(n1max, n2max, n1, n2, n3, isgn, a)
      end if
      end
!
      subroutine rdft3dsort(n1max, n2max, n1, n2, n3, isgn, a)
      integer n1max, n2max, n1, n2, n3, isgn, n2h, n3h, j, k
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : n3 - 1), x, y
      n2h = n2 / 2
      n3h = n3 / 2
      if (isgn .lt. 0) then
          do k = 0, n3 - 1
              do j = n2h + 1, n2 - 1
                  a(0, j, k) = a(n1 + 1, j, k)
                  a(1, j, k) = a(n1, j, k)
              end do
          end do
          do k = n3h + 1, n3 - 1
              a(0, 0, k) = a(n1 + 1, 0, k)
              a(1, 0, k) = a(n1, 0, k)
              a(0, n2h, k) = a(n1 + 1, n2h, k)
              a(1, n2h, k) = a(n1, n2h, k)
          end do
          a(1, 0, 0) = a(n1, 0, 0)
          a(1, n2h, 0) = a(n1, n2h, 0)
          a(1, 0, n3h) = a(n1, 0, n3h)
          a(1, n2h, n3h) = a(n1, n2h, n3h)
      else
          do j = n2h + 1, n2 - 1
              y = a(0, j, 0)
              x = a(1, j, 0)
              a(n1, j, 0) = x
              a(n1 + 1, j, 0) = y
              a(n1, n2 - j, 0) = x
              a(n1 + 1, n2 - j, 0) = -y
              a(0, j, 0) = a(0, n2 - j, 0)
              a(1, j, 0) = -a(1, n2 - j, 0)
          end do
          do k = 1, n3 - 1
              do j = n2h + 1, n2 - 1
                  y = a(0, j, k)
                  x = a(1, j, k)
                  a(n1, j, k) = x
                  a(n1 + 1, j, k) = y
                  a(n1, n2 - j, n3 - k) = x
                  a(n1 + 1, n2 - j, n3 - k) = -y
                  a(0, j, k) = a(0, n2 - j, n3 - k)
                  a(1, j, k) = -a(1, n2 - j, n3 - k)
              end do
          end do
          do k = n3h + 1, n3 - 1
              y = a(0, 0, k)
              x = a(1, 0, k)
              a(n1, 0, k) = x
              a(n1 + 1, 0, k) = y
              a(n1, 0, n3 - k) = x
              a(n1 + 1, 0, n3 - k) = -y
              a(0, 0, k) = a(0, 0, n3 - k)
              a(1, 0, k) = -a(1, 0, n3 - k)
              y = a(0, n2h, k)
              x = a(1, n2h, k)
              a(n1, n2h, k) = x
              a(n1 + 1, n2h, k) = y
              a(n1, n2h, n3 - k) = x
              a(n1 + 1, n2h, n3 - k) = -y
              a(0, n2h, k) = a(0, n2h, n3 - k)
              a(1, n2h, k) = -a(1, n2h, n3 - k)
          end do
          a(n1, 0, 0) = a(1, 0, 0)
          a(n1 + 1, 0, 0) = 0
          a(1, 0, 0) = 0
          a(n1, n2h, 0) = a(1, n2h, 0)
          a(n1 + 1, n2h, 0) = 0
          a(1, n2h, 0) = 0
          a(n1, 0, n3h) = a(1, 0, n3h)
          a(n1 + 1, 0, n3h) = 0
          a(1, 0, n3h) = 0
          a(n1, n2h, n3h) = a(1, n2h, n3h)
          a(n1 + 1, n2h, n3h) = 0
          a(1, n2h, n3h) = 0
      end if
      end
!
      subroutine ddct3d(n1max, n2max, n1, n2, n3, isgn, a,
     &    t, ip, w)
      integer n1max, n2max, n1, n2, n3, isgn, ip(0 : *),
     &    n, nw, nc
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : n3 - 1),
     &    t(0 : *), w(0 : *)
      n = max(n2, n3)
      n = max(n, n1)
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n .gt. nc) then
          nc = n
          call makect(nc, ip, w(nw))
      end if
      call ddxt3da_sub(n1max, n2max, n1, n2, n3, 0,
     &    isgn, a, t, ip, w)
      call ddxt3db_sub(n1max, n2max, n1, n2, n3, 0,
     &    isgn, a, t, ip, w)
      end
!
      subroutine ddst3d(n1max, n2max, n1, n2, n3, isgn, a,
     &    t, ip, w)
      integer n1max, n2max, n1, n2, n3, isgn, ip(0 : *),
     &    n, nw, nc
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : n3 - 1),
     &    t(0 : *), w(0 : *)
      n = max(n2, n3)
      n = max(n, n1)
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n .gt. nc) then
          nc = n
          call makect(nc, ip, w(nw))
      end if
      call ddxt3da_sub(n1max, n2max, n1, n2, n3, 1,
     &    isgn, a, t, ip, w)
      call ddxt3db_sub(n1max, n2max, n1, n2, n3, 1,
     &    isgn, a, t, ip, w)
      end
!
! -------- child routines --------
!
      subroutine xdft3da_sub(n1max, n2max, n1, n2, n3, icr,
     &    isgn, a, t, ip, w)
      integer n1max, n2max, n1, n2, n3, icr, isgn,
     &    ip(0 : *), i, j, k
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : n3 - 1),
     &    t(0 : *), w(0 : *)
      do k = 0, n3 - 1
          if (icr .eq. 0) then
              do j = 0, n2 - 1
                  call cdft(n1, isgn, a(0, j, k), ip, w)
              end do
          else if (isgn .ge. 0) then
              do j = 0, n2 - 1
                  call rdft(n1, isgn, a(0, j, k), ip, w)
              end do
          end if
          if (n1 .gt. 4) then
              do i = 0, n1 - 8, 8
                  do j = 0, n2 - 1
                      t(2 * j) = a(i, j, k)
                      t(2 * j + 1) = a(i + 1, j, k)
                      t(2 * n2 + 2 * j) = a(i + 2, j, k)
                      t(2 * n2 + 2 * j + 1) = a(i + 3, j, k)
                      t(4 * n2 + 2 * j) = a(i + 4, j, k)
                      t(4 * n2 + 2 * j + 1) = a(i + 5, j, k)
                      t(6 * n2 + 2 * j) = a(i + 6, j, k)
                      t(6 * n2 + 2 * j + 1) = a(i + 7, j, k)
                  end do
                  call cdft(2 * n2, isgn, t, ip, w)
                  call cdft(2 * n2, isgn, t(2 * n2), ip, w)
                  call cdft(2 * n2, isgn, t(4 * n2), ip, w)
                  call cdft(2 * n2, isgn, t(6 * n2), ip, w)
                  do j = 0, n2 - 1
                      a(i, j, k) = t(2 * j)
                      a(i + 1, j, k) = t(2 * j + 1)
                      a(i + 2, j, k) = t(2 * n2 + 2 * j)
                      a(i + 3, j, k) = t(2 * n2 + 2 * j + 1)
                      a(i + 4, j, k) = t(4 * n2 + 2 * j)
                      a(i + 5, j, k) = t(4 * n2 + 2 * j + 1)
                      a(i + 6, j, k) = t(6 * n2 + 2 * j)
                      a(i + 7, j, k) = t(6 * n2 + 2 * j + 1)
                  end do
              end do
          else if (n1 .eq. 4) then
              do j = 0, n2 - 1
                  t(2 * j) = a(0, j, k)
                  t(2 * j + 1) = a(1, j, k)
                  t(2 * n2 + 2 * j) = a(2, j, k)
                  t(2 * n2 + 2 * j + 1) = a(3, j, k)
              end do
              call cdft(2 * n2, isgn, t, ip, w)
              call cdft(2 * n2, isgn, t(2 * n2), ip, w)
              do j = 0, n2 - 1
                  a(0, j, k) = t(2 * j)
                  a(1, j, k) = t(2 * j + 1)
                  a(2, j, k) = t(2 * n2 + 2 * j)
                  a(3, j, k) = t(2 * n2 + 2 * j + 1)
              end do
          else if (n1 .eq. 2) then
              do j = 0, n2 - 1
                  t(2 * j) = a(0, j, k)
                  t(2 * j + 1) = a(1, j, k)
              end do
              call cdft(2 * n2, isgn, t, ip, w)
              do j = 0, n2 - 1
                  a(0, j, k) = t(2 * j)
                  a(1, j, k) = t(2 * j + 1)
              end do
          end if
          if (icr .ne. 0 .and. isgn .lt. 0) then
              do j = 0, n2 - 1
                  call rdft(n1, isgn, a(0, j, k), ip, w)
              end do
          end if
      end do
      end
!
      subroutine cdft3db_sub(n1max, n2max, n1, n2, n3,
     &    isgn, a, t, ip, w)
      integer n1max, n2max, n1, n2, n3, isgn, ip(0 : *),
     &    i, j, k
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : n3 - 1),
     &    t(0 : *), w(0 : *)
      if (n1 .gt. 4) then
          do j = 0, n2 - 1
              do i = 0, n1 - 8, 8
                  do k = 0, n3 - 1
                      t(2 * k) = a(i, j, k)
                      t(2 * k + 1) = a(i + 1, j, k)
                      t(2 * n3 + 2 * k) = a(i + 2, j, k)
                      t(2 * n3 + 2 * k + 1) = a(i + 3, j, k)
                      t(4 * n3 + 2 * k) = a(i + 4, j, k)
                      t(4 * n3 + 2 * k + 1) = a(i + 5, j, k)
                      t(6 * n3 + 2 * k) = a(i + 6, j, k)
                      t(6 * n3 + 2 * k + 1) = a(i + 7, j, k)
                  end do
                  call cdft(2 * n3, isgn, t, ip, w)
                  call cdft(2 * n3, isgn, t(2 * n3), ip, w)
                  call cdft(2 * n3, isgn, t(4 * n3), ip, w)
                  call cdft(2 * n3, isgn, t(6 * n3), ip, w)
                  do k = 0, n3 - 1
                      a(i, j, k) = t(2 * k)
                      a(i + 1, j, k) = t(2 * k + 1)
                      a(i + 2, j, k) = t(2 * n3 + 2 * k)
                      a(i + 3, j, k) = t(2 * n3 + 2 * k + 1)
                      a(i + 4, j, k) = t(4 * n3 + 2 * k)
                      a(i + 5, j, k) = t(4 * n3 + 2 * k + 1)
                      a(i + 6, j, k) = t(6 * n3 + 2 * k)
                      a(i + 7, j, k) = t(6 * n3 + 2 * k + 1)
                  end do
              end do
          end do
      else if (n1 .eq. 4) then
          do j = 0, n2 - 1
              do k = 0, n3 - 1
                  t(2 * k) = a(0, j, k)
                  t(2 * k + 1) = a(1, j, k)
                  t(2 * n3 + 2 * k) = a(2, j, k)
                  t(2 * n3 + 2 * k + 1) = a(3, j, k)
              end do
              call cdft(2 * n3, isgn, t, ip, w)
              call cdft(2 * n3, isgn, t(2 * n3), ip, w)
              do k = 0, n3 - 1
                  a(0, j, k) = t(2 * k)
                  a(1, j, k) = t(2 * k + 1)
                  a(2, j, k) = t(2 * n3 + 2 * k)
                  a(3, j, k) = t(2 * n3 + 2 * k + 1)
              end do
          end do
      else if (n1 .eq. 2) then
          do j = 0, n2 - 1
              do k = 0, n3 - 1
                  t(2 * k) = a(0, j, k)
                  t(2 * k + 1) = a(1, j, k)
              end do
              call cdft(2 * n3, isgn, t, ip, w)
              do k = 0, n3 - 1
                  a(0, j, k) = t(2 * k)
                  a(1, j, k) = t(2 * k + 1)
              end do
          end do
      end if
      end
!
      subroutine rdft3d_sub(n1max, n2max, n1, n2, n3, isgn, a)
      integer n1max, n2max, n1, n2, n3, isgn,
     &    n2h, n3h, i, j, k, l
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : n3 - 1), xi
      n2h = n2 / 2
      n3h = n3 / 2
      if (isgn .lt. 0) then
          do k = 1, n3h - 1
              l = n3 - k
              xi = a(0, 0, k) - a(0, 0, l)
              a(0, 0, k) = a(0, 0, k) + a(0, 0, l)
              a(0, 0, l) = xi
              xi = a(1, 0, l) - a(1, 0, k)
              a(1, 0, k) = a(1, 0, k) + a(1, 0, l)
              a(1, 0, l) = xi
              xi = a(0, n2h, k) - a(0, n2h, l)
              a(0, n2h, k) = a(0, n2h, k) + a(0, n2h, l)
              a(0, n2h, l) = xi
              xi = a(1, n2h, l) - a(1, n2h, k)
              a(1, n2h, k) = a(1, n2h, k) + a(1, n2h, l)
              a(1, n2h, l) = xi
              do i = 1, n2h - 1
                  j = n2 - i
                  xi = a(0, i, k) - a(0, j, l)
                  a(0, i, k) = a(0, i, k) + a(0, j, l)
                  a(0, j, l) = xi
                  xi = a(1, j, l) - a(1, i, k)
                  a(1, i, k) = a(1, i, k) + a(1, j, l)
                  a(1, j, l) = xi
                  xi = a(0, i, l) - a(0, j, k)
                  a(0, i, l) = a(0, i, l) + a(0, j, k)
                  a(0, j, k) = xi
                  xi = a(1, j, k) - a(1, i, l)
                  a(1, i, l) = a(1, i, l) + a(1, j, k)
                  a(1, j, k) = xi
              end do
          end do
          do i = 1, n2h - 1
              j = n2 - i
              xi = a(0, i, 0) - a(0, j, 0)
              a(0, i, 0) = a(0, i, 0) + a(0, j, 0)
              a(0, j, 0) = xi
              xi = a(1, j, 0) - a(1, i, 0)
              a(1, i, 0) = a(1, i, 0) + a(1, j, 0)
              a(1, j, 0) = xi
              xi = a(0, i, n3h) - a(0, j, n3h)
              a(0, i, n3h) = a(0, i, n3h) + a(0, j, n3h)
              a(0, j, n3h) = xi
              xi = a(1, j, n3h) - a(1, i, n3h)
              a(1, i, n3h) = a(1, i, n3h) + a(1, j, n3h)
              a(1, j, n3h) = xi
          end do
      else
          do k = 1, n3h - 1
              l = n3 - k
              a(0, 0, l) = 0.5d0 * (a(0, 0, k) - a(0, 0, l))
              a(0, 0, k) = a(0, 0, k) - a(0, 0, l)
              a(1, 0, l) = 0.5d0 * (a(1, 0, k) + a(1, 0, l))
              a(1, 0, k) = a(1, 0, k) - a(1, 0, l)
              a(0, n2h, l) = 0.5d0 * (a(0, n2h, k) - a(0, n2h, l))
              a(0, n2h, k) = a(0, n2h, k) - a(0, n2h, l)
              a(1, n2h, l) = 0.5d0 * (a(1, n2h, k) + a(1, n2h, l))
              a(1, n2h, k) = a(1, n2h, k) - a(1, n2h, l)
              do i = 1, n2h - 1
                  j = n2 - i
                  a(0, j, l) = 0.5d0 * (a(0, i, k) - a(0, j, l))
                  a(0, i, k) = a(0, i, k) - a(0, j, l)
                  a(1, j, l) = 0.5d0 * (a(1, i, k) + a(1, j, l))
                  a(1, i, k) = a(1, i, k) - a(1, j, l)
                  a(0, j, k) = 0.5d0 * (a(0, i, l) - a(0, j, k))
                  a(0, i, l) = a(0, i, l) - a(0, j, k)
                  a(1, j, k) = 0.5d0 * (a(1, i, l) + a(1, j, k))
                  a(1, i, l) = a(1, i, l) - a(1, j, k)
              end do
          end do
          do i = 1, n2h - 1
              j = n2 - i
              a(0, j, 0) = 0.5d0 * (a(0, i, 0) - a(0, j, 0))
              a(0, i, 0) = a(0, i, 0) - a(0, j, 0)
              a(1, j, 0) = 0.5d0 * (a(1, i, 0) + a(1, j, 0))
              a(1, i, 0) = a(1, i, 0) - a(1, j, 0)
              a(0, j, n3h) = 0.5d0 * (a(0, i, n3h) - a(0, j, n3h))
              a(0, i, n3h) = a(0, i, n3h) - a(0, j, n3h)
              a(1, j, n3h) = 0.5d0 * (a(1, i, n3h) + a(1, j, n3h))
              a(1, i, n3h) = a(1, i, n3h) - a(1, j, n3h)
          end do
      end if
      end
!
      subroutine ddxt3da_sub(n1max, n2max, n1, n2, n3, ics,
     &    isgn, a, t, ip, w)
      integer n1max, n2max, n1, n2, n3, ics, isgn,
     &    ip(0 : *), i, j, k
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : n3 - 1),
     &    t(0 : *), w(0 : *)
      do k = 0, n3 - 1
          if (ics .eq. 0) then
              do j = 0, n2 - 1
                  call ddct(n1, isgn, a(0, j, k), ip, w)
              end do
          else
              do j = 0, n2 - 1
                  call ddst(n1, isgn, a(0, j, k), ip, w)
              end do
          end if
          if (n1 .gt. 2) then
              do i = 0, n1 - 4, 4
                  do j = 0, n2 - 1
                      t(j) = a(i, j, k)
                      t(n2 + j) = a(i + 1, j, k)
                      t(2 * n2 + j) = a(i + 2, j, k)
                      t(3 * n2 + j) = a(i + 3, j, k)
                  end do
                  if (ics .eq. 0) then
                      call ddct(n2, isgn, t, ip, w)
                      call ddct(n2, isgn, t(n2), ip, w)
                      call ddct(n2, isgn, t(2 * n2), ip, w)
                      call ddct(n2, isgn, t(3 * n2), ip, w)
                  else
                      call ddst(n2, isgn, t, ip, w)
                      call ddst(n2, isgn, t(n2), ip, w)
                      call ddst(n2, isgn, t(2 * n2), ip, w)
                      call ddst(n2, isgn, t(3 * n2), ip, w)
                  end if
                  do j = 0, n2 - 1
                      a(i, j, k) = t(j)
                      a(i + 1, j, k) = t(n2 + j)
                      a(i + 2, j, k) = t(2 * n2 + j)
                      a(i + 3, j, k) = t(3 * n2 + j)
                  end do
              end do
          else if (n1 .eq. 2) then
              do j = 0, n2 - 1
                  t(j) = a(0, j, k)
                  t(n2 + j) = a(1, j, k)
              end do
              if (ics .eq. 0) then
                  call ddct(n2, isgn, t, ip, w)
                  call ddct(n2, isgn, t(n2), ip, w)
              else
                  call ddst(n2, isgn, t, ip, w)
                  call ddst(n2, isgn, t(n2), ip, w)
              end if
              do j = 0, n2 - 1
                  a(0, j, k) = t(j)
                  a(1, j, k) = t(n2 + j)
              end do
          end if
      end do
      end
!
      subroutine ddxt3db_sub(n1max, n2max, n1, n2, n3, ics,
     &    isgn, a, t, ip, w)
      integer n1max, n2max, n1, n2, n3, ics, isgn,
     &    ip(0 : *), i, j, k
      real*8 a(0 : n1max - 1, 0 : n2max - 1, 0 : n3 - 1),
     &    t(0 : *), w(0 : *)
      if (n1 .gt. 2) then
          do j = 0, n2 - 1
              do i = 0, n1 - 4, 4
                  do k = 0, n3 - 1
                      t(k) = a(i, j, k)
                      t(n3 + k) = a(i + 1, j, k)
                      t(2 * n3 + k) = a(i + 2, j, k)
                      t(3 * n3 + k) = a(i + 3, j, k)
                  end do
                  if (ics .eq. 0) then
                      call ddct(n3, isgn, t, ip, w)
                      call ddct(n3, isgn, t(n3), ip, w)
                      call ddct(n3, isgn, t(2 * n3), ip, w)
                      call ddct(n3, isgn, t(3 * n3), ip, w)
                  else
                      call ddst(n3, isgn, t, ip, w)
                      call ddst(n3, isgn, t(n3), ip, w)
                      call ddst(n3, isgn, t(2 * n3), ip, w)
                      call ddst(n3, isgn, t(3 * n3), ip, w)
                  end if
                  do k = 0, n3 - 1
                      a(i, j, k) = t(k)
                      a(i + 1, j, k) = t(n3 + k)
                      a(i + 2, j, k) = t(2 * n3 + k)
                      a(i + 3, j, k) = t(3 * n3 + k)
                  end do
              end do
          end do
      else if (n1 .eq. 2) then
          do j = 0, n2 - 1
              do k = 0, n3 - 1
                  t(k) = a(0, j, k)
                  t(n3 + k) = a(1, j, k)
              end do
              if (ics .eq. 0) then
                  call ddct(n3, isgn, t, ip, w)
                  call ddct(n3, isgn, t(n3), ip, w)
              else
                  call ddst(n3, isgn, t, ip, w)
                  call ddst(n3, isgn, t(n3), ip, w)
              end if
              do k = 0, n3 - 1
                  a(0, j, k) = t(k)
                  a(1, j, k) = t(n3 + k)
              end do
          end do
      end if
      end
!


id = \x . x

0 = \f . \x . x
1 = \f . \x . f x
s = \x . \y . \z . y (x y z)

pred = \n . \f . \x . n (\g . \h . h (g f)) (\u . x) (\u . u)
zero? = \n . n (\x . 0) 1

+ = \n1 . \n2 . \f . \x . n2 f (n1 f x)
* = \n1 . \n2 . \f . n1 (n2 f)

if = \c . \tf . \ff . (c tf ff) id

Y = \f . (\x . (\y . x x y)) (\x . (\y . x x y))

fact = Y (\f . \x . if (zero? x) (\_ . 1) (\_ . (* x (f (pred x)))))

------------------

fact (s s 1)


      DOUBLE PRECISION FUNCTION PHO_GGFLCL(Xi)
C*********************************************************************
C
C     semi-classical photon flux (geometrical model)
C
C*********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION PHO_BESSK0 , PHO_BESSK1 , Xi
      SAVE

      PHO_GGFLCL = 2.D0/3.141592653589793238462643383279D+00*
     &             (Xi*PHO_BESSK0(Xi)*PHO_BESSK1(Xi)
     &             -Xi**2/2.D0*(PHO_BESSK1(Xi)**2-PHO_BESSK0(Xi)**2))

      END FUNCTION


! **************************************************************
!
!  Interpolates opacity table.
!
! **************************************************************

       subroutine get_kappa(dens,kappa,T)

	use eosdata

       real :: dens, kappa
       real :: upart1, upart2,T
       real :: m, d

       integer ::  i, j

       if (dens<1.0e-24) dens = 1.0e-24

       i = 1
       do while((eostable(i,1,1)<=dens).and.(i<nrhopoints))
         i = i + 1
       enddo

       If (T<1.0) T = 1.0

       j = 1
       do while ((eostable(i-1,j,2)<=T).and.(j<nUpoints))
         j = j + 1
       enddo

       m = (eostable(i-1,j-1,6) - eostable(i-1,j,6))/ &
          (eostable(i-1,j-1,2) - eostable(i-1,j,2))
       d = eostable(i-1,j,6) - m*eostable(i-1,j,2)

       upart1 = m*T + d

       j = 1
       do while ((eostable(i,j,2)<=T).and.(j<1000))
         j = j + 1
       enddo

       m = (eostable(i,j-1,6) - eostable(i,j,6))/ &
          (eostable(i,j-1,2) - eostable(i,j,2))
       d = eostable(i,j,6) - m*eostable(i,j,2)

       upart2 = m*T + d

       m = (upart2 - upart1)/  &
          (eostable(i,1,1)-eostable(i-1,1,1))
       d = upart2 - m*eostable(i,1,1)

       kappa = m*dens + d

       return

       end subroutine get_kappa


      subroutine sma_fortran(period, dataa, smas, n)
      integer pos, n, endd, period
      real dataa(n), smas(n), sma
      do 10 endd = 1, n
         pos = endd
         sma = 0.0
         do 20 while ((endd - pos .lt. period) .and. (pos .ge. 1))
            sma = sma + dataa(pos)
            pos = pos - 1
 20      end do
         if (endd - pos .eq. period) then
            sma = sma / period
         else
            sma = 0
         end if
         smas(endd) = sma
 10   continue
      end


! =============================================================================
! This module contains all non-modifiable parameters and all quantities which
! never change throughout a simulation.
! =============================================================================
module constants
    implicit none

    double precision, parameter :: zero     = 0.0d0
    double precision, parameter :: one      = 1.0d0
    double precision, parameter :: two      = 2.0d0
    double precision, parameter :: three    = 3.0d0
    double precision, parameter :: four     = 4.0d0
    double precision, parameter :: five     = 5.0d0
    double precision, parameter :: six      = 6.0d0
    double precision, parameter :: seven    = 7.0d0
    double precision, parameter :: eight    = 8.0d0
    double precision, parameter :: nine     = 9.0d0
    double precision, parameter :: ten      = 10.0d0
    double precision, parameter :: hundred  = ten ** 2
    double precision, parameter :: thousand = ten ** 3

    double precision, parameter :: pi     = dacos(-one)
    double precision, parameter :: twopi  = two * pi
    double precision, parameter :: fpi    = one / pi
    double precision, parameter :: fpi2   = pi / two
    double precision, parameter :: fpi4   = pi / four

    double precision, parameter :: f32   = three / two
    double precision, parameter :: f34   = three / four
    double precision, parameter :: f12   = one / two
    double precision, parameter :: f13   = one / three
    double precision, parameter :: f14   = one / four
    double precision, parameter :: f15   = one / five
    double precision, parameter :: f18   = one / eight
    double precision, parameter :: f23   = two / three
    double precision, parameter :: f112  = one / 12.d0
    double precision, parameter :: f16   = one / six
    double precision, parameter :: f56   = five / six
    double precision, parameter :: f76   = 7.d0 / six
    double precision, parameter :: f124  = one / 24.d0
    double precision, parameter :: f1112 = 11.d0 / 12.d0

    double precision, parameter :: rad2deg = 180.0d0 * fpi
    double precision, parameter :: deg2rad = one / rad2deg

end module


! mwebber
! 4670 Numerical Analysis
! Homework Two Redo

module secret

end module secret

program WebberHomework2Question3
use secret							! uses secret module
implicit none

double complex :: f
double complex :: p
double complex :: old
double complex :: prime
double complex :: tolerance

p = (0, 1)
old = (p*2.0d0)
tolerance = 1.0d0-10

do while ((abs(p - old) /= tolerance))
	old = p
	p = (p + 1)
	p = (f(old) - (old - f(old)) / prime(old))
	print*, "probability = ", p
end do

stop
end program WebberHomework2Question3

double complex function f(p)				! function for probability
implicit none

double complex :: p

f = ((p + 1) / 2)* & (p / (1 - p + p**2)**21)

return
end

double complex function firstP(p)
implicit none

double complex :: p

firstP = 1 - 1/2 p / & 1 - p + p**21

return
end

double complex function secondP(p)
implicit none

double complex :: p

secondP = 21(1 + p) / 2* & (p / (1 - p + p**2))**20

return
end

double complex function thirdP(p)
implicit none

double complex :: p

thirdP = (1 - p**2) / & (1 - p + p**2)**2

return
end

double complex function prime(p)
implicit none

double complex :: p
double complex :: firstP
double complex :: secondP
double complex :: thirdP

prime = (firstP(p) - secondP(p) * thirdP(p))

return
end


      SUBROUTINE slINVF (FWDS,BKWDS,J)
*+
*     - - - - -
*      I N V F
*     - - - - -
*
*  Invert a linear model of the type produced by the slFTXY routine.
*
*  Given:
*     FWDS    d(6)      model coefficients
*
*  Returned:
*     BKWDS   d(6)      inverse model
*     J        i        status:  0 = OK, -1 = no inverse
*
*  The models relate two sets of [X,Y] coordinates as follows.
*  Naming the elements of FWDS:
*
*     FWDS(1) = A
*     FWDS(2) = B
*     FWDS(3) = C
*     FWDS(4) = D
*     FWDS(5) = E
*     FWDS(6) = F
*
*  where two sets of coordinates [X1,Y1] and [X2,Y1] are related
*  thus:
*
*     X2 = A + B*X1 + C*Y1
*     Y2 = D + E*X1 + F*Y1
*
*  the present routine generates a new set of coefficients:
*
*     BKWDS(1) = P
*     BKWDS(2) = Q
*     BKWDS(3) = R
*     BKWDS(4) = S
*     BKWDS(5) = T
*     BKWDS(6) = U
*
*  such that:
*
*     X1 = P + Q*X2 + R*Y2
*     Y1 = S + T*X2 + U*Y2
*
*  Two successive calls to slINVF will thus deliver a set
*  of coefficients equal to the starting values.
*
*  To comply with the ANSI Fortran standard, FWDS and BKWDS must
*  not be the same array, even though the routine is coded to
*  work on many platforms even if this rule is violated.
*
*  See also slFTXY, slPXY, slXYXY, slDCMF
*
*  Last revision:   26 December 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION FWDS(6),BKWDS(6)
      INTEGER J

      DOUBLE PRECISION A,B,C,D,E,F,DET

      A=FWDS(1)
      B=FWDS(2)
      C=FWDS(3)
      D=FWDS(4)
      E=FWDS(5)
      F=FWDS(6)
      DET=B*F-C*E
      IF (DET.NE.0D0) THEN
         BKWDS(1)=(C*D-A*F)/DET
         BKWDS(2)=F/DET
         BKWDS(3)=-C/DET
         BKWDS(4)=(A*E-B*D)/DET
         BKWDS(5)=-E/DET
         BKWDS(6)=B/DET
         J=0
      ELSE
         J=-1
      END IF

      END


program array1

    implicit none
    integer, parameter :: m = 5, n=6
    integer :: nthreads, thread_num

    real (kind=8), dimension(m,n) :: A
    real (kind=8), dimension(m) :: b
    real (kind=8), dimension(n) :: x

    real (kind=8), dimension(m,n) :: At
    real (kind=8), dimension(m) :: bt
    real (kind=8), dimension(n) :: xt
    integer :: i,j

    nthreads = 1  ! if not using OpenMP
    !$ call omp_set_num_threads(6)
    !$ nthreads = omp_get_num_threads()
    print *, "nthreads = ",nthreads

    ! initialize matrix A and vector x:
    do i=1,m
        $omp parallel do private(i)
        do j=1,n
            A(i,j) = i+j
            enddo
        enddo

    ! serial version for At:
    do i=1,m
        do j=1,n
            At(i,j)=i+j
            enddo
        enddo

    xt = 1.
    x  = 1.

    ! multiply A*x to get b:
    !$omp parallel do private(j)
    do i=1,m
        b(i) = 0.
        do j=1,n
            b(i) = b(i) + A(i,j)*x(j)
            enddo
        enddo

    bt=matmul(At,xt)

    print *, "b and bt should be equal "
    print *, "b="
    print "(d16.6)", b
    print *, "bt="
    print "(d16.6)",bt

end program array1


!----------------------------------------------------------------------------- best with 100 columns

function fixPt1()
  use modSUNDIALS
  integer fixPt1
  type(fixPt)::p
  double precision::s(3)

  fixPt1=0
  call p%init(3,func,maa=10)
  s(:)=[0d0,0d0,0d0]
  call p%solve(s)
  if(norm2(s-[-1d0,-2d0/3d0,1d0/3d0])>1d-12)then
    fixPt1=1
  end if
  call p%clear()

contains

  function func(cx,cy,dat)
    use iso_c_binding
    use modSUNDIALS
    type(C_PTR),value::cx,cy,dat
    integer(C_INT)::func
    double precision,pointer::x(:)
    double precision,pointer::y(:)
    type(C_PTR)::foo

    call associateVector(cx,x)
    call associateVector(cy,y)
    y(1:3)=[2d0,4d0,-8d0]*x(1:3)+[1d0,2d0,3d0]
    func=0
    foo=dat
  end function

end function


*DECK PCOEF
      SUBROUTINE PCOEF (L, C, TC, A)
C***BEGIN PROLOGUE  PCOEF
C***PURPOSE  Convert the POLFIT coefficients to Taylor series form.
C***LIBRARY   SLATEC
C***CATEGORY  K1A1A2
C***TYPE      SINGLE PRECISION (PCOEF-S, DPCOEF-D)
C***KEYWORDS  CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT
C***AUTHOR  Shampine, L. F., (SNLA)
C           Davenport, S. M., (SNLA)
C***DESCRIPTION
C
C     Written BY L. F. Shampine and S. M. Davenport.
C
C     Abstract
C
C     POLFIT  computes the least squares polynomial fit of degree  L  as
C     a sum of orthogonal polynomials.  PCOEF  changes this fit to its
C     Taylor expansion about any point  C , i.e. writes the polynomial
C     as a sum of powers of (X-C).  Taking  C=0.  gives the polynomial
C     in powers of X, but a suitable non-zero  C  often leads to
C     polynomials which are better scaled and more accurately evaluated.
C
C     The parameters for  PCOEF  are
C
C     INPUT --
C         L -      Indicates the degree of polynomial to be changed to
C                  its Taylor expansion.  To obtain the Taylor
C                  coefficients in reverse order, input  L  as the
C                  negative of the degree desired.  The absolute value
C                  of L  must be less than or equal to NDEG, the highest
C                  degree polynomial fitted by  POLFIT .
C         C -      The point about which the Taylor expansion is to be
C                  made.
C         A -      Work and output array containing values from last
C                  call to  POLFIT .
C
C     OUTPUT --
C         TC -     Vector containing the first LL+1 Taylor coefficients
C                  where LL=ABS(L).  If  L.GT.0 , the coefficients are
C                  in the usual Taylor series order, i.e.
C                    P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N
C                  If L .LT. 0, the coefficients are in reverse order,
C                  i.e.
C                    P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1)
C
C***REFERENCES  L. F. Shampine, S. M. Davenport and R. E. Huddleston,
C                 Curve fitting by polynomials in one variable, Report
C                 SLA-74-0270, Sandia Laboratories, June 1974.
C***ROUTINES CALLED  PVALUE
C***REVISION HISTORY  (YYMMDD)
C   740601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  PCOEF
C
      DIMENSION A(*), TC(*)
C***FIRST EXECUTABLE STATEMENT  PCOEF
      LL = ABS(L)
      LLP1 = LL + 1
      CALL PVALUE (LL,LL,C,TC(1),TC(2),A)
      IF (LL .LT. 2) GO TO 2
      FAC = 1.0
      DO 1 I = 3,LLP1
        FAC = FAC*(I-1)
 1      TC(I) = TC(I)/FAC
 2    IF (L .GE. 0) GO TO 4
      NR = LLP1/2
      LLP2 = LL + 2
      DO 3 I = 1,NR
        SAVE = TC(I)
        NEW = LLP2 - I
        TC(I) = TC(NEW)
 3      TC(NEW) = SAVE
 4    RETURN
      END
c$$$
c$$$      subroutine  dscal(n,da,dx,incx)
c$$$c
c$$$c     scales a vector by a constant.
c$$$c     uses unrolled loops for increment equal to one.
c$$$c     jack dongarra, linpack, 3/11/78.
c$$$c     modified 3/93 to return if incx .le. 0.
c$$$c
c$$$      double precision da,dx(1)
c$$$      integer i,incx,m,mp1,n,nincx
c$$$c
c$$$      if( n.le.0 .or. incx.le.0 )return
c$$$      if(incx.eq.1)go to 20
c$$$c
c$$$c        code for increment not equal to 1
c$$$c
c$$$      nincx = n*incx
c$$$      do 10 i = 1,nincx,incx
c$$$        dx(i) = da*dx(i)
c$$$   10 continue
c$$$      return
c$$$c
c$$$c        code for increment equal to 1
c$$$c
c$$$c
c$$$c        clean-up loop
c$$$c
c$$$   20 m = mod(n,5)
c$$$      if( m .eq. 0 ) go to 40
c$$$      do 30 i = 1,m
c$$$        dx(i) = da*dx(i)
c$$$   30 continue
c$$$      if( n .lt. 5 ) return
c$$$   40 mp1 = m + 1
c$$$      do 50 i = mp1,n,5
c$$$        dx(i) = da*dx(i)
c$$$        dx(i + 1) = da*dx(i + 1)
c$$$        dx(i + 2) = da*dx(i + 2)
c$$$        dx(i + 3) = da*dx(i + 3)
c$$$        dx(i + 4) = da*dx(i + 4)
c$$$   50 continue
c$$$      return
c$$$      end

      subroutine dgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
      integer lda,n,ml,mu,ipvt(1)
      double precision abd(lda,1),z(1)
      double precision rcond
c
c     dgbco factors a double precision band matrix by gaussian
c     elimination and estimates the condition of the matrix.
c
c     if  rcond  is not needed, dgbfa is slightly faster.
c     to solve  a*x = b , follow dgbco by dgbsl.
c     to compute  inverse(a)*c , follow dgbco by dgbsl.
c     to compute  determinant(a) , follow dgbco by dgbdi.
c
c     on entry
c
c        abd     double precision(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers 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        rcond   double precision
c                an estimate of the reciprocal condition of  a .
c                for the system  a*x = b , relative perturbations
c                in  a  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  a  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  a  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max0(1, j-mu)
c                      i2 = min0(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     example..  if the original matrix is
c
c           11 12 13  0  0  0
c           21 22 23 24  0  0
c            0 32 33 34 35  0
c            0  0 43 44 45 46
c            0  0  0 54 55 56
c            0  0  0  0 65 66
c
c      then  n = 6, ml = 1, mu = 2, lda .ge. 5  and abd should contain
c
c            *  *  *  +  +  +  , * = not used
c            *  * 13 24 35 46  , + = used for pivoting
c            * 12 23 34 45 56
c           11 22 33 44 55 66
c           21 32 43 54 65  *
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     linpack dgbfa
c     blas daxpy,ddot,dscal,dasum
c     fortran dabs,dmax1,max0,min0,dsign
c
c     internal variables
c
      double precision ddot,ek,t,wk,wkm
      double precision anorm,s,dasum,sm,ynorm
      integer is,info,j,ju,k,kb,kp1,l,la,lm,lz,m,mm
c
c
c     compute 1-norm of a
c
      anorm = 0.0d0
      l = ml + 1
      is = l + mu
      do 10 j = 1, n
         anorm = dmax1(anorm,dasum(l,abd(is,j),1))
         if (is .gt. ml + 1) is = is - 1
         if (j .le. mu) l = l + 1
         if (j .ge. n - ml) l = l - 1
   10 continue
c
c     factor
c
      call dgbfa(abd,lda,n,ml,mu,ipvt,info)
c
c     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
c     estimate = norm(z)/norm(y) where  a*z = y  and  trans(a)*y = e .
c     trans(a)  is the transpose of a .  the components of  e  are
c     chosen to cause maximum local growth in the elements of w  where
c     trans(u)*w = e .  the vectors are frequently rescaled to avoid
c     overflow.
c
c     solve trans(u)*w = e
c
      ek = 1.0d0
      do 20 j = 1, n
         z(j) = 0.0d0
   20 continue
      m = ml + mu + 1
      ju = 0
      do 100 k = 1, n
         if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
         if (dabs(ek-z(k)) .le. dabs(abd(m,k))) go to 30
            s = dabs(abd(m,k))/dabs(ek-z(k))
            call dscal(n,s,z,1)
            ek = s*ek
   30    continue
         wk = ek - z(k)
         wkm = -ek - z(k)
         s = dabs(wk)
         sm = dabs(wkm)
         if (abd(m,k) .eq. 0.0d0) go to 40
            wk = wk/abd(m,k)
            wkm = wkm/abd(m,k)
         go to 50
   40    continue
            wk = 1.0d0
            wkm = 1.0d0
   50    continue
         kp1 = k + 1
         ju = min0(max0(ju,mu+ipvt(k)),n)
         mm = m
         if (kp1 .gt. ju) go to 90
            do 60 j = kp1, ju
               mm = mm - 1
               sm = sm + dabs(z(j)+wkm*abd(mm,j))
               z(j) = z(j) + wk*abd(mm,j)
               s = s + dabs(z(j))
   60       continue
            if (s .ge. sm) go to 80
               t = wkm - wk
               wk = wkm
               mm = m
               do 70 j = kp1, ju
                  mm = mm - 1
                  z(j) = z(j) + t*abd(mm,j)
   70          continue
   80       continue
   90    continue
         z(k) = wk
  100 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
c     solve trans(l)*y = w
c
      do 120 kb = 1, n
         k = n + 1 - kb
         lm = min0(ml,n-k)
         if (k .lt. n) z(k) = z(k) + ddot(lm,abd(m+1,k),1,z(k+1),1)
         if (dabs(z(k)) .le. 1.0d0) go to 110
            s = 1.0d0/dabs(z(k))
            call dscal(n,s,z,1)
  110    continue
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
  120 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
      ynorm = 1.0d0
c
c     solve l*v = y
c
      do 140 k = 1, n
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
         lm = min0(ml,n-k)
         if (k .lt. n) call daxpy(lm,t,abd(m+1,k),1,z(k+1),1)
         if (dabs(z(k)) .le. 1.0d0) go to 130
            s = 1.0d0/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  130    continue
  140 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
c     solve  u*z = w
c
      do 160 kb = 1, n
         k = n + 1 - kb
         if (dabs(z(k)) .le. dabs(abd(m,k))) go to 150
            s = dabs(abd(m,k))/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  150    continue
         if (abd(m,k) .ne. 0.0d0) z(k) = z(k)/abd(m,k)
         if (abd(m,k) .eq. 0.0d0) z(k) = 1.0d0
         lm = min0(k,m) - 1
         la = m - lm
         lz = k - lm
         t = -z(k)
         call daxpy(lm,t,abd(la,k),1,z(lz),1)
  160 continue
c     make znorm = 1.0
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
      if (anorm .ne. 0.0d0) rcond = ynorm/anorm
      if (anorm .eq. 0.0d0) rcond = 0.0d0
      return
      end

      subroutine dgeco(a,lda,n,ipvt,rcond,z)
      integer lda,n,ipvt(1)
      double precision a(lda,1),z(1)
      double precision rcond
c
c     dgeco factors a double precision matrix by gaussian elimination
c     and estimates the condition of the matrix.
c
c     if  rcond  is not needed, dgefa is slightly faster.
c     to solve  a*x = b , follow dgeco by dgesl.
c     to compute  inverse(a)*c , follow dgeco by dgesl.
c     to compute  determinant(a) , follow dgeco by dgedi.
c     to compute  inverse(a) , follow dgeco by dgedi.
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        rcond   double precision
c                an estimate of the reciprocal condition of  a .
c                for the system  a*x = b , relative perturbations
c                in  a  and  b  of size  epsilon  may cause
c                relative perturbations in  x  of size  epsilon/rcond .
c                if  rcond  is so small that the logical expression
c                           1.0 + rcond .eq. 1.0
c                is true, then  a  may be singular to working
c                precision.  in particular,  rcond  is zero  if
c                exact singularity is detected or the estimate
c                underflows.
c
c        z       double precision(n)
c                a work vector whose contents are usually unimportant.
c                if  a  is close to a singular matrix, then  z  is
c                an approximate null vector in the sense that
c                norm(a*z) = rcond*norm(a)*norm(z) .
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     linpack dgefa
c     blas daxpy,ddot,dscal,dasum
c     fortran dabs,dmax1,dsign
c
c     internal variables
c
      double precision ddot,ek,t,wk,wkm
      double precision anorm,s,dasum,sm,ynorm
      integer info,j,k,kb,kp1,l
c
c
c     compute 1-norm of a
c
      anorm = 0.0d0
      do 10 j = 1, n
         anorm = dmax1(anorm,dasum(n,a(1,j),1))
   10 continue
c
c     factor
c
      call dgefa(a,lda,n,ipvt,info)
c
c     rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) .
c     estimate = norm(z)/norm(y) where  a*z = y  and  trans(a)*y = e .
c     trans(a)  is the transpose of a .  the components of  e  are
c     chosen to cause maximum local growth in the elements of w  where
c     trans(u)*w = e .  the vectors are frequently rescaled to avoid
c     overflow.
c
c     solve trans(u)*w = e
c
      ek = 1.0d0
      do 20 j = 1, n
         z(j) = 0.0d0
   20 continue
      do 100 k = 1, n
         if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k))
         if (dabs(ek-z(k)) .le. dabs(a(k,k))) go to 30
            s = dabs(a(k,k))/dabs(ek-z(k))
            call dscal(n,s,z,1)
            ek = s*ek
   30    continue
         wk = ek - z(k)
         wkm = -ek - z(k)
         s = dabs(wk)
         sm = dabs(wkm)
         if (a(k,k) .eq. 0.0d0) go to 40
            wk = wk/a(k,k)
            wkm = wkm/a(k,k)
         go to 50
   40    continue
            wk = 1.0d0
            wkm = 1.0d0
   50    continue
         kp1 = k + 1
         if (kp1 .gt. n) go to 90
            do 60 j = kp1, n
               sm = sm + dabs(z(j)+wkm*a(k,j))
               z(j) = z(j) + wk*a(k,j)
               s = s + dabs(z(j))
   60       continue
            if (s .ge. sm) go to 80
               t = wkm - wk
               wk = wkm
               do 70 j = kp1, n
                  z(j) = z(j) + t*a(k,j)
   70          continue
   80       continue
   90    continue
         z(k) = wk
  100 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
c     solve trans(l)*y = w
c
      do 120 kb = 1, n
         k = n + 1 - kb
         if (k .lt. n) z(k) = z(k) + ddot(n-k,a(k+1,k),1,z(k+1),1)
         if (dabs(z(k)) .le. 1.0d0) go to 110
            s = 1.0d0/dabs(z(k))
            call dscal(n,s,z,1)
  110    continue
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
  120 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
c
      ynorm = 1.0d0
c
c     solve l*v = y
c
      do 140 k = 1, n
         l = ipvt(k)
         t = z(l)
         z(l) = z(k)
         z(k) = t
         if (k .lt. n) call daxpy(n-k,t,a(k+1,k),1,z(k+1),1)
         if (dabs(z(k)) .le. 1.0d0) go to 130
            s = 1.0d0/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  130    continue
  140 continue
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
c     solve  u*z = v
c
      do 160 kb = 1, n
         k = n + 1 - kb
         if (dabs(z(k)) .le. dabs(a(k,k))) go to 150
            s = dabs(a(k,k))/dabs(z(k))
            call dscal(n,s,z,1)
            ynorm = s*ynorm
  150    continue
         if (a(k,k) .ne. 0.0d0) z(k) = z(k)/a(k,k)
         if (a(k,k) .eq. 0.0d0) z(k) = 1.0d0
         t = -z(k)
         call daxpy(k-1,t,a(1,k),1,z(1),1)
  160 continue
c     make znorm = 1.0
      s = 1.0d0/dasum(n,z,1)
      call dscal(n,s,z,1)
      ynorm = s*ynorm
c
      if (anorm .ne. 0.0d0) rcond = ynorm/anorm
      if (anorm .eq. 0.0d0) rcond = 0.0d0
      return
      end

      subroutine dgedi(a,lda,n,ipvt,det,work,job)
      integer lda,n,ipvt(1),job
      double precision a(lda,1),det(2),work(1)
c
c     dgedi computes the determinant and inverse of a matrix
c     using the factors computed by dgeco or dgefa.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output from dgeco or dgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from dgeco or dgefa.
c
c        work    double precision(n)
c                work vector.  contents destroyed.
c
c        job     integer
c                = 11   both determinant and inverse.
c                = 01   inverse only.
c                = 10   determinant only.
c
c     on return
c
c        a       inverse of original matrix if requested.
c                otherwise unchanged.
c
c        det     double precision(2)
c                determinant of original matrix if requested.
c                otherwise not referenced.
c                determinant = det(1) * 10.0**det(2)
c                with  1.0 .le. dabs(det(1)) .lt. 10.0
c                or  det(1) .eq. 0.0 .
c
c     error condition
c
c        a division by zero will occur if the input factor contains
c        a zero on the diagonal and the inverse is requested.
c        it will not occur if the subroutines are called correctly
c        and if dgeco has set rcond .gt. 0.0 or dgefa has set
c        info .eq. 0 .
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,dswap
c     fortran dabs,mod
c
c     internal variables
c
      double precision t
      double precision ten
      integer i,j,k,kb,kp1,l,nm1
c
c
c     compute determinant
c
      if (job/10 .eq. 0) go to 70
         det(1) = 1.0d0
         det(2) = 0.0d0
         ten = 10.0d0
         do 50 i = 1, n
            if (ipvt(i) .ne. i) det(1) = -det(1)
            det(1) = a(i,i)*det(1)
c        ...exit
            if (det(1) .eq. 0.0d0) go to 60
   10       if (dabs(det(1)) .ge. 1.0d0) go to 20
               det(1) = ten*det(1)
               det(2) = det(2) - 1.0d0
            go to 10
   20       continue
   30       if (dabs(det(1)) .lt. ten) go to 40
               det(1) = det(1)/ten
               det(2) = det(2) + 1.0d0
            go to 30
   40       continue
   50    continue
   60    continue
   70 continue
c
c     compute inverse(u)
c
      if (mod(job,10) .eq. 0) go to 150
         do 100 k = 1, n
            a(k,k) = 1.0d0/a(k,k)
            t = -a(k,k)
            call dscal(k-1,t,a(1,k),1)
            kp1 = k + 1
            if (n .lt. kp1) go to 90
            do 80 j = kp1, n
               t = a(k,j)
               a(k,j) = 0.0d0
               call daxpy(k,t,a(1,k),1,a(1,j),1)
   80       continue
   90       continue
  100    continue
c
c        form inverse(u)*inverse(l)
c
         nm1 = n - 1
         if (nm1 .lt. 1) go to 140
         do 130 kb = 1, nm1
            k = n - kb
            kp1 = k + 1
            do 110 i = kp1, n
               work(i) = a(i,k)
               a(i,k) = 0.0d0
  110       continue
            do 120 j = kp1, n
               t = work(j)
               call daxpy(n,t,a(1,j),1,a(1,k),1)
  120       continue
            l = ipvt(k)
            if (l .ne. k) call dswap(n,a(1,k),1,a(1,l),1)
  130    continue
  140    continue
  150 continue
      return
      end


      PROGRAM xfourfs
C     driver for routine fourfs
      INTEGER NX,NY,NZ,NDAT
      PARAMETER (NX=8,NY=32,NZ=4,NDAT=2*NX*NY*NZ)
      INTEGER idum,i,j,k,l,kbf,nnv,idim(3),iunit(4)
      REAL diff,ran1,smax,sum,sum1,sum2,tot,data1(NDAT),data2(NDAT)
      COMPLEX cdata1(NX,NY,NZ),cdata2(NX,NY,NZ),ctdat(NZ,NY,NX)
      EQUIVALENCE (data1,cdata1,ctdat),(data2,cdata2)
      kbf=128
      nnv=3
      idim(1)=NX
      idim(2)=NY
      idim(3)=NZ
      tot=float(NX)*float(NY)*float(NZ)
      open (unit=10,form='unformatted',status='scratch')
      open (unit=11,form='unformatted',status='scratch')
      open (unit=12,form='unformatted',status='scratch')
      open (unit=13,form='unformatted',status='scratch')
      do 11 i=1,4
        iunit(i)=i+9
11    continue
      idum=-23
      do 14 i=1,idim(3)
        do 13 j=1,idim(2)
          do 12 k=1,idim(1)
            l=k+(j-1)*idim(1)+(i-1)*idim(2)*idim(1)
            l=2*l-1
            data1(l)=2.*ran1(idum)-1.
            data2(l)=data1(l)
            l=l+1
            data1(l)=2.*ran1(idum)-1.
            data2(l)=data1(l)
12        continue
13      continue
14    continue
      do 15 j=1,NDAT/2,kbf
        write(iunit(1)) (data1(j+i),i=0,kbf-1)
        write(iunit(2)) (data1(NDAT/2+j+i),i=0,kbf-1)
15    continue
      write(*,*) '**************** now doing fourfs ********'
      call fourfs(iunit,idim,nnv,1)
      do 16 j=1,NDAT/2,kbf
        read(iunit(3)) (data1(j+i),i=0,kbf-1)
        read(iunit(4)) (data1(NDAT/2+j+i),i=0,kbf-1)
16    continue
      write(*,*) '**************** now doing fourn *********'
      call fourn(data2,idim,nnv,1)
      sum=0.
      smax=0.
      sum2=0.
      do 19 i=1,NZ
        do 18 j=1,NY
          do 17 k=1,NX
            diff=abs(cdata2(k,j,i)-ctdat(i,j,k))
            sum2=sum2+real(ctdat(i,j,k))**2+aimag(ctdat(i,j,k))**2
            sum=sum+diff
            if (diff.gt.smax) smax=diff
17        continue
18      continue
19    continue
      sum2=sqrt(sum2/tot)
      sum=sum/tot
      write(*,'(1x,a,3f12.7)')
     *  '(r.m.s.) value, (max,ave) discrepancy=',sum2,smax,sum
      do 21 i=1,4
        rewind(unit=iunit(i))
21    continue
C     now check the inverse transforms
      idim(1)=NZ
      idim(2)=NY
      idim(3)=NX
      idum=iunit(1)
      iunit(1)=iunit(3)
      iunit(3)=idum
      idum=iunit(2)
      iunit(2)=iunit(4)
      iunit(4)=idum
      write(*,*) '**************** now doing fourfs ********'
      call fourfs(iunit,idim,nnv,-1)
      do 22 j=1,NDAT/2,kbf
        read(iunit(3)) (data1(j+i),i=0,kbf-1)
        read(iunit(4)) (data1(NDAT/2+j+i),i=0,kbf-1)
22    continue
      idim(1)=NX
      idim(2)=NY
      idim(3)=NZ
      write(*,*) '**************** now doing fourn *********'
      call fourn(data2,idim,nnv,-1)
      sum=0.
      smax=0.
      sum1=0.
      do 25 i=1,NZ
        do 24 j=1,NY
          do 23 k=1,NX
            sum1=sum1+real(cdata2(k,j,i))**2+aimag(cdata2(k,j,i))**2
            diff=abs(cdata2(k,j,i)-cdata1(k,j,i))
            sum=sum+diff
            if (diff.gt.smax) smax=diff
23        continue
24      continue
25    continue
      sum=sum/tot
      sum1=sqrt(sum1/tot)
      write(*,'(1x,a,3f12.7)')
     *  '(r.m.s.) value, (max,ave) discrepancy=',sum1,smax,sum
      write(*,*) 'ratio of r.m.s. values, expected ratio=',
     *  sum1/sum2,sqrt(tot)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xfourfs.for


program Knuth_Shuffle
  implicit none

  integer, parameter :: reps = 1000000
  integer :: i, n
  integer, dimension(10) :: a, bins = 0, initial = (/ (n, n=1,10) /)

  do i = 1, reps
    a = initial
 	call Shuffle(a)
    where (a == initial) bins = bins + 1  ! skew tester
  end do
  write(*, "(10(i8))") bins
! prints  100382  100007   99783  100231  100507   99921   99941  100270  100290  100442

contains

subroutine Shuffle(a)
  integer, intent(inout) :: a(:)
  integer :: i, randpos, temp
  real :: r

  do i = size(a), 2, -1
    call random_number(r)
    randpos = int(r * i) + 1
    temp = a(randpos)
    a(randpos) = a(i)
    a(i) = temp
  end do

end subroutine Shuffle

end program Knuth_Shuffle


!===============================================================================
program axial_average
!===============================================================================
!  Takes sets of constants from stdin and rotates them about one of the three
!  principle axes and sends to stdout.

   use anisotropy_ajn

   implicit none

   integer, parameter :: rs = 8
   real(rs) :: C(6,6), Cave(6,6)
   integer :: necs, iostat, axis, i,j
   character(len=250) :: arg
   integer :: nrot = 100

   ! Check and get arguments
   if (command_argument_count() /= 2 .and. command_argument_count() /= 3) call usage()
   ! Axis of rotation
   call get_command_argument(1,arg)
   read(arg,*,iostat=iostat) axis
   if (iostat /= 0) call usage()
   ! Number of ecs
   call get_command_argument(2,arg)
   read(arg,*,iostat=iostat) necs
   if (iostat /= 0) call usage()
   ! Optional: number of points to rotate about
   if (command_argument_count() == 3) then
      call get_command_argument(3,arg)
      read(arg,*,iostat=iostat) nrot
      if (iostat /= 0) call usage()
   endif

   iostat = 0
   do while (iostat == 0)
      ! Read from stdin
      if (necs == 21) then
         read(*,*,iostat=iostat) ((C(i,j),j=i,6),i=1,6)
         ! No need to symmetrise, as we're writing out the same number of constants
      else
         read(*,*,iostat=iostat) ((C(i,j),j=1,6),i=1,6)
      endif
      if (iostat < 0) exit ! EOF
      if (iostat > 0) then ! Bad read
         write(0,'(a,i0.0,a)') 'CIJ_axial_average: Problem reading ',necs,' constants from stdin'
         stop
      endif

      ! Rotate about desired axis
      call CIJ_axial_average(C,axis,Cave,nrot=nrot)

      ! Write out with same number of ecs
      if (necs == 21) then
         write(*,*) ((Cave(i,j),j=i,6),i=1,6)
      else
         write(*,*) ((Cave(i,j),j=1,6),i=1,6)
      endif
   enddo

   contains
      !=========================================================================
      subroutine usage
      !=========================================================================
         implicit none
         write(0,'(a)') 'Usage: CIJ_axial_average [rotation axis (1|2|3)] ' // &
         '[necs] (n rotations) < (ECs from stdin)', &
         'Options:', &
         '   (n rotations)  : Compute average with n different orientations about axis'
         stop
      end subroutine usage
      !------------------------------------------------------------------------
end program axial_average
!-------------------------------------------------------------------------------


program regressp

  use regression
  type (reg_type) :: var, varvec

  integer, parameter :: npoints = 100

  real, dimension(npoints) :: epsilon
  real :: x, y, a, b
  real, dimension (npoints) :: xv, yv

  call random_number (epsilon)

  do i=1,npoints
     x = real(i)
     y = 3.*real(i)+epsilon(i)
     call regress (var, x, y)
  end do

  y = yp (var, 10.)

  write (*,*) y

  write (*,*)
  write (*,*) 'And now with vectors...'

! now do it again with vectors

  call random_number (epsilon)

  do i=1,npoints
     xv(i) = real(i)
  end do

  yv = 3.*xv
  call regress (varvec, xv, yv)

  y = yp (var, 10.)

  write (*,*) y

end program regressp


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     PROGRAM TO ILLUSTRATE THE USE OF HSTSSP TO SOLVE POISSON"S
C     EQUATION
C
C             (1/SIN(THETA))(D/DTHETA)(SIN(THETA)*DU/DTHETA) +
C
C    (1/SIN(THETA)**2)(D/DPHI)(DU/DPHI) = 2 - 6*(SIN(THETA)*SIN(PHI))**2
C     ON THE NORTHERN HEMISPHERE SUBJECT TO EQUATORIAL SYMMETRY, I.E.
C     THE DERIVATIVE OF THE SOLUTION AT THETA = PI/2 IS ZERO.  A
C     5-DEGREE GRID IS TO BE USED.
C
C     THE EXACT SOLUTION IS NOT UNIQUE.  ANY FUNCTION OF THE FORM
C
C           U(THETA,PHI) = (SIN(THETA)*SIN(PHI))**2 + CONSTANT
C
C     IS A SOLUTION.
C
      DIMENSION       F(18,72)   ,BDB(72)    ,SINT(18)   ,SINP(72)   ,
     1                W(630)
C
C     THE VALUE OF IDIMF IS THE FIRST DIMENSION OF F. W IS DIMENSIONED
C     (13 + INT(LOG2(N)))*M + 4*N
C
      PI = PIMACH(DUM)
      A = 0.
      B = PI/2.
      M = 18
      MBDCND = 6
      C = 0.
      D = 2.*PI
      N = 72
      NBDCND = 0
      ELMBDA = 0.
      IDIMF = 18
C
C     GENERATE SINES FOR USE IN SUBSEQUENT COMPUTATIONS
C
      DTHETA = B/FLOAT(M)
      DO 101 I=1,M
         SINT(I) = SIN((FLOAT(I)-0.5)*DTHETA)
  101 CONTINUE
      DPHI = D/FLOAT(N)
      DO 102 J=1,N
         SINP(J) = SIN((FLOAT(J)-0.5)*DPHI)
  102 CONTINUE
C
C     COMPUTE RIGHT SIDE OF EQUATION AND STORE IN F
C
      DO 104 J=1,N
         DO 103 I=1,M
            F(I,J) = 2.-6.*(SINT(I)*SINP(J))**2
  103    CONTINUE
  104 CONTINUE
C
C     STORE DERIVATIVE DATA AT THE EQUATOR
C
      DO 105 J=1,N
         BDB(J) = 0.
  105 CONTINUE
C
C     BDA, BDC, AND BDD ARE DUMMY VARIABLES.
C
      CALL HSTSSP (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F,
     1             IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR. SINCE PROBLEM IS SINGULAR, THE
C     SOLUTION MUST BE NORMALIZED.
C
      ERR = 0.
      DO 107 J=1,N
         DO 106 I=1,M
            Z = ABS(F(I,J)-(SINT(I)*SINP(J))**2-F(1,1))
            IF (Z .GT. ERR) ERR = Z
  106    CONTINUE
  107 CONTINUE
C
      PRINT 1001 , IERROR,PERTRB,ERR,W(1)
      STOP
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE HSTSSP EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/32X,20HPERTRB = 6.35830E-04/
     3        18X,34HDISCRETIZATION ERROR = 3.37523E-03/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 540//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/32X,8HPERTRB =,E12.5/
     7        18X,22HDISCRETIZATION ERROR =,E12.5/
     8        12X,28HREQUIRED LENGTH OF W ARRAY =,F4.0)
C
      END


program test_solver
    use Utils
    use Types
    use le_solver
    use gausets
    integer NMAX
    PARAMETER        ( NMAX = 10000 )
    complex, dimension(NMAX,NMAX) :: RA, RB

	complex(DPT), dimension (:,:), allocatable :: A
	complex(DPT), dimension (:,:), allocatable :: B

	integer, dimension( 4 )  ::	ISEED

    CHARACTER(len=32) :: arg
    integer stat
    integer nn

    real all_time1, all_time2
    real time_init
    real time21, time22
    real    ::  T1,T2
    real    ::  dt1, dt2, dt3

    print *, 'Solve the complex equations A*X = B.'
    print *, 'and calc exec time'
    CALL getarg(1, arg)
    READ(arg,*,iostat=stat)N
    if (stat<0) then
       print *, "set default size"
       N = 4
    end if
    print *, "N=", N

    !allocate ( A(N, N) )
    !allocate ( B(N, 1) )

    all_time1 = sys_time()
    print *, 'Init matrix'
    ISEED = (/ 1, 2, 3, 4 /)
    call cpu_time(T1)
    call clarnv	(1, ISEED, NMAX*NMAX,	RA )
	call clarnv	(1, ISEED, NMAX,	RB )

    print *, RB(1:N, 1:1)
    !call clarnv	(1, ISEED, N*N,	A )
	!call clarnv	(1, ISEED, N,	B )

    call cpu_time(T2)
    dt1 = T2-T1
    print *, "init matrix time = ", dt1
    print *, "         n","   cpu time", "         sys time", "      cpu/sys time"

    do nn = 500, 5000, 500
        N = nn
        A = RA(1:N, 1:N)
        B = RB(1:N, 1:1)
        !print *, RB(1:N, 1:1)
        time_init = sys_time()
        call cpu_time(T1)

        call mkl_le_solver(A,B)
        !call gauset (A,B)

        call cpu_time(T2)
        time_matmul = sys_time() - time_init
        dt2 = T2-T1

        print *, nn, dt2,  time_matmul, dt2/time_matmul

       ! print *, RB(1:N, 1:1)
    end do
    all_time2 = sys_time()
    print *,"all time =", all_time2 - all_time1

end program test_solver


\ Test 2 for GUI
\ simple primarity test
\ Michel Jean, June 2019
\ Warning : disable case-insensivity

REQUIRE S>NUM ~nn/lib/s2num.f
REQUIRE WL-MODULES ~day\lib\includemodule.f
NEEDS ~day\wfl\wfl.f

101 CONSTANT nombreID

CDialog SUBCLASS CPswDialog

CString OBJ nombre

VARIABLE root
VARIABLE div
VARIABLE nbr

: root? ( n1 -- n2 ) \ calculate square root of the number
    2 16 0 DO 2DUP / + 2 / LOOP NIP 1 +
;

: test ( -- )
   BEGIN
   div @ 2 + div ! \ check odd number only
   nbr @ div @ MOD 0 = div @ root @ < NOT OR UNTIL
   div @ root @  < NOT IF S"  is prime " ELSE
   div @ . S"  is dividing by " THEN
;

: prime? ( -- )
   nombre @ STR@ S>NUM DUP nbr ! \ transform string in number

	DUP 0 = IF DROP S"  !!! Input a number > 0" ELSE
	DUP 1 = IF DROP S"  is not a prime" ELSE
	DUP 2 = IF DROP S"  is prime" ELSE
        DUP 2 MOD 0 = IF DROP S"  is dividing by 2 " ELSE   \ check if even
	1 div ! root? root ! test THEN THEN THEN THEN
;

C: IDOK ( code -- )
    nombreID SUPER getItemStrText nombre !
    DROP IDOK SUPER endDialog
;

: report ( -- addr u )

    <# prime? HOLDS
       nombre @ STR@ HOLDS 0. #>
    SUPER showMessage
;

;CLASS

0 0 102 66
WS_POPUP WS_SYSMENU OR WS_CAPTION OR DS_MODALFRAME OR
DS_SETFONT OR DS_CENTER OR

DIALOG: EntreeDialog Primarity test

      8 0 FONT MS Sans Serif
  nombreID 45  20 51 14 ES_NUMBER ( autorise only numbers ) EDITTEXT
     IDOK  5 45 40 14 0 PUSHBUTTON OK
 IDCANCEL 55 45 40 14 0 PUSHBUTTON Annuler
      104  6  7 37  8 0 LTEXT Enter

DIALOG;

CPswDialog NEW dialog

: bye S" Good Bye!" dialog showMessage ;

: windows ( -- )
    EntreeDialog 0 dialog showModal IDOK =
    IF
    dialog report
    ELSE bye -1
    THEN
;

windows

: run ( -- )
DO windows DUP -1 = IF LEAVE THEN LOOP 0 ;

run


	subroutine setpindx(n,p,w,nlev,plev)
	implicit none

c	.."pindx" a given array of pressure levels against a sorted list
c	of pressure referenc values.

c	  A "pindx" is defined as a value with its integer part for the
c	index to the reference array, and its decimal part for the log-
c	linear weight off the indexed reference array element.

c  Arguments
c ===========
	integer n	! size of p[], input
	real p(n)	! pressure levels to be "pindx"ed, input
	real w(n)	! "pindx" values for the levels, output

	integer nlev	! size of plev[], input
	real plev(nlev)	! reference pressure levels, input

c  Locals
c ========
	integer l,i

	l=0
	do i=1,n
	  call hunt(p(i),nlev,plev,l)
	  if(l.lt.1) then
	    w(i)=1.
	  elseif(l.ge.nlev) then
	    w(i)=nlev
	  else
	    w(i)=l+log(p(i)/plev(l))/log(plev(l+1)/plev(l))
	  endif
	end do

	end


! performs matrix-matrix multiply
! C=A*B
  subroutine mat_mul(nmatdim,A,B,C)

     use para, only : Dp
      implicit none

     integer,intent(in) :: nmatdim

     complex(Dp) :: ALPHA
     complex(Dp) :: BETA

     complex(Dp), intent(in)  :: A(nmatdim ,nmatdim)
     complex(Dp), intent(in)  :: B(nmatdim ,nmatdim)
     complex(Dp), intent(out) :: C(nmatdim,nmatdim)

     ALPHA=1.0d0
     BETA=0.0D0

     C(:,:)=(0.0d0,0.0d0)

     call ZGEMM('N','N',nmatdim,nmatdim,nmatdim,ALPHA, &
               &  A,nmatdim,B,nmatdim,BETA,C,nmatdim)

     return
  end subroutine mat_mul


program l5
    use pyplot_module, only : pyplot

    implicit none

    type(pyplot) :: plt

    ! Variables
    integer, parameter :: nx = 101, ny = 101, nt = 80, c = 1
    real(kind=8), parameter :: dx = real(2) / (nx -1 )
    real(kind=8), parameter :: dy = real(2) / (ny -1 )
    real(kind=8), parameter :: sigma = 0.2
    real(kind=8), parameter :: dt = sigma * dx
    real(kind=8), dimension(nx,ny) :: u, un, v, vn
    real(kind=8), dimension(nx) :: x
    real(kind=8), dimension(ny) :: y
    integer :: i, j, n, time, istat
    character :: input
    real(kind=8) :: plotX = 2, plotY = 2

10  format (i1)
15  format (f10.5,",")
20  format ("")

    !Generate values for y
    call spaceevenly(1, ny, plotY, y)
    !Generate values for x
    call spaceevenly(1, nx, plotX , x)

    ! Generate ones for entire array "u" "v" "vn" un"
    do i=1,nx
        do j=1, ny
            u(i,j) = 1
            un(i,j) = 1
            v(i,j) = 1
            vn(i,j) = 1
        end do
    end do

    ! Set boundary conditions for "u" "v"
    do i=1,nx
        do j=1, ny
            if (i >= 0.5 / dx  .and. i <= 1 / dx + 1 .and. &
                j >= 0.5 / dy .and. j <= 1 / dy + 1) then
                u(i,j) = 2
                v(i,j) = 2
            end if
        end do
    end do

    ! Print array
    do i=1, nx
        do j=1, ny
            write(*, 10, advance="no"), int(u(i,j))
        end do
        print*,""
    end do

    open(unit=1, file="l5.csv")

    ! Main loop
    do time = 1, nt + 1
        un = u
        vn = v

        do j=1, nx
            do i=1, ny
                !u(j,i) = (un(j,i) - (c * dt / dx * (un(j,i) - un(j,merge(1,i-1,i.eq.1)))) - &
                !    (c * dt / dy * (un(j,i) - un(merge(1,j-1,j.eq.1),i))));

                 u(j,i) = (un(j,i) - (un(j,i) * c * dt / dx * (un(j,i) - un(j,merge(1,i-1,i.eq.1)))) - &
                    vn(j,i) * c * dt / dy * (un(j,i) - un(merge(1,j-1,j.eq.1),i)))

                v(j,i) = (vn(j,i) - (un(j,i) * c * dt / dx * (vn(j,i) - vn(j,merge(1,i-1,i.eq.1)))) - &
                    vn(j,i) * c * dt / dy * (vn(j,i) - vn(merge(1,j-1,j.eq.1),i)))

                u(1,j) = 1;
                u(nx-1,j) = 1;
                u(i,1) = 1;
                u(i,ny-1) = 1;

                v(1,j) = 1;
                v(nx-1,j) = 1;
                v(i,1) = 1;
                v(i,ny-1) = 1;
            end do
        end do
    end do

    ! Write to csv
    do i=1, nx
        do j=1, ny
            write(unit=1, fmt=15, advance="no"), u(i,j)
        end do
        write(unit=1,fmt=20)
    end do

    print*, "File written"

    call plt%initialize(grid=.true.,&
                        title='Plot of u',legend=.false.,mplot3d=.true.,use_colormap=.true.)

    call plt%plot_surface(x,y,u,label='value of u', istat=istat, &
                            cmap="cm.cividis")

    call plt%savefig('l5.png', &
                      pyfile='l5.py', &
                      dpi='200',istat=istat)
    close(unit=1)
    read*, input

end program l5