program hts2d
! Adding modules
use solver
use parmesh
use chars
use physics
use parsolvers
! use constants
use state
implicit none
!
! HTS2D is a Fortran 95/03 implementation, of GMRES method to solve a linear
!system that comes from the discretization of a physical domain, under heat
!transfer problems. This program is modular so feel free to mess around and
!create another subroutines. I'll look forward for it.
!
!       Programmer: Paulo Conci                Date: 23/03/16
!                                       Last modify: 29/03/18
!
! Declaring all variables used in this file(program), and some used in subrou-
!tines.
!
! Counting variables
   integer*4 :: stat, lin, cls, i, j, nz_num, delt
   integer*4 :: nodes
!
! Time variables
    real(kind=8) :: time_phsc, tm
    integer(kind=8) :: cnt1, cnt2, rate_cnt, cnt_max, nb_ticks
    real(kind=8), allocatable, dimension(:) :: time
!
! Mesh variables
   real*8, allocatable, dimension(:,:) :: msh
   real*8, allocatable, dimension(:,:) :: msh_copy
   real*8 :: n, dxdy
!
! Iterative Method Variables
   character(len=30) :: fout
   character(len=60) :: dirname, dname, dir
   integer(kind=4) :: iwk, ierr, im, getcwd
   real*8 ::  normt
   real*8, allocatable, dimension(:,:) :: alin
   integer(kind=4), allocatable, dimension(:,:) :: conn
   integer(kind=4), allocatable, dimension(:,:) :: connfth
   real*8, allocatable, dimension(:) :: rhs
   real*8, allocatable, dimension(:) :: x
   real*8, allocatable, dimension(:) :: x0
   real*8, allocatable, dimension(:) :: x_exact
   integer*4, allocatable, dimension(:) :: ia
   integer*4, allocatable, dimension(:) :: ja
   real*8, allocatable, dimension(:) :: a
   real*8, allocatable, dimension(:) :: t
   real(kind=8), allocatable, dimension(:) :: ao
   integer(kind=4), allocatable, dimension(:) :: iao
   integer(kind=4), allocatable, dimension(:) :: jao
   integer(kind=4), allocatable, dimension(:) :: ju
   real(kind=8), allocatable, dimension(:) :: wu
   real(kind=8), allocatable, dimension(:) :: wl
   real(kind=8), allocatable, dimension(:) :: alu
   real(kind=8), allocatable, dimension(:,:) :: vv
   real(kind=8), allocatable, dimension(:) ::w
   integer(kind=4), allocatable, dimension(:) :: jr
   integer(kind=4), allocatable, dimension(:) :: jwl
   integer(kind=4), allocatable, dimension(:) :: jwu
   integer(kind=4), allocatable, dimension(:) :: jlu
   integer(kind=4), allocatable, dimension(:) :: iw
   integer(kind=4), allocatable, dimension(:) :: levs
   integer(kind=4), allocatable, dimension(:) :: jw
!
! Defining some name, for lazyness at the time, this was the better solution,
! it will be appreciated ideas to automated this.
    if(choice .eq. 1)then
      write(*,*) 'Solving w/ Gauss Siedel'
      fout = 'residual_gauss_siedel.dat'
      dname = 'gauss'
    elseif(choice .eq. 2)then
      write(*,*) 'Solving w/ GMRES'
      fout = 'residual_gmres.dat'
      dname = 'gmres'
    elseif(choice .eq. 3)then
      write(*,*) 'Solving w/ GMRES p. ILU0'
      fout = 'residual_ilu0.dat'
      dname = 'ilu0'
    elseif(choice .eq. 4)then
      write(*,*) 'Solving w/ GMRES p. ILUT'
      fout = 'residual_ilut.dat'
      dname = 'ilut'
    elseif(choice .eq. 5)then
      write(*,*) 'Solving w/ GMRES p. MILU0'
      fout = 'residual_milu0.dat'
      dname = 'milu'
    elseif(choice .eq. 6)then
      write(*,3) 'Solving w/ GMRES p. ILU', lfil
        if(lfil .eq. 0)then
        dname = 'ilu0'
        fout = 'residual_ilu0.dat'
        elseif(lfil .eq. 1)then
        dname = 'ilu1'
        fout = 'residual_ilu1.dat'
        elseif(lfil .eq. 2)then
        dname = 'ilu2'
        fout = 'residual_ilu2.dat'
        elseif(lfil .eq. 3)then
        dname = 'ilu3'
        fout = 'residual_ilu3.dat'
        elseif(lfil .eq. 4)then
        dname = 'ilu4'
        fout = 'residual_ilu4.dat'
        else
        dname = 'iluk'
        fout = 'residual_iluk.dat'
        endif
    endif
3 format(a, I1)
    if(transient .eq. 1)then
      write(*,*) 'Unsteady State'
    elseif(transient .eq. 0)then
      write(*,*) 'Steady State'
    endif
!
! Creating directories and open files to read the mesh file and write out the
!solution. This is literally where everything starts.
    call execute_command_line('mkdir -p ' // adjustl(trim(dname)))
!    call execute_command_line('pwd ')
    stat = getcwd(dir)
    if(stat .ne. 0 )stop 'getcwd: error'
!
    dirname = adjustl(adjustr(trim(trim(dir)//'/'//trim(dname)//'/')))
    dirname = trim(adjustl(trim(dirname)))
!
    open(unit=2, file=mshdir//meshfile, status= 'old', iostat = stat)
    open(unit=43, file= trim(adjustl(trim(dirname))//'residual_timemachine.plt'), status='unknown')
    open(unit=44, file= trim(adjustl(trim(dirname))//'residual_iteration.plt'), status='unknown')
    open(unit=45, file= trim(adjustl(trim(dirname))//'residual_timephysics.plt'), status='unknown')
    open(unit=80, file= trim(adjustl(trim(dirname))//savename), status='unknown')
!
! Counting how many number are on the mesh file
!for allocate after (this will use only the necessary memory)
  if(stat .eq. 0) then
    nodes=0
    do
      read (2, *, iostat = stat) n
      if(stat .ne. 0)exit
      nodes = nodes + 1
    end do
  endif
!
!Allocating the memory for mesh, linear system and solution.
   allocate (msh(nodes,4))
   allocate (msh_copy(nodes,4))
   allocate (alin(nodes,nodes))
   allocate (rhs(nodes))
   allocate (t(nodes))
   allocate (x(nodes))
   allocate (x0(nodes))
   allocate (time(itr_max))
   allocate (conn(nodes,9))
   ! allocate (connfth(nodes,9))
!
!This will reopen unit two for avoiding reading errors.
  rewind (unit=2)
!
!Reading matrix of nodes
  read(2,*, iostat=stat) ((msh(lin,cls), cls=1,4), lin=1,nodes)
  if (stat .eq. 0)then
! This print the mesh file on screen, uncomment for debug
!	write(*,300) ((msh(lin,cls), cls=1,4), lin=1,nodes)
!300 format(4(F20.6))
! This is VERY important for the program to work, dxdy should always be the
! distance between two mesh points, if your mesh file is not ordered in the
! correct way this value will be wrong and crash the solution.
    dxdy = msh(2,2)
  else
    write(*,*)'Error reading matrix', stat
  end if
  do i=1, nodes
!	    msh(i,1) = i
    msh(i,4) = 1.0d0
  enddo
!
  call connect(msh, conn, nodes, dxdy)
  ! call connect4th(msh,connfth,nodes,dxdy)
  ! write(*,13) ((conn(i,j),j=1,9),i=1,nodes)
!
!
13 format(9(I4))
! proportion bb
!    do i = 1, nodes
!        msh(i,2) = 1.d3 * msh(i,2)
!        msh(i,3) = 1.d3 * msh(i,3)
!    enddo
!
!Defining initial parameter for denominator of norm temperature
    x0(1:nodes) = msh(1:nodes,4)
!Setting the boundary conditions, msh is an intent(inout)
    call bound_cond(msh, nodes)
!Iniciating the allocatable matrix for avoiding errors
    msh_copy = msh
    x(1:nodes) = msh(1:nodes,4)
!
! write(*,*) "HEEEEELLLLLOOOOO MATTY D"
!Here is the critical part, it's where we read all nodes of mesh and
!them generate one equation for each node, that is a finite difference
!equation, we are allocating in alin(i,j) only the the constants terms
!that multiplicate the temperature value, this alin matrix have the
!dimension of (nodes,nodes) and must be square matrix, here we have a
!little problem because we must identifying the neibourhood nodes,
!and for that it is necessary to identifying them.
! Initializind the time variables
    delt = 0
    cnt1 = 0
    cnt2 = 0
    cnt_max = 1000000000
    rate_cnt = 1000
    call system_clock(count_rate=rate_cnt, count_max=cnt_max)
!
!    call cpu_time(start_time)
    call system_clock(count=cnt1)
!    call cpu_time(init_time)
! LOOOOOOOOOOOOOOOOOOOP
5 continue
!
!getting out of the loop on steady state
    if((delt .ne. 0) .and. (transient .eq. 0))then
        goto 25
    endif
!
! Saving a copy of the initial values of solution to mensurate how the method
!is behaving
  t(1:nodes) = x(1:nodes)
!
! Starting matrix of constants, at each time step for security
  alin(1:nodes,1:nodes) = 0.0d0
  rhs(1:nodes) = 0.0d0
!
! Subroutine responsible to generate constants, this is still an odd way to do
!it, take and example, if you want to simulate diferent boundary conditions you
!must change this subroutine. At this time is working, but it'll be implemented
!in another more user fliendly way.
  call ccall(conn, nodes, dxdy, alin, rhs, t)
    ! if (choice2 .eq. 1)then
      ! call create_a_unsteady(msh, t, nodes, alin, rhs, dxdy)
    ! elseif(choice2 .eq. 2)then
    ! write(80,12) ((alin(i,j),j=1,nodes),i=1,nodes)
    ! 12 format(25(F10.5))
     ! call create_a_steady(msh, t, nodes, alin, rhs, dxdy)
    ! elseif(choice2 .eq. 3)then
      ! call create_4_steady(msh, t, nodes, alin, rhs, dxdy)
    ! end if
!Iterative methods
!==============================================================================
!solve the linear system with gauss-siedel iterative method
   if (choice .eq. 1)then
!
      call kicks(nodes, x)
!
      call gs(alin, rhs, nodes, x, fout, dirname)
      if(allocated(alin)) deallocate(alin)
!******************************************************************************
! GMRES without preconditioning with no restart, is not working at the time
   elseif (choice .eq. 2)then
!
!      call pre_gmres(alin, nodes, a, ia, ja, nz_num)
!      if(allocated(alin)) deallocate(alin)
!!
!   ind = (nodes+2) - (nz_num+1)
!!
!       if (delt .eq. 0)then
!        allocate(ao(nz_num))
!        allocate(jao(nz_num))
!        allocate(iao(nodes+1))
!      endif
!!
!      call sttocsr ( nodes, nz_num, a, ia, ja, ao, jao, iao )
!      call kicks(nodes, x)
!!
!       if(delt .eq. 0)then
!        iwk = nodes*nodes
!        allocate(alu(nodes*nodes))
!        allocate(jlu(nodes*nodes))
!        allocate(ju(nodes))
!        allocate(jr(nodes+1))
!        allocate(wl(nodes))
!        allocate(jw(nodes*nodes))
!    endif
!
!      call csrmsr ( nodes, ao, jao, iao, alu, jlu, ju, wl, jr )
!
!      if (ierr .eq. 0)then
!            im = 100
!!
!            if(delt .eq. 0)then
!                allocate(vv(nodes,im+1))
!            endif
!!
!!
!      call pgmres(nodes, im, rhs, x, vv, ao, jao, iao, alu, jlu, ju, ierr )
!!
!      if(ierr .ne. 0)then
!         write(*,*) 'Error on GMRES = ', ierr
!      elseif(ierr .eq. 0)then
!         write(*,*) 'Sucessful Solving!'
!      endif
!      endif
!
! Instead we are using a restarted version of GMRES, is no preconditioned, so
!work as test case for the preconditioned version, although, no all orthogonal
!vector are stored. This saves memory, but not improve convergence.
      call pre_gmres(alin, nodes, a, ia, ja, nz_num)
      if(allocated(alin)) deallocate(alin)
!
      call kicks(nodes, x)
!
      call mgmres_st ( nodes, nz_num, ia, ja, a, x, rhs, fout, dirname)
!******************************************************************************
! GMRES preconditioned with ILU0
   elseif(choice .eq. 3) then
!
      call pre_gmres(alin, nodes, a, ia, ja, nz_num)
      if(allocated(alin)) deallocate(alin)
!
    if (delt .eq. 0)then
        allocate(ao(nz_num))
        allocate(jao(nz_num))
        allocate(iao(nodes+1))
    endif
      call sttocsr ( nodes, nz_num, a, ia, ja, ao, jao, iao )
!
   if(delt .eq. 0)then
      allocate(iw(nodes))
      allocate(alu(nodes*nodes))
      allocate(jlu(nodes*nodes))
      allocate(ju(nodes))
   endif
      call ilu0 ( nodes, ao, jao, iao, alu, jlu, ju, iw, ierr )
   if(ierr .ne. 0)then
      write(*,*) 'Error after ILU0 = ', ierr
   endif
!
      call kicks(nodes, x)
!
!
      if (ierr .eq. 0)then
            im = 500
!
            if(delt .eq. 0)then
                allocate(vv(nodes,im+1))
            endif
!
      call pgmres(nodes, im, rhs, x, vv, ao, jao, iao, alu, jlu, ju, fout, ierr, dirname)
!
      if(ierr .ne. 0)then
         write(*,*) 'Error on GMRES ILU0 = ', ierr
      elseif(ierr .eq. 0)then
         write(*,*) 'Sucessful Solving!'
      endif
      endif
!******************************************************************************
!GMRES with ILUT
    elseif(choice .eq. 4)then
!
!storing alin in sparse triplet form
        call pre_gmres(alin, nodes, a, ia, ja, nz_num)
        if(allocated(alin)) deallocate(alin)
!
!storing a(nz_num), ja(nz_num) and ia(nz_num) ia CSR
    if (delt .eq. 0)then
        allocate(ao(nz_num))
        allocate(jao(nz_num))
        allocate(iao(nodes+1))
    endif
        call sttocsr ( nodes, nz_num, a, ia, ja, ao, jao, iao )
!
!setting some parameters of the preconditioner
    if(delt .eq. 0)then
        iwk = nodes*nodes
        allocate(alu(nodes*nodes))
        allocate(jlu(nodes*nodes))
        allocate(ju(nodes))
        allocate(wu(nodes+1))
        allocate(wl(nodes))
        allocate(jr(nodes))
        allocate(jwl(nodes))
        allocate(jwu(nodes))
    endif
!calling the preconditioner ILUT
        call ilut ( nodes, ao, jao, iao, alu, jlu, ju, &
                    iwk, wu, wl, jr, jwl, jwu, ierr )
!
    if(ierr .ne. 0)then
      write(*,*) 'Error after ILUT = ', ierr
    endif
        call kicks(nodes, x)
!
        if (ierr .eq. 0)then
            im = 500
!
            if(delt .eq. 0)then
                allocate(vv(nodes,im+1))
            endif
!
      call pgmres(nodes, im, rhs, x, vv, ao, jao, iao, alu, jlu, ju, fout, ierr, dirname)
!
      if(ierr .ne. 0)then
         write(*,*) 'Error on GMRES w/ ILUT = ', ierr
      elseif(ierr .eq. 0)then
         write(*,*) 'Sucessful Solving!'
      endif
   endif
!******************************************************************************
! GMRES with MILU0
    else if(choice .eq. 5)then
        call pre_gmres(alin, nodes, a, ia, ja, nz_num)
        if(allocated(alin)) deallocate(alin)
!
        if (delt .eq. 0)then
            allocate(ao(nz_num))
            allocate(jao(nz_num))
            allocate(iao(nodes+1))
        endif
            call sttocsr ( nodes, nz_num, a, ia, ja, ao, jao, iao )
!
        if(delt .eq. 0)then
            allocate(alu(nz_num+2))
            allocate(jlu(nz_num+2))
            allocate(ju(nodes))
            allocate(iw(nodes))
        endif
            call milu0( nodes, ao, jao, iao, alu, jlu, ju, iw, ierr )

!
   if (ierr .eq. 0)then
                im = 500
!
        call kicks(nodes, x)
!
                if(delt .eq. 0)then
                    allocate(vv(nodes,im+1))
                endif
!
      call pgmres(nodes, im, rhs, x, vv, ao, jao, iao, alu, jlu, ju, fout, ierr, dirname)
!
      if(ierr .ne. 0)then
         write(*,*) 'Error on GMRES w/ ILU0 = ', ierr
      elseif(ierr .eq. 0)then
         write(*,*) 'Sucessful Solving!'
      endif
   endif
!******************************************************************************
!Gmres w/ iluk
        elseif(choice .eq. 6)then
!
!storing alin in sparse triplet form
        call pre_gmres(alin, nodes, a, ia, ja, nz_num)
        if(allocated(alin)) deallocate(alin)
!
!storing a(nz_num), ja(nz_num) and ia(nz_num) ia CSR
    if (delt .eq. 0)then
        allocate(ao(nz_num))
        allocate(jao(nz_num))
        allocate(iao(nodes+1))
    endif
        call sttocsr ( nodes, nz_num, a, ia, ja, ao, jao, iao )
!
!setting some parameters of the preconditioner
    if(delt .eq. 0)then
        iwk = nodes*nodes
        allocate(alu(iwk))
        allocate(jlu(iwk))
        allocate(ju(nodes))
        allocate(levs(iwk))
        allocate(w(nodes))
        allocate(jw(3*nodes))
    endif
!calling the preconditioner ILUk
!
      call iluk(nodes, ao, jao, iao, alu, jlu, ju, levs, iwk, w, jw, ierr)
!
   if(ierr .ne. 0)then
      write(*,*) 'Error on ILU',lfil,' = ', ierr
   elseif(ierr .eq. 0)then
      write(*,*) 'Sucessful precondiotioning'
   endif
!
   call kicks(nodes, x)
!
   if (ierr .eq. 0)then
            im = 500
!
      if(delt .eq. 0)then
          allocate(vv(nodes,im+1))
      endif
!
   call pgmres(nodes, im, rhs, x, vv, ao, jao, iao, alu, jlu, ju, fout, ierr, dirname)
      if(ierr .ne. 0)then
         write(*,*) 'Error on GMRES w/ ILUK = ', ierr
      elseif(ierr .eq. 0)then
         write(*,*) 'Sucessful Solving'
      endif
   endif
   endif
!******************************************************************************
!Checking the convergence, this is made with a norm L2, with both initial and
!final solution. If the norm is less the *epsolon* (yes I know this is not the
!real word) the program exits the loop and is take the last vector as solution
!for the problem.
   call cvgc(x, x0, t, nodes, normt)
!
   if((normt .lt. epsolon) .and. (delt .ge. itr_max))then
      goto 25
   else if((normt .gt. epsolon) .and. (delt .lt. itr_max))then
!
! Counting how many interations has taken to obtain the solution.
  delt = delt + 1
!
! Mensuring the time your CPU took to obtain each iteration. This is still in
!an early state. But the main goal is to compare how the method takes less time
!to obtain a solution once it get close to the analytical solution.
        call system_clock(count=cnt2)
        nb_ticks = cnt2 - cnt1
        if(cnt2 .lt. cnt1)then
            nb_ticks = nb_ticks + cnt_max
        endif
            time(delt) = dfloat(nb_ticks)/rate_cnt
            time_phsc = delt*deltat
!
        if(delt .eq. 1)then
            tm = time(delt)
        else
            tm = time(delt) - time(delt - 1)
        endif
!
! Writing to files the number of the iteration, and time taken to obtain, the
!norm value and the physical CPU time.
    write(43,*) delt, tm
    write(44,*) delt, normt
    write(45,*) time_phsc, normt
!writing a backup file for power loss or program interruption. Early stages,
!this needs a subroutine to read the file and a parameter to tell if it's a
!new simulation or a old one.
! do i=1, nodes
!     write(80,*) i, x(i)
! enddo
!
! I use TecPlot to plot the graphs, so the value file needs to be formated
!before ploting, to use another ploting program probably you will need
!another format, so feel free to implemente your own subroutine and call it.
        msh(1:nodes,4) = x(1:nodes)
        call temp_time_plot(msh, nodes, dxdy)
        call temp_origin(msh, nodes, delt, dxdy)
!
! Tell the user that and iteration has occur.
        write (*,*) 'Outer Iteration =', delt
!
! Once we deallocate alin inside the iteration process to save memory ( meshs
!with 30k nodes, storing real*8 variables, will need up to 6GB of RAM), we need
!to reallocate that space.
! write(*,*) "heellloooooo"
    allocate(alin(nodes, nodes))
!
    goto 5
   end if
!
!END OF LOOOOOOOOOOOOOOOP
25 continue
!
! Verifying how much time has taken to solve the problem.
    call system_clock(cnt2, rate_cnt, cnt_max)
    write(*,*) 'System Clock = ', real(cnt2 - cnt1) / real(rate_cnt)
!    call cpu_time(finish_time)
!    write(*,*) 'Total time is = ', finish_time - init_time
    msh(1:nodes,4) = x(1:nodes)
!
!    delt = delt + 1
!    write(*,*) 'Outer Iteration =', delt
!
!Printing the values of solution in a file for opening with tecplot
   call tcplt(msh, nodes, filename, dxdy, dirname)
   if(allocated(msh)) deallocate(msh)
!Only for steady cases
!==============================================================================
! Once the problem is simple and has a analytical solution, is possible to
!verified how close are the approximate solution by the numerical method and
!the exact solution to that problem.
  if (choice3 .eq. 1)then
!Calculating the exact solution for steady state case
    allocate(x_exact(nodes))
    if(choice2 .eq. 2 .or. choice2 .eq. 3) then
        call temp_exact(msh_copy, nodes)
        x_exact(1:nodes) = msh_copy(1:nodes,4)
!printing the exact solution
        call tcplt(msh_copy, nodes, filename_exact, dxdy, dirname)
        if(allocated(msh_copy)) deallocate(msh_copy)
!Calculate the logarithm error for the steady state
        call logerror(x, x_exact, nodes, dxdy, dirname)
!    write(*,*) 'type the next mesh file name'
!    read (*,*) meshfile
!    goto3
    elseif(choice2 .eq. 1) then
        call reddy(msh_copy, nodes)
        x_exact(1:nodes) = msh_copy(1:nodes,4)
        call tcplt(msh_copy, nodes, filename_exact, dxdy, dirname)
        if(allocated(msh_copy)) deallocate(msh_copy)
!Calculate the logarithm error for the steady state
        call logerror(x, x_exact, nodes, dxdy, dirname)
    endif
!
  endif
stop
!I guess this is THE END.
end program hts2d


!!$program main
!!$  implicit none
!!$  double precision :: pi,a,b,alpha
!!$  COMPLEX*16, DIMENSION(:), ALLOCATABLE:: in,out
!!$  integer i,n,q,Ly
!!$
!!$  n = 512
!!$  allocate(in(n))
!!$  allocate(out(n))
!!$
!!$  call timestamp ( )
!!$
!!$ ! write ( *, '(a)' ) ' '
!!$  write ( *, '(a)' ) '#FFTW3_PRB'
!!$  write ( *, '(a)' ) '#  FORTRAN77 version'
!!$  write ( *, '(a)' ) '# '
!!$  write ( *, '(a)' ) '#  Demonstrate the use of the FFTW3 library.'
!!$  alpha = 1.0/7.0
!!$  pi = 4.0*atan(1.0)
!!$  q  = 12
!!$  Ly = 256
!!$  do i = 1, n
!!$     a =  cos(cos(2*pi*i*alpha + 2*pi*q/Ly))!r8_uniform_01 ( seed )
!!$     b = -sin(cos(2*pi*i*alpha + 2*pi*q/Ly))!r8_uniform_01 ( seed )
!!$     in(i) = dcmplx ( a, b )
!!$  end do
!!$
!!$  call FFTWinFORTRAN ( in , out,  n )
!!$
!!$  write ( *, '(a)' ) '# '
!!$  write ( *, '(a)' ) '#FFTW3_PRB'
!!$  write ( *, '(a)' ) '#  Normal end of execution.'
!!$
!!$  write ( *, '(a)' ) '# '
!!$  call timestamp ( )
!!$
!!$  stop
!!$end program main

subroutine FFTWinFORTRAN( in, out,n)

!n : vector length
!in: COMPLEX VECTOR IN
!out: fourier components

  implicit none

  integer,intent(in) :: n  !
  complex*16,dimension(n),intent(in)  :: in
  complex*16,dimension(n),intent(out) :: out
  !parameter ( n = 1024 )

  include "fftw3.f"

  double precision a
  double precision b
  double precision r8_uniform_01,pi
  integer i
  complex*16 in2(n)

  integer*8 plan_backward
  integer*8 plan_forward
  integer seed

  seed = 123456789

!!$  write ( *, '(a)' ) '# '
!!$  write ( *, '(a)' ) '# TEST01'
!!$  write ( *, '(a)' ) '#  Demonstrate FFTW3 on a single vector '
!!$  write ( *, '(a)' ) '#  of complex data.'
!!$  write ( *, '(a)' ) '# '
!!$  write ( *, '(a)' ) '#  Transform data to FFT coefficients.'
!!$  write ( *, '(a)' ) '#  Backtransform FFT coefficients to recover'
!!$  write ( *, '(a)' ) '#  the data.'
!!$  write ( *, '(a)' ) '#  Compare recovered data to original data.'

!!$  pi = 4.0*atan(1.0)
!!$  do i = 1, n
!!$     a = cos(2*pi*i/n) + 0.5*cos(4*pi*i/n) + 0.1*sin(3*pi*i/n) + 2.0 + 2.0*cos((n-1)*2*pi*i/(4*n))!r8_uniform_01 ( seed )
!!$     b = 0.0 !r8_uniform_01 ( seed )
!!$     in(i) = dcmplx ( a, b )
!!$  end do

!!$  write ( *, '(a)' ) '# '
!!$  write ( *, '(a)' ) '#  Input Data:'
!!$  write ( *, '(a)' ) '# '
!!$
!!$  do i = 1, n
!!$     write ( *, '(2x,i4,2x,2g14.6)' ) i, in(i)
!!$  end do
!!$  write ( *, '(a)' ) ' '
!!$  write ( *, '(a)' ) ' '

  call dfftw_plan_dft_1d ( plan_forward, n, in, out, &
       &  FFTW_FORWARD, FFTW_ESTIMATE )

  call dfftw_execute ( plan_forward )
  out = out/n

!!$  write ( *, '(a)' ) '# '
!!$  write ( *, '(a)' ) '#  Output FFT Coefficients:'
!!$  write ( *, '(a)' ) '# '
!!$
!!$  do i = 1, n
!!$     write ( *, '(2x,i4,2x,2g14.6)' ) i, out(i)/n
!!$  end do
!!$  write ( *, '(a)' ) ' '
!!$  write ( *, '(a)' ) ' '

!!$  call dfftw_plan_dft_1d ( plan_backward, n, out, in2, &
!!$       &  FFTW_BACKWARD, FFTW_ESTIMATE )
!!$
!!$  call dfftw_execute ( plan_backward )
!!$
!!$  write ( *, '(a)' ) '# '
!!$  write ( *, '(a)' ) '#  Recovered input data divided by N:'
!!$  write ( *, '(a)' ) '# '
!!$
!!$  do i = 1, n
!!$     write ( *, '(2x,i4,2x,2g14.6)' ) i, in2(i) / dble ( n )
!!$  end do
!!$  write ( *, '(a)' ) ' '
!!$  write ( *, '(a)' ) ' '

  call dfftw_destroy_plan ( plan_forward )
!!$  call dfftw_destroy_plan ( plan_backward )

  return
end subroutine FFTWinFORTRAN

function r8_uniform_01 ( seed )

  implicit none

  double precision r8_uniform_01
  integer k
  integer seed

  k = seed / 127773

  seed = 16807 * ( seed - k * 127773 ) - k * 2836

  if ( seed < 0 ) then
     seed = seed + 2147483647
  end if

  r8_uniform_01 = dble ( seed ) * 4.656612875D-10

  return
end function r8_uniform_01

subroutine timestamp ( )

  implicit none

  character ( len = 8 ) date
  character ( len = 10 ) time

  call date_and_time ( date, time )

!  write ( *, '(a8,2x,a10)' ) date, time

  return
end subroutine timestamp


include '../../src/find_mod.f90'

program test_sort
use find_mod
implicit none
    integer                 :: k1                   ! iterator
    double precision        :: tda1(10), tda2(10)   ! double arrays
    integer                 :: tia1(8), tia2(8)     ! integer arrays
    integer, allocatable    :: sid(:)               ! sort_inds

    integer                 :: find_int = 86        ! Value to find
    integer                 :: find_int_ind = 3     ! Position to find (int)
    double precision        :: find_dbl = 0.8592    ! Value to find
    integer                 :: find_dbl_ind = 2     ! Position to find (dbl)
    double precision        :: find_tol = 1.e-3     ! Find tolerance

    logical             :: test_failed = .false.

    ! Functions to test
    ! - find_int_1d - OK
    ! - find_int_2d - OK
    ! - find_dbl_1d_tol - TBA
    ! - find_dbl_2d_tol - TBA
    ! - find_dbl_pt_3d_array - TBA

    tia1 = [14, -56, 86, 3, 94, -44, -55, -68]
    tia1(find_int_ind) = find_int
    tia2 = tia1

    tda1 = [0.45933988, 0.85925698, 0.19866538, 0.19590951, 0.26951959, &
            0.21166847, 0.58193321, 0.54999474, 0.74012868, 0.58838597]
    tda1(find_dbl_ind) = find_dbl
    tda2 = tda1

    if (find(tia1, find_int) /= find_int_ind) then
        write(*,"(A,F0.5,A)") 'Could not find ', find_int, ' in:'
        write(*,*) tia1
        test_failed = .true.
    endif
    if (.not.all(tia1==tia2)) then
        write(*,*) 'call to find affected the searched integer array'
        test_failed = .true.
    endif

    if (find(tda1, find_dbl-find_tol/2, find_tol) /= find_dbl_ind) then
        write(*,"(A,F0.5,A,F0.5,A)") 'Could not find ', find_dbl-find_tol/2, ' with tol = ', find_tol, ' in:'
        write(*,*) tda1
        test_failed = .true.
    endif
    if (.not.all(tda1==tda2)) then
        write(*,*) 'call to find affected the searched double array'
        test_failed = .true.
    endif

    if (test_failed) then
        error stop 1
    else
        stop 0
    endif

end program


program nmodm
  implicit none
  character(32) :: arg
  character(10) :: str
  integer :: stat,n,m,sep
  call get_command_argument(1, arg)
  open (11,file=trim(arg),action='read')
  do
    read (11,'(a)',iostat=stat) str
    if (stat /= 0) exit
    if (str /= '') then
      sep = scan(str,',')
      read (str(1:sep-1),'(i10)') n
      read (str(sep+1:),'(i10)') m
      write (*,'(i0)') n - (n / m) * m
    end if
  end do
  close (11)
end program nmodm


c
c**********************************************************************
c
      subroutine sigslo(q, zions, velect, valpha, omgc, omgp2, omgrf,
     .   sigxx, sigxy, sigxz,
     .   sigyx, sigyy, sigyz,
     .   sigzx, sigzy, sigzz,
     .   xkprl, xkperp, lmin, lmax)

      implicit none

      integer lmin, lmax

      real q, zeff, velect, valpha, omgc, omgp2, omgrf, xkprl, xkperp
      real beta, alfa, xk0, chrg, xkz, rdz, vm, vte, zions, qe,
     .     clight, xmu0, eps0

      complex zi, xkx2,
     .   sigxx, sigxy, sigxz,
     .   sigyx, sigyy, sigyz,
     .   sigzx, sigzy, sigzz

      complex sig(3,3), rdx

      common/slowdist/zeff, vte

      xkz = xkprl
      xkx2 = xkperp**2
      zeff = zions

      qe = -1.6e-19
      eps0 = 8.85e-12
      xmu0 = 1.26e-06
      clight = 1.0 / sqrt(eps0 * xmu0)
      zi = cmplx(0.0, 1.0)
      xk0 = omgrf / clight

      alfa = omgp2 / omgrf**2
      beta = (omgc / omgrf)**2

      chrg = q / abs(qe)

      vm =  valpha / clight
      vte = velect / clight

      rdx = csqrt(xkx2) / xk0
c      rdx = xkperp / xk0
      rdz = xkz / xk0

c      write(6, 11)lmin, lmax
c      write(6, 10)alfa, beta, chrg, vm, rdx, rdz

      call isosig(alfa, beta, chrg, vm, rdx, rdz, lmin, lmax, sig)

      sigxx = sig(1,1) * eps0 * omgrf / zi
      sigxy = sig(1,2) * eps0 * omgrf / zi
      sigxz = sig(1,3) * eps0 * omgrf / zi

      sigyx = sig(2,1) * eps0 * omgrf / zi
      sigyy = sig(2,2) * eps0 * omgrf / zi
      sigyz = sig(2,3) * eps0 * omgrf / zi

      sigzx = sig(3,1) * eps0 * omgrf / zi
      sigzy = sig(3,2) * eps0 * omgrf / zi
      sigzz = sig(3,3) * eps0 * omgrf / zi

c      write(6, 10)sigxx, sigxy, sigxz
c      write(6, 10)sigyx, sigyy, sigyz
c      write(6, 10)sigzx, sigzy, sigzz

      return

   10 format(8e12.4)
   11 format(8i10)

      end

c
c**********************************************************************
c

      subroutine isosig(alfa,beta,chrg,vm,rdx,rdz,nhmin,nhmax,sig)

*     ------------------------------------------------------------------------
*     calculates Hermitian part of dispersion tensor for arbitrary isotropic
*     distribution function of a single plasma species
*
*     sig(i,j) = hermitian part of 4*pi*i/omega*sigma
*
*     alfa=(plasma freq/wave freq)**2 for the given species
*     beta=(cyclotron freq/wave freq)**2
*     chrg=species charge/abs(electron charge) only sgn of chrg is used
*     vmax=maximum velocity of nonzero distribution/speed of light
*     rdx=complex perpendicular refractive index
*     rdz=real parallel refractive index (Plemelj relation assumes kz real)
*     nhmin=minimum harmonic number allowed
*     nhmax=maximum harmonic number allowed
*     note: nmin and nmax are calculated from presence of resonant particles.
*     however, nhmin and nhmax place limits on allowed values
*------------------------------------------------------------------------

      dimension bk(3)
      complex rdx,rx,rx2
      complex sig(3,3),sv(6),v(6),vc(6)
      common /int/rx,rx2,b,bet,vmax,rz,rz2,u,n
c
      external intz1
      data ncall/0/,pi/3.141592654/
c
c
      ncall=ncall+1
      vmax=vm
      bet=beta
      b=chrg*sqrt(beta)/abs(chrg)
      rx=rdx
      rx2=rx**2
      rz=abs(rdz)
      rz2=rz**2
c
      do 10 i=1,6
10    sv(i)=cmplx(0.,0.)
c
c do special case nz=0
c
      if (rz .eq.0.) go to 300
c
c
calculate contribution from each cyclotron harmonic
c
c
c
      do 200 n=nhmin,nhmax
c
c determine if resonant particles exist for this harmonic.  If not
c there is no contribution.
c
      if (abs(1.-n*b).ge. rz*vmax) go to 200
c
      x0=0.
      x1=1.
      np=30
      ndim=6
      call simpc (x0,x1,np,intz1,v,ndim)
c
calculate contribution from velocity cutoff
c

c
calculate u resonant
c
      u=(1.-n*b)/vmax/rz
c
c if u is too big there are no resonant particles, u-parallel integral is 0
c
      x=sqrt(1.-u**2)
      call mofx (x,vc)
      call dgdv2(x,dg,gcut)
c
c

      do 100 i=1,6
100   sv(i)=sv(i)+v(i)-gcut*vc(i)/rz/2.

200   continue
c
c
calculate normalizaton
c
      anorm=-4.*pi**2*alfa
c
240   do 250 i=1,6
250   sv(i)=anorm*cmplx(0.,1.)*sv(i)
c
300   continue
      sig(1,1)=sv(1)
      sig(1,2)=sv(2)
      sig(1,3)=sv(3)
      sig(2,1)=-sig(1,2)
      sig(2,2)=sv(4)
      sig(2,3)=sv(5)
      sig(3,1)=sig(1,3)
      sig(3,2)=-sig(2,3)
      sig(3,3)=sv(6)
c
c
c
c      call matout (sig,'ISOSIG',beta,'BETA',10)
c
      return
      end

c
c**********************************************************************
c

      subroutine intz1 (x,v)

*     ---------------------
*     integrand fo nz=0 case 1
*     ---------------------
      complex rx,rx2
      complex v(6),vm(6)
      common /int/rx,rx2,b,bet,vmax,rz,rz2,u,n
c
calculate u resonant
c
      u=(1.-n*b)/vmax/rz
c
c if u is too big there are no resonant particles, u-parallel integral is 0
c
      if (abs(u).lt.sqrt(1.-x**2)) then
      ucut=1.
      call mofx (x,vm)
      call dgdv2(x,dg,gcut)
      else
      ucut=0.
      end if
c
50    do 100 i=1,6
100   v(i)=ucut*x*dg*vm(i)/rz
c
      return
      end

c
c***************************************************************************
c
      subroutine mofx (x,um)

*     ------------------
*     generate m matrix
*     ------------------

      complex rx,rx2,bj,bjp,besc(50),arg
      dimension bes(3)
      complex um(6),ci
      common /int/ rx,rx2,b,bet,vmax,rz,rz2,u,n
      ci=cmplx(0.,1.)
      arg=rx*x*vmax/b

*     ----------------------------
*     generate j(n,x) and jprime(n,x)
*     ----------------------------

      nabs=iabs(n)
      if (nabs.ge.1) go to 220
      a1=0.
      nj=2
        nmax=1
        call besjc(arg,nmax,besc,ier)
        bj=besc(1)
        bjp=-besc(2)
        if (ier .ne. 0) write(59,10) ier
10      format( ' ier in besjc is ',i2)
      go to 225
220   a1=nabs-1
      nj=3
        nmax=nabs+1
                                call besjc(arg,nmax,besc,ier)
        bjp=(besc(nabs)-besc(nabs+2))/2.
        bj=besc(nabs+1)
        if(ier .ne. 0) write(59,10)ier
225   continue
c
c evaluate um vectors, consisting of the 6 independant
c elements of matrix m
c
c
      um(1)=n**2*b**2/rx2*bj**2
      um(2)=ci*n*b/rx*x*vmax*bj*bjp
      um(3)=u*n*b/rx*vmax*bj**2
      um(4)=x**2*vmax**2*bjp**2
      um(5)=-ci*x*u*vmax**2*bj*bjp
      um(6)=u**2*vmax**2*bj**2
      return
      end

c
c*********************************************************************
c

      subroutine dgdv2 (x,dg,gcut)

*     ---------------------------------------------------------
*     c**3*vmax**2* dg/dv**2 for a slowing down distribution
*     vte=electron thermal speed /c
*     rmass=species mass (probably alpha particles)/electron mass
*     vmax=cutoff speed/c
*     zeff= z effective
*     ---------------------------------------------------------

      complex rx,rx2
      common /int/ rx,rx2,b,bet,vmax,rz,rz2,u,n
      common /slowdist/ zeff, vte
c     data pi/3.1415926/, pi32/5.568328/,rmass/7296./,vmax/0.137/
      data pi/3.1415926/, pi32/5.568328/,rmass/7296./

*     ---------------------------------------------------------
*     calculate vcrit,delt and normalization factor anorm
*     recalculate only if vte or zeff has changed since last time
*     ---------------------------------------------------------

      if ((vte.eq.vte0).and.(zeff.eq.zeff0)) go to 50
      vte0=vte
      zeff0=zeff
      vc=(3.*sqrt(pi)/rmass*zeff)**.3333*vte
      delt=vc/vmax
      a=3./4./pi/alog(1.+1./delt**3)/vc**3
      anorm=1.5*a/delt**3
      gcut0=a/(1.+1./delt**3)
c
50    vu=sqrt(u**2+x**2)
      dg=-anorm*vu/(1.+(vu/delt)**3)**2
      gcut=gcut0
c
      return
      end

c
c***************************************************************************
c

      subroutine dgdv2max (x,dg)

*     -----------------------------------------------------
*     c**3*vmax**2* dg/dv**2 for a Maxwellian distribution

*     t=temperature in kev
*     rmass=species mass/electron mass
*     vmax=cutoff speed/c
*     v=species thermal speed (sqrt(2T/M)) divided by speed of light c
*     -----------------------------------------------------------------

      complex rx,rx2
      common /int/ rx,rx2,b,bet,vmax,rz,rz2,u,n
      common /maxdist/ v
      data pi32/5.568328/
c
      delt=v/vmax
      dg1=-exp(-(u**2+x**2)/delt**2)/v**3/delt**2/pi32
      dg=dg1
      x1=x
c
      return
      end

c
c***************************************************************************
c

      subroutine simpc (x0,x1,np,fname,fint,ndim)

*     -------------------------------------------
*     complex vector integration using simpsons rule
*     ------------------------------------------

      complex fint(ndim),veven(100),vodd(100)

      n=2*np
      h=(x1-x0)/n

      call fname (x0,fint)

      do 50 i=1,np
      x=x0+2.*h*i
      call fname (x,veven)
      x=x-h
      call fname (x,vodd)
      wt=2.
      if (i.eq.np) wt=1.
      do 25 j=1,ndim
25    fint(j)=fint(j)+wt*veven(j)+4.*vodd(j)
50    continue
c
      do 100 i=1,ndim
      fint(i)=h*fint(i)/3.
100   continue
      return
      end


      SUBROUTINE sla_PVOBS (P, H, STL, PV)
*+
*     - - - - - -
*      P V O B S
*     - - - - - -
*
*  Position and velocity of an observing station (double precision)
*
*  Given:
*     P     dp     latitude (geodetic, radians)
*     H     dp     height above reference spheroid (geodetic, metres)
*     STL   dp     local apparent sidereal time (radians)
*
*  Returned:
*     PV    dp(6)  position/velocity 6-vector (AU, AU/s, true equator
*                                              and equinox of date)
*
*  Called:  sla_GEOC
*
*  IAU 1976 constants are used.
*
*  P.T.Wallace   Starlink   14 November 1994
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
*    Boston, MA  02111-1307  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION P,H,STL,PV(6)

      DOUBLE PRECISION R,Z,S,C,V

*  Mean sidereal rate (at J2000) in radians per (UT1) second
      DOUBLE PRECISION SR
      PARAMETER (SR=7.292115855306589D-5)

*  Geodetic to geocentric conversion
      CALL sla_GEOC(P,H,R,Z)

*  Functions of ST
      S=SIN(STL)
      C=COS(STL)

*  Speed
      V=SR*R

*  Position
      PV(1)=R*C
      PV(2)=R*S
      PV(3)=Z

*  Velocity
      PV(4)=-V*S
      PV(5)=V*C
      PV(6)=0D0

      END


! Fast Fourier/Cosine/Sine Transform
!     dimension   :two
!     data length :power of 2
!     decimation  :frequency
!     radix       :4, 2, row-column
!     data        :inplace
!     table       :use
! subroutines
!     cdft2d: Complex Discrete Fourier Transform
!     rdft2d: Real Discrete Fourier Transform
!     ddct2d: Discrete Cosine Transform
!     ddst2d: Discrete Sine Transform
!
!
! -------- Complex DFT (Discrete Fourier Transform) --------
!     [definition]
!         <case1>
!             X(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 x(j1,j2) *
!                            exp(2*pi*i*j1*k1/n1) *
!                            exp(2*pi*i*j2*k2/n2),
!                            0<=k1<n1, 0<=k2<n2
!         <case2>
!             X(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 x(j1,j2) *
!                            exp(-2*pi*i*j1*k1/n1) *
!                            exp(-2*pi*i*j2*k2/n2),
!                            0<=k1<n1, 0<=k2<n2
!         (notes: sum_j=0^n-1 is a summation from j=0 to n-1)
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call cdft2d(n1max, 2*n1, n2, 1, a, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call cdft2d(n1max, 2*n1, n2, -1, a, ip, w)
!     [parameters]
!         n1max  :row size of the 2D array (integer)
!         2*n1   :data length (integer)
!                 n1 >= 1, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 1, n2 = power of 2
!         a(0:2*n1-1,0:n2-1)
!                :input/output data (real*8)
!                 input data
!                     a(2*j1,j2) = Re(x(j1,j2)),
!                     a(2*j1+1,j2) = Im(x(j1,j2)),
!                     0<=j1<n1, 0<=j2<n2
!                 output data
!                     a(2*k1,k2) = Re(X(k1,k2)),
!                     a(2*k1+1,k2) = Im(X(k1,k2)),
!                     0<=k1<n1, 0<=k2<n2
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1, n2))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1/2, n2/2)
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call cdft2d(n1max, 2*n1, n2, -1, a, ip, w)
!         is
!             call cdft2d(n1max, 2*n1, n2, 1, a, ip, w)
!             do j2 = 0, n2 - 1
!                 do j1 = 0, 2 * n1 - 1
!                     a(j1, j2) = a(j1, j2) * (1.0d0 / (n1 * n2))
!                 end do
!             end do
!         .
!
!
! -------- Real DFT / Inverse of Real DFT --------
!     [definition]
!         <case1> RDFT
!             R(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 a(j1,j2) *
!                            cos(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2),
!                            0<=k1<n1, 0<=k2<n2
!             I(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 a(j1,j2) *
!                            sin(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2),
!                            0<=k1<n1, 0<=k2<n2
!         <case2> IRDFT (excluding scale)
!             a(k1,k2) = (1/2) * sum_j1=0^n1-1 sum_j2=0^n2-1
!                            (R(j1,j2) *
!                            cos(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2) +
!                            I(j1,j2) *
!                            sin(2*pi*j1*k1/n1 + 2*pi*j2*k2/n2)),
!                            0<=k1<n1, 0<=k2<n2
!         (notes: R(n1-k1,n2-k2) = R(k1,k2),
!                 I(n1-k1,n2-k2) = -I(k1,k2),
!                 R(n1-k1,0) = R(k1,0),
!                 I(n1-k1,0) = -I(k1,0),
!                 R(0,n2-k2) = R(0,k2),
!                 I(0,n2-k2) = -I(0,k2),
!                 0<k1<n1, 0<k2<n2)
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call rdft2d(n1max, n1, n2, 1, a, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call rdft2d(n1max, n1, n2, -1, a, ip, w)
!     [parameters]
!         n1max  :row size of the 2D array (integer)
!         n1     :data length (integer)
!                 n1 >= 2, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 2, n2 = power of 2
!         a(0:n1-1,0:n2-1)
!                :input/output data (real*8)
!                 <case1>
!                     output data
!                         a(2*k1,k2) = R(k1,k2) = R(n1-k1,n2-k2),
!                         a(2*k1+1,k2) = I(k1,k2) = -I(n1-k1,n2-k2),
!                             0<k1<n1/2, 0<k2<n2,
!                         a(2*k1,0) = R(k1,0) = R(n1-k1,0),
!                         a(2*k1+1,0) = I(k1,0) = -I(n1-k1,0),
!                             0<k1<n1/2,
!                         a(0,k2) = R(0,k2) = R(0,n2-k2),
!                         a(1,k2) = I(0,k2) = -I(0,n2-k2),
!                         a(1,n2-k2) = R(n1/2,k2) = R(n1/2,n2-k2),
!                         a(0,n2-k2) = -I(n1/2,k2) = I(n1/2,n2-k2),
!                             0<k2<n2/2,
!                         a(0,0) = R(0,0),
!                         a(1,0) = R(n1/2,0),
!                         a(0,n2/2) = R(0,n2/2),
!                         a(1,n2/2) = R(n1/2,n2/2)
!                 <case2>
!                     input data
!                         a(2*j1,j2) = R(j1,j2) = R(n1-j1,n2-j2),
!                         a(2*j1+1,j2) = I(j1,j2) = -I(n1-j1,n2-j2),
!                             0<j1<n1/2, 0<j2<n2,
!                         a(2*j1,0) = R(j1,0) = R(n1-j1,0),
!                         a(2*j1+1,0) = I(j1,0) = -I(n1-j1,0),
!                             0<j1<n1/2,
!                         a(0,j2) = R(0,j2) = R(0,n2-j2),
!                         a(1,j2) = I(0,j2) = -I(0,n2-j2),
!                         a(1,n2-j2) = R(n1/2,j2) = R(n1/2,n2-j2),
!                         a(0,n2-j2) = -I(n1/2,j2) = I(n1/2,n2-j2),
!                             0<j2<n2/2,
!                         a(0,0) = R(0,0),
!                         a(1,0) = R(n1/2,0),
!                         a(0,n2/2) = R(0,n2/2),
!                         a(1,n2/2) = R(n1/2,n2/2)
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1/2, n2))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1/4, n2/2) + n1/4
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call rdft2d(n1max, n1, n2, 1, a, ip, w)
!         is
!             call rdft2d(n1max, n1, n2, -1, a, ip, w)
!             do j2 = 0, n2 - 1
!                 do j1 = 0, n1 - 1
!                     a(j1, j2) = a(j1, j2) * (2.0d0 / (n1 * n2))
!                 end do
!             end do
!         .
!
!
! -------- DCT (Discrete Cosine Transform) / Inverse of DCT --------
!     [definition]
!         <case1> IDCT (excluding scale)
!             C(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 a(j1,j2) *
!                            cos(pi*j1*(k1+1/2)/n1) *
!                            cos(pi*j2*(k2+1/2)/n2),
!                            0<=k1<n1, 0<=k2<n2
!         <case2> DCT
!             C(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 a(j1,j2) *
!                            cos(pi*(j1+1/2)*k1/n1) *
!                            cos(pi*(j2+1/2)*k2/n2),
!                            0<=k1<n1, 0<=k2<n2
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call ddct2d(n1max, n1, n2, 1, a, t, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call ddct2d(n1max, n1, n2, -1, a, t, ip, w)
!     [parameters]
!         n1max  :row size of the 2D array (integer)
!         n1     :data length (integer)
!                 n1 >= 2, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 2, n2 = power of 2
!         a(0:n1-1,0:n2-1)
!                :input/output data (real*8)
!                 output data
!                     a(k1,k2) = C(k1,k2), 0<=k1<n1, 0<=k2<n2
!         t(0:n1-1,0:n2-1)
!                :work area (real*8)
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1/2, n2))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1/4, n2/2) + max(n1, n2)
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call ddct2d(n1max, n1, n2, -1, a, t, ip, w)
!         is
!             do j1 = 0, n1 - 1
!                 a(j1, 0) = a(j1, 0) * 0.5d0
!             end do
!             do j2 = 0, n2 - 1
!                 a(0, j2) = a(0, j2) * 0.5d0
!             end do
!             call ddct2d(n1max, n1, n2, 1, a, t, ip, w)
!             do j2 = 0, n2 - 1
!                 do j1 = 0, n1 - 1
!                     a(j1, j2) = a(j1, j2) * (4.0d0 / (n1 * n2))
!                 end do
!             end do
!         .
!
!
! -------- DST (Discrete Sine Transform) / Inverse of DST --------
!     [definition]
!         <case1> IDST (excluding scale)
!             S(k1,k2) = sum_j1=1^n1 sum_j2=1^n2 A(j1,j2) *
!                            sin(pi*j1*(k1+1/2)/n1) *
!                            sin(pi*j2*(k2+1/2)/n2),
!                            0<=k1<n1, 0<=k2<n2
!         <case2> DST
!             S(k1,k2) = sum_j1=0^n1-1 sum_j2=0^n2-1 a(j1,j2) *
!                            sin(pi*(j1+1/2)*k1/n1) *
!                            sin(pi*(j2+1/2)*k2/n2),
!                            0<k1<=n1, 0<k2<=n2
!     [usage]
!         <case1>
!             ip(0) = 0  ! first time only
!             call ddst2d(n1max, n1, n2, 1, a, t, ip, w)
!         <case2>
!             ip(0) = 0  ! first time only
!             call ddst2d(n1max, n1, n2, -1, a, t, ip, w)
!     [parameters]
!         n1max  :row size of the 2D array (integer)
!         n1     :data length (integer)
!                 n1 >= 2, n1 = power of 2
!         n2     :data length (integer)
!                 n2 >= 2, n2 = power of 2
!         a(0:n1-1,0:n2-1)
!                :input/output data (real*8)
!                 <case1>
!                     input data
!                         a(j1,j2) = A(j1,j2), 0<j1<n1, 0<j2<n2,
!                         a(j1,0) = A(j1,n2), 0<j1<n1,
!                         a(0,j2) = A(n1,j2), 0<j2<n2,
!                         a(0,0) = A(n1,n2)
!                         (i.e. A(j1,j2) = a(mod(j1,n1),mod(j2,n2)))
!                     output data
!                         a(k1,k2) = S(k1,k2), 0<=k1<n1, 0<=k2<n2
!                 <case2>
!                     output data
!                         a(k1,k2) = S(k1,k2), 0<k1<n1, 0<k2<n2,
!                         a(k1,0) = S(k1,n2), 0<k1<n1,
!                         a(0,k2) = S(n1,k2), 0<k2<n2,
!                         a(0,0) = S(n1,n2)
!                         (i.e. S(k1,k2) = a(mod(k1,n1),mod(k2,n2)))
!         t(0:n1-1,0:n2-1)
!                :work area (real*8)
!         ip(0:*):work area for bit reversal (integer)
!                 length of ip >= 2+sqrt(n)
!                 (n = max(n1/2, n2))
!                 ip(0),ip(1) are pointers of the cos/sin table.
!         w(0:*) :cos/sin table (real*8)
!                 length of w >= max(n1/4, n2/2) + max(n1, n2)
!                 w(),ip() are initialized if ip(0) = 0.
!     [remark]
!         Inverse of
!             call ddst2d(n1max, n1, n2, -1, a, t, ip, w)
!         is
!             do j1 = 0, n1 - 1
!                 a(j1, 0) = a(j1, 0) * 0.5d0
!             end do
!             do j2 = 0, n2 - 1
!                 a(0, j2) = a(0, j2) * 0.5d0
!             end do
!             call ddst2d(n1max, n1, n2, 1, a, t, ip, w)
!             do j2 = 0, n2 - 1
!                 do j1 = 0, n1 - 1
!                     a(j1, j2) = a(j1, j2) * (4.0d0 / (n1 * n2))
!                 end do
!             end do
!         .
!
!
      subroutine cdft2d(n1max, n1, n2, isgn, a, ip, w)
      integer n1max, n1, n2, isgn, ip(0 : *), n
      real*8 a(0 : n1max - 1, 0 : n2 - 1), w(0 : *)
      n = max(n1, 2 * n2)
      if (n .gt. 4 * ip(0)) then
          call makewt(n / 4, ip, w)
      end if
      if (n1 .gt. 4) then
          call bitrv2row(n1max, n1, n2, ip(2), a)
      end if
      if (n2 .gt. 2) then
          call bitrv2col(n1max, n1, n2, ip(2), a)
      end if
      if (isgn .lt. 0) then
          call cftfrow(n1max, n1, n2, a, w)
          call cftfcol(n1max, n1, n2, a, w)
      else
          call cftbrow(n1max, n1, n2, a, w)
          call cftbcol(n1max, n1, n2, a, w)
      end if
      end
!
      subroutine rdft2d(n1max, n1, n2, isgn, a, ip, w)
      integer n1max, n1, n2, isgn, ip(0 : *), n, nw, nc, n2h, i, j
      real*8 a(0 : n1max - 1, 0 : n2 - 1), w(0 : *), xi
      n = max(n1, 2 * n2)
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n1 .gt. 4 * nc) then
          nc = n1 / 4
          call makect(nc, ip, w(nw))
      end if
      n2h = n2 / 2
      if (isgn .lt. 0) then
          do i = 1, n2h - 1
              j = n2 - i
              xi = a(0, i) - a(0, j)
              a(0, i) = a(0, i) + a(0, j)
              a(0, j) = xi
              xi = a(1, j) - a(1, i)
              a(1, i) = a(1, i) + a(1, j)
              a(1, j) = xi
          end do
          if (n2 .gt. 2) then
              call bitrv2col(n1max, n1, n2, ip(2), a)
          end if
          call cftfcol(n1max, n1, n2, a, w)
          do i = 0, n2 - 1
              a(1, i) = 0.5d0 * (a(0, i) - a(1, i))
              a(0, i) = a(0, i) - a(1, i)
          end do
          if (n1 .gt. 4) then
              call rftfrow(n1max, n1, n2, a, nc, w(nw))
              call bitrv2row(n1max, n1, n2, ip(2), a)
          end if
          call cftfrow(n1max, n1, n2, a, w)
      else
          if (n1 .gt. 4) then
              call bitrv2row(n1max, n1, n2, ip(2), a)
          end if
          call cftbrow(n1max, n1, n2, a, w)
          if (n1 .gt. 4) then
              call rftbrow(n1max, n1, n2, a, nc, w(nw))
          end if
          do i = 0, n2 - 1
              xi = a(0, i) - a(1, i)
              a(0, i) = a(0, i) + a(1, i)
              a(1, i) = xi
          end do
          if (n2 .gt. 2) then
              call bitrv2col(n1max, n1, n2, ip(2), a)
          end if
          call cftbcol(n1max, n1, n2, a, w)
          do i = 1, n2h - 1
              j = n2 - i
              a(0, j) = 0.5d0 * (a(0, i) - a(0, j))
              a(0, i) = a(0, i) - a(0, j)
              a(1, j) = 0.5d0 * (a(1, i) + a(1, j))
              a(1, i) = a(1, i) - a(1, j)
          end do
      end if
      end
!
      subroutine ddct2d(n1max, n1, n2, isgn, a, t, ip, w)
      integer n1max, n1, n2, isgn, ip(0 : *), n, nw, nc, n1h, n2h,
     &    i, ix, ic, j, jx, jc
      real*8 a(0 : n1max - 1, 0 : n2 - 1),
     &    t(0 : n1max - 1, 0 : n2 - 1), w(0 : *), xi
      n = max(n1, 2 * n2)
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n1 .gt. nc .or. n2 .gt. nc) then
          nc = max(n1, n2)
          call makect(nc, ip, w(nw))
      end if
      n1h = n1 / 2
      n2h = n2 / 2
      if (isgn .ge. 0) then
          do i = 0, n2 - 1
              do j = 1, n1h - 1
                  jx = 2 * j
                  t(jx, i) = a(j, i)
                  t(jx + 1, i) = a(n1 - j, i)
              end do
          end do
          t(0, 0) = a(0, 0)
          t(1, 0) = a(n1h, 0)
          t(0, n2h) = a(0, n2h)
          t(1, n2h) = a(n1h, n2h)
          do i = 1, n2h - 1
              ic = n2 - i
              t(0, i) = a(0, i)
              t(1, ic) = a(n1h, i)
              t(1, i) = a(0, ic)
              t(0, ic) = a(n1h, ic)
          end do
          call dctfsub(n1max, n1, n2, t, nc, w(nw))
          if (n2 .gt. 2) then
              call bitrv2col(n1max, n1, n2, ip(2), t)
          end if
          call cftfcol(n1max, n1, n2, t, w)
          do i = 0, n2 - 1
              t(1, i) = 0.5d0 * (t(0, i) - t(1, i))
              t(0, i) = t(0, i) - t(1, i)
          end do
          if (n1 .gt. 4) then
              call rftfrow(n1max, n1, n2, t, nc, w(nw))
              call bitrv2row(n1max, n1, n2, ip(2), t)
          end if
          call cftfrow(n1max, n1, n2, t, w)
          do i = 0, n2h - 1
              ix = 2 * i
              ic = n2 - 1 - i
              do j = 0, n1h - 1
                  jx = 2 * j
                  jc = n1 - 1 - j
                  a(jx, ix) = t(j, i)
                  a(jx + 1, ix) = t(jc, i)
                  a(jx, ix + 1) = t(j, ic)
                  a(jx + 1, ix + 1) = t(jc, ic)
              end do
          end do
      else
          do i = 0, n2h - 1
              ix = 2 * i
              ic = n2 - 1 - i
              do j = 0, n1h - 1
                  jx = 2 * j
                  jc = n1 - 1 - j
                  t(j, i) = a(jx, ix)
                  t(jc, i) = a(jx + 1, ix)
                  t(j, ic) = a(jx, ix + 1)
                  t(jc, ic) = a(jx + 1, ix + 1)
              end do
          end do
          if (n1 .gt. 4) then
              call bitrv2row(n1max, n1, n2, ip(2), t)
          end if
          call cftbrow(n1max, n1, n2, t, w)
          if (n1 .gt. 4) then
              call rftbrow(n1max, n1, n2, t, nc, w(nw))
          end if
          do i = 0, n2 - 1
              xi = t(0, i) - t(1, i)
              t(0, i) = t(0, i) + t(1, i)
              t(1, i) = xi
          end do
          if (n2 .gt. 2) then
              call bitrv2col(n1max, n1, n2, ip(2), t)
          end if
          call cftbcol(n1max, n1, n2, t, w)
          call dctbsub(n1max, n1, n2, t, nc, w(nw))
          do i = 0, n2 - 1
              do j = 1, n1h - 1
                  jx = 2 * j
                  a(j, i) = t(jx, i)
                  a(n1 - j, i) = t(jx + 1, i)
              end do
          end do
          a(0, 0) = t(0, 0)
          a(n1h, 0) = t(1, 0)
          a(0, n2h) = t(0, n2h)
          a(n1h, n2h) = t(1, n2h)
          do i = 1, n2h - 1
              ic = n2 - i
              a(0, i) = t(0, i)
              a(n1h, i) = t(1, ic)
              a(0, ic) = t(1, i)
              a(n1h, ic) = t(0, ic)
          end do
      end if
      end
!
      subroutine ddst2d(n1max, n1, n2, isgn, a, t, ip, w)
      integer n1max, n1, n2, isgn, ip(0 : *), n, nw, nc, n1h, n2h,
     &    i, ix, ic, j, jx, jc
      real*8 a(0 : n1max - 1, 0 : n2 - 1),
     &    t(0 : n1max - 1, 0 : n2 - 1), w(0 : *), xi
      n = max(n1, 2 * n2)
      nw = ip(0)
      if (n .gt. 4 * nw) then
          nw = n / 4
          call makewt(nw, ip, w)
      end if
      nc = ip(1)
      if (n1 .gt. nc .or. n2 .gt. nc) then
          nc = max(n1, n2)
          call makect(nc, ip, w(nw))
      end if
      n1h = n1 / 2
      n2h = n2 / 2
      if (isgn .ge. 0) then
          do i = 0, n2 - 1
              do j = 1, n1h - 1
                  jx = 2 * j
                  t(jx, i) = a(j, i)
                  t(jx + 1, i) = a(n1 - j, i)
              end do
          end do
          t(0, 0) = a(0, 0)
          t(1, 0) = a(n1h, 0)
          t(0, n2h) = a(0, n2h)
          t(1, n2h) = a(n1h, n2h)
          do i = 1, n2h - 1
              ic = n2 - i
              t(0, i) = a(0, i)
              t(1, ic) = a(n1h, i)
              t(1, i) = a(0, ic)
              t(0, ic) = a(n1h, ic)
          end do
          call dstfsub(n1max, n1, n2, t, nc, w(nw))
          if (n2 .gt. 2) then
              call bitrv2col(n1max, n1, n2, ip(2), t)
          end if
          call cftfcol(n1max, n1, n2, t, w)
          do i = 0, n2 - 1
              t(1, i) = 0.5d0 * (t(0, i) - t(1, i))
              t(0, i) = t(0, i) - t(1, i)
          end do
          if (n1 .gt. 4) then
              call rftfrow(n1max, n1, n2, t, nc, w(nw))
              call bitrv2row(n1max, n1, n2, ip(2), t)
          end if
          call cftfrow(n1max, n1, n2, t, w)
          do i = 0, n2h - 1
              ix = 2 * i
              ic = n2 - 1 - i
              do j = 0, n1h - 1
                  jx = 2 * j
                  jc = n1 - 1 - j
                  a(jx, ix) = t(j, i)
                  a(jx + 1, ix) = -t(jc, i)
                  a(jx, ix + 1) = -t(j, ic)
                  a(jx + 1, ix + 1) = t(jc, ic)
              end do
          end do
      else
          do i = 0, n2h - 1
              ix = 2 * i
              ic = n2 - 1 - i
              do j = 0, n1h - 1
                  jx = 2 * j
                  jc = n1 - 1 - j
                  t(j, i) = a(jx, ix)
                  t(jc, i) = -a(jx + 1, ix)
                  t(j, ic) = -a(jx, ix + 1)
                  t(jc, ic) = a(jx + 1, ix + 1)
              end do
          end do
          if (n1 .gt. 4) then
              call bitrv2row(n1max, n1, n2, ip(2), t)
          end if
          call cftbrow(n1max, n1, n2, t, w)
          if (n1 .gt. 4) then
              call rftbrow(n1max, n1, n2, t, nc, w(nw))
          end if
          do i = 0, n2 - 1
              xi = t(0, i) - t(1, i)
              t(0, i) = t(0, i) + t(1, i)
              t(1, i) = xi
          end do
          if (n2 .gt. 2) then
              call bitrv2col(n1max, n1, n2, ip(2), t)
          end if
          call cftbcol(n1max, n1, n2, t, w)
          call dstbsub(n1max, n1, n2, t, nc, w(nw))
          do i = 0, n2 - 1
              do j = 1, n1h - 1
                  jx = 2 * j
                  a(j, i) = t(jx, i)
                  a(n1 - j, i) = t(jx + 1, i)
              end do
          end do
          a(0, 0) = t(0, 0)
          a(n1h, 0) = t(1, 0)
          a(0, n2h) = t(0, n2h)
          a(n1h, n2h) = t(1, n2h)
          do i = 1, n2h - 1
              ic = n2 - i
              a(0, i) = t(0, i)
              a(n1h, i) = t(1, ic)
              a(0, ic) = t(1, i)
              a(n1h, ic) = t(0, ic)
          end do
      end if
      end
!
! -------- initializing routines --------
!
      subroutine makewt(nw, ip, w)
      integer nw, ip(0 : *), nwh, j
      real*8 w(0 : nw - 1), delta, x, y
      ip(0) = nw
      ip(1) = 1
      if (nw .gt. 2) then
          nwh = nw / 2
          delta = atan(1.0d0) / nwh
          w(0) = 1
          w(1) = 0
          w(nwh) = cos(delta * nwh)
          w(nwh + 1) = w(nwh)
          do j = 2, nwh - 2, 2
              x = cos(delta * j)
              y = sin(delta * j)
              w(j) = x
              w(j + 1) = y
              w(nw - j) = y
              w(nw - j + 1) = x
          end do
          call bitrv2(nw, ip(2), w)
      end if
      end
!
      subroutine makect(nc, ip, c)
      integer nc, ip(0 : *), nch, j
      real*8 c(0 : nc - 1), delta
      ip(1) = nc
      if (nc .gt. 1) then
          nch = nc / 2
          delta = atan(1.0d0) / nch
          c(0) = 0.5d0
          c(nch) = 0.5d0 * cos(delta * nch)
          do j = 1, nch - 1
              c(j) = 0.5d0 * cos(delta * j)
              c(nc - j) = 0.5d0 * sin(delta * j)
          end do
      end if
      end
!
! -------- child routines --------
!
      subroutine bitrv2(n, ip, a)
      integer n, ip(0 : *), j, j1, k, k1, l, m, m2
      real*8 a(0 : n - 1), xr, xi
      ip(0) = 0
      l = n
      m = 1
      do while (4 * m .lt. l)
          l = l / 2
          do j = 0, m - 1
              ip(m + j) = ip(j) + l
          end do
          m = m * 2
      end do
      if (4 * m .gt. l) then
          do k = 1, m - 1
              do j = 0, k - 1
                  j1 = 2 * j + ip(k)
                  k1 = 2 * k + ip(j)
                  xr = a(j1)
                  xi = a(j1 + 1)
                  a(j1) = a(k1)
                  a(j1 + 1) = a(k1 + 1)
                  a(k1) = xr
                  a(k1 + 1) = xi
              end do
          end do
      else
          m2 = 2 * m
          do k = 1, m - 1
              do j = 0, k - 1
                  j1 = 2 * j + ip(k)
                  k1 = 2 * k + ip(j)
                  xr = a(j1)
                  xi = a(j1 + 1)
                  a(j1) = a(k1)
                  a(j1 + 1) = a(k1 + 1)
                  a(k1) = xr
                  a(k1 + 1) = xi
                  j1 = j1 + m2
                  k1 = k1 + m2
                  xr = a(j1)
                  xi = a(j1 + 1)
                  a(j1) = a(k1)
                  a(j1 + 1) = a(k1 + 1)
                  a(k1) = xr
                  a(k1 + 1) = xi
              end do
          end do
      end if
      end
!
      subroutine bitrv2row(n1max, n, n2, ip, a)
      integer n1max, n, n2, ip(0 : *), i, j, j1, k, k1, l, m, m2
      real*8 a(0 : n1max - 1, 0 : n2 - 1), xr, xi
      ip(0) = 0
      l = n
      m = 1
      do while (4 * m .lt. l)
          l = l / 2
          do j = 0, m - 1
              ip(m + j) = ip(j) + l
          end do
          m = m * 2
      end do
      if (4 * m .gt. l) then
          do i = 0, n2 - 1
              do k = 1, m - 1
                  do j = 0, k - 1
                      j1 = 2 * j + ip(k)
                      k1 = 2 * k + ip(j)
                      xr = a(j1, i)
                      xi = a(j1 + 1, i)
                      a(j1, i) = a(k1, i)
                      a(j1 + 1, i) = a(k1 + 1, i)
                      a(k1, i) = xr
                      a(k1 + 1, i) = xi
                  end do
              end do
          end do
      else
          m2 = 2 * m
          do i = 0, n2 - 1
              do k = 1, m - 1
                  do j = 0, k - 1
                      j1 = 2 * j + ip(k)
                      k1 = 2 * k + ip(j)
                      xr = a(j1, i)
                      xi = a(j1 + 1, i)
                      a(j1, i) = a(k1, i)
                      a(j1 + 1, i) = a(k1 + 1, i)
                      a(k1, i) = xr
                      a(k1 + 1, i) = xi
                      j1 = j1 + m2
                      k1 = k1 + m2
                      xr = a(j1, i)
                      xi = a(j1 + 1, i)
                      a(j1, i) = a(k1, i)
                      a(j1 + 1, i) = a(k1 + 1, i)
                      a(k1, i) = xr
                      a(k1 + 1, i) = xi
                  end do
              end do
          end do
      end if
      end
!
      subroutine bitrv2col(n1max, n1, n, ip, a)
      integer n1max, n1, n, ip(0 : *), i, j, j1, k, k1, l, m
      real*8 a(0 : n1max - 1, 0 : n - 1), xr, xi
      ip(0) = 0
      l = n
      m = 1
      do while (2 * m .lt. l)
          l = l / 2
          do j = 0, m - 1
              ip(m + j) = ip(j) + l
          end do
          m = m * 2
      end do
      if (2 * m .gt. l) then
          do k = 1, m - 1
              do j = 0, k - 1
                  j1 = j + ip(k)
                  k1 = k + ip(j)
                  do i = 0, n1 - 2, 2
                      xr = a(i, j1)
                      xi = a(i + 1, j1)
                      a(i, j1) = a(i, k1)
                      a(i + 1, j1) = a(i + 1, k1)
                      a(i, k1) = xr
                      a(i + 1, k1) = xi
                  end do
              end do
          end do
      else
          do k = 1, m - 1
              do j = 0, k - 1
                  j1 = j + ip(k)
                  k1 = k + ip(j)
                  do i = 0, n1 - 2, 2
                      xr = a(i, j1)
                      xi = a(i + 1, j1)
                      a(i, j1) = a(i, k1)
                      a(i + 1, j1) = a(i + 1, k1)
                      a(i, k1) = xr
                      a(i + 1, k1) = xi
                  end do
                  j1 = j1 + m
                  k1 = k1 + m
                  do i = 0, n1 - 2, 2
                      xr = a(i, j1)
                      xi = a(i + 1, j1)
                      a(i, j1) = a(i, k1)
                      a(i + 1, j1) = a(i + 1, k1)
                      a(i, k1) = xr
                      a(i + 1, k1) = xi
                  end do
              end do
          end do
      end if
      end
!
      subroutine cftbrow(n1max, n, n2, a, w)
      integer n1max, n, n2, i, j, j1, j2, j3, k, k1, ks, l, m
      real*8 a(0 : n1max - 1, 0 : n2 - 1), w(0 : *)
      real*8 wk1r, wk1i, wk2r, wk2i, wk3r, wk3i
      real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i
      do i = 0, n2 - 1
          l = 2
          do while (2 * l .lt. n)
              m = 4 * l
              do j = 0, l - 2, 2
                  j1 = j + l
                  j2 = j1 + l
                  j3 = j2 + l
                  x0r = a(j, i) + a(j1, i)
                  x0i = a(j + 1, i) + a(j1 + 1, i)
                  x1r = a(j, i) - a(j1, i)
                  x1i = a(j + 1, i) - a(j1 + 1, i)
                  x2r = a(j2, i) + a(j3, i)
                  x2i = a(j2 + 1, i) + a(j3 + 1, i)
                  x3r = a(j2, i) - a(j3, i)
                  x3i = a(j2 + 1, i) - a(j3 + 1, i)
                  a(j, i) = x0r + x2r
                  a(j + 1, i) = x0i + x2i
                  a(j2, i) = x0r - x2r
                  a(j2 + 1, i) = x0i - x2i
                  a(j1, i) = x1r - x3i
                  a(j1 + 1, i) = x1i + x3r
                  a(j3, i) = x1r + x3i
                  a(j3 + 1, i) = x1i - x3r
              end do
              if (m .lt. n) then
                  wk1r = w(2)
                  do j = m, l + m - 2, 2
                      j1 = j + l
                      j2 = j1 + l
                      j3 = j2 + l
                      x0r = a(j, i) + a(j1, i)
                      x0i = a(j + 1, i) + a(j1 + 1, i)
                      x1r = a(j, i) - a(j1, i)
                      x1i = a(j + 1, i) - a(j1 + 1, i)
                      x2r = a(j2, i) + a(j3, i)
                      x2i = a(j2 + 1, i) + a(j3 + 1, i)
                      x3r = a(j2, i) - a(j3, i)
                      x3i = a(j2 + 1, i) - a(j3 + 1, i)
                      a(j, i) = x0r + x2r
                      a(j + 1, i) = x0i + x2i
                      a(j2, i) = x2i - x0i
                      a(j2 + 1, i) = x0r - x2r
                      x0r = x1r - x3i
                      x0i = x1i + x3r
                      a(j1, i) = wk1r * (x0r - x0i)
                      a(j1 + 1, i) = wk1r * (x0r + x0i)
                      x0r = x3i + x1r
                      x0i = x3r - x1i
                      a(j3, i) = wk1r * (x0i - x0r)
                      a(j3 + 1, i) = wk1r * (x0i + x0r)
                  end do
                  k1 = 1
                  ks = -1
                  do k = 2 * m, n - m, m
                      k1 = k1 + 1
                      ks = -ks
                      wk1r = w(2 * k1)
                      wk1i = w(2 * k1 + 1)
                      wk2r = ks * w(k1)
                      wk2i = w(k1 + ks)
                      wk3r = wk1r - 2 * wk2i * wk1i
                      wk3i = 2 * wk2i * wk1r - wk1i
                      do j = k, l + k - 2, 2
                          j1 = j + l
                          j2 = j1 + l
                          j3 = j2 + l
                          x0r = a(j, i) + a(j1, i)
                          x0i = a(j + 1, i) + a(j1 + 1, i)
                          x1r = a(j, i) - a(j1, i)
                          x1i = a(j + 1, i) - a(j1 + 1, i)
                          x2r = a(j2, i) + a(j3, i)
                          x2i = a(j2 + 1, i) + a(j3 + 1, i)
                          x3r = a(j2, i) - a(j3, i)
                          x3i = a(j2 + 1, i) - a(j3 + 1, i)
                          a(j, i) = x0r + x2r
                          a(j + 1, i) = x0i + x2i
                          x0r = x0r - x2r
                          x0i = x0i - x2i
                          a(j2, i) = wk2r * x0r - wk2i * x0i
                          a(j2 + 1, i) = wk2r * x0i + wk2i * x0r
                          x0r = x1r - x3i
                          x0i = x1i + x3r
                          a(j1, i) = wk1r * x0r - wk1i * x0i
                          a(j1 + 1, i) = wk1r * x0i + wk1i * x0r
                          x0r = x1r + x3i
                          x0i = x1i - x3r
                          a(j3, i) = wk3r * x0r - wk3i * x0i
                          a(j3 + 1, i) = wk3r * x0i + wk3i * x0r
                      end do
                  end do
              end if
              l = m
          end do
          if (l .lt. n) then
              do j = 0, l - 2, 2
                  j1 = j + l
                  x0r = a(j, i) - a(j1, i)
                  x0i = a(j + 1, i) - a(j1 + 1, i)
                  a(j, i) = a(j, i) + a(j1, i)
                  a(j + 1, i) = a(j + 1, i) + a(j1 + 1, i)
                  a(j1, i) = x0r
                  a(j1 + 1, i) = x0i
              end do
          end if
      end do
      end
!
      subroutine cftbcol(n1max, n1, n, a, w)
      integer n1max, n1, n, i, j, j1, j2, j3, k, k1, ks, l, m
      real*8 a(0 : n1max - 1, 0 : n - 1), w(0 : *)
      real*8 wk1r, wk1i, wk2r, wk2i, wk3r, wk3i
      real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i
      l = 1
      do while (2 * l .lt. n)
          m = 4 * l
          do j = 0, l - 1
              j1 = j + l
              j2 = j1 + l
              j3 = j2 + l
              do i = 0, n1 - 2, 2
                  x0r = a(i, j) + a(i, j1)
                  x0i = a(i + 1, j) + a(i + 1, j1)
                  x1r = a(i, j) - a(i, j1)
                  x1i = a(i + 1, j) - a(i + 1, j1)
                  x2r = a(i, j2) + a(i, j3)
                  x2i = a(i + 1, j2) + a(i + 1, j3)
                  x3r = a(i, j2) - a(i, j3)
                  x3i = a(i + 1, j2) - a(i + 1, j3)
                  a(i, j) = x0r + x2r
                  a(i + 1, j) = x0i + x2i
                  a(i, j2) = x0r - x2r
                  a(i + 1, j2) = x0i - x2i
                  a(i, j1) = x1r - x3i
                  a(i + 1, j1) = x1i + x3r
                  a(i, j3) = x1r + x3i
                  a(i + 1, j3) = x1i - x3r
              end do
          end do
          if (m .lt. n) then
              wk1r = w(2)
              do j = m, l + m - 1
                  j1 = j + l
                  j2 = j1 + l
                  j3 = j2 + l
                  do i = 0, n1 - 2, 2
                      x0r = a(i, j) + a(i, j1)
                      x0i = a(i + 1, j) + a(i + 1, j1)
                      x1r = a(i, j) - a(i, j1)
                      x1i = a(i + 1, j) - a(i + 1, j1)
                      x2r = a(i, j2) + a(i, j3)
                      x2i = a(i + 1, j2) + a(i + 1, j3)
                      x3r = a(i, j2) - a(i, j3)
                      x3i = a(i + 1, j2) - a(i + 1, j3)
                      a(i, j) = x0r + x2r
                      a(i + 1, j) = x0i + x2i
                      a(i, j2) = x2i - x0i
                      a(i + 1, j2) = x0r - x2r
                      x0r = x1r - x3i
                      x0i = x1i + x3r
                      a(i, j1) = wk1r * (x0r - x0i)
                      a(i + 1, j1) = wk1r * (x0r + x0i)
                      x0r = x3i + x1r
                      x0i = x3r - x1i
                      a(i, j3) = wk1r * (x0i - x0r)
                      a(i + 1, j3) = wk1r * (x0i + x0r)
                  end do
              end do
              k1 = 1
              ks = -1
              do k = 2 * m, n - m, m
                  k1 = k1 + 1
                  ks = -ks
                  wk1r = w(2 * k1)
                  wk1i = w(2 * k1 + 1)
                  wk2r = ks * w(k1)
                  wk2i = w(k1 + ks)
                  wk3r = wk1r - 2 * wk2i * wk1i
                  wk3i = 2 * wk2i * wk1r - wk1i
                  do j = k, l + k - 1
                      j1 = j + l
                      j2 = j1 + l
                      j3 = j2 + l
                      do i = 0, n1 - 2, 2
                          x0r = a(i, j) + a(i, j1)
                          x0i = a(i + 1, j) + a(i + 1, j1)
                          x1r = a(i, j) - a(i, j1)
                          x1i = a(i + 1, j) - a(i + 1, j1)
                          x2r = a(i, j2) + a(i, j3)
                          x2i = a(i + 1, j2) + a(i + 1, j3)
                          x3r = a(i, j2) - a(i, j3)
                          x3i = a(i + 1, j2) - a(i + 1, j3)
                          a(i, j) = x0r + x2r
                          a(i + 1, j) = x0i + x2i
                          x0r = x0r - x2r
                          x0i = x0i - x2i
                          a(i, j2) = wk2r * x0r - wk2i * x0i
                          a(i + 1, j2) = wk2r * x0i + wk2i * x0r
                          x0r = x1r - x3i
                          x0i = x1i + x3r
                          a(i, j1) = wk1r * x0r - wk1i * x0i
                          a(i + 1, j1) = wk1r * x0i + wk1i * x0r
                          x0r = x1r + x3i
                          x0i = x1i - x3r
                          a(i, j3) = wk3r * x0r - wk3i * x0i
                          a(i + 1, j3) = wk3r * x0i + wk3i * x0r
                      end do
                  end do
              end do
          end if
          l = m
      end do
      if (l .lt. n) then
          do j = 0, l - 1
              j1 = j + l
              do i = 0, n1 - 2, 2
                  x0r = a(i, j) - a(i, j1)
                  x0i = a(i + 1, j) - a(i + 1, j1)
                  a(i, j) = a(i, j) + a(i, j1)
                  a(i + 1, j) = a(i + 1, j) + a(i + 1, j1)
                  a(i, j1) = x0r
                  a(i + 1, j1) = x0i
              end do
          end do
      end if
      end
!
      subroutine cftfrow(n1max, n, n2, a, w)
      integer n1max, n, n2, i, j, j1, j2, j3, k, k1, ks, l, m
      real*8 a(0 : n1max - 1, 0 : n2 - 1), w(0 : *)
      real*8 wk1r, wk1i, wk2r, wk2i, wk3r, wk3i
      real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i
      do i = 0, n2 - 1
          l = 2
          do while (2 * l .lt. n)
              m = 4 * l
              do j = 0, l - 2, 2
                  j1 = j + l
                  j2 = j1 + l
                  j3 = j2 + l
                  x0r = a(j, i) + a(j1, i)
                  x0i = a(j + 1, i) + a(j1 + 1, i)
                  x1r = a(j, i) - a(j1, i)
                  x1i = a(j + 1, i) - a(j1 + 1, i)
                  x2r = a(j2, i) + a(j3, i)
                  x2i = a(j2 + 1, i) + a(j3 + 1, i)
                  x3r = a(j2, i) - a(j3, i)
                  x3i = a(j2 + 1, i) - a(j3 + 1, i)
                  a(j, i) = x0r + x2r
                  a(j + 1, i) = x0i + x2i
                  a(j2, i) = x0r - x2r
                  a(j2 + 1, i) = x0i - x2i
                  a(j1, i) = x1r + x3i
                  a(j1 + 1, i) = x1i - x3r
                  a(j3, i) = x1r - x3i
                  a(j3 + 1, i) = x1i + x3r
              end do
              if (m .lt. n) then
                  wk1r = w(2)
                  do j = m, l + m - 2, 2
                      j1 = j + l
                      j2 = j1 + l
                      j3 = j2 + l
                      x0r = a(j, i) + a(j1, i)
                      x0i = a(j + 1, i) + a(j1 + 1, i)
                      x1r = a(j, i) - a(j1, i)
                      x1i = a(j + 1, i) - a(j1 + 1, i)
                      x2r = a(j2, i) + a(j3, i)
                      x2i = a(j2 + 1, i) + a(j3 + 1, i)
                      x3r = a(j2, i) - a(j3, i)
                      x3i = a(j2 + 1, i) - a(j3 + 1, i)
                      a(j, i) = x0r + x2r
                      a(j + 1, i) = x0i + x2i
                      a(j2, i) = x0i - x2i
                      a(j2 + 1, i) = x2r - x0r
                      x0r = x1r + x3i
                      x0i = x1i - x3r
                      a(j1, i) = wk1r * (x0i + x0r)
                      a(j1 + 1, i) = wk1r * (x0i - x0r)
                      x0r = x3i - x1r
                      x0i = x3r + x1i
                      a(j3, i) = wk1r * (x0r + x0i)
                      a(j3 + 1, i) = wk1r * (x0r - x0i)
                  end do
                  k1 = 1
                  ks = -1
                  do k = 2 * m, n - m, m
                      k1 = k1 + 1
                      ks = -ks
                      wk1r = w(2 * k1)
                      wk1i = w(2 * k1 + 1)
                      wk2r = ks * w(k1)
                      wk2i = w(k1 + ks)
                      wk3r = wk1r - 2 * wk2i * wk1i
                      wk3i = 2 * wk2i * wk1r - wk1i
                      do j = k, l + k - 2, 2
                          j1 = j + l
                          j2 = j1 + l
                          j3 = j2 + l
                          x0r = a(j, i) + a(j1, i)
                          x0i = a(j + 1, i) + a(j1 + 1, i)
                          x1r = a(j, i) - a(j1, i)
                          x1i = a(j + 1, i) - a(j1 + 1, i)
                          x2r = a(j2, i) + a(j3, i)
                          x2i = a(j2 + 1, i) + a(j3 + 1, i)
                          x3r = a(j2, i) - a(j3, i)
                          x3i = a(j2 + 1, i) - a(j3 + 1, i)
                          a(j, i) = x0r + x2r
                          a(j + 1, i) = x0i + x2i
                          x0r = x0r - x2r
                          x0i = x0i - x2i
                          a(j2, i) = wk2r * x0r + wk2i * x0i
                          a(j2 + 1, i) = wk2r * x0i - wk2i * x0r
                          x0r = x1r + x3i
                          x0i = x1i - x3r
                          a(j1, i) = wk1r * x0r + wk1i * x0i
                          a(j1 + 1, i) = wk1r * x0i - wk1i * x0r
                          x0r = x1r - x3i
                          x0i = x1i + x3r
                          a(j3, i) = wk3r * x0r + wk3i * x0i
                          a(j3 + 1, i) = wk3r * x0i - wk3i * x0r
                      end do
                  end do
              end if
              l = m
          end do
          if (l .lt. n) then
              do j = 0, l - 2, 2
                  j1 = j + l
                  x0r = a(j, i) - a(j1, i)
                  x0i = a(j + 1, i) - a(j1 + 1, i)
                  a(j, i) = a(j, i) + a(j1, i)
                  a(j + 1, i) = a(j + 1, i) + a(j1 + 1, i)
                  a(j1, i) = x0r
                  a(j1 + 1, i) = x0i
              end do
          end if
      end do
      end
!
      subroutine cftfcol(n1max, n1, n, a, w)
      integer n1max, n1, n, i, j, j1, j2, j3, k, k1, ks, l, m
      real*8 a(0 : n1max - 1, 0 : n - 1), w(0 : *)
      real*8 wk1r, wk1i, wk2r, wk2i, wk3r, wk3i
      real*8 x0r, x0i, x1r, x1i, x2r, x2i, x3r, x3i
      l = 1
      do while (2 * l .lt. n)
          m = 4 * l
          do j = 0, l - 1
              j1 = j + l
              j2 = j1 + l
              j3 = j2 + l
              do i = 0, n1 - 2, 2
                  x0r = a(i, j) + a(i, j1)
                  x0i = a(i + 1, j) + a(i + 1, j1)
                  x1r = a(i, j) - a(i, j1)
                  x1i = a(i + 1, j) - a(i + 1, j1)
                  x2r = a(i, j2) + a(i, j3)
                  x2i = a(i + 1, j2) + a(i + 1, j3)
                  x3r = a(i, j2) - a(i, j3)
                  x3i = a(i + 1, j2) - a(i + 1, j3)
                  a(i, j) = x0r + x2r
                  a(i + 1, j) = x0i + x2i
                  a(i, j2) = x0r - x2r
                  a(i + 1, j2) = x0i - x2i
                  a(i, j1) = x1r + x3i
                  a(i + 1, j1) = x1i - x3r
                  a(i, j3) = x1r - x3i
                  a(i + 1, j3) = x1i + x3r
              end do
          end do
          if (m .lt. n) then
              wk1r = w(2)
              do j = m, l + m - 1
                  j1 = j + l
                  j2 = j1 + l
                  j3 = j2 + l
                  do i = 0, n1 - 2, 2
                      x0r = a(i, j) + a(i, j1)
                      x0i = a(i + 1, j) + a(i + 1, j1)
                      x1r = a(i, j) - a(i, j1)
                      x1i = a(i + 1, j) - a(i + 1, j1)
                      x2r = a(i, j2) + a(i, j3)
                      x2i = a(i + 1, j2) + a(i + 1, j3)
                      x3r = a(i, j2) - a(i, j3)
                      x3i = a(i + 1, j2) - a(i + 1, j3)
                      a(i, j) = x0r + x2r
                      a(i + 1, j) = x0i + x2i
                      a(i, j2) = x0i - x2i
                      a(i + 1, j2) = x2r - x0r
                      x0r = x1r + x3i
                      x0i = x1i - x3r
                      a(i, j1) = wk1r * (x0i + x0r)
                      a(i + 1, j1) = wk1r * (x0i - x0r)
                      x0r = x3i - x1r
                      x0i = x3r + x1i
                      a(i, j3) = wk1r * (x0r + x0i)
                      a(i + 1, j3) = wk1r * (x0r - x0i)
                  end do
              end do
              k1 = 1
              ks = -1
              do k = 2 * m, n - m, m
                  k1 = k1 + 1
                  ks = -ks
                  wk1r = w(2 * k1)
                  wk1i = w(2 * k1 + 1)
                  wk2r = ks * w(k1)
                  wk2i = w(k1 + ks)
                  wk3r = wk1r - 2 * wk2i * wk1i
                  wk3i = 2 * wk2i * wk1r - wk1i
                  do j = k, l + k - 1
                      j1 = j + l
                      j2 = j1 + l
                      j3 = j2 + l
                      do i = 0, n1 - 2, 2
                          x0r = a(i, j) + a(i, j1)
                          x0i = a(i + 1, j) + a(i + 1, j1)
                          x1r = a(i, j) - a(i, j1)
                          x1i = a(i + 1, j) - a(i + 1, j1)
                          x2r = a(i, j2) + a(i, j3)
                          x2i = a(i + 1, j2) + a(i + 1, j3)
                          x3r = a(i, j2) - a(i, j3)
                          x3i = a(i + 1, j2) - a(i + 1, j3)
                          a(i, j) = x0r + x2r
                          a(i + 1, j) = x0i + x2i
                          x0r = x0r - x2r
                          x0i = x0i - x2i
                          a(i, j2) = wk2r * x0r + wk2i * x0i
                          a(i + 1, j2) = wk2r * x0i - wk2i * x0r
                          x0r = x1r + x3i
                          x0i = x1i - x3r
                          a(i, j1) = wk1r * x0r + wk1i * x0i
                          a(i + 1, j1) = wk1r * x0i - wk1i * x0r
                          x0r = x1r - x3i
                          x0i = x1i + x3r
                          a(i, j3) = wk3r * x0r + wk3i * x0i
                          a(i + 1, j3) = wk3r * x0i - wk3i * x0r
                      end do
                  end do
              end do
          end if
          l = m
      end do
      if (l .lt. n) then
          do j = 0, l - 1
              j1 = j + l
              do i = 0, n1 - 2, 2
                  x0r = a(i, j) - a(i, j1)
                  x0i = a(i + 1, j) - a(i + 1, j1)
                  a(i, j) = a(i, j) + a(i, j1)
                  a(i + 1, j) = a(i + 1, j) + a(i + 1, j1)
                  a(i, j1) = x0r
                  a(i + 1, j1) = x0i
              end do
          end do
      end if
      end
!
      subroutine rftbrow(n1max, n, n2, a, nc, c)
      integer n1max, n, n2, nc, i, j, k, kk, ks
      real*8 a(0 : n1max - 1, 0 : n2 - 1), c(0 : nc - 1),
     &    wkr, wki, xr, xi, yr, yi
      ks = 4 * nc / n
      do i = 0, n2 - 1
          kk = 0
          do k = n / 2 - 2, 2, -2
              j = n - k
              kk = kk + ks
              wkr = 0.5d0 - c(kk)
              wki = c(nc - kk)
              xr = a(k, i) - a(j, i)
              xi = a(k + 1, i) + a(j + 1, i)
              yr = wkr * xr - wki * xi
              yi = wkr * xi + wki * xr
              a(k, i) = a(k, i) - yr
              a(k + 1, i) = a(k + 1, i) - yi
              a(j, i) = a(j, i) + yr
              a(j + 1, i) = a(j + 1, i) - yi
          end do
      end do
      end
!
      subroutine rftfrow(n1max, n, n2, a, nc, c)
      integer n1max, n, n2, nc, i, j, k, kk, ks
      real*8 a(0 : n1max - 1, 0 : n2 - 1), c(0 : nc - 1),
     &    wkr, wki, xr, xi, yr, yi
      ks = 4 * nc / n
      do i = 0, n2 - 1
          kk = 0
          do k = n / 2 - 2, 2, -2
              j = n - k
              kk = kk + ks
              wkr = 0.5d0 - c(kk)
              wki = c(nc - kk)
              xr = a(k, i) - a(j, i)
              xi = a(k + 1, i) + a(j + 1, i)
              yr = wkr * xr + wki * xi
              yi = wkr * xi - wki * xr
              a(k, i) = a(k, i) - yr
              a(k + 1, i) = a(k + 1, i) - yi
              a(j, i) = a(j, i) + yr
              a(j + 1, i) = a(j + 1, i) - yi
          end do
      end do
      end
!
      subroutine dctbsub(n1max, n1, n2, a, nc, c)
      integer n1max, n1, n2, nc, kk1, kk2, ks1, ks2, n2h, j2,
     &    k1, k2
      real*8 a(0 : n1max - 1, 0 : n2 - 1), c(0 : nc - 1),
     &    w2r, w2i, wkr, wki, wjr, wji, x0r, x0i, x1r, x1i
      ks1 = nc / n1
      ks2 = nc / n2
      n2h = n2 / 2
      kk2 = ks2
      do k2 = 1, n2h - 1
          j2 = n2 - k2
          w2r = 2 * c(kk2)
          w2i = 2 * c(nc - kk2)
          kk2 = kk2 + ks2
          kk1 = ks1
          do k1 = 2, n1 - 2, 2
              x0r = w2r * c(kk1)
              x0i = w2i * c(kk1)
              x1r = w2r * c(nc - kk1)
              x1i = w2i * c(nc - kk1)
              wkr = x0r - x1i
              wki = x0i + x1r
              wji = x0r + x1i
              wjr = x0i - x1r
              kk1 = kk1 + ks1
              x0r = wkr * a(k1, k2) - wki * a(k1 + 1, k2)
              x0i = wkr * a(k1 + 1, k2) + wki * a(k1, k2)
              x1r = wjr * a(k1, j2) - wji * a(k1 + 1, j2)
              x1i = wjr * a(k1 + 1, j2) + wji * a(k1, j2)
              a(k1, k2) = x0r + x1i
              a(k1 + 1, k2) = x0i - x1r
              a(k1, j2) = x1r + x0i
              a(k1 + 1, j2) = x1i - x0r
          end do
          wkr = w2r * 0.5d0
          wki = w2i * 0.5d0
          wjr = w2r * c(kk1)
          wji = w2i * c(kk1)
          x0r = a(0, k2) + a(0, j2)
          x0i = a(1, k2) - a(1, j2)
          x1r = a(0, k2) - a(0, j2)
          x1i = a(1, k2) + a(1, j2)
          a(0, k2) = wkr * x0r - wki * x0i
          a(1, k2) = wkr * x0i + wki * x0r
          a(0, j2) = -wjr * x1r + wji * x1i
          a(1, j2) = wjr * x1i + wji * x1r
      end do
      w2r = 2 * c(kk2)
      kk1 = ks1
      do k1 = 2, n1 - 2, 2
          wkr = 2 * c(kk1)
          wki = 2 * c(nc - kk1)
          wjr = w2r * wkr
          wji = w2r * wki
          kk1 = kk1 + ks1
          x0i = wkr * a(k1 + 1, 0) + wki * a(k1, 0)
          a(k1, 0) = wkr * a(k1, 0) - wki * a(k1 + 1, 0)
          a(k1 + 1, 0) = x0i
          x0i = wjr * a(k1 + 1, n2h) + wji * a(k1, n2h)
          a(k1, n2h) = wjr * a(k1, n2h) - wji * a(k1 + 1, n2h)
          a(k1 + 1, n2h) = x0i
      end do
      a(1, 0) = a(1, 0) * w2r
      a(0, n2h) = a(0, n2h) * w2r
      a(1, n2h) = a(1, n2h) * 0.5d0
      end
!
      subroutine dctfsub(n1max, n1, n2, a, nc, c)
      integer n1max, n1, n2, nc, kk1, kk2, ks1, ks2, n2h, j2,
     &    k1, k2
      real*8 a(0 : n1max - 1, 0 : n2 - 1), c(0 : nc - 1),
     &    w2r, w2i, wkr, wki, wjr, wji, x0r, x0i, x1r, x1i
      ks1 = nc / n1
      ks2 = nc / n2
      n2h = n2 / 2
      kk2 = ks2
      do k2 = 1, n2h - 1
          j2 = n2 - k2
          w2r = 2 * c(kk2)
          w2i = 2 * c(nc - kk2)
          kk2 = kk2 + ks2
          kk1 = ks1
          do k1 = 2, n1 - 2, 2
              x0r = w2r * c(kk1)
              x0i = w2i * c(kk1)
              x1r = w2r * c(nc - kk1)
              x1i = w2i * c(nc - kk1)
              wkr = x0r - x1i
              wki = x0i + x1r
              wji = x0r + x1i
              wjr = x0i - x1r
              kk1 = kk1 + ks1
              x0r = a(k1, k2) - a(k1 + 1, j2)
              x0i = a(k1, j2) + a(k1 + 1, k2)
              x1r = a(k1, j2) - a(k1 + 1, k2)
              x1i = a(k1, k2) + a(k1 + 1, j2)
              a(k1, k2) = wkr * x0r + wki * x0i
              a(k1 + 1, k2) = wkr * x0i - wki * x0r
              a(k1, j2) = wjr * x1r + wji * x1i
              a(k1 + 1, j2) = wjr * x1i - wji * x1r
          end do
          x0r = 2 * c(kk1)
          wjr = x0r * w2r
          wji = x0r * w2i
          x0r = w2r * a(0, k2) + w2i * a(1, k2)
          x0i = w2r * a(1, k2) - w2i * a(0, k2)
          x1r = -wjr * a(0, j2) + wji * a(1, j2)
          x1i = wjr * a(1, j2) + wji * a(0, j2)
          a(0, k2) = x0r + x1r
          a(1, k2) = x1i + x0i
          a(0, j2) = x0r - x1r
          a(1, j2) = x1i - x0i
      end do
      w2r = 2 * c(kk2)
      kk1 = ks1
      do k1 = 2, n1 - 2, 2
          wkr = 2 * c(kk1)
          wki = 2 * c(nc - kk1)
          wjr = w2r * wkr
          wji = w2r * wki
          kk1 = kk1 + ks1
          x0i = wkr * a(k1 + 1, 0) - wki * a(k1, 0)
          a(k1, 0) = wkr * a(k1, 0) + wki * a(k1 + 1, 0)
          a(k1 + 1, 0) = x0i
          x0i = wjr * a(k1 + 1, n2h) - wji * a(k1, n2h)
          a(k1, n2h) = wjr * a(k1, n2h) + wji * a(k1 + 1, n2h)
          a(k1 + 1, n2h) = x0i
      end do
      w2r = w2r * 2
      a(0, 0) = a(0, 0) * 2
      a(1, 0) = a(1, 0) * w2r
      a(0, n2h) = a(0, n2h) * w2r
      end
!
      subroutine dstbsub(n1max, n1, n2, a, nc, c)
      integer n1max, n1, n2, nc, kk1, kk2, ks1, ks2, n2h, j2,
     &    k1, k2
      real*8 a(0 : n1max - 1, 0 : n2 - 1), c(0 : nc - 1),
     &    w2r, w2i, wkr, wki, wjr, wji, x0r, x0i, x1r, x1i
      ks1 = nc / n1
      ks2 = nc / n2
      n2h = n2 / 2
      kk2 = ks2
      do k2 = 1, n2h - 1
          j2 = n2 - k2
          w2r = 2 * c(kk2)
          w2i = 2 * c(nc - kk2)
          kk2 = kk2 + ks2
          kk1 = ks1
          do k1 = 2, n1 - 2, 2
              x0r = w2r * c(kk1)
              x0i = w2i * c(kk1)
              x1r = w2r * c(nc - kk1)
              x1i = w2i * c(nc - kk1)
              wkr = x0r - x1i
              wki = x0i + x1r
              wji = x0r + x1i
              wjr = x0i - x1r
              kk1 = kk1 + ks1
              x0r = wkr * a(k1, k2) - wki * a(k1 + 1, k2)
              x0i = wkr * a(k1 + 1, k2) + wki * a(k1, k2)
              x1r = wjr * a(k1, j2) - wji * a(k1 + 1, j2)
              x1i = wjr * a(k1 + 1, j2) + wji * a(k1, j2)
              a(k1, k2) = x1i - x0r
              a(k1 + 1, k2) = x1r + x0i
              a(k1, j2) = x0i - x1r
              a(k1 + 1, j2) = x0r + x1i
          end do
          wkr = w2r * 0.5d0
          wki = w2i * 0.5d0
          wjr = w2r * c(kk1)
          wji = w2i * c(kk1)
          x0r = a(0, k2) + a(0, j2)
          x0i = a(1, k2) - a(1, j2)
          x1r = a(0, k2) - a(0, j2)
          x1i = a(1, k2) + a(1, j2)
          a(1, k2) = wkr * x0r - wki * x0i
          a(0, k2) = wkr * x0i + wki * x0r
          a(1, j2) = -wjr * x1r + wji * x1i
          a(0, j2) = wjr * x1i + wji * x1r
      end do
      w2r = 2 * c(kk2)
      kk1 = ks1
      do k1 = 2, n1 - 2, 2
          wkr = 2 * c(kk1)
          wki = 2 * c(nc - kk1)
          wjr = w2r * wkr
          wji = w2r * wki
          kk1 = kk1 + ks1
          x0i = wkr * a(k1 + 1, 0) + wki * a(k1, 0)
          a(k1 + 1, 0) = wkr * a(k1, 0) - wki * a(k1 + 1, 0)
          a(k1, 0) = x0i
          x0i = wjr * a(k1 + 1, n2h) + wji * a(k1, n2h)
          a(k1 + 1, n2h) = wjr * a(k1, n2h) - wji * a(k1 + 1, n2h)
          a(k1, n2h) = x0i
      end do
      a(1, 0) = a(1, 0) * w2r
      a(0, n2h) = a(0, n2h) * w2r
      a(1, n2h) = a(1, n2h) * 0.5d0
      end
!
      subroutine dstfsub(n1max, n1, n2, a, nc, c)
      integer n1max, n1, n2, nc, kk1, kk2, ks1, ks2, n2h, j2,
     &    k1, k2
      real*8 a(0 : n1max - 1, 0 : n2 - 1), c(0 : nc - 1),
     &    w2r, w2i, wkr, wki, wjr, wji, x0r, x0i, x1r, x1i
      ks1 = nc / n1
      ks2 = nc / n2
      n2h = n2 / 2
      kk2 = ks2
      do k2 = 1, n2h - 1
          j2 = n2 - k2
          w2r = 2 * c(kk2)
          w2i = 2 * c(nc - kk2)
          kk2 = kk2 + ks2
          kk1 = ks1
          do k1 = 2, n1 - 2, 2
              x0r = w2r * c(kk1)
              x0i = w2i * c(kk1)
              x1r = w2r * c(nc - kk1)
              x1i = w2i * c(nc - kk1)
              wkr = x0r - x1i
              wki = x0i + x1r
              wji = x0r + x1i
              wjr = x0i - x1r
              kk1 = kk1 + ks1
              x0r = a(k1 + 1, j2) - a(k1, k2)
              x0i = a(k1 + 1, k2) + a(k1, j2)
              x1r = a(k1 + 1, k2) - a(k1, j2)
              x1i = a(k1 + 1, j2) + a(k1, k2)
              a(k1, k2) = wkr * x0r + wki * x0i
              a(k1 + 1, k2) = wkr * x0i - wki * x0r
              a(k1, j2) = wjr * x1r + wji * x1i
              a(k1 + 1, j2) = wjr * x1i - wji * x1r
          end do
          x0r = 2 * c(kk1)
          wjr = x0r * w2r
          wji = x0r * w2i
          x0r = w2r * a(1, k2) + w2i * a(0, k2)
          x0i = w2r * a(0, k2) - w2i * a(1, k2)
          x1r = -wjr * a(1, j2) + wji * a(0, j2)
          x1i = wjr * a(0, j2) + wji * a(1, j2)
          a(0, k2) = x0r + x1r
          a(1, k2) = x1i + x0i
          a(0, j2) = x0r - x1r
          a(1, j2) = x1i - x0i
      end do
      w2r = 2 * c(kk2)
      kk1 = ks1
      do k1 = 2, n1 - 2, 2
          wkr = 2 * c(kk1)
          wki = 2 * c(nc - kk1)
          wjr = w2r * wkr
          wji = w2r * wki
          kk1 = kk1 + ks1
          x0i = wkr * a(k1, 0) - wki * a(k1 + 1, 0)
          a(k1, 0) = wkr * a(k1 + 1, 0) + wki * a(k1, 0)
          a(k1 + 1, 0) = x0i
          x0i = wjr * a(k1, n2h) - wji * a(k1 + 1, n2h)
          a(k1, n2h) = wjr * a(k1 + 1, n2h) + wji * a(k1, n2h)
          a(k1 + 1, n2h) = x0i
      end do
      w2r = w2r * 2
      a(0, 0) = a(0, 0) * 2
      a(1, 0) = a(1, 0) * w2r
      a(0, n2h) = a(0, n2h) * w2r
      end
!


c
c    A set of subroutines useful for spherical-earth calculations
c    ellipticity subs modified from ken creager's subs
c
	subroutine elpcr (elat,delta,azdg,depth,elpc,iphase,ic)
c
c   Compute ellipticity correction from dziewonski and gilbert
c   Geophys. J. R. Astr. Soc. (1976) 44, 7-17.
c   elat   =  epicentral latitude
c   delta  =  distance in degrees
c   azdg   =  azimuth from epicenter to receiver in degrees
c   depth  =  earthquake depth in km.
c   iphase =  0 for p or 1 for s
c   elpc   =  ellipticity correction in seconds
c   if input latitude is in geographic (?geocentric?) degrees   ic=0
c   if input latitude is in geocentric radians   ic=1
c
	common /elcor/  ecpd(37), ecp0(37,3), ecp1(37,3), ecp2(37,3),
     +    ecsd(22), ecs0(22,3), ecs1(22,3), ecs2(22,3)
	pi = 3.1415927
	if ( delta .lt. 0.0 )   go to 999
	if ( delta .gt. 180.0 ) go to 999

c   interpolate over distance and depth to get tau0, tau1, and tau2.

	if (iphase.eq.1) then
	   if ( delta .gt. 105. )  go to 999
	   call find ( ecsd, delta, 22, idl )
	   y = ( delta - ecsd(idl) ) / ( ecsd(idl+1) - ecsd(idl) )
	else
	   if ( delta .gt. 180. )  go to 999
	   call find ( ecpd, delta, 37, idl )
	   y = ( delta - ecpd(idl) ) / ( ecpd(idl+1) - ecpd(idl) )
	end if

	if ( depth .le. 300. )  then
	   idt = 1
	   x = depth / 300.
	   if (x .lt. 0.0) x=0.0
	else
	   idt = 2
	   x = (depth -  300. ) /   350.
	   if ( x .gt. 1.0 ) x = 1.0
	end if
	a = 1 - x - y + x*y
	b = x - x*y
	c = y - x*y
	d = x*y
	if (iphase.eq.1) then

	  tau0 = ecs0(idl,idt)*a + ecs0(idl,idt+1)*b + ecs0(idl+1,idt)*c +
     #	   ecs0(idl+1,idt+1)*d
	  tau1 = ecs1(idl,idt)*a + ecs1(idl,idt+1)*b + ecs1(idl+1,idt)*c +
     #	   ecs1(idl+1,idt+1)*d
	  tau2 = ecs2(idl,idt)*a + ecs2(idl,idt+1)*b + ecs2(idl+1,idt)*c +
     #	   ecs2(idl+1,idt+1)*d

	else

	  tau0 = ecp0(idl,idt)*a + ecp0(idl,idt+1)*b + ecp0(idl+1,idt)*c +
     #	   ecp0(idl+1,idt+1)*d
	  tau1 = ecp1(idl,idt)*a + ecp1(idl,idt+1)*b + ecp1(idl+1,idt)*c +
     #	   ecp1(idl+1,idt+1)*d
	  tau2 = ecp2(idl,idt)*a + ecp2(idl,idt+1)*b + ecp2(idl+1,idt)*c +
     #	   ecp2(idl+1,idt+1)*d

	endif

	theta = elat
	if (ic .eq. 0)  theta = theta * pi/180.
	theta = pi/2. - theta
	az = azdg * pi/180.
	c0 = ( 1. + 3. * cos(2.*theta) ) /4.
	c1 = sin(2.*theta) * cos(az) * sqrt(3.) / 2.
	c2 = sin(theta)*sin(theta) * cos(2.*az) * sqrt(3.) / 2.
	elpc = c0*tau0 + c1*tau1 + c2*tau2
	return
999	print 160 , delta,phase
160	format('delta = ',f8.1,'  which is out of the ellipticity',
     1'   correction range for ',a4,'phase')
	elpc = 0.0
	return
	end


      DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   X, Y
*     ..
*
*  Purpose
*  =======
*
*  DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
*  overflow.
*
*  Arguments
*  =========
*
*  X       (input) DOUBLE PRECISION
*  Y       (input) DOUBLE PRECISION
*          X and Y specify the values x and y.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   W, XABS, YABS, Z
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
      XABS = ABS( X )
      YABS = ABS( Y )
      W = MAX( XABS, YABS )
      Z = MIN( XABS, YABS )
      IF( Z.EQ.ZERO ) THEN
         DLAPY2 = W
      ELSE
         DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
      END IF
      RETURN
*
*     End of DLAPY2
*
      END