!**********************************************************************
!     matmult.f90 - simple matrix multiply implementation
!************************************************************************

program main
  implicit none

  include 'mpif.h'

  integer, parameter :: MATSIZE = 1000
  integer, parameter :: MASTER = 0

  real(kind=8), dimension(:,:),ALLOCATABLE :: a,b,c
  real(kind=8), dimension(:), ALLOCATABLE :: buffer, answer

  integer :: myid, maxpe, ierr, provided
  integer, dimension(MPI_STATUS_SIZE) :: stat

  integer :: i, j, numsent, sender
  integer :: answertype, row, flag
  integer :: nthreads, tid, omp_get_num_threads, omp_get_thread_num

  continue

  allocate(a(MATSIZE,MATSIZE),b(MATSIZE,MATSIZE),c(MATSIZE,MATSIZE))
  allocate(buffer(MATSIZE),answer(MATSIZE))

  call MPI_Init_thread(MPI_THREAD_FUNNELED, provided, ierr)
  call MPI_Comm_rank(MPI_COMM_WORLD, myid, ierr)
  call MPI_Comm_size(MPI_COMM_WORLD, maxpe, ierr)
  write(*,'("Process ",I0," of ",I0," is active")') myid, maxpe

  !$omp parallel private(tid,nthreads) default(shared)
  tid = omp_get_thread_num()
  write(*,'("hello world from thread ",I0)') tid
  if (tid == 0) then
    nthreads = omp_get_num_threads()
    write(*, '("number of threads = ",I0)') nthreads
  end if
  !$omp end parallel

  if ( myid == master ) then
    ! master initializes and then dispatches
    ! initialize a and b
    call initialize(MATSIZE, a, b)
    numsent = 0

    ! send b to each other process
    do i = 1,MATSIZE
      call MPI_Bcast(b(1,i), MATSIZE, MPI_DOUBLE_PRECISION, master, &
                     MPI_COMM_WORLD, ierr)
    end do

    ! send a row of a to each other process; tag with row number
    do i = 1,maxpe-1
      do j = 1,MATSIZE
        buffer(j) = a(i,j)
      end do
      call MPI_Send(buffer, MATSIZE, MPI_DOUBLE_PRECISION, i, i, &
                    MPI_COMM_WORLD, ierr)
      numsent = numsent+1
    end do

    do i = 1,MATSIZE
      call MPI_Recv(answer, MATSIZE, MPI_DOUBLE_PRECISION, &
                    MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, &
                    stat, ierr)
      sender = stat(MPI_SOURCE)
      answertype = stat(MPI_TAG)
      c(answertype,:) = answer(:)

      if (numsent < MATSIZE) then
        buffer(:) = a(numsent+1,:)
        call MPI_Send(buffer, MATSIZE, MPI_DOUBLE_PRECISION, sender, &
                      numsent+1, MPI_COMM_WORLD, ierr)
        numsent = numsent+1
      else
        call MPI_Send(1.0, 1, MPI_DOUBLE_PRECISION, sender, 0, &
                      MPI_COMM_WORLD, ierr)
      endif
    end do

    ! print out one element of the answer
    write(*, '("c(",I0,",",I0,") = ",ES24.14)') MATSIZE, MATSIZE, c(MATSIZE,MATSIZE)
  else
    ! workers receive B, then compute rows of C until done message
    do i = 1,MATSIZE
      call MPI_Bcast(b(1,i), MATSIZE, MPI_DOUBLE_PRECISION, master, &
                     MPI_COMM_WORLD, ierr)
    end do
    flag = 1
    do while (flag /= 0)
      call MPI_Recv(buffer, MATSIZE, MPI_DOUBLE_PRECISION, master,  &
                    MPI_ANY_TAG, MPI_COMM_WORLD, stat, ierr)
      row = stat(MPI_TAG)
      flag = row
      if (flag /= 0) then
        ! multiply the matrices here using C(i,j) += sum (A(i,k)* B(k,j))
        call multiply_matrices(MATSIZE, answer, buffer, b)
        call MPI_Send(answer, MATSIZE, MPI_DOUBLE_PRECISION, master, &
                      row, MPI_COMM_WORLD, ierr)
      endif
    end do
  endif

  call MPI_FINALIZE(ierr)

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

  subroutine initialize(n, a, b)
    implicit none
    integer, intent(in) :: n
    real(kind=8), dimension(n,n), intent(out) :: a, b
    integer :: i, j

    !$omp parallel private(i,j) default(shared)
    !$omp do
    do i = 1,n
      do j = 1,n
        a(j,i) = i
      end do
    end do
    !$omp end do nowait
    !$omp do
    do i = 1,n
      do j = 1,n
        b(j,i) = i
      end do
    end do
    !$omp end do nowait
    !$omp end parallel
  end subroutine initialize

  subroutine multiply_matrices(n, answer, buffer, b)
    implicit none
    integer, intent(in) :: n
    real(kind=8), dimension(n), intent(inout) :: answer
    real(kind=8), dimension(n), intent(in) :: buffer
    real(kind=8), dimension(n,n) :: b
    integer :: i, j

    !$omp parallel do private(i,j) default(shared)
    do i=1,n
      answer(i) = 0
      do j=1,MATSIZE
        answer(i) = answer(i) + buffer(j)*b(j,i)
      end do
    end do
    !$omp end parallel do
  end subroutine multiply_matrices

end program main


! Define Pauli matrix.
! Define the operations on Pauli matrix or use the library for manipulation of matrix
! update. Give them a name space. sigma is repeated. sigma[3]
PROGRAM PauliMatrix

  IMPLICIT NONE

  INTEGER, DIMENSION(1:2,1:2):: sigma_1, sigma_3
  COMPLEX, DIMENSION(1:2,1:2):: sigma_2
  INTEGER :: i, j

  sigma_1 = RESHAPE ((/ 0, 1, 1, 0 /), (/ 2, 2 /))
  sigma_2 = RESHAPE ((/ (0,0), (0,-1), (0,1), (0,0)/), (/ 2, 2 /))
  sigma_3 = RESHAPE ((/ 1, 0, 0, -1 /), (/ 2, 2 /))
  WRITE (*,*) "Fortran array is column-contigious"
  DO i = 1,2
    PRINT *, LOC(sigma_3(1, i))
  END DO
  WRITE (*,*) sigma_2
END PROGRAM PauliMatrix


program main
    implicit none
    integer :: i
    integer :: acum
    integer :: max

    max = 1000

    acum = 0

    do i = 3, max - 1
        if ((mod(i, 3) == 0) .or. (mod(i, 5) == 0)) then
            acum = acum + i
        end if
    end do

    print *, acum

end program main


!*******************************************************
!* Given an array A of N numbers, returns their median *
!* value XMED. In this version, the input array A is   *
!* not destroyed.                                       *
!*******************************************************
SUBROUTINE NMEDIAN(a,N,XMED)
  real a(N)
  real(4),   allocatable :: X(:)
  allocate (x(N))
  X = a
  call hpsort(N,X)
  N2=N/2
  if (2*N2.eq.N) then
    XMED = 0.5*(X(N2)+X(N2+1))
  else
    XMED = X(N2+1)
  endif
  deallocate(X)
  return
END

!*****************************************************
!*  Sorts an array RA of length N in ascending order *
!*                by the Heapsort method             *
!* ------------------------------------------------- *
!* INPUTS:                                           *
!*          N     size of table RA                       *
!*      RA        table to be sorted                     *
!* OUTPUT:                                           *
!*          RA    table sorted in ascending order        *
!*                                                   *
!* NOTE: The Heapsort method is a N Log2 N routine,  *
!*       and can be used for very large arrays.      *
!*****************************************************
SUBROUTINE HPSORT(N,RA)
  real RA(N)
  L=N/2+1
  IR=N
  !The index L will be decremented from its initial value during the
  !"hiring" (heap creation) phase. Once it reaches 1, the index IR
  !will be decremented from its initial value down to 1 during the
  !"retirement-and-promotion" (heap selection) phase.
10 continue
  if(L > 1)then
    L=L-1
    RRA=RA(L)
  else
    RRA=RA(IR)
    RA(IR)=RA(1)
    IR=IR-1
    if(IR.eq.1)then
      RA(1)=RRA
      return
    end if
  end if
  I=L
  J=L+L
20 if(J.le.IR)then
  if(J < IR)then
    if(RA(J) < RA(J+1))  J=J+1
  end if
  if(RRA < RA(J))then
    RA(I)=RA(J)
    I=J; J=J+J
  else
    J=IR+1
  end if
  goto 20
  end if
  RA(I)=RRA
  goto 10
END


module matrix_utils_m
use constants_m
implicit none

contains

subroutine matrix_inv(mat,inv)
  real(rp),dimension(:,:),intent(in)::mat
  real(rp),dimension(:,:),intent(out)::inv
  real(rp)::det
  integer::m,n

  m=size(mat,1)
  n=size(mat,2)

  if(.not.(m==n.and.(m==2.or.m==3)))then
    return
  end if

  select case(m)
  case(2)
    det=mat(1,1)*mat(2,2)-mat(1,2)*mat(2,1)
  case(3)
    det=(mat(2,2)*mat(3,3)-mat(2,3)*mat(3,2))*mat(1,1)
    det=det+(mat(2,3)*mat(3,1)-mat(2,1)*mat(3,3))*mat(1,2)
    det=det+(mat(2,1)*mat(3,2)-mat(2,2)*mat(3,1))*mat(1,3)
  end select

  if(abs(det) < small)then
    inv = zero
    return
  end if

  select case(m)
  case(2)
    inv(1,1)= mat(2,2)
    inv(1,2)=-mat(1,2)
    inv(2,1)=-mat(2,1)
    inv(2,2)= mat(1,1)
  case(3)
    inv(1,1)=mat(2,2)*mat(3,3)-mat(2,3)*mat(3,2)
    inv(2,1)=mat(2,3)*mat(3,1)-mat(2,1)*mat(3,3)
    inv(3,1)=mat(2,1)*mat(3,2)-mat(2,2)*mat(3,1)
    inv(1,2)=mat(3,2)*mat(1,3)-mat(3,3)*mat(1,2)
    inv(2,2)=mat(3,3)*mat(1,1)-mat(3,1)*mat(1,3)
    inv(3,2)=mat(3,1)*mat(1,2)-mat(3,2)*mat(1,1)
    inv(1,3)=mat(1,2)*mat(2,3)-mat(1,3)*mat(2,2)
    inv(2,3)=mat(1,3)*mat(2,1)-mat(1,1)*mat(2,3)
    inv(3,3)=mat(1,1)*mat(2,2)-mat(1,2)*mat(2,1)
  end select

  inv=inv/det
end subroutine

function csr_index(i,j,ja,ia) result(kij)
  integer,intent(in)::i,j
  integer,dimension(:),intent(in)::ja,ia
  integer::kij

  do kij=ia(i),ia(i+1)-1
    select case(ja(kij)-j)
    case(0)
      return
    end select
  end do

  kij=-1
end function

subroutine csr_matvec_prod(a_ij,phi,ja,ia,res)
  integer,dimension(:)::ja,ia
  real(rp),dimension(:)::a_ij
  real(rp),dimension(:)::phi

  real(rp),dimension(:),intent(inout)::res
  integer::i,k,n
  n=size(ia)-1

  do i=1,n
    res(i)=zero
    do k=ia(i),ia(i+1)-1
      res(i)=res(i)+a_ij(k)*phi(ja(k))
    end do
  end do
end subroutine

function csr_diag(a_ij,ja,ia) result(diag)
  integer,dimension(:)::ja,ia
  real(rp),dimension(:)::a_ij

  real(rp),dimension(size(ia)-1)::diag
  integer::i,kii,n
  n=size(ia)-1

!$AD II-LOOP
  do i=1,n
    kii=csr_index(i,i,ja,ia)
    diag(i)=a_ij(kii)
  end do
end function

subroutine csr_transpose(a_ij,ja,ia,at_ij)
  integer,dimension(:)::ja,ia
  real(rp),dimension(:)::a_ij,at_ij
  integer::i,kij,j,kji,n
  n=size(ia)-1

  do i=1,n
    do kij=ia(i),ia(i+1)-1
      j=ja(kij)
      kji=csr_index(j,i,ja,ia)
      at_ij(kji)=a_ij(kij)
    end do
  end do
end subroutine

subroutine csr_to_csc(ja,ia,jao,iao,a,ao)
  integer,dimension(:)::ia,iao,ja,jao
  real(rp),dimension(:),optional::a,ao

  integer i,j,k,n,next,ipos

  n=size(ia)-1
  iao = 0

  do i=1, n
    do k=ia(i), ia(i+1)-1
      j = ja(k)+1
      iao(j) = iao(j)+1
    end do
  end do

  iao(1) = 1
  do i=1,n
    iao(i+1) = iao(i) + iao(i+1)
  end do

  do i=1,n
    do k=ia(i),ia(i+1)-1
      j = ja(k)
      next = iao(j)
      if(present(a).and.present(ao))then
        ao(next) = a(k)
      end if
      jao(next) = i
      iao(j) = next+1
    end do
  end do

  do i=n,1,-1
    iao(i+1) = iao(i)
  end do
  iao(1) = 1
end subroutine
end module


!  ********************************************************************
!  *                                                                  *
!  *                          function gmdst                          *
!  *                                                                  *
!  ********************************************************************
!  Single Precision Version 2.0
!  Written by Press etal., Numerical Recipes with some modifications
!  by Gordon A. Fenton, TUNS, 1994
!  Latest Update: May 9, 1994
!
!  PURPOSE  returns the Gamma distribution function for given x and parameters
!           alpha and beta.
!
!  This routine employs a series or partial fraction solution to compute
!  the cumulative probability associated with a variable following the
!  Gamma distribution,
!
!                   1       x
!     F(x) =   ---------  INT exp{-t/b}*t**(a-1) dt
!              G(a)*b**a    0
!
!  where G(.) is the Gamma function (G(a) = (a-1)! if `a' is an integer).
!  When b = 1, this is the incomplete Gamma function. When b = 2 and a = k/2,
!  this is the Chi-squared distribution with k degrees of freedom.
!  This routine is derived from Press etal. in "Numerical Recipes",
!  2nd Edition, pg. 218.
!  Arguments to the routine are as follows;
!
!     x   real value giving the position at which the cumulative distribution
!         is desired. (input)
!
!     a   the alpha parameter of the Gamma distribution (a > 0). (input)
!
!     b   the beta parameter of the Gamma distribution (b > 0). (input)
!---------------------------------------------------------------------------
      real function gmdst( x, a, b )
      parameter (ITMAX = 400)
      data zero/0.0/, one/1.0/, two/2.0/, tol/1.e-6/, small/1.e-24/

   1  format(a)
!-------------------------------- start executable statements ------------

      if( (x .le. zero) .or. (a .le. zero) .or. (b .lt. zero) ) then
         gmdst = zero
         return
      endif

      xb = x/b
      gl = gamln(a)
      ta = exp(a*alog(xb) - xb - gl)
      if( xb .lt. (a + one) ) then
!						use series representation
         ap = a
         d  = one/a
         s  = d
         do 10 i = 1, ITMAX
            ap = ap + one
            d  = d*xb/ap
            s  = s + d
            if( d .lt. s*tol ) then
               gmdst = s*ta
               return
            endif
  10     continue
      else
!						use continued fraction rep.
         ap = xb + one - a
         c  = one/small
         d  = one/ap
         h  = d
         do 20 i = 1, ITMAX
            an = -float(i)*(float(i) - a)
            ap = ap + two
            d  = an*d + ap
            if( abs(d) .lt. small ) d = small
            c  = ap + an/c
            if( abs(c) .lt. small ) c = small
            d  = one/d
            e  = d*c
            h  = h*e
            if( abs(e-one) .lt. tol ) then
               gmdst = one - h*ta
               return
            endif
  20     continue
      endif

      write(6,1)'Gamma Distribution (gmdst) unable to converge.'
      gmdst = zero
      return
      end


!=======================================================================
! Created by
!     Keurfon Luu <keurfon.luu@mines-paristech.fr>
!     MINES ParisTech - Centre de Géosciences
!     PSL - Research University
!=======================================================================

program example_cluster2d

  use forlab, only: IPRE, RPRE, rng, chol, randn, repmat, vertcat, savetxt, &
                    mean, num2str, zeros, gmm, kmeans, mbkmeans, &
                    silhouette, dbindex

  implicit none

  integer(kind = IPRE) :: i, j, k, itermax, kmax
  integer(kind = IPRE), dimension(:), allocatable :: idx
  real(kind = RPRE) :: perc = 0.2
  real(kind = RPRE), dimension(:), allocatable :: x, y, mu, sil, db
  real(kind = RPRE), dimension(:,:), allocatable :: A, B, L, R, Sigma, means
  character(len = :), allocatable :: outdir, method

  ! Output directory
  outdir = "examples/cluster2d/"
  call system("mkdir -p " // outdir)

  ! Initialize random number generation
  call rng()

  ! Create 2D data
  print *, "Creating 2D data:"

  ! Cluster 1
  Sigma = reshape( [ 3., 0., 0., 0.5 ], [ 2, 2 ] )
  L = chol(Sigma)
  R = randn(2, 500)
  mu = [ 3., 3. ]
  B = transpose( matmul(L, R) + repmat(mu, size(R, 2)) )
  A = B

  ! Cluster 2
  Sigma = reshape( [ 1., 0., 0., 1. ], [ 2, 2 ] )
  L = chol(Sigma)
  R = randn(2, 400)
  mu = [ -3., 3. ]
  B = transpose( matmul(L, R) + repmat(mu, size(R, 2)) )
  A = vertcat(A, B)

  ! Cluster 3
  Sigma = reshape( [ 2., 0., 0., 1. ], [ 2, 2 ] )
  L = chol(Sigma)
  R = randn(2, 600)
  mu = [ 6., -3. ]
  B = transpose( matmul(L, R) + repmat(mu, size(R, 2)) )
  A = vertcat(A, B)

  ! Cluster 4
  Sigma = reshape( [ 1., 0., 0., 1.5 ], [ 2, 2 ])
  L = chol(Sigma)
  R = randn(2, 500)
  mu = [ 0., 0. ]
  B = transpose( matmul(L, R) + repmat(mu, size(R, 2)) )
  A = vertcat(A, B)

  call savetxt(outdir // "data.txt", A)
  print *, "Data saved in " // outdir

  ! Clustering
  k = 4
  itermax = 500
  method = "gmm"

  print *; print *, "Clustering using " // method // ":"
  select case(method)
  case("kmeans")
    idx = kmeans(A, k, means = means, itermax = itermax)
  case("mbkmeans")
    idx = mbkmeans(A, k, perc = perc, means = means, itermax = itermax)
  case("gmm")
    idx = gmm(A, k, means = means, itermax = itermax)
  end select

  call savetxt(outdir // "index.txt", idx)
  call savetxt(outdir // "means.txt", means)
  print *, "Clustering results saved in " // outdir

  ! Cluster analysis: compute several indices for different K
  kmax = 20
  sil = zeros(kmax)
  db = zeros(kmax)

  print *; print *, "Performing cluster analysis:"
  !$omp parallel do default(shared) private(idx, means)
  do i = 1, kmax
    idx = kmeans(A, i, means = means, itermax = itermax)
    sil(i) = mean(silhouette(A, idx))
    db(i) = dbindex(A, idx, means)
  end do
  !$end omp parallel do

  call savetxt(outdir // "silhouette.txt", sil)
  call savetxt(outdir // "db.txt", db)
  print *, "Cluster analysis results saved in " // outdir

  print *; print *, "Run script /utils/view_cluster2d.py to check results."

  print *

end program example_cluster2d


program test_linalg

  use stdlib_experimental_error, only: check
  use stdlib_experimental_kinds, only: sp, dp, qp, int8, int16, int32, int64
  use stdlib_experimental_linalg, only: diag, eye, trace

  implicit none

  real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
  real(dp), parameter :: dptol = 1000 * epsilon(1._dp)
  real(qp), parameter :: qptol = 1000 * epsilon(1._qp)

  logical :: warn

  ! whether calls to check issue a warning
  ! or stop execution
  warn = .false.

  !
  ! eye
  !
  call test_eye

  !
  ! diag
  !
  call test_diag_rsp
  call test_diag_rsp_k
  call test_diag_rdp
  call test_diag_rqp

  call test_diag_csp
  call test_diag_cdp
  call test_diag_cqp

  call test_diag_int8
  call test_diag_int16
  call test_diag_int32
  call test_diag_int64

  !
  ! trace
  !
  call test_trace_rsp
  call test_trace_rsp_nonsquare
  call test_trace_rdp
  call test_trace_rdp_nonsquare
  call test_trace_rqp

  call test_trace_csp
  call test_trace_cdp
  call test_trace_cqp

  call test_trace_int8
  call test_trace_int16
  call test_trace_int32
  call test_trace_int64

contains

  subroutine test_eye
    real(sp), allocatable :: rye(:,:)
    complex(sp) :: cye(7,7)
    integer :: i
    write(*,*) "test_eye"

    call check(all(eye(5) == diag([(1,i=1,5)])), &
          msg="all(eye(5) == diag([(1,i=1,5)] failed.",warn=warn)

    rye = eye(6)
    call check(sum(rye - diag([(1.0_sp,i=1,6)])) < sptol, &
          msg="sum(rye - diag([(1.0_sp,i=1,6)])) < sptol failed.",warn=warn)

    cye = eye(7)
    call check(abs(trace(cye) - cmplx(7.0_sp,0.0_sp,kind=sp)) < sptol, &
          msg="abs(trace(cye) - cmplx(7.0_sp,0.0_sp,kind=sp)) < sptol failed.",warn=warn)
  end subroutine

  subroutine test_diag_rsp
    integer, parameter :: n = 3
    real(sp) :: v(n), a(n,n), b(n,n)
    integer :: i,j
    write(*,*) "test_diag_rsp"
    v = [(i,i=1,n)]
    a = diag(v)
    b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n])
    call check(all(a == b), &
            msg="all(a == b) failed.",warn=warn)

    call check(all(diag(3*a) == 3*v), &
            msg="all(diag(3*a) == 3*v) failed.",warn=warn)
  end subroutine

  subroutine test_diag_rsp_k
    integer, parameter :: n = 4
    real(sp) :: a(n,n), b(n,n)
    integer :: i,j
    write(*,*) "test_diag_rsp_k"

    a = diag([(1._sp,i=1,n-1)],-1)

    b = reshape([((merge(1,0,i==j+1), i=1,n), j=1,n)], [n,n])

    call check(all(a == b), &
          msg="all(a == b) failed.",warn=warn)

    call check(sum(diag(a,-1)) - (n-1) < sptol, &
          msg="sum(diag(a,-1)) - (n-1) < sptol failed.",warn=warn)

    call check(all(a == transpose(diag([(1._sp,i=1,n-1)],1))), &
          msg="all(a == transpose(diag([(1._sp,i=1,n-1)],1))) failed",warn=warn)

    call random_number(a)
    do i = 1, n
      call check(size(diag(a,i)) == n-i, &
            msg="size(diag(a,i)) == n-i failed.",warn=warn)
    end do
    call check(size(diag(a,n+1)) == 0, &
        msg="size(diag(a,n+1)) == 0 failed.",warn=warn)
  end subroutine

  subroutine test_diag_rdp
    integer, parameter :: n = 3
    real(dp) :: v(n), a(n,n), b(n,n)
    integer :: i,j
    write(*,*) "test_diag_rdp"
    v = [(i,i=1,n)]
    a = diag(v)
    b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n])
    call check(all(a == b), &
            msg="all(a == b) failed.",warn=warn)

    call check(all(diag(3*a) == 3*v), &
            msg="all(diag(3*a) == 3*v) failed.",warn=warn)
  end subroutine

  subroutine test_diag_rqp
    integer, parameter :: n = 3
    real(qp) :: v(n), a(n,n), b(n,n)
    integer :: i,j
    write(*,*) "test_diag_rqp"
    v = [(i,i=1,n)]
    a = diag(v)
    b = reshape([((merge(i,0,i==j), i=1,n), j=1,n)], [n,n])
    call check(all(a == b), &
            msg="all(a == b) failed.", warn=warn)

    call check(all(diag(3*a) == 3*v), &
            msg="all(diag(3*a) == 3*v) failed.", warn=warn)
  end subroutine

  subroutine test_diag_csp
    integer, parameter :: n = 3
    complex(sp) :: a(n,n), b(n,n)
    complex(sp), parameter :: i_ = cmplx(0,1,kind=sp)
    integer :: i,j
    write(*,*) "test_diag_csp"
    a = diag([(i,i=1,n)]) + diag([(i_,i=1,n)])
    b = reshape([((merge(i + 1*i_,0*i_,i==j), i=1,n), j=1,n)], [n,n])
    call check(all(a == b), &
            msg="all(a == b) failed.",warn=warn)

    call check(all(abs(real(diag(a)) - [(i,i=1,n)]) < sptol), &
          msg="all(abs(real(diag(a)) - [(i,i=1,n)]) < sptol)", warn=warn)
    call check(all(abs(aimag(diag(a)) - [(1,i=1,n)]) < sptol), &
          msg="all(abs(aimag(diag(a)) - [(1,i=1,n)]) < sptol)", warn=warn)
  end subroutine

  subroutine test_diag_cdp
    integer, parameter :: n = 3
    complex(dp) :: a(n,n)
    complex(dp), parameter :: i_ = cmplx(0,1,kind=dp)
    write(*,*) "test_diag_cdp"
    a = diag([i_],-2) + diag([i_],2)
    call check(a(3,1) == i_ .and. a(1,3) == i_, &
          msg="a(3,1) == i_ .and. a(1,3) == i_ failed.",warn=warn)
  end subroutine

  subroutine test_diag_cqp
    integer, parameter :: n = 3
    complex(qp) :: a(n,n)
    complex(qp), parameter :: i_ = cmplx(0,1,kind=qp)
    write(*,*) "test_diag_cqp"
    a = diag([i_,i_],-1) + diag([i_,i_],1)
    call check(all(diag(a,-1) == i_) .and. all(diag(a,1) == i_), &
          msg="all(diag(a,-1) == i_) .and. all(diag(a,1) == i_) failed.",warn=warn)
  end subroutine

  subroutine test_diag_int8
    integer, parameter :: n = 3
    integer(int8), allocatable :: a(:,:)
    integer :: i
    logical, allocatable :: mask(:,:)
    write(*,*) "test_diag_int8"
    a = reshape([(i,i=1,n**2)],[n,n])
    mask = merge(.true.,.false.,eye(n) == 1)
    call check(all(diag(a) == pack(a,mask)), &
          msg="all(diag(a) == pack(a,mask)) failed.", warn=warn)
    call check(all(diag(diag(a)) == merge(a,0_int8,mask)), &
          msg="all(diag(diag(a)) == merge(a,0_int8,mask)) failed.", warn=warn)
  end subroutine
  subroutine test_diag_int16
    integer, parameter :: n = 4
    integer(int16), allocatable :: a(:,:)
    integer :: i
    logical, allocatable :: mask(:,:)
    write(*,*) "test_diag_int16"
    a = reshape([(i,i=1,n**2)],[n,n])
    mask = merge(.true.,.false.,eye(n) == 1)
    call check(all(diag(a) == pack(a,mask)), &
          msg="all(diag(a) == pack(a,mask))", warn=warn)
    call check(all(diag(diag(a)) == merge(a,0_int16,mask)), &
          msg="all(diag(diag(a)) == merge(a,0_int16,mask)) failed.", warn=warn)
  end subroutine
  subroutine test_diag_int32
    integer, parameter :: n = 3
    integer(int32) :: a(n,n)
    logical :: mask(n,n)
    integer :: i, j
    write(*,*) "test_diag_int32"
    mask = reshape([((merge(.true.,.false.,i==j+1), i=1,n), j=1,n)], [n,n])
    a = 0
    a = unpack([1_int32,1_int32],mask,a)
    call check(all(diag([1,1],-1) == a), &
          msg="all(diag([1,1],-1) == a) failed.", warn=warn)
    call check(all(diag([1,1],1) == transpose(a)), &
          msg="all(diag([1,1],1) == transpose(a)) failed.", warn=warn)
  end subroutine
  subroutine test_diag_int64
    integer, parameter :: n = 4
    integer(int64) :: a(n,n), c(0:2*n-1)
    logical :: mask(n,n)
    integer :: i, j

    write(*,*) "test_diag_int64"

    mask = reshape([((merge(.true.,.false.,i+1==j), i=1,n), j=1,n)], [n,n])
    a = 0
    a = unpack([1_int64,1_int64,1_int64],mask,a)

    call check(all(diag([1,1,1],1) == a), &
          msg="all(diag([1,1,1],1) == a) failed.", warn=warn)
    call check(all(diag([1,1,1],-1) == transpose(a)), &
          msg="all(diag([1,1,1],-1) == transpose(a)) failed.", warn=warn)

    ! Fill array c with Catalan numbers
    do i = 0, 2*n-1
      c(i) = catalan_number(i)
    end do
    ! Symmetric Hankel matrix filled with Catalan numbers (det(H) = 1)
    do i = 1, n
      do j = 1, n
        a(i,j) = c(i-1 + (j-1))
      end do
    end do
    call check(all(diag(a,-2) == diag(a,2)), &
          msg="all(diag(a,-2) == diag(a,2))", warn=warn)
  end subroutine

  subroutine test_trace_rsp
    integer, parameter :: n = 5
    real(sp) :: a(n,n)
    integer :: i
    write(*,*) "test_trace_rsp"
    a = reshape([(i,i=1,n**2)],[n,n])
    call check(abs(trace(a) - sum(diag(a))) < sptol, &
          msg="abs(trace(a) - sum(diag(a))) < sptol failed.",warn=warn)
  end subroutine

  subroutine test_trace_rsp_nonsquare
    integer, parameter :: n = 4
    real(sp) :: a(n,n+1), ans
    integer :: i
    write(*,*) "test_trace_rsp_nonsquare"

    ! 1   5   9  13  17
    ! 2   6  10  14  18
    ! 3   7  11  15  19
    ! 4   8  12  16  20
    a = reshape([(i,i=1,n*(n+1))],[n,n+1])
    ans = sum([1._sp,6._sp,11._sp,16._sp])

    call check(abs(trace(a) - ans) < sptol, &
          msg="abs(trace(a) - ans) < sptol failed.",warn=warn)
  end subroutine

  subroutine test_trace_rdp
    integer, parameter :: n = 4
    real(dp) :: a(n,n)
    integer :: i
    write(*,*) "test_trace_rdp"
    a = reshape([(i,i=1,n**2)],[n,n])
    call check(abs(trace(a) - sum(diag(a))) < dptol, &
          msg="abs(trace(a) - sum(diag(a))) < dptol failed.",warn=warn)
  end subroutine

  subroutine test_trace_rdp_nonsquare
    integer, parameter :: n = 4
    real(dp) :: a(n,n-1), ans
    integer :: i
    write(*,*) "test_trace_rdp_nonsquare"

    !  1   25   81
    !  4   36  100
    !  9   49  121
    ! 16   64  144
    a = reshape([(i**2,i=1,n*(n-1))],[n,n-1])
    ans = sum([1._dp,36._dp,121._dp])

    call check(abs(trace(a) - ans) < dptol, &
          msg="abs(trace(a) - ans) < dptol failed.",warn=warn)
  end subroutine

  subroutine test_trace_rqp
    integer, parameter :: n = 3
    real(qp) :: a(n,n)
    integer :: i
    write(*,*) "test_trace_rqp"
    a = reshape([(i,i=1,n**2)],[n,n])
    call check(abs(trace(a) - sum(diag(a))) < qptol, &
          msg="abs(trace(a) - sum(diag(a))) < qptol failed.",warn=warn)
  end subroutine

  subroutine test_trace_csp
    integer, parameter :: n = 5
    real(sp) :: re(n,n), im(n,n)
    complex(sp) :: a(n,n), b(n,n)
    complex(sp), parameter :: i_ = cmplx(0,1,kind=sp)
    write(*,*) "test_trace_csp"

    call random_number(re)
    call random_number(im)
    a = re + im*i_

    call random_number(re)
    call random_number(im)
    b = re + im*i_

    ! tr(A + B) = tr(A) + tr(B)
    call check(abs(trace(a+b) - (trace(a) + trace(b))) < sptol, &
          msg="abs(trace(a+b) - (trace(a) + trace(b))) < sptol failed.",warn=warn)
  end subroutine

  subroutine test_trace_cdp
    integer, parameter :: n = 3
    complex(dp) :: a(n,n), ans
    complex(dp), parameter :: i_ = cmplx(0,1,kind=dp)
    integer :: j
    write(*,*) "test_trace_cdp"

    a = reshape([(j + (n**2 - (j-1))*i_,j=1,n**2)],[n,n])
    ans = cmplx(15,15,kind=dp) !(1 + 5 + 9) + (9 + 5 + 1)i

    call check(abs(trace(a) - ans) < dptol, &
          msg="abs(trace(a) - ans) < dptol failed.",warn=warn)
  end subroutine

  subroutine test_trace_cqp
    integer, parameter :: n = 3
    complex(qp) :: a(n,n)
    complex(qp), parameter :: i_ = cmplx(0,1,kind=qp)
    write(*,*) "test_trace_cqp"
    a = 3*eye(n) + 4*eye(n)*i_ ! pythagorean triple
    call check(abs(trace(a)) - 3*5.0_qp < qptol, &
          msg="abs(trace(a)) - 3*5.0_qp < qptol failed.",warn=warn)
  end subroutine

  subroutine test_trace_int8
    integer, parameter :: n = 3
    integer(int8) :: a(n,n)
    integer :: i
    write(*,*) "test_trace_int8"
    a = reshape([(i**2,i=1,n**2)],[n,n])
    call check(trace(a) == (1 + 25 + 81), &
          msg="trace(a) == (1 + 25 + 81) failed.",warn=warn)
  end subroutine

  subroutine test_trace_int16
    integer, parameter :: n = 3
    integer(int16) :: a(n,n)
    integer :: i
    write(*,*) "test_trace_int16"
    a = reshape([(i**3,i=1,n**2)],[n,n])
    call check(trace(a) == (1 + 125 + 729), &
          msg="trace(a) == (1 + 125 + 729) failed.",warn=warn)
  end subroutine

  subroutine test_trace_int32
    integer, parameter :: n = 3
    integer(int32) :: a(n,n)
    integer :: i
    write(*,*) "test_trace_int32"
    a = reshape([(i**4,i=1,n**2)],[n,n])
    call check(trace(a) == (1 + 625 + 6561), &
          msg="trace(a) == (1 + 625 + 6561) failed.",warn=warn)
  end subroutine

  subroutine test_trace_int64
    integer, parameter :: n = 5
    integer, parameter :: nd = 2*n-1 ! number of diagonals
    integer :: i, j
    integer(int64) :: c(0:nd), H(n,n)
    write(*,*) "test_trace_int64"

    ! Fill array with Catalan numbers
    do i = 0, nd
      c(i) = catalan_number(i)
    end do

    ! Symmetric Hankel matrix filled with Catalan numbers (det(H) = 1)
    do i = 1, n
      do j = 1, n
        H(i,j) = c(i-1 + (j-1))
      end do
    end do

    call check(trace(h) == sum(c(0:nd:2)), &
          msg="trace(h) == sum(c(0:nd:2)) failed.",warn=warn)

  end subroutine

  pure recursive function catalan_number(n) result(value)
    integer, intent(in) :: n
    integer :: value
    integer :: i
    if (n <= 1) then
      value = 1
    else
      value = 0
      do i = 0, n-1
        value = value + catalan_number(i)*catalan_number(n-i-1)
      end do
    end if
  end function

end program


!
! Author: Amir H. T.
!
module patches
    implicit none
    private
    public  optimal_gridmap, gridmap

    type gridmap
        integer              :: n ! 0, 1, ...
        integer, allocatable :: c1(:,:), c2(:,:), cw(:,:)
        integer              :: nxt      , nyt
        integer, allocatable :: xticks(:), yticks(:)
    end type gridmap

    interface gridmap
        module procedure make_gridmap
    end interface

  contains

    !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    subroutine optimal_gridmap( rect, min_parts, ticks )
    ! solves division of a rectangle with rect(1)*rect(2)
    ! discrete grids into ticks(1)*ticks(2) (>= min_parts)
    ! regions so that the length of borders is minimal
    implicit none
    integer, intent(in)  :: rect(2), min_parts
    integer, intent(out) :: ticks(2)
    integer              :: q, qx, qy, nbx, nby,&
                            length, least
    ticks = [ min_parts, min_parts ]
    least = sum(rect)*min_parts
    do qx = 1, min_parts
        do qy = 1, min_parts
            q = qx*qy
            if( q>=min_parts .and. q-qx<min_parts .and. &
                           q-qy<min_parts .and. &
                       qx<=rect(1) .and. qy<=rect(2) ) then
               if( qx==1 ) then
                  nbx = 0
               else
                  nbx = qx
               end if
               if( qy==1 ) then
                  nby = 0
               else
                  nby = qy
               end if
               length = nbx*rect(2)+nby*rect(1)
               if( length<least ) then
                  least = length
                  ticks = [qx, qy]
               end if
            end if
        end do
    end do
    end subroutine optimal_gridmap

    !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    function make_gridmap( rect, q ) result(map)
    implicit none
    integer, intent(in) :: rect(2), q(2)
    type(gridmap)       :: map
    integer             :: w(2), r(2)
    integer             :: nx(q(1)), ny(q(2))
    integer             :: i,j, n, cx1, cx2, cy1, cy2
    map%n = q(1)*q(2)
    w = rect/q
    r = rect - q*w
    nx = w(1); nx(1:r(1)) = nx(1:r(1)) + 1
    ny = w(2); ny(1:r(2)) = ny(1:r(2)) + 1
    allocate(map%c1(2,0:map%n-1))
    allocate(map%c2(2,0:map%n-1))
    allocate(map%cw(2,0:map%n-1))
    n = 0
    cy1 = 0
    do j = 1, q(2)
     cy2 = cy1 + ny(j)
     cx1 = 0
     do i = 1, q(1)
        cx2 = cx1 + nx(i)
        map%c1(:,n) = [cx1,cy1]
        map%c2(:,n) = [cx2,cy2] - 1
        map%cw(:,n) = [nx(i),ny(j)]
        n = n+1
        cx1 = cx2
     end do
     cy1 = cy2
    end do
    ! x-,y-ticks
    map%nxt = q(1); if( map%nxt==1 ) map%nxt = 0
    map%nyt = q(2); if( map%nyt==1 ) map%nyt = 0
    allocate(map%xticks(q(1)))
    allocate(map%yticks(q(2)))
    cx1 = 0
    do i = 1, q(1)
       map%xticks(i) = cx1
       cx1 = cx1 + nx(i)
    end do
    cy1 = 0
    do i = 1, q(2)
       map%yticks(i) = cy1
       cy1 = cy1 + ny(i)
    end do
    end function make_gridmap

end module patches

!    program main
!    use patches
!    implicit none
!    integer :: x,y,n,ticks(2)
!    type(gridmap) :: map
!    read(*,*) x,y,n
!    call optimal_gridmap([x,y],n,ticks)
!    map = gridmap([x,y],ticks)
!    write(*,*) ticks
!    write(*,*) map%nxt, map%xticks
!    write(*,*) map%nyt, map%yticks
!    do n = 0, map%n - 1
!        write(*,*) map%c1(:,n),map%c2(:,n),map%cw(:,n)
!    end do
!    end program


program tarefac

    ! variavel que para personalizar o nome dos arquivos de saidas
    character(22) filename
    ! constantes
    parameter (Mmax = 10000000, pi = 4d0*atan(1d0))
    ! vetor AndPos, matrix para receber a coordenada de cada andarilho
    ! vetor I_passo, vetor de direção do passo
    dimension AndPos(Mmax,2), I_passo(2)

    ! recebe o número de passos N
    write(*,*) 'Digite o número de passos N:'
    read(*,*) N

    ! recebe o número de andarilhos M
    write(*,*) 'Digite o número de andarilhos M:'
    read(*,*) M

    ! valor inicial da variavel
    AndPos = 0

    ! loop dos passo
    do j = 1, N

        ! loop dos andarilhos
        do i = 1, M

            ! nrand, parte inteira do rand() dilatado
            nrand = 4*rand()
            ! arg, argumento que fará a rotação do passo no plano (x,y)
            arg = nrand*pi/2
            ! I_passo, recebe o valor do passo como vetor
            I_passo = (/cos(arg), sin(arg)/)
            ! soma o passo para cada andarilho
            AndPos(i,:) = AndPos(i,:) + I_passo

        end do

        ! trecho do código para gerar o arquivo de saida para N = 10**j, se j for inteiro
        exp10 = dlog10(dfloat(j))
        i_exp10 = exp10

        ! condiciona para verificar a hipotese acima
        if (mod(exp10, 1.).eq.0) then

            ! filename é alterada para o expoente correspondente
            write(filename, '(A11,I0,A9)') 'saida-c-10e', i_exp10, '-10407962'
            open(10, file=filename)

            ! loop para gerar o arquivo de saida
            do k = 1, M
                write(10,'(I0,", ",I0)') int(AndPos(k,:))
            end do

            ! r2, soma do r**2
            r2 = (sum(AndPos(:,1)**2) + sum(AndPos(:,2)**2))

            ! r = raiz de r2
            r = sqrt(r2)

            ! calculando delta**2
            delta2 = r2/M - (r/M)**2

            ! escreve no terminal o valor de N, <r> e delta**2
            write(*,'("N: 10e",I0,", <r>: ",1F0.3,", delta**2: ",1F0.3)') i_exp10, abs(r/M), abs(delta2)

            close(10)
        end if

    end do

end program tarefac


!     ==========================================
    subroutine mapc2p(x1,y1,xp,yp,zp,Rsphere)
!     ==========================================

!     Map computational point (x1,y1) to the point (xp,yp,zp)
!     on the sphere.

!     Points in [-1,1]x[-1,1]  are mapped to the upper hemisphere
!     Points in [-3,-1]x[-1,1] are mapped to the lower hemisphere

    implicit real*8(a-h,o-z)
!f2py  double precision intent(in) x1
!f2py  double precision intent(in) y1
!f2py  double precision intent(in) xp
!f2py  double precision intent(in) yp
!f2py  double precision intent(in) zp
!f2py  double precision intent(in) Rsphere

    r1 = Rsphere
    xc = x1
    yc = y1
    pi = 4.d0*datan(1.d0)

!     # ghost cell values outside of [-3,1]x[-1,1] get mapped to other
!     # hemisphere:
    if (xc >= 1.d0) xc = xc-4.d0
    if (xc < -3.d0) xc = xc+4.d0

    if (yc >= 1.d0) then
        yc = 2.d0 - yc
        xc = -2.d0 - xc
    endif

    if (yc < -1.d0) then
        yc = -2.d0 - yc
        xc = -2.d0 - xc
    endif

    if (xc < -1.d0) then
    !         # points in [-3,-1] map to lower hemisphere - reflect about x=-1
    !         # to compute x,y mapping and set sgnz appropriately:
        xc = -2.d0 - xc
        sgnz = -1.d0
    else
        sgnz = 1.d0
    endif

    sgnxc = dsign(1.d0,xc)
    sgnyc = dsign(1.d0,yc)

    xc1 = dabs(xc)
    yc1 = dabs(yc)
    d = dmax1(dmax1(xc1,yc1), 1.d-10)

    DD = r1*d*(2.d0 - d) / dsqrt(2.d0)
    R = r1

    centers = DD - dsqrt(dmax1(R**2 - DD**2, 0.d0))
    xp = DD/d * xc1
    yp = DD/d * yc1

    if (yc1 > xc1) then
        yp = centers + dsqrt(dmax1(R**2 - xp**2, 0.d0))
    else
        xp = centers + dsqrt(dmax1(R**2 - yp**2, 0.d0))
    endif

    zp = dsqrt(dmax1(r1**2 - (xp**2 + yp**2), 0.d0))
    xp = xp*sgnxc
    yp = yp*sgnyc
    zp = zp*sgnz

    return
    end subroutine mapc2p


program HammingCode
  implicit none
  integer, parameter :: codeLength = 7
  integer, parameter :: checkBits = 3
  integer, parameter :: informationBitsLen = codeLength - checkBits
  integer :: wrongBit
  integer :: cur
  integer :: i
  integer :: j

  integer :: codeArray(codeLength)
  integer :: syndromeS(checkBits)
  integer :: informationBits(informationBitsLen)
  character(codeLength) :: str

  syndromeS(:) = 0

  write (*, "(A)", advance='no') "Input the code: "
  read(*, *) str

  ! Fill code array

  do i = 1, codeLength
      if (str(i:i) == "0") codeArray(i) = 0
      if (str(i:i) == "1") codeArray(i) = 1
  end do

  ! Count syndrome s for each check bit

  do i = 1, codeLength
      do j = 1, checkBits
          if (mod(i, 2 ** j) >= 2 ** (j - 1)) then
              syndromeS(j) = syndromeS(j) + codeArray(i)
          end if
      end do
  end do

  ! Find the wrong bit

  wrongBit = 0

  do i = 0, checkBits - 1
      wrongBit = wrongBit + mod(syndromeS(i + 1), 2) * 2 ** i
  end do

  ! Invert wrong bit in the message

  if (wrongBit > 0) codeArray(wrongBit) = 1 - codeArray(wrongBit)

  ! Find all information bits

  cur = 1

  first_loop: do i = 1, codeLength
      do j = 0, checkBits - 1
         if (i == 2 ** j) cycle first_loop
      end do

      informationBits(cur) = codeArray(i)
      cur = cur + 1
  end do first_loop

  ! Print right message, information bits and wrong bit number

  write(*, *) "" ! New line
  write(*, "(A)", advance='no') "Right Message: "
  do i = 1, codeLength
      write(*, "(I0)", advance='no') codeArray(i)
  end do

  write(*, *) "" ! New line
  write(*, "(A)", advance='no') "Information Bits: "

  do i = 1, informationBitsLen
        write(*, "(I0)", advance='no') informationBits(i)
  end do

  write(*, *) "" ! New line

  if (wrongBit > 0) then
     write(*, "(A, I1)") "Wrong Bit: ", wrongBit
  else
     write(*, "(A)") "No Wrong Bits"
  end if
end program HammingCode


C
C-----------------------------------------------------------------------
      SUBROUTINE INIT(N,NUM,PI,HOVERD,HEIGHT,VALUE,DEPTH,CASE,CURRNT,
     $           Z,COSA,SINA,COEFF,SOL,Y)
C-----------------------------------------------------------------------
C
C     Calculate initial solution from linear wave theory
C
C-----------------------------------------------------------------------
C
      implicit none
      CHARACTER*10 DEPTH,CASE,CURRNT
      INTEGER n,num
      REAL*8 PI,HOVERD,HEIGHT,VALUE,Z(num),COSA(0:num),SINA(0:num),
     $     COEFF(num),SOL(num,2),Y(num)

      integer :: i
      real*8 :: t, b, a
C
      IF (DEPTH.EQ.'finite') THEN
         IF (CASE.EQ.'period') THEN
            A=4.D0*PI*PI*HEIGHT/HOVERD
            B=A/DSQRT(DTANH(A))
            T=DTANH(B)
            Z(1)=B+(A-B*T)/(T+B*(1.D0-T*T))
         ELSE
            Z(1)=2.D0*PI*HEIGHT/HOVERD
         ENDIF
         Z(2)=Z(1)*HOVERD
         Z(4)=DSQRT(DTANH(Z(1)))
      ELSE
         Z(1)=-1.D0
         Z(4)=1.D0
         IF (CASE.EQ.'period') THEN
            Z(2)=4.D0*PI*PI*HEIGHT
         ELSE
            Z(2)=2.D0*PI*HEIGHT
         ENDIF
      ENDIF
      Z(3)=2.D0*PI/Z(4)
      IF (CURRNT.EQ.'Euler') THEN
         Z(5)=VALUE*DSQRT(Z(2))
         Z(6)=0.D0
      ELSE
         Z(5)=0.D0
         Z(6)=VALUE*DSQRT(Z(2))
      ENDIF
      Z(7)=Z(4)
      Z(8)=0.D0
      Z(9)=0.5D0*Z(7)**2
      Z(10)=0.5D0*Z(2)
      COSA(0)=1.D0
      SINA(0)=0.D0
      DO 1 I=1,N
         COSA(I)=DCOS(I*PI/N)
         COSA(I+N)=DCOS((I+N)*PI/N)
         SINA(I)=DSIN(I*PI/N)
         SINA(I+N)=DSIN((I+N)*PI/N)
         Z(N+I+10)=0.D0
         Z(I+10)=0.5D0*Z(2)*COSA(I)
    1 CONTINUE
      Z(N+11)=0.5D0*Z(2)/Z(7)
C
    2 FORMAT(//,'   INITIAL LINEAR SOLUTION',10(/,6E13.6))
      DO 3 I=1,9
    3     SOL(I,1)=Z(I)
      DO 4 I=10,NUM
    4    SOL(I,1)=0.D0
      DO 5 I=1,NUM
    5    SOL(I,2)=0.D0
      RETURN
      END


!*****************************************************************************************
!>
!  Extrapolation test
!
!### Results
!  ![Plot of results](https://raw.githubusercontent.com/jacobwilliams/bspline-fortran/master/src/tests/results/bspline_extrap_test.png)

    program bspline_extrap_test

    use bspline_module
    use bspline_kinds_module, only: wp, ip
    use pyplot_module

    implicit none

    integer(ip),parameter :: nx    = 400   !! number of points in x
    integer(ip),parameter :: nxv   = 800   !! number of points to evaluate interpolant

    integer(ip),parameter :: kx    = 4    !! order in x
    integer(ip),parameter :: iknot = 0    !! automatically select the knots

    real(wp) :: x(nx)
    real(wp) :: xval(nxv),fval(nxv)
    real(wp) :: tx(nx+kx)
    real(wp) :: fcn_1d(nx)
    real(wp) :: val,tru,err,errmax
    integer(ip) :: i,j,idx,iflag,inbvx,iloy
    logical :: extrap
    type(pyplot) :: plt
    integer :: istat  !! pyplot-fortran status flag
    real(wp),dimension(3*kx) :: w1_1d !! work array

    real(wp),parameter :: rad2deg = 180.0_wp / acos(-1.0_wp)  !! deg. to radians conversion factor

    idx = 0

    do i=1,nx
        x(i) = real(i-1,wp)/100.0_wp + 0.0001_wp
        fcn_1d(i) = f1(x(i))
    end do
    do i=1,nxv
        xval(i) = real(i-200,wp)/100.0_wp
    end do

    !have to set these before the first evaluate call:
    inbvx = 1
    iloy  = 1

    ! initialize
    call db1ink(x,nx,fcn_1d,kx,iknot,tx,fcn_1d,iflag)

    if (iflag/=0) then
        write(*,*) 'Error initializing 1D spline: '//get_status_message(iflag)
    end if

    !initialize the plot:
    call plt%initialize(grid=.true.,xlabel='x (deg)',ylabel='f(x)',&
                        title='Extrapolation Test',legend=.true.)
    call plt%add_plot(x*rad2deg,fcn_1d,label='Function $f(x) = \sin(x)$',&
                        linestyle='ko',markersize=5,linewidth=2,istat=istat)

    do j=1,2

        ! run once without extrapolation, and once with extrapolation
        extrap = j==2

        errmax = 0.0_wp
        do i=1,nxv
            call db1val(xval(i),idx,tx,nx,kx,fcn_1d,val,iflag,inbvx,w1_1d,extrap=extrap)
            fval(i) = val  ! save it for plot
            tru    = f1(xval(i))
            err    = abs(tru-val)
            errmax = max(err,errmax)
            !write(*,*) xval(i), val, tru, err, iflag
        end do

        ! check max error against tolerance
        write(*,*) ''
        write(*,*) '1D: max error:', errmax
        write(*,*) ''

        if (extrap) then
            call plt%add_plot(xval*rad2deg,fval,&
                    label='Interpolated',&
                    linestyle='g.-',linewidth=1,istat=istat)
            call plt%savefig('bspline_extrap_test.png',istat=istat)
        end if

    end do

    contains

        real(wp) function f1(x) !! 1d test function
        implicit none
        real(wp) :: x
        f1 = sin(x)
        end function f1

    end program bspline_extrap_test


PROGRAM merror

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

!       ===================================================
!       Purpose: This program computes the error function
!                erf(x) using subroutine ERROR
!       Input:   x   --- Argument of erf(x)
!       Output:  ERR --- erf(x)
!       Example:
!                  x         erf(x)
!                ---------------------
!                 1.0       .84270079
!                 2.0       .99532227
!                 3.0       .99997791
!                 4.0       .99999998
!                 5.0      1.00000000
!       ===================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
WRITE(*,*)'Please enter x '
!        READ(*,*)X
x=1.0
WRITE(*,*)'   x         erf(x)'
WRITE(*,*)'---------------------'
CALL errorf(x,er)
WRITE(*,10)x,er
10      FORMAT(1X,f5.2,f15.8)
END PROGRAM merror

SUBROUTINE errorf(x,ERR)

!       =========================================
!       Purpose: Compute error function erf(x)
!       Input:   x   --- Argument of erf(x)
!       Output:  ERR --- erf(x)
!       =========================================

DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: ERR
IMPLICIT DOUBLE PRECISION (a-h,o-z)
eps=1.0D-15
pi=3.141592653589793D0
x2=x*x
IF (DABS(x) < 3.5D0) THEN
  er=1.0D0
  r=1.0D0
  DO  k=1,50
    r=r*x2/(k+0.5D0)
    er=er+r
    IF (DABS(r) <= DABS(er)*eps) EXIT
  END DO
  15         c0=2.0D0/DSQRT(pi)*x*DEXP(-x2)
  ERR=c0*er
ELSE
  er=1.0D0
  r=1.0D0
  DO  k=1,12
    r=-r*(k-0.5D0)/x2
    er=er+r
  END DO
  c0=DEXP(-x2)/(DABS(x)*DSQRT(pi))
  ERR=1.0D0-c0*er
  IF (x < 0.0) ERR=-ERR
END IF
RETURN
END SUBROUTINE errorf


c**********************************************************************
c   pi.f - compute pi by integrating f(x) = 4/(1 + x**2)
c
c   Each node:
c    1) receives the number of rectangles used in the approximation.
c    2) calculates the areas of it's rectangles.
c    3) Synchronizes for a global summation.
c   Node 0 prints the result.
c
c  Variables:
c
c    pi  the calculated result
c    n   number of points of integration.
c    x           midpoint of each rectangle's interval
c    f           function to integrate
c    sum,pi      area of rectangles
c    tmp         temporary scratch space for global summation
c    i           do loop index
c****************************************************************************
      program main

      include 'mpif.h'

      double precision  PI25DT
      parameter        (PI25DT = 3.141592653589793238462643d0)

      double precision  mypi, pi, h, sum, x, f, a
      integer n, myid, numprocs, i, rc, idx

      integer event1a, event1b, event2a, event2b
      integer event3a, event3b, event4a, event4b
      integer ierr

c                                 function to integrate
      f(a) = 4.d0 / (1.d0 + a*a)

      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr )
      print *, "Process ", myid, " of ", numprocs, " is alive"

      sizetype   = 1
      sumtype    = 2

      event1a = MPE_Log_get_event_number()
      event1b = MPE_Log_get_event_number()
      event2a = MPE_Log_get_event_number()
      event2b = MPE_Log_get_event_number()
      event3a = MPE_Log_get_event_number()
      event3b = MPE_Log_get_event_number()
      event4a = MPE_Log_get_event_number()
      event4b = MPE_Log_get_event_number()

      if ( myid .eq. 0 ) then
          ierr = MPE_Describe_state( event1a, event1b,
     &                               "User_Broadcast", "red" )
          ierr = MPE_Describe_state( event2a, event2b,
     &                               "User_Barrier", "blue" )
          ierr = MPE_Describe_state( event3a, event3b,
     &                               "User_Compute", "orange" )
          ierr = MPE_Describe_state( event4a, event4b,
     &                               "User_Reduce", "green" )
          write(6,*) "events ID are ", event1a, event1b,
     &                                 event2a, event2b
      endif

      if ( myid .eq. 0 ) then
C         write(6,98)
C 98      format('Enter the number of intervals: (0 quits)')
C         read(5,99) n
C 99      format(i10)
          n = 1000000
          write(6,*) 'The number of intervals =', n
      endif

      call MPI_BARRIER( MPI_COMM_WORLD, ierr )

      do idx = 1, 2

          ierr = MPE_Log_event( event1a, 0, "start broadcast" )
          call MPI_BCAST(n,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
          ierr = MPE_Log_event( event1b, 0, "end broadcast" )

c                                 check for quit signal
C         if ( n .le. 0 ) goto 30

          ierr = MPE_Log_event( event2a, 0, "start barrier" )
          call MPI_Barrier( MPI_COMM_WORLD, ierr )
          ierr = MPE_Log_event( event2b, 0, "end barrier" )

c                                 calculate the interval size
          ierr = MPE_Log_event( event3a, 0, "start compute" )
          h = 1.0d0/n

          sum  = 0.0d0
          do 20 i = myid+1, n, numprocs
              x = h * (dble(i) - 0.5d0)
              sum = sum + f(x)
 20       continue
          mypi = h * sum
          ierr = MPE_Log_event( event3b, 0, "end compute" )

c                                 collect all the partial sums
          ierr = MPE_Log_event( event4a, 0, "Start Reduce" )
          call MPI_REDUCE(mypi,pi,1,MPI_DOUBLE_PRECISION,MPI_SUM,0,
     $                    MPI_COMM_WORLD,ierr)
          ierr = MPE_Log_event( event4b, 0, "End Reduce" )

c                                 node 0 prints the answer.
          if ( myid .eq. 0 ) then
              write(6, 97) pi, abs(pi - PI25DT)
 97           format('  pi is approximately: ', F18.16,
     +               '  Error is: ', F18.16)
          endif

      enddo

 30   call MPI_FINALIZE(rc)

      end


! HOW TO COMPILE THROUGH COMMAND LINE (CMD OR TERMINAL)
! gfortran -c gausselimination.f95
! gfortran -o gausselimination gausselimination.o
!
! The program is open source and can use to numeric study purpose.
! The program was build by Aulia Khalqillah,S.Si., M.Si
!
! email: auliakhalqillah.mail@gmail.com
! ==============================================================================
program gauss
    implicit none

    real, dimension(3,4) :: x
    real, dimension(3) :: s
    real :: const
    integer :: i,j,totalrows,totalcolumns

    x(1,1) = -2
    x(1,2) = 1
    x(1,3) = 2
    x(1,4) = 6
    x(2,1) = 3
    x(2,2) = -4
    x(2,3) = 8
    x(2,4) = 12
    x(3,1) = 6
    x(3,2) = -2
    x(3,3) = 1
    x(3,4) = 4

    ! show matrix
    do i = 1,3
        write(*,*) (x(i,j), j = 1,4)
    end do

    write(*,*) ""

    totalcolumns = 4
    totalrows = totalcolumns - 1
    do j = 1,totalrows-1
        do i = j+1,totalrows
            if (x(i,j) == x(j,j)) then
                x(i,(j):(totalcolumns)) = x(i,(j):(totalcolumns)) * (-1)
                x(i,(j):(totalcolumns)) = x((j),(j):(totalcolumns)) + x(i,(j):(totalcolumns))
            else
                if (x(i,j) == 0) then
                    x(i,(j):(totalcolumns)) = x(i,(j):(totalcolumns))
                else
                    const = x(i,j)/x(j,j)
                    x(i,(j):(totalcolumns)) = (x(i,(j):(totalcolumns))/const) * (-1)
                    x(i,(j):(totalcolumns)) = x((j),(j):(totalcolumns)) + x(i,(j):(totalcolumns))
                end if
            end if
        end do
    end do

    write(*,*) 'Final Results'
    do i = 1,3
        write(*,*) (x(i,j), j = 1,4)
    end do

    ! calculate the solutions/backward subtitutions
    s(totalrows) = x(totalrows,totalcolumns)/x(totalrows,totalrows)
    do i = totalrows-1,1,-1
        write(*,*)""
        s(i) = x(i,totalcolumns)
        do j = i+1,totalrows
            s(i) = s(i) - (x(i,j) * s(j))
        end do
        s(i) = s(i)/x(i,i)
    end do

    do i = 1,totalrows
        write(*,*) 'Solutions',i,':',s(i)
    end do
end program gauss


*DECK DEXPRL
      DOUBLE PRECISION FUNCTION DEXPRL (X)
C***BEGIN PROLOGUE  DEXPRL
C***PURPOSE  Calculate the relative error exponential (EXP(X)-1)/X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4B
C***TYPE      DOUBLE PRECISION (EXPREL-S, DEXPRL-D, CEXPRL-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, EXPONENTIAL, FIRST ORDER, FNLIB
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate  EXPREL(X) = (EXP(X) - 1.0) / X.   For small ABS(X) the
C Taylor series is used.  If X is negative the reflection formula
C         EXPREL(X) = EXP(X) * EXPREL(ABS(X))
C may be used.  This reflection formula will be of use when the
C evaluation for small ABS(X) is done by Chebyshev series rather than
C Taylor series.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DEXPRL
      DOUBLE PRECISION X, ABSX, ALNEPS, XBND, XLN, XN,  D1MACH
      LOGICAL FIRST
      SAVE NTERMS, XBND, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DEXPRL
      IF (FIRST) THEN
         ALNEPS = LOG(D1MACH(3))
         XN = 3.72D0 - 0.3D0*ALNEPS
         XLN = LOG((XN+1.0D0)/1.36D0)
         NTERMS = XN - (XN*XLN+ALNEPS)/(XLN+1.36D0) + 1.5D0
         XBND = D1MACH(3)
      ENDIF
      FIRST = .FALSE.
C
      ABSX = ABS(X)
      IF (ABSX.GT.0.5D0) DEXPRL = (EXP(X)-1.0D0)/X
      IF (ABSX.GT.0.5D0) RETURN
C
      DEXPRL = 1.0D0
      IF (ABSX.LT.XBND) RETURN
C
      DEXPRL = 0.0D0
      DO 20 I=1,NTERMS
        DEXPRL = 1.0D0 + DEXPRL*X/(NTERMS+2-I)
 20   CONTINUE
C
      RETURN
      END


module gauss_seidel

  use shared_data
  use boundary_conditions
  use diagnostics

  implicit none

  private

  public :: solve_const_Helmholtz, &
            solve_variable_elliptic

  contains

  subroutine solve_const_Helmholtz(phigs,f,alpha,beta,use_old_phi,tol)

    ! Solves the constand co-efficient Helmholtz equation
    ! (alpha - beta del**2) phi = f
    !
    ! For somple Poisson set alpha = 0 and beta = -1
    !
    ! Variable coefficients are handled separately

    real(num), dimension(-1:nx+2,-1:ny+2), intent(inout) :: phigs
    real(num), dimension(1:nx,1:ny), intent(in) :: f
    real(num), intent(in) :: alpha, beta
    logical, intent(in) :: use_old_phi
    real(num), intent(in) :: tol

    logical :: gsrb=.true. !hidden option

    real(num) :: L2, L2_old !norms
    real(num) :: L_phigs !laplacian of phigs

    integer :: maxir = -1 ! <0 for no max no of iterations
    integer :: ir = 0
    logical :: verbose=.false.

    print *, '*** begining GS relaxation solve.'
    print *, '*** this can take a while, use VERBOSE if you want to monitor stepping'

    if (.not. use_old_phi) then
      phi = 0.0_num
    else
      call phigs_bcs(phigs) !phi = 0.0_num
    endif

    L2_old = 1e6_num

    ir = 0
    do
      ir = ir + 1

      ! if not using redblack order
      if (.not. gsrb) then
        do iy = 1, ny
        do ix = 1, nx
          phigs(ix,iy) = phigs(ix+1,iy) + phigs(ix-1,iy) + phigs(ix,iy+1) + phigs(ix,iy-1)
          phigs(ix,iy) = (f(ix,iy) + beta * phigs(ix,iy) / dx**2) / &
            & (alpha + 4.0_num * beta / dx**2)

! hardcoded poisson equation
!          phi(ix,iy) = 0.25_num * ( &
!            & phi(ix+1,iy) + phi(ix-1,iy) + phi(ix,iy+1) + phi(ix,iy-1) &
!            - dx**2 * divu(ix,iy) )
        end do
        end do
      else !use red black
        ! odd iteration
        do iy = 1, ny
        do ix = 1, nx
          if (modulo(ix+iy,2) == 1) then
            phigs(ix,iy) = phigs(ix+1,iy) + phigs(ix-1,iy) + phigs(ix,iy+1) + phigs(ix,iy-1)
            phigs(ix,iy) = (f(ix,iy) + beta * phigs(ix,iy) / dx**2) / &
              & (alpha + 4.0_num * beta / dx**2)

!            phi(ix,iy) = 0.25_num * ( &
!              & phi(ix+1,iy) + phi(ix-1,iy) + phi(ix,iy+1) + phi(ix,iy-1) &
!              - dx**2 * divu(ix,iy) )
          endif
        end do
        end do
        ! even iteration
        do iy = 1, ny
        do ix = 1, nx
          if (modulo(ix+iy,2) == 0) then
            phigs(ix,iy) = phigs(ix+1,iy) + phigs(ix-1,iy) + phigs(ix,iy+1) + phigs(ix,iy-1)
            phigs(ix,iy) = (f(ix,iy) + beta * phigs(ix,iy) / dx**2) / &
              & (alpha + 4.0_num * beta / dx**2)
!            phi(ix,iy) = 0.25_num * ( &
!              & phi(ix+1,iy) + phi(ix-1,iy) + phi(ix,iy+1) + phi(ix,iy-1) &
!              - dx**2 * divu(ix,iy) )
          endif
        end do
        end do

      endif

      ! Apply periodic boundary conditions on phi's ghost cells

      call phigs_bcs(phigs)

      L2 = 0.0_num
      do iy = 1, ny
      do ix = 1, nx
        L_phigs = (phigs(ix+1,iy) - 2.0_num*phigs(ix,iy) + phigs(ix-1,iy)) &
          & / dx**2 + &
          & (phigs(ix,iy+1) - 2.0_num*phigs(ix,iy) + phigs(ix,iy-1)) / dy**2

        !L2 = L2 + abs(divu(ix,iy)-L_phi)**2
        L2 = L2 + abs(f(ix,iy)-(alpha*phigs(ix,iy)-beta*L_phigs))**2
      end do
      end do
      L2 = sqrt( L2 / REAL(nx*ny,num))

      if (verbose) &
        & print *, 'GS-iteration',ir,'complete. L2 is',L2,'|L2-L2_old| is',abs(L2-L2_old),'tol is',tol

     !exit conditions
     !if ((step >= nsteps .and. nsteps >= 0) .or. (L2 <= tol)) exit
     ! alt, exit if the difference between L2 and L2 prev is small - might
     ! indicate convergence
      if ((ir >= maxir .and. maxir >= 0) .or. (abs(L2-L2_old) <= tol)) exit
      L2_old = L2
    end do

    print *, '*** Gauss Seidel relaxation completed in',ir,'steps'
    print *, '*** L2 norm on numerical residuals',L2

  end subroutine solve_const_Helmholtz

  subroutine solve_variable_elliptic(phigs,f,eta,use_old_phi,tol)

    real(num), dimension(-1:nx+2,-1:ny+2), intent(inout) :: phigs
    real(num), dimension(1:nx,1:ny), intent(in) :: f
    real(num), dimension(0:nx+1,0:ny+1), intent(in) :: eta
            ! ^ eta should typically be rho plus its up-to-date +-1 ghost cells
    logical, intent(in) :: use_old_phi
    real(num), intent(in) :: tol

    logical :: gsrb=.true. !hidden option

    real(num) :: L2, L2_old !norms
    real(num) :: L_phigs !laplacian of phigs

    real(num) :: eta_ip, eta_im, eta_jp, eta_jm

    integer :: maxir = -1 ! <0 for no max no of iterations
    integer :: ir = 0
    logical :: verbose=.false.

    print *, '*** begining GS relaxation solve.'
    print *, '*** this can take a while, use VERBOSE if you want to monitor stepping'

    if (.not. use_old_phi) then
      phi = 0.0_num
    else
      call phigs_bcs(phigs) !phi = 0.0_num
    endif

    L2_old = 1e6_num

    ir = 0
    do
      ir = ir + 1

      ! if not using redblack order
      if (.not. gsrb) then
        do iy = 1, ny
        do ix = 1, nx
          !eta_ip actually also has the deltas built in
          eta_ip = 0.5_num * (eta(ix,iy)+eta(ix+1,iy)) / dx**2
          eta_im = 0.5_num * (eta(ix,iy)+eta(ix-1,iy)) / dx**2
          eta_jp = 0.5_num * (eta(ix,iy)+eta(ix,iy+1)) / dy**2
          eta_jm = 0.5_num * (eta(ix,iy)+eta(ix,iy-1)) / dy**2

          phigs(ix,iy) = eta_ip * phigs(ix+1,iy) + eta_im*phigs(ix-1,iy) &
            & + eta_jp * phigs(ix,iy+1) + eta_jm * phigs(ix,iy-1) - f(ix,iy)
          phigs(ix,iy) = phigs(ix,iy) / ( eta_ip + eta_im + eta_jp + eta_jm )
        end do
        end do
      else !use red black
        ! odd iteration
        do iy = 1, ny
        do ix = 1, nx
          if (modulo(ix+iy,2) == 1) then
            !eta_ip actually also has the deltas built in
            eta_ip = 0.5_num * (eta(ix,iy)+eta(ix+1,iy)) / dx**2
            eta_im = 0.5_num * (eta(ix,iy)+eta(ix-1,iy)) / dx**2
            eta_jp = 0.5_num * (eta(ix,iy)+eta(ix,iy+1)) / dy**2
            eta_jm = 0.5_num * (eta(ix,iy)+eta(ix,iy-1)) / dy**2

            phigs(ix,iy) = eta_ip * phigs(ix+1,iy) + eta_im*phigs(ix-1,iy) &
              & + eta_jp * phigs(ix,iy+1) + eta_jm * phigs(ix,iy-1) - f(ix,iy)
            phigs(ix,iy) = phigs(ix,iy) / ( eta_ip + eta_im + eta_jp + eta_jm )
          endif
        end do
        end do
        ! even iteration
        do iy = 1, ny
        do ix = 1, nx
          if (modulo(ix+iy,2) == 0) then
            !eta_ip actually also has the deltas built in
            eta_ip = 0.5_num * (eta(ix,iy)+eta(ix+1,iy)) / dx**2
            eta_im = 0.5_num * (eta(ix,iy)+eta(ix-1,iy)) / dx**2
            eta_jp = 0.5_num * (eta(ix,iy)+eta(ix,iy+1)) / dy**2
            eta_jm = 0.5_num * (eta(ix,iy)+eta(ix,iy-1)) / dy**2

            phigs(ix,iy) = eta_ip * phigs(ix+1,iy) + eta_im*phigs(ix-1,iy) &
              & + eta_jp * phigs(ix,iy+1) + eta_jm * phigs(ix,iy-1) - f(ix,iy)
            phigs(ix,iy) = phigs(ix,iy) / ( eta_ip + eta_im + eta_jp + eta_jm )
          endif
        end do
        end do

      endif

      ! Apply periodic boundary conditions on phi's ghost cells

      call phigs_bcs(phigs)

      L2 = 0.0_num
      do iy = 1, ny
      do ix = 1, nx

        eta_ip = 0.5_num * (eta(ix,iy)+eta(ix+1,iy))
        eta_im = 0.5_num * (eta(ix,iy)+eta(ix-1,iy))
        eta_jp = 0.5_num * (eta(ix,iy)+eta(ix,iy+1))
        eta_jm = 0.5_num * (eta(ix,iy)+eta(ix,iy-1))

        L_phigs = ( eta_ip * (phigs(ix+1,iy)-phigs(ix,iy)) &
              &    -  eta_im * (phigs(ix,iy)-phigs(ix-1,iy)) ) / dx**2 + &
              & ( eta_jp * (phigs(ix,iy+1)-phigs(ix,iy)) &
              &    -  eta_jm * (phigs(ix,iy)-phigs(ix,iy-1)) ) / dy**2

        !residual
        L2 = L2 + abs(f(ix,iy)-L_phigs)**2
      end do
      end do
      L2 = sqrt( L2 / REAL(nx*ny,num))

      if (verbose) &
        & print *, 'GS-iteration',ir,'complete. L2 is',L2,'|L2-L2_old| is',abs(L2-L2_old),'tol is',tol

     !exit conditions
     !if ((step >= nsteps .and. nsteps >= 0) .or. (L2 <= tol)) exit
     ! alt, exit if the difference between L2 and L2 prev is small - might
     ! indicate convergence
      if ((ir >= maxir .and. maxir >= 0) .or. (abs(L2-L2_old) <= tol)) exit
      L2_old = L2
    end do

    print *, '*** Gauss Seidel relaxation completed in',ir,'steps'
    print *, '*** L2 norm on numerical residuals',L2

  end subroutine solve_variable_elliptic

  subroutine phigs_bcs(phigs)

    real(num), dimension(-1:nx+2,-1:ny+2), intent(inout) :: phigs

    if (bc_xmin == periodic) then
      phigs(0,:) = phigs(nx,:)
      phigs(-1,:) = phigs(nx-1,:)
    endif
    if (bc_xmax == periodic) then
      phigs(nx+1,:) = phigs(1,:)
      phigs(nx+2,:) = phigs(2,:)
    endif
    if (bc_ymin == periodic) then
      phigs(:,0) = phigs(:,ny)
      phigs(:,-1) = phigs(:,ny-1)
    endif
    if (bc_ymax == periodic) then
      phigs(:,ny+1) = phigs(:,1)
      phigs(:,ny+2) = phigs(:,2)
    endif

    ! Zero gradient

    if (bc_xmin == zero_gradient) then
      phigs(0,:) = phigs(1,:)
      phigs(-1,:) = phigs(2,:)
    endif
    if (bc_xmax == zero_gradient) then
      phigs(nx+1,:) = phigs(nx,:)
      phigs(nx+2,:) = phigs(nx-1,:)
    endif
    if (bc_ymin == zero_gradient) then
      phigs(:,0) = phigs(:,1)
      phigs(:,-1) = phigs(:,2)
    endif
    if (bc_ymax == zero_gradient) then
      phigs(:,ny+1) = phigs(:,ny)
      phigs(:,ny+2) = phigs(:,ny-1)
    endif

    ! No slip

!!    if (bc_xmin == no_slip) then
!!      phigs(0,:) = -phigs(1,:)
!!      phigs(-1,:) = -phigs(2,:)
!!    endif
!!    if (bc_xmax == no_slip) then
!!      phigs(nx+1,:) = -phigs(nx,:)
!!      phigs(nx+2,:) = -phigs(nx-1,:)
!!    endif
!!    if (bc_ymin == no_slip) then
!!      phigs(:,0) = -phigs(:,1)
!!      phigs(:,-1) = -phigs(:,2)
!!    endif
!!    if (bc_ymax == no_slip) then
!!      phigs(:,ny+1) = -phigs(:,ny)
!!      phigs(:,ny+2) = -phigs(:,ny-1)
!!    endif
    if (bc_xmin == no_slip) then
      phigs(0,:) = phigs(1,:)
      phigs(-1,:) = phigs(2,:)
    endif
    if (bc_xmax == no_slip) then
      phigs(nx+1,:) = phigs(nx,:)
      phigs(nx+2,:) = phigs(nx-1,:)
    endif
    if (bc_ymin == no_slip) then
      phigs(:,0) = phigs(:,1)
      phigs(:,-1) = phigs(:,2)
    endif
    if (bc_ymax == no_slip) then
      phigs(:,ny+1) = phigs(:,ny)
      phigs(:,ny+2) = phigs(:,ny-1)
    endif

!    !overwrite with experimental no_slip
    ! seems to give large (>0 !) for the grav problem

!    if (bc_ymin == no_slip) then
!      phigs(:,0) =  phigs(:,1) - (phigs(:,2)-phigs(:,1))
!      phigs(:,-1) = phigs(:,1) - (phigs(:,2)-phigs(:,1))*2.0_num
!    endif
!    if (bc_ymax == no_slip) then
!      phigs(:,ny+1) = phigs(:,ny) + (phigs(:,ny) - phigs(:,ny-1))
!      phigs(:,ny+2) = phigs(:,ny) + (phigs(:,ny) - phigs(:,ny-1))*2.0_num
!    endif

    !duplicate of no_slip for driven
    if (bc_ymax == driven) then
      phigs(:,ny+1) = phigs(:,ny)
      phigs(:,ny+2) = phigs(:,ny-1)
    endif

  end subroutine phigs_bcs

end module gauss_seidel


      PROGRAM xquad3d
C     driver for routine quad3d
      COMMON xmax
      REAL xmax
      INTEGER NVAL
      REAL PI
      PARAMETER(PI=3.1415926,NVAL=10)
      INTEGER i
      REAL s,xmin
      write(*,*) 'Integral of r^2 over a spherical volume'
      write(*,'(/4x,a,t14,a,t24,a)') 'Radius','QUAD3D','Actual'
      do 11 i=1,NVAL
        xmax=0.1*i
        xmin=-xmax
        call quad3d(xmin,xmax,s)
        write(*,'(1x,f8.2,2f10.4)') xmax,s,4.0*PI*(xmax**5)/5.0
11    continue
      END
      REAL FUNCTION func(x,y,z)
      REAL x,y,z
      func=x**2+y**2+z**2
      END
      REAL FUNCTION z1(x,y)
      REAL x,y
      COMMON xmax
      REAL xmax
      z1=-sqrt(abs(xmax**2-x**2-y**2))
      END
      REAL FUNCTION z2(x,y)
      REAL x,y
      COMMON xmax
      REAL xmax
      z2=sqrt(abs(xmax**2-x**2-y**2))
      END
      REAL FUNCTION y1(x)
      REAL x
      COMMON xmax
      REAL xmax
      y1=-sqrt(abs(xmax**2-x**2))
      END
      REAL FUNCTION y2(x)
      REAL x
      COMMON xmax
      REAL xmax
      y2=sqrt(abs(xmax**2-x**2))
      END
      SUBROUTINE qgausx(func,a,b,ss)
      REAL x(5),w(5)
      INTEGER j
      REAL a,b,dx,ss,xm,xr
      REAL func
      EXTERNAL func
      DATA x/.1488743389,.4333953941,.6794095682,
     *     .8650633666,.9739065285/
      DATA w/.2955242247,.2692667193,.2190863625,
     *     .1494513491,.0666713443/
      xm=0.5*(b+a)
      xr=0.5*(b-a)
      ss=0
      do 11 j=1,5
        dx=xr*x(j)
        ss=ss+w(j)*(func(xm+dx)+func(xm-dx))
11    continue
      ss=xr*ss
      return
      END
      SUBROUTINE qgausy(func,a,b,ss)
      REAL x(5),w(5)
      INTEGER j
      REAL a,b,dx,ss,xm,xr
      REAL func
      EXTERNAL func
      DATA x/.1488743389,.4333953941,.6794095682,
     *     .8650633666,.9739065285/
      DATA w/.2955242247,.2692667193,.2190863625,
     *     .1494513491,.0666713443/
      xm=0.5*(b+a)
      xr=0.5*(b-a)
      ss=0
      do 11 j=1,5
        dx=xr*x(j)
        ss=ss+w(j)*(func(xm+dx)+func(xm-dx))
11    continue
      ss=xr*ss
      return
      END
      SUBROUTINE qgausz(func,a,b,ss)
      REAL x(5),w(5)
      INTEGER j
      REAL a,b,dx,ss,xm,xr
      REAL func
      EXTERNAL func
      DATA x/.1488743389,.4333953941,.6794095682,
     *     .8650633666,.9739065285/
      DATA w/.2955242247,.2692667193,.2190863625,
     *     .1494513491,.0666713443/
      xm=0.5*(b+a)
      xr=0.5*(b-a)
      ss=0
      do 11 j=1,5
        dx=xr*x(j)
        ss=ss+w(j)*(func(xm+dx)+func(xm-dx))
11    continue
      ss=xr*ss
      return
      END

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


program test_tan
use lfortran_intrinsic_math, only: tan
implicit none
real :: x
x = tan(1.5)
print *, x
if (abs(x - 14.1014204) > 1e-5) error stop
end program


program main

    use mod_numerical, only: max_nonconvex
    implicit none

    real(8) :: a,b,max_val,arg_min,true_min

    !max_nonconvex(f, a, b, xmax, fmax, mytol, mymaxit, mynx)

    a = 0d0
    b = 5d0
    true_min = 4.691893d0 ! global minimum (argmin)

    call max_nonconvex(fun, a, b, arg_min, max_val, mynx=15)

    write(*,*) "Interval [a,b]", a,b
    write(*,*) "Arg min       = ", arg_min
    write(*,*) "Minimum value = ", -max_val
    write(*,*) "True global arg-min = ", true_min

    if (abs(arg_min-true_min)<1d-4) then
        write(*,*) "Test passed!"
    else
        write(*,*) "Test failed!"
    endif

    write(*,*) "Program will terminate.."
    pause

    contains

    function fun(x) result(F)
        ! This function has many local minima in the interval [0,5]
        ! The unique global minimum is at x = 4.691893
        ! Variables
        real(8), intent(in) :: x
        real(8) :: F
        ! Body of fun
        F = x*cos(x*x)

        F = -F

    end function fun

end program main


! Objetivo: Integrar a equacao diferencial do oscilador de Van der Pol
!	    de t=0 ate t=8pi para obter os graficos x, v e E/m em funcao de
!           t/pi e investigar sua trajetoria no espaco de fase.

MODULE derivada
	REAL, PARAMETER :: omega0=1.0,mu=1.0,x0=1.0
CONTAINS
	SUBROUTINE deriv_func_vanderpol(t, x, dxdt)
		USE nrtype
		IMPLICIT none
		REAL(SP), intent(in) :: t
		REAL(SP), DIMENSION(:), intent(in) :: x
		REAL(SP), DIMENSION(:), intent(out) :: dxdt
		dxdt(1)=x(2)
		dxdt(2)=mu*x(2)*(x0**2-(x(1))**2)-x(1)*omega0**2
	END SUBROUTINE deriv_func_vanderpol
END MODULE derivada

PROGRAM oscilador_van_der_pol
	USE nrtype
	USE derivada
	USE nr, only: bsstep, odeint
	IMPLICIT none
	INTEGER :: ponto_ti, curva_in
	INTEGER, PARAMETER :: Arquivo_t_x_v_Em=1, Arquivo_espaco_fase=2
	INTEGER, PARAMETER :: pontos=800, num_curvas=6
	REAL :: t1, t2, Em
	REAL, DIMENSION(2) :: x
	REAL, PARAMETER :: pts_menos1=pontos-1, curv_menos1=num_curvas-1
	REAL, PARAMETER :: tempo_i=0.0, tempo_final=8.0*pi, variacao_t= &
					& (tempo_final-tempo_i)/pts_menos1
	REAL, PARAMETER :: posicao_i=0.5, posicao_f=3.0, variacao_posi= &
					& (posicao_f-posicao_i)/curv_menos1
	REAL, PARAMETER :: velocidade_i=0.0, eps=epsilon(posicao_i), &
						&  h1=1.e-6, hmin=0.0
	REAL, PARAMETER :: meio_omega02=0.5*omega0**2
	x(1)=posicao_i
	x(2)=velocidade_i
	t1=tempo_i

	OPEN(unit=Arquivo_t_x_v_Em, file="x_v_Em_vs_tpi.dat")
	OPEN(unit=Arquivo_espaco_fase, file="v_vs_x.dat")
! Escrever a posicao, velocidade e energia total dividida pela massa
! em funcao do tempo/pi
	WRITE(unit=Arquivo_t_x_v_Em,fmt=*) t1/pi, x, 0.5*x(2)**2+ &
						& meio_omega02*x(1)**2
	t2=tempo_i+variacao_t
	DO ponto_ti=2, pontos
		CALL odeint(x, t1, t2, eps, h1, hmin, deriv_func_vanderpol, bsstep)
! Escrever a posicao, velocidade e energia total dividida pela massa
! em funcao do tempo/pi
		WRITE(unit=Arquivo_t_x_v_Em,fmt=*) t2/pi, x, 0.5*x(2)**2+ &
						& meio_omega02*x(1)**2
		t1=t2
		t2=t2+variacao_t
	END DO
! Investigando a trajetoria do oscilador no espaco de fase
	x(1)=posicao_i
	DO curva_in=1, num_curvas
		t1=tempo_i
		t2=tempo_i+variacao_t
		x(2)=x(1)
		WRITE(unit=Arquivo_espaco_fase,fmt=*) x
		DO ponto_ti=1,pontos
			CALL odeint(x,t1,t2,eps,h1,hmin,deriv_func_vanderpol,bsstep)
			WRITE(unit=Arquivo_espaco_fase,fmt=*) x
			t1=t2
			t2=t2+variacao_t
		END DO
		WRITE(unit=Arquivo_espaco_fase,fmt=*)
		x(1)=posicao_i+variacao_posi*REAL(curva_in)
	END DO
	CLOSE(unit=Arquivo_t_x_v_Em)
	CLOSE(unit=Arquivo_espaco_fase)
END PROGRAM oscilador_van_der_pol


      double precision function DCOSHM (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DCOSHM Krogh  Changes to use M77CON
c>> 1993-05-07 DCOSHM WVSnyder JPL Initial code
c
c     Compute cosh(x) - 1 using a rational approximation when abs(x)
c     is less than 1.2, else use the Fortran intrinsic function.
c
c--D replaces "?": ?COSHM
      double precision CP5, CP4, CP3, CP2, CP1, CQ1, X, XS
      parameter ( CP5 = .116744361560051d-08)
      parameter ( CP4 = .280407224259429d-06 )
      parameter ( CP3 = .344417983443219d-04 )
      parameter ( CP2 = .232293648552398d-02 )
      parameter ( CP1 = .778752378267155d-01 )
      parameter ( CQ1 = -.545809550662099d-02*2.0d0)
      xs = x*x
      if (xs .lt. 1.44d0) then
         dcoshm = ((((((cp5*xs+cp4)*xs+cp3)*xs+cp2)*xs+cp1)*xs+1.0d0)
     *                  *xs)/(cq1*xs+2.0d0)
      else
         dcoshm = cosh(x) - 1.0d0
      end if
      return
      end


! Mikayla Webber
! 4670 Numerical Analysis
! Homework Four Due 11/6/17

module secret 							! secret module

integer :: fcounter						! counter for loop

end module secret

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

! MAIN FOR COMPOSITE SIMPSON METHOD
program WebberHomework4Question1				! main program
use secret							! uses secret module
implicit none

real :: a, b, f, h						! declares real variables
real :: actual							! declares real variable
real :: simpson, s						! declares real variable
integer :: i, n							! declares integer variables

a = 1.0								! sets a to 1
b = 2.0								! sets b to 2
n = 2								! sets n to 2
actual = log(2.0)						! sets actual to the log of 2

print*, "Newton and Composite Simpson Method"			! displays message to output

do i = 1, 25
	h = (b - a) / float(n)					! sets h to (b - a) / n
print*, h
	s = (simpson(n, a, b, f))				! sets s to simpson function
print*, s
	!print*, n, s, abs(actual - s), abs(actual - s) / h**4.0
	write(*,* ) n, s, abs(actual - s), abs(actual - s) / h**4.0 ! writes message to standard output
	n = (n * 2)						! sets n to n * 2
print*, n
	fcounter = (fcounter + 1)				! increments counter
end do

stop
end program WebberHomework4Question1				! ends main program

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

! MAIN FOR COMPOSITE TRAPEZOID METHOD
!program WebberHomework4Question1				! main program
!use secret							! uses secret module
!implicit none

!real :: a, b, f, h						! declares real variables
!real :: actual, t, trapezoid					! declares real variable
!integer :: i, n						! declares integer variables

!a = 1.0							! sets a to 1
!b = 2.0							! sets b to 2
!n = 2								! sets n to 2
!actual = log(2.0)						! sets actual to the log of 2

!print*, "Newton and Composite Trapezoid Method"		! displays message to output

!do i = 1, 25
!	h = (b - a) / float(n)					! sets h to (b - a) / n
!	! print*, h 						! for debugging
!	t = (trapezoid(n, a, b, f))				! sets t to trapezoid function
!	! print*, t						! for debugging
!	print*, n, t, abs(actual - t), abs(actual - t) / h**4.0 ! writes message to standard output
!	n = (n * 2)						! sets n to n * 2
!	! print*, n						! for debugging
!	fcounter = (fcounter + 1)				! increments counter
!	! print*, fcounter					! for debugging
!end do

!stop
!end program WebberHomework4Question1				! ends main program

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

real function fprime(x)						! function for fprime(x)
implicit none
real :: f, pi, x						! declares real variables

f = exp(1.0)
pi = (4 * ATAN(1.0))						! most accurate for pi

fprime = (1.0 / SQRT(2.0 * pi)) * (f**(-x**2.0) / 2.0)		! sets fprime to the equation from problem

return
end

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

real function simpson(n, a, b, fprime)				! function for composite simpson
implicit none

integer :: i, n							! declares integer variables
real :: a, b, fv, h, fprime					! declares real variables
real :: se, so							! declares simpson even and odd real variables

h = (b - a) / float(n)						! sets h to (b - a) / n

simpson = 0.0							! initial value of zero
se = 0.0							! initial value of zero
so = 0.0							! initial value of zero

do i = 1, n - 1							! loop that decrements
	fv = fprime(a + float(i) * h)				! calls fprime function for fv value
	if (mod(i, 2) == 0) then				! if even then set se to
		se = se + fv					! simpson even + fv
	else
		so = so + fv					! else set so to simpson odd + fv
	end if
end do

simpson = (h / 3.0 * (fprime(a) + fprime(b) + 2.0 * se + 4.0 * so)) ! sets simpson to composite simpson equation

return
end

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

real function trapezoid(n, a, b, fprime)			! function for trapezoid
implicit none

integer :: i, n							! declares integer variables
real :: a, b, fprime, h, xuse					! declares real variables

h = (b - a) / float(n)						! sets h to (b - a) / n

trapezoid = 0.0							! initial value of zero

do i = 1, n - 1
	xuse = a + float(i) * h					! sets xuse to a + i * h
	trapezoid = fprime + fprime(xuse)			! sets trapezoid to fprime + fprime(xuse)
end do

trapezoid = h / 2.0 * (2 * trapezoid + fprime(a) + fprime(b))	! sets trapezoid to equation in problem

return
end								! ends function


      SUBROUTINE SB08MD( ACONA, DA, A, RES, E, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute a real polynomial E(s) such that
C
C        (a)  E(-s) * E(s) = A(-s) * A(s) and
C        (b)  E(s) is stable - that is, all the zeros of E(s) have
C             non-positive real parts,
C
C     which corresponds to computing the spectral factorization of the
C     real polynomial A(s) arising from continuous optimality problems.
C
C     The input polynomial may be supplied either in the form
C
C        A(s) = a(0) + a(1) * s + ... + a(DA) * s**DA
C
C     or as
C
C        B(s) = A(-s) * A(s)
C             = b(0) + b(1) * s**2  + ... + b(DA) * s**(2*DA)        (1)
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     ACONA   CHARACTER*1
C             Indicates whether the coefficients of A(s) or B(s) =
C             A(-s) * A(s) are to be supplied as follows:
C             = 'A':  The coefficients of A(s) are to be supplied;
C             = 'B':  The coefficients of B(s) are to be supplied.
C
C     Input/Output Parameters
C
C     DA      (input) INTEGER
C             The degree of the polynomials A(s) and E(s).  DA >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (DA+1)
C             On entry, this array must contain either the coefficients
C             of the polynomial A(s) in increasing powers of s if
C             ACONA = 'A', or the coefficients of the polynomial B(s) in
C             increasing powers of s**2 (see equation (1)) if ACONA =
C             'B'.
C             On exit, this array contains the coefficients of the
C             polynomial B(s) in increasing powers of s**2.
C
C     RES     (output) DOUBLE PRECISION
C             An estimate of the accuracy with which the coefficients of
C             the polynomial E(s) have been computed (see also METHOD
C             and NUMERICAL ASPECTS).
C
C     E       (output) DOUBLE PRECISION array, dimension (DA+1)
C             The coefficients of the spectral factor E(s) in increasing
C             powers of s.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= 5*DA+5.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if on entry, A(I) = 0.0, for I = 1,2,...,DA+1.
C             = 2:  if on entry, ACONA = 'B' but the supplied
C                   coefficients of the polynomial B(s) are not the
C                   coefficients of A(-s) * A(s) for some real A(s);
C                   in this case, RES and E are unassigned;
C             = 3:  if the iterative process (see METHOD) has failed to
C                   converge in 30 iterations;
C             = 4:  if the last computed iterate (see METHOD) is
C                   unstable. If ACONA = 'B', then the supplied
C                   coefficients of the polynomial B(s) may not be the
C                   coefficients of A(-s) * A(s) for some real A(s).
C
C     METHOD
C         _                                               _
C     Let A(s) be the conjugate polynomial of A(s), i.e., A(s) = A(-s).
C
C     The method used by the routine is based on applying the
C     Newton-Raphson iteration to the function
C               _       _
C        F(e) = A * A - e * e,
C
C     which leads to the iteration formulae (see [1]):
C
C        _(i)   (i)  _(i)   (i)     _      )
C        q   * x   + x   * q    = 2 A * A  )
C                                          )   for i = 0, 1, 2,...
C         (i+1)    (i)   (i)               )
C        q     = (q   + x   )/2            )
C
C                    (0)         DA
C     Starting from q   = (1 + s)   (which has no zeros in the closed
C                                                  (1)   (2)   (3)
C     right half-plane), the sequence of iterates q   , q   , q   ,...
C     converges to a solution of F(e) = 0 which has no zeros in the
C     open right half-plane.
C
C     The iterates satisfy the following conditions:
C
C              (i)
C        (a)  q   is a stable polynomial (no zeros in the closed right
C             half-plane) and
C
C              (i)        (i-1)
C        (b)  q   (1) <= q     (1).
C
C                                       (i-1)                       (i)
C     The iterative process stops with q     , (where i <= 30)  if q
C     violates either (a) or (b), or if the condition
C                       _(i) (i)  _
C        (c)  RES  = ||(q   q   - A A)|| < tol,
C
C     is satisfied, where || . || denotes the largest coefficient of
C                     _(i) (i)  _
C     the polynomial (q   q   - A A) and tol is an estimate of the
C                                                    _(i)  (i)
C     rounding error in the computed coefficients of q    q   . If there
C     is no convergence after 30 iterations then the routine returns
C     with the Error Indicator (INFO) set to 3, and the value of RES may
C     indicate whether or not the last computed iterate is close to the
C     solution.
C
C     If ACONA = 'B', then it is possible that the equation e(-s) *
C     e(s) = B(s) has no real solution, which will be the case if A(1)
C     < 0 or if ( -1)**DA * A(DA+1) < 0.
C
C     REFERENCES
C
C     [1] Vostry, Z.
C         New Algorithm for Polynomial Spectral Factorization with
C         Quadratic Convergence II.
C         Kybernetika, 12, pp. 248-259, 1976.
C
C     NUMERICAL ASPECTS
C
C     The conditioning of the problem depends upon the distance of the
C     zeros of A(s) from the imaginary axis and on their multiplicity.
C     For a well-conditioned problem the accuracy of the computed
C     coefficients of E(s) is of the order of RES. However, for problems
C     with zeros near the imaginary axis or with multiple zeros, the
C     value of RES may be an overestimate of the true accuracy.
C
C     FURTHER COMMENTS
C
C     In order for the problem e(-s) * e(s) = B(s) to have a real
C     solution e(s), it is necessary and sufficient that B(j*omega)
C     >= 0 for any purely imaginary argument j*omega (see [1]).
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C     Supersedes Release 2.0 routine SB08AD by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Factorization, Laplace transform, optimal control, optimal
C     filtering, polynomial operations, spectral factorization, zeros.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, HALF, ONE
      PARAMETER         ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         ACONA
      INTEGER           DA, INFO, LDWORK
      DOUBLE PRECISION  RES
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), DWORK(*), E(*)
C     .. Local Scalars ..
      LOGICAL           CONV, LACONA, STABLE
      INTEGER           BINC, DA1, I, I0, J, K, LAMBDA, LAY, LAYEND,
     $                  LDIF, LPHEND, LPHI, LQ, M, NC
      DOUBLE PRECISION  A0, EPS, MU, MUJ, SI, SIGNI, SIGNI0, SIGNJ,
     $                  SIMIN1, SQRTA0, SQRTMJ, SQRTMU, TOLPHI, W, XDA
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           IDAMAX
      DOUBLE PRECISION  DLAMCH
      EXTERNAL          DLAMCH, IDAMAX, LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, SB08MY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MOD, SQRT
C     .. Executable Statements ..
C
      INFO = 0
      LACONA = LSAME( ACONA, 'A' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LACONA .AND. .NOT.LSAME( ACONA, 'B' ) ) THEN
         INFO = -1
      ELSE IF( DA.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDWORK.LT.5*DA + 5 ) THEN
         INFO = -7
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB08MD', -INFO )
         RETURN
      END IF
C
      IF ( .NOT.LACONA ) THEN
         CALL DCOPY( DA+1, A, 1, E, 1 )
      ELSE
         W = ZERO
         CALL SB08MY( DA, A, E, W )
      END IF
C
C     Reduce E such that the first and the last element are non-zero.
C
      DA1 = DA + 1
C
C     WHILE ( DA1 >= 1 and E(DA1) = 0 ) DO
   20 IF ( DA1.GE.1 ) THEN
         IF ( E(DA1).EQ.ZERO ) THEN
            DA1 = DA1 - 1
            GO TO 20
         END IF
      END IF
C     END WHILE 20
C
      DA1 = DA1 - 1
      IF ( DA1.LT.0 ) THEN
         INFO = 1
         RETURN
      END IF
C
      I0 = 1
C
C     WHILE ( E(I0) = 0 ) DO
   40 IF ( E(I0).EQ.ZERO ) THEN
         I0 = I0 + 1
         GO TO 40
      END IF
C     END WHILE 40
C
      I0 = I0 - 1
      IF ( I0.NE.0 ) THEN
         IF ( MOD( I0, 2 ).EQ.0 ) THEN
            SIGNI0 = ONE
         ELSE
            SIGNI0 = -ONE
         END IF
C
         DO 60 I = 1, DA1 - I0 + 1
            E(I) = SIGNI0*E(I+I0)
   60    CONTINUE
C
         DA1 = DA1 - I0
      END IF
      IF ( MOD( DA1, 2 ).EQ.0 ) THEN
         SIGNI = ONE
      ELSE
         SIGNI = -ONE
      END IF
      NC = DA1 + 1
      IF ( ( E(1).LT.ZERO ) .OR. ( ( E(NC)*SIGNI ).LT.ZERO ) ) THEN
         INFO = 2
         RETURN
      END IF
C
C     Initialization.
C
      EPS = DLAMCH( 'Epsilon' )
      SI = ONE/DLAMCH( 'Safe minimum' )
      LQ = 1
      LAY = LQ + NC
      LAMBDA = LAY + NC
      LPHI = LAMBDA + NC
      LDIF = LPHI + NC
C
      A0 = E(1)
      BINC = 1
C
C     Computation of the starting polynomial and scaling of the input
C     polynomial.
C
      MU = ( A0/ABS( E(NC) ) )**( ONE/DBLE( DA1 ) )
      MUJ = ONE
C
      DO 80 J = 1, NC
         W = E(J)*MUJ/A0
         A(J) = W
         E(J) = BINC
         DWORK(LQ+J-1) = BINC
         MUJ = MUJ*MU
         BINC = BINC*( NC - J )/J
   80 CONTINUE
C
      CONV = .FALSE.
      STABLE = .TRUE.
C
C     The contents of the arrays is, cf [1],
C
C     E : the last computed stable polynomial q   ;
C                                              i-1
C     DWORK(LAY+1,...,LAY+DA1-1)  : a'(1), ..., a'(DA1-1), these values
C                                   are changed during the computation
C                                   into y;
C          (LAMBDA+1,...,LAMBDA+DA1-2) : lambda(1), ..., lambda(DA1-2),
C                                        the factors of the Routh
C                                        stability test, (lambda(i) is
C                                        P(i) in [1]);
C          (LPHI+1,...,LPHI+DA1-1) : phi(1), ..., phi(DA1-1), the values
C                                    phi(i,j), see [1], scheme (11);
C          (LDIF,...,LDIF+DA1) : the coeffs of q (-s) * q (s) - b(s).
C                                               i        i
C     DWORK(LQ,...,LQ+DA1) : the last computed polynomial q .
C                                                          i
      I = 0
C
C     WHILE ( I < 30 and CONV = FALSE and STABLE = TRUE ) DO
  100 IF ( I.LT.30 .AND. .NOT.CONV .AND. STABLE ) THEN
         I = I + 1
         CALL DCOPY( NC, A, 1, DWORK(LAY), 1 )
         CALL DCOPY( NC, DWORK(LQ), 1, DWORK(LPHI), 1 )
         M = DA1/2
         LAYEND = LAY + DA1
         LPHEND = LPHI + DA1
         XDA = A(NC)/DWORK(LQ+DA1)
C
         DO 120 K = 1, M
            DWORK(LAY+K) = DWORK(LAY+K) - DWORK(LPHI+2*K)
            DWORK(LAYEND-K) = DWORK(LAYEND-K) - DWORK(LPHEND-2*K)*XDA
  120    CONTINUE
C
C        Computation of lambda(k) and y(k).
C
         K = 1
C
C        WHILE ( K <= DA1 - 2 and STABLE = TRUE ) DO
  140    IF ( ( K.LE.( DA1 - 2 ) ) .AND. STABLE ) THEN
            IF ( DWORK(LPHI+K).LE.ZERO ) STABLE = .FALSE.
            IF ( STABLE ) THEN
               W = DWORK(LPHI+K-1)/DWORK(LPHI+K)
               DWORK(LAMBDA+K) = W
               CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2,
     $                                        DWORK(LPHI+K+1), 2 )
               W = DWORK(LAY+K)/DWORK(LPHI+K)
               DWORK(LAY+K) = W
               CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LPHI+K+2), 2,
     $                                        DWORK(LAY+K+1), 1 )
               K = K + 1
            END IF
            GO TO 140
         END IF
C        END WHILE 140
C
         IF ( DWORK(LPHI+DA1-1).LE.ZERO ) THEN
            STABLE = .FALSE.
         ELSE
            DWORK(LAY+DA1-1) = DWORK(LAY+DA1-1)/DWORK(LPHI+DA1-1)
         END IF
C
C        STABLE = The polynomial q    is stable.
C                                 i-1
         IF ( STABLE ) THEN
C
C           Computation of x  and q .
C                           i      i
C
            DO 160 K = DA1 - 2, 1, -1
               W = DWORK(LAMBDA+K)
               CALL DAXPY( ( DA1 - K )/2, -W, DWORK(LAY+K+1), 2,
     $                                        DWORK(LAY+K), 2 )
  160       CONTINUE
C
            DWORK(LAY+DA1) = XDA
C
            CALL DCOPY( NC, DWORK(LQ), 1, E, 1 )
            SIMIN1 = SI
            SI = DWORK(LQ)
            SIGNJ = -ONE
C
            DO 180 J = 1, DA1
               W = HALF*( DWORK(LQ+J) + SIGNJ*DWORK(LAY+J) )
               DWORK(LQ+J) = W
               SI = SI + W
               SIGNJ = -SIGNJ
  180       CONTINUE
C
            TOLPHI = EPS
            CALL SB08MY( DA1, E, DWORK(LDIF), TOLPHI )
            CALL DAXPY( NC, -ONE, A, 1, DWORK(LDIF), 1 )
            RES = ABS( DWORK( IDAMAX( NC, DWORK(LDIF), 1 ) + LDIF-1 ) )
C
C           Convergency test.
C
            IF ( ( SI.GT.SIMIN1 ) .OR. ( RES.LT.TOLPHI ) ) THEN
               CONV = .TRUE.
            END IF
            GO TO 100
         END IF
      END IF
C     END WHILE 100
C
C     Backscaling.
C
      MU = ONE/MU
      SQRTA0 = SQRT( A0 )
      SQRTMU = SQRT( MU )
      MUJ = ONE
      SQRTMJ = ONE
C
      DO 200 J = 1, NC
         E(J) = E(J)*SQRTA0*SQRTMJ
         A(J) = A(J)*A0*MUJ
         MUJ = MUJ*MU
         SQRTMJ = SQRTMJ*SQRTMU
  200 CONTINUE
C
      IF ( I0.NE.0 ) THEN
C
         DO 220 J = NC, 1, -1
            E(I0+J) = E(J)
            A(I0+J) = SIGNI0*A(J)
  220    CONTINUE
C
         DO 240 J = 1, I0
            E(J) = ZERO
            A(J) = ZERO
  240    CONTINUE
C
      END IF
C
      IF ( .NOT.CONV ) THEN
         IF ( STABLE ) THEN
            INFO = 3
         ELSE
            INFO = 4
         END IF
      END IF
C
      RETURN
C *** Last line of SB08MD ***
      END


      PROGRAM nodplane2
C----
C Compute the second nodal plane of a double couple source
C given strike, dip, rake
C
C x: parallel to input strike
C y: horizontal up-dip relative to input strike
C z: vertical up
C----
      IMPLICIT none
      REAL*8 pi,d2r,r2d
      PARAMETER (pi=4.0d0*datan(1.0d0),d2r=pi/1.8d2,r2d=1.8d2/pi)
      REAL*8 str1,dip1,rak1,str,dip,rak,str2,dip2,rak2
      REAL*8 xn1,yn1,zn1,xr,yr,zr,xs2,ys2,zs2,dum1,dum2
      CHARACTER*80 txt

C Read from standard input
  100 read (*,'(A)',end=101) txt
      read(txt,*) str1,dip1,rak1
      str = d2r*str1
      dip = d2r*dip1
      rak = d2r*rak1

C Normal vector to input plane
      xn1 =  dsin(dip)*dcos(str)
      yn1 = -dsin(dip)*dsin(str)
      zn1 =  dcos(dip)

C Rake vector of input plane
      xr =  dcos(rak)*dsin(str) - dcos(dip)*dsin(rak)*dcos(str)
      yr =  dcos(rak)*dcos(str) + dcos(dip)*dsin(rak)*dsin(str)
      zr =  dsin(rak)*dsin(dip)
      ! If vector points downward, flip it
      if (zr.lt.0.0d0) then
          xr = -xr
          yr = -yr
          zr = -zr
          xn1 = -xn1
          yn1 = -yn1
          zn1 = -zn1
      endif
      !print *,"NOR ",xn1,yn1,zn1
      !print *,"RAK ",xr,yr,zr

C Compute new strike
      str2 = r2d*datan2(xr,yr) - 90.0d0
      if (str2.gt.360.0d0) str2 = str2 - 360.0d0
      if (str2.lt.0.0d0) str2 = str2 + 360.0d0

C Compute new dip
      dip2 = r2d*datan(dsqrt(xr*xr+yr*yr)/zr)

C Compute new rake
      xs2 = dsin(str2*d2r)
      ys2 = dcos(str2*d2r)
      zs2 = 0.0d0
      !print *,"NEW RAK ",xs2,ys2,zs2
      !print *,xn1*xs2+yn1*ys2+zn1*zs2
      rak2 = r2d*dacos(xn1*xs2+yn1*ys2+zn1*zs2)

C Check rake is pos or neg
      dum1 = xs2*yn1 - ys2*xn1
      if (dum1.lt.0.0d0) then
          rak2 = -rak2
      endif

      write(*,9999) str2,dip2,rak2
      goto 100
  101 continue

9999  format(3F12.1)
      END

C      if (z.gt.0.and.x.gt.0) then
C          str2 = str1 - 90.0 - r2d*atan(y/x)
C      elseif (z.gt.0.and.x.lt.0) then
C          str2 = str1 + 90.0 + r2d*atan(abs(y/x))
C      elseif (z.lt.0.and.x.gt.0) then
C          z = -z
C          x = -x
C          y = -y
C          str2 = str1 - 180.0 - r2d*atan(x/y)
C      elseif (z.lt.0.and.x.lt.0) then
C          z = -z
C          x = -x
C          y = -y
C          str2 = str1 + 90.0 - r2d*atan(y/x)
C      elseif (x.eq.1.0) then
C          str2 = str1 - 90.0
C      endif