!=======================================================================
! This is part of the 2DECOMP&FFT library
!
! 2DECOMP&FFT is a software framework for general-purpose 2D (pencil)
! decomposition. It also implements a highly scalable distributed
! three-dimensional Fast Fourier Transform (FFT).
!
! Copyright (C) 2009-2012 Ning Li, the Numerical Algorithms Group (NAG)
!
!=======================================================================

! This is the FFTW implementation of the FFT library using
! the Fortran 2003 interface introduced in FFTW 3.3-beta1

module decomp_2d_fft

  use decomp_2d  ! 2D decomposition module
  use, intrinsic :: iso_c_binding

  implicit none

  include "fftw3.f03"

  private        ! Make everything private unless declared public

  ! engine-specific global variables
  integer, save :: plan_type = FFTW_MEASURE

  ! FFTW plans
  ! j=1,2,3 corresponds to the 1D FFTs in X,Y,Z direction, respectively
  ! For c2c transforms:
  !     use plan(-1,j) for  forward transform;
  !     use plan( 1,j) for backward transform;
  ! For r2c/c2r transforms:
  !     use plan(0,j) for r2c transforms;
  !     use plan(2,j) for c2r transforms;
  type(C_PTR), save :: plan(-1:2,3)

  integer, parameter, public :: DECOMP_2D_FFT_FORWARD = -1
  integer, parameter, public :: DECOMP_2D_FFT_BACKWARD = 1

  ! Physical space data can be stored in either X-pencil or Z-pencil
  integer, parameter, public :: PHYSICAL_IN_X = 1
  integer, parameter, public :: PHYSICAL_IN_Z = 3

  integer, save :: format                 ! input X-pencil or Z-pencil

  ! The libary can only be initialised once
  logical, save :: initialised = .false.

  ! Global size of the FFT
  integer, save :: nx_fft, ny_fft, nz_fft

  ! 2D processor grid
  integer, save, dimension(2) :: dims

  ! Decomposition objects
  TYPE(DECOMP_INFO), save :: ph  ! physical space
  TYPE(DECOMP_INFO), save :: sp  ! spectral space

  ! Workspace to store the intermediate Y-pencil data
  ! *** TODO: investigate how to use only one workspace array
  complex(mytype), pointer :: wk2_c2c(:,:,:), wk2_r2c(:,:,:), wk13(:,:,:)
  type(C_PTR) :: wk2_c2c_p, wk2_r2c_p, wk13_p

  public :: decomp_2d_fft_init, decomp_2d_fft_3d, &
       decomp_2d_fft_finalize, decomp_2d_fft_get_size

  ! Declare generic interfaces to handle different inputs

  interface decomp_2d_fft_init
     module procedure fft_init_noarg
     module procedure fft_init_arg
     module procedure fft_init_general
  end interface

  interface decomp_2d_fft_3d
     module procedure fft_3d_c2c
     module procedure fft_3d_r2c
     module procedure fft_3d_c2r
  end interface

contains

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Initialise the FFT module
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_init_noarg

    implicit none

    call fft_init_arg(PHYSICAL_IN_X)  ! default input is X-pencil data

    return
  end subroutine fft_init_noarg

  subroutine fft_init_arg(pencil)     ! allow to handle Z-pencil input

    implicit none

    integer, intent(IN) :: pencil

    call fft_init_general(pencil, nx_global, ny_global, nz_global)

    return
  end subroutine fft_init_arg

  ! Initialise the FFT library to perform arbitrary size transforms
  subroutine fft_init_general(pencil, nx, ny, nz)

    implicit none

    integer, intent(IN) :: pencil
    integer, intent(IN) :: nx, ny, nz

    logical, dimension(2) :: dummy_periods
    integer, dimension(2) :: dummy_coords
    integer :: status, errorcode
    integer(C_SIZE_T) :: sz, ierror

    if (initialised) then
       errorcode = 4
       call decomp_2d_abort(errorcode, &
            'FFT library should only be initialised once')
    end if

    format = pencil
    nx_fft = nx
    ny_fft = ny
    nz_fft = nz

    ! determine the processor grid in use
    call MPI_CART_GET(DECOMP_2D_COMM_CART_X, 2, &
         dims, dummy_periods, dummy_coords, ierror)

    ! for c2r/r2c interface:
    ! if in physical space, a real array is of size: nx*ny*nz
    ! in spectral space, the complex array is of size:
    !         (nx/2+1)*ny*nz, if PHYSICAL_IN_X
    !      or nx*ny*(nz/2+1), if PHYSICAL_IN_Z

    call decomp_info_init(nx, ny, nz, ph)
    if (format==PHYSICAL_IN_X) then
       call decomp_info_init(nx/2+1, ny, nz, sp)
    else if (format==PHYSICAL_IN_Z) then
       call decomp_info_init(nx, ny, nz/2+1, sp)
    end if

    sz = ph%ysz(1)*ph%ysz(2)*ph%ysz(3)
    wk2_c2c_p = fftw_alloc_complex(sz)
    call c_f_pointer(wk2_c2c_p,wk2_c2c,[ph%ysz(1),ph%ysz(2),ph%ysz(3)])

    sz = sp%ysz(1)*sp%ysz(2)*sp%ysz(3)
    wk2_r2c_p = fftw_alloc_complex(sz)
    call c_f_pointer(wk2_r2c_p,wk2_r2c,[sp%ysz(1),sp%ysz(2),sp%ysz(3)])

    if (format==PHYSICAL_IN_X) then
       sz = sp%xsz(1)*sp%xsz(2)*sp%xsz(3)
       wk13_p = fftw_alloc_complex(sz)
       call c_f_pointer(wk13_p,wk13,[sp%xsz(1),sp%xsz(2),sp%xsz(3)])
    else if (format==PHYSICAL_IN_Z) then
       sz = sp%zsz(1)*sp%zsz(2)*sp%zsz(3)
       wk13_p = fftw_alloc_complex(sz)
       call c_f_pointer(wk13_p,wk13,[sp%zsz(1),sp%zsz(2),sp%zsz(3)])
    end if

    call init_fft_engine

    initialised = .true.

    return
  end subroutine fft_init_general

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Final clean up
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine decomp_2d_fft_finalize

    implicit none

    call decomp_info_finalize(ph)
    call decomp_info_finalize(sp)

    call fftw_free(wk2_c2c_p)
    call fftw_free(wk2_r2c_p)
    call fftw_free(wk13_p)

    call finalize_fft_engine

    initialised = .false.

    return
  end subroutine decomp_2d_fft_finalize

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! Return the size, starting/ending index of the distributed array
  !  whose global size is (nx/2+1)*ny*nz, for defining data structures
  !  in r2c and c2r interfaces
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine decomp_2d_fft_get_size(istart, iend, isize)

    implicit none
    integer, dimension(3), intent(OUT) :: istart, iend, isize

    if (format==PHYSICAL_IN_X) then
       istart = sp%zst
       iend   = sp%zen
       isize  = sp%zsz
    else if (format==PHYSICAL_IN_Z) then
       istart = sp%xst
       iend   = sp%xen
       isize  = sp%xsz
    end if

    return
  end subroutine decomp_2d_fft_get_size

  ! Return a FFTW3 plan for multiple 1D c2c FFTs in X direction
  subroutine c2c_1m_x_plan(plan1, decomp, isign)

    implicit none

    type(C_PTR) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp
    integer, intent(IN) :: isign

    complex(mytype), pointer :: a1(:,:,:)
    type(C_PTR) :: a1_p
    integer(C_SIZE_T) :: sz

    sz = decomp%xsz(1)*decomp%xsz(2)*decomp%xsz(3)
    a1_p = fftw_alloc_complex(sz)
    call c_f_pointer(a1_p,a1,[decomp%xsz(1),decomp%xsz(2),decomp%xsz(3)])

#ifdef DOUBLE_PREC
    plan1 =  fftw_plan_many_dft(1, decomp%xsz(1), &
         decomp%xsz(2)*decomp%xsz(3), a1, decomp%xsz(1), 1, &
         decomp%xsz(1), a1, decomp%xsz(1), 1, decomp%xsz(1), &
         isign, plan_type)
#else
    plan1 = fftwf_plan_many_dft(1, decomp%xsz(1), &
         decomp%xsz(2)*decomp%xsz(3), a1, decomp%xsz(1), 1, &
         decomp%xsz(1), a1, decomp%xsz(1), 1, decomp%xsz(1), &
         isign, plan_type)
#endif

    call fftw_free(a1_p)

    return
  end subroutine c2c_1m_x_plan

  ! Return a FFTW3 plan for multiple 1D c2c FFTs in Y direction
  subroutine c2c_1m_y_plan(plan1, decomp, isign)

    implicit none

    type(C_PTR) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp
    integer, intent(IN) :: isign

    complex(mytype), pointer :: a1(:,:)
    type(C_PTR) :: a1_p
    integer(C_SIZE_T) :: sz

    ! Due to memory pattern of 3D arrays, 1D FFTs along Y have to be
    ! done one Z-plane at a time. So plan for 2D data sets here.
    sz = decomp%ysz(1)*decomp%ysz(2)
    a1_p = fftw_alloc_complex(sz)
    call c_f_pointer(a1_p,a1,[decomp%ysz(1),decomp%ysz(2)])

#ifdef DOUBLE_PREC
    plan1 =  fftw_plan_many_dft(1, decomp%ysz(2), decomp%ysz(1), &
         a1, decomp%ysz(2), decomp%ysz(1), 1, a1, decomp%ysz(2), &
         decomp%ysz(1), 1, isign, plan_type)
#else
    plan1 = fftwf_plan_many_dft(1, decomp%ysz(2), decomp%ysz(1), &
         a1, decomp%ysz(2), decomp%ysz(1), 1, a1, decomp%ysz(2), &
         decomp%ysz(1), 1, isign, plan_type)
#endif

    call fftw_free(a1_p)

    return
  end subroutine c2c_1m_y_plan

  ! Return a FFTW3 plan for multiple 1D c2c FFTs in Z direction
  subroutine c2c_1m_z_plan(plan1, decomp, isign)

    implicit none

    type(C_PTR) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp
    integer, intent(IN) :: isign

    complex(mytype), pointer :: a1(:,:,:)
    type(C_PTR) :: a1_p
    integer(C_SIZE_T) :: sz

    sz = decomp%zsz(1)*decomp%zsz(2)*decomp%zsz(3)
    a1_p = fftw_alloc_complex(sz)
    call c_f_pointer(a1_p,a1,[decomp%zsz(1),decomp%zsz(2),decomp%zsz(3)])

#ifdef DOUBLE_PREC
    plan1 =  fftw_plan_many_dft(1, decomp%zsz(3), &
         decomp%zsz(1)*decomp%zsz(2), a1, decomp%zsz(3), &
         decomp%zsz(1)*decomp%zsz(2), 1, a1, decomp%zsz(3), &
         decomp%zsz(1)*decomp%zsz(2), 1, isign, plan_type)
#else
    plan1 = fftwf_plan_many_dft(1, decomp%zsz(3), &
         decomp%zsz(1)*decomp%zsz(2), a1, decomp%zsz(3), &
         decomp%zsz(1)*decomp%zsz(2), 1, a1, decomp%zsz(3), &
         decomp%zsz(1)*decomp%zsz(2), 1, isign, plan_type)
#endif

    call fftw_free(a1_p)

    return
  end subroutine c2c_1m_z_plan

  ! Return a FFTW3 plan for multiple 1D r2c FFTs in X direction
  subroutine r2c_1m_x_plan(plan1, decomp_ph, decomp_sp)

    implicit none

    type(C_PTR) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp_ph
    TYPE(DECOMP_INFO), intent(IN) :: decomp_sp

    real(mytype), pointer :: a1(:,:,:)
    complex(mytype), pointer :: a2(:,:,:)
    type(C_PTR) :: a1_p, a2_p
    integer(C_SIZE_T) :: sz

    sz = decomp_ph%xsz(1)*decomp_ph%xsz(2)*decomp_ph%xsz(3)
    a1_p = fftw_alloc_real(sz)
    call c_f_pointer(a1_p,a1, &
         [decomp_ph%xsz(1),decomp_ph%xsz(2),decomp_ph%xsz(3)])
    sz = decomp_sp%xsz(1)*decomp_sp%xsz(2)*decomp_sp%xsz(3)
    a2_p = fftw_alloc_complex(sz)
    call c_f_pointer(a2_p,a2, &
         [decomp_sp%xsz(1),decomp_sp%xsz(2),decomp_sp%xsz(3)])

#ifdef DOUBLE_PREC
    plan1 =  fftw_plan_many_dft_r2c(1, decomp_ph%xsz(1), &
         decomp_ph%xsz(2)*decomp_ph%xsz(3), a1, decomp_ph%xsz(1), 1, &
         decomp_ph%xsz(1), a2, decomp_sp%xsz(1), 1, decomp_sp%xsz(1), &
         plan_type)
#else
    plan1 = fftwf_plan_many_dft_r2c(1, decomp_ph%xsz(1), &
         decomp_ph%xsz(2)*decomp_ph%xsz(3), a1, decomp_ph%xsz(1), 1, &
         decomp_ph%xsz(1), a2, decomp_sp%xsz(1), 1, decomp_sp%xsz(1), &
         plan_type)
#endif

    call fftw_free(a1_p)
    call fftw_free(a2_p)

    return
  end subroutine r2c_1m_x_plan

  ! Return a FFTW3 plan for multiple 1D c2r FFTs in X direction
  subroutine c2r_1m_x_plan(plan1, decomp_sp, decomp_ph)

    implicit none

    type(C_PTR) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp_sp
    TYPE(DECOMP_INFO), intent(IN) :: decomp_ph

    complex(mytype), pointer :: a1(:,:,:)
    real(mytype), pointer :: a2(:,:,:)
    type(C_PTR) :: a1_p, a2_p
    integer(C_SIZE_T) :: sz

    sz = decomp_sp%xsz(1)*decomp_sp%xsz(2)*decomp_sp%xsz(3)
    a1_p = fftw_alloc_complex(sz)
    call c_f_pointer(a1_p,a1, &
         [decomp_sp%xsz(1),decomp_sp%xsz(2),decomp_sp%xsz(3)])
    sz = decomp_ph%xsz(1)*decomp_ph%xsz(2)*decomp_ph%xsz(3)
    a2_p = fftw_alloc_real(sz)
    call c_f_pointer(a2_p,a2, &
         [decomp_ph%xsz(1),decomp_ph%xsz(2),decomp_ph%xsz(3)])

#ifdef DOUBLE_PREC
    plan1 =  fftw_plan_many_dft_c2r(1, decomp_ph%xsz(1), &
         decomp_ph%xsz(2)*decomp_ph%xsz(3), a1, decomp_sp%xsz(1), 1, &
         decomp_sp%xsz(1), a2, decomp_ph%xsz(1), 1, decomp_ph%xsz(1), &
         plan_type)
#else
    plan1 = fftwf_plan_many_dft_c2r(1, decomp_ph%xsz(1), &
         decomp_ph%xsz(2)*decomp_ph%xsz(3), a1, decomp_sp%xsz(1), 1, &
         decomp_sp%xsz(1), a2, decomp_ph%xsz(1), 1, decomp_ph%xsz(1), &
         plan_type)
#endif

    call fftw_free(a1_p)
    call fftw_free(a2_p)

    return
  end subroutine c2r_1m_x_plan

  ! Return a FFTW3 plan for multiple 1D r2c FFTs in Z direction
  subroutine r2c_1m_z_plan(plan1, decomp_ph, decomp_sp)

    implicit none

    type(C_PTR) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp_ph
    TYPE(DECOMP_INFO), intent(IN) :: decomp_sp

    real(mytype), pointer :: a1(:,:,:)
    complex(mytype), pointer :: a2(:,:,:)
    type(C_PTR) :: a1_p, a2_p
    integer(C_SIZE_T) :: sz

    sz = decomp_ph%zsz(1)*decomp_ph%zsz(2)*decomp_ph%zsz(3)
    a1_p = fftw_alloc_real(sz)
    call c_f_pointer(a1_p,a1, &
         [decomp_ph%zsz(1),decomp_ph%zsz(2),decomp_ph%zsz(3)])
    sz = decomp_sp%zsz(1)*decomp_sp%zsz(2)*decomp_sp%zsz(3)
    a2_p = fftw_alloc_complex(sz)
    call c_f_pointer(a2_p,a2, &
         [decomp_sp%zsz(1),decomp_sp%zsz(2),decomp_sp%zsz(3)])

#ifdef DOUBLE_PREC
    plan1 =  fftw_plan_many_dft_r2c(1, decomp_ph%zsz(3), &
         decomp_ph%zsz(1)*decomp_ph%zsz(2), a1, decomp_ph%zsz(3), &
         decomp_ph%zsz(1)*decomp_ph%zsz(2), 1, a2, decomp_sp%zsz(3), &
         decomp_sp%zsz(1)*decomp_sp%zsz(2), 1, plan_type)
#else
    plan1 = fftwf_plan_many_dft_r2c(1, decomp_ph%zsz(3), &
         decomp_ph%zsz(1)*decomp_ph%zsz(2), a1, decomp_ph%zsz(3), &
         decomp_ph%zsz(1)*decomp_ph%zsz(2), 1, a2, decomp_sp%zsz(3), &
         decomp_sp%zsz(1)*decomp_sp%zsz(2), 1, plan_type)
#endif

    call fftw_free(a1_p)
    call fftw_free(a2_p)

    return
  end subroutine r2c_1m_z_plan

  ! Return a FFTW3 plan for multiple 1D c2r FFTs in Z direction
  subroutine c2r_1m_z_plan(plan1, decomp_sp, decomp_ph)

    implicit none

    type(C_PTR) :: plan1
    TYPE(DECOMP_INFO), intent(IN) :: decomp_sp
    TYPE(DECOMP_INFO), intent(IN) :: decomp_ph

    complex(mytype), pointer :: a1(:,:,:)
    real(mytype), pointer :: a2(:,:,:)
    type(C_PTR) :: a1_p, a2_p
    integer(C_SIZE_T) :: sz

    sz = decomp_sp%zsz(1)*decomp_sp%zsz(2)*decomp_sp%zsz(3)
    a1_p = fftw_alloc_complex(sz)
    call c_f_pointer(a1_p,a1, &
         [decomp_sp%zsz(1),decomp_sp%zsz(2),decomp_sp%zsz(3)])
    sz = decomp_ph%zsz(1)*decomp_ph%zsz(2)*decomp_ph%zsz(3)
    a2_p = fftw_alloc_real(sz)
    call c_f_pointer(a2_p,a2, &
         [decomp_ph%zsz(1),decomp_ph%zsz(2),decomp_ph%zsz(3)])

#ifdef DOUBLE_PREC
    plan1 =  fftw_plan_many_dft_c2r(1, decomp_ph%zsz(3), &
         decomp_ph%zsz(1)*decomp_ph%zsz(2), a1, decomp_sp%zsz(3), &
         decomp_sp%zsz(1)*decomp_sp%zsz(2), 1, a2, decomp_ph%zsz(3), &
         decomp_ph%zsz(1)*decomp_ph%zsz(2), 1, plan_type)
#else
    plan1 = fftwf_plan_many_dft_c2r(1, decomp_ph%zsz(3), &
         decomp_ph%zsz(1)*decomp_ph%zsz(2), a1, decomp_sp%zsz(3), &
         decomp_sp%zsz(1)*decomp_sp%zsz(2), 1, a2, decomp_ph%zsz(3), &
         decomp_ph%zsz(1)*decomp_ph%zsz(2), 1, plan_type)
#endif

    call fftw_free(a1_p)
    call fftw_free(a2_p)

    return
  end subroutine c2r_1m_z_plan

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  This routine performs one-time initialisations for the FFT engine
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine init_fft_engine

    implicit none

    if (nrank==0) then
       write(*,*) ' '
       write(*,*) '***** Using the FFTW (F2003 interface) engine *****'
       write(*,*) ' '
    end if

    if (format == PHYSICAL_IN_X) then

       ! For C2C transforms
       call c2c_1m_x_plan(plan(-1,1), ph, FFTW_FORWARD )
       call c2c_1m_y_plan(plan(-1,2), ph, FFTW_FORWARD )
       call c2c_1m_z_plan(plan(-1,3), ph, FFTW_FORWARD )
       call c2c_1m_z_plan(plan( 1,3), ph, FFTW_BACKWARD)
       call c2c_1m_y_plan(plan( 1,2), ph, FFTW_BACKWARD)
       call c2c_1m_x_plan(plan( 1,1), ph, FFTW_BACKWARD)

       ! For R2C/C2R tranforms
       call r2c_1m_x_plan(plan(0,1), ph, sp)
       call c2c_1m_y_plan(plan(0,2), sp, FFTW_FORWARD )
       call c2c_1m_z_plan(plan(0,3), sp, FFTW_FORWARD )
       call c2c_1m_z_plan(plan(2,3), sp, FFTW_BACKWARD)
       call c2c_1m_y_plan(plan(2,2), sp, FFTW_BACKWARD)
       call c2r_1m_x_plan(plan(2,1), sp, ph)

    else if (format == PHYSICAL_IN_Z) then

       ! For C2C transforms
       call c2c_1m_z_plan(plan(-1,3), ph, FFTW_FORWARD )
       call c2c_1m_y_plan(plan(-1,2), ph, FFTW_FORWARD )
       call c2c_1m_x_plan(plan(-1,1), ph, FFTW_FORWARD )
       call c2c_1m_x_plan(plan( 1,1), ph, FFTW_BACKWARD)
       call c2c_1m_y_plan(plan( 1,2), ph, FFTW_BACKWARD)
       call c2c_1m_z_plan(plan( 1,3), ph, FFTW_BACKWARD)

       ! For R2C/C2R tranforms
       call r2c_1m_z_plan(plan(0,3), ph, sp)
       call c2c_1m_y_plan(plan(0,2), sp, FFTW_FORWARD )
       call c2c_1m_x_plan(plan(0,1), sp, FFTW_FORWARD )
       call c2c_1m_x_plan(plan(2,1), sp, FFTW_BACKWARD)
       call c2c_1m_y_plan(plan(2,2), sp, FFTW_BACKWARD)
       call c2r_1m_z_plan(plan(2,3), sp, ph)

    end if

    return
  end subroutine init_fft_engine

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  This routine performs one-time finalisations for the FFT engine
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine finalize_fft_engine

    implicit none

    integer :: i,j

    do j=1,3
       do i=-1,2
#ifdef DOUBLE_PREC
          call fftw_destroy_plan(plan(i,j))
#else
          call fftwf_destroy_plan(plan(i,j))
#endif
       end do
    end do

    return
  end subroutine finalize_fft_engine

  ! Following routines calculate multiple one-dimensional FFTs to form
  ! the basis of three-dimensional FFTs.

  ! c2c transform, multiple 1D FFTs in x direction
  subroutine c2c_1m_x(inout, isign, plan1)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
    integer, intent(IN) :: isign
    type(C_PTR) :: plan1

#ifdef DOUBLE_PREC
    call fftw_execute_dft(plan1, inout, inout)
#else
    call fftwf_execute_dft(plan1, inout, inout)
#endif

    return
  end subroutine c2c_1m_x

  ! c2c transform, multiple 1D FFTs in y direction
  subroutine c2c_1m_y(inout, isign, plan1)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
    integer, intent(IN) :: isign
    type(C_PTR) :: plan1

    integer :: k, s3

    s3 = size(inout,3)

    do k=1,s3  ! transform on one Z-plane at a time
#ifdef DOUBLE_PREC
       call fftw_execute_dft(plan1, inout(:,:,k), inout(:,:,k))
#else
       call fftwf_execute_dft(plan1, inout(:,:,k), inout(:,:,k))
#endif
    end do

    return
  end subroutine c2c_1m_y

  ! c2c transform, multiple 1D FFTs in z direction
  subroutine c2c_1m_z(inout, isign, plan1)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: inout
    integer, intent(IN) :: isign
    type(C_PTR) :: plan1

#ifdef DOUBLE_PREC
       call fftw_execute_dft(plan1, inout, inout)
#else
       call fftwf_execute_dft(plan1, inout, inout)
#endif

    return
  end subroutine c2c_1m_z

  ! r2c transform, multiple 1D FFTs in x direction
  subroutine r2c_1m_x(input, output)

    implicit none

    real(mytype), dimension(:,:,:), intent(INOUT)  ::  input
    complex(mytype), dimension(:,:,:), intent(OUT) :: output

#ifdef DOUBLE_PREC
    call fftw_execute_dft_r2c(plan(0,1), input, output)
#else
    call fftwf_execute_dft_r2c(plan(0,1), input, output)
#endif

    return

  end subroutine r2c_1m_x

  ! r2c transform, multiple 1D FFTs in z direction
  subroutine r2c_1m_z(input, output)

    implicit none

    real(mytype), dimension(:,:,:), intent(INOUT)  ::  input
    complex(mytype), dimension(:,:,:), intent(OUT) :: output

#ifdef DOUBLE_PREC
    call fftw_execute_dft_r2c(plan(0,3), input, output)
#else
    call fftwf_execute_dft_r2c(plan(0,3), input, output)
#endif

    return

  end subroutine r2c_1m_z

  ! c2r transform, multiple 1D FFTs in x direction
  subroutine c2r_1m_x(input, output)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT)  ::  input
    real(mytype), dimension(:,:,:), intent(OUT) :: output

#ifdef DOUBLE_PREC
    call fftw_execute_dft_c2r(plan(2,1), input, output)
#else
    call fftwf_execute_dft_c2r(plan(2,1), input, output)
#endif

    return

  end subroutine c2r_1m_x

  ! c2r transform, multiple 1D FFTs in z direction
  subroutine c2r_1m_z(input, output)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: input
    real(mytype), dimension(:,:,:), intent(OUT) :: output

#ifdef DOUBLE_PREC
    call fftw_execute_dft_c2r(plan(2,3), input, output)
#else
    call fftwf_execute_dft_c2r(plan(2,3), input, output)
#endif

    return

  end subroutine c2r_1m_z

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D FFT - complex to complex
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_c2c(in, out, isign)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: in
    complex(mytype), dimension(:,:,:), intent(OUT) :: out
    integer, intent(IN) :: isign

#ifndef OVERWRITE
    complex(mytype), pointer :: wk1(:,:,:)
    integer(C_SIZE_T) :: sz
    type(C_PTR) :: wk1_p
#endif

    if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_FORWARD .OR.  &
         format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_BACKWARD) then

       ! ===== 1D FFTs in X =====
#ifdef OVERWRITE
       call c2c_1m_x(in,isign,plan(isign,1))
#else
       sz = ph%xsz(1)*ph%xsz(2)*ph%xsz(3)
       wk1_p = fftw_alloc_complex(sz)
       call c_f_pointer(wk1_p, wk1, [ph%xsz(1),ph%xsz(2),ph%xsz(3)])
       wk1 = in
       call c2c_1m_x(wk1,isign,plan(isign,1))
#endif

       ! ===== Swap X --> Y; 1D FFTs in Y =====

       if (dims(1)>1) then
#ifdef OVERWRITE
          call transpose_x_to_y(in,wk2_c2c,ph)
#else
          call transpose_x_to_y(wk1,wk2_c2c,ph)
#endif
          call c2c_1m_y(wk2_c2c,isign,plan(isign,2))
       else
#ifdef OVERWRITE
          call c2c_1m_y(in,isign,plan(isign,2))
#else
          call c2c_1m_y(wk1,isign,plan(isign,2))
#endif
       end if

       ! ===== Swap Y --> Z; 1D FFTs in Z =====
       if (dims(1)>1) then
          call transpose_y_to_z(wk2_c2c,out,ph)
       else
#ifdef OVERWRITE
          call transpose_y_to_z(in,out,ph)
#else
          call transpose_y_to_z(wk1,out,ph)
#endif
       end if
       call c2c_1m_z(out,isign,plan(isign,3))

    else if (format==PHYSICAL_IN_X .AND. isign==DECOMP_2D_FFT_BACKWARD &
         .OR. &
         format==PHYSICAL_IN_Z .AND. isign==DECOMP_2D_FFT_FORWARD) then

       ! ===== 1D FFTs in Z =====
#ifdef OVERWRITE
       call c2c_1m_z(in,isign,plan(isign,3))
#else
       sz = ph%zsz(1)*ph%zsz(2)*ph%zsz(3)
       wk1_p = fftw_alloc_complex(sz)
       call c_f_pointer(wk1_p, wk1, [ph%zsz(1),ph%zsz(2),ph%zsz(3)])
       wk1 = in
       call c2c_1m_z(wk1,isign,plan(isign,3))
#endif

       ! ===== Swap Z --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
#ifdef OVERWRITE
          call transpose_z_to_y(in,wk2_c2c,ph)
#else
          call transpose_z_to_y(wk1,wk2_c2c,ph)
#endif
          call c2c_1m_y(wk2_c2c,isign,plan(isign,2))
       else  ! out==wk2_c2c if 1D decomposition
#ifdef OVERWRITE
          call transpose_z_to_y(in,out,ph)
#else
          call transpose_z_to_y(wk1,out,ph)
#endif
          call c2c_1m_y(out,isign,plan(isign,2))
       end if

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(wk2_c2c,out,ph)
       end if
       call c2c_1m_x(out,isign,plan(isign,1))

    end if

#ifndef OVERWRITE
    call fftw_free(wk1_p)
#endif

    return
  end subroutine fft_3d_c2c

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D forward FFT - real to complex
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_r2c(in_r, out_c)

    implicit none

    real(mytype), dimension(:,:,:), intent(INOUT) :: in_r
    complex(mytype), dimension(:,:,:), intent(OUT) :: out_c

    if (format==PHYSICAL_IN_X) then

       ! ===== 1D FFTs in X =====
       call r2c_1m_x(in_r,wk13)

       ! ===== Swap X --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
          call transpose_x_to_y(wk13,wk2_r2c,sp)
          call c2c_1m_y(wk2_r2c,-1,plan(0,2))
       else
          call c2c_1m_y(wk13,-1,plan(0,2))
       end if

       ! ===== Swap Y --> Z; 1D FFTs in Z =====
       if (dims(1)>1) then
          call transpose_y_to_z(wk2_r2c,out_c,sp)
       else
          call transpose_y_to_z(wk13,out_c,sp)
       end if
       call c2c_1m_z(out_c,-1,plan(0,3))

    else if (format==PHYSICAL_IN_Z) then

       ! ===== 1D FFTs in Z =====
       call r2c_1m_z(in_r,wk13)

       ! ===== Swap Z --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
          call transpose_z_to_y(wk13,wk2_r2c,sp)
          call c2c_1m_y(wk2_r2c,-1,plan(0,2))
       else  ! out_c==wk2_r2c if 1D decomposition
          call transpose_z_to_y(wk13,out_c,sp)
          call c2c_1m_y(out_c,-1,plan(0,2))
       end if

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(wk2_r2c,out_c,sp)
       end if
       call c2c_1m_x(out_c,-1,plan(0,1))

    end if

    return
  end subroutine fft_3d_r2c

  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  ! 3D inverse FFT - complex to real
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine fft_3d_c2r(in_c, out_r)

    implicit none

    complex(mytype), dimension(:,:,:), intent(INOUT) :: in_c
    real(mytype), dimension(:,:,:), intent(OUT) :: out_r

#ifndef OVERWRITE
    complex(mytype), pointer :: wk1(:,:,:)
    integer(C_SIZE_T) :: sz
    type(C_PTR) :: wk1_p
#endif

    if (format==PHYSICAL_IN_X) then

       ! ===== 1D FFTs in Z =====
#ifdef OVERWRITE
       call c2c_1m_z(in_c,1,plan(2,3))
#else
       sz = sp%zsz(1)*sp%zsz(2)*sp%zsz(3)
       wk1_p = fftw_alloc_complex(sz)
       call c_f_pointer(wk1_p, wk1, [sp%zsz(1),sp%zsz(2),sp%zsz(3)])
       wk1 = in_c
       call c2c_1m_z(wk1,1,plan(2,3))
#endif

       ! ===== Swap Z --> Y; 1D FFTs in Y =====
#ifdef OVERWRITE
       call transpose_z_to_y(in_c,wk2_r2c,sp)
#else
       call transpose_z_to_y(wk1,wk2_r2c,sp)
#endif
       call c2c_1m_y(wk2_r2c,1,plan(2,2))

       ! ===== Swap Y --> X; 1D FFTs in X =====
       if (dims(1)>1) then
          call transpose_y_to_x(wk2_r2c,wk13,sp)
          call c2r_1m_x(wk13,out_r)
       else
          call c2r_1m_x(wk2_r2c,out_r)
       end if

    else if (format==PHYSICAL_IN_Z) then

       ! ===== 1D FFTs in X =====
#ifdef OVERWRITE
       call c2c_1m_x(in_c,1,plan(2,1))
#else
       sz = sp%xsz(1)*sp%xsz(2)*sp%xsz(3)
       wk1_p = fftw_alloc_complex(sz)
       call c_f_pointer(wk1_p, wk1, [sp%xsz(1),sp%xsz(2),sp%xsz(3)])
       wk1 = in_c
       call c2c_1m_x(wk1,1,plan(2,1))
#endif

       ! ===== Swap X --> Y; 1D FFTs in Y =====
       if (dims(1)>1) then
#ifdef OVERWRITE
          call transpose_x_to_y(in_c,wk2_r2c,sp)
#else
          call transpose_x_to_y(wk1,wk2_r2c,sp)
#endif
          call c2c_1m_y(wk2_r2c,1,plan(2,2))
       else  ! in_c==wk2_r2c if 1D decomposition
#ifdef OVERWRITE
          call c2c_1m_y(in_c,1,plan(2,2))
#else
          call c2c_1m_y(wk1,1,plan(2,2))
#endif
       end if

       ! ===== Swap Y --> Z; 1D FFTs in Z =====
       if (dims(1)>1) then
          call transpose_y_to_z(wk2_r2c,wk13,sp)
       else
#ifdef OVERWRITE
          call transpose_y_to_z(in_c,wk13,sp)
#else
          call transpose_y_to_z(wk1,wk13,sp)
#endif
       end if
       call c2r_1m_z(wk13,out_r)

    end if

#ifndef OVERWRITE
    call fftw_free(wk1_p)
#endif

    return
  end subroutine fft_3d_c2r

end module decomp_2d_fft


!!$! NOTE: this program only works for L=0!
!!$MODULE delta_fun
!!$  IMPLICIT NONE
!!$
!!$CONTAINS
!!$
!!$  FUNCTION delta_kr(M,N)
!!$    IMPLICIT NONE
!!$    DOUBLE PRECISION :: M,N
!!$    INTEGER DELTA_KR
!!$    IF(M.EQ.N) DELTA_KR = 1
!!$    IF(M.NE.N) DELTA_KR = 0
!!$  END FUNCTION delta_kr
!!$END MODULE delta_fun
!!$
!!$PROGRAM IJtoF_MatrixTest
!!$
!!$  IMPLICIT NONE
!!$  DOUBLE PRECISION L,S,I,Total_states_LSI,F,J
!!$  DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: CLEBSH_GORDAN_JtoF
!!$  INTEGER N,i_
!!$
!!$  L = 0.0
!!$  S = 0.5
!!$  I = 1.5
!!$
!!$  !----- Counting the number of states
!!$  J = L+S
!!$  Total_states_LSI = 0
!!$  DO WHILE(J.GE.ABS(L-S))
!!$     F = I+J
!!$     DO WHILE(F.GE.ABS(J-I))
!!$        Total_states_LSI = Total_states_LSI + 2*F + 1
!!$        F = F - 1
!!$     END DO
!!$     J= J - 1 ! only two values allowed for J: J = L+1/2 and J=L-1/2
!!$  END DO
!!$  J = L+S  ! reseting value of J modified before
!!$
!!$  N = INT(Total_states_LSI)
!!$  write(*,*) Total_states_LSI,J,I
!!$  ALLOCATE(CLEBSH_GORDAN_JtoF(N,N))
!!$
!!$  CALL IJtoF_Matrix(L,S,I,N,CLEBSH_GORDAN_JtoF)
!!$
!!$  write(*,208) (CLEBSH_GORDAN_JtoF(:,i_), i_=1,N)
!!$
!!$208 FORMAT(8E15.6)
!!$END PROGRAM IJtoF_MatrixTest

SUBROUTINE IJtoF_Matrix(L,S,I,Total_states_LSI,CLEBSH_GORDAN_JtoF)

  !USE delta_fun
  USE FUNCIONES
  IMPLICIT NONE
  DOUBLE PRECISION, INTENT(IN) ::L,S,I
  INTEGER, INTENT(IN) :: Total_states_LSI
  DOUBLE PRECISION, DIMENSION(Total_states_LSI,Total_states_LSI), INTENT(OUT) :: CLEBSH_GORDAN_JtoF

  DOUBLE PRECISION, DIMENSION(Total_states_LSI,4) :: STATE
  DOUBLE PRECISION J,F,J_,CB,mF
  DOUBLE PRECISION mI,mI_,mJ,mJ_,M,M_
  INTEGER u,r,p,o,v,k,w

  !Build the Clebsh-Gordan Matrix for {|IJmImJ> --> |IJFmF>}

!  write(*,*) Total_states_LSI
  r = 0
  p = 0
  J = L+S
  CLEBSH_GORDAN_JtoF  = 0.0
  DO u =0,int(2*(L+S+I))                                           ! POSSIBLE VALUES FOR mF
     mF = L+S+I - u
     DO v=0,0
        J_ = L+S-v                                                 ! SET THE ELECTRONIC ANGULAR MOMENTUM J_
        F = L+S+I - v                                              ! SET THE TOTAL ANGULAR MOMENTUM F
        o = 0
        DO WHILE (ABS(mF).LE.F .AND. F.GE.ABS(J_-I))
           r = r + 1
           p = r - o

           STATE(r,1) = I
           STATE(r,2) = J_
           STATE(r,3) = F
           STATE(r,4) = mF

           mJ = J
           mI = mF-J
           if(abs(mI).GT.I)  then
              mJ = -J
              mI = mF + J
           end if
!           write(*,*) mJ,mI
           DO WHILE ((mJ.GE.-J).AND.(ABS(mI).LE.I))
              !r = r + 1

              !DO w = 0,int(2*I)
              !mI = I-w                                             ! POSSIBLE VALUES OF mI
              ! INITIAL VALUE OF J
              !DO WHILE(J.GE.ABS(L-S))
              !DO k = 0,int(2*J)
              !   mJ= J - k                                      ! POSSIBLE VALUES OF mJ

              CALL cb_fun(int(2.0*J),int(2.0*I),int(2.0*F), &
                   & int(2.0*mJ),int(2.0*mI),int(2.0*mF),CB) ! CLEBSH-GORDAN COEFFICIENTE <F,mF|J,I,mJ,mi>

              CLEBSH_GORDAN_JtoF(r,p) = CB*delta_kr(J_,J)
!              write(*,*) r,p,mI,mJ,F,mF,CLEBSH_GORDAN_JtoF(r,p)
              p = p+1
              mJ = mJ - 1
              mI = mI + 1
              !   J= J - 1                                         ! only two values allowed for J: J = L+1/2 and J=L-1/2
              !END DO
              o=1
           END DO
           F =F-1                                                 ! change the value of F
        END DO
     END DO
  END DO

END SUBROUTINE IJtoF_Matrix
FUNCTION delta_kr(M,N)
  IMPLICIT NONE
  DOUBLE PRECISION :: M,N
  INTEGER DELTA_KR
  IF(M.EQ.N) DELTA_KR = 1
  IF(M.NE.N) DELTA_KR = 0
END FUNCTION delta_kr


      SUBROUTINE SPROD (X,Y,SCAL,R1,R2)
*+
*  - - - - - - - - - - -
*   S P R O D
*  - - - - - - - - - - -
*
*  This routine is part of the International Earth Rotation and
*  Reference Systems Service (IERS) Conventions software collection.
*
*  This subroutine computes the scalar product of two vectors and
*  their norms.
*
*  In general, Class 1, 2, and 3 models represent physical effects that
*  act on geodetic parameters while canonical models provide lower-level
*  representations or basic computations that are used by Class 1, 2, or
*  3 models.
*
*  Status: Canonical model
*
*     Class 1 models are those recommended to be used a priori in the
*     reduction of raw space geodetic data in order to determine
*     geodetic parameter estimates.
*     Class 2 models are those that eliminate an observational
*     singularity and are purely conventional in nature.
*     Class 3 models are those that are not required as either Class
*     1 or 2.
*     Canonical models are accepted as is and cannot be classified as a
*     Class 1, 2, or 3 model.
*
*  Given:
*     X            d(3)      components of vector x
*     Y            d(3)      components of vector y
*
*  Returned:
*     SCAL         d      scalar product of vector x and vector y
*     R1           d      length of vector x
*     R2           d      length of vector y
*
*  Called:
*     None
*
*  Test case:
*     given input: X(1) = 2D0	Y(1) = 1D0
*                  X(2) = 2D0	Y(2) = 3D0
*                  X(3) = 3D0	Y(3) = 4D0
*
*     expected output: SCAL = 20D0
*                      R1 = 4.123105625617660586D0
*                      R2 = 5.099019513592784492D0
*
*  References:
*
*     Mathews, P. M., Dehant, V., and Gipson, J. M., 1997, ''Tidal station
*     displacements," J. Geophys. Res., 102(B9), pp. 20,469-20,477
*
*     Petit, G. and Luzum, B. (eds.), IERS Conventions (2010),
*     IERS Technical Note No. 36, BKG (2010)
*
*  Revisions:
*  2009 July 10 B.E.Stetzler Initial standardization of function,
*                            explicit exponential notation and
*                            provided a test case
*-----------------------------------------------------------------------

      IMPLICIT NONE
      DOUBLE PRECISION X(3), Y(3), R1, R2, SCAL

      R1=DSQRT(X(1)*X(1)+X(2)*X(2)+X(3)*X(3))
      R2=DSQRT(Y(1)*Y(1)+Y(2)*Y(2)+Y(3)*Y(3))
      SCAL=X(1)*Y(1)+X(2)*Y(2)+X(3)*Y(3)

      RETURN

* Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2008
*  IERS Conventions Center
*
*  ==================================
*  IERS Conventions Software License
*  ==================================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING TERMS AND CONDITIONS
*  WHICH APPLY TO ITS USE.
*
*  1. The Software is provided by the IERS Conventions Center ("the
*     Center").
*
*  2. Permission is granted to anyone to use the Software for any
*     purpose, including commercial applications, free of charge,
*     subject to the conditions and restrictions listed below.
*
*  3. You (the user) may adapt the Software and its algorithms for your
*     own purposes and you may distribute the resulting "derived work"
*     to others, provided that the derived work complies with the
*     following requirements:
*
*     a) Your work shall be clearly identified so that it cannot be
*        mistaken for IERS Conventions software and that it has been
*        neither distributed by nor endorsed by the Center.
*
*     b) Your work (including source code) must contain descriptions of
*        how the derived work is based upon and/or differs from the
*        original Software.
*
*     c) The name(s) of all modified routine(s) that you distribute
*        shall be changed.
*
*     d) The origin of the IERS Conventions components of your derived
*        work must not be misrepresented; you must not claim that you
*        wrote the original Software.
*
*     e) The source code must be included for all routine(s) that you
*        distribute.  This notice must be reproduced intact in any
*        source distribution.
*
*  4. In any published work produced by the user and which includes
*     results achieved by using the Software, you shall acknowledge
*     that the Software was used in obtaining those results.
*
*  5. The Software is provided to the user "as is" and the Center makes
*     no warranty as to its use or performance.   The Center does not
*     and cannot warrant the performance or results which the user may
*     obtain by using the Software.  The Center makes no warranties,
*     express or implied, as to non-infringement of third party rights,
*     merchantability, or fitness for any particular purpose.  In no
*     event will the Center be liable to the user for any consequential,
*     incidental, or special damages, including any lost profits or lost
*     savings, even if a Center representative has been advised of such
*     damages, or for any claim by any third party.
*
*  Correspondence concerning IERS Conventions software should be
*  addressed as follows:
*
*                     Gerard Petit
*     Internet email: gpetit[at]bipm.org
*     Postal address: IERS Conventions Center
*                     Time, frequency and gravimetry section, BIPM
*                     Pavillon de Breteuil
*                     92312 Sevres  FRANCE
*
*     or
*
*                     Brian Luzum
*     Internet email: brian.luzum[at]usno.navy.mil
*     Postal address: IERS Conventions Center
*                     Earth Orientation Department
*                     3450 Massachusetts Ave, NW
*                     Washington, DC 20392
*
*
*-----------------------------------------------------------------------
      END


      subroutine setprob

      implicit none

      common /cqinit/ x1,x2

      common /comaux/ Zl, cl, Zr, cr
      double precision rhol, Zl, cl, rhor, Zr, cr
      double precision x1,x2
c
c     # Set the material parameters for the acoustic equations
c
      character*25 fname

      fname = 'setprob.data'
      call opendatafile(7, fname)

c     # x1,x2 for initial conditions:
      read(7,*) x1
      read(7,*) x2
c
c     # Piecewise constant medium with single interface at x=0
c     # Density and sound speed to left and right:
      read(7,*) rhol
      read(7,*) cl
      Zl = rhol*cl

      read(7,*) rhor
      read(7,*) cr
      Zr = rhor*cr

      return
      end


! tensor.f90
!
!>  Tensor utility module
!
!> @copyright
!> 2015 Lesley De Cruz & Jonathan Demaeyer.
!> See LICENSE.txt for license information.
!
!---------------------------------------------------------------------------!

MODULE tensor
  USE params, only: ndim
  IMPLICIT NONE

  PRIVATE

  !> Coordinate list element type. Elementary elements of the sparse tensors.
  TYPE :: coolist_elem
     INTEGER :: j !< Index \f$j\f$ of the element
     INTEGER :: k !< Index \f$k\f$ of the element
     REAL(KIND=8) :: v !< Value of the element
  END TYPE coolist_elem

  !> Coordinate list. Type used to represent the sparse tensor.
  TYPE, PUBLIC :: coolist
     TYPE(coolist_elem), DIMENSION(:), ALLOCATABLE :: elems !< Lists of elements tensor::coolist_elem
     INTEGER :: nelems = 0 !< Number of elements in the list.
  END TYPE coolist

  !> Parameter to test the equality with zero.
  REAL(KIND=8), PARAMETER :: real_eps = 2.2204460492503131e-16

  PUBLIC :: sparse_mul3,sparse_mul2,copy_coo,mat_to_coo,jsparse_mul,jsparse_mul_mat,simplify
  PUBLIC :: add_elem,add_to_tensor,print_tensor,load_tensor_from_file,write_tensor_to_file,add_check

CONTAINS

  !> Routine to copy a coolist.
  !> @param src Source coolist
  !> @param dst Destination coolist
  !> @remark The destination tensor have to be an empty tensor, i.e. with unallocated list of elements and nelems set to 0.
  SUBROUTINE copy_coo(src,dst)
    TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: src
    TYPE(coolist), DIMENSION(ndim), INTENT(OUT) :: dst
    INTEGER :: i,j,AllocStat

    DO i=1,ndim
       IF (dst(i)%nelems/=0) STOP "*** copy_coo : Destination coolist not empty ! ***"
       ALLOCATE(dst(i)%elems(src(i)%nelems), STAT=AllocStat)
       IF (AllocStat /= 0) then
         print *, "copy_coo:: AllocStat = ", AllocStat
         STOP "*** Not enough memory ! ***"
       ENDIF
       DO j=1,src(i)%nelems
          dst(i)%elems(j)%j=src(i)%elems(j)%j
          dst(i)%elems(j)%k=src(i)%elems(j)%k
          dst(i)%elems(j)%v=src(i)%elems(j)%v
       ENDDO
       dst(i)%nelems=src(i)%nelems
    ENDDO
  END SUBROUTINE copy_coo

  !> Routine to convert a matrix to a tensor.
  !> @param src Source matrix
  !> @param dst Destination tensor
  !> @remark The destination tensor have to be an empty tensor, i.e. with unallocated list of elements and nelems set to 0.
  SUBROUTINE mat_to_coo(src,dst)
    REAL(KIND=8), DIMENSION(0:ndim,0:ndim), INTENT(IN) :: src
    TYPE(coolist), DIMENSION(ndim), INTENT(OUT) :: dst
    INTEGER :: i,j,n,AllocStat
    DO i=1,ndim
       n=0
       DO j=1,ndim
          IF (ABS(src(i,j))>real_eps) n=n+1
       ENDDO
       IF (dst(i)%nelems/=0) STOP "*** mat_to_coo : Destination coolist not empty ! ***"
       ALLOCATE(dst(i)%elems(n), STAT=AllocStat)
       IF (AllocStat /= 0) then
         print *, "mat_to_coo:: AllocStat = ", AllocStat
         STOP "*** Not enough memory ! ***"
       ENDIF
       n=0
       DO j=1,ndim
          IF (ABS(src(i,j))>real_eps) THEN
             n=n+1
             dst(i)%elems(n)%j=j
             dst(i)%elems(n)%k=0
             dst(i)%elems(n)%v=src(i,j)
          ENDIF
       ENDDO
       dst(i)%nelems=n
    ENDDO
  END SUBROUTINE mat_to_coo

  !> Sparse multiplication of a tensor with two vectors:  \f${\displaystyle \sum_{j,k=0}^{ndim}} \mathcal{T}_{i,j,k} \, a_j \,b_k\f$.
  !> @param coolist_ijk a coordinate list (sparse tensor) of which index
  !> 2 and 3 will be contracted.
  !> @param arr_j the vector to be contracted with index 2 of coolist_ijk
  !> @param arr_k the vector to be contracted with index 3 of coolist_ijk
  !> @param res vector (buffer) to store the result of the contraction
  !> @remark Note that it is NOT safe to pass `arr_j`/`arr_k` as a result buffer,
  !> as this operation does multiple passes.
  SUBROUTINE sparse_mul3(coolist_ijk, arr_j, arr_k, res)
    TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ijk
    REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN)  :: arr_j, arr_k
    REAL(KIND=8), DIMENSION(0:ndim), INTENT(OUT) :: res
    INTEGER :: i,j,k,n
    res=0.D0
    DO i=1,ndim
       DO n=1,coolist_ijk(i)%nelems
         j=coolist_ijk(i)%elems(n)%j
         k=coolist_ijk(i)%elems(n)%k
         res(i) = res(i) + coolist_ijk(i)%elems(n)%v * arr_j(j)*arr_k(k)
      END DO
   END DO
  END SUBROUTINE sparse_mul3

  !> Sparse multiplication of two tensors to determine the Jacobian:
  !> \f[J_{i,j} = {\displaystyle \sum_{k=0}^{ndim}} \left( \mathcal{T}_{i,j,k} + \mathcal{T}_{i,k,j} \right) \, a_k.\f]
  !> It's implemented slightly differently: for every \f$\mathcal{T}_{i,j,k}\f$, we add to \f$J_{i,j}\f$ as follows:
  !> \f[J_{i,j} = J_{i,j} + \mathcal{T}_{i,j,k} \, a_k \\ J_{i,k} = J_{i,k} + \mathcal{T}_{i,j,k} \, a_j\f]
  !> This version return a coolist (sparse tensor).
  !> @param coolist_ijk a coordinate list (sparse tensor) of which index
  !> 2 or 3 will be contracted.
  !> @param arr_j the vector to be contracted with index 2 and then index 3 of ffi_coo_ijk
  !> @param jcoo_ij a coolist (sparse tensor) to store the result of the contraction
  SUBROUTINE jsparse_mul(coolist_ijk, arr_j, jcoo_ij)
    TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ijk
    TYPE(coolist), DIMENSION(ndim), INTENT(OUT):: jcoo_ij
    REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN)  :: arr_j
    REAL(KIND=8) :: v
    INTEGER :: i,j,k,n,nj,AllocStat
    DO i=1,ndim
       IF (jcoo_ij(i)%nelems/=0) STOP "*** jsparse_mul : Destination coolist not empty ! ***"
       nj=2*coolist_ijk(i)%nelems
       ALLOCATE(jcoo_ij(i)%elems(nj), STAT=AllocStat)
       IF (AllocStat /= 0) then
         print *, "jsparse_mul:: AllocStat = ", AllocStat
         STOP "*** Not enough memory ! ***"
       ENDIF
       nj=0
       DO n=1,coolist_ijk(i)%nelems
          j=coolist_ijk(i)%elems(n)%j
          k=coolist_ijk(i)%elems(n)%k
          v=coolist_ijk(i)%elems(n)%v
          IF (j /=0) THEN
             nj=nj+1
             jcoo_ij(i)%elems(nj)%j=j
             jcoo_ij(i)%elems(nj)%k=0
             jcoo_ij(i)%elems(nj)%v=v*arr_j(k)
          END IF

          IF (k /=0) THEN
             nj=nj+1
             jcoo_ij(i)%elems(nj)%j=k
             jcoo_ij(i)%elems(nj)%k=0
             jcoo_ij(i)%elems(nj)%v=v*arr_j(j)
          END IF
       END DO
       jcoo_ij(i)%nelems=nj
    END DO
  END SUBROUTINE jsparse_mul

  !> Sparse multiplication of two tensors to determine the Jacobian:
  !> \f[J_{i,j} = {\displaystyle \sum_{k=0}^{ndim}} \left( \mathcal{T}_{i,j,k} + \mathcal{T}_{i,k,j} \right) \, a_k.\f]
  !> It's implemented slightly differently: for every \f$\mathcal{T}_{i,j,k}\f$, we add to \f$J_{i,j}\f$ as follows:
  !> \f[J_{i,j} = J_{i,j} + \mathcal{T}_{i,j,k} \, a_k \\ J_{i,k} = J_{i,k} + \mathcal{T}_{i,j,k} \, a_j\f]
  !> This version return a matrix.
  !> @param coolist_ijk a coordinate list (sparse tensor) of which index
  !> 2 or 3 will be contracted.
  !> @param arr_j the vector to be contracted with index 2 and then index 3 of ffi_coo_ijk
  !> @param jcoo_ij a matrix to store the result of the contraction
  SUBROUTINE jsparse_mul_mat(coolist_ijk, arr_j, jcoo_ij)
    TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ijk
    REAL(KIND=8), DIMENSION(ndim,ndim), INTENT(OUT):: jcoo_ij
    REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN)  :: arr_j
    REAL(KIND=8) :: v
    INTEGER :: i,j,k,n
    jcoo_ij=0.D0
    DO i=1,ndim
       DO n=1,coolist_ijk(i)%nelems
          j=coolist_ijk(i)%elems(n)%j
          k=coolist_ijk(i)%elems(n)%k
          v=coolist_ijk(i)%elems(n)%v
          IF (j /=0) jcoo_ij(i,j)=jcoo_ij(i,j)+v*arr_j(k)
          IF (k /=0) jcoo_ij(i,k)=jcoo_ij(i,k)+v*arr_j(j)
       END DO
    END DO
  END SUBROUTINE jsparse_mul_mat

  !> Sparse multiplication of a 2d sparse tensor with a vector:  \f${\displaystyle \sum_{j=0}^{ndim}} \mathcal{T}_{i,j,k} \, a_j \f$.
  !> @param coolist_ij a coordinate list (sparse tensor) of which index
  !> 2 will be contracted.
  !> @param arr_j the vector to be contracted with index 2 of coolist_ijk
  !> @param res vector (buffer) to store the result of the contraction
  !> @remark Note that it is NOT safe to pass `arr_j` as a result buffer,
  !> as this operation does multiple passes.
  SUBROUTINE sparse_mul2(coolist_ij, arr_j, res)
    TYPE(coolist), DIMENSION(ndim), INTENT(IN):: coolist_ij
    REAL(KIND=8), DIMENSION(0:ndim), INTENT(IN)  :: arr_j
    REAL(KIND=8), DIMENSION(0:ndim), INTENT(OUT) :: res
    INTEGER :: i,j,n
    res=0.D0
    DO i=1,ndim
       DO n=1,coolist_ij(i)%nelems
         j=coolist_ij(i)%elems(n)%j
         res(i) = res(i) + coolist_ij(i)%elems(n)%v * arr_j(j)
      END DO
   END DO
 END SUBROUTINE sparse_mul2

 !> Routine to simplify a coolist (sparse tensor). For each index \f$i\f$, it upper triangularize the matrix
 !> \f[\mathcal{T}_{i,j,k} \qquad 0 \leq j,k \leq ndim.\f]
 !> @param tensor a coordinate list (sparse tensor) which will be simplified.
 SUBROUTINE simplify(tensor)
   TYPE(coolist), DIMENSION(ndim), INTENT(INOUT):: tensor
   INTEGER :: i,j,k
   INTEGER :: li,lii,liii,n
   DO i= 1,ndim
      n=tensor(i)%nelems
      DO li=n,2,-1
         j=tensor(i)%elems(li)%j
         k=tensor(i)%elems(li)%k
         DO lii=li-1,1,-1
            IF (((j==tensor(i)%elems(lii)%j).AND.(k==tensor(i)&
                 &%elems(lii)%k)).OR.((j==tensor(i)%elems(lii)%k).AND.(k==tensor(i)%elems(lii)%j))) THEN
               ! Found another entry with the same i,j,k: merge both into
               ! the one listed first (of those two).
               tensor(i)%elems(lii)%v=tensor(i)%elems(lii)%v+tensor(i)%elems(li)%v
               IF (j>k) THEN
                  tensor(i)%elems(lii)%j=tensor(i)%elems(li)%k
                  tensor(i)%elems(lii)%k=tensor(i)%elems(li)%j
               ENDIF

               ! Shift the rest of the items one place down.
               DO liii=li+1,n
                  tensor(i)%elems(liii-1)%j=tensor(i)%elems(liii)%j
                  tensor(i)%elems(liii-1)%k=tensor(i)%elems(liii)%k
                  tensor(i)%elems(liii-1)%v=tensor(i)%elems(liii)%v
               END DO
               tensor(i)%nelems=tensor(i)%nelems-1
               ! Here we should stop because the li no longer points to the
               ! original i,j,k element
               EXIT
            ENDIF
         ENDDO
      ENDDO
      n=tensor(i)%nelems
      li=1
      DO WHILE (li<=tensor(i)%nelems)
         ! Clear new "almost" zero entries and shift rest of the items one place down.
         ! Make sure not to skip any entries while shifting!
         DO WHILE (ABS(tensor(i)%elems(li)%v) < real_eps)
            DO liii=li+1,n
               tensor(i)%elems(liii-1)%j=tensor(i)%elems(liii)%j
               tensor(i)%elems(liii-1)%k=tensor(i)%elems(liii)%k
               tensor(i)%elems(liii-1)%v=tensor(i)%elems(liii)%v
            ENDDO
            tensor(i)%nelems=tensor(i)%nelems-1
            if (li > tensor(i)%nelems) THEN
               EXIT
            ENDIF
         ENDDO
         li=li+1
      ENDDO

      n=tensor(i)%nelems
      DO li=1,n
         ! Upper triangularize
         j=tensor(i)%elems(li)%j
         k=tensor(i)%elems(li)%k
         IF (j>k) THEN
            tensor(i)%elems(li)%j=k
            tensor(i)%elems(li)%k=j
         ENDIF
      ENDDO

   ENDDO
 END SUBROUTINE simplify

  !> Subroutine to add element to a coolist.
  !> @param t destination tensor
  !> @param i tensor \f$i\f$ index
  !> @param j tensor \f$j\f$ index
  !> @param k tensor \f$k\f$ index
  !> @param v value to add
  SUBROUTINE add_elem(t,i,j,k,v)
    TYPE(coolist), DIMENSION(ndim), INTENT(INOUT) :: t
    INTEGER, INTENT(IN) :: i,j,k
    REAL(KIND=8), INTENT(IN) :: v
    INTEGER :: n
    IF (ABS(v) .ge. real_eps) THEN
       n=(t(i)%nelems)+1
       t(i)%elems(n)%j=j
       t(i)%elems(n)%k=k
       t(i)%elems(n)%v=v
       t(i)%nelems=n
    END IF
  END SUBROUTINE add_elem

  !> Subroutine to add element to a coolist and check for overflow.
  !> Once the t buffer tensor is full, add it to the destination buffer.
  !> @param t temporary buffer tensor for the destination tensor
  !> @param i tensor \f$i\f$ index
  !> @param j tensor \f$j\f$ index
  !> @param k tensor \f$k\f$ index
  !> @param v value to add
  !> @param dst destination tensor
  SUBROUTINE add_check(t,i,j,k,v,dst)
    TYPE(coolist), DIMENSION(ndim), INTENT(INOUT) :: t
    TYPE(coolist), DIMENSION(ndim), INTENT(INOUT) :: dst
    INTEGER, INTENT(IN) :: i,j,k
    REAL(KIND=8), INTENT(IN) :: v
    INTEGER :: n
    CALL add_elem(t,i,j,k,v)
    IF (t(i)%nelems==size(t(i)%elems)) THEN
       CALL add_to_tensor(t,dst)
       DO n=1,ndim
           t(n)%nelems=0
       ENDDO
    ENDIF
  END SUBROUTINE add_check

  !> Routine to add a rank-3 tensor to another one.
  !> @param src Tensor to add
  !> @param dst Destination tensor
  SUBROUTINE add_to_tensor(src,dst)
    TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: src
    TYPE(coolist), DIMENSION(ndim), INTENT(INOUT) :: dst
    TYPE(coolist_elem), DIMENSION(:), ALLOCATABLE :: celems
    INTEGER :: i,j,n,AllocStat

    DO i=1,ndim
       IF (src(i)%nelems/=0) THEN
          IF (dst(i)%nelems==0) THEN
             IF (ALLOCATED(dst(i)%elems)) THEN
                DEALLOCATE(dst(i)%elems, STAT=AllocStat)
                IF (AllocStat /= 0) STOP "*** Deallocation problem ! ***"
             ENDIF
             ALLOCATE(dst(i)%elems(src(i)%nelems), STAT=AllocStat)
             IF (AllocStat /= 0) then
               print *, "add_to_tensor:: AllocStat = ", AllocStat
               STOP "*** Not enough memory ! ***"
             ENDIF
             n=0
          ELSE
             n=dst(i)%nelems
             ALLOCATE(celems(n), STAT=AllocStat)
             DO j=1,n
                celems(j)%j=dst(i)%elems(j)%j
                celems(j)%k=dst(i)%elems(j)%k
                celems(j)%v=dst(i)%elems(j)%v
             ENDDO
             DEALLOCATE(dst(i)%elems, STAT=AllocStat)
             IF (AllocStat /= 0) STOP "*** Deallocation problem ! ***"
             ALLOCATE(dst(i)%elems(src(i)%nelems+n), STAT=AllocStat)
             IF (AllocStat /= 0) then
               print *, "add_to_tensor:: AllocStat = ", AllocStat
               STOP "*** Not enough memory ! ***"
             ENDIF
             DO j=1,n
                dst(i)%elems(j)%j=celems(j)%j
                dst(i)%elems(j)%k=celems(j)%k
                dst(i)%elems(j)%v=celems(j)%v
             ENDDO
             DEALLOCATE(celems, STAT=AllocStat)
             IF (AllocStat /= 0) STOP "*** Deallocation problem ! ***"
          ENDIF
          DO j=1,src(i)%nelems
             dst(i)%elems(n+j)%j=src(i)%elems(j)%j
             dst(i)%elems(n+j)%k=src(i)%elems(j)%k
             dst(i)%elems(n+j)%v=src(i)%elems(j)%v
          ENDDO
          dst(i)%nelems=src(i)%nelems+n
       ENDIF
    ENDDO

  END SUBROUTINE add_to_tensor

   !> Routine to print a rank 3 tensor coolist.
  !> @param t coolist to print
  SUBROUTINE print_tensor(t,s)
    USE util, only: str
    TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: t
    CHARACTER, INTENT(IN), OPTIONAL :: s
    CHARACTER :: r
    INTEGER :: i,n,j,k
    IF (PRESENT(s)) THEN
       r=s
    ELSE
       r="t"
    END IF
    DO i=1,ndim
       DO n=1,t(i)%nelems
          j=t(i)%elems(n)%j
          k=t(i)%elems(n)%k
          IF( ABS(t(i)%elems(n)%v) .GE. real_eps) THEN
             write(*,"(A,ES12.5)") r//"["//TRIM(str(i))//"]["//TRIM(str(j)) &
                  &//"]["//TRIM(str(k))//"] = ",t(i)%elems(n)%v
          END IF
       END DO
    END DO
  END SUBROUTINE print_tensor

  !> Load a rank-4 tensor coolist from a file definition
  !> @param s Destination filename
  !> @param t The coolist to write
  SUBROUTINE write_tensor_to_file(s,t)
    CHARACTER (LEN=*), INTENT(IN) :: s
    TYPE(coolist), DIMENSION(ndim), INTENT(IN) :: t
    INTEGER :: i,j,k,n
    OPEN(30,file=s)
    DO i=1,ndim
       WRITE(30,*) i,t(i)%nelems
       DO n=1,t(i)%nelems
          j=t(i)%elems(n)%j
          k=t(i)%elems(n)%k
          WRITE(30,*) i,j,k,t(i)%elems(n)%v
       END DO
    END DO
    CLOSE(30)
  END SUBROUTINE write_tensor_to_file

  !> Load a rank-4 tensor coolist from a file definition
  !> @param s Filename of the tensor definition file
  !> @param t The loaded coolist
  !> @remark The destination tensor have to be an empty tensor, i.e. with unallocated list of elements and nelems set to 0.
  SUBROUTINE load_tensor_from_file(s,t)
    CHARACTER (LEN=*), INTENT(IN) :: s
    TYPE(coolist), DIMENSION(ndim), INTENT(OUT) :: t
    INTEGER :: i,ir,j,k,n,AllocStat
    REAL(KIND=8) :: v
    OPEN(30,file=s,status='old')
    DO i=1,ndim
       READ(30,*) ir,n
       IF (n /= 0) THEN
          ALLOCATE(t(i)%elems(n), STAT=AllocStat)
          IF (AllocStat /= 0) then
            print *, "load_tensor_from_file:: AllocStat = ", AllocStat
            STOP "*** Not enough memory ! ***"
          ENDIF
          t(i)%nelems=n
       ENDIF
       DO n=1,t(i)%nelems
          READ(30,*) ir,j,k,v
          t(i)%elems(n)%j=j
          t(i)%elems(n)%k=k
          t(i)%elems(n)%v=v
       ENDDO
    END DO
    CLOSE(30)
  END SUBROUTINE load_tensor_from_file

END MODULE tensor


** Copyright (c) 1989, NVIDIA CORPORATION.  All rights reserved.
**
** Licensed under the Apache License, Version 2.0 (the "License");
** you may not use this file except in compliance with the License.
** You may obtain a copy of the License at
**
**     http://www.apache.org/licenses/LICENSE-2.0
**
** Unless required by applicable law or agreed to in writing, software
** distributed under the License is distributed on an "AS IS" BASIS,
** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
** See the License for the specific language governing permissions and
** limitations under the License.

*   Exponentiation (** operator) to double complex powers.

	program p
	implicit double complex (c)

	parameter (N=6)
	integer rslts(N), expect(N)

	integer ctoi
	ctoi(c) = real(c) + dimag(c)

	data x2 / 2.0/
	data c2, c23, c11, c12/ (2, 0), (2, 3), (1, 1), (1, 2) /

	rslts(1) = ctoi( (2.1d0, 0.0) ** (2.0d0, 0.0) )
	rslts(2) = ctoi( (2.1, 0.0d0) ** c2)
	rslts(3) = ctoi( c23 ** x2 + .001 )
	rslts(4) = c23 ** c11 + 10
	rslts(5) = ctoi( 10 ** c12 )
	rslts(6) = ctoi(x2 ** (-1.0d0, 2.0) * 10)

c --- check results:

	call check(rslts, expect, N)

	data expect /
     +                4, 4, 7, 9, -11, 5      /

	end


      SUBROUTINE ODRRB( N, D, LLD, IFIRST, ILAST, RTOL1,
     $                  RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK,
     $                  PIVMIN, SPDIAM, TWIST, INFO )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            IFIRST, ILAST, INFO, N, OFFSET, TWIST
      DOUBLE PRECISION   PIVMIN, RTOL1, RTOL2, SPDIAM
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   D( * ), LLD( * ), W( * ),
     $                   WERR( * ), WGAP( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  Given the relatively robust representation(RRR) L D L^T, ODRRB
*  does "limited" bisection to refine the eigenvalues of L D L^T,
*  W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
*  guesses for these eigenvalues are input in W, the corresponding estimate
*  of the error in these guesses and their gaps are input in WERR
*  and WGAP, respectively. During bisection, intervals
*  [left, right] are maintained by storing their mid-points and
*  semi-widths in the arrays W and WERR respectively.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix.
*
*  D       (input) DOUBLE PRECISION array, dimension (N)
*          The N diagonal elements of the diagonal matrix D.
*
*  LLD     (input) DOUBLE PRECISION array, dimension (N-1)
*          The (N-1) elements L(i)*L(i)*D(i).
*
*  IFIRST  (input) INTEGER
*          The index of the first eigenvalue to be computed.
*
*  ILAST   (input) INTEGER
*          The index of the last eigenvalue to be computed.
*
*  RTOL1   (input) DOUBLE PRECISION
*  RTOL2   (input) DOUBLE PRECISION
*          Tolerance for the convergence of the bisection intervals.
*          An interval [LEFT,RIGHT] has converged if
*          RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
*          where GAP is the (estimated) distance to the nearest
*          eigenvalue.
*
*  OFFSET  (input) INTEGER
*          Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET
*          through ILAST-OFFSET elements of these arrays are to be used.
*
*  W       (input/output) DOUBLE PRECISION array, dimension (N)
*          On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
*          estimates of the eigenvalues of L D L^T indexed IFIRST throug
*          ILAST.
*          On output, these estimates are refined.
*
*  WGAP    (input/output) DOUBLE PRECISION array, dimension (N-1)
*          On input, the (estimated) gaps between consecutive
*          eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between
*          eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST
*          then WGAP(IFIRST-OFFSET) must be set to ZERO.
*          On output, these gaps are refined.
*
*  WERR    (input/output) DOUBLE PRECISION array, dimension (N)
*          On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
*          the errors in the estimates of the corresponding elements in W.
*          On output, these errors are refined.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (2*N)
*          Workspace.
*
*  IWORK   (workspace) INTEGER array, dimension (2*N)
*          Workspace.
*
*  PIVMIN  (input) DOUBLE PRECISION
*          The minimum pivot in the Sturm sequence.
*
*  SPDIAM  (input) DOUBLE PRECISION
*          The spectral diameter of the matrix.
*
*  TWIST   (input) INTEGER
*          The twist index for the twisted factorization that is used
*          for the negcount.
*          TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T
*          TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T
*          TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)
*
*  INFO    (output) INTEGER
*          Error flag.
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Beresford Parlett, University of California, Berkeley, USA
*     Jim Demmel, University of California, Berkeley, USA
*     Inderjit Dhillon, University of Texas, Austin, USA
*     Osni Marques, LBNL/NERSC, USA
*     Christof Voemel, University of California, Berkeley, USA
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, TWO, HALF
      PARAMETER        ( ZERO = 0.0D0, TWO = 2.0D0,
     $                   HALF = 0.5D0 )
      INTEGER   MAXITR
*     ..
*     .. Local Scalars ..
      INTEGER            I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT,
     $                   OLNINT, PREV, R
      DOUBLE PRECISION   BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
     $                   RGAP, RIGHT, TMP, WIDTH
*     ..
*     .. External Functions ..
      INTEGER            ODNEG
      EXTERNAL           ODNEG
*
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      INFO = 0
*
      MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
     $           LOG( TWO ) ) + 2
      MNWDTH = TWO * PIVMIN
*
      R = TWIST
      IF((R.LT.1).OR.(R.GT.N)) R = N
*
*     Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
*     The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
*     Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
*     for an unconverged interval is set to the index of the next unconverged
*     interval, and is -1 or 0 for a converged interval. Thus a linked
*     list of unconverged intervals is set up.
*
      I1 = IFIRST
*     The number of unconverged intervals
      NINT = 0
*     The last unconverged interval found
      PREV = 0

      RGAP = WGAP( I1-OFFSET )
      DO 75 I = I1, ILAST
         K = 2*I
         II = I - OFFSET
         LEFT = W( II ) - WERR( II )
         RIGHT = W( II ) + WERR( II )
         LGAP = RGAP
         RGAP = WGAP( II )
         GAP = MIN( LGAP, RGAP )

*        Make sure that [LEFT,RIGHT] contains the desired eigenvalue
*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT
*
*        Do while( NEGCNT(LEFT).GT.I-1 )
*
         BACK = WERR( II )
 20      CONTINUE
         NEGCNT = ODNEG( N, D, LLD, LEFT, PIVMIN, R )
         IF( NEGCNT.GT.I-1 ) THEN
            LEFT = LEFT - BACK
            BACK = TWO*BACK
            GO TO 20
         END IF
*
*        Do while( NEGCNT(RIGHT).LT.I )
*        Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT
*
         BACK = WERR( II )
 50      CONTINUE

         NEGCNT = ODNEG( N, D, LLD, RIGHT, PIVMIN, R )
          IF( NEGCNT.LT.I ) THEN
             RIGHT = RIGHT + BACK
             BACK = TWO*BACK
             GO TO 50
          END IF
         WIDTH = HALF*ABS( LEFT - RIGHT )
         TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
         CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
         IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN
*           This interval has already converged and does not need refinement.
*           (Note that the gaps might change through refining the
*            eigenvalues, however, they can only get bigger.)
*           Remove it from the list.
            IWORK( K-1 ) = -1
*           Make sure that I1 always points to the first unconverged interval
            IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1
            IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1
         ELSE
*           unconverged interval found
            PREV = I
            NINT = NINT + 1
            IWORK( K-1 ) = I + 1
            IWORK( K ) = NEGCNT
         END IF
         WORK( K-1 ) = LEFT
         WORK( K ) = RIGHT
 75   CONTINUE

*
*     Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
*     and while (ITER.LT.MAXITR)
*
      ITER = 0
 80   CONTINUE
      PREV = I1 - 1
      I = I1
      OLNINT = NINT

      DO 100 IP = 1, OLNINT
         K = 2*I
         II = I - OFFSET
         RGAP = WGAP( II )
         LGAP = RGAP
         IF(II.GT.1) LGAP = WGAP( II-1 )
         GAP = MIN( LGAP, RGAP )
         NEXT = IWORK( K-1 )
         LEFT = WORK( K-1 )
         RIGHT = WORK( K )
         MID = HALF*( LEFT + RIGHT )

*        semiwidth of interval
         WIDTH = RIGHT - MID
         TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
         CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
         IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR.
     $       ( ITER.EQ.MAXITR ) )THEN
*           reduce number of unconverged intervals
            NINT = NINT - 1
*           Mark interval as converged.
            IWORK( K-1 ) = 0
            IF( I1.EQ.I ) THEN
               I1 = NEXT
            ELSE
*              Prev holds the last unconverged interval previously examined
               IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
            END IF
            I = NEXT
            GO TO 100
         END IF
         PREV = I
*
*        Perform one bisection step
*
         NEGCNT = ODNEG( N, D, LLD, MID, PIVMIN, R )
         IF( NEGCNT.LE.I-1 ) THEN
            WORK( K-1 ) = MID
         ELSE
            WORK( K ) = MID
         END IF
         I = NEXT
 100  CONTINUE
      ITER = ITER + 1
*     do another loop if there are still unconverged intervals
*     However, in the last iteration, all intervals are accepted
*     since this is the best we can do.
      IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
*
*
*     At this point, all the intervals have converged
      DO 110 I = IFIRST, ILAST
         K = 2*I
         II = I - OFFSET
*        All intervals marked by '0' have been refined.
         IF( IWORK( K-1 ).EQ.0 ) THEN
            W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
            WERR( II ) = WORK( K ) - W( II )
         END IF
 110  CONTINUE
*
      DO 111 I = IFIRST+1, ILAST
         K = 2*I
         II = I - OFFSET
         WGAP( II-1 ) = MAX( ZERO,
     $                     W(II) - WERR (II) - W( II-1 ) - WERR( II-1 ))
 111  CONTINUE

      RETURN
*
*     End of ODRRB
*
      END


!--------------------------------------------------------------------------------------------------!
! Module: annealing
!
! Routines to implement the simulated annealing algorithm (Kirkpatrick et al., 1983), used to
! determine a set of NPARAM model parameters that maximize some objective function.
!
! Simulated annealing pseudo code:
! 0) Initialize a model, M(0), and a temperature, T [init]
! 1) For i = 1, 2, ... , N
!     1) Propose a new model: M(i) [propose]
!     2) Calculate the objective function for the proposed model: obj(i) [objective]
!        (Note that the algorithm is extremely sensitive to the choice of this objective function
!        because of the exponential in the probability expression!)
!     3) Accept the proposed model with probability: min((1,exp(obj(i)-obj(i-1))/T)
!     4) Decrease T
!
! Subroutine arguments:
!     nparam:       Number of parameters in model array
!     model_best:   Model array containing best model from search
!     *init:        External subroutine to initialize model array
!     *propose:     External subroutine to propose a new model
!     *objective:   External subroutine to compute objective function for model
!     max_it:       Number of iterations to search
!     reset_it:     Number of iterations per temperature reset
!     T_start:      Starting temperature
!     T_min:        Minimum temperature
!     cool:         Cooling factor
!     *write_log:   Write  annealing results to log file
!
! *The user must supply the following external routine names in the argument list:
!     - subroutine init(model_init, nparam)
!     - subroutine propose(model_current, model_proposed, nparam)
!     - function objective(model, nparam)
!     - subroutine write_log()
!
! Examples of these "driver" routines are provided in the unit test for this module
! (unit_test_annealing.f90).
!
! Annealing subroutines are provided for INTEGER and DOUBLE PRECISION model arrays. These are
! interfaced to the generic subroutine call "anneal". This means that the user simply calls the
! subroutine "anneal" in their program. It also means that they must define the argument variable
! and routine types precisely the same as in either "anneal_int_array" or "anneal_dp_array". If the
! variable types do not match exactly, there will be a compiler error; unfortunately, these error
! messages are totally uninformative, e.g., if I declare reset_it as double precision in Example #1,
! gfortran gives me the error message:
!
!     "Error: There is no specific subroutine for the generic ‘anneal’ at (1)"
!
! As you can see, this is not particularly helpful. But now you know.
!
!--------------------------------------------------------------------------------------------------!

module annealing

interface anneal
    module procedure anneal_int_array
    module procedure anneal_dp_array
end interface

public :: anneal

!--------------------------------------------------------------------------------------------------!
contains
!--------------------------------------------------------------------------------------------------!

subroutine anneal_int_array(nparam, &
                            model_best, &
                            init, &
                            propose, &
                            objective, &
                            max_it, &
                            reset_it, &
                            T_start, &
                            T_min, &
                            cool, &
                            write_log)
!----
! Simulated annealing algorithm with an integer model array
!----

use io, only: verbosity, progress_indicator, stdout
use random, only: r8_uniform_01, timeseed, iseed

implicit none

! Arguments: model array
integer :: nparam
integer :: model_best(NPARAM)

! Arguments: user-supplied external subroutines
interface
    subroutine init(model_init,n)
        integer :: n
        integer :: model_init(n)
    end subroutine
    subroutine propose(model_current,model_proposed,n)
        integer :: n
        integer :: model_current(n)
        integer :: model_proposed(n)
    end subroutine
    function objective(model,n)
        integer :: n
        integer :: model(n)
        double precision :: objective
    end function
    subroutine write_log(it,temp,obj,model_current,model_proposed,n,isAccepted,string)
        integer :: it, n
        double precision :: temp, obj
        integer :: model_current(n)
        integer :: model_proposed(n)
        logical :: isAccepted
        character(len=*) :: string
    end subroutine
end interface

! Arguments: annealing controls
integer :: max_it
integer :: reset_it
double precision :: T_start
double precision :: T_min
double precision :: cool

! Local variables
integer :: i
integer :: ierr
double precision :: T
double precision :: obj_current
double precision :: obj_proposed
double precision :: obj_best
double precision :: ptrans
double precision :: ran_uniform
integer :: model_current(NPARAM)
integer :: model_proposed(NPARAM)
logical :: isAccepted

! Initialize the random number generator with integer based on system time
iseed = -timeseed()

! Initialize the temperature from the argument list
T = T_start

! Initialize a model and calculate its objective function
call init(model_current,nparam)
obj_current = objective(model_current,nparam)
model_best = model_current
obj_best = obj_current

! Open log file and write first entry
isAccepted = .false.
call write_log(0,T,obj_current,model_current,model_current,nparam,isAccepted,'init')

! Run the annealing search
do i = 1,max_it

    if (verbosity.eq.1) then
        call progress_indicator(i,max_it,'anneal',ierr)
    elseif (verbosity.ge.2) then
        write(stdout,*) 'anneal: starting iteration ',i,' of ',max_it
    endif

    ! Propose a new model and calculate its objective function
    call propose(model_current,model_proposed,nparam)
    obj_proposed = objective(model_proposed,nparam)

    ! Save the model if it is the best overall
    if (obj_proposed.gt.obj_best) then
        model_best = model_proposed
        obj_best = obj_proposed
    endif

    ! Calculate the transition probability for current to proposed model (maximizing objective func)
    ptrans = exp((obj_proposed-obj_current)/T)
    ptrans = min(1.0d0,ptrans)

    ! Update the current model if transition is made
    isAccepted = .false.
    ran_uniform = r8_uniform_01(iseed)
    if (ran_uniform.lt.ptrans) then
        model_current = model_proposed
        obj_current = obj_proposed
        isAccepted = .true.
    endif

    ! Save results in log file
    call write_log(i,T,obj_proposed,model_current,model_proposed,nparam,isAccepted,'append')

    ! Update temperature
    T = T*cool

    ! Make sure temperature stays above T_min
    if (T.lt.T_min) then
        T = T_min
    endif

    ! Reset temperature every reset_it iterations
    if (reset_it.gt.0.and.mod(i,reset_it).eq.0) then
        T = T_start
    endif
enddo

! Close log file
call write_log(i,T,obj_current,model_current,model_proposed,nparam,isAccepted,'close')

return
end subroutine anneal_int_array

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

subroutine anneal_dp_array(nparam, &
                            model_best, &
                            init, &
                            propose, &
                            objective, &
                            max_it, &
                            reset_it, &
                            T_start, &
                            T_min, &
                            cool, &
                            write_log)
!----
! Simulated annealing algorithm with an double precision model array
!----

use io, only: verbosity, progress_indicator, stdout
use random, only: r8_uniform_01, timeseed, iseed

implicit none

! Arguments: model array
integer :: nparam
double precision :: model_best(NPARAM)

! Arguments: user-supplied external subroutines
interface
    subroutine init(model_init,n)
        integer :: n
        double precision :: model_init(n)
    end subroutine
    subroutine propose(model_current,model_proposed,n)
        integer :: n
        double precision :: model_current(n)
        double precision :: model_proposed(n)
    end subroutine
    function objective(model,n)
        integer :: n
        double precision :: model(n)
        double precision :: objective
    end function
    subroutine write_log(it,temp,obj,model_current,model_proposed,n,isAccepted,string)
        integer :: it, n
        double precision :: temp, obj
        double precision :: model_current(n)
        double precision :: model_proposed(n)
        logical :: isAccepted
        character(len=*) :: string
    end subroutine
end interface

! Arguments: annealing controls
integer :: max_it
integer :: reset_it
double precision :: T_start
double precision :: T_min
double precision :: cool

! Local variables
integer :: i
integer :: ierr
double precision :: T
double precision :: obj_current
double precision :: obj_proposed
double precision :: obj_best
double precision :: ptrans
double precision :: ran_uniform
double precision :: model_current(NPARAM)
double precision :: model_proposed(NPARAM)
logical :: isAccepted

! Initialize the random number generator with integer based on system time
iseed = -timeseed()

! Initialize the temperature from the argument list
T = T_start

! Initialize a model and calculate its objective function
call init(model_current,nparam)
obj_current = objective(model_current,nparam)
model_best = model_current
obj_best = obj_current

! Open log file and write first entry
isAccepted = .false.
call write_log(0,T,obj_current,model_current,model_current,nparam,isAccepted,'init')

! Run the annealing search
do i = 1,max_it

    if (verbosity.eq.1) then
        call progress_indicator(i,max_it,'anneal',ierr)
    elseif (verbosity.ge.2) then
        write(stdout,*) 'anneal: starting iteration ',i,' of ',max_it
    endif

    ! Propose a new model and calculate its objective function
    call propose(model_current,model_proposed,nparam)
    obj_proposed = objective(model_proposed,nparam)

    ! Save the model if it is the best overall
    if (obj_proposed.gt.obj_best) then
        model_best = model_proposed
        obj_best = obj_proposed
    endif

    ! Calculate the transition probability for current to proposed model (maximizing objective func)
    ptrans = exp((obj_proposed-obj_current)/T)
    ptrans = min(1.0d0,ptrans)

    ! Update the current model if transition is made
    isAccepted = .false.
    ran_uniform = r8_uniform_01(iseed)
    if (ran_uniform.lt.ptrans) then
        model_current = model_proposed
        obj_current = obj_proposed
        isAccepted = .true.
    endif

    ! Save results in log file
    call write_log(i,T,obj_proposed,model_current,model_proposed,nparam,isAccepted,'append')

    ! Update temperature
    T = T*cool

    ! Make sure temperature stays above T_min
    if (T.lt.T_min) then
        T = T_min
    endif

    ! Reset temperature every reset_it iterations
    if (reset_it.gt.0.and.mod(i,reset_it).eq.0) then
        T = T_start
    endif
enddo

! Close log file
call write_log(i,T,obj_current,model_current,model_proposed,nparam,isAccepted,'close')

return
end subroutine anneal_dp_array

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

subroutine resample(weights,iselected,n)
!----
! Resample from n weights, assuming they represent proportional probabilities. Output array contains
! weight index selected in each resampling step.
!----

use random, only: r8_uniform_01, iseed

implicit none

! Arguments
integer :: n
double precision :: weights(n)
integer :: iselected(n)

! Local variables
integer :: i, j
double precision :: wt_sum, wt_cum_pdf(n), f

! iselected contains which index is sampled for each index
iselected = 0

! Sum of weights
wt_sum = 0.0d0
do i = 1,n
    wt_sum = wt_sum + weights(i)
enddo

! Cumulative PDF is the sum of weights, normalized by total
wt_cum_pdf(1) = weights(1)/wt_sum
do i = 2,n
    wt_cum_pdf(i) = wt_cum_pdf(i-1) + weights(i)/wt_sum
enddo

! Resample model population from the cumulative PDF
do i = 1,n
    f = r8_uniform_01(iseed)
    do j = 1,n
        if (f.le.wt_cum_pdf(j)) then
            iselected(i) = j
            exit
        endif
    enddo
enddo

return
end subroutine

end module

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


      SUBROUTINE UD01ND( MP, NP, DP, L, NOUT, P, LDP1, LDP2, TEXT,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To print the MP-by-NP coefficient matrices of a matrix polynomial
C                                                    dp-1           dp
C        P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s    + P(dp) * s  .
C
C     The elements of the matrices are output to 7 significant figures.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     MP      (input) INTEGER
C             The number of rows of the matrix polynomial P(s).
C             MP >= 1.
C
C     NP      (input) INTEGER
C             The number of columns of the matrix polynomial P(s).
C             NP >= 1.
C
C     DP      (input) INTEGER
C             The degree of the matrix polynomial P(s).  DP >= 0.
C
C     L       (input) INTEGER
C             The number of elements of the coefficient matrices to be
C             printed per line.  1 <= L <= 5.
C
C     NOUT    (input) INTEGER
C             The output channel to which the results are sent.
C             NOUT >= 0.
C
C     P       (input) DOUBLE PRECISION array, dimension (LDP1,LDP2,DP+1)
C             The leading MP-by-NP-by-(DP+1) part of this array must
C             contain the coefficients of the matrix polynomial P(s).
C             Specifically, P(i,j,k) must contain the coefficient of
C             s**(k-1) of the polynomial which is the (i,j)-th element
C             of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and
C             k = 1,2,...,DP+1.
C
C     LDP1    INTEGER
C             The leading dimension of array P.  LDP1 >= MP.
C
C     LDP2    INTEGER
C             The second dimension of array P.  LDP2 >= NP.
C
C     TEXT    (input) CHARACTER*72
C             Title caption of the coefficient matrices to be printed.
C             TEXT is followed by the degree of the coefficient matrix,
C             within brackets. If TEXT = ' ', then the coefficient
C             matrices are separated by an empty line.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     For i = 1, 2, ..., DP + 1 the routine first prints the contents of
C     TEXT followed by (i-1) as a title, followed by the elements of the
C     MP-by-NP coefficient matrix P(i) such that
C     (i)  if NP < L, then the leading MP-by-NP part is printed;
C     (ii) if NP = k*L + p (where k, p > 0), then k MP-by-L blocks of
C          consecutive columns of P(i) are printed one after another
C          followed by one MP-by-p block containing the last p columns
C          of P(i).
C     Row numbers are printed on the left of each row and a column
C     number on top of each column.
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C     Based on routine PRMAPO by A.J. Geurts, Eindhoven University of
C     Technology, Holland.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER           DP, INFO, L, LDP1, LDP2, MP, NP, NOUT
      CHARACTER*(*)     TEXT
C     .. Array Arguments ..
      DOUBLE PRECISION  P(LDP1,LDP2,*)
C     .. Local Scalars ..
      INTEGER           I, J, J1, J2, JJ, K, LENTXT, LTEXT, N1
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         LEN, MIN
C
C     .. Executable Statements ..
C
      INFO = 0
C
C     Check the input scalar arguments.
C
      IF( MP.LT.1 ) THEN
         INFO = -1
      ELSE IF( NP.LT.1 ) THEN
         INFO = -2
      ELSE IF( DP.LT.0 ) THEN
         INFO = -3
      ELSE IF( L.LT.1 .OR. L.GT.5 ) THEN
         INFO = -4
      ELSE IF( NOUT.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDP1.LT.MP ) THEN
         INFO = -7
      ELSE IF( LDP2.LT.NP ) THEN
         INFO = -8
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'UD01ND', -INFO )
         RETURN
      END IF
C
      LENTXT = LEN( TEXT )
      LTEXT  = MIN( 72, LENTXT )
C     WHILE ( TEXT(LTEXT:LTEXT) =  ' ' ) DO
   10 IF ( TEXT(LTEXT:LTEXT).EQ.' ' ) THEN
         LTEXT = LTEXT - 1
         GO TO 10
      END IF
C     END WHILE 10
C
      DO 50 K = 1, DP + 1
         IF ( LTEXT.EQ.0 ) THEN
            WRITE ( NOUT, FMT = 99999 )
         ELSE
            WRITE ( NOUT, FMT = 99998 ) TEXT(1:LTEXT), K - 1, MP, NP
         END IF
         N1 = ( NP - 1 )/L
         J1 = 1
         J2 = L
C
         DO 30 J = 1, N1
            WRITE ( NOUT, FMT = 99997 ) ( JJ, JJ = J1, J2 )
C
            DO 20 I = 1, MP
               WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, J2 )
   20       CONTINUE
C
            J1 = J1 + L
            J2 = J2 + L
   30    CONTINUE
C
         WRITE ( NOUT, FMT = 99997 ) ( J, J = J1, NP )
C
         DO 40 I = 1, MP
            WRITE ( NOUT, FMT = 99996 ) I, ( P(I,JJ,K), JJ = J1, NP )
   40    CONTINUE
C
   50 CONTINUE
C
      WRITE ( NOUT, FMT = 99999 )
C
      RETURN
C
99999 FORMAT (' ')
99998 FORMAT (/, 1X, A, '(', I2, ')', ' (', I2, 'X', I2, ')')
99997 FORMAT (5X, 5(6X, I2, 7X))
99996 FORMAT (1X, I2, 2X, 5D15.7)
C
C *** Last line of UD01ND ***
      END


      SUBROUTINE DETCKX( JARG, IFGPST, NPVT )
C*****
C THIS ROUTINE GENERATES THE GRID POINT SINGULARITY TABLE BY EXAMINING
C THE TRANSLATIONAL AND DIAGONAL 3 X 3 SUBMATRICES OF THE KGG MATRIX.
C IF JARG = 0, THE PIVOT POINT HAS ELEMENTS ATTACHED TO IT.
C IF JARG =-1, THE PIVOT IS A SCALAR POINT AND NO ELEMENTS ARE
C CONNECTED TO IT.
C IF JARG = 1, THE PIVOT POINT IS A GRID POINT AND NO ELEMENTS ARE
C CONNECTED TO IT.
C*****
      DOUBLE PRECISION
     1                   DZ(1)              ,B(9)
     2,                  FL(3)              ,M(3)
     3,                  R(3)               ,TEMP
     4,                  FM                 ,FR
     5,                  DET                ,CONST
     6,                  DTOL               ,D(18)
C
      INTEGER
     1                   TNWDS              ,IARRAY(8)
     2,                  IZ(1)              ,BACK
     3,                  NAME(2)
C
      COMMON /MA1XX / D, B, DZ, FL, R, M
      COMMON /SYSTEM/ ISYS(69),TOLEL,SDUM(10)
C
C
      EQUIVALENCE
     1                   (IZ(1),DZ(1))      ,(IARRAY(1),IORDER)
     2,                  (IARRAY(2),NWDS)
C
C
C
      DATA  NEOR/ 0 /
      DATA NAME / 4HDETC,4HKX   /
C
      DTOL = TOLEL
      IARG = JARG
      IF (IARG) 35,10,52
   35 IORDER = 1
      NWDS = 1
      IARRAY(3) = NPVT
      CALL WRITE (IFGPST,IARRAY(1),3,NEOR)
      RETURN
C
C AT THIS POINT, BOTH TRANSLATIONAL AND ROTATIONAL DIAGONAL 3X3 S ARE
C STORED IN THE D ARRAY.  HENCE WE PROCESS THEM.
C
   10 CONTINUE
   52 CONTINUE
      IP = NPVT - 1
      ASSIGN 450 TO IGOTO
      IF (IARG .NE. 1) GO TO 55
      ASSIGN 425 TO BACK
      GO TO 425
   55 ASSIGN 70 TO BACK
      DO 60 I = 1,9
   60 B(I) = D(I)
      GO TO 90
   70 DO 80 I = 1,9
   80 B(I) = D(I+9)
C
C INSURE THE SYMMETRY OF THE B MATRIX
C
      IF (B(2) .NE. 0.0D0 .AND. B(4) .NE. 0.0D0) GO TO 82
      B(2) = 0.0D0
      B(4) = 0.0D0
      GO TO 83
   82 TEMP = (B(2) + B(4)) / 2.0D0
      B(2) = TEMP
      B(4) = TEMP
   83 IF (B(3) .NE. 0.0D0 .AND. B(7) .NE. 0.0D0) GO TO 84
      B(3) = 0.0D0
      B(7) = 0.0D0
      GO TO 85
   84 TEMP = (B(3) + B(7)) / 2.0D0
      B(3) = TEMP
      B(7) = TEMP
   85 IF (B(6) .NE. 0.0D0 .AND. B(8) .NE. 0.0D0) GO TO 86
      B(6) = 0.0D0
      B(8) = 0.0D0
      GO TO 90
   86 TEMP = (B(6) + B(8)) / 2.0D0
C
C SCALE THE MATRIX BY DIVIDING EACH ELEMENT OF B BY THE LARGEST ELEMENT.
C IF THE LARGEST ELEMENT IS NON-POSITIVE, THE SINGULARITY IS OF ORDER 3.
C
   90 TEMP = B(1)
      DO 100 I = 2,9
      IF (B(I) .GT. TEMP) TEMP = B(I)
  100 CONTINUE
      IF (TEMP .LE. 0.0D0) GO TO 425
      DO 110 I = 1,9
  110 B(I) = B(I) / TEMP
C
C FIND THE SQUARES OF THE MAGNITUDES OF THE VECTORS OF THE ROWS OF THE
C B MATRIX.
C
      IORDER = 0
      J = 0
      DO 120 I = 1,9,3
      J = J + 1
      FL(J) = B(I)**2 + B(I+1)**2 + B(I+2)**2
      IF (FL(J) .EQ. 0.0D0) IORDER = IORDER + 1
  120 CONTINUE
      IF (IORDER .EQ. 2)  GO TO 410
      IF (IORDER .EQ. 0)  GO TO 250
C
C AT THIS POINT ONE AND ONLY ONE FL(I) IS ZERO.
C
      DO 130 I = 1,3
      ISAVE = I
      IF (FL(I) .EQ. 0. 0D0) GO TO (140,150,160), ISAVE
  130 CONTINUE
      CALL MESAGE (-30,26,NAME)
  140 FM = B(5) * B(9)  -  B(6) * B(8)
      FR = DSQRT( (B(5)**2  +  B(6)**2)  *  (B(8)**2  +  B(9)**2) )
      GO TO 170
  150 FM = B(1) * B(9)  -  B(3) * B(7)
      FR = DSQRT( (B(1)**2  +  B(3)**2)  *  (B(7)**2  +  B(9)**2) )
      GO TO 170
  160 FM = B(1) * B(5)  -  B(2) * B(4)
      FR = DSQRT( (B(1)**2  +  B(2)**2)  *  (B(4)**2  +  B(5)**2) )
  170 IF( FM .EQ. 0.0D0 ) GO TO 171
      IF( FR .LE. 0.0D0 ) GO TO 240
      IF ( FM/FR .GE. DTOL ) GO TO 240
C
C HERE WE HAVE THAT THE ORDER OF THE SINGULARITY IS 2.
C
  171 IORDER = 2
      NWDS   = 0
      TNWDS  = 2
      GO TO (180,190,200), ISAVE
  180 K1   = 5
      K2   = 9
      INC1 = 1
      INC2 = 3
      INC3 = 2
      GO TO 210
  190 K1   = 1
      K2   = 9
      INC1 = 2
      INC2 = 3
      INC3 = 1
      GO TO 210
  200 K1   = 1
      K2   = 5
      INC1 = 3
      INC2 = 2
      INC3 = 1
  210 IF (B(K1) .LE. 0.0D0  .AND.  B(K2) .LE. 0.0D0) GO TO 425
      IF (B(K1) .LE. 0.0D0) GO TO 220
      NWDS      = 2
      TNWDS     = 4
      IARRAY(3) = IP + INC1
      IARRAY(4) = IP + INC2
      IPOINT    = 5
      GO TO 230
  220 IPOINT = 3
  230 IF (B(K2) .LE. 0.0D0) GO TO 430
      NWDS = NWDS + 2
      TNWDS = TNWDS + 2
      IARRAY(IPOINT)   = IP + INC1
      IARRAY(IPOINT+1) = IP + INC3
      GO TO 430
C
C AT THIS POINT WE HAVE THAT ONE AND ONLY ONE FL IS ZERO BUT THAT ORDER
C OF THE SINGULARITY IS 1.
C
  240 IORDER    = 1
      NWDS      = 1
      TNWDS     = 3
      IARRAY(3) = IP + ISAVE
      GO TO 430
C
C AT STATEMENT NO. 250, WE HAVE THAT ALL THE FL(I) ARE .GT. 0.0D0, SO
C THAT THE DETERMINANT, DET, OF B MUST BE COMPUTED.
C
  250 DET = B(1) * ( B(5)*B(9) - B(6)*B(8) )
     1    - B(2) * ( B(4)*B(9) - B(6)*B(7) )
     2    + B(3) * ( B(4)*B(8) - B(5)*B(7) )
      CONST = 0.05D0*DTOL * FL(1) * FL(2) * FL(3)
      IF (DET .GT. CONST) GO TO 440
C
C COMPUTE M(I) AND R(I)
C
      M(1) = B(5) * B(9) - B(6) * B(8)
      M(2) = B(1) * B(9) - B(3) * B(7)
      M(3) = B(1) * B(5)  -  B(2) * B(4)
      R(1) =   DSQRT ( B(5)**2 + B(6)**2 )
     1       * DSQRT ( B(8)**2 + B(9)**2 )
      R(2) =   DSQRT ( B(1)**2 + B(3)**2 )
     1       * DSQRT ( B(7)**2 + B(9)**2 )
      R(3) =   DSQRT ( B(1)**2 + B(2)**2 )
     1       * DSQRT ( B(4)**2 + B(5)**2 )
C
C FIND I1,J1,K1 SUCH THAT M(I1)/R(I1) .GE. M(J1)/R(J1) .GE. M(K1)/R(K1)
C
      I1 = 1
      J1 = 2
      K1 = 3
      IF (M(1)*R(2).GE.M(2)*R(1)) GO TO 270
      I1 = 2
      J1 = 1
  270 IF (M(I1)*R(K1).GE.M(K1)*R(I1)) GO TO 280
      ITEMP = I1
      I1    = K1
      K1    = ITEMP
  280 IF (M(J1)*R(K1).GE.M(K1)*R(J1)) GO TO 290
      ITEMP = J1
      J1    = K1
      K1 = ITEMP
  290 IF (M(I1).GE.R(I1)*DTOL) GO TO 400
C
C HERE THE SINGULARITY IS OF ORDER 2.
C
      NWDS   = 0
      TNWDS  = 2
      IORDER = 2
C
C FIND II, JJ, KK SUCH THAT B(II) .GE. B(JJ) .GE. B(KK)
C
      II = 1
      JJ = 5
      KK = 9
      IF (B(1) .GE. B(5)) GO TO 300
      II = 5
      JJ = 1
  300 IF (B(II) .GE. B(KK)) GO TO 310
      ITEMP = II
      II    = KK
      KK    = ITEMP
  310 IF (B(JJ) .GE. B(KK)) GO TO 320
      ITEMP = JJ
      JJ    = KK
      KK    = ITEMP
  320 LL    = II
      KOUNT = 0
      IPOINT= 3
  330 IF (B(LL) .LE. 0.0D0) GO TO 430
      NWDS  = NWDS + 2
      TNWDS = TNWDS + 2
      IF (LL - 5) 340,350,360
  340 INC1 = 2
      INC2 = 3
      GO TO 370
  350 INC1 = 1
      INC2 = 3
      GO TO 370
  360 INC1 = 1
      INC2 = 2
  370 IARRAY(IPOINT)   = IP + INC1
      IARRAY(IPOINT+1) = IP + INC2
      IPOINT = IPOINT + 2
      KOUNT  = KOUNT  + 1
      IF (KOUNT - 2) 380,390,430
  380 LL = JJ
      GO TO 330
  390 LL = KK
      GO TO 330
C
C AT THIS POINT THE SINGULARITY IS OF ORDER 1.
C
  400 IORDER = 1
      NWDS   = 1
      TNWDS  = 3
      IARRAY(3) = IP + I1
      IF (M(J1).LT.R(J1)*DTOL) GO TO 430
      NWDS  = 2
      TNWDS = 4
      IARRAY(4) = IP + J1
      IF (M(K1).LT.R(K1)*DTOL) GO TO 430
      NWDS  = 3
      TNWDS = 5
      IARRAY(5) = IP + K1
      GO TO 430
C
C AT THIS POINT 2 ROWS OF THE B MATRIX ARE IDENTICALLY ZERO.
C
  410 NWDS   = 2
      TNWDS  = 4
      IPOINT = 2
      DO 420 I = 1,3
      IF (FL(I) .NE. 0.0D0) GO TO 420
      IPOINT = IPOINT + 1
      IARRAY(IPOINT) = IP + I
  420 CONTINUE
      GO TO 430
C
C THE SINGULARITY IS OF ORDER 3
C
  425 IORDER = 3
      NWDS   = 3
      TNWDS  = 5
      IARRAY(3) = IP + 1
      IARRAY(4) = IP + 2
      IARRAY(5) = IP + 3
C
C WRITE IARRAY ON THE GPST FILE.
C
  430 CALL WRITE (IFGPST,IARRAY(1),TNWDS,NEOR)
  440 GO TO IGOTO, (450,460)
  450 ASSIGN 460 TO IGOTO
      IP = IP + 3
      GO TO BACK, (70,425)
  460 CONTINUE
      RETURN
      END


*dk,angle3v
      subroutine angle3v(xa,ya,za,x1,y1,z1,phi,thi)
      implicit none
      include 'consts.h'
      include 'chydro.h'
      real*8 x1,y1,z1,xa,ya,za,sinph,cosph,sinth,costh,phi,thi
C
C
C#######################################################################
C
C      PURPOSE -
C
C        THIS ROUTINE CALCULATES REFERENCE ANGLES RELATIVE TO A
C           LINE SIGMENT.  FROM THE TWO PAIRS OF (X,Y,Z) COORDINATES
C           WE CAN DERIVE EITHER (radius,THETA,z) OR (radius,THETA,PHI)
C           TRIPLETS.
C        NOTE:  THE ANGLES ARE RETURN IN RADIANS (NOT DEGREES).
C
C
C      INPUT ARGUMENTS -
C
C         xa       - X-COORDINATE CENTER.
C
C         ya       - Y-COORDINATE CENTER.
C
C         za       - Z-COORDINATE CENTER.
C
C         x1       - X-COORDINATE OF THE TERMINATION POINT.
C
C         y1       - Y-COORDINATE OF THE TERMINATION POINT.
C
C         z1       - Z-COORDINATE OF THE TERMINATION POINT.
C
C
C
C      OUTPUT ARGUMENTS -
C
C         phi      - ANGLE IN RADIANS.  FOR CYLINDRICAL COORDINATES
C                       THIS IS THE ANGLE (CALLED THETA) IN THE XY-PLANE
C                       RELATIVE TO THE X-AXIS. IN SPHERICAL COORDINATES
C                       THIS ANGLE (CALLED PHI) IS IN THE XY-PLANE
C                       RELATIVE TO THE X-AXIS. THE RANGE OF THIS
C                       ANGLE IS FROM [0,2PIE].
C
C         theta    - ANGLE IN RADIANS.  FOR SPHERICAL COORDINATES
C                       THIS IS THE ANGLE (CALLED THETA) RELATIVE TO THE
C                       Z-AXIS. THE RANGE OF THIS ANGLE IS FROM [0,180].
C
C
C      CHANGE HISTORY -
C
C        $Log: angle3v.f,v $
C        Revision 2.00  2007/11/05 19:45:46  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.3   29 Sep 2004 15:54:52   dcg
CPVCS    use pie from common - make routine implicit none
CPVCS
CPVCS       Rev 1.2   Wed Apr 05 13:34:02 2000   nnc
CPVCS    Minor source modifications required by the Absoft compiler.
CPVCS
CPVCS       Rev 1.1   Mon Apr 14 16:39:00 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.0   11/10/94 12:10:54   pvcs
CPVCS    Original version.
C
C#######################################################################
C
C
C
C     ..................................................................
C
C     CHECK TO SEE IF BOTH ANGLES ARE ZERO ( BOTH POINTS ARE AT THE
C        SAME LOCATION).
C
      if(abs(x1-xa).lt.1.0d-10.and.abs(y1-ya).lt.1.0d-10.
     *   and.abs(z1-za).lt.1.0d-10) then
         phi=zero
         thi=zero
         goto 9999
      endif
C
C
      call angle3(xa,ya,za,x1,y1,z1,sinph,cosph,sinth,costh)
C
C
C
C
C     ..................................................................
C     CALCULATE PHI.
C
      cosph=min( one,cosph)
      cosph=max(-one,cosph)
      phi=acos(cosph)
      if(cosph.ge.zero.and.sinph.ge.zero) phi=phi+3.d0*pie/two
      if(cosph.le.zero.and.sinph.ge.zero) phi=phi-pie/two
      if(cosph.le.zero.and.sinph.le.zero) phi=pie-phi+pie/two
      if(cosph.ge.zero.and.sinph.le.zero) phi=pie/two-phi+pie
      if(abs(cosph-one).le.1.0d-10) phi=3.d0*pie/two
      if(abs(sinph-one).le.1.0d-10) phi=zero
      if(abs(cosph+one).le.1.0d-10) phi=pie/two
      if(abs(sinph+one).le.1.0d-10) phi=pie
C
C
C     ,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
C     CHECK TO SEE IF THERE IS NO PHI ANGLE.
C
      if(abs(x1-xa).lt.1.0d-10.and.abs(y1-ya).lt.1.0d-10) then
         phi=zero
      endif
C
C     ..................................................................
C     CALCULATE THETA.
C
      costh=min( one,costh)
      costh=max(-one,costh)
      thi=acos(costh)
      if(sinth.lt.zero) then
         if(costh.lt.zero) then
            thi=thi+pie/two
         else
            thi=two*pie-thi
         endif
      endif
C
C     ..................................................................
C
      goto 9999
 9999 continue
      return
      end