!
! sparse BLAS
!

module spblas
  use sparse
  implicit none

contains

  ! Description:
  !     vector-matrix operation for sparsematrix;
  !           y = alpha * trans(spA) * x + beta * y
  ! Parameters:
  !     m: rows of spA
  !     n: columns of spA
  !     nnz: nnz of spA
  !     spA: value of spA
  !     rowptr: rowptr of spA
  !     colptr: colptr of spA
  !     rowind: rowind of spA
  !     colind: colind of spA
  !     alpha, beta: constant values
  !     x, y: vectors
  !

  subroutine dcsrmv(trans, m, n, alpha, &
    spA, rowptr, colind, nnz, x, incx, beta, y, incy)
    integer, parameter :: base = sparse_base_index
    character, intent(in) :: trans
    integer, intent(in) :: m, n, nnz, incx, incy
    double precision, intent(in) :: alpha, beta, spA(base:*), x(1:incx,base:*)
    double precision, intent(out) :: y(1:incy,base:*)
    integer, intent(in) :: rowptr(base:*), colind(base:*)
    integer :: i, j, z

    select case (trans)
      case ('N', 'n')
        call dscal(m, beta, y(1,base), incy)
        do i = base, base+m-1
           do z = rowptr(i), rowptr(i+1)-1
              j = colind(z)
              y(1,i) = y(1,i) + alpha * spA(z) * x(1,j)
           end do
        end do
      case ('T', 't')
        call dscal(n, beta, y(1,base), incy)
        do i = base, base+m-1
           do z = rowptr(i), rowptr(i+1)-1
              j = colind(z)
              y(1,j) = y(1,j) + alpha * spA(z) * x(1,i)
           end do
        end do
    end select
  end subroutine dcsrmv

  subroutine dcscmv(trans, m, n, alpha, &
    spA, colptr, rowind, nnz, x, incx, beta, y, incy)
    integer, parameter :: base = sparse_base_index
    character, intent(in) :: trans
    integer, intent(in) :: m, n, nnz, incx, incy
    double precision, intent(in) :: alpha, beta, spA(base:*), x(1:incx,base:*)
    double precision, intent(out) :: y(1:incy,base:*)
    integer, intent(in) :: colptr(base:*), rowind(base:*)
    integer :: i, j, z

    select case (trans)
      case ('N', 'n')
        call dscal(m, beta, y(1,base), incy)
        do j = base, base+n-1
           do z = colptr(j), colptr(j+1)-1
              i = rowind(z)
              y(1,i) = y(1,i) + alpha * spA(z) * x(1,j)
           end do
        end do
      case ('T', 't')
        call dscal(n, beta, y(1,base), incy)
        do j = base, base+n-1
           do z = colptr(j), colptr(j+1)-1
              i = rowind(z)
              y(1,j) = y(1,j) + alpha * spA(z) * x(1,i)
           end do
        end do
    end select
  end subroutine dcscmv

  subroutine dcoomv(trans, m, n, alpha, &
    spA, rowind, colind, nnz, x, incx, beta, y, incy)
    integer, parameter :: base = sparse_base_index
    character, intent(in) :: trans
    integer, intent(in) :: m, n, nnz, incx, incy
    double precision, intent(in) :: alpha, beta, spA(base:*), x(1:incx,base:*)
    double precision, intent(out) :: y(1:incy,base:*)
    integer, intent(in) :: rowind(base:*), colind(base:*)
    integer :: i, j, z

    select case (trans)
      case ('N', 'n')
        call dscal(m, beta, y(1,base), incy)
        do z = base, base+nnz-1
          i = rowind(z)
          j = colind(z)
          y(1,i) = y(1,i) + alpha * spA(z) * x(1,j)
        end do
      case ('T', 't')
        call dscal(n, beta, y(1,base), incy)
        do z = base, base+nnz-1
          i = rowind(z)
          j = colind(z)
          y(1,j) = y(1,j) + alpha * spA(z) * x(1,i)
        end do
    end select
  end subroutine dcoomv

  ! Description:
  !     vector-vector operation for sparsematrix;
  !           spA = alpha * x * y + spA
  ! Parameters:
  !     m: rows of spA
  !     n: columns of spA
  !     nnz: nnz of spA
  !     spA: value of spA
  !     rowptr: rowptr of spA
  !     colptr: colptr of spA
  !     rowind: rowind of spA
  !     colind: colind of spA
  !     alpha, beta: constant values
  !     x, y: vectors
  !

  subroutine dcsrr(m, n, alpha, x, incx, y, incy, &
    spA, rowptr, colind, nnz)
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: m, n, nnz, incx, incy
    double precision, intent(in) :: alpha, x(1:incx,base:*), y(1:incy,base:*)
    double precision, intent(out) :: spA(base:*)
    integer, intent(in) :: rowptr(base:*), colind(base:*)
    integer :: i, j, z
    do i = base, base+m-1
       do z = rowptr(i), rowptr(i+1)-1
          j = colind(z)
          spA(z) = spA(z) + alpha * x(1,i) * y(1,j)
       end do
    end do
  end subroutine dcsrr

  subroutine dcscr(m, n, alpha, x, incx, y, incy, &
    spA, colptr, rowind, nnz)
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: m, n, nnz, incx, incy
    double precision, intent(in) :: alpha, x(1:incx,base:*), y(1:incy,base:*)
    double precision, intent(out) :: spA(base:*)
    integer, intent(in) :: colptr(base:*), rowind(base:*)
    integer :: i, j, z
    do j = base, base+n-1
       do z = colptr(j), colptr(j+1)-1
          i = rowind(z)
          spA(z) = spA(z) + alpha * x(1,i) * y(1,j)
       end do
    end do
  end subroutine dcscr

  subroutine dcoor(m, n, alpha, x, incx, y, incy, &
    spA, rowind, colind, nnz)
    integer, parameter :: base = sparse_base_index
    integer, intent(in) :: m, n, nnz, incx, incy
    double precision, intent(in) :: alpha, x(1:incx,base:*), y(1:incy,base:*)
    double precision, intent(out) :: spA(base:*)
    integer, intent(in) :: rowind(base:*), colind(base:*)
    integer :: i, j, z
    do z = base, base+nnz-1
      i = rowind(z)
      j = colind(z)
      spA(z) = spA(z) + alpha * x(1,i) * y(1,j)
    end do
  end subroutine dcoor

  ! Description:
  !     matrix-matrix operation for sparsematrix;
  !           C = alpha * transA(spA) * transB(B) * x + beta * C
  ! Parameters:
  !     m: rows of spA
  !     n: columns of spA
  !     nnz: nnz of spA
  !     spA: value of spA
  !     rowptr: rowptr of spA
  !     colptr: colptr of spA
  !     rowind: rowind of spA
  !     colind: colind of spA
  !     alpha, beta: constant values
  !     x, y: vectors
  !

  subroutine dcsrmm(transA, transB, m, n, k, alpha, &
    spA, rowptr, colind, nnz, B, ldb, beta, C, ldc)

    character, intent(in) :: transA, transB
    integer, intent(in) :: m, n, k, nnz, ldb, ldc
    double precision, intent(in) :: alpha, beta, spA(1:*), B(1:ldb,1:*)
    double precision, intent(out) :: C(1:ldc,1:*)
    integer, intent(in) :: rowptr(1:*), colind(1:*)
    integer :: i

    select case (transB)
      case ('N', 'n')
        select case (transA)
          case ('N', 'n')
            do i = 1, n
              call dcsrmv('N', m, k, alpha, spA, rowptr, colind, nnz, B(1,i), 1, beta, C(1,i), 1)
            end do
          case ('T', 't')
            do i = 1, n
              call dcsrmv('T', k, m, alpha, spA, rowptr, colind, nnz, B(1,i), 1, beta, C(1,i), 1)
            end do
        end select
      case ('T', 't')
        select case (transA)
          case ('N', 'n')
            do i = 1, n
              call dcsrmv('N', m, k, alpha, spA, rowptr, colind, nnz, B(i,1), ldb, beta, C(1,i), 1)
            end do
          case ('T', 't')
            do i = 1, n
              call dcsrmv('T', k, m, alpha, spA, rowptr, colind, nnz, B(i,1), ldb, beta, C(1,i), 1)
            end do
        end select
    end select
  end subroutine dcsrmm

  subroutine dcscmm(transA, transB, m, n, k, alpha, &
    spA, colptr, rowind, nnz, B, ldb, beta, C, ldc)

    character, intent(in) :: transA, transB
    integer, intent(in) :: m, n, k, nnz, ldb, ldc
    double precision, intent(in) :: alpha, beta, spA(1:*), B(1:ldb,1:*)
    double precision, intent(out) :: C(1:ldc,1:*)
    integer, intent(in) :: colptr(1:*), rowind(1:*)
    integer :: i

    select case (transB)
      case ('N', 'n')
        select case (transA)
          case ('N', 'n')
            do i = 1, n
              call dcscmv('N', m, k, alpha, spA, colptr, rowind, nnz, B(1,i), 1, beta, C(1,i), 1)
            end do
          case ('T', 't')
            do i = 1, n
              call dcscmv('T', k, m, alpha, spA, colptr, rowind, nnz, B(1,i), 1, beta, C(1,i), 1)
            end do
        end select
      case ('T', 't')
        select case (transA)
          case ('N', 'n')
            do i = 1, n
              call dcscmv('N', m, k, alpha, spA, colptr, rowind, nnz, B(i,1), ldb, beta, C(1,i), 1)
            end do
          case ('T', 't')
            do i = 1, n
              call dcscmv('T', k, m, alpha, spA, colptr, rowind, nnz, B(i,1), ldb, beta, C(1,i), 1)
            end do
        end select
    end select
  end subroutine dcscmm

  subroutine dcoomm(transA, transB, m, n, k, alpha, &
    spA, rowind, colind, nnz, B, ldb, beta, C, ldc)

    character, intent(in) :: transA, transB
    integer, intent(in) :: m, n, k, nnz, ldb, ldc
    double precision, intent(in) :: alpha, beta, spA(1:*), B(1:ldb,1:*)
    double precision, intent(out) :: C(1:ldc,1:*)
    integer, intent(in) :: rowind(1:*), colind(1:*)
    integer :: i

    select case (transB)
      case ('N', 'n')
        select case (transA)
          case ('N', 'n')
            do i = 1, n
              call dcoomv('N', m, k, alpha, spA, rowind, colind, nnz, B(1,i), 1, beta, C(1,i), 1)
            end do
          case ('T', 't')
            do i = 1, n
              call dcoomv('T', k, m, alpha, spA, rowind, colind, nnz, B(1,i), 1, beta, C(1,i), 1)
            end do
        end select
      case ('T', 't')
        select case (transA)
          case ('N', 'n')
            do i = 1, n
              call dcoomv('N', m, k, alpha, spA, rowind, colind, nnz, B(i,1), ldb, beta, C(1,i), 1)
            end do
          case ('T', 't')
            do i = 1, n
              call dcoomv('T', k, m, alpha, spA, rowind, colind, nnz, B(i,1), ldb, beta, C(1,i), 1)
            end do
        end select
    end select
  end subroutine dcoomm

  ! Description:
  !     matrix-matrix operation for sparsematrix;
  !           C = alpha * transA(A) * transB(spB) * x + beta * C
  ! Parameters:
  !     m: rows of C
  !     n: columns of C
  !     nnz: nnz of spA
  !     spA: value of spA
  !     rowptr: rowptr of spA
  !     colptr: colptr of spA
  !     rowind: rowind of spA
  !     colind: colind of spA
  !     alpha, beta: constant values
  !     x, y: vectors
  !

  subroutine dcsrmm2(transA, transB, m, n, k, alpha, &
    A, lda, spB, rowptr, colind, nnz, beta, C, ldc)

    character, intent(in) :: transA, transB
    integer, intent(in) :: m, n, k, nnz, lda, ldc
    double precision, intent(in) :: alpha, beta, spB(1:*), A(1:lda,1:*)
    double precision, intent(out) :: C(1:ldc,1:*)
    integer, intent(in) :: rowptr(1:*), colind(1:*)
    integer :: i

    select case (transA)
      case ('N', 'n')
        select case (transB)
          case ('N', 'n')
            do i = 1, m
              call dcsrmv('T', k, n, alpha, spB, rowptr, colind, nnz, A(i,1), lda, beta, C(i,1), ldc)
            end do
          case ('T', 't')
            do i = 1, n
              call dcsrmv('N', n, k, alpha, spB, rowptr, colind, nnz, A(i,1), lda, beta, C(i,1), ldc)
            end do
        end select
      case ('T', 't')
        select case (transB)
          case ('N', 'n')
            do i = 1, n
              call dcsrmv('T', k, n, alpha, spB, rowptr, colind, nnz, A(1,i), 1, beta, C(i,1), ldc)
            end do
          case ('T', 't')
            do i = 1, n
              call dcsrmv('N', n, k, alpha, spB, rowptr, colind, nnz, A(1,i), 1, beta, C(i,1), ldc)
            end do
        end select
    end select
  end subroutine dcsrmm2

  subroutine dcscmm2(transA, transB, m, n, k, alpha, &
    A, lda, spB, colptr, rowind, nnz, beta, C, ldc)

    character, intent(in) :: transA, transB
    integer, intent(in) :: m, n, k, nnz, lda, ldc
    double precision, intent(in) :: alpha, beta, spB(1:*), A(1:lda,1:*)
    double precision, intent(out) :: C(1:ldc,1:*)
    integer, intent(in) :: colptr(1:*), rowind(1:*)
    integer :: i

    select case (transA)
      case ('N', 'n')
        select case (transB)
          case ('N', 'n')
            do i = 1, m
              call dcscmv('T', k, n, alpha, spB, colptr, rowind, nnz, A(i,1), lda, beta, C(i,1), ldc)
            end do
          case ('T', 't')
            do i = 1, n
              call dcscmv('N', n, k, alpha, spB, colptr, rowind, nnz, A(i,1), lda, beta, C(i,1), ldc)
            end do
        end select
      case ('T', 't')
        select case (transB)
          case ('N', 'n')
            do i = 1, n
              call dcscmv('T', k, n, alpha, spB, colptr, rowind, nnz, A(1,i), 1, beta, C(i,1), ldc)
            end do
          case ('T', 't')
            do i = 1, n
              call dcscmv('N', n, k, alpha, spB, colptr, rowind, nnz, A(1,i), 1, beta, C(i,1), ldc)
            end do
        end select
    end select
  end subroutine dcscmm2

  subroutine dcoomm2(transA, transB, m, n, k, alpha, &
    A, lda, spB, rowind, colind, nnz, beta, C, ldc)

    character, intent(in) :: transA, transB
    integer, intent(in) :: m, n, k, nnz, lda, ldc
    double precision, intent(in) :: alpha, beta, spB(1:*), A(1:lda,1:*)
    double precision, intent(out) :: C(1:ldc,1:*)
    integer, intent(in) :: rowind(1:*), colind(1:*)
    integer :: i

    select case (transA)
      case ('N', 'n')
        select case (transB)
          case ('N', 'n')
            do i = 1, m
              call dcoomv('T', k, n, alpha, spB, rowind, colind, nnz, A(i,1), lda, beta, C(i,1), ldc)
            end do
          case ('T', 't')
            do i = 1, n
              call dcoomv('N', n, k, alpha, spB, rowind, colind, nnz, A(i,1), lda, beta, C(i,1), ldc)
            end do
        end select
      case ('T', 't')
        select case (transB)
          case ('N', 'n')
            do i = 1, n
              call dcoomv('T', k, n, alpha, spB, rowind, colind, nnz, A(1,i), 1, beta, C(i,1), ldc)
            end do
          case ('T', 't')
            do i = 1, n
              call dcoomv('N', n, k, alpha, spB, rowind, colind, nnz, A(1,i), 1, beta, C(i,1), ldc)
            end do
        end select
    end select
  end subroutine dcoomm2
end module spblas


program main

  use mod_cte
  use mod_rng
  use mod_ios
  use mod_global
  use ho3dnn

  implicit none

  real(kd) :: cpu
  integer  :: wall

  real(kd), allocatable :: g(:), h(:), ene_g(:), acc_g(:)
  real(kd), allocatable :: vec_v(:), hat_v(:), vec_m(:), hat_m(:)
  real(kd), allocatable :: fim(:,:), inv(:,:)
  real(kd) :: xa(3), xt(3), xn(3)
  real(kd) :: ela, elt, eln ! Local energy for the actual, trial and Neural Network wavefunction
  real(kd) :: eat, ean      ! Accumulated energy for the trial and Neural Network wavefunction
  real(kd) :: ebt, ebn      ! Accumulated energy by block for the trial and NN wavefunction
  real(kd) :: ets, ens      ! Accumalated mean squared energy for trial and NN wavefunction
  integer  :: acc_a, acc_t, acc_n
  integer  :: i, j, k, m, n

  real(kd) :: beta1 = 0.9_kd, beta2 = 0.999_kd
  real(kd) :: eta = 0.001_kd, eps = one/10**8

  call start_tracking_time( cpu, wall )
  call initialize_rng(10)
  call read_set

  xa = randu( 1, 3 )
  xt = randu( 1, 3 )
  xn = randu( 1, 3 )

  i = size( gradient_nn(xa) )
  allocate( g(i), h(i), ene_g(i), acc_g(i) )
  allocate( vec_v(i), vec_m(i) )
  allocate( hat_v(i), hat_m(i) )
  allocate( fim(i,i), inv(i,i) )

  eta = rate

  vec_m = zero
  vec_v = zero

  do m = 1, batches

    if ( mod(m,int(0.2*batches))==0 ) write(*,'(1f6.2,a)') 1e2*m/batches,'%'

    fim   = zero
    acc_g = zero
    ene_g = zero

    ! Find a value for the variable delta such that the acceptation of trial moves
    ! gives something around 46% for the Metropolis algorithm
    do while ( True )
      acc_n = 0
      do i = 1, 1000
        call trial_move( xn, gs_nn, acc_n )
      enddo
      if (acc_n==0) exit
      if ( acc_n/1000.0 > 0.43 .and. acc_n/1000.0 < 0.48 ) exit
      delta = delta - log(0.46*1000/acc_n)
    enddo

    ! Equilibration steps
    do i = 1, reports/2
      do j = 1, cycles
        call trial_move( xa, gs_actual, acc_a )
        call trial_move( xt, gs_trial,  acc_t )
        call trial_move( xn, gs_nn,     acc_n )
      enddo
    enddo

    ! Reset average values and acceptation
    acc_a = 0
    acc_t = 0
    acc_n = 0

    eat = zero
    ean = zero
    ets = zero
    ens = zero

    ! Accumulation of local observables
    do i = 1, blocks

      ebt = zero
      ebn = zero

      do n = 1, reports/blocks

        do j = 1, cycles
          call trial_move( xa, gs_actual, acc_a )
          call trial_move( xt, gs_trial,  acc_t )
          call trial_move( xn, gs_nn,     acc_n )
        enddo

        ela = ene_actual(xa)
        elt = ene_trial(xt)
        eat = eat + elt
        ebt = ebt + elt
        eln = ene_nn(xn)
        ean = ean + eln
        ebn = ebn + eln

        g = gradient_nn ( xn )

        acc_g = acc_g + g / reports
        ene_g = ene_g + eln * g / reports

        if ( optimizer == 'kfac' ) then
          do j = 1, size(fim,1)
            do k = 1, size(fim,2)
              fim(j,k) = fim(j,k) + g(j)*g(k) / reports
            enddo
          enddo
        endif

      enddo

      ets = ets + ( ebt * blocks / reports )**2
      ens = ens + ( ebn * blocks / reports )**2

    enddo

    ebt = ( eat / reports )**2 * blocks / (blocks-1)
    ebn = ( ean / reports )**2 * blocks / (blocks-1)
    ets = ets / ( blocks-1 )
    ens = ens / ( blocks-1 )

    eat = eat / reports
    ean = ean / reports

    write(unit_out,fmt='(1I8,1f10.4)',advance='no') m, ela
    write(unit_out,fmt='(3f10.4)',advance='no') eat,sqrt(ets-ebt), real(acc_t,kd)/(reports*cycles)
    write(unit_out,fmt='(3f11.4)') ean,sqrt(ens-ebn), real(acc_n,kd)/(reports*cycles)

    if ( optimizer == 'kfac' ) then
      ! ------------- KFAC Optimizer ------------- !
      do j = 1, size(fim,1)
        do k = 1, size(fim,2)
          fim(j,k) = fim(j,k) - acc_g(j)*acc_g(k)
        enddo
        fim(j,j) = fim(j,j) + lambda
      enddo

      inv = inverse( fim, size(fim,1) )
      h = lambda * get_params()
      h = h + ene_g - ean*acc_g
      g = maprod( inv, h )

      g = eta * g
      ! ------------------------------------------ !
    elseif ( optimizer == 'adam' ) then
      ! ------------- ADAM Optimizer ------------- !
      g = ene_g - ean * acc_g

      vec_m = beta1 * vec_m + ( one - beta1 )*g
      vec_v = beta2 * vec_v + ( one - beta2 )*( g*g )

      hat_m = vec_m / ( one - beta1**m )
      hat_v = vec_v / ( one - beta2**m )

      g = eta * hat_m / ( sqrt( hat_v ) + eps )
      ! ------------------------------------------ !
    else
      ! ------------- SGD  Optimizer ------------- !
      g = ene_g - ean * acc_g
      g = eta * g / norm2(g)
      ! ------------------------------------------ !
    endif

    call update_parameter( g )

  enddo

  call write_out( "", "output" )
  call ann % save( 'output' )
  call finalize_rng()
  call end_tracking_time( cpu, wall, 'output' )

end program


	Complex Function f0(a,b,z)
	complex a,b,z
	f0=a*z+b*conjg(z)
	return
	end
c
	Complex Function f1(c,d,z)
	complex c,d,z
	f1=C*(z-1)+d*(conjg(z)-1)+1
	return
	end
c
	Program Complex_map
	implicit none
	complex f0,f1,a,b,c,d,ORIGIN,val
	integer order,loop,i,func_list,lsb
	parameter(ORIGIN=(0.0,0.0),order=18)
c
	call init_Complex_map(a,b,c,d)
c
	open(1,file='fenxing.dat')
	do loop=0,2**order-1
		val=f0(a,b,val)
		func_list=loop
		do i=1,order
			lsb=func_list.and.'01'x
			if(lsb.eq.0) then
				val=f0(a,b,val)
			else
				val=f1(c,d,val)
			end if
			func_list=func_list/2
		end do
		write(1,*) real(val),aimag(val)
	end do
	close(1)
	end

	Subroutine init_complex_map(a,b,c,d)
	complex a,b,c,d
	a=(0.0,0.0)
	b=cmplx(0.4614,0.4614)
	c=cmplx(0.622,-0.196)
	d=(0.0,0.0)
c
	a=(0.0,0.0)
	b=cmplx(1./2, sqrt(3.)/6)
	c=(0.0,0.0)
	d=cmplx(1./2,-sqrt(3.)/6)
	return
	end


!**************************************************************************
! Compute the solution to a nonsymmetric system of linear equations of the
! form Ax=b by the restarted left-preconditioned Generalized Minimal Residual method (GMRES),
! This code is based on Givens tranform, not Housholder transform, we refer to the Matlab code in
! http://www.netlib.org/templates/matlab/gmres.m
!**************************************************************************
module gmres_module

  use multifab_module
  use ml_layout_module
  use define_bc_module
  use bl_constants_module
  use bc_module
  use bl_types
  use probin_gmres_module, only: gmres_max_inner, gmres_abs_tol, gmres_max_iter, &
       gmres_max_outer, gmres_min_iter, gmres_rel_tol, gmres_verbose, p_norm_weight, &
       scale_factor
  use vcycle_counter_module
  use apply_precon_module
  use apply_matrix_module
  use norm_inner_product_module

  implicit none

  private
  public :: gmres

contains

  subroutine gmres(mla,the_bc_tower,dx,b_u,b_p,x_u,x_p, &
                   alpha_fc,beta,beta_ed,gamma,theta_alpha,norm_pre_rhs)

    type(ml_layout),intent(in   ) :: mla
    type(bc_tower), intent(in   ) :: the_bc_tower
    real(dp_t)    , intent(in   ) :: dx(:,:)
    type(multifab), intent(inout) :: b_u(:,:)  ! (nlevs,dm)
    type(multifab), intent(in   ) :: b_p(:)    ! (nlevs)
    type(multifab), intent(inout) :: x_u(:,:)  ! (nlevs,dm)
    type(multifab), intent(inout) :: x_p(:)    ! (nlevs)
    type(multifab), intent(in   ) :: alpha_fc(:,:)
    type(multifab), intent(inout) :: beta(:)
    type(multifab), intent(inout) :: beta_ed(:,:) ! nodal (2d), edge-centered (3d)
    type(multifab), intent(inout) :: gamma(:)
    real(dp_t)    , intent(inout) :: theta_alpha
    real(dp_t), optional, intent(out) :: norm_pre_rhs

    ! Local
    type(multifab) ::   r_u(mla%nlevel,mla%dim)
    type(multifab) ::   w_u(mla%nlevel,mla%dim)
    type(multifab) :: tmp_u(mla%nlevel,mla%dim)
    type(multifab) ::   r_p(mla%nlevel)
    type(multifab) ::   w_p(mla%nlevel)
    type(multifab) :: tmp_p(mla%nlevel)

    real(kind=dp_t) :: cs(gmres_max_inner)
    real(kind=dp_t) :: sn(gmres_max_inner)
    real(kind=dp_t) ::  y(gmres_max_inner)
    real(kind=dp_t) ::  s(gmres_max_inner+1)
    real(kind=dp_t) ::  H(gmres_max_inner+1,gmres_max_inner) ! for storing Hessenberg mat

    type(bl_prof_timer), save :: bpt

    ! Krylov space vectors
    type(multifab) :: V_u(mla%nlevel,mla%dim)
    type(multifab) :: V_p(mla%nlevel)

    integer :: n, d, i, k, dm, nlevs, iter, total_iter, i_copy  ! for looping iteration
    integer :: vcycle_counter_temp ! Local copy
    real(kind=dp_t) :: norm_b,norm_pre_b,norm_resid,rel_resid, norm_init_resid
    real(kind=dp_t) :: norm_resid_Stokes, norm_init_Stokes
    real(kind=dp_t) :: norm_u, norm_p, norm_init_resid_u, norm_init_resid_p
    real(kind=dp_t) :: norm_init_u, norm_init_p, norm_u_noprecon
    real(kind=dp_t) :: norm_p_noprecon, norm_resid_est
    real(kind=dp_t) :: inner_prod_vel(mla%dim), inner_prod_pres

    call build(bpt, "gmres")

    if (gmres_verbose .ge. 3) then
      if (parallel_IOProcessor()) then
        open (unit = 204, file = "gmres_inner_resid.dat", form="formatted", status="unknown", action = "write")
        write ( 204, '(A)' ) "# 1=#V, 2=|Pr_est|/|Pr_est0|"

        open (unit = 205, file = "gmres_outer_resid.dat", form="formatted", status="unknown", action = "write")
        write ( 205, '(A)' ) "# 1=#V, 2=|r|/|r0|, 3=|r_u|/|r_u0|, 4=|r_p|/|r_p0|"
        write ( 205, '(A)' ) "# 5=|Pr|/|Pr0|, 6=|Pr_u|/|Pr_u0|, 7=|Pr_p|/|Pr_p0|, 8=|Pr_est|/|Pr|"
      end if
    end if

    nlevs=mla%nlevel
    dm= mla%dim

    do n=1,nlevs
       do d=1,dm
          call multifab_build_edge(r_u(n,d)  ,mla%la(n),1                ,1,d)
          call multifab_build_edge(w_u(n,d)  ,mla%la(n),1                ,0,d)
          call multifab_build_edge(tmp_u(n,d),mla%la(n),1                ,0,d)
          call multifab_build_edge(V_u(n,d)  ,mla%la(n),gmres_max_inner+1,0,d) ! Krylov vectors
       end do
       call multifab_build(r_p(n)  ,mla%la(n),1                ,1)
       call multifab_build(w_p(n)  ,mla%la(n),1                ,0)
       call multifab_build(tmp_p(n),mla%la(n),1                ,0)
       call multifab_build(V_p(n)  ,mla%la(n),gmres_max_inner+1,0) ! Krylov vectors
    end do

    ! apply scaling factor
    if (scale_factor .ne. 1.d0) then
       theta_alpha = theta_alpha*scale_factor
       do n=1,nlevs
          ! we will solve for scale*x_p so we need to scale the initial guess
          call multifab_mult_mult_s(x_p(n),scale_factor,x_p(n)%ng)
          ! scale the rhs:
          do i=1,dm
             call multifab_mult_mult_s(b_u(n,i),scale_factor,b_u(n,i)%ng)
          end do
          ! scale the viscosities:
          call multifab_mult_mult_s(beta(n),scale_factor,beta(n)%ng)
          call multifab_mult_mult_s(gamma(n),scale_factor,gamma(n)%ng)
          do i=1,size(beta_ed,dim=2)
             call multifab_mult_mult_s(beta_ed(n,i),scale_factor,beta_ed(n,i)%ng)
          end do
       end do
    end if

    ! preconditioned norm_b: norm_pre_b
    call apply_precon(mla,b_u,b_p,tmp_u,tmp_p,alpha_fc, &
                      beta,beta_ed,gamma,theta_alpha,dx,the_bc_tower)
    call stag_l2_norm(mla,tmp_u,norm_u)
    call cc_l2_norm(mla,tmp_p,norm_p)
    norm_p=p_norm_weight*norm_p
    norm_pre_b = sqrt(norm_u**2+norm_p**2)

    if (present(norm_pre_rhs)) then
       norm_pre_rhs = norm_pre_b
    end if

    ! calculate the l2 norm of rhs
    call stag_l2_norm(mla,b_u,norm_u)
    call cc_l2_norm(mla,b_p,norm_p)
    norm_p = p_norm_weight*norm_p
    norm_b = sqrt(norm_u**2+norm_p**2)

    ! If norm_b=0 we should return zero as the solution and "return" from this routine
    if (norm_b .le. 0.0d0) then
       do n=1,nlevs
         do d=1,dm
           call setval(x_u(n,d),0.d0,all=.true.)
         end do
         call setval(x_p(n),0.d0,all=.true.)
       end do
       if (gmres_verbose .ge. 1) then
          if (parallel_IOProcessor()) then
             write ( *, *) "gmres.f90: conveged in 0 iteration since rhs=0"
          end if
       end if

       ! clean up memory
       do n=1,nlevs
          do d=1,dm
             call multifab_destroy(r_u(n,d))
             call multifab_destroy(w_u(n,d))
             call multifab_destroy(tmp_u(n,d))
             call multifab_destroy(V_u(n,d))
          end do
          call multifab_destroy(r_p(n))
          call multifab_destroy(w_p(n))
          call multifab_destroy(tmp_p(n))
          call multifab_destroy(V_p(n))
       end do

       return
    end if

    !!!!!!!!!!!!!!!!!!!
    ! begin outer iteration
    !!!!!!!!!!!!!!!!!!!

    total_iter = 0
    iter = 0
    vcycle_counter = 0
    OuterLoop: do

       ! Calculate tmp = Ax
       call apply_matrix(mla,tmp_u,tmp_p,x_u,x_p,alpha_fc,beta,beta_ed, &
                         gamma,theta_alpha,dx,the_bc_tower)

       ! tmp = b - Ax
       do n=1,nlevs
          do d=1,dm
             call multifab_sub_sub_c(tmp_u(n,d),1,b_u(n,d),1,1,0)
             call multifab_mult_mult_s_c(tmp_u(n,d),1,-1.d0,1,0)
          end do
          call multifab_sub_sub_c(tmp_p(n),1,b_p(n),1,1,0)
          call multifab_mult_mult_s_c(tmp_p(n),1,-1.d0,1,0)
       end do

       ! un-preconditioned residuals
       call stag_l2_norm(mla,tmp_u, norm_u_noprecon)
       call cc_l2_norm(mla,tmp_p,norm_p_noprecon)
       norm_p_noprecon = p_norm_weight*norm_p_noprecon
       norm_resid_Stokes=sqrt(norm_u_noprecon**2+norm_p_noprecon**2)
       if(iter==0) then
         norm_init_u=norm_u_noprecon
         norm_init_p=norm_p_noprecon
         norm_init_Stokes=norm_resid_Stokes
       end if

       if (gmres_verbose .ge. 2) then
          if (parallel_IOProcessor()) then
             write ( *, '(a,i4)' )     'total ITERs = ', total_iter
             write ( *, '(a,100g17.9)' )  'r/(r_0,b) = ',  norm_resid_Stokes/norm_init_Stokes, norm_resid_Stokes/norm_b
          end if
       end if
       if (gmres_verbose .ge. 3) then
          if (parallel_IOProcessor()) then
             write ( *, '(a,100g17.9)' )  'un-Precond. rel. resid. (u,v,p) = ', &
                  norm_resid_Stokes/norm_init_Stokes, norm_u_noprecon/norm_init_Stokes, norm_p_noprecon/norm_init_Stokes
          end if
       end if

       ! solve for r = M^{-1} tmp
       ! We should not be counting these toward the number of mg cycles performed
       vcycle_counter_temp = vcycle_counter
       call apply_precon(mla,tmp_u,tmp_p,r_u,r_p,alpha_fc, &
                         beta,beta_ed,gamma,theta_alpha,dx,the_bc_tower)
       vcycle_counter = vcycle_counter_temp

       ! resid = sqrt(dot_product(r, r))
       call stag_l2_norm(mla,r_u,norm_u)
       call cc_l2_norm(mla,r_p,norm_p)
       norm_p = p_norm_weight*norm_p
       norm_resid=sqrt(norm_u**2+norm_p**2)
       ! If first iteration, save the initial preconditioned residual
       if(iter==0) then
         norm_init_resid=norm_resid
         norm_init_resid_u=norm_u
         norm_init_resid_p=norm_p
         norm_resid_est=norm_resid
       end if

       if (gmres_verbose .ge. 3) then
         if (parallel_IOProcessor()) then
           ! Write the residuals in outer iteration to 205
           write ( 205, '(I0,100g17.9)' ) vcycle_counter, &
              norm_resid/norm_init_resid, norm_u/norm_init_resid, norm_p/norm_init_resid, &
              norm_resid_Stokes/norm_init_Stokes, norm_u_noprecon/norm_init_Stokes, norm_p_noprecon/norm_init_Stokes, &
              norm_resid_est/norm_resid
           write ( *, '(a,100g17.9)' ) 'Precond. rel. res. (u,v,p) = ', &
                 norm_resid/norm_init_resid, norm_u/norm_init_resid, norm_p/norm_init_resid
                 ! Printing norm_u/norm_init_resid_u, norm_p/norm_init_resid_p may divide by zero...
         end if
       end if

       ! We need to test the residual now and exit OuterLoop if converged
       if(total_iter >= gmres_max_iter) then
         if (gmres_verbose .ge. 1) then
           if (parallel_IOProcessor()) then
             write ( *, '(a)' ) 'GMRES did not converge in max number of total inner iterations: Exiting'
           end if
         end if
         exit OuterLoop
       else if(total_iter .ge. gmres_min_iter) then
          ! other options
          if(norm_resid <= gmres_rel_tol*min(norm_pre_b, norm_init_resid)) then
          !if(norm_resid <= gmres_rel_tol*norm_pre_b) then
          !if(norm_resid <= gmres_rel_tol*norm_init_resid) then
            if (gmres_verbose .ge. 2) then
              if (parallel_IOProcessor()) then
                write ( *, '(a, i4,a,i4,a,i4)' ) 'GMRES converged: Outer = ', iter, ',  Inner = ', i, ' Total=', total_iter
              end if
            end if

            if (norm_resid_Stokes >= 10*gmres_rel_tol*min(norm_b, norm_init_Stokes)) then
              if (parallel_IOProcessor()) write(*,*) 'gmres.f90: Warning: gmres may not have converged: |r|/|b|=', &
                         norm_resid_Stokes/norm_b, ' |r|/|r0|=', norm_resid_Stokes/norm_init_Stokes
            end if

            exit OuterLoop ! Only exit if the *true* preconditioned residual is less than tolerance: Do not trust the gmres estimate
         else if (norm_resid <= gmres_abs_tol) then

            if (gmres_verbose .ge. 2) then
              if (parallel_IOProcessor()) then
                write ( *, '(a, i4,a,i4,a,i4)' ) 'GMRES converged: Outer = ', iter, ',  Inner = ', i, ' Total=', total_iter
              end if
            end if

            exit OuterLoop

          end if
       end if

       if(iter >= gmres_max_outer) then
           if (parallel_IOProcessor()) then
               print*, 'GMRES did not converge in max number of outer iterations: Exiting'
           end if
           exit OuterLoop
       end if
       iter=iter+1

       ! create the first basis in Krylov space
       ! V(1) = r / norm(r)
       do n=1,nlevs
          do d=1,dm
             call multifab_copy_c(V_u(n,d),1,r_u(n,d),1,1,0)
             call multifab_div_div_s_c(V_u(n,d),1,norm_resid,1,0)
          end do
          call multifab_copy_c(V_p(n),1,r_p(n),1,1,0)
          call multifab_div_div_s_c(V_p(n),1,norm_resid,1,0)
       end do

       ! s = norm(r) * e_1
       s(:) = 0.d0
       s(1) = norm_resid

       !!!!!!!!!!!!!!!!!!!!!!!!!
       ! begin inner iteration
       !!!!!!!!!!!!!!!!!!!!!!!!!

       InnerLoop: do i=1,gmres_max_inner
          total_iter = total_iter + 1
          i_copy=i

          ! tmp=A*V(i)
          ! we use r_p and r_u as temporaries to hold ith component of V
          do n=1,nlevs
             do d=1,dm
                call multifab_copy_c(r_u(n,d),1,V_u(n,d),i,1,0)
             end do
             call multifab_copy_c(r_p(n),1,V_p(n),i,1,0)
          end do

          call apply_matrix(mla,tmp_u,tmp_p,r_u,r_p,alpha_fc,beta,beta_ed, &
                            gamma,theta_alpha,dx,the_bc_tower)

          ! w = M^{-1} A*V(i)
          call apply_precon(mla,tmp_u,tmp_p,w_u,w_p,alpha_fc, &
                            beta,beta_ed,gamma,theta_alpha,dx,the_bc_tower)

          do k=1,i
             ! form H(k,i) Hessenberg matrix
             ! H(k,i) = dot_product(w, V(k))
             !        = dot_product(w_u, V_u(k))+dot_product(w_p, V_p(k))
             call stag_inner_prod(mla,w_u,1,V_u,k,inner_prod_vel)
             call cc_inner_prod(mla,w_p,1,V_p,k,inner_prod_pres)
             H(k,i) = sum(inner_prod_vel(1:dm)) + (p_norm_weight**2)*inner_prod_pres

             ! w = w - H(k,i) * V(k)
             ! use tmp_u and tmp_p as temporaries to hold kth component of V(k)
             do n=1,nlevs
                do d=1,dm
                   call multifab_copy_c(tmp_u(n,d),1,V_u(n,d),k,1,0)
                   call multifab_mult_mult_s_c(tmp_u(n,d),1,H(k,i),1,0)
                   call multifab_sub_sub_c(w_u(n,d),1,tmp_u(n,d),1,1,0)
                end do
                call multifab_copy_c(tmp_p(n),1,V_p(n),k,1,0)
                call multifab_mult_mult_s_c(tmp_p(n),1,H(k,i),1,0)
                call multifab_sub_sub_c(w_p(n),1,tmp_p(n),1,1,0)
             end do
          end do

          ! H(i+1,i) = norm(w)
          call stag_l2_norm(mla,w_u,norm_u)
          call cc_l2_norm(mla,w_p,norm_p)
          norm_p = p_norm_weight*norm_p
          H(i+1,i) = sqrt(norm_u**2+norm_p**2)

          ! V(i+1) = w / H(i+1,i)
          if ( H(i+1,i) .ne. 0.d0 ) then
             do n=1,nlevs
                do d=1,dm
                   call multifab_copy_c(V_u(n,d),i+1,w_u(n,d),1,1,0)
                   call multifab_div_div_s_c(V_u(n,d),i+1,H(i+1,i),1,0)
                end do
                call multifab_copy_c(V_p(n),i+1,w_p(n),1,1,0)
                call multifab_div_div_s_c(V_p(n),i+1,H(i+1,i),1,0)
             end do
          else
             call bl_error("gmres.f90: error in orthogonalization")
          end if

          call least_squares(i, H, cs, sn, s)   ! solve least square problem
          norm_resid_est=abs(s(i+1))

          if (gmres_verbose .ge. 2) then
          if (parallel_IOProcessor()) then
             write ( *, '(2i6,a,100g17.9)' ) total_iter, vcycle_counter, ',  est. rel. resid. |Pr|/(Pr0,b)= ', &
                norm_resid_est/norm_init_resid, norm_resid_est/norm_pre_b
             if (gmres_verbose .ge. 3) then
                ! Write the convergence information to files
                write ( 204, '(I0,100g17.9)' ) vcycle_counter, norm_resid_est/norm_init_resid
             end if
          end if
          end if

          ! force output to be written for screen
          ! useful for parallel problems
          ! "6" is the standard output
          call flush(6)

          if(total_iter >= gmres_max_iter) then
            exit InnerLoop
          else if(total_iter .ge. gmres_min_iter) then
             ! other options
             if ((norm_resid_est <= gmres_rel_tol*min(norm_pre_b, norm_init_resid)) .or. (norm_resid_est <= gmres_abs_tol)) then
             !if(norm_resid_est <= gmres_rel_tol*norm_pre_b .or. (norm_resid_est <= gmres_abs_tol)) then
             !if(norm_resid_est <= gmres_rel_tol*norm_init_resid .or. (norm_resid_est <= gmres_abs_tol)) then
                exit InnerLoop
             end if
          end if

       end do InnerLoop ! end of inner loop (do i=1,gmres_max_inner)

       ! update the solution   ! first, solve for y
       call SolveUTriangular(i_copy-1, H, s, y)

       ! then, x = x + dot(V(1:i),y(1:i))
       call update_sol(mla, x_u(1,:), x_p(1), V_u(1,:), V_p(1), y, i_copy, &
                       the_bc_tower%bc_tower_array(1), dx(1,:))

    end do OuterLoop ! end of outer loop (do iter=1,gmres_max_outer)

    ! AJN - this is here since I notice epsilon roundoff errors building up
    !       just enough to destroy the asymmetry in time-advancement codes that
    !       ultimately causes lack of convergence in subsequent gmres calls
    do i=1,dm
       call multifab_internal_sync(x_u(1,i))
    end do

    ! apply scaling factor
    if (scale_factor .ne. 1.d0) then
       theta_alpha = theta_alpha/scale_factor
       do n=1,nlevs
          ! the solution we got is scale*x_p
          call multifab_mult_mult_s(x_p(n),1.d0/scale_factor,x_p(n)%ng)
          ! unscale the rhs
          do i=1,dm
             call multifab_mult_mult_s(b_u(n,i),1.d0/scale_factor,b_u(n,i)%ng)
          end do
          ! unscale the viscosities
          call multifab_mult_mult_s(beta(n),1.d0/scale_factor,beta(n)%ng)
          call multifab_mult_mult_s(gamma(n),1.d0/scale_factor,gamma(n)%ng)
          do i=1,size(beta_ed,dim=2)
             call multifab_mult_mult_s(beta_ed(n,i),1.d0/scale_factor,beta_ed(n,i)%ng)
          end do
       end do
    end if

    ! clean up memory
    do n=1,nlevs
       do d=1,dm
          call multifab_destroy(r_u(n,d))
          call multifab_destroy(w_u(n,d))
          call multifab_destroy(tmp_u(n,d))
          call multifab_destroy(V_u(n,d))
       end do
       call multifab_destroy(r_p(n))
       call multifab_destroy(w_p(n))
       call multifab_destroy(tmp_p(n))
       call multifab_destroy(V_p(n))
    end do

    if (gmres_verbose .ge. 1) then
      if (gmres_verbose .ge. 3) then
        if (parallel_IOProcessor()) then
          close(204)
          close(205)
        end if
      else
        if (parallel_IOProcessor()) then
          write ( *, '(a)' ) 'Preconditioned GMRES:'
          write ( *, '(a,i4)' ) '  total ITERs = ', total_iter
          write ( *, '(a, 100g17.9)' ) '  residual/(norm_b,initial) = ', norm_resid/norm_b, norm_resid/norm_init_resid
        end if
      end if
    end if

    call destroy(bpt)

  contains

    !------------------------------------------
    subroutine update_sol(mla,x_u,x_p,V_u,V_p,y,i,the_bc_level,dx)

      type(ml_layout), intent(in   ) :: mla
      type(multifab) , intent(inout) :: x_u(:)
      type(multifab) , intent(inout) :: x_p
      type(multifab) , intent(inout) :: V_u(:)
      type(multifab) , intent(inout) :: V_p
      real(kind=dp_t), intent(in   ) :: y(:)
      integer        , intent(in   ) :: i
      type(bc_level) , intent(in   ) :: the_bc_level
      real(kind=dp_t), intent(in   ) :: dx(:)

      ! local variables
      integer :: dm,d,iter

      type(bl_prof_timer), save :: bpt

      call build(bpt,"udate_sol")

      dm = mla%dim

      ! set V(i) = V(i)*y(i)
      ! set x = x + V(i)
      do iter=1,i
         call multifab_mult_mult_s_c(V_p,iter,y(iter),1,0)
         call multifab_plus_plus_c(x_p,1,V_p,iter,1,0)
         do d=1,dm
            call multifab_mult_mult_s_c(V_u(d),iter,y(iter),1,0)
            call multifab_plus_plus_c(x_u(d),1,V_u(d),iter,1,0)
         end do
      end do

      call destroy(bpt)

    end subroutine update_sol

    subroutine least_squares(i, H, cs, sn, s)

      integer        , intent(in   ) :: i
      real(kind=dp_t), intent(inout) :: H(:,:)
      real(kind=dp_t), intent(inout) :: cs(:)
      real(kind=dp_t), intent(inout) :: sn(:)
      real(kind=dp_t), intent(inout) :: s(:)

      ! local variable
      integer :: k
      real(kind=dp_t) :: temp

      type(bl_prof_timer), save :: bpt

      call build(bpt,"least_squares")

      ! apply Givens rotation
      do k = 1,i-1
         temp     =  cs(k)*H(k,i) + sn(k)*H(k+1,i)
         H(k+1,i) = -sn(k)*H(k,i) + cs(k)*H(k+1,i)
         H(k,i)   = temp
      end do

      ! form i-th rotation matrix
      call rotmat(H(i,i), H(i+1,i), cs(i), sn(i))

      ! approximate residual norm
      temp   = cs(i)*s(i)
      s(i+1) = -sn(i)*s(i)
      s(i)   = temp
      H(i,i) = cs(i)*H(i,i) + sn(i)*H(i+1,i)
      H(i+1,i) = 0.0d0

      call destroy(bpt)

    end subroutine least_squares

    subroutine rotmat(a, b, cs, sn)

      ! Compute the Givens rotation matrix parameters for a and b.

      real(kind=dp_t), intent(in   ) :: a,b
      real(kind=dp_t), intent(inout) :: cs,sn

      ! local
      real(kind=dp_t) :: temp

      type(bl_prof_timer), save :: bpt

      call build(bpt,"rotmat")

      if ( b .eq. 0.0d0 ) then
         cs = 1.0d0
         sn = 0.0d0
      elseif(abs(b) > abs(a)) then
         temp = a/b
         sn = 1.0d0/sqrt(1.0d0 + temp**2)
         cs = temp * sn
      else
         temp = b / a;
         cs = 1.0d0/sqrt(1.0d0 + temp**2)
         sn = temp * cs
      end if

      call destroy(bpt)

    end subroutine rotmat

    subroutine SolveUTriangular(k, H, s, y)

      integer        , intent(in   ) :: k
      real(kind=dp_t), intent(in   ) :: H(:,:)
      real(kind=dp_t), intent(in   ) :: s(:)
      real(kind=dp_t), intent(inout) :: y(:)
      !local
      integer :: i

      type(bl_prof_timer), save :: bpt

      call build(bpt,"SolveUTriangular")

      y(k+1) = s(k+1)/H(k+1,k+1)
      do i = k, 1, -1
         y(i) = (s(i)-dot_product(H(i,i+1:k+1), y(i+1:k+1)))/H(i,i)
      end do

      call destroy(bpt)

    end subroutine SolveUTriangular

  end subroutine gmres

end module gmres_module


program Assignment2

sum=0
do k = 1,100
  sum = sum + k
end do
print*,"The sum of the numbers from 0 to 100 is",sum

end program Assignment2


c
c     ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine ifacts(lmax,illp,ilp1,iprint,istop)
c     =================================================================
c
      implicit   none
c
      character  sname*20
      character  istop*32
c
      integer    iprint
      integer    lmax
      integer    l
      integer    m
      integer    lp
      integer    mp
      integer    lm
      integer    lmp
c
      complex*16 illp((lmax+1)**2,(lmax+1)**2)
      complex*16 ilp1(0:2*lmax)
      complex*16 cone
      complex*16 sqrtm1
c
      parameter (sqrtm1=(0.0d0,1.0d0))
      parameter (cone=(1.0d0,0.0d0))
      parameter (sname='ifacts')
c
c     ================================================================
c     set up factors i**l.............................................
      ilp1(0)=cone
      do l=1,2*lmax
         ilp1(l)=ilp1(l-1)*sqrtm1
      enddo
c     ================================================================
c     load the factors i**(l-lp)into the matrix illp(lm,lmp).........
      do l=0,lmax
         do m= -l,l
            lm=l*(l+1)+1+m
            do lp=0,lmax
               do mp= -lp,lp
                  lmp=lp*(lp+1)+1+mp
                  illp(lm,lmp)=ilp1(l)/ilp1(lp)
c                 ====================================================
c                 printout if needed..................................
                  if(iprint.ge.1) then
                     write(6,'('' l,m,lp,mp,lm,lmp,illp(lm,lmp):'',
     >               6i4,2f8.3)') l,m,lp,mp,lm,lmp,illp(lm,lmp)
                  endif
               enddo
            enddo
         enddo
      enddo
c     ================================================================
c     set up factors i**(l+1)..........................................
      do l=0,2*lmax
         ilp1(l)=ilp1(l)*sqrtm1
      enddo
c     ================================================================
c     printout if needed..............................................
      if(iprint.ge.1) then
         write(6,'('' ifacts:: l,i**(l+1):'',i3,2d12.4)')
     >   (l,ilp1(l),l=0,2*lmax)
      endif
c
c     ================================================================
      if(istop.eq.sname) then
         call fstop(sname)
      else
         return
      endif
      end


      SUBROUTINE ZTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*     .. Scalar Arguments ..
      INTEGER INCX,LDA,N
      CHARACTER DIAG,TRANS,UPLO
*     ..
*     .. Array Arguments ..
      DOUBLE COMPLEX A(LDA,*),X(*)
*     ..
*
*  Purpose
*  =======
*
*  ZTRMV  performs one of the matrix-vector operations
*
*     x := A*x,   or   x := A**T*x,   or   x := A**H*x,
*
*  where x is an n element vector and  A is an n by n unit, or non-unit,
*  upper or lower triangular matrix.
*
*  Arguments
*  ==========
*
*  UPLO   - CHARACTER*1.
*           On entry, UPLO specifies whether the matrix is an upper or
*           lower triangular matrix as follows:
*
*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
*
*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
*
*           Unchanged on exit.
*
*  TRANS  - CHARACTER*1.
*           On entry, TRANS specifies the operation to be performed as
*           follows:
*
*              TRANS = 'N' or 'n'   x := A*x.
*
*              TRANS = 'T' or 't'   x := A**T*x.
*
*              TRANS = 'C' or 'c'   x := A**H*x.
*
*           Unchanged on exit.
*
*  DIAG   - CHARACTER*1.
*           On entry, DIAG specifies whether or not A is unit
*           triangular as follows:
*
*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
*
*              DIAG = 'N' or 'n'   A is not assumed to be unit
*                                  triangular.
*
*           Unchanged on exit.
*
*  N      - INTEGER.
*           On entry, N specifies the order of the matrix A.
*           N must be at least zero.
*           Unchanged on exit.
*
*  A      - COMPLEX*16       array of DIMENSION ( LDA, n ).
*           Before entry with  UPLO = 'U' or 'u', the leading n by n
*           upper triangular part of the array A must contain the upper
*           triangular matrix and the strictly lower triangular part of
*           A is not referenced.
*           Before entry with UPLO = 'L' or 'l', the leading n by n
*           lower triangular part of the array A must contain the lower
*           triangular matrix and the strictly upper triangular part of
*           A is not referenced.
*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
*           A are not referenced either, but are assumed to be unity.
*           Unchanged on exit.
*
*  LDA    - INTEGER.
*           On entry, LDA specifies the first dimension of A as declared
*           in the calling (sub) program. LDA must be at least
*           max( 1, n ).
*           Unchanged on exit.
*
*  X      - COMPLEX*16       array of dimension at least
*           ( 1 + ( n - 1 )*abs( INCX ) ).
*           Before entry, the incremented array X must contain the n
*           element vector x. On exit, X is overwritten with the
*           tranformed vector x.
*
*  INCX   - INTEGER.
*           On entry, INCX specifies the increment for the elements of
*           X. INCX must not be zero.
*           Unchanged on exit.
*
*  Further Details
*  ===============
*
*  Level 2 Blas routine.
*  The vector and matrix arguments are not referenced when N = 0, or M = 0
*
*  -- Written on 22-October-1986.
*     Jack Dongarra, Argonne National Lab.
*     Jeremy Du Croz, Nag Central Office.
*     Sven Hammarling, Nag Central Office.
*     Richard Hanson, Sandia National Labs.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE COMPLEX ZERO
      PARAMETER (ZERO= (0.0D+0,0.0D+0))
*     ..
*     .. Local Scalars ..
      DOUBLE COMPLEX TEMP
      INTEGER I,INFO,IX,J,JX,KX
      LOGICAL NOCONJ,NOUNIT
*     ..
*     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC DCONJG,MAX
*     ..
*
*     Test the input parameters.
*
      INFO = 0
      IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
          INFO = 1
      ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
     +         .NOT.LSAME(TRANS,'C')) THEN
          INFO = 2
      ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
          INFO = 3
      ELSE IF (N.LT.0) THEN
          INFO = 4
      ELSE IF (LDA.LT.MAX(1,N)) THEN
          INFO = 6
      ELSE IF (INCX.EQ.0) THEN
          INFO = 8
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('ZTRMV ',INFO)
          RETURN
      END IF
*
*     Quick return if possible.
*
      IF (N.EQ.0) RETURN
*
      NOCONJ = LSAME(TRANS,'T')
      NOUNIT = LSAME(DIAG,'N')
*
*     Set up the start point in X if the increment is not unity. This
*     will be  ( N - 1 )*INCX  too small for descending loops.
*
      IF (INCX.LE.0) THEN
          KX = 1 - (N-1)*INCX
      ELSE IF (INCX.NE.1) THEN
          KX = 1
      END IF
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF (LSAME(TRANS,'N')) THEN
*
*        Form  x := A*x.
*
          IF (LSAME(UPLO,'U')) THEN
              IF (INCX.EQ.1) THEN
                  DO 20 J = 1,N
                      IF (X(J).NE.ZERO) THEN
                          TEMP = X(J)
                          DO 10 I = 1,J - 1
                              X(I) = X(I) + TEMP*A(I,J)
   10                     CONTINUE
                          IF (NOUNIT) X(J) = X(J)*A(J,J)
                      END IF
   20             CONTINUE
              ELSE
                  JX = KX
                  DO 40 J = 1,N
                      IF (X(JX).NE.ZERO) THEN
                          TEMP = X(JX)
                          IX = KX
                          DO 30 I = 1,J - 1
                              X(IX) = X(IX) + TEMP*A(I,J)
                              IX = IX + INCX
   30                     CONTINUE
                          IF (NOUNIT) X(JX) = X(JX)*A(J,J)
                      END IF
                      JX = JX + INCX
   40             CONTINUE
              END IF
          ELSE
              IF (INCX.EQ.1) THEN
                  DO 60 J = N,1,-1
                      IF (X(J).NE.ZERO) THEN
                          TEMP = X(J)
                          DO 50 I = N,J + 1,-1
                              X(I) = X(I) + TEMP*A(I,J)
   50                     CONTINUE
                          IF (NOUNIT) X(J) = X(J)*A(J,J)
                      END IF
   60             CONTINUE
              ELSE
                  KX = KX + (N-1)*INCX
                  JX = KX
                  DO 80 J = N,1,-1
                      IF (X(JX).NE.ZERO) THEN
                          TEMP = X(JX)
                          IX = KX
                          DO 70 I = N,J + 1,-1
                              X(IX) = X(IX) + TEMP*A(I,J)
                              IX = IX - INCX
   70                     CONTINUE
                          IF (NOUNIT) X(JX) = X(JX)*A(J,J)
                      END IF
                      JX = JX - INCX
   80             CONTINUE
              END IF
          END IF
      ELSE
*
*        Form  x := A**T*x  or  x := A**H*x.
*
          IF (LSAME(UPLO,'U')) THEN
              IF (INCX.EQ.1) THEN
                  DO 110 J = N,1,-1
                      TEMP = X(J)
                      IF (NOCONJ) THEN
                          IF (NOUNIT) TEMP = TEMP*A(J,J)
                          DO 90 I = J - 1,1,-1
                              TEMP = TEMP + A(I,J)*X(I)
   90                     CONTINUE
                      ELSE
                          IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
                          DO 100 I = J - 1,1,-1
                              TEMP = TEMP + DCONJG(A(I,J))*X(I)
  100                     CONTINUE
                      END IF
                      X(J) = TEMP
  110             CONTINUE
              ELSE
                  JX = KX + (N-1)*INCX
                  DO 140 J = N,1,-1
                      TEMP = X(JX)
                      IX = JX
                      IF (NOCONJ) THEN
                          IF (NOUNIT) TEMP = TEMP*A(J,J)
                          DO 120 I = J - 1,1,-1
                              IX = IX - INCX
                              TEMP = TEMP + A(I,J)*X(IX)
  120                     CONTINUE
                      ELSE
                          IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
                          DO 130 I = J - 1,1,-1
                              IX = IX - INCX
                              TEMP = TEMP + DCONJG(A(I,J))*X(IX)
  130                     CONTINUE
                      END IF
                      X(JX) = TEMP
                      JX = JX - INCX
  140             CONTINUE
              END IF
          ELSE
              IF (INCX.EQ.1) THEN
                  DO 170 J = 1,N
                      TEMP = X(J)
                      IF (NOCONJ) THEN
                          IF (NOUNIT) TEMP = TEMP*A(J,J)
                          DO 150 I = J + 1,N
                              TEMP = TEMP + A(I,J)*X(I)
  150                     CONTINUE
                      ELSE
                          IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
                          DO 160 I = J + 1,N
                              TEMP = TEMP + DCONJG(A(I,J))*X(I)
  160                     CONTINUE
                      END IF
                      X(J) = TEMP
  170             CONTINUE
              ELSE
                  JX = KX
                  DO 200 J = 1,N
                      TEMP = X(JX)
                      IX = JX
                      IF (NOCONJ) THEN
                          IF (NOUNIT) TEMP = TEMP*A(J,J)
                          DO 180 I = J + 1,N
                              IX = IX + INCX
                              TEMP = TEMP + A(I,J)*X(IX)
  180                     CONTINUE
                      ELSE
                          IF (NOUNIT) TEMP = TEMP*DCONJG(A(J,J))
                          DO 190 I = J + 1,N
                              IX = IX + INCX
                              TEMP = TEMP + DCONJG(A(I,J))*X(IX)
  190                     CONTINUE
                      END IF
                      X(JX) = TEMP
                      JX = JX + INCX
  200             CONTINUE
              END IF
          END IF
      END IF
*
      RETURN
*
*     End of ZTRMV .
*
      END


PROGRAM mclpmn

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:10

!       ============================================================
!       Purpose: This program computes the associated Legendre
!                functions Pmn(z) and their derivatives Pmn'(z) for
!                a complex argument using subroutine CLPMN
!       Input :  x --- Real part of z
!                y --- Imaginary part of z
!                m --- Order of Pmn(z),  m = 0,1,2,...,n
!                n --- Degree of Pmn(z), n = 0,1,2,...,N
!       Output:  CPM(m,n) --- Pmn(z)
!                CPD(m,n) --- Pmn'(z)
!       Examples:
!                n = 5, x = 0.5, y = 0.2

!       m     Re[Pmn(z)]    Im[Pmn(z)]    Re[Pmn'(z)]   Im[Pmn'(z)]
!      -------------------------------------------------------------
!       0    .252594D+00  -.530293D+00   -.347606D+01  -.194250D+01
!       1    .333071D+01   .135206D+01    .117643D+02  -.144329D+02
!       2   -.102769D+02   .125759D+02    .765713D+02   .598500D+02
!       3   -.572879D+02  -.522744D+02   -.343414D+03   .147389D+03
!       4    .335711D+03  -.389151D+02   -.226328D+03  -.737100D+03
!       5   -.461125D+03   .329122D+03    .187180D+04   .160494D+02

!                n = 5, x = 2.5, y = 1.0

!       m     Re[Pmn(z)]    Im[Pmn(z)]    Re[Pmn'(z)]   Im[Pmn'(z)]
!      -------------------------------------------------------------
!       0   -.429395D+03   .900336D+03   -.350391D+02   .193594D+04
!       1   -.216303D+04   .446358D+04   -.208935D+03   .964685D+04
!       2   -.883477D+04   .174005D+05   -.123703D+04   .381938D+05
!       3   -.273211D+05   .499684D+05   -.568080D+04   .112614D+06
!       4   -.565523D+05   .938503D+05   -.167147D+05   .219713D+06
!       5   -.584268D+05   .863328D+05   -.233002D+05   .212595D+06
!       ============================================================

IMPLICIT DOUBLE PRECISION (x,y)
IMPLICIT COMPLEX*16 (c,z)
DIMENSION cpm(0:40,0:40),cpd(0:40,0:40)
WRITE(*,*)'  Please enter m, n, x and y '
!        READ(*,*) M,N,X,Y
m=0
n=5
x=.5
y=.2
WRITE(*,30) m,n,x,y
CALL clpmn(40,m,n,x,y,cpm,cpd)
WRITE(*,*)'   m   n    Re[Pmn(z)]    Im[Pmn(z)]    ',  &
    'Re[Pmn''(Z)]   IM[PMN''(Z)]'
WRITE(*,*)' -----------------------------------',  &
    '-------------------------------'
DO  j=0,n
  WRITE(*,20)m,j,cpm(m,j),cpd(m,j)
END DO
20      FORMAT(1X,2I4,1X,2D14.6,1X,2D14.6)
30      FORMAT(1X,'m =',i2,', ','n =',i2,', ','x =',f5.1, ', ','y =',f5.1)
END PROGRAM mclpmn

SUBROUTINE clpmn(mm,m,n,x,y,cpm,cpd)

!       =========================================================
!       Purpose: Compute the associated Legendre functions Pmn(z)
!                and their derivatives Pmn'(z) for a complex
!                argument
!       Input :  x  --- Real part of z
!                y  --- Imaginary part of z
!                m  --- Order of Pmn(z),  m = 0,1,2,...,n
!                n  --- Degree of Pmn(z), n = 0,1,2,...,N
!                mm --- Physical dimension of CPM and CPD
!       Output:  CPM(m,n) --- Pmn(z)
!                CPD(m,n) --- Pmn'(z)
!       =========================================================

INTEGER, INTENT(IN OUT)                  :: mm
INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(IN OUT)         :: y
COMPLEX, INTENT(OUT)                     :: cpm(0:mm,0:n)
COMPLEX, INTENT(OUT)                     :: cpd(0:mm,0:n)
IMPLICIT DOUBLE PRECISION (x,y)
IMPLICIT COMPLEX*16 (c,z)

z=CMPLX(x,y)
DO  i=0,n
  DO  j=0,m
    cpm(j,i)=(0.0D0,0.0D0)
    cpd(j,i)=(0.0D0,0.0D0)
  END DO
END DO
cpm(0,0)=(1.0D0,0.0D0)
IF (DABS(x) == 1.0D0.AND.y == 0.0D0) THEN
  DO  i=1,n
    cpm(0,i)=x**i
    cpd(0,i)=0.5D0*i*(i)*x**(i)
  END DO
  DO  j=1,n
    DO  i=1,m
      IF (i == 1) THEN
        cpd(i,j)=(1.0D+300,0.0D0)
      ELSE IF (i == 2) THEN
        cpd(i,j)=-0.25D0*(j+2)*(j)*j*(j-1)*x**(j)
      END IF
    END DO
  END DO
  RETURN
END IF
ls=1
IF (CDABS(z) > 1.0D0) ls=-1
zq=CDSQRT(ls*(1.0D0-z*z))
zs=ls*(1.0D0-z*z)
DO  i=1,m
  cpm(i,i)=-ls*(2.0D0*i-1.0D0)*zq*cpm(i-1,i-1)
END DO
DO  i=0,m
  cpm(i,i+1)=(2.0D0*i+1.0D0)*z*cpm(i,i)
END DO
DO  i=0,m
  DO  j=i+2,n
    cpm(i,j)=((2.0D0*j-1.0D0)*z*cpm(i,j-1)-(i+j- 1.0D0)*cpm(i,j-2))/(j-i)
  END DO
END DO
cpd(0,0)=(0.0D0,0.0D0)
DO  j=1,n
  cpd(0,j)=ls*j*(cpm(0,j-1)-z*cpm(0,j))/zs
END DO
DO  i=1,m
  DO  j=i,n
    cpd(i,j)=ls*i*z*cpm(i,j)/zs+(j+i)*(j-i+1.0D0) /zq*cpm(i-1,j)
  END DO
END DO
RETURN
END SUBROUTINE clpmn


c     program DRDWCOM2
c>> 1996-05-28 DRDWCOM2 Krogh Removed implicit statement.
c>> 1996-05-28 DRDWCOM2 Krogh Added external statement.
c>> 1995-10-24 DRDWCOM2 Krogh Changed misleading message.
c>> 1994-11-02 DRDWCOM2 Krogh Changes to use M77CON
c>> 1992-05-15 DRDWCOM2 CLL Removed "stop '... finished'"
c>> 1992-03-24 CLL Add parameter MXCASE.
c>> 1992-03-12 CLL
c>> 1987-10-28 Original time stamp
c  Demo driver for the DWCOMP package.  This code was adapted from the
c  test driver to reduce the number of tests and the amount of output.
c  Here we have NCASES = 1 and NN(1) = 6, whereas the test driver had
c  NCASES = 7 and NN(1) = 0.
c     The package DWCOMP computes values and derivatives using the
c     approach described by Wengert.
c     C. L. Lawson, JPL, 1971.  Revised for Fortran77, Jan 1987.
c     CLL 8/18/87. Added DWASIN & DWACOS to package.
c     CLL 8/31/87. Added DWRCHN and changed order of args in DWCHN.
c     CLL 9/1/87.  Added DWSINH, DWCOSH, DWTANH.
c     1992-05-15 CLL Removed "stop '... finished'" to simplify
c     comparison of output from different systems.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c--D replaces "?": DR?WCOM2, ?WCOMP
c--&    ?COPY, ?MXDIF, ?PASCL, ?VECP, ?WACOS, ?WASIN
c--&    ?WATAN, ?WATN2, ?WCHN, ?WCOS, ?WCOSH, ?WDIF, ?WDIF1, ?WEXP
c--&    ?WLOG, ?WPRO, ?WPRO1, ?WPWRI, ?WQUO, ?WQUO1, ?WRCHN, ?WSET
c--&    ?WSIN, ?WSINH, ?WSQRT, ?WSUM, ?WSUM1, ?WTAN, ?WTANH
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer I, IA, ICASE, ICOUNT, II, J, MXCASE, N, NCASES, NMAX,
     1   NDIM, NP1, NW, NA, NX
      parameter(MXCASE = 7)
      parameter(NCASES = 1, NMAX = 6, NDIM = NMAX+1, NW = 20)
      parameter(NA = 4, NX = 10)
      external DMXDIF
      double precision DMXDIF
      double precision S(295),W(NDIM, NW), TEMP(NDIM), X(NDIM,NX)
      double precision SAVE1(NDIM), SAVE2(NDIM), XEXP(NDIM), XLOG(NDIM)
      double precision A(NA), FIX3(NA)
      double precision ZERO, ONE, TWO, HALF, FOUR, PI, C9, C8, C7
      parameter(ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0, HALF = 0.50d0)
      parameter(FOUR = 4.0d0, C9 = 0.9d0, C8 = 0.8d0, C7 = 0.7d0)
      logical DETAIL, AS(NA), AC(NA)
      integer          NN(MXCASE), IPWR
      data NN/6,1,2,3,4,5,6/
      data A    / -2.0d0, -1.0d0, 0.75d0, 2.5d0/
      data FIX3 /  4*0.0d0 /
      data AS   /  .false., .true., .true., .false. /
      data AC   /  .false., .false., .true., .true. /
      data DETAIL / .false. /
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      print'(a)',
     *   ' DRDWCOM2..  Demo driver for the whole DWCOMP package.',
     *   ' Will print the numerical error in various calculations.'
      PI = ATAN(ONE) * FOUR
      FIX3(1) =  PI
      FIX3(4) = -PI
c
      if(DETAIL) then
      do 20 I=1,6
         do 10 J=1,40
            S(J)=ZERO
   10    continue
         call DPASCL(I-1,S)
         II=((I-1)*I)/2 + 1
         call DVECP  (S,II,  '0DPASCL')
   20    continue
      endif
c                                   Set X(*,1) and X(*,2)
      X(1,1) = C8
      X(1,2) = C7
      do 30 I = 2,NDIM
         X(I,1) = C8 * X(I-1,1)
         X(I,2) = -C7 * X(I-1,2)
   30 continue
c                              Loop through different values of N
      do 500 ICASE= 1, NCASES
         N=NN(ICASE)
         write(*,'(1x/1x,a,i3/1X)') '>>>>>> Tests with Nderiv = ', N
         NP1=N+1
c                                   Set W(*,1) and W(*,2)
            W(1,1) = C9
            W(1,2) = C9
            W(2,1) = C9*C9
            W(2,2) = -C9
            do 40 I = 3,NDIM
               W(I,1) = -C9*W(I-1,1)
               W(I,2) = ZERO
   40       continue
c                                                     Test DWSET
         call  DWSET  (N, C9, -C9, W(1,3))
         write(*,'(1x,a,g11.3)')
     *         'Error in SET                           =',
     *      DMXDIF(NP1,W(1,2),1, W(1,3),1)
c
c                             Test DWSUM, DWSUM1, DWDIF, DWDIF1, DWPRO1
c
      call DWSUM1(N, FOUR, X(1,1), X(1,3))
      call DWSUM (N, X(1,3), X(1,2), X(1,3))
      call DWDIF (N, X(1,3), X(1,1), X(1,3))
      call DWDIF1(N, FOUR, X(1,3), X(1,3))
      call DWPRO1(N, -ONE, X(1,3), X(1,3))
            write(*,'(1x,a,g11.3)')
     *         'Error in -(4-(((4+x)+y))-x) - y        =',
     *         DMXDIF(NP1,X(1,3),1, X(1,2),1)
c
c                                   Test DWQUO1, DWPRO1, and DWPWRI
c
      call DWQUO1(N,TWO, X(1,1), X(1,3))
      call DWPWRI(N,-1, X(1,3), X(1,4))
      call DWPRO1(N,TWO, X(1,4), X(1,5))
            write(*,'(1x,a,g11.3)')
     *         'Error in 2*((2/x)**-1) - x             =',
     *         DMXDIF(NP1,X(1,5),1, X(1,1),1)
c                                                 Test DWPRO and DWQUO
      call DWPRO(N, X(1,1), X(1,2), X(1,3))
      call DWQUO(N, X(1,3), X(1,2), X(1,4))
            write(*,'(1x,a,g11.3)')
     *         'Error in (X1*X2)/X2 - X1               =',
     *         DMXDIF(NP1,X(1,4),1, X(1,1),1)
      if(DETAIL) then
         print*,'X1, X2, X3 = X1 * X2, X4 = X3/X2'
         do 50 J = 1,4
            write(*,'(1x,I3,4g15.7/(4x,4g15.7))') J,(X(I,J),I=1,NP1)
   50    continue
      endif
      call DWQUO(N, X(1,3), X(1,2), X(1,3))
            write(*,'(1x,a,g11.3)')
     *         'Error in (X1*X2)/X2 - X1               =',
     *         DMXDIF(NP1,X(1,3),1, X(1,1),1)
      if(DETAIL) then
         print*,' '
         print*,'X3 = X3/X2'
         write(*,'(1x,I3,4g15.7)') 3,(X(I,3),I=1,NDIM)
      endif
c
c                             Test DWLOG and DWEXP, uses DWCHN
c
          call  DWLOG  (N,W(1,1),W(1,2))
          call  DWEXP (N,W(1,2),W(1,3))
         write(*,'(1x,a,g11.3)')
     *      'Error in Exp(Log(2)) - 2               =',
     *      DMXDIF(NP1,W(1,3),1, W(1,1),1)
         if(DETAIL) then
          call  DVECP(W(1,1),NP1,   '0W1 = T = 2.')
          call  DVECP (W(1,2),NP1,   '0W2 = LOG(W1)')
          call  DVECP (W(1,3),NP1,   '0W3 = EXP(W2). SHOULD MATCH W1.')
          call  DVECP (W(1,4),NP1,   '0W4 = 0.+W1. SCALAR ADD.')
         endif
c
c                                               Test DWCHN and DWRCHN
      call DWSET(N, HALF, ONE, X(1,8))
      call DWEXP(N, X(1,8), XEXP)
      call DWSET(N, HALF, ONE, X(1,3))
      call DWRCHN(N, XEXP, X(1,3))
      if(DETAIL) then
      print*,' '
      print*,'X1, X2 = EXP(X1), X3 = Reversion to Log'
      do 60 J = 1,3
         write(*,'(1x,I3,4g15.7)') J,(X(I,J),I=1,NDIM)
   60 continue
      endif
c
      call DWSET(N, XEXP(1), ONE, X(1,4))
      call DWLOG(N, X(1,4), XLOG)
      call DWSET(N, X(1,4), ONE, X(1,6))
      call DWRCHN(N, XLOG, X(1,6))
      if(DETAIL) then
         print*,' '
         print*,'X4, X5 = LOG(X4), X6 = Reversion to Exp'
         do 70 J = 4,6
            write(*,'(1x,I3,4g15.7)') J,(X(I,J),I=1,NDIM)
   70    continue
      endif
            write(*,'(1x,a,g11.3)')
     *         'Error in Log(x) - Rev. of Exp(x)       =',
     *         DMXDIF(NP1,XLOG,1, X(1,3),1)
            write(*,'(1x,a,g11.3)')
     *         'Error in Exp(x) - Rev. of Log(x)       =',
     *         DMXDIF(NP1,XEXP,1, X(1,6),1)
c
      call DCOPY(NP1, X(1,1),1, X(1,7),1)
      call DCOPY(NP1, X(1,7),1, SAVE1,1)
      call DWCHN (N, XEXP, X(1,7))
      call DCOPY(NP1, X(1,7),1, SAVE2,1)
      call DWRCHN(N, XEXP, X(1,7))
            write(*,'(1x,a,g11.3)')
     *         'Error in X7;CHN(XEXP,X7);RCHN(XEXP,X7) =',
     *         DMXDIF(NP1,SAVE1,1, X(1,7),1)
      if(DETAIL) then
         print*,' '
         print*,'X7 ='
         J = 7
         write(*,'(1x,I3,4g15.7)') J,(SAVE1(I),I=1,NDIM)
         print*,'call DWCHN ( N, X2, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(SAVE2(I),I=1,NDIM)
         print*,'call DWRCHN ( N, X2, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(X(I,J),I=1,NDIM)
      endif
c
c
      call DCOPY(NP1, X(1,1),1, X(1,7),1)
      call DCOPY(NP1, X(1,7),1, SAVE1,1)
      call DWCHN (N, XEXP, X(1,7))
      call DCOPY(NP1, X(1,7),1, SAVE2,1)
      call DWCHN(N, XLOG, X(1,7))
            write(*,'(1x,a,g11.3)')
     *         'Error in X7;CHN(XEXP,X7);CHN(XLOG,X7)  =',
     *         DMXDIF(NP1,SAVE1,1, X(1,7),1)
      if(DETAIL) then
         print*,' '
         print*,'X7 ='
         J = 7
         write(*,'(1x,I3,4g15.7)') J,(SAVE1(I),I=1,NDIM)
         print*,'call DWCHN ( N, X2, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(SAVE2(I),I=1,NDIM)
         print*,'call DWCHN ( N, X5, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(X(I,J),I=1,NDIM)
      endif
c
      call DCOPY(NP1, X(1,1),1, X(1,7),1)
      call DCOPY(NP1, X(1,7),1, SAVE1,1)
      call DWRCHN (N, XEXP, X(1,7))
      call DCOPY(NP1, X(1,7),1, SAVE2,1)
      call DWRCHN(N, XLOG, X(1,7))
            write(*,'(1x,a,g11.3)')
     *         'Error in X7;RCHN(XEXP,X7);RCHN(XLOG,X7)=',
     *         DMXDIF(NP1,SAVE1,1, X(1,7),1)
      if(DETAIL) then
         print*,' '
         print*,'X7 ='
         J = 7
         write(*,'(1x,I3,4g15.7)') J,(SAVE1(I),I=1,NDIM)
         print*,'call DWRCHN ( N, X2, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(SAVE2(I),I=1,NDIM)
         print*,'call DWRCHN ( N, X5, X7).  X7 ='
         write(*,'(1x,I3,4g15.7)') J,(X(I,J),I=1,NDIM)
      endif
c                                         Test DWPRO and DWSQRT
c
         call  DCOPY (NP1, W(1,1),1, W(1,4),1)
         do 80 I=1,3
            call DWPRO (N,W(1,4),W(1,4),W(1,4))
            if(I .eq. 2) call DCOPY(NP1, W(1,4),1, TEMP,1)
            if(DETAIL) call DVECP  (W(1,4),NP1,   '0W4 = W4*W4')
   80    continue
c
          call DWSQRT (N, W(1,4), W(1,5) )
         write(*,'(1x,a,g11.3)')
     *         'Error in Sqrt(x*x) - x                 =',
     *      DMXDIF(NP1,TEMP,1, W(1,5),1)
         if(DETAIL) call DVECP  (W(1,5), NP1,     '0W5=SQRT(W4)')
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                                           Test of DWPWRI( ,0, , )
c
         call DWPWRI(N, 0, X(1,1), X(1,3))
         call DWSET (N, ONE, ZERO, X(1,4))
         write(*,'(1x,a,g11.3)')
     *         'Error in x**0 - 1                      =',
     *      DMXDIF(NP1,X(1,3),1, X(1,4),1)
c
c                                     Loop through tests of DWPWRI
         do 100 IPWR = 1,3
            write(*,'(1x/1x,a,i3)') 'Test DWPWRI using I = ',IPWR
            call DWPWRI(N, IPWR, X(1,1), X(1,3))
            call DCOPY(NP1, X(1,1),1, X(1,4),1)
            do 90 ICOUNT = 2,IPWR
               call DWPRO(N, X(1,1), X(1,4), X(1,4))
   90       continue
            write(*,'(1x,a,g11.3)')
     *         'Error in x**I - x * x * ... * x        =',
     *      DMXDIF(NP1,X(1,3),1, X(1,4),1)
            call DWPWRI(N, -IPWR, X(1,1), X(1,5))
            call DWPRO(N, X(1,5), X(1,4), X(1,6))
            call DWSET (N, ONE, ZERO, X(1,7))
            write(*,'(1x,a,g11.3)')
     *         'Error in x**(-I) * x**I - 1            =',
     *      DMXDIF(NP1,X(1,6),1, X(1,7),1)
  100    continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                        Loop through quadrants to test trig functions.
c
         do 110 IA=1,NA
            write(*,'(1x/1x,a,f11.4)') 'Using angle argument,',A(IA)
            call DCOPY (NP1, W(1,1),1, W(1,5),1)
            W(1,5) = A(IA)
c                                              Test DWSIN and DWASIN
            call DWSIN  (N,W(1,5),W(1,6))
            if(AS(IA)) then
            call DWASIN  (N,W(1,6),W(1,13))
            write(*,'(1x,a,g11.3)')
     *         'Error in Asin(Sin(x)) - x              =',
     *         DMXDIF(NP1,W(1,5),1, W(1,13),1)
            endif
c                                              Test DWCOS and DWACOS
            call DWCOS  (N,W(1,5),W(1,7))
            if(AC(IA)) then
            call DWACOS  (N,W(1,7),W(1,14))
            write(*,'(1x,a,g11.3)')
     *         'Error in Acos(Cos(x)) - x              =',
     *         DMXDIF(NP1,W(1,5),1, W(1,14),1)
            endif
c                                               Test DWTAN
            call DWTAN(N, W(1,5), W(1,8))
            call DWQUO (N,W(1,6),W(1,7),W(1,9))
            write(*,'(1x,a,g11.3)')
     *         'Error in Tan(x) - Sin(x)/Cos(x)        =',
     *         DMXDIF(NP1,W(1,8),1, W(1,9),1)
c                                                Test DWATN2, DWATAN
            call DWATN2(N,W(1,6),W(1,7),W(1,9))
            call DWATAN (N,W(1,8),W(1,10))
            call DCOPY(NP1,W(1,9),1, TEMP,1)
            TEMP(1) = TEMP(1) + FIX3(IA)
            write(*,'(1x,a,g11.3)')
     *         'Error in FIX + Atan2(y,x) - Atan(y/x)  =',
     *         DMXDIF(NP1,TEMP,1, W(1,10),1)
            call DWSET(N,ONE,ZERO,W(1,11) )
            call DWATN2(N,W(1,8), W(1,11), W(1,12))
            write(*,'(1x,a,g11.3)')
     *         'Error in Atan2(y/x, 1) - Atan(y/x)     =',
     *         DMXDIF(NP1,W(1,12),1, W(1,10),1)

         if(DETAIL) then
            call DVECP  (W(1,5),NP1,   '0W5 = ANGLE(IA)')
            call DVECP  (W(1,6),NP1,   '0W6 = SIN(W5)')
            call DVECP  (W(1,13),NP1,
     *                     '0W13 = ASIN(W6).  Compare with W5.')
            call DVECP  (W(1,7),NP1,   '0W7 = COS(W5)')
            call DVECP  (W(1,14),NP1,
     *                  '0W13 = Acos(W7).  Compare with W5.')
            call DVECP  (W(1,8),NP1,   '0W8 = W6/W7')
            call DVECP  (W(1,9),NP1,
     *              '0W9 = ATAN2(W6,W7).   SHOULD MATCH W5')
            call DVECP  (W(1,10),NP1,
     *  '0W10 = ATAN(W8).     SHOULD MATCH W5 OR DIFFER BY 3.14159265')
            call DVECP(W(1,12),NP1,   '0W12=ATAN2(W8,1.)' )
         endif
  110    continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c
c                                    Test DWSINH, DWCOSH,  TANH
c     First check identity: cosh**2 = sinh**2 + 1
c
      call DWSINH(N, X(1,1), X(1,3))
      call DWPRO(N, X(1,3), X(1,3), X(1,6))
      call DWSUM1(N, ONE, X(1,6), X(1,8))
      call DWCOSH(N, X(1,1), X(1,4))
      call DWPRO(N, X(1,4), X(1,4), X(1,7))
            write(*,'(1x,a,g11.3)')
     *         'Error in cosh**2 - sinh**2 - 1         =',
     *         DMXDIF(NP1,X(1,7),1, X(1,8),1)
c
c                                 Check identity: Tanh = Sinh/Cosh
c
      call DWQUO(N, X(1,3), X(1,4), X(1,9))
      call DWTANH(N, X(1,1), X(1,5))
            write(*,'(1x,a,g11.3)')
     *         'Error in tanh - sinh/cosh              =',
     *         DMXDIF(NP1,X(1,5),1, X(1,9),1)
  500 continue
      end
c     ==================================================================
      double precision function DMXDIF(N,X,INCX, Y,INCY)
c
c     Compute max norm of difference between the N-vectors x and y.
c     The vectors are stored with a storage increment of INCX and INCY
c     between successive components.
c     C. L. Lawson, JPL, Sept 1987.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      integer I, INCX, INCY, IX, IY, N
      double precision X(*), Y(*), ZERO, TEMP
      parameter(ZERO = 0.0d0)
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      TEMP = ZERO
      IX = 1 - INCX
      IY = 1 - INCY
      do 10 I = 1,N
         IX = IX + INCX
         IY = IY + INCY
         TEMP = max(TEMP, abs(X(IX) - Y(IY)))
   10 continue
      DMXDIF = TEMP
      return
      end


! { dg-do run }
! { dg-require-effective-target fortran_large_int }

module testmod
  integer,parameter :: k = selected_int_kind (range (0_8) + 1)
contains
  subroutine testoutput (a,b,length,f)
    integer(kind=k),intent(in) :: a
    integer(kind=8),intent(in) ::  b
    integer,intent(in) :: length
    character(len=*),intent(in) :: f

    character(len=length) :: ca
    character(len=length) :: cb

    write (ca,f) a
    write (cb,f) b
    if (ca /= cb) call abort
  end subroutine testoutput
end module testmod

! Testing I/O of large integer kinds (larger than kind=8)
program test
  use testmod
  implicit none

  integer(kind=k) :: x
  character(len=50) :: c1, c2

  call testoutput (0_k,0_8,50,'(I50)')
  call testoutput (1_k,1_8,50,'(I50)')
  call testoutput (-1_k,-1_8,50,'(I50)')
  x = huge(0_8)
  call testoutput (x,huge(0_8),50,'(I50)')
  x = -huge(0_8)
  call testoutput (x,-huge(0_8),50,'(I50)')
end program test


program main
  implicit none
  real(8),parameter :: pi = 4d0*atan(1d0)
  complex(8),parameter :: zI = (0d0,1d0)
  integer,parameter :: Nt = 6000, Nw = 500
  real(8),parameter :: wi = 0.1d0/27.211d0, wf = 20d0/27.211d0, dw = (wf-wi)/Nw
  real(8) :: tt(0:Nt),Act(0:Nt),jt(0:Nt)
  real(8) :: dt,ww,xx,ff
  integer :: it,iw
  complex(8) :: zAw,zEw,zJw,zsigma,zeps
  real(8) :: kick_impulsive

  kick_impulsive = 1d-4

  do it = 0,Nt
    read(*,*)tt(it),Act(it),jt(it)
  end do
  dt = tt(1) - tt(0)
  jt(0) = jt(0)*0.5d0

  open(21,file="zeps.out")
  do iw = 0,Nw
    ww = wi + dw*iw
    zAw = 0d0; zJw = 0d0
    do it = 0,Nt
      xx = (tt(it)-tt(0))/(tt(Nt) - tt(0))
      ff = 1d0 -3d0 * xx**2 + 2d0*xx**3
      zAw = zAw + exp(zI*ww*tt(it)) *Act(it)
      zjw = zjw + exp(zI*ww*tt(it)) *jt(it)*ff
    end do
    zEw = -(-zI*ww)*zAw*dt
    zJw = - zJw*dt
!    zsigma = zJw/zEw
    zsigma = zJw/kick_impulsive
    zeps = 1d0 + 4d0*pi*zi*zsigma/ww

    write(21,"(999e26.16e3)")ww,zeps,zsigma

  end do

  close(21)

end program main


SUBROUTINE eq1_wu(upstream)
!Till: computationally irrelevant: outcommented unused vars
!2012-09-14

!Till: computationally irrelevant: minor changes to improve compiler compatibility
!2011-04-29

! Code converted using TO_F90 by Alan Miller
! Date: 2005-08-23  Time: 12:57:31

use common_h
use time_h
use reservoir_h

IMPLICIT NONE

INTEGER, INTENT(IN OUT)                  :: upstream
INTEGER :: j,g,h !i,id,ih,irout,imun,dummy1,,factor_sed
real:: dummy2

real :: manning_sed,shear_bed,shear_sec,d50 !,accum1,accum2
real :: hidp(n_sed_class),expp(n_sed_class),hidexp(n_sed_class)
real :: wat_dens,sed_dens,shield,crshear(n_sed_class)
real :: visc !,perc_bed(n_sed_class),perc_susp(n_sed_class)
real :: transpfac_bed(n_sed_class),transpfac_susp(n_sed_class)

!Ge to include the DAILY mean temperature of the reservoir (celsius degree)
!Ge tempres=20 C (temporarily)
REAL :: tempres(step,upstream)

real :: discharge(200),depth(200),hydrad(200),energslope(200)
real :: manning(200),topwidth(200),meanvel(200)

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

do j=1,nbrsec(upstream)
 if (j /= nbrsec(upstream)) then
    discharge(j)=(discharge_sec(j,upstream)+discharge_sec(j+1,upstream))/2.
    depth(j)=(depth_sec(j,upstream)+depth_sec(j+1,upstream))/2.
    hydrad(j)=(hydrad_sec(j,upstream)+hydrad_sec(j+1,upstream))/2.
    energslope(j)=(energslope_sec(j,upstream)+energslope_sec(j+1,upstream))/2.
    manning(j)=(manning_sec(j,upstream)+manning_sec(j+1,upstream))/2.
    topwidth(j)=(topwidth_sec(j,upstream)+topwidth_sec(j+1,upstream))/2.
    meanvel(j)=(meanvel_sec(j,upstream)+meanvel_sec(j+1,upstream))/2.
 else
    discharge(j)=discharge_sec(j,upstream)
    depth(j)=depth_sec(j,upstream)
    hydrad(j)=hydrad_sec(j,upstream)
    energslope(j)=energslope_sec(j,upstream)
    manning(j)=manning_sec(j,upstream)
    topwidth(j)=topwidth_sec(j,upstream)
    meanvel(j)=meanvel_sec(j,upstream)
 endif
enddo

! loop to calculate the sediment carrying capacity
DO j=1,nbrsec(upstream)

 if (discharge(j) /= 0.) then

!Ge mean diameter is calculated using the grain size distribution
  dummy2=d50_actlay(j,upstream)

! 1) BED LOAD FORMULA

! Gravitacional acceleration (m/s2)
! 9.807

! density of water and density of natural sediments (kg/m3)
  wat_dens=1.*1000.
  sed_dens=2.65*1000.

! bed shear stress (N/m2)
  shear_bed=9.807*wat_dens*depth(j)* energslope(j)

! shear stress on the entire cross section (N/m2)
  shear_sec=9.807*wat_dens*hydrad(j)* energslope(j)

! hiding probability (-)
! exposure probability (-)
  DO g=1,n_sed_class
    hidp(g)=0.
	expp(g)=0.
    DO h=1,n_sed_class
      IF (frac_actlay(g,j,upstream) /= 0.) THEN
        hidp(g)=hidp(g)+frac_actlay(h,j,upstream)* (diam(h)/(diam(g)+diam(h)))
        expp(g)=expp(g)+frac_actlay(h,j,upstream)* (diam(g)/(diam(g)+diam(h)))
      ELSE
        hidp(g)=1.
        expp(g)=1.
      END IF
    END DO
  END DO

! critical Shields parameter (-)
! 0.03 according to Wu et al.
  shield=0.03

! loop to calculate the sediment carrying capacity for bed load
  DO g=1,n_sed_class
    if(dummy2==0.) then
	  d50=diam(g)
	else
	  d50=dummy2
	endif

! Manning's roughness related to grains (s/(m**1/3))
    manning_sed=(d50**(1./6.))/20.

! hiding/exposure factor (-)
    hidexp(g)=(expp(g)/hidp(g))**(-0.6)

! critical shear stress (N/m2)
    crshear(g)=(sed_dens-wat_dens)*9.807*diam(g)*shield*hidexp(g)

! dimensionless transport parameter for fractional bed load yields (-)
    if ((((manning_sed/manning(j))**(3./2.))*shear_bed/crshear(g))-1. <= 0.) then
	  transpfac_bed(g)=0.
	else
      transpfac_bed(g)=0.0053*((((manning_sed/manning(j))  &
        **(3./2.))*shear_bed/crshear(g))-1.)**2.2
    endif
!    transpfac_bed(g)=MAX(0.,transpfac_bed(g))

! fractional bed sediment transport (m2/s)
    bed_frtransp(g,j)=transpfac_bed(g)*  &
        SQRT((sed_dens-wat_dens)/wat_dens*9.807*(diam(g)**3.))

! fractional bed sediment transport (m3/day)
    bed_frtransp(g,j)=86400.*bed_frtransp(g,j)*topwidth(j)

!write(*,'(3I4,6F10.6)')d,j,g,d50,manning_sed,hidexp(g),shear_bed,crshear(g),transpfac_bed(g)
  END DO

! 2) SUSPENDED LOAD FORMULA

!Ge to include the DAILY mean temperature of the reservoir (celsius degree)
!Ge tempres=20 C (temporarily)
  tempres(step,upstream)=20.

! kinematic viscosity (m2/s)
  visc=(1.14-0.031*(tempres(step,upstream)-15.)+  &
      0.00068*((tempres(step,upstream)-15.)**2.))*1.e-6

! loop to calculate the sediment carrying capacity for suspended load
  DO g=1,n_sed_class

! settling velocity (m/s)
    setvel(g)=SQRT((13.95*visc/diam(g))**2.+1.09*  &
        ((sed_dens-wat_dens)/wat_dens)*9.807*diam(g))-13.95*visc/diam(g)

! the fractional transport parameter for suspended sediment transport (-)
    if ((shear_sec/crshear(g))-1. <= 0.) then
	  transpfac_susp(g)=0.
	else
      transpfac_susp(g)=0.0000262*(((shear_sec/crshear(g))-1.)*  &
        meanvel(j)/setvel(g))**1.74
    endif

!    transpfac_susp(g)=MAX(0.,transpfac_susp(g))

! total suspended sediment transport (m2/s)
    susp_frtransp(g,j)=transpfac_susp(g)*  &
        SQRT((sed_dens-wat_dens)/wat_dens*9.807*(diam(g)**3.))

! total suspended sediment transport (m3/day)
!    susp_frtransp(g,j)=min(susp_frtransp(g,j),1000.)
    susp_frtransp(g,j)=86400.*susp_frtransp(g,j)*topwidth(j)

  END DO

! loop to calculate the fractional carrying capacity for total load (m3/day)
  DO g=1,n_sed_class
    fr_capacity(g,j)=susp_frtransp(g,j)+bed_frtransp(g,j)
  END DO

 else
  DO g=1,n_sed_class
    fr_capacity(g,j)=0.
  enddo
 endif

 DO g=1,n_sed_class
!write(*,'(3I4,3F20.5)')d,j,g,fr_capacity(g,j),susp_frtransp(g,j),bed_frtransp(g,j)
 END DO

!if (d==54)read(*,*)
END DO

RETURN
END SUBROUTINE eq1_wu


!     Last change:  HO   31 May 2000    4:42 am
!==============================================================================
MODULE fft_module
IMPLICIT NONE
PRIVATE
PUBLIC :: fft_window
INTEGER, PARAMETER :: np2 = 10, nn = 2**np2, nn_2 = nn / 2 ! 2^10 = 1024
INTEGER :: indx(nn)
REAL    (KIND = 8) :: pi, pi2, pi2_n, hann_window(nn)
COMPLEX (KIND = 8) :: omega(0:nn - 1)
CONTAINS
!--------------------------------------------------------------------------
SUBROUTINE fft_initialize()
IMPLICIT NONE
INTEGER :: i, j2, k, n
pi  = 4.0d0 * ATAN(1.0d0)
pi2 = 2.0d0 * pi
pi2_n = pi2 / REAL(nn, KIND = 8)
DO i = 1, nn
 omega(i - 1)   =     EXP( CMPLX(0.0d0, pi2_n * REAL(i - 1, KIND = 8), KIND = 8) )
 hann_window(i) = 0.5d0 * ( 1.0d0 - COS(pi2_n * REAL(i - 1, KIND = 8)          ) )
END DO
!
DO i = 1, nn
 n = 0
 k = i - 1
 DO j2 = np2 - 1, 0, -1
  n = n + MOD(k, 2) * 2**j2
  k = k / 2
 END DO
 indx(i) = n + 1 ! indx = 1..N
END DO
RETURN
END SUBROUTINE fft_initialize
!--------------------------------------------------------------------------
SUBROUTINE fft_window(x, y)
IMPLICIT NONE
REAL    (KIND = 8), INTENT(IN ) :: x(:)
COMPLEX (KIND = 8), INTENT(OUT) :: y(:)
LOGICAL :: qfirst = .TRUE.
IF (qfirst) THEN
 qfirst = .FALSE.
 CALL fft_initialize()
END IF
y = hann_window * x
CALL fft2(y)
RETURN
END SUBROUTINE fft_window
!--------------------------------------------------------------------------
SUBROUTINE fft2(fft)
IMPLICIT NONE
COMPLEX (KIND = 8), INTENT(IN OUT) :: fft(:)
COMPLEX (KIND = 8) :: tmp1, tmp2, c1
INTEGER :: i, j, k2, m1, m2, iphase, kn2
fft = fft(indx)
! FFT_2
DO k2 = 1, np2
 kn2 = 2**(k2 - 1)
 DO i = 1, nn, 2* kn2
  DO j = 1, kn2
   iphase = 2**(np2 - k2)*(j - 1)
   c1 = omega( MOD(iphase, nn) )
   m1 = i + j - 1
   m2 = m1 + kn2
   tmp1 =      fft(m1)
   tmp2 = c1 * fft(m2)
   fft(m1) = tmp1 + tmp2 ! 1 = x^2 ; x = 1 or -1
   fft(m2) = tmp1 - tmp2
  END DO
 END DO
END DO
RETURN
END SUBROUTINE fft2
!------------------------------------------------------------------------
END MODULE fft_module
!==========================================================================
MODULE psycho
IMPLICIT NONE
PRIVATE
PUBLIC :: psychoacoustics
CONTAINS
!------------------------------------------------------------------------
SUBROUTINE psychoacoustics(pcm, smr, isample_rate)
USE fft_module
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN ) :: pcm(:, :)
REAL (KIND = 8), INTENT(OUT) :: smr(:, :)
INTEGER        , INTENT(IN ) :: isample_rate
COMPLEX (KIND = 8) :: cfft(1024)
REAL    (KIND = 8) :: signal(32), xmask(32)
REAL    (KIND = 8), SAVE :: abs_thres(1024)
INTEGER :: ichannel, isubband, i0, i1
LOGICAL, SAVE :: qfirst = .TRUE.
IF (qfirst) THEN
 qfirst = .FALSE.
 CALL init_absolute_threshold(abs_thres, isample_rate)
END IF
i0 = (SIZE(pcm, 1) - 512) / 2 + 1
i1 = i0 + 1024 - 1
DO ichannel = 1, SIZE(pcm, 2)
 CALL fft_window(pcm(i0:i1, ichannel), cfft)
 CALL calc_signal(cfft, signal)
 CALL calc_mask  (abs_thres, xmask)
 DO isubband = 1, 32
  smr(isubband, ichannel) = signal(isubband) - xmask(isubband)
 END DO
END DO
RETURN
END SUBROUTINE psychoacoustics
!------------------------------------------------------------------------
SUBROUTINE init_absolute_threshold(abs_thres, isample_rate)
IMPLICIT NONE
REAL (KIND = 8), INTENT(OUT) :: abs_thres(:) ! in the unit of dB
INTEGER        , INTENT(IN ) :: isample_rate
REAL (KIND = 8) :: freq
INTEGER :: i
DO i = 1, SIZE(abs_thres)
 freq = REAL(isample_rate, KIND = 8) / 2.0d0 / 1000.0d0 &
      * REAL(i - 0.5d0, KIND = 8) / REAL(SIZE(abs_thres) - 1, KIND = 8)
 abs_thres(i) = 3.64d0 * freq**(-0.8d0) - 6.5d0 * EXP(-0.6d0 * (freq - 3.3d0)**2.0d0) &
              + 0.001d0 * freq**4.0d0
END DO
RETURN
END SUBROUTINE init_absolute_threshold
!------------------------------------------------------------------------
SUBROUTINE calc_signal(cfft, signal)
IMPLICIT NONE
COMPLEX (KIND = 8), INTENT(IN ) :: cfft(:)
REAL    (KIND = 8), INTENT(OUT) :: signal(:)
REAL    (KIND = 8) :: tmp
INTEGER :: iband, j
DO iband =  1, 12
 tmp = 100
 DO j = 1, 32
  tmp = MIN( tmp, decibel(cfft( (iband - 1) * 32 + j)) )
 END DO
 signal(iband) = tmp
END DO
DO iband = 13, 32
 tmp = 0.0d0
 DO j = 1, 32
  tmp = tmp + decibel(cfft( (iband - 1) * 32 + j))
 END DO
 signal(iband) = tmp / 32.0d0
END DO
RETURN
END SUBROUTINE calc_signal
!------------------------------------------------------------------------
FUNCTION decibel(x) RESULT(res)
IMPLICIT NONE
COMPLEX (KIND = 8), INTENT(IN) :: x
REAL    (KIND = 8) :: res, tmp
tmp = MAX(1.0d-20, ABS(x))
res = 20.0d0 * LOG10(tmp)
RETURN
END FUNCTION decibel
!------------------------------------------------------------------------
SUBROUTINE calc_mask(abs_thres, xmask)
IMPLICIT NONE
REAL (KIND = 8), INTENT(IN ) :: abs_thres(:)
REAL (KIND = 8), INTENT(OUT) :: xmask(:)
REAL (KIND = 8) :: temp(1)
INTEGER :: iband
DO iband =  1, 12
 temp = MINVAL( abs_thres( (iband - 1) * 32 + 1: iband * 32) )
 xmask(iband) = temp(1)
END DO
DO iband = 13, 32
 xmask(iband) = SUM( abs_thres( (iband - 1) * 32 + 1: iband * 32) ) / 32.0d0
END DO
! Enoken (|O.O|)
xmask = xmask - 114.0d0
!xmask(:11) = xmask(:11) - 50.0d0
!xmask(25:) = xmask(25:) + 100.0d0
!
RETURN
END SUBROUTINE calc_mask
!------------------------------------------------------------------------
END MODULE psycho