module stafft

implicit none

! Fourier transform module.
! This is not a general purpose transform package but is designed to be
! quick for arrays of length 2^n. It will work if the array length is of
! the form 2^i * 3^j * 4^k * 5^l * 6^m (integer powers obviously).
!
! Minimal error-checking is performed by the code below. The only check is that
! the initial factorisation can be performed.
! Therefore if the transforms are called with an array of length <2, or a trig array
! not matching the length of the array to be transformed the code will fail in a
! spectacular way (eg. Seg. fault or nonsense returned).
! It is up to the calling code to ensure everything is called sensibly.
! The reason for stripping error checking is to speed up the backend by performing
! less if() evaluations - as errors in practice seem to occur very rarely.
! So the good news is this should be a fast library - the bad is that you may have to pick
! around in it if there are failures.
!
! To initialise the routines call init(n,factors,trig,ierr).
! This fills a factorisation array (factors), and a sin/cos array (trig).
! These must be kept in memory by the calling program.
! The init routine can be called multiple times with different arrays if more than
! one length of array is to be transformed.
! If a factorisation of the array length n cannot be found (as specified above)
! then the init routine will exit immediately and the integer ierr will be set to 1.
! If the init returns with ierr=0 then the call was successful.
!
! Top-level subroutines contained in this module are:
! 1) initfft(n,factors,trig)        :
!      Performs intialisation of the module, by working out the factors of n (the FFT length).
!      This will fail if n is not factorised completely by 2,3,4,5,6.
!      The trig array contains the necessary cosine and sine values.
!      Both arrays passed to init **must** be kept between calls to routines in this module.
! 2) forfft(m,n,x,trig,factors)  :
!      This performs a FFT of an array x containing m vectors of length n.
!      The transform length is n.
!      This inverse of this transform is obtained by revfft.
! 3) revfft(m,n,x,trig,factors)  :
!      This performs an inverse FFT of an array x containing m vectors of length n.
!      The transform length is n.
!      This inverse of this transform is forfft.
! 4) dct(m,n,x,trig,factors)     :
!      This performs a discrete cosine transform of an array x containing m vectors of length n.
!      The transform length is n.
!      This routine calls forfft and performs pre- and post- processing to obtain the transform.
!      This transform is it's own inverse.
! 5) dst(m,n,x,trig,factors)     :
!      This performs a discrete sine transform of an array x containing m vectors of length n.
!      The transform length is n.
!      This routine calls forfft and performs pre- and post- processing to obtain the transform.
!      This transform is it's own inverse.
!
! The storage of the transformed array is in 'Hermitian form'. This means that, for the jth vector
! the values x(j,1:nw) contain the cosine modes of the transform, while the values x(j,nw+1:n) contain
! the sine modes (in reverse order ie. wave number increasing from n back to nw+1).
! [Here, for even n, nw=n/2, and for odd n, nw=(n-1)/2].

contains
!----------------------------
subroutine initfft(n,factors,trig)

! Subroutine performs initialisation work for all the transforms.
! It calls routines to factorise the array length n and then sets up
! a trig array full of sin/cos values used in the transform backend.

implicit none

 !Argument declarations:
integer:: n,factors(5)
real*8:: trig(2*n)

!f2py intent(in)  :: n
!f2py intent(out) :: factors, trig

 !Local declarations:
double precision,parameter:: twopi=6.283185307179586476925286766559005768394338798750211641949889184615633d0
double precision:: ftwopin
integer:: i,j,k,l,m,fac(5),rem,ierr
!---------------------------------

 !First factorise n:
call factorisen(n,factors,ierr)

 !Return if factorisation unsuccessful:
if (ierr .eq. 1) then
   !Catastrophic end to run if factorisation fails:
  write(*,*) '****************************'
  write(*,*) ' Factorisation not possible.'
  write(*,*) ' Only factors from 2-6 allowed.'
  write(*,*) ' STOPPING...'
  write(*,*) '****************************'
  stop
endif

 !Define list of factors array:
fac(1)=6
fac(2)=4
fac(3)=2
fac(4)=3
fac(5)=5

 !Define constants needed in trig array definition:
ftwopin=twopi/dble(n)
rem=n
m=1
do i=1,5
  do j=1,factors(i)
    rem=rem/fac(i)
    do k=1,fac(i)-1
      do l=0,rem-1
        trig(m)=ftwopin*dble(k*l)
        m=m+1
      enddo
    enddo
    ftwopin=ftwopin*fac(i)
  enddo
enddo

do i=1,n-1
  trig(n+i)=-sin(trig(i))
  trig(i)  = cos(trig(i))
enddo

return
end subroutine
!============================================

subroutine factorisen(n,factors,ierr)

implicit none

 !Argument declarations:
integer:: n,factors(5),ierr
 !Local declarations:
integer:: i,rem

!f2py intent(in)  :: n
!f2py intent(out) :: factors, ierr
!--------------------------------

ierr=0
 !Initialiase factors array:
do i=1,5
  factors(i)=0
enddo

rem=n
 !Find factors of 6:
do while (mod(rem,6) .eq. 0)
  factors(1)=factors(1)+1
  rem=rem/6
  if (rem .eq. 1) return
enddo

 !Find factors of 4:
do while (mod(rem,4) .eq. 0)
  factors(2)=factors(2)+1
  rem=rem/4
  if (rem .eq. 1) return
enddo

 !Find factors of 2:
do while (mod(rem,2) .eq. 0)
  factors(3)=factors(3)+1
  rem=rem/2
  if (rem .eq. 1) return
enddo

 !Find factors of 3:
do while (mod(rem,3) .eq. 0)
  factors(4)=factors(4)+1
  rem=rem/3
  if (rem .eq. 1) return
enddo

 !Find factors of 5:
do while (mod(rem,5) .eq. 0)
  factors(5)=factors(5)+1
  rem=rem/5
  if (rem .eq. 1) return
enddo
 !If code reaches this point factorisation has
 !failed - return error code in ierr:
ierr=1

return
end subroutine
!============================================

subroutine forfft(m,n,x,trig,factors)

! Main physical to spectral (forward) FFT routine.
! Performs m transforms of length n in the array x which is dimensioned x(m,n).
! The arrays trig and factors are filled by the init routine and
! should be kept from call to call.
! Backend consists of mixed-radix routines, with 'decimation in time'.
! Transform is stored in Hermitian form.

implicit none

 !Arguments declarations:
double precision:: x(0:m*n-1),trig(0:2*n-1)
integer:: m,n,factors(5)

!f2py intent(in)      :: m, n, trig, factors
!f2py intent(in, out) :: x

 !Local declarations:
double precision:: wk(0:m*n-1),normfac
integer:: i,rem,cum,iloc
logical:: orig

!--------------------------------------
 !Initialise flip/flop logical and counters
orig=.true.
rem=n
cum=1
 !Use factors of 5:
do i=1,factors(5)
  rem=rem/5
  iloc=(rem-1)*5*cum
  if (orig) then
    call forrdx5(x,wk,m*rem,cum,trig(iloc),trig(n+iloc))
  else
    call forrdx5(wk,x,m*rem,cum,trig(iloc),trig(n+iloc))
  endif
  orig=.not. orig
  cum=cum*5
enddo
 !Use factors of 3:
do i=1,factors(4)
  rem=rem/3
  iloc=(rem-1)*3*cum
  if (orig) then
    call forrdx3(x,wk,m*rem,cum,trig(iloc),trig(n+iloc))
  else
    call forrdx3(wk,x,m*rem,cum,trig(iloc),trig(n+iloc))
  endif
  orig=.not. orig
  cum=cum*3
enddo
 !Use factors of 2:
do i=1,factors(3)
  rem=rem/2
  iloc=(rem-1)*2*cum
  if (orig) then
    call forrdx2(x,wk,m*rem,cum,trig(iloc),trig(n+iloc))
  else
    call forrdx2(wk,x,m*rem,cum,trig(iloc),trig(n+iloc))
  endif
  orig=.not. orig
  cum=cum*2
enddo
 !Use factors of 4:
do i=1,factors(2)
  rem=rem/4
  iloc=(rem-1)*4*cum
  if (orig) then
    call forrdx4(x,wk,m*rem,cum,trig(iloc),trig(n+iloc))
  else
    call forrdx4(wk,x,m*rem,cum,trig(iloc),trig(n+iloc))
  endif
  orig=.not. orig
  cum=cum*4
enddo
 !Use factors of 6:
do i=1,factors(1)
  rem=rem/6
  iloc=(rem-1)*6*cum
  if (orig) then
    call forrdx6(x,wk,m*rem,cum,trig(iloc),trig(n+iloc))
  else
    call forrdx6(wk,x,m*rem,cum,trig(iloc),trig(n+iloc))
  endif
  orig=.not. orig
  cum=cum*6
enddo

 !Multiply by the normalisation constant and put
 !transformed array in the right location:
normfac=1.0d0/sqrt(dble(n))
if (orig) then
  do i=0,m*n-1
    x(i)=x(i)*normfac
  enddo
else
  do i=0,m*n-1
    x(i)=wk(i)*normfac
  enddo
endif

return
end subroutine
!=====================================================

subroutine revfft(m,n,x,trig,factors)

! Main spectral to physical (reverse) FFT routine.
! Performs m reverse transforms of length n in the array x which is dimensioned x(m,n).
! The arrays trig and factors are filled by the init routine and
! should be kept from call to call.
! Backend consists of mixed-radix routines, with 'decimation in frequency'.
! Reverse transform starts in Hermitian form.

implicit none

 !Arguments declarations:
double precision:: x(0:m*n-1),trig(0:2*n-1)
integer:: m,n,factors(5)

!f2py intent(in)      :: m, n, trig, factors
!f2py intent(in, out) :: x

 !Local declarations:
double precision:: wk(0:m*n-1),normfac
integer:: i,k,cum,rem,iloc
logical:: orig

!----------------------------------------
 !Flip the sign of the sine coefficients:
do i=(n/2+1)*m,n*m-1
  x(i)=-x(i)
enddo

 !Scale 0 and Nyquist frequencies:
do i=0,m-1
  x(i)=0.5d0*x(i)
enddo
if (mod(n,2) .eq. 0) then
  k=m*n/2
  do i=0,m-1
    x(k+i)=0.5d0*x(k+i)
  enddo
endif

 !Initialise flip/flop logical and counters
orig=.true.
cum=1
rem=n
 !Use factors of 6:
do i=1,factors(1)
  rem=rem/6
  iloc=(cum-1)*6*rem
  if (orig) then
    call revrdx6(x,wk,m*cum,rem,trig(iloc),trig(n+iloc))
  else
    call revrdx6(wk,x,m*cum,rem,trig(iloc),trig(n+iloc))
  endif
  orig=.not. orig
  cum=cum*6
enddo
 !Use factors of 4:
do i=1,factors(2)
  rem=rem/4
  iloc=(cum-1)*4*rem
  if (orig) then
    call revrdx4(x,wk,m*cum,rem,trig(iloc),trig(n+iloc))
  else
    call revrdx4(wk,x,m*cum,rem,trig(iloc),trig(n+iloc))
  endif
  orig=.not. orig
  cum=cum*4
enddo
 !Use factors of 2:
do i=1,factors(3)
  rem=rem/2
  iloc=(cum-1)*2*rem
  if (orig) then
    call revrdx2(x,wk,m*cum,rem,trig(iloc),trig(n+iloc))
  else
    call revrdx2(wk,x,m*cum,rem,trig(iloc),trig(n+iloc))
  endif
  orig=.not. orig
  cum=cum*2
enddo
 !Use factors of 3:
do i=1,factors(4)
  rem=rem/3
  iloc=(cum-1)*3*rem
  if (orig) then
    call revrdx3(x,wk,m*cum,rem,trig(iloc),trig(n+iloc))
  else
    call revrdx3(wk,x,m*cum,rem,trig(iloc),trig(n+iloc))
  endif
  orig=.not. orig
  cum=cum*3
enddo
 !Use factors of 5:
do i=1,factors(5)
  rem=rem/5
  iloc=(cum-1)*5*rem
  if (orig) then
    call revrdx5(x,wk,m*cum,rem,trig(iloc),trig(n+iloc))
  else
    call revrdx5(wk,x,m*cum,rem,trig(iloc),trig(n+iloc))
  endif
  orig=.not. orig
  cum=cum*5
enddo

 !Multiply by the normalisation constant and put
 !transformed array in the right location:
normfac=2.0d0/sqrt(dble(n))
if (orig) then
  do i=0,m*n-1
    x(i)=x(i)*normfac
  enddo
else
  do i=0,m*n-1
    x(i)=wk(i)*normfac
  enddo
endif

return
end subroutine
!============================================

subroutine dct(m,n,x,trig,factors)

! This routine computes multiple fourier cosine transforms of sequences
! of doubles using the forfft routine to compute the FFT,
! along with pre- and post-processing steps to extract the dst.

implicit none

!Argument declarations:
integer:: m,n,factors(5)
double precision:: x(m,0:n),trig(2*n)

!f2py intent(in)      :: m, n, trig, factors
!f2py intent(in, out) :: x

!Local declarations:
double precision,parameter:: pi=3.141592653589793238462643383279502884197169399375105820974944592307816d0
double precision,parameter:: rt2=1.414213562373095048801688724209698078569671875376948073176679737990732d0
double precision:: wk(1:m,0:n-1),fpin,rtn,rowsum
integer:: i,j,nd2

!--------------------------------------------------
fpin=pi/dble(n)
rtn=sqrt(dble(n))

 !Pre-process the array and store it in wk:
do i=1,m
  wk(i,0)=0.5d0*(x(i,0)+x(i,n))
enddo

do j=1,n-1
  do i=1,m
    wk(i,j)=0.5d0*(x(i,j)+x(i,n-j))-sin(dble(j)*fpin)*(x(i,j)-x(i,n-j))
  enddo
enddo

 !Get the first element of the transform x(i,1) and store
 !in x(i,n), as this is not overwritten when x is used
 !as a work array in the forfft routine called next:
do i=1,m
  rowsum=0.0d0
  rowsum=rowsum+0.5d0*x(i,0)
  do j=1,n-1
    rowsum=rowsum+x(i,j)*cos(dble(j)*fpin)
  enddo
  rowsum=rowsum-0.5d0*x(i,n)
  x(i,n)=rt2*rowsum/rtn
enddo

 !Transform the wk array by use of the general FFT routine:
call forfft(m,n,wk,trig,factors)

 !Post-process the result of the FFT to get the dst of x and
 !put the result back into the x array:
do i=1,m
  x(i,0)=rt2*wk(i,0)
enddo
do i=1,m
  x(i,1)=x(i,n)
enddo

if (mod(n,2) .eq. 0) then
  nd2=n/2
  do j=1,nd2-1
    do i=1,m
      x(i,2*j)=rt2*wk(i,j)
      x(i,2*j+1)=x(i,2*j-1)-rt2*wk(i,n-j)
    enddo
  enddo
  do i=1,m
    x(i,n)=rt2*wk(i,nd2)
  enddo
else if (mod(n,2) .eq. 1) then
  do j=1,(n-1)/2
    do i=1,m
      x(i,2*j)=rt2*wk(i,j)
      x(i,2*j+1)=x(i,2*j-1)-rt2*wk(i,n-j)
    enddo
  enddo
endif

return
end subroutine
!=============================================================

subroutine dst(m,n,x,trig,factors)

! This routine computes multiple fourier sine transforms of sequences
! of doubles using the forfft routine to compute the FFT,
! along with pre- and post-processing steps to extract the dst.

implicit none

!Argument declarations:
integer:: m,n,factors(5)
double precision:: x(m,n),trig(2*n)

!f2py intent(in)      :: m, n, trig, factors
!f2py intent(in, out) :: x

!Local declarations:
double precision,parameter:: pi=3.141592653589793238462643383279502884197169399375105820974944592307816d0
double precision,parameter:: rt2=1.414213562373095048801688724209698078569671875376948073176679737990732d0
double precision:: wk(1:m,0:n-1),fpin
integer:: i,j

!------------------------------------------
fpin=pi/dble(n)

 !Pre-process the array and store it in wk:
 !First set 0 frequency element to zero:
do i=1,m
  wk(i,0)=0.0d0
enddo

 !Next set up the rest of the array:
do j=1,n-1
  do i=1,m
    wk(i,j)=0.5d0*(x(i,j)-x(i,n-j))+sin(dble(j)*fpin)*(x(i,j)+x(i,n-j))
  enddo
enddo

 !Transform the wk array by use of the general FFT routine:
call forfft(m,n,wk,trig,factors)

 !Post-process the result of the FFT to get the dst of x and
 !put the result back into the x array:
do i=1,m
  x(i,1)=wk(i,0)/rt2
enddo
if (mod(n,2) .eq. 0) then
  do j=1,n/2-1
    do i=1,m
      x(i,2*j)=-rt2*wk(i,n-j)
    enddo
    do i=1,m
      x(i,2*j+1)=rt2*wk(i,j)+x(i,2*j-1)
    enddo
  enddo
else if (mod(n,2) .eq. 1) then
  do j=1,(n-1)/2-1
    do i=1,m
      x(i,2*j)=-rt2*wk(i,n-j)
      x(i,2*j+1)=rt2*wk(i,j)+x(i,2*j-1)
    enddo
  enddo
  do i=1,m
    x(i,n-1)=-rt2*wk(i,(n+1)/2)
  enddo
endif

 !  Set the Nyquist frequency element to zero:
do i=1,m
  x(i,n)=0.0d0
enddo

return
end subroutine
!==================================================

!====================================================
!  Internal radix routines only beyond this point...
!  Abandon hope all ye who enter in!
!====================================================
! Physical to spectral (forward) routines:
!====================================================
subroutine forrdx6(a,b,nv,lv,cosine,sine)

! Radix six physical to Hermitian FFT with 'decimation in time'.

implicit none

 !Arguments declarations:
integer:: nv,lv
double precision:: a(0:nv-1,0:5,0:lv-1),b(0:nv-1,0:lv-1,0:5),cosine(0:lv-1,5),sine(0:lv-1,5)

 !Local declarations:
double precision,parameter:: sinfpi3=0.8660254037844386467637231707529361834714026269051903140279034897259665d0
double precision:: x1p,x2p,x3p,x4p,x5p
double precision:: y1p,y2p,y3p,y4p,y5p
double precision:: s1k,s2k,s3k,s4k,s5k
double precision:: c1k,c2k,c3k,c4k,c5k
double precision:: t1i,t1r,t2i,t2r,t3i,t3r
double precision:: u0i,u0r,u1i,u1r,u2i,u2r
double precision:: v0i,v0r,v1i,v1r,v2i,v2r
double precision:: q1,q2,q3,q4,q5,q6
integer:: i,k,kc,lvd2

!-----------------------------------------
 !Do k=0 first:
do i=0,nv-1
  t1r=a(i,2,0)+a(i,4,0)
  t2r=a(i,0,0)-0.5d0*t1r
  t3r=sinfpi3*(a(i,4,0)-a(i,2,0))
  u0r=a(i,0,0)+t1r
  t1i=a(i,5,0)+a(i,1,0)
  t2i=a(i,3,0)-0.5d0*t1i
  t3i=sinfpi3*(a(i,5,0)-a(i,1,0))
  v0r=a(i,3,0)+t1i
  b(i,0,0)=u0r+v0r
  b(i,0,1)=t2r-t2i
  b(i,0,2)=t2r+t2i
  b(i,0,3)=u0r-v0r
  b(i,0,4)=t3i-t3r
  b(i,0,5)=t3r+t3i
enddo
 !Next do remaining k:
if (nv .le. (lv-1)/2) then
  do i=0,nv-1
    do k=1,(lv-1)/2
      kc=lv-k
      x1p=cosine(k,1)*a(i,1, k)-sine(k,1)*a(i,1,kc)
      y1p=cosine(k,1)*a(i,1,kc)+sine(k,1)*a(i,1, k)
      x2p=cosine(k,2)*a(i,2, k)-sine(k,2)*a(i,2,kc)
      y2p=cosine(k,2)*a(i,2,kc)+sine(k,2)*a(i,2, k)
      x3p=cosine(k,3)*a(i,3, k)-sine(k,3)*a(i,3,kc)
      y3p=cosine(k,3)*a(i,3,kc)+sine(k,3)*a(i,3, k)
      x4p=cosine(k,4)*a(i,4, k)-sine(k,4)*a(i,4,kc)
      y4p=cosine(k,4)*a(i,4,kc)+sine(k,4)*a(i,4, k)
      x5p=cosine(k,5)*a(i,5, k)-sine(k,5)*a(i,5,kc)
      y5p=cosine(k,5)*a(i,5,kc)+sine(k,5)*a(i,5, k)
      t1r=x2p+x4p
      t1i=y2p+y4p
      t2r=a(i,0,k)-0.5d0*t1r
      t2i=a(i,0,kc)-0.5d0*t1i
      t3r=sinfpi3*(x2p-x4p)
      t3i=sinfpi3*(y2p-y4p)
      u0r=a(i,0,k)+t1r
      u0i=a(i,0,kc)+t1i
      u1r=t2r+t3i
      u1i=t2i-t3r
      u2r=t2r-t3i
      u2i=t2i+t3r
      t1r=x5p+x1p
      t1i=y5p+y1p
      t2r=x3p-0.5d0*t1r
      t2i=y3p-0.5d0*t1i
      t3r=sinfpi3*(x5p-x1p)
      t3i=sinfpi3*(y5p-y1p)
      v0r=x3p+t1r
      v0i=y3p+t1i
      v1r=t2r+t3i
      v1i=t3r-t2i
      v2r=t2r-t3i
      v2i=t2i+t3r
      b(i, k,0)=u0r+v0r
      b(i,kc,0)=u2r-v2r
      b(i, k,1)=u1r-v1r
      b(i,kc,1)=u1r+v1r
      b(i, k,2)=u2r+v2r
      b(i,kc,2)=u0r-v0r
      b(i, k,3)=v0i-u0i
      b(i,kc,3)=u2i+v2i
      b(i, k,4)=v1i-u1i
      b(i,kc,4)=u1i+v1i
      b(i, k,5)=v2i-u2i
      b(i,kc,5)=u0i+v0i
    enddo
  enddo
else
  do k=1,(lv-1)/2
    kc=lv-k
    c1k=cosine(k,1)
    s1k=sine(k,1)
    c2k=cosine(k,2)
    s2k=sine(k,2)
    c3k=cosine(k,3)
    s3k=sine(k,3)
    c4k=cosine(k,4)
    s4k=sine(k,4)
    c5k=cosine(k,5)
    s5k=sine(k,5)
    do i=0,nv-1
      x1p=c1k*a(i,1, k)-s1k*a(i,1,kc)
      y1p=c1k*a(i,1,kc)+s1k*a(i,1, k)
      x2p=c2k*a(i,2, k)-s2k*a(i,2,kc)
      y2p=c2k*a(i,2,kc)+s2k*a(i,2, k)
      x3p=c3k*a(i,3, k)-s3k*a(i,3,kc)
      y3p=c3k*a(i,3,kc)+s3k*a(i,3, k)
      x4p=c4k*a(i,4, k)-s4k*a(i,4,kc)
      y4p=c4k*a(i,4,kc)+s4k*a(i,4, k)
      x5p=c5k*a(i,5, k)-s5k*a(i,5,kc)
      y5p=c5k*a(i,5,kc)+s5k*a(i,5, k)
      t1r=x2p+x4p
      t1i=y2p+y4p
      t2r=a(i,0,k)-0.5d0*t1r
      t2i=a(i,0,kc)-0.5d0*t1i
      t3r=sinfpi3*(x2p-x4p)
      t3i=sinfpi3*(y2p-y4p)
      u0r=a(i,0,k)+t1r
      u0i=a(i,0,kc)+t1i
      u1r=t2r+t3i
      u1i=t2i-t3r
      u2r=t2r-t3i
      u2i=t2i+t3r
      t1r=x5p+x1p
      t1i=y5p+y1p
      t2r=x3p-0.5d0*t1r
      t2i=y3p-0.5d0*t1i
      t3r=sinfpi3*(x5p-x1p)
      t3i=sinfpi3*(y5p-y1p)
      v0r=x3p+t1r
      v0i=y3p+t1i
      v1r=t2r+t3i
      v1i=t3r-t2i
      v2r=t2r-t3i
      v2i=t2i+t3r
      b(i, k,0)=u0r+v0r
      b(i,kc,0)=u2r-v2r
      b(i, k,1)=u1r-v1r
      b(i,kc,1)=u1r+v1r
      b(i, k,2)=u2r+v2r
      b(i,kc,2)=u0r-v0r
      b(i, k,3)=v0i-u0i
      b(i,kc,3)=u2i+v2i
      b(i, k,4)=v1i-u1i
      b(i,kc,4)=u1i+v1i
      b(i, k,5)=v2i-u2i
      b(i,kc,5)=u0i+v0i
    enddo
  enddo
endif

 !Catch the case k=lv/2 when lv even:
if (mod(lv,2) .eq. 0) then
  lvd2=lv/2
  do i=0,nv-1
    q1=a(i,2,lvd2)-a(i,4,lvd2)
    q2=a(i,0,lvd2)+0.5d0*q1
    q3=sinfpi3*(a(i,2,lvd2)+a(i,4,lvd2))
    q4=a(i,1,lvd2)+a(i,5,lvd2)
    q5=-a(i,3,lvd2)-0.5d0*q4
    q6=sinfpi3*(a(i,1,lvd2)-a(i,5,lvd2))
    b(i,lvd2,0)=q2+q6
    b(i,lvd2,1)=a(i,0,lvd2)-q1
    b(i,lvd2,2)=q2-q6
    b(i,lvd2,3)=q5+q3
    b(i,lvd2,4)=a(i,3,lvd2)-q4
    b(i,lvd2,5)=q5-q3
  enddo
endif

return
end subroutine
!================================================
subroutine forrdx5(a,b,nv,lv,cosine,sine)

! Radix five physical to Hermitian FFT with 'decimation in time'.

implicit none

 !Arguments declarations:
integer:: nv,lv
double precision:: a(0:nv-1,0:4,0:lv-1),b(0:nv-1,0:lv-1,0:4),cosine(0:lv-1,1:4),sine(0:lv-1,1:4)
 !Local declarations:
double precision,parameter:: rtf516=0.5590169943749474241022934171828190588601545899028814310677243113526302d0
double precision,parameter:: sinf2pi5=0.9510565162951535721164393333793821434056986341257502224473056444301532d0
double precision,parameter:: sinfpi5=0.5877852522924731291687059546390727685976524376431459910722724807572785d0
double precision,parameter:: sinrat=0.6180339887498948482045868343656381177203091798057628621354486227052605d0
double precision:: x1p,x2p,x3p,x4p,y1p,y2p,y3p,y4p
double precision:: s1k,s2k,s3k,s4k,c1k,c2k,c3k,c4k
double precision:: t1i,t1r,t2i,t2r,t3i,t3r,t4i,t4r,t5i,t5r,t6i,t6r
double precision:: t7i,t7r,t8i,t8r,t9i,t9r,t10i,t10r,t11i,t11r
integer:: i,k,kc

!--------------------------------------------------
 !Do k=0 first:
do i=0,nv-1
  t1r=a(i,1,0)+a(i,4,0)
  t2r=a(i,2,0)+a(i,3,0)
  t3r=sinf2pi5*(a(i,4,0)-a(i,1,0))
  t4r=sinf2pi5*(a(i,2,0)-a(i,3,0))
  t5r=t1r+t2r
  t6r=rtf516*(t1r-t2r)
  t7r=a(i,0,0)-0.25d0*t5r
  b(i,0,0)=a(i,0,0)+t5r
  b(i,0,1)=t7r+t6r
  b(i,0,2)=t7r-t6r
  b(i,0,3)=t4r+sinrat*t3r
  b(i,0,4)=t3r-sinrat*t4r
enddo
 !Next do remaining k:
if (nv .le. (lv-1)/2) then
  do i=0,nv-1
    do k=1,(lv-1)/2
      kc=lv-k
      x1p=cosine(k,1)*a(i,1, k)-sine(k,1)*a(i,1,kc)
      y1p=cosine(k,1)*a(i,1,kc)+sine(k,1)*a(i,1, k)
      x2p=cosine(k,2)*a(i,2, k)-sine(k,2)*a(i,2,kc)
      y2p=cosine(k,2)*a(i,2,kc)+sine(k,2)*a(i,2, k)
      x3p=cosine(k,3)*a(i,3, k)-sine(k,3)*a(i,3,kc)
      y3p=cosine(k,3)*a(i,3,kc)+sine(k,3)*a(i,3, k)
      x4p=cosine(k,4)*a(i,4, k)-sine(k,4)*a(i,4,kc)
      y4p=cosine(k,4)*a(i,4,kc)+sine(k,4)*a(i,4, k)
      t1r=x1p+x4p
      t1i=y1p+y4p
      t2r=x2p+x3p
      t2i=y2p+y3p
      t3r=sinf2pi5*(x1p-x4p)
      t3i=sinf2pi5*(y1p-y4p)
      t4r=sinf2pi5*(x2p-x3p)
      t4i=sinf2pi5*(y2p-y3p)
      t5r=t1r+t2r
      t5i=t1i+t2i
      t6r=rtf516*(t1r-t2r)
      t6i=rtf516*(t1i-t2i)
      t7r=a(i,0,k)-0.25d0*t5r
      t7i=a(i,0,kc)-0.25d0*t5i
      t8r=t7r+t6r
      t8i=t7i+t6i
      t9r=t7r-t6r
      t9i=t7i-t6i
      t10r=t3r+sinrat*t4r
      t10i=t3i+sinrat*t4i
      t11r=t4r-sinrat*t3r
      t11i=sinrat*t3i-t4i
      b(i, k,0)=a(i,0,k)+t5r
      b(i,kc,0)=t8r-t10i
      b(i, k,1)=t8r+t10i
      b(i,kc,1)=t9r-t11i
      b(i, k,2)=t9r+t11i
      b(i,kc,2)=t9i+t11r
      b(i, k,3)=t11r-t9i
      b(i,kc,3)=t8i-t10r
      b(i, k,4)=-t8i-t10r
      b(i,kc,4)=a(i,0,kc)+t5i
    enddo
  enddo
else
  do k=1,(lv-1)/2
    kc=lv-k
    c1k=cosine(k,1)
    s1k=sine(k,1)
    c2k=cosine(k,2)
    s2k=sine(k,2)
    c3k=cosine(k,3)
    s3k=sine(k,3)
    c4k=cosine(k,4)
    s4k=sine(k,4)
    do i=0,nv-1
      x1p=c1k*a(i,1, k)-s1k*a(i,1,kc)
      y1p=c1k*a(i,1,kc)+s1k*a(i,1, k)
      x2p=c2k*a(i,2, k)-s2k*a(i,2,kc)
      y2p=c2k*a(i,2,kc)+s2k*a(i,2, k)
      x3p=c3k*a(i,3, k)-s3k*a(i,3,kc)
      y3p=c3k*a(i,3,kc)+s3k*a(i,3, k)
      x4p=c4k*a(i,4, k)-s4k*a(i,4,kc)
      y4p=c4k*a(i,4,kc)+s4k*a(i,4, k)
      t1r=x1p+x4p
      t1i=y1p+y4p
      t2r=x2p+x3p
      t2i=y2p+y3p
      t3r=sinf2pi5*(x1p-x4p)
      t3i=sinf2pi5*(y1p-y4p)
      t4r=sinf2pi5*(x2p-x3p)
      t4i=sinf2pi5*(y2p-y3p)
      t5r=t1r+t2r
      t5i=t1i+t2i
      t6r=rtf516*(t1r-t2r)
      t6i=rtf516*(t1i-t2i)
      t7r=a(i,0,k)-0.25d0*t5r
      t7i=a(i,0,kc)-0.25d0*t5i
      t8r=t7r+t6r
      t8i=t7i+t6i
      t9r=t7r-t6r
      t9i=t7i-t6i
      t10r=t3r+sinrat*t4r
      t10i=t3i+sinrat*t4i
      t11r=t4r-sinrat*t3r
      t11i=sinrat*t3i-t4i
      b(i, k,0)=a(i,0,k)+t5r
      b(i,kc,0)=t8r-t10i
      b(i, k,1)=t8r+t10i
      b(i,kc,1)=t9r-t11i
      b(i, k,2)=t9r+t11i
      b(i,kc,2)=t9i+t11r
      b(i, k,3)=t11r-t9i
      b(i,kc,3)=t8i-t10r
      b(i, k,4)=-t8i-t10r
      b(i,kc,4)=a(i,0,kc)+t5i
    enddo
  enddo
endif

return
end subroutine
!===========================================
subroutine forrdx4(a,b,nv,lv,cosine,sine)

! Radix four physical to Hermitian FFT with 'decimation in time'.

implicit none

 !Arguments declarations:
integer:: nv,lv
double precision:: a(0:nv-1,0:3,0:lv-1),b(0:nv-1,0:lv-1,0:3),cosine(0:lv-1,1:3),sine(0:lv-1,1:3)

 !Local declarations:
double precision,parameter:: rtf12=0.7071067811865475244008443621048490392848359376884740365883398689953662d0
double precision:: x1p,x2p,x3p,y1p,y2p,y3p
double precision:: s1k,s2k,s3k,c1k,c2k,c3k
double precision:: t1i,t1r,t2i,t2r,t3i,t3r,t4i,t4r
double precision:: q1,q2
integer:: i,k,kc,lvd2

!-----------------------------------------------
 !Do k=0 first:
do i=0,nv-1
  t1r=a(i,0,0)+a(i,2,0)
  t2r=a(i,1,0)+a(i,3,0)
  b(i,0,0)=t1r+t2r
  b(i,0,1)=a(i,0,0)-a(i,2,0)
  b(i,0,2)=t1r-t2r
  b(i,0,3)=a(i,3,0)-a(i,1,0)
enddo
 !Next do remaining k:
if (nv .lt. (lv-1)/2) then
  do i=0,nv-1
    do k=1,(lv-1)/2
      kc=lv-k
      x1p=cosine(k,1)*a(i,1, k)-sine(k,1)*a(i,1,kc)
      y1p=cosine(k,1)*a(i,1,kc)+sine(k,1)*a(i,1, k)
      x2p=cosine(k,2)*a(i,2, k)-sine(k,2)*a(i,2,kc)
      y2p=cosine(k,2)*a(i,2,kc)+sine(k,2)*a(i,2, k)
      x3p=cosine(k,3)*a(i,3, k)-sine(k,3)*a(i,3,kc)
      y3p=cosine(k,3)*a(i,3,kc)+sine(k,3)*a(i,3, k)
      t1r=a(i,0,k)+x2p
      t1i=a(i,0,kc)+y2p
      t2r=x1p+x3p
      t2i=y1p+y3p
      t3r=a(i,0,k)-x2p
      t3i=a(i,0,kc)-y2p
      t4r=x3p-x1p
      t4i=y1p-y3p
      b(i, k,0)=t1r+t2r
      b(i,kc,0)=t3r-t4i
      b(i, k,1)=t3r+t4i
      b(i,kc,1)=t1r-t2r
      b(i, k,2)=t2i-t1i
      b(i,kc,2)=t3i+t4r
      b(i, k,3)=t4r-t3i
      b(i,kc,3)=t1i+t2i
    enddo
  enddo
else
  do k=1,(lv-1)/2
    kc=lv-k
    c1k=cosine(k,1)
    s1k=sine(k,1)
    c2k=cosine(k,2)
    s2k=sine(k,2)
    c3k=cosine(k,3)
    s3k=sine(k,3)
    do i=0,nv-1
      x1p=c1k*a(i,1, k)-s1k*a(i,1,kc)
      y1p=c1k*a(i,1,kc)+s1k*a(i,1, k)
      x2p=c2k*a(i,2, k)-s2k*a(i,2,kc)
      y2p=c2k*a(i,2,kc)+s2k*a(i,2, k)
      x3p=c3k*a(i,3, k)-s3k*a(i,3,kc)
      y3p=c3k*a(i,3,kc)+s3k*a(i,3, k)
      t1r=a(i,0,k)+x2p
      t1i=a(i,0,kc)+y2p
      t2r=x1p+x3p
      t2i=y1p+y3p
      t3r=a(i,0,k)-x2p
      t3i=a(i,0,kc)-y2p
      t4r=x3p-x1p
      t4i=y1p-y3p
      b(i, k,0)=t1r+t2r
      b(i,kc,0)=t3r-t4i
      b(i, k,1)=t3r+t4i
      b(i,kc,1)=t1r-t2r
      b(i, k,2)=t2i-t1i
      b(i,kc,2)=t3i+t4r
      b(i, k,3)=t4r-t3i
      b(i,kc,3)=t1i+t2i
    enddo
  enddo
endif

 !Catch the case k=lv/2 when lv even:
if (mod(lv,2) .eq. 0) then
  lvd2=lv/2
  do i=0,nv-1
    q1=rtf12*(a(i,1,lvd2)-a(i,3,lvd2))
    q2=rtf12*(a(i,1,lvd2)+a(i,3,lvd2))
    b(i,lvd2,0)=a(i,0,lvd2)+q1
    b(i,lvd2,1)=a(i,0,lvd2)-q1
    b(i,lvd2,2)=a(i,2,lvd2)-q2
    b(i,lvd2,3)=-a(i,2,lvd2)-q2
  enddo
endif

return
end subroutine
!================================================

subroutine forrdx3(a,b,nv,lv,cosine,sine)

! Radix three physical to Hermitian FFT with 'decimation in time'.

implicit none

 !Arguments declarations:
integer:: nv,lv
double precision:: a(0:nv-1,0:2,0:lv-1),b(0:nv-1,0:lv-1,0:2),cosine(0:lv-1,1:2),sine(0:lv-1,1:2)

 !Local declarations:
double precision,parameter:: sinfpi3=0.8660254037844386467637231707529361834714026269051903140279034897259665d0
double precision:: x1p,x2p,y1p,y2p
double precision:: s1k,s2k,c1k,c2k
double precision:: t1i,t1r,t2i,t2r,t3i,t3r
integer:: i,k,kc

!---------------------------------------------
 !Do k=0 first:
do i=0,nv-1
  t1r=a(i,1,0)+a(i,2,0)
  b(i,0,0)=a(i,0,0)+t1r
  b(i,0,1)=a(i,0,0)-0.5d0*t1r
  b(i,0,2)=sinfpi3*(a(i,2,0)-a(i,1,0))
enddo
 !Next do remaining k:
if (nv .le. (lv-1)/2) then
  do i=0,nv-1
    do k=1,(lv-1)/2
      kc=lv-k
      x1p=cosine(k,1)*a(i,1, k)-sine(k,1)*a(i,1,kc)
      y1p=cosine(k,1)*a(i,1,kc)+sine(k,1)*a(i,1, k)
      x2p=cosine(k,2)*a(i,2, k)-sine(k,2)*a(i,2,kc)
      y2p=cosine(k,2)*a(i,2,kc)+sine(k,2)*a(i,2, k)
      t1r=x1p+x2p
      t1i=y1p+y2p
      t2r=a(i,0, k)-0.5d0*t1r
      t2i=0.5d0*t1i-a(i,0,kc)
      t3r=sinfpi3*(x2p-x1p)
      t3i=sinfpi3*(y1p-y2p)
      b(i, k,0)=a(i,0, k)+t1r
      b(i,kc,0)=t2r-t3i
      b(i, k,1)=t2r+t3i
      b(i,kc,1)=t3r-t2i
      b(i, k,2)=t2i+t3r
      b(i,kc,2)=a(i,0,kc)+t1i
    enddo
  enddo
else
  do k=1,(lv-1)/2
    kc=lv-k
    c1k=cosine(k,1)
    s1k=sine(k,1)
    c2k=cosine(k,2)
    s2k=sine(k,2)
    do i=0,nv-1
      x1p=c1k*a(i,1, k)-s1k*a(i,1,kc)
      y1p=c1k*a(i,1,kc)+s1k*a(i,1, k)
      x2p=c2k*a(i,2, k)-s2k*a(i,2,kc)
      y2p=c2k*a(i,2,kc)+s2k*a(i,2, k)
      t1r=x1p+x2p
      t1i=y1p+y2p
      t2r=a(i,0, k)-0.5d0*t1r
      t2i=0.5d0*t1i-a(i,0,kc)
      t3r=sinfpi3*(x2p-x1p)
      t3i=sinfpi3*(y1p-y2p)
      b(i, k,0)=a(i,0, k)+t1r
      b(i,kc,0)=t2r-t3i
      b(i, k,1)=t2r+t3i
      b(i,kc,1)=t3r-t2i
      b(i, k,2)=t2i+t3r
      b(i,kc,2)=a(i,0,kc)+t1i
    enddo
  enddo
endif

return
end subroutine
!========================================

subroutine forrdx2(a,b,nv,lv,cosine,sine)

! Radix two physical to Hermitian FFT with 'decimation in time'.

implicit none

 !Arguments declarations:
integer:: nv,lv
double precision:: a(0:nv-1,0:1,0:lv-1),b(0:nv-1,0:lv-1,0:1),cosine(0:lv-1),sine(0:lv-1)

 !Local declarations:
double precision:: x1,y1,c1k,s1k
integer:: i,k,kc

!-----------------------------------------
 !Do k=0 first:
do i=0,nv-1
  b(i,0,0)=a(i,0,0)+a(i,1,0)
  b(i,0,1)=a(i,0,0)-a(i,1,0)
enddo
 !Next do remaining k:
if (nv .lt. (lv-1)/2) then
  do i=0,nv-1
    do k=1,(lv-1)/2
      kc=lv-k
      x1=cosine(k)*a(i,1, k)-sine(k)*a(i,1,kc)
      y1=cosine(k)*a(i,1,kc)+sine(k)*a(i,1, k)
      b(i, k,0)=a(i,0, k)+x1
      b(i,kc,0)=a(i,0, k)-x1
      b(i, k,1)=y1-a(i,0,kc)
      b(i,kc,1)=a(i,0,kc)+y1
    enddo
  enddo
else
  do k=1,(lv-1)/2
    kc=lv-k
    c1k=cosine(k)
    s1k=sine(k)
    do i=0,nv-1
      x1=c1k*a(i,1, k)-s1k*a(i,1,kc)
      y1=c1k*a(i,1,kc)+s1k*a(i,1, k)
      b(i, k,0)=a(i,0, k)+x1
      b(i,kc,0)=a(i,0, k)-x1
      b(i, k,1)=y1-a(i,0,kc)
      b(i,kc,1)=a(i,0,kc)+y1
    enddo
  enddo
endif

return
end subroutine
!======================================

!====================================================
! Spectral to physical (reverse) routines:
!====================================================
subroutine revrdx6(a,b,nv,lv,cosine,sine)

!Radix six Hermitian to physical FFT with 'decimation in frequency'.

implicit none

 !Arguments declarations:
integer:: nv,lv
double precision:: a(0:nv-1,0:lv-1,0:5),b(0:nv-1,0:5,0:lv-1),cosine(0:lv-1,1:5),sine(0:lv-1,1:5)

 !Local declarations:
double precision,parameter:: sinfpi3=0.8660254037844386467637231707529361834714026269051903140279034897259665d0
double precision:: x1p,x2p,x3p,x4p,x5p
double precision:: y1p,y2p,y3p,y4p,y5p
double precision:: s1k,s2k,s3k,s4k,s5k
double precision:: c1k,c2k,c3k,c4k,c5k
double precision:: t1i,t1r,t2i,t2r,t3i,t3r
double precision:: u0i,u0r,u1i,u1r,u2i,u2r
double precision:: v0i,v0r,v1i,v1r,v2i,v2r
double precision:: q1,q2,q3,q4,q5,q6
integer:: i,k,kc,lvd2

!-----------------------------------------
 !Do k=0 first:
do i=0,nv-1
  t2r=a(i,0,0)-0.5d0*a(i,0,2)
  t3r=sinfpi3*a(i,0,4)
  u0r=a(i,0,0)+a(i,0,2)
  u1r=t2r+t3r
  u2r=t2r-t3r
  t2i=a(i,0,3)-0.5d0*a(i,0,1)
  t3i=-sinfpi3*a(i,0,5)
  v0r=a(i,0,3)+a(i,0,1)
  v1r=t2i+t3i
  v2r=t2i-t3i
  b(i,0,0)=u0r+v0r
  b(i,1,0)=u1r-v1r
  b(i,2,0)=u2r+v2r
  b(i,3,0)=u0r-v0r
  b(i,4,0)=u1r+v1r
  b(i,5,0)=u2r-v2r
enddo
 !Next do remaining k:
if (nv .le. (lv-1)/2) then
  do i=0,nv-1
    do k=1,(lv-1)/2
      kc=lv-k
      t1r=a(i, k,2)+a(i,kc,1)
      t1i=a(i,kc,3)-a(i, k,4)
      t2r=a(i, k,0)-0.5d0*t1r
      t2i=a(i,kc,5)-0.5d0*t1i
      t3r=sinfpi3*(a(i, k,2)-a(i,kc,1))
      t3i=sinfpi3*(a(i,kc,3)+a(i, k,4))
      u0r=a(i, k,0)+t1r
      u0i=a(i,kc,5)+t1i
      u1r=t2r+t3i
      u1i=t2i-t3r
      u2r=t2r-t3i
      u2i=t2i+t3r
      t1r=a(i,kc,0)+a(i,k,1)
      t1i=a(i,kc,4)-a(i,k,5)
      t2r=a(i,kc,2)-0.5d0*t1r
      t2i=-a(i,k,3)-0.5d0*t1i
      t3r=sinfpi3*(a(i,kc,0)-a(i, k,1))
      t3i=sinfpi3*(-a(i,k,5)-a(i,kc,4))
      v0r=a(i,kc,2)+t1r
      v0i=t1i-a(i,k,3)
      v1r=t2r+t3i
      v1i=t2i-t3r
      v2r=t2r-t3i
      v2i=t2i+t3r
      x1p=u1r-v1r
      y1p=u1i-v1i
      x2p=u2r+v2r
      y2p=u2i+v2i
      x3p=u0r-v0r
      y3p=u0i-v0i
      x4p=u1r+v1r
      y4p=u1i+v1i
      x5p=u2r-v2r
      y5p=u2i-v2i
      b(i,0, k)=u0r+v0r
      b(i,0,kc)=u0i+v0i
      b(i,1, k)=cosine(k,1)*x1p-sine(k,1)*y1p
      b(i,1,kc)=cosine(k,1)*y1p+sine(k,1)*x1p
      b(i,2, k)=cosine(k,2)*x2p-sine(k,2)*y2p
      b(i,2,kc)=cosine(k,2)*y2p+sine(k,2)*x2p
      b(i,3, k)=cosine(k,3)*x3p-sine(k,3)*y3p
      b(i,3,kc)=cosine(k,3)*y3p+sine(k,3)*x3p
      b(i,4, k)=cosine(k,4)*x4p-sine(k,4)*y4p
      b(i,4,kc)=cosine(k,4)*y4p+sine(k,4)*x4p
      b(i,5, k)=cosine(k,5)*x5p-sine(k,5)*y5p
      b(i,5,kc)=cosine(k,5)*y5p+sine(k,5)*x5p
    enddo
  enddo
else
  do k=1,(lv-1)/2
    kc=lv-k
    c1k=cosine(k,1)
    s1k=sine(k,1)
    c2k=cosine(k,2)
    s2k=sine(k,2)
    c3k=cosine(k,3)
    s3k=sine(k,3)
    c4k=cosine(k,4)
    s4k=sine(k,4)
    c5k=cosine(k,5)
    s5k=sine(k,5)
    do i=0,nv-1
      t1r=a(i, k,2)+a(i,kc,1)
      t1i=a(i,kc,3)-a(i, k,4)
      t2r=a(i, k,0)-0.5d0*t1r
      t2i=a(i,kc,5)-0.5d0*t1i
      t3r=sinfpi3*(a(i, k,2)-a(i,kc,1))
      t3i=sinfpi3*(a(i,kc,3)+a(i, k,4))
      u0r=a(i, k,0)+t1r
      u0i=a(i,kc,5)+t1i
      u1r=t2r+t3i
      u1i=t2i-t3r
      u2r=t2r-t3i
      u2i=t2i+t3r
      t1r=a(i,kc,0)+a(i,k,1)
      t1i=a(i,kc,4)-a(i,k,5)
      t2r=a(i,kc,2)-0.5d0*t1r
      t2i=-a(i,k,3)-0.5d0*t1i
      t3r=sinfpi3*(a(i,kc,0)-a(i, k,1))
      t3i=sinfpi3*(-a(i,k,5)-a(i,kc,4))
      v0r=a(i,kc,2)+t1r
      v0i=t1i-a(i,k,3)
      v1r=t2r+t3i
      v1i=t2i-t3r
      v2r=t2r-t3i
      v2i=t2i+t3r
      x1p=u1r-v1r
      y1p=u1i-v1i
      x2p=u2r+v2r
      y2p=u2i+v2i
      x3p=u0r-v0r
      y3p=u0i-v0i
      x4p=u1r+v1r
      y4p=u1i+v1i
      x5p=u2r-v2r
      y5p=u2i-v2i
      b(i,0, k)=u0r+v0r
      b(i,0,kc)=u0i+v0i
      b(i,1, k)=c1k*x1p-s1k*y1p
      b(i,1,kc)=c1k*y1p+s1k*x1p
      b(i,2, k)=c2k*x2p-s2k*y2p
      b(i,2,kc)=c2k*y2p+s2k*x2p
      b(i,3, k)=c3k*x3p-s3k*y3p
      b(i,3,kc)=c3k*y3p+s3k*x3p
      b(i,4, k)=c4k*x4p-s4k*y4p
      b(i,4,kc)=c4k*y4p+s4k*x4p
      b(i,5, k)=c5k*x5p-s5k*y5p
      b(i,5,kc)=c5k*y5p+s5k*x5p
    enddo
  enddo
endif

 !Catch the case k=lv/2 when lv even:
if (mod(lv,2) .eq. 0) then
  lvd2=lv/2
  do i=0,nv-1
    q1=a(i,lvd2,0)+a(i,lvd2,2)
    q2=a(i,lvd2,5)+a(i,lvd2,3)
    q3=a(i,lvd2,1)-0.5d0*q1
    q4=a(i,lvd2,4)+0.5d0*q2
    q5=sinfpi3*(a(i,lvd2,0)-a(i,lvd2,2))
    q6=sinfpi3*(a(i,lvd2,5)-a(i,lvd2,3))
    b(i,0,lvd2)=a(i,lvd2,1)+q1
    b(i,1,lvd2)=q4+q5
    b(i,2,lvd2)=q6-q3
    b(i,3,lvd2)=q2-a(i,lvd2,4)
    b(i,4,lvd2)=q3+q6
    b(i,5,lvd2)=q4-q5
  enddo
endif

return
end subroutine
!=======================================

subroutine revrdx5(a,b,nv,lv,cosine,sine)

! Radix five Hermitian to physical FFT with 'decimation in frequency'.

implicit none

 !Arguments declarations:
integer:: nv,lv
double precision:: a(0:nv-1,0:lv-1,0:4),b(0:nv-1,0:4,0:lv-1),cosine(0:lv-1,1:4),sine(0:lv-1,1:4)
 !Local declarations:
double precision,parameter:: rtf516=0.5590169943749474241022934171828190588601545899028814310677243113526302d0
double precision,parameter:: sinf2pi5=0.9510565162951535721164393333793821434056986341257502224473056444301532d0
double precision,parameter:: sinfpi5=0.5877852522924731291687059546390727685976524376431459910722724807572785d0
double precision,parameter:: sinrat=0.6180339887498948482045868343656381177203091798057628621354486227052605d0
double precision:: x1p,x2p,x3p,x4p,y1p,y2p,y3p,y4p
double precision:: s1k,s2k,s3k,s4k,c1k,c2k,c3k,c4k
double precision:: t1i,t1r,t2i,t2r,t3i,t3r,t4i,t4r,t5i,t5r,t6i,t6r
double precision:: t7i,t7r,t8i,t8r,t9i,t9r,t10i,t10r,t11i,t11r
integer:: i,k,kc

!----------------------------------------------------
 !Do k=0 first:
do i=0,nv-1
  t3r=sinf2pi5*a(i,0,4)
  t4r=sinf2pi5*a(i,0,3)
  t5r=a(i,0,1)+a(i,0,2)
  t6r=rtf516*(a(i,0,1)-a(i,0,2))
  t7r=a(i,0,0)-0.25d0*t5r
  t8r=t7r+t6r
  t9r=t7r-t6r
  t10r=t3r+sinrat*t4r
  t11r=sinrat*t3r-t4r
  b(i,0,0)=a(i,0,0)+t5r
  b(i,1,0)=t8r+t10r
  b(i,2,0)=t9r+t11r
  b(i,3,0)=t9r-t11r
  b(i,4,0)=t8r-t10r
enddo
 !Next do remaining k:
if (nv .le. (lv-1)/2) then
  do i=0,nv-1
    do k=1,(lv-1)/2
      kc=lv-k
      t1r=a(i, k,1)+a(i,kc,0)
      t1i=a(i,kc,3)-a(i, k,4)
      t2r=a(i, k,2)+a(i,kc,1)
      t2i=a(i,kc,2)-a(i, k,3)
      t3r=sinf2pi5*(a(i, k,1)-a(i,kc,0))
      t3i=sinf2pi5*(a(i,kc,3)+a(i, k,4))
      t4r=sinf2pi5*(a(i, k,2)-a(i,kc,1))
      t4i=sinf2pi5*(a(i,kc,2)+a(i, k,3))
      t5r=t1r+t2r
      t5i=t1i+t2i
      t6r=rtf516*(t1r-t2r)
      t6i=rtf516*(t1i-t2i)
      t7r=a(i,k,0)-0.25d0*t5r
      t7i=a(i,kc,4)-0.25d0*t5i
      t8r=t7r+t6r
      t8i=t7i+t6i
      t9r=t7r-t6r
      t9i=t7i-t6i
      t10r=t3r+sinrat*t4r
      t10i=t3i+sinrat*t4i
      t11r=sinrat*t3r-t4r
      t11i=sinrat*t3i-t4i
      x1p=t8r+t10i
      y1p=t8i-t10r
      x2p=t9r+t11i
      y2p=t9i-t11r
      x3p=t9r-t11i
      y3p=t9i+t11r
      x4p=t8r-t10i
      y4p=t8i+t10r
      b(i,0, k)=a(i, k,0)+t5r
      b(i,0,kc)=a(i,kc,4)+t5i
      b(i,1, k)=cosine(k,1)*x1p-sine(k,1)*y1p
      b(i,1,kc)=cosine(k,1)*y1p+sine(k,1)*x1p
      b(i,2, k)=cosine(k,2)*x2p-sine(k,2)*y2p
      b(i,2,kc)=cosine(k,2)*y2p+sine(k,2)*x2p
      b(i,3, k)=cosine(k,3)*x3p-sine(k,3)*y3p
      b(i,3,kc)=cosine(k,3)*y3p+sine(k,3)*x3p
      b(i,4, k)=cosine(k,4)*x4p-sine(k,4)*y4p
      b(i,4,kc)=cosine(k,4)*y4p+sine(k,4)*x4p
    enddo
  enddo
else
  do k=1,(lv-1)/2
    kc=lv-k
    c1k=cosine(k,1)
    s1k=sine(k,1)
    c2k=cosine(k,2)
    s2k=sine(k,2)
    c3k=cosine(k,3)
    s3k=sine(k,3)
    c4k=cosine(k,4)
    s4k=sine(k,4)
    do i=0,nv-1
      t1r=a(i, k,1)+a(i,kc,0)
      t1i=a(i,kc,3)-a(i, k,4)
      t2r=a(i, k,2)+a(i,kc,1)
      t2i=a(i,kc,2)-a(i, k,3)
      t3r=sinf2pi5*(a(i, k,1)-a(i,kc,0))
      t3i=sinf2pi5*(a(i,kc,3)+a(i, k,4))
      t4r=sinf2pi5*(a(i, k,2)-a(i,kc,1))
      t4i=sinf2pi5*(a(i,kc,2)+a(i, k,3))
      t5r=t1r+t2r
      t5i=t1i+t2i
      t6r=rtf516*(t1r-t2r)
      t6i=rtf516*(t1i-t2i)
      t7r=a(i,k,0)-0.25d0*t5r
      t7i=a(i,kc,4)-0.25d0*t5i
      t8r=t7r+t6r
      t8i=t7i+t6i
      t9r=t7r-t6r
      t9i=t7i-t6i
      t10r=t3r+sinrat*t4r
      t10i=t3i+sinrat*t4i
      t11r=sinrat*t3r-t4r
      t11i=sinrat*t3i-t4i
      x1p=t8r+t10i
      y1p=t8i-t10r
      x2p=t9r+t11i
      y2p=t9i-t11r
      x3p=t9r-t11i
      y3p=t9i+t11r
      x4p=t8r-t10i
      y4p=t8i+t10r
      b(i,0, k)=a(i, k,0)+t5r
      b(i,0,kc)=a(i,kc,4)+t5i
      b(i,1, k)=c1k*x1p-s1k*y1p
      b(i,1,kc)=c1k*y1p+s1k*x1p
      b(i,2, k)=c2k*x2p-s2k*y2p
      b(i,2,kc)=c2k*y2p+s2k*x2p
      b(i,3, k)=c3k*x3p-s3k*y3p
      b(i,3,kc)=c3k*y3p+s3k*x3p
      b(i,4, k)=c4k*x4p-s4k*y4p
      b(i,4,kc)=c4k*y4p+s4k*x4p
    enddo
  enddo
endif

return
end subroutine
!=================================================

subroutine revrdx4(a,b,nv,lv,cosine,sine)

!Radix four Hermitian to physical FFT with 'decimation in frequency'.

implicit none

 !Arguments declarations:
integer:: nv,lv
double precision:: a(0:nv-1,0:lv-1,0:3),b(0:nv-1,0:3,0:lv-1),cosine(0:lv-1,1:3),sine(0:lv-1,1:3)

 !Local declarations:
double precision,parameter:: rtf12=0.7071067811865475244008443621048490392848359376884740365883398689953662d0
double precision:: x1p,x2p,x3p,y1p,y2p,y3p
double precision:: s1k,s2k,s3k,c1k,c2k,c3k
double precision:: t1i,t1r,t2i,t2r,t3i,t3r,t4i,t4r
integer:: i,k,kc,lvd2

!--------------------------------------------------
 !Do k=0 first:
do i=0,nv-1
  t1r=a(i,0,0)+a(i,0,2)
  t2r=a(i,0,1)
  t3r=a(i,0,0)-a(i,0,2)
  t4r=a(i,0,3)
  b(i,0,0)=t1r+t2r
  b(i,1,0)=t3r+t4r
  b(i,2,0)=t1r-t2r
  b(i,3,0)=t3r-t4r
enddo
 !Next do remaining k:
if (nv .lt. (lv-1)/2) then
  do i=0,nv-1
    do k=1,(lv-1)/2
      kc=lv-k
      t1r=a(i, k,0)+a(i,kc,1)
      t1i=a(i,kc,3)-a(i, k,2)
      t2r=a(i, k,1)+a(i,kc,0)
      t2i=a(i,kc,2)-a(i, k,3)
      t3r=a(i, k,0)-a(i,kc,1)
      t3i=a(i,kc,3)+a(i, k,2)
      t4r=a(i, k,1)-a(i,kc,0)
      t4i=a(i,kc,2)+a(i, k,3)
      x1p=t3r+t4i
      y1p=t3i-t4r
      x2p=t1r-t2r
      y2p=t1i-t2i
      x3p=t3r-t4i
      y3p=t3i+t4r
      b(i,0, k)=t1r+t2r
      b(i,0,kc)=t1i+t2i
      b(i,1, k)=cosine(k,1)*x1p-sine(k,1)*y1p
      b(i,1,kc)=cosine(k,1)*y1p+sine(k,1)*x1p
      b(i,2, k)=cosine(k,2)*x2p-sine(k,2)*y2p
      b(i,2,kc)=cosine(k,2)*y2p+sine(k,2)*x2p
      b(i,3, k)=cosine(k,3)*x3p-sine(k,3)*y3p
      b(i,3,kc)=cosine(k,3)*y3p+sine(k,3)*x3p
    enddo
  enddo
else
  do k=1,(lv-1)/2
    kc=lv-k
    c1k=cosine(k,1)
    s1k=sine(k,1)
    c2k=cosine(k,2)
    s2k=sine(k,2)
    c3k=cosine(k,3)
    s3k=sine(k,3)
    do i=0,nv-1
      t1r=a(i,k,0)+a(i,kc,1)
      t1i=a(i,kc,3)-a(i,k,2)
      t2r=a(i,k,1)+a(i,kc,0)
      t2i=a(i,kc,2)-a(i,k,3)
      t3r=a(i,k,0)-a(i,kc,1)
      t3i=a(i,kc,3)+a(i,k,2)
      t4r=a(i,k,1)-a(i,kc,0)
      t4i=a(i,kc,2)+a(i,k,3)
      x1p=t3r+t4i
      y1p=t3i-t4r
      x2p=t1r-t2r
      y2p=t1i-t2i
      x3p=t3r-t4i
      y3p=t3i+t4r
      b(i,0, k)=t1r+t2r
      b(i,0,kc)=t1i+t2i
      b(i,1, k)=c1k*x1p-s1k*y1p
      b(i,1,kc)=c1k*y1p+s1k*x1p
      b(i,2, k)=c2k*x2p-s2k*y2p
      b(i,2,kc)=c2k*y2p+s2k*x2p
      b(i,3, k)=c3k*x3p-s3k*y3p
      b(i,3,kc)=c3k*y3p+s3k*x3p
    enddo
  enddo
endif

 !Catch the case k=lv/2 when lv even:
if (mod(lv,2) .eq. 0) then
  lvd2=lv/2
  do i=0,nv-1
    b(i,0,lvd2)=a(i,lvd2,0)+a(i,lvd2,1)
    b(i,2,lvd2)=a(i,lvd2,3)-a(i,lvd2,2)
    t3r=a(i,lvd2,0)-a(i,lvd2,1)
    t4r=a(i,lvd2,3)+a(i,lvd2,2)
    b(i,1,lvd2)=rtf12*(t3r+t4r)
    b(i,3,lvd2)=rtf12*(t4r-t3r)
  enddo
endif

return
end subroutine
!=================================================

subroutine revrdx3(a,b,nv,lv,cosine,sine)

!Radix three Hermitian to physical FFT with 'decimation in frequency'.

implicit none

 !Arguments declarations:
integer:: nv,lv
double precision:: a(0:nv-1,0:lv-1,0:2),b(0:nv-1,0:2,0:lv-1),cosine(0:lv-1,1:2),sine(0:lv-1,1:2)

 !Local declarations:
double precision,parameter:: sinfpi3=0.8660254037844386467637231707529361834714026269051903140279034897259665d0
double precision:: x1p,x2p,y1p,y2p
double precision:: c2k,c1k,s2k,s1k
double precision:: t1i,t1r,t2i,t2r,t3i,t3r
integer:: i,k,kc

!-------------------------------------------------
 !Do k=0 first:
do i=0,nv-1
  t1r=a(i,0,1)
  t2r=a(i,0,0)-0.5d0*t1r
  t3r=sinfpi3*a(i,0,2)
  b(i,0,0)=a(i,0,0)+t1r
  b(i,1,0)=t2r+t3r
  b(i,2,0)=t2r-t3r
enddo
 !Next do remaining k:
if (nv .le. (lv-1)/2) then
  do i=0,nv-1
    do k=1,(lv-1)/2
      kc=lv-k
      t1r=a(i, k,1)+a(i,kc,0)
      t1i=a(i,kc,1)-a(i, k,2)
      t2r=a(i, k,0)-0.5d0*t1r
      t2i=a(i,kc,2)-0.5d0*t1i
      t3r=sinfpi3*(a(i, k,1)-a(i,kc,0))
      t3i=sinfpi3*(a(i,kc,1)+a(i, k,2))
      x1p=t2r+t3i
      y1p=t2i-t3r
      x2p=t2r-t3i
      y2p=t2i+t3r
      b(i,0, k)=a(i, k,0)+t1r
      b(i,0,kc)=a(i,kc,2)+t1i
      b(i,1, k)=cosine(k,1)*x1p-sine(k,1)*y1p
      b(i,1,kc)=sine(k,1)*x1p+cosine(k,1)*y1p
      b(i,2, k)=cosine(k,2)*x2p-sine(k,2)*y2p
      b(i,2,kc)=sine(k,2)*x2p+cosine(k,2)*y2p
    enddo
  enddo
else
  do k=1,(lv-1)/2
    kc=lv-k
    c1k=cosine(k,1)
    s1k=sine(k,1)
    c2k=cosine(k,2)
    s2k=sine(k,2)
    do i=0,nv-1
      t1r=a(i, k,1)+a(i,kc,0)
      t1i=a(i,kc,1)-a(i, k,2)
      t2r=a(i, k,0)-0.5d0*t1r
      t2i=a(i,kc,2)-0.5d0*t1i
      t3r=sinfpi3*(a(i, k,1)-a(i,kc,0))
      t3i=sinfpi3*(a(i,kc,1)+a(i, k,2))
      x1p=t2r+t3i
      y1p=t2i-t3r
      x2p=t2r-t3i
      y2p=t2i+t3r
      b(i,0, k)=a(i, k,0)+t1r
      b(i,0,kc)=a(i,kc,2)+t1i
      b(i,1, k)=c1k*x1p-s1k*y1p
      b(i,1,kc)=s1k*x1p+c1k*y1p
      b(i,2, k)=c2k*x2p-s2k*y2p
      b(i,2,kc)=s2k*x2p+c2k*y2p
    enddo
  enddo
endif

return
end subroutine
!================================================

subroutine revrdx2(a,b,nv,lv,cosine,sine)

!Radix two Hermitian to physical FFT with 'decimation in frequency'.

implicit none

 !Arguments declarations:
integer:: nv,lv
double precision:: a(0:nv-1,0:lv-1,0:1),b(0:nv-1,0:1,0:lv-1),cosine(0:lv-1),sine(0:lv-1)

 !Local declarations:
double precision:: x1p,y1p,c1k,s1k
integer:: i,k,kc

!-----------------------------------------
 !Do k=0 first:
do i=0,nv-1
  b(i,0,0)=a(i,0,0)+a(i,0,1)
  b(i,1,0)=a(i,0,0)-a(i,0,1)
enddo
 !Next do remaining k:
if (nv .lt. (lv-1)/2) then
  do i=0,nv-1
    do k=1,(lv-1)/2
      kc=lv-k
      x1p=a(i, k,0)-a(i,kc,0)
      y1p=a(i,kc,1)+a(i, k,1)
      b(i,0, k)=a(i, k,0)+a(i,kc,0)
      b(i,0,kc)=a(i,kc,1)-a(i, k,1)
      b(i,1, k)=cosine(k)*x1p-sine(k)*y1p
      b(i,1,kc)=cosine(k)*y1p+sine(k)*x1p
    enddo
  enddo
else
  do k=1,(lv-1)/2
    kc=lv-k
    c1k=cosine(k)
    s1k=sine(k)
    do i=0,nv-1
      x1p=a(i, k,0)-a(i,kc,0)
      y1p=a(i,kc,1)+a(i, k,1)
      b(i,0, k)=a(i, k,0)+a(i,kc,0)
      b(i,0,kc)=a(i,kc,1)-a(i, k,1)
      b(i,1, k)=c1k*x1p-s1k*y1p
      b(i,1,kc)=c1k*y1p+s1k*x1p
    enddo
  enddo
endif

return
end subroutine
!=================================================

end module


      SUBROUTINE TC05AD( LERI, M, P, SVAL, INDEX, PCOEFF, LDPCO1,
     $                   LDPCO2, QCOEFF, LDQCO1, LDQCO2, RCOND, CFREQR,
     $                   LDCFRE, IWORK, DWORK, ZWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To evaluate the transfer matrix T(s) of a left polynomial matrix
C     representation [T(s) = inv(P(s))*Q(s)] or a right polynomial
C     matrix representation [T(s) = Q(s)*inv(P(s))] at any specified
C     complex frequency s = SVAL.
C
C     This routine will calculate the standard frequency response
C     matrix at frequency omega if SVAL is supplied as (0.0,omega).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LERI    CHARACTER*1
C             Indicates whether a left polynomial matrix representation
C             or a right polynomial matrix representation is to be used
C             to evaluate the transfer matrix as follows:
C             = 'L':  A left matrix fraction is input;
C             = 'R':  A right matrix fraction is input.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     SVAL    (input) COMPLEX*16
C             The frequency at which the transfer matrix or the
C             frequency respose matrix is to be evaluated.
C             For a standard frequency response set the real part
C             of SVAL to zero.
C
C     INDEX   (input) INTEGER array, dimension (MAX(M,P))
C             If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the
C             maximum degree of the polynomials in the I-th row of the
C             denominator matrix P(s) of the given left polynomial
C             matrix representation.
C             If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the
C             maximum degree of the polynomials in the I-th column of
C             the denominator matrix P(s) of the given right polynomial
C             matrix representation.
C
C     PCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1.
C             If LERI = 'L' then porm = P, otherwise porm = M.
C             The leading porm-by-porm-by-kpcoef part of this array must
C             contain the coefficients of the denominator matrix P(s).
C             PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
C             of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if
C             LERI = 'L' then iorj = I, otherwise iorj = J.
C             Thus for LERI = 'L', P(s) =
C             diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...).
C             If LERI = 'R', PCOEFF is modified by the routine but
C             restored on exit.
C
C     LDPCO1  INTEGER
C             The leading dimension of array PCOEFF.
C             LDPCO1 >= MAX(1,P) if LERI = 'L',
C             LDPCO1 >= MAX(1,M) if LERI = 'R'.
C
C     LDPCO2  INTEGER
C             The second dimension of array PCOEFF.
C             LDPCO2 >= MAX(1,P) if LERI = 'L',
C             LDPCO2 >= MAX(1,M) if LERI = 'R'.
C
C     QCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDQCO1,LDQCO2,kpcoef)
C             If LERI = 'L' then porp = M, otherwise porp = P.
C             The leading porm-by-porp-by-kpcoef part of this array must
C             contain the coefficients of the numerator matrix Q(s).
C             QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).
C             If LERI = 'R', QCOEFF is modified by the routine but
C             restored on exit.
C
C     LDQCO1  INTEGER
C             The leading dimension of array QCOEFF.
C             LDQCO1 >= MAX(1,P)   if LERI = 'L',
C             LDQCO1 >= MAX(1,M,P) if LERI = 'R'.
C
C     LDQCO2  INTEGER
C             The second dimension of array QCOEFF.
C             LDQCO2 >= MAX(1,M)   if LERI = 'L',
C             LDQCO2 >= MAX(1,M,P) if LERI = 'R'.
C
C     RCOND   (output) DOUBLE PRECISION
C             The estimated reciprocal of the condition number of the
C             denominator matrix P(SVAL).
C             If RCOND is nearly zero, SVAL is approximately a system
C             pole.
C
C     CFREQR  (output) COMPLEX*16 array, dimension (LDCFRE,MAX(M,P))
C             The leading porm-by-porp part of this array contains the
C             frequency response matrix T(SVAL).
C
C     LDCFRE  INTEGER
C             The leading dimension of array CFREQR.
C             LDCFRE >= MAX(1,P)   if LERI = 'L',
C             LDCFRE >= MAX(1,M,P) if LERI = 'R'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (liwork)
C             where liwork = P, if LERI = 'L',
C                   liwork = M, if LERI = 'R'.
C
C     DWORK   DOUBLE PRECISION array, dimension (ldwork)
C             where ldwork = 2*P, if LERI = 'L',
C                   ldwork = 2*M, if LERI = 'R'.
C
C     ZWORK   COMPLEX*16 array, dimension (lzwork),
C             where lzwork = P*(P+2), if LERI = 'L',
C                   lzwork = M*(M+2), if LERI = 'R'.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if P(SVAL) is exactly or nearly singular;
C                   no frequency response is calculated.
C
C     METHOD
C
C     The method for a left matrix fraction will be described here;
C     right matrix fractions are dealt with by obtaining the dual left
C     fraction and calculating its frequency response (see SLICOT
C     Library routine TC01OD). The first step is to calculate the
C     complex value P(SVAL) of the denominator matrix P(s) at the
C     desired frequency SVAL. If P(SVAL) is approximately singular,
C     SVAL is approximately a pole of this system and so the frequency
C     response matrix T(SVAL) is not calculated; in this case, the
C     routine returns with the Error Indicator (INFO) set to 1.
C     Otherwise, the complex value Q(SVAL) of the numerator matrix Q(s)
C     at frequency SVAL is calculated in a similar way to P(SVAL), and
C     the desired response matrix T(SVAL) = inv(P(SVAL))*Q(SVAL) is
C     found by solving the corresponding system of complex linear
C     equations.
C
C     REFERENCES
C
C     None
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TC01AD by T.W.C.Williams, Kingston
C     Polytechnic, United Kingdom, March 1982.
C
C     REVISIONS
C
C     February 22, 1998 (changed the name of TC01MD).
C
C     KEYWORDS
C
C     Coprime matrix fraction, elementary polynomial operations,
C     polynomial matrix, state-space representation, transfer matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         LERI
      INTEGER           INFO, LDCFRE, LDPCO1, LDPCO2, LDQCO1, LDQCO2, M,
     $                  P
      DOUBLE PRECISION  RCOND
      COMPLEX*16        SVAL
C     .. Array Arguments ..
      INTEGER           INDEX(*), IWORK(*)
      DOUBLE PRECISION  DWORK(*), PCOEFF(LDPCO1,LDPCO2,*),
     $                  QCOEFF(LDQCO1,LDQCO2,*)
      COMPLEX*16        CFREQR(LDCFRE,*), ZWORK(*)
C     .. Local Scalars ..
      LOGICAL           LLERI
      INTEGER           I, IZWORK, IJ, INFO1, J, K, KPCOEF, LDZWOR,
     $                  MAXIND, MINMP, MPLIM, MWORK, PWORK
      DOUBLE PRECISION  CNORM
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, ZLANGE
      EXTERNAL          DLAMCH, LSAME, ZLANGE
C     .. External Subroutines ..
      EXTERNAL          TC01OD, XERBLA, ZCOPY, ZGECON, ZGETRF, ZGETRS,
     $                  ZSWAP
C     .. Intrinsic Functions ..
      INTRINSIC         DCMPLX, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LLERI = LSAME( LERI, 'L' )
      MPLIM = MAX( M, P )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN
         INFO = -7
      ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN
         INFO = -8
      ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, M, P ) ) ) THEN
         INFO = -10
      ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR.
     $    ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MPLIM ) ) ) THEN
         INFO = -11
      ELSE IF( ( LLERI .AND. LDCFRE.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDCFRE.LT.MAX( 1, MPLIM ) ) ) THEN
         INFO = -14
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TC05AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 .OR. P.EQ.0 ) THEN
         RCOND = ONE
         RETURN
      END IF
C
      IF ( LLERI ) THEN
C
C        Initialization for left matrix fraction.
C
         PWORK = P
         MWORK = M
      ELSE
C
C        Initialization for right matrix fraction: obtain dual system.
C
         PWORK = M
         MWORK = P
         IF ( MPLIM.GT.1 )
     $      CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2,
     $                   QCOEFF, LDQCO1, LDQCO2, INFO )
      END IF
C
      LDZWOR = PWORK
      IZWORK = LDZWOR*LDZWOR + 1
      MAXIND = 0
C
      DO 10 I = 1, PWORK
         IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I)
   10 CONTINUE
C
      KPCOEF = MAXIND + 1
C
C     Calculate the complex denominator matrix P(SVAL), row by row.
C
      DO 50 I = 1, PWORK
         IJ = I
C
         DO 20 J = 1, PWORK
            ZWORK(IJ) = DCMPLX( PCOEFF(I,J,1), ZERO )
            IJ = IJ + PWORK
   20    CONTINUE
C
C        Possibly non-constant row: finish evaluating it.
C
         DO 40 K = 2, INDEX(I) + 1
C
            IJ = I
C
            DO 30 J = 1, PWORK
               ZWORK(IJ) = ( SVAL*ZWORK(IJ) ) +
     $                       DCMPLX( PCOEFF(I,J,K), ZERO )
               IJ = IJ + PWORK
   30       CONTINUE
C
   40    CONTINUE
C
   50 CONTINUE
C
C     Check if this P(SVAL) is singular: if so, don't compute T(SVAL).
C     Note that DWORK is not actually referenced in ZLANGE routine.
C
      CNORM = ZLANGE( '1-norm', PWORK, PWORK, ZWORK, LDZWOR, DWORK )
C
      CALL ZGETRF( PWORK, PWORK, ZWORK, LDZWOR, IWORK, INFO )
C
      IF ( INFO.GT.0 ) THEN
C
C        Singular matrix.  Set INFO and RCOND for error return.
C
         INFO  = 1
         RCOND = ZERO
      ELSE
C
C        Estimate the reciprocal condition of P(SVAL).
C        Workspace: ZWORK: PWORK*PWORK + 2*PWORK, DWORK: 2*PWORK.
C
         CALL ZGECON( '1-norm', PWORK, ZWORK, LDZWOR, CNORM, RCOND,
     $                ZWORK(IZWORK), DWORK, INFO )
C
         IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN
C
C           Nearly singular matrix.  Set INFO for error return.
C
            INFO  = 1
         ELSE
C
C           Calculate the complex numerator matrix Q(SVAL), row by row.
C
            DO 90 I = 1, PWORK
C
               DO 60 J = 1, MWORK
                  CFREQR(I,J) = DCMPLX( QCOEFF(I,J,1), ZERO )
   60          CONTINUE
C
C              Possibly non-constant row: finish evaluating it.
C
               DO 80 K = 2, INDEX(I) + 1
C
                  DO 70 J = 1, MWORK
                     CFREQR(I,J) = ( SVAL*CFREQR(I,J) ) +
     $                             DCMPLX( QCOEFF(I,J,K), ZERO )
   70             CONTINUE
C
   80          CONTINUE
C
   90       CONTINUE
C
C           Now calculate frequency response T(SVAL).
C
            CALL ZGETRS( 'No transpose', PWORK, MWORK, ZWORK, LDZWOR,
     $                   IWORK, CFREQR, LDCFRE, INFO )
         END IF
      END IF
C
C     For right matrix fraction, return to original (dual of the dual)
C     system.
C
      IF ( ( .NOT.LLERI ) .AND. ( MPLIM.NE.1 ) ) THEN
         CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1,
     $                LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO1 )
C
         IF ( INFO.EQ.0 ) THEN
C
C           Also, transpose T(SVAL) here if this was successfully
C           calculated.
C
            MINMP = MIN( M, P )
C
            DO 100 J = 1, MPLIM
               IF ( J.LT.MINMP ) THEN
                  CALL ZSWAP( MINMP-J, CFREQR(J+1,J), 1, CFREQR(J,J+1),
     $                        LDCFRE )
               ELSE IF ( J.GT.P ) THEN
                  CALL ZCOPY( P, CFREQR(1,J), 1, CFREQR(J,1), LDCFRE )
               ELSE IF ( J.GT.M ) THEN
                  CALL ZCOPY( M, CFREQR(J,1), LDCFRE, CFREQR(1,J), 1 )
               END IF
  100       CONTINUE
C
         END IF
      END IF
C
      RETURN
C *** Last line of TC05AD ***
      END


! **************************************************************************
! ... makeobs.f90
! ... Quim Ballabrera, February 2013
! ...
! ... System dynamics
! ...
! **************************************************************************

program makeobs

use sysdyn

logical                               :: default = .false.
logical                               :: Zexist

real(dp), dimension(:), allocatable   :: Y,Xm,Xs,Xe,Xo
real(dp), dimension(:), allocatable   :: T
real(dp), dimension(:,:), allocatable :: X

integer nl,no,step,idum,n,iu
real(dp) dto,var,t1,t2,noise(1)
character(len=180) ifile,ofile,nfile,line

namelist /namobs/ idum,ifile,ofile,var,dto

call header()

nfile = ''
call getarg(1,nfile)
inquire(file=nfile,exist=Zexist)
if (Zexist) then
  write(*,*) 'Reading ', trim(nfile)
  open(10,file=nfile,status='old')
  rewind(10)
  read(10,namobs)
  close(10)
  default = .false.
else
  write(*,*) 'No valid namelist specified.'
  write(*,*) 'Default makeobs parameters'
  default = .true.
endif

if (default) then
  write(*,*) 'Using default parameters ...'
  idum  = -1
  ifile = './lorenz_simulation.dat'
  ofile = 'lorenz_obs.dat'
  var   = 2.00
  dto   = 0.25
endif

iu = unitfree()
write(*,*) 'Reading lorenz simulation from : ', TRIM(ifile)
open(iu,file=ifile,status='old')

nl = numlines(iu)
IF (nl.LE.1) STOP 'MAKEOBS ERROR: not enough model outputs'

rewind(iu)
read(iu,'(A)') line
n = numwords(line) - 1     ! First column is time

write(*,*)
write(*,*) 'n         = ', n
write(*,*) 'idum      = ', idum
write(*,*) 'ifile     = ', TRIM(ifile)
write(*,*) 'ofile     = ', TRIM(ofile)
write(*,*) 'var       = ', var
write(*,*) 'dto       = ', dto
write(*,*)

! ... Random number generator seed
! ... if idum = -1, the default seed is used
! ...
if (idum.eq.-1) then
  write(*,*) 'Default random number generator seed'
else
  write(*,*) 'Resetting random number generator seed'
  call randseed(idum)
endif

allocate(Xo(n))
allocate(Xm(n))
allocate(Xs(n))
allocate(Xe(n))
allocate(Y(n))

rewind(iu)
read(iu,*) t1,Xo
read(iu,*) t2,Xo
dt = t2 - t1
no = nint(dto/dt)

write(*,*)
write(*,*) 'Model entries             : ', nl
write(*,*) 'Model time-step           : ', dt
write(*,*) 'Observation time-step     : ', dto
write(*,*) 'Observation sampling rate : ', no

! ... Trajectory sampling
! ...
allocate (T(nl))
allocatE (X(n,nl))

rewind(iu)
do i=1,nl
  read(iu,*,err=1000) T(i), X(:,i)
enddo

write(*,*) 'Initial time              : ', T(1)
write(*,*) 'Final time                : ', T(nl)

! ... Standard deviation
! ...
do i=1,n
  CALL avevar (X(i,:),Xm(i),Xs(i))
  Xs(i) = maxval((/Xs(i),0.0D0/))
  Xs(i) = SQRT(Xs(i))
enddo
write(*,*)
write(*,*) 'Mean value and Standard deviation'
write(*,'(T2,A,T5,F9.3,T15,F9.3)') 'X',Xm(1),Xs(1)
write(*,'(T2,A,T5,F9.3,T15,F9.3)') 'Y',Xm(2),Xs(2)
write(*,'(T2,A,T5,F9.3,T15,F9.3)') 'Z',Xm(3),Xs(3)

open(9,file='lorenz_simulation_ave.dat',status='unknown')
write(9,'(4F10.4)') 0.0, Xm(:)
close(9)

open(9,file='lorenz_simulation_std.dat',status='unknown')
write(9,'(4F10.4)') 0.0, Xs(:)
close(9)

Xe = sqrt(var)

write(*,*)
write(*,*) 'Error variance ', var
write(*,*) 'Standard deviation of error'
write(*,'(T2,A,T5,F9.3)') 'X',Xe(1)
write(*,'(T2,A,T5,F9.3)') 'Y',Xe(2)
write(*,'(T2,A,T5,F9.3)') 'Z',Xe(3)

open(20,file=ofile,status='unknown')
do step=1,nl
  if (MOD(step,no).EQ.1) THEN
    do i=1,n
      noise = randn()
      Y(i) = X(i,step) + Xe(i)*noise(1)
    enddo
    write(20,'(4F10.4)') T(step), Y(:)
  endif
enddo

call stop_error(0,'makeobs program Ok')

1000 call stop_error(1,'Error while reading the trajectory')

end program makeobs


module lola2distaz_prog

character(len=512) :: input_file
character(len=512) :: output_file

end module

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

program main
!----
! Compute the distance and azimuth between two geographic points.
!
! (Public implementation of subroutine lola2distaz() in geom_module.f90)
!----

use io, only: stderr, stdin, stdout, fileExists
use geom, only: lola2distaz
use earth, only: radius_earth_km

use lola2distaz_prog, only: input_file, &
                            output_file
implicit none

! Local variables
integer :: ierr, luin, luout, ios, nline
double precision :: lon1, lat1, dist, az, lon2, lat2
character(len=512) :: input_line

call gcmdln()

! Check that input file exists, if defined
if (input_file.ne.'') then
    if (.not.fileExists(input_file)) then
        call usage('lola2distaz: no input file found named '//trim(input_file))
    endif
endif

! Open input and output streams
if (input_file.eq.''.or.input_file.eq.'stdin') then
    luin = stdin
else
    luin = 11
    open(unit=luin,file=input_file,status='old')
endif

if (output_file.eq.''.or.output_file.eq.'stdout') then
    luout = stdout
else
    luout = 12
    open(unit=luout,file=output_file,status='unknown')
endif

! Calculate the distance and azimuth
nline = 0
do
    ! Read input line
    read (luin,'(A)',iostat=ios) input_line
    if (ios.ne.0) then
        exit
    else
        nline = nline + 1
    endif

    ! Read lon, lat, dist, az from input line
    read (input_line,*,iostat=ios) lon1,lat1,lon2,lat2
    if (ios.ne.0) then
        write(stderr,*) 'lola2distaz: error reading line ',nline,':'
        call usage(trim(input_line))
    endif

    ! Make sure latitudes are reasonable
    if (lat1.gt.90.0d0) then
        write(stderr,*) 'lola2distaz: latitude 1in line ',nline,' is greater than 90 degrees:'
        call usage(trim(input_line))
    elseif (lat1.lt.-90.0d0) then
        write(stderr,*) 'lola2distaz: latitude 1 in line ',nline,' is less than -90 degrees:'
        call usage(trim(input_line))
    elseif (lat2.gt.90.0d0) then
        write(stderr,*) 'lola2distaz: latitude 2 in line ',nline,' is greater than 90 degrees:'
        call usage(trim(input_line))
    elseif (lat2.lt.-90.0d0) then
        write(stderr,*) 'lola2distaz: latitude 2 in line ',nline,' is less than -90 degrees:'
        call usage(trim(input_line))
    endif

    ! Compute longitude and latitude
    call lola2distaz(lon1,lat1,lon2,lat2,dist,az,'radians','degrees',ierr)
    if (ierr.ne.0) then
        call usage('lola2distaz: error calculating dist and az')
    endif
    dist = dist*radius_earth_km

    ! Write distance/azimuth
    write(luout,*) dist,az
enddo

! A little spring cleaning
if (input_file.ne.'') then
    close(luin)
endif
if (output_file.ne.'') then
    close(luout)
endif
if (input_file.eq.'lola2distaz_86_this_at_the_end.tmp') then
    open(unit=86,file=input_file,status='old')
    close(86,status='delete')
endif

end

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

subroutine gcmdln()

use lola2distaz_prog, only: input_file, &
                            output_file

implicit none

! Local variables
integer :: i, narg
character(len=512) :: tag, tag_array(4)

! Initialize control parameters
input_file = ''
output_file = ''

! Number of arguments
narg = command_argument_count()
if (narg.eq.0) then
  call usage('')
endif

! Read arguments
i = 1
do while (i.le.narg)

    call get_command_argument(i,tag)

    if (trim(tag).eq.'-f') then
        i = i + 1
        call get_command_argument(i,input_file)
        if (input_file.eq.'stdin') then
            input_file = ''
        endif
    elseif (trim(tag).eq.'-s') then
        ! Do nothing: default reads from stdin
    elseif (trim(tag).eq.'-o') then
        i = i + 1
        call get_command_argument(i,output_file)
    elseif (trim(tag).eq.'-c') then
        i = i + 1
        call get_command_argument(i,tag_array(1))
        i = i + 1
        call get_command_argument(i,tag_array(2))
        i = i + 1
        call get_command_argument(i,tag_array(3))
        i = i + 1
        call get_command_argument(i,tag_array(4))
        input_file = 'lola2distaz_86_this_at_the_end.tmp'
        open(unit=86,file=input_file,status='unknown')
        write(86,*) trim(tag_array(1)),' ', &
                    trim(tag_array(2)),' ', &
                    trim(tag_array(3)),' ', &
                    trim(tag_array(4))
        close(86)
    else
        call usage('lola2distaz: no option '//trim(tag))
    endif

    i = i + 1

enddo

return
end subroutine

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

subroutine usage(str)

use io, only: stderr
implicit none

character(len=*) :: str

if (str.ne.'') then
    write(stderr,*) trim(str)
    write(stderr,*)
endif

write(stderr,*) 'Usage: lola2distaz -s|-f IFILE [-o OFILE] [-c LON1 LAT1 DIST AZ]'
write(stderr,*)
write(stderr,*) '-s                     Read standard input: lon1 lat1 lon2 lat2'
write(stderr,*) '-f IFILE               Input file: lon1 lat1 lon2 lat2'
write(stderr,*) '-o OFILE               Output file: dist(km) az(deg CW from N)'
write(stderr,*) '-c LON1 LAT1 LON2 LAT2 Compute DIST AZ for a single LON LAT pair'
write(stderr,*)

call error_exit(1)
end subroutine


C$Procedure      MEQUG  ( Matrix equal to another, general dimension )

      SUBROUTINE MEQUG ( M1, NR, NC, MOUT )

C$ Abstract
C
C      Set one double precision matrix of arbitrary size equal to
C      another.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C      None.
C
C$ Keywords
C
C      ASSIGNMENT,  MATRIX
C
C$ Declarations

      INTEGER            NR
      INTEGER            NC
      DOUBLE PRECISION   M1   ( NR,NC )
      DOUBLE PRECISION   MOUT ( NR,NC )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       M1        I     Input matrix.
C       NR        I     Row dimension of M1 (and also MOUT).
C       NC        I     Column dimension of M1 (and also MOUT).
C       MOUT      O     Output matrix equal to M1.
C
C$ Detailed_Input
C
C      M1      is an arbitrary-sized double precision matrix.
C              There are no restrictions on what it may contain.
C
C      NR      is the number of rows in the input matrix.
C
C      NC      is the number of columns in the input matrix.
C
C$ Detailed_Output
C
C      MOUT    This matrix is set to be equal to M1.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      None.
C
C$ Examples
C
C      If  M1 = | 1.0D0   2.0D0 |
C               |               |
C               | 2.0D0   4.0D0 |
C               |               |
C               | 4.0D0   6.0D0 |
C
C      the call
C
C      CALL MEQUG ( M1, 3, 2, MOUT )
C
C      produces the matrix
C
C        MOUT = | 1.0D0   2.0D0 |
C               |               |
C               | 2.0D0   4.0D0 |
C               |               |
C               | 4.0D0   6.0D0 |
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If NR < 1 or NC < 1, the elements of the matrix MOUT are not
C        assigned any values.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.M. Owen       (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     equal to another n-dimensional matrix
C
C-&

      CALL MOVED (M1, NR*NC, MOUT)
C
      RETURN
      END


!! This module contains tools (convolution/ravel) to manipulate 2D/3Darray
module mod_array
  !! This module contains tools (convolution/ravel) to manipulate 2D/3Darray
  use mod_constants
  implicit none

  private

  public :: convolution_2D_mirror, ravel_2D, ravel_3D, unravel_3D, mean, std, std_2D, mean_2D, max_2D, ravel_3D_abs, unravel_3D_abs

contains

  subroutine convolution_2D_mirror(image, conv, dim_y, dim_x, kernel, dim_k)
    implicit none

    real(xp), intent(in), dimension(:,:), allocatable :: image
    real(xp), intent(inout), dimension(:,:), allocatable :: conv
    real(xp), intent(in), dimension(:,:), allocatable :: kernel
    integer, intent(in) :: dim_y, dim_x, dim_k

    integer :: i, j, ii, jj, m, n, mm, nn
    integer :: kCenterY, kCenterX
    real(xp), dimension(:,:), allocatable :: ext_conv, extended

    allocate(ext_conv(dim_y+4, dim_x+4))
    allocate(extended(dim_y+4, dim_x+4))

    ii = 0; jj = 0; mm = 0; nn = 0
    kCenterY = 0; kCenterX = 0
    ext_conv = 0._xp
    extended = 0._xp

    do j=1, dim_x
       do i=1, dim_y
          extended(2+i,2+j) = image(i,j)
       end do
    end do

    do j=1, 2
       do i=1, dim_y
          extended(2+i,j) = image(i,j);
       end do
    end do

    do i=1, 2
       do j=1, dim_x
          extended(i,2+j) = image(i,j);
       end do
    end do

    do j=dim_x+1, dim_x+2
       do i=1, dim_y
          extended(2+i,2+j) = image(i,j-2)
       end do
    end do

    do j=1, dim_x
       do i=dim_y+1, dim_y+2
          extended(2+i,2+j) = image(i-2,j)
       end do
    end do

    kCenterY = dim_k / 2 + 1
    kCenterX = kCenterY

    do j=1, dim_x+4
       do i=1, dim_y+4
          do m=1, dim_k
             mm = dim_k - m + 1

             do n=1, dim_k
                nn = dim_k - n + 1

                ii = i + (m - kCenterY)
                jj = j + (n - kCenterX)

                if( ii >= 1 .and. ii < dim_y+4 .and. jj >= 1 .and. jj < dim_x+4 ) then
                   ext_conv(i,j) = ext_conv(i,j) + extended(ii,jj) * kernel(mm,nn)
                end if
             end do

          end do
       end do
    end do

    do j=1, dim_x
       do i=1, dim_y
          conv(i,j) = ext_conv(2+i,2+j)
       end do
    end do

  end subroutine convolution_2D_mirror

  ! Return a contiguous flattened 1D array from a 2D array
  subroutine ravel_2D(map, vector, dim_y, dim_x)
    implicit none

    integer, intent(in) :: dim_y, dim_x
    real(xp), intent(in), dimension(:,:), allocatable :: map
    real(xp), intent(inout), dimension(:), allocatable :: vector

    integer :: j, k, i__

    i__ = 1

    do k=1, dim_x
       do j=1, dim_y
             vector(i__) = map(j,k)
             i__ = i__ + 1
       end do
    end do
  end subroutine ravel_2D

  ! Return a contiguous flattened 1D array from a 3D array
  subroutine ravel_3D(cube, vector, dim_v, dim_y, dim_x)
    implicit none

    integer, intent(in) :: dim_v, dim_y, dim_x
    real(xp), intent(in), dimension(:,:,:), allocatable :: cube
    real(xp), intent(inout), dimension(:), allocatable :: vector

    integer :: i, j, k, i__

    i__ = 1

    do k=1, dim_x
       do j=1, dim_y
          do i=1, dim_v
             vector(i__) = cube(i,j,k)
             i__ = i__ + 1
          end do
       end do
    end do
  end subroutine ravel_3D

  ! Return a 3D array from a contiguous flattened 1D array
  subroutine unravel_3D(vector, cube, dim_v, dim_y, dim_x)
    implicit none

    integer, intent(in) :: dim_v, dim_y, dim_x
    real(xp), intent(in), dimension(:), allocatable :: vector
    real(xp), intent(inout), dimension(:,:,:), allocatable :: cube

    integer :: i, j, k, i__

    i__ = 1

    do k=1, dim_x
       do j=1, dim_y
          do i=1, dim_v
             cube(i,j,k) = vector(i__)
             i__ = i__ + 1
          end do
       end do
    end do
  end subroutine unravel_3D

  ! Return a contiguous flattened 1D array from a 3D array
  subroutine ravel_3D_abs(cube, cube_abs, vector, dim_v, dim_y, dim_x)
    implicit none

    integer, intent(in) :: dim_v, dim_y, dim_x
    real(xp), intent(in), dimension(:,:,:), allocatable :: cube, cube_abs
    real(xp), intent(inout), dimension(:), allocatable :: vector

    integer :: i, j, k, i__

    i__ = 1

    do k=1, dim_x
       do j=1, dim_y
          do i=1, dim_v
             vector(i__) = cube(i,j,k)
             i__ = i__ + 1
          end do
       end do
    end do

    do k=1, dim_x
       do j=1, dim_y
          do i=1, dim_v
             vector(i__) = cube_abs(i,j,k)
             i__ = i__ + 1
          end do
       end do
    end do

  end subroutine ravel_3D_abs

  ! Return a 3D array from a contiguous flattened 1D array
  subroutine unravel_3D_abs(vector, cube, cube_abs, dim_v, dim_y, dim_x)
    implicit none

    integer, intent(in) :: dim_v, dim_y, dim_x
    real(xp), intent(in), dimension(:), allocatable :: vector
    real(xp), intent(inout), dimension(:,:,:), allocatable :: cube, cube_abs

    integer :: i, j, k, i__

    i__ = 1

    do k=1, dim_x
       do j=1, dim_y
          do i=1, dim_v
             cube(i,j,k) = vector(i__)
             i__ = i__ + 1
          end do
       end do
    end do

    do k=1, dim_x
       do j=1, dim_y
          do i=1, dim_v
             cube_abs(i,j,k) = vector(i__)
             i__ = i__ + 1
          end do
       end do
    end do

  end subroutine unravel_3D_abs

  pure function mean(array)
    !! Compute the mean of a 1D array
    implicit none

    real(xp), intent(in), dimension(:) :: array !! 1D array
    real(xp) :: mean

    mean = sum(array)/(max(1,size(array)))

    return
  end function mean

  pure function std(array)
    !! Compute the STD of a 1D array
    implicit none

    real(xp), intent(in), dimension(:) :: array !! 1D array
    integer :: i
    integer :: n
    real(xp) :: std !! standard deviation
    real(xp) :: mean
    real(xp) :: var

    mean = 0._xp; var = 0._xp
    std = 0._xp

    n = size(array)
    mean = sum(array) / n

    do i=1, n
       var = var + (array(i) - mean)**2._xp
    end do

    var = var / (n - 1)
    std = sqrt(var)

    return
  end function std

  function std_2D(map, dim_y, dim_x)
    !! Compute the STD of a 2D map
    implicit none

    integer, intent(in) :: dim_y !! dimension along spatial axis y
    integer, intent(in) :: dim_x !! dimension along spatial axis x
    real(xp), intent(in), dimension(:,:), allocatable :: map !! 2D array
    real(xp), dimension(:), allocatable :: vector !! 1D array
    real(xp) :: std_2D

    allocate(vector(dim_y*dim_x))

    call ravel_2D(map, vector, dim_y, dim_x)
    std_2D = std(vector)

    deallocate(vector)

  end function std_2D

  function max_2D(map, dim_y, dim_x)
    !! Compute the MAX of a 2D map
    implicit none

    integer, intent(in) :: dim_y !! dimension along spatial axis y
    integer, intent(in) :: dim_x !! dimension along spatial axis x
    real(xp), intent(in), dimension(:,:), allocatable :: map !! 2D array
    real(xp), dimension(:), allocatable :: vector !! 1D array
    real(xp) :: max_2D

    allocate(vector(dim_y*dim_x))

    call ravel_2D(map, vector, dim_y, dim_x)
    max_2D = maxval(vector)

    deallocate(vector)

  end function max_2D

  function mean_2D(map, dim_y, dim_x)
    !! Compute the MEAN of a 2D map
    implicit none

    integer, intent(in) :: dim_y !! dimension along spatial axis y
    integer, intent(in) :: dim_x !! dimension along spatial axis x
    real(xp), intent(in), dimension(:,:), allocatable :: map !! 2D array
    real(xp), dimension(:), allocatable :: vector !! 1D array
    real(xp) :: mean_2D

    allocate(vector(dim_y*dim_x))

    call ravel_2D(map, vector, dim_y, dim_x)
    mean_2D = mean(vector)

    deallocate(vector)

  end function mean_2D

end module mod_array


program main
    use fem
    implicit none

    type(FEMDomain_) :: obj1
    type(FEMDomain_) :: obj2
    type(FEMDomain_) :: obj3
    type(FEMDomain_) :: obj4
    type(FEMDomain_) :: obj5

    ! create FEM domain entities

    ! -----> 1D
    call obj1%create(meshtype="Bar1D",x_num=10,x_len=10.0d0)

    ! -----> 2D
    call obj2%create(meshtype="rectangular2D",x_num=12,y_num=12,x_len=5.0d0,y_len=50.0d0)
    call obj2%gmsh(Name="obj2")

    ! -----> 3D
    call obj3%create(meshtype="Cube",x_num=10,y_num=12,z_num=10,x_len=5.0d0,y_len=50.0d0,z_len=10.0d0)

    ! export .pos for Gmsh
    call obj3%gmsh(Name="obj3")

    call obj4%create(meshtype="Sphere",x_num=10,y_num=10,z_num=10,x_len=5.0d0,y_len=50.0d0,z_len=10.0d0)
    call obj4%resize(x=1.0d0,y=1.0d0,z=1.0d0)
    ! export .pos for Gmsh
    call obj4%gmsh(Name="obj4")

    ! move 1.0 to x direction
    call obj4%move(x=1.0d0)

    ! rotate 30.0 degrees around x-axis
    call obj4%rotate(y=radian(30.0d0) )

    ! copy obj4 to obj5
    call obj5%copy(obj4)
    call obj5%resize(x=10.0d0,y=10.0d0,z=10.0d0)
    call obj5%gmsh(Name="obj5")

    ! remove obj5
    call obj5%remove()

    ! Create cylinder mesh
    call obj5%create(meshtype="Cylinder",x_num=10,y_num=10,z_num=10,x_len=5.0d0,y_len=50.0d0,z_len=10.0d0)
    call obj5%resize(x=10.0d0,y=10.0d0,z=10.0d0)
    call obj5%gmsh(Name="obj5_1")

    ! export as JSON file
    call obj5%json("obj5.json",endl=.true.)

end program main


!***********************************/
!	Name:計算格子のセル体積を計算するプログラム
!	Alias:CalcEdgeArea
!	Description:1次元の場合格子の幅を用いる
!	Type:Geom
!	Input:Geom%Width
!	Output:Geom＆%Volume
!	Note:
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2017.11.09
!	Other:
!***********************************/
subroutine CalcVolume(Geom)
use StructVar_Mod
use LoopVar_Mod
implicit none
    type(Geometry),intent(inout) :: Geom

    Geom%Volume(1) = 1.0d0

    do iLoop=1, Geom%Dimension
        Geom%Volume(1) = Geom%Volume(1) * 2.0d0*Geom%Width(1,1,iLoop)
    end do

return
end subroutine CalcVolume


!{ dg-do run }
! Tests namelist on complex variables
! provided by Paul Thomas - pault@gcc.gnu.org
program namelist_16
  complex(kind=8), dimension(2)  ::   z
  namelist /mynml/ z
  z = (/(1.0,2.0), (3.0,4.0)/)

  open (10, status = "scratch")
  write (10, '(A)') "&mynml z(1)=(5.,6.) z(2)=(7.,8.) /"
  rewind (10)

  read (10, mynml, iostat = ier)
  if (ier .ne. 0) call abort ()
  close (10)

  open (10, status = "scratch")
  write (10, mynml, iostat = ier)
  if (ier .ne. 0) call abort ()
  rewind (10)

  z = (/(1.0,2.0), (3.0,4.0)/)
  read (10, mynml, iostat = ier)
  if (ier .ne. 0) call abort ()
  close (10)

  if ((z(1) .ne. (5.0,6.0)) .or. (z(2) .ne. (7.0,8.0))) call abort ()

end program namelist_16


!! # check to see if value exceeds threshold

integer function fclaw2d_clawpatch_minmax_exceeds_th(blockno,&
                                     qval,qmin,qmax,quad, &
                                     dx,dy,xc,yc,threshold, &
                                     init_flag, is_ghost)
    implicit none

    double precision :: qval,qmin,qmax,threshold
    double precision :: quad(-1:1,-1:1)
    double precision :: dx,dy, xc, yc
    integer :: blockno, init_flag
    logical(kind=4) :: is_ghost

    integer :: refine

    refine = 0

    if (qmax-qmin .gt. threshold) then
        refine = 1
    endif

    fclaw2d_clawpatch_minmax_exceeds_th = refine

end function fclaw2d_clawpatch_minmax_exceeds_th


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: func @_QPtranspose_test(
! CHECK-SAME: %[[source:.*]]: !fir.ref<!fir.array<2x3xf32>>{{.*}}) {
subroutine transpose_test(mat)
! CHECK:  %[[resultDescr:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x?xf32>>>
   real :: mat(2,3)
   call bar_transpose_test(transpose(mat))
! CHECK:  %[[sourceBox:.*]] = fir.embox %[[source]]({{.*}}) : (!fir.ref<!fir.array<2x3xf32>>, !fir.shape<2>) -> !fir.box<!fir.array<2x3xf32>>
! CHECK:  %[[zeroArray:.*]] = fir.zero_bits !fir.heap<!fir.array<?x?xf32>
! CHECK:  %[[c0:.*]] = arith.constant 0 : index
! CHECK:  %[[shapeResult:.*]] = fir.shape %[[c0]], %[[c0]] : (index, index) -> !fir.shape<2>
! CHECK:  %[[resultBox:.*]] = fir.embox %[[zeroArray]](%[[shapeResult]]) : (!fir.heap<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.heap<!fir.array<?x?xf32>>>
! CHECK:  fir.store %[[resultBox]] to %[[resultDescr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
! CHECK:  %[[resultOpaque:.*]] = fir.convert %[[resultDescr]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<none>>
! CHECK:  %[[sourceOpaque:.*]] = fir.convert %[[sourceBox]] : (!fir.box<!fir.array<2x3xf32>>) -> !fir.box<none>
! CHECK:  %{{.*}} = fir.call @_FortranATranspose(%[[resultOpaque]], %[[sourceOpaque]], %{{.*}}, %{{.*}}) : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.ref<i8>, i32) -> none
! CHECK:  %[[tmp1:.*]] = fir.load %[[resultDescr]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>
! CHECK:  %[[tmp2:.*]] = fir.box_addr %[[tmp1]] : (!fir.box<!fir.heap<!fir.array<?x?xf32>>>) -> !fir.heap<!fir.array<?x?xf32>>
! CHECK:  %[[tmp3:.*]] = fir.convert %[[tmp2]] : (!fir.heap<!fir.array<?x?xf32>>) -> !fir.ref<!fir.array<3x2xf32>>
! CHECK:  fir.call @_QPbar_transpose_test(%[[tmp3]]) : (!fir.ref<!fir.array<3x2xf32>>) -> ()
! CHECK:  fir.freemem %[[tmp2]] : <!fir.array<?x?xf32>
end subroutine


module node_mod
    use, intrinsic :: iso_fortran_env
    implicit none

    private
    integer, parameter :: sp = REAL32
    type, public :: node_type
        private
        real(kind=sp) :: value = 0.0_sp
        class(node_type), pointer :: left => null(), right => null()
    contains
        procedure, nopass, public :: new
        procedure, public :: set_left
        procedure, public :: get_left
        procedure, public :: set_right
        procedure, public :: get_right
        procedure, public :: set_value
        procedure, public :: get_value
        procedure, public :: show
        procedure, public :: init_random
        procedure, public :: count_nodes
        procedure, public :: leaf_distance
        procedure, public :: finalize
        procedure :: show_level
    end type node_type

contains

    function new() result(node)
        implicit none
        class(node_type), pointer :: node
        integer :: status
        allocate(node, source=node_type(0.0_sp, null(), null()), &
                 stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt="(A)") &
                    "# error: can not allocate node"
            stop
        end if
    end function new

    function get_value(node) result(value)
        implicit none
        class(node_type), intent(in) :: node
        real(kind=sp) :: value
        value = node%value
    end function get_value

    subroutine set_value(node, value)
        implicit none
        class(node_type), intent(inout) :: node
        real(kind=sp), intent(in) :: value
        node%value = value
    end subroutine set_value

    function get_left(node) result(child)
        implicit none
        class(node_type), intent(in) :: node
        class(node_type), pointer :: child
        child => node%left
    end function get_left

    subroutine set_left(node, child)
        implicit none
        class(node_type), intent(inout) :: node
        class(node_type), target, intent(in) :: child
        node%left => child
    end subroutine set_left

     subroutine set_right(node, child)
        implicit none
        class(node_type), intent(inout) :: node
        class(node_type), target, intent(in) :: child
        node%right => child
    end subroutine set_right

    function get_right(node) result(child)
        implicit none
        class(node_type), intent(in) :: node
        class(node_type), pointer :: child
        child => node%right
    end function get_right

    subroutine show(node)
        implicit none
        class(node_type), intent(in) :: node
        character(len=0) :: indent = ""
        call node%show_level(indent)
    end subroutine show

    recursive subroutine show_level(node, indent)
        implicit none
        class(node_type), intent(in) :: node
        character(len=*), intent(in) :: indent
        class(node_type), pointer :: child
        write (unit=output_unit, fmt="(A, F6.3)") indent, node%get_value()
        child => node%get_left()
        if (associated(child)) &
            call child%show_level(indent // '  ')
        child => node%get_right()
        if (associated(child)) &
            call child%show_level(indent // '  ')
    end subroutine show_level

    recursive subroutine init_random(node, prob, factor, value)
        implicit none
        class(node_type), intent(inout) :: node
        real(kind=sp), intent(in) :: prob, factor
        real(kind=sp), optional, intent(in) :: value
        class(node_type), pointer :: child
        real(kind=sp) :: r
        if (present(value)) then
            r = value
        else
            call random_number(r)
        end if
        call node%set_value(r)
        call random_number(r)
        if (r < prob) then
            child => node%new()
            call node%set_left(child)
            call child%init_random(prob*factor, factor)
        end if
        call random_number(r)
        if (r < prob) then
            child => node%new()
            call node%set_right(child)
            call child%init_random(prob*factor, factor)
        end if
    end subroutine init_random

    recursive function count_nodes(node) result(count)
        implicit none
        class(node_type), intent(in) :: node
        integer :: count
        class(node_type), pointer :: child
        count = 1
        child => node%get_left()
        if (associated(child)) &
            count = count + child%count_nodes()
        child => node%get_right()
        if (associated(child)) &
            count = count + child%count_nodes()
    end function count_nodes

    recursive function leaf_distance(node) result(dist)
        implicit none
        class(node_type), intent(in) :: node
        real(kind=sp) :: dist
        class(node_type), pointer :: child
        real(kind=sp) :: path1, path2
        path1 = node%get_value()
        path2 = node%get_value()
        child => node%get_left()
        if (associated(child)) &
            path1 = path1 + child%leaf_distance()
        child => node%get_right()
        if (associated(child)) &
            path2 = path2 + child%leaf_distance()
        dist = max(path1, path2)
    end function leaf_distance

    recursive subroutine finalize(node)
        implicit none
        class(node_type), intent(inout) :: node
        class(node_type), pointer :: child
        child => node%get_left()
        if (associated(child)) then
            call child%finalize()
            deallocate(child)
        end if
        child => node%get_right()
        if (associated(child)) then
            call child%finalize()
            deallocate(child)
        end if
    end subroutine finalize

end module node_mod


program main

!*****************************************************************************80
!
!!  MAIN is the main program for WAVE_MPI.
!
  use mpi

  integer ( kind = 4 ) id
  integer ( kind = 4 ) ierr
  integer ( kind = 4 ) p
  double precision :: wtime

  call MPI_Init ( ierr )

  call MPI_Comm_rank ( MPI_COMM_WORLD, id, ierr )

  call MPI_Comm_size ( MPI_COMM_WORLD, p, ierr )

  if ( id == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  WAVE_MPI:'
    write ( *, '(a)' ) '  FORTRAN90/MPI version.'
    write ( *, '(a)' ) '  Solve the 1D time-dependent wave equation.'
  end if
!
!  Record the starting time.
!
  if ( id == 0 ) then
    wtime = MPI_Wtime ( )
  end if

  call solution ( id, p )
!
!  Record the final time.
!
  if ( id == 0 ) then
    wtime = MPI_Wtime ( ) - wtime
    write ( *, '(a)' ) ' '
    write ( *, '(a,g14.6)' ) '  Wall clock elapsed seconds = ', wtime
  end if
!
!  Terminate MPI.
!
  call MPI_Finalize ( ierr )
!
!  Terminate.
!
  if ( id == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'WAVE_MPI:'
    write ( *, '(a)' ) '  Normal end of execution.'
  end if

  stop
end

!***********************************************************************************
subroutine solution ( id, p )

!
!! SOLUTION computes the solution of the 1D wave equation.
!

  use mpi

  integer , parameter :: n = 100
  double precision ::  Transition_wave(1:800)
  double precision ::  Exact_sol(1:800)
  double precision ::  u_ex(1:n)
  double precision ::  u(0:n+1)
  double precision ::  u_new(1:n)
  integer :: i
  integer :: id
  integer :: p
  double precision :: initial_condition
  integer :: j
  integer :: j_max
  integer :: j_min
  integer :: k
  integer :: l
  integer :: status(MPI_STATUS_SIZE)
  integer :: tag
  double precision ::  time
  double precision ::  time_delta
  double precision ::  time_max
  double precision ::  time_min
  double precision ::  time_new
  double precision ::  x(0:n+1)
  double precision ::  x_delta
  double precision ::  x_max
  double precision ::  x_min
  double precision ::  Nc
  double precision, parameter :: c=0.5006257822277846d0, kh=0.5d0,alp=8.0d0
  character*11 :: filestr

  j_max = 400
  j_min = 0
  time_max = 5.0D+00
  time_min = 0.0D+00
  x_max = 5.0D+00
  x_min = 0.0D+00
!
!  Have process 0 print out some information.
!
  if ( id == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  Compute an approximate solution to the time dependent'
    write ( *, '(a)' ) '  one dimensional wave equation:'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '    du/dt - c * du/dx = 0 '
    write ( *, '(a)' ) ' '
    write ( *, '(a,g14.6,a,g14.6)' ) &
    '  for ', x_min, ' = x_min < x < x_max = ', x_max
    write ( *, '(a)' ) ' '
    write ( *, '(a,g14.6,a,g14.6)' ) &
    '  and ', time_min, ' = time_min < t <= t_max = ', time_max
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  Initial condition is specified at time_min.'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  The finite difference method is used to discretize'
    write ( *, '(a)' ) '  internal points of the differential equation.'
    write ( *, '(a)' ) '  and Forward diference for left boundary and Backward for right boundary'
    write ( *, '(a)' ) '  '
    write ( *, '(a,i8,a)' ) '  This uses', p * n, ' equally spaced points in X'
    write ( *, '(a,i8,a)' ) '  and', j_max, ' equally spaced points in time.'
    write ( *, '(a)' ) ' '
    write ( *, '(a,i8,a)' ) &
      '  Parallel execution is done using', p, ' processors.'
    write ( *, '(a)' ) '  Domain decomposition is used.'
    write ( *, '(a,i8,a)' ) '  Each processor works on', n, ' nodes,'
    write ( *, '(a)' ) &
      '  and shares some information with its immediate neighbors.'
  end if
!
!  Set the X coordinates of the N nodes.
!  We don't actually need ghost values of X but we'll throw them in
!  as X(0) and X(N+1).

  do i = 0, n + 1
    x(i) = ( dble ( id * n + i - 1 ) * x_max + dble ( p * n - id * n - i ) * x_min ) / dble (p * n - 1 )
  end do

  time_delta = ( time_max - time_min ) / dble ( j_max - j_min )
  x_delta = ( x_max - x_min ) / dble ( p * n - 1 )

  Nc = c * time_delta/x_delta
  print*, "CFL number is:", Nc
!  Set the values of u at the initial time.
!
  time = time_min

  u(0) = 0.0D+00
  do i = 1, n

    u(i) = dexp(-alp * (x(i)-1.0d0)**2) * dsin(kh * (x(i)) / x_delta)

  end do
  u(n+1) = 0.0D+00

!  Compute the values of u at the next time, based on current data.

  do j = 1, j_max

    time_new = ( dble(j - j_min ) * time_max + dble( j_max - j) * time_min ) / dble ( j_max - j_min )

!   Send u(1) to ID-1.

    if ( id > 0 ) then
      tag = 1
      call MPI_Send ( u(1), 1, MPI_DOUBLE_PRECISION, id-1, tag, &
        MPI_COMM_WORLD, ierr )
    end if

!   Receive u(N+1) from ID+1.

    if ( id < p - 1 ) then
      tag = 1
      call MPI_Recv ( u(n+1), 1,  MPI_DOUBLE_PRECISION, id+1, tag, &
        MPI_COMM_WORLD, status, ierr )
    end if

!   Send u(N) to ID+1.

    if ( id < p - 1 ) then
      tag = 2
      call MPI_Send ( u(n), 1, MPI_DOUBLE_PRECISION, id+1, tag, &
        MPI_COMM_WORLD, ierr )
    end if

!   Receive u(0) from ID-1.

    if ( 0 < id ) then
      tag = 2
      call MPI_Recv ( u(0), 1, MPI_DOUBLE_PRECISION, id-1, tag, &
        MPI_COMM_WORLD, status, ierr )
    end if

    call MPI_Barrier(MPI_COMM_WORLD, ierr)

!   Update the temperature based on the four point stencil.

    do i = 1, n

      u_new(i) = u(i) - 0.5d0 * Nc * (u(i+1) - u(i-1)) + 0.5d0 * Nc**2 * (u(i+1) -2*u(i) + u(i-1))

    end do

!   u at the extreme left and right boundaries was incorrectly computed
!   using the differential equation.  Replace that calculation by
!   the boundary conditions.

    if ( 0 == id ) then
    !Forward differencing
      u_new(1) = u(1) - c * time_delta * (u(2)-u(1)) / x_delta
    end if

    if ( id == p - 1 ) then
    !Backward differencing
      u_new(n) = u(n) - c * time_delta * (u(n)-u(n-1)) / x_delta

    end if

    !exact solution
    do k = 1,n
        u_ex(k) = dexp(-alp * ((x(k)-c * time)-1.0d0)**2) * dsin(kh * (x(k)-c * time) / x_delta)
    end do

    !use gather library to send message to rank zero
    call MPI_Gather( u_new, n, MPI_DOUBLE_PRECISION, Transition_wave, n, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr )
    call MPI_Gather( u_ex, n, MPI_DOUBLE_PRECISION, Exact_sol, n, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr )

    if (id == 0) then

    filestr(1:1) = 't'
    filestr(2:2) = ACHAR(48+int(time/100000))
    filestr(3:3) = ACHAR(48+int(time/10000)-10*int(time/100000))
    filestr(4:4) = ACHAR(48+int(time/1000)-10*int(time/10000))
    filestr(5:5) = ACHAR(48+int(time/100)-10*int(time/1000))
    filestr(6:6) = ACHAR(48+int(time/10)-10*int(time/100))
    filestr(7:7) = ACHAR(48+int(time/1)-10*int(time/100))
    filestr(8:11) = '.dat'

    open(1,file = filestr, status = 'replace')
    write(1,*) 'Variable = Numerical Solution, Exact Solution'

    do l = 1, 800
    write (1,*)  Transition_wave(l), Exact_sol(l)
    enddo

    close(1)

    end if

    !Update time and temperature.
    time = time_new
    u(1:n) = u_new(1:n)
    u(0) = 0.0D+00
    u(n+1) = 0.0D+00

  end do

  return
end

function initial_condition ( x, time, x_delta )

!*****************************************************************************80
!
!! INITIAL_CONDITION evaluates the initial conditions.
!
!  Parameters:
!
!    Input, real  X, TIME, grid spacing.
!
!    Output, real  INITIAL_CONDITION, the initial condition.
!
  implicit none

  double precision:: initial_condition
  double precision :: time
  double precision :: x
  double precision, parameter :: c=2.5d0, kh=0.5d0,alp=8.0d0
  double precision :: x_delta

  initial_condition = dexp(-alp * ((x-c * time)-1.0d0)**2) * dsin(kh * (x-c * time) / x_delta)

  return
end

subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.

!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


program test_intrinsic_leadz
   implicit none

   call test_leadz(0_1,0_2,0_4,0_8,1_1,1_2,1_4,1_8,8_1,8_2,8_4,8_8)
   stop

   contains

        subroutine test_leadz(z1,z2,z4,z8,i1,i2,i4,i8,e1,e2,e4,e8)
           integer(kind=1) :: z1, i1, e1
           integer(kind=2) :: z2, i2, e2
           integer(kind=4) :: z4, i4, e4
           integer(kind=8) :: z8, i8, e8

           if (leadz(0_1) /=  8) call abort()
           if (leadz(0_2) /= 16) call abort()
           if (leadz(0_4) /= 32) call abort()
           if (leadz(0_8) /= 64) call abort()

           if (leadz(1_1) /=  7) call abort()
           if (leadz(1_2) /= 15) call abort()
           if (leadz(1_4) /= 31) call abort()
           if (leadz(1_8) /= 63) call abort()

           if (leadz(8_1) /=  4) call abort()
           if (leadz(8_2) /= 12) call abort()
           if (leadz(8_4) /= 28) call abort()
           if (leadz(8_8) /= 60) call abort()

           if (leadz(z1) /=  8) call abort()
           if (leadz(z2) /= 16) call abort()
           if (leadz(z4) /= 32) call abort()
           if (leadz(z8) /= 64) call abort()

           if (leadz(i1) /=  7) call abort()
           if (leadz(i2) /= 15) call abort()
           if (leadz(i4) /= 31) call abort()
           if (leadz(i8) /= 63) call abort()

           if (leadz(e1) /=  4) call abort()
           if (leadz(e2) /= 12) call abort()
           if (leadz(e4) /= 28) call abort()
           if (leadz(e8) /= 60) call abort()
        end subroutine test_leadz

end program