MODULE common_mtx
!=======================================================================
!
! [PURPOSE:] Matrix Functions
!
! [CREATED:] 07/20/2004 Takemasa Miyoshi
! [UPDATED:] 10/16/2004 Takemasa Miyoshi
!
! [PUBLIC:]
!   mtx_eigen  : eigenvalue decomposition
!   mtx_inv    : real symmetric matrix inverse
!   mtx_sqrt   : real symmetric matrix square root
!
! [REFERENCES:]
!    Core subroutines are adapted from netlib.org
!
! [HISTORY:]
!  07/20/2003 Takemasa Miyoshi  Created at University of Maryland, College Park
!
!=======================================================================
  USE common

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: mtx_eigen, mtx_inv, mtx_sqrt, mtx_inv_rg

CONTAINS
!=======================================================================
!  Eigenvalue decomposition using subroutine rs
!    INPUT
!      INTEGER :: imode           : mode switch (0: only eiven values)
!      INTEGER :: n               : dimension of matrix
!      REAL(r_size) :: a(n,n)     : input matrix
!    OUTPUT
!      REAL(r_size) :: eival(n)   : eiven values in decending order
!                                   i.e. eival(1) is the largest
!      REAL(r_size) :: eivec(n,n) : eiven vectors
!      INTEGER :: nrank_eff       : number of positive eivenvalues
!=======================================================================
SUBROUTINE mtx_eigen(imode,n,a,eival,eivec,nrank_eff)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: imode ! 0: calculate only eigen values
  INTEGER,INTENT(IN) :: n
  REAL(r_size),INTENT(IN) :: a(1:n,1:n)
  REAL(r_size),INTENT(OUT) :: eival(1:n)
  REAL(r_size),INTENT(OUT) :: eivec(1:n,1:n)
  INTEGER,INTENT(OUT) :: nrank_eff

  REAL(r_dble) :: a8(n,n)
  REAL(r_dble) :: eival8(n)
  REAL(r_dble) :: eivec8(n,n)
  REAL(r_dble) :: wrk1(n)
  REAL(r_dble) :: wrk2(n)
  INTEGER :: ierr,i,j

  a8 = a
  eivec8 = 0.0d0
  CALL rs(n,n,a8,eival8,imode,eivec8,wrk1,wrk2,ierr)
  IF( ierr/=0 ) THEN
    WRITE(6,'(A,I)') '!!! ERROR (mtx_eigen): rs error code is ',ierr
    STOP 2
  END IF

  nrank_eff = n
  IF( eival8(n) > 0 ) THEN
    DO i=1,n
      IF( eival8(i) < ABS(eival8(n))*SQRT(EPSILON(eival8)) ) THEN
        nrank_eff = nrank_eff - 1
        eival8(i) = 0.0d0
        eivec8(:,i) = 0.0d0
      END IF
    END DO
  ELSE
    WRITE(6,'(A)') '!!! ERROR (mtx_eigen): All Eigenvalues are below 0'
    !STEVE:
    print *, "a = ", a
    print *, "eival8 = ", eival8
    print *, "imode = ", imode
    print *, "eivec8 = ", eivec8
    print *, "wrk1 = ", wrk1
    print *, "wrk2 = ", wrk2
    print *, "ierr = ", ierr
    !STEVE: end
    STOP 2
  END IF

  IF( nrank_eff<n .AND. eival8(1)/=0 ) THEN
    j = 0
    DO i=n,1,-1
      IF( eival8(i) == 0 ) THEN
        eival8(i) = eival8(n-nrank_eff-j)
        eivec(:,i) = eivec8(:,n-nrank_eff-j)
        eival8(n-nrank_eff-j) = 0.0d0
        eivec8(:,n-nrank_eff-j) = 0.0d0
        j = j+1
      END IF
    END DO
  END IF

  DO i=1,n
    eival(i) = eival8(n+1-i)
    eivec(:,i) = eivec8(:,n+1-i)
  END DO

END SUBROUTINE mtx_eigen
!=======================================================================
!  Real symmetric matrix inversion using subroutine dspdi
!    INPUT
!      INTEGER :: n               : dimension of matrix
!      REAL(r_size) :: a(n,n)     : input matrix (real symmetric)
!    OUTPUT
!      REAL(r_size) :: ainv(n,n)  : inverse of a
!=======================================================================
SUBROUTINE mtx_inv(n,a,ainv)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: n
  REAL(r_size),INTENT(IN) :: a(1:n,1:n)
  REAL(r_size),INTENT(OUT) :: ainv(1:n,1:n)

  REAL(r_dble) :: acmp(n*(n+1)/2)
  REAL(r_dble) :: det(2)
  REAL(r_dble) :: work(n)
  INTEGER :: kpvt(n)
  INTEGER :: inert(3)
  INTEGER :: info
  INTEGER :: i,j,k

  IF(n==1) THEN
    ainv(1,1) = 1.0d0 / a(1,1)
  ELSE

!-----------------------------------------------------------------------
!  Packed form of matrix
!-----------------------------------------------------------------------
  k=0
  DO j=1,n
    DO i=1,j
      k = k+1
      acmp(k) = a(i,j)
    END DO
  END DO
!-----------------------------------------------------------------------
!  dspfa
!-----------------------------------------------------------------------
  CALL dspfa(acmp,n,kpvt,info)
  IF(info /= 0) THEN
    WRITE(6,'(A,I)') '!!! ERROR (mtx_inv): dspfa error code is ',info
    STOP 3
  END IF
!-----------------------------------------------------------------------
!  dspdi
!-----------------------------------------------------------------------
  CALL dspdi(acmp,n,kpvt,det,inert,work,001)
!-----------------------------------------------------------------------
!  unpack matrix
!-----------------------------------------------------------------------
  k=0
  DO j=1,n
    DO i=1,j
      k = k+1
      ainv(i,j) = acmp(k)
    END DO
  END DO

  DO j=1,n
    DO i=j+1,n
      ainv(i,j) = ainv(j,i)
    END DO
  END DO

  END IF

END SUBROUTINE mtx_inv
!=======================================================================
!  Compute square root of real symmetric matrix
!    INPUT
!      INTEGER :: n                : dimension of matrix
!      REAL(r_size) :: a(n,n)      : input matrix (real symmetric)
!    OUTPUT
!      REAL(r_size) :: a_sqrt(n,n) : square root of a
!=======================================================================
SUBROUTINE mtx_sqrt(n,a,a_sqrt)
  IMPLICIT NONE

  INTEGER,INTENT(IN) :: n
  REAL(r_size),INTENT(IN) :: a(1:n,1:n)
  REAL(r_size),INTENT(OUT) :: a_sqrt(1:n,1:n)

  REAL(r_size) :: eival(n)   ! holds eivenvalue of a
  REAL(r_size) :: eivec(n,n) ! holds eivenvector of a
  REAL(r_size) :: wk(n,n)
  INTEGER :: i,j,k

  CALL mtx_eigen(1,n,a,eival,eivec,i)

  DO i=1,n
    wk(:,i) = eivec(:,i) * SQRT( eival(i) )
  END DO

!  a_sqrt = matmul(wk,transpose(eivec))
  DO j=1,n
    DO i=1,n
      a_sqrt(i,j) = wk(i,1)*eivec(j,1)
      DO k=2,n
        a_sqrt(i,j) = a_sqrt(i,j) + wk(i,k)*eivec(j,k)
      END DO
    END DO
  END DO

END SUBROUTINE mtx_sqrt
!=======================================================================
!  Compute inverse of a real matrix (not necessarily symmetric)
!    INPUT
!      INTEGER :: n            : dimension of matrix
!      REAL(r_size) :: aa(n,n) : input matrix (real symmetric)
!    OUTPUT
!      REAL(r_size) :: ff(n,n) : square root of a
!*** COPIED FROM 'A0568.NEW.FORT(MTXINV)' ON 1989.10.1
!    changed to free format by H.Yoshimura 2000.06.27
!    adapted by T.Miyoshi on 2005.10.31
!=======================================================================
SUBROUTINE mtx_inv_rg(n,aa,ff)
!
!##  MATRIX INVERSION
!##  AA IS THE MATRIX TO BE INVERTED
!##  FF IS THE INVERSE OF AA
!
  INTEGER,INTENT(IN) :: n
  REAL(r_size),INTENT(IN) :: aa(n,n)
  REAL(r_size),INTENT(OUT) :: ff(n,n)
!
  REAL(r_size) :: a(n,n)
  REAL(r_size) :: b(n,n)
  REAL(r_size) :: x(n,n)
!
  REAL(r_size) :: c,cc,xx
  INTEGER :: i,j,n1,k,kp,jx,ii,jr,jp
!-------------------------------------------------------
  n1=n-1
!
  do i=1,n
    do j=1,n
      a(i,j)=aa(i,j)
    end do
  end do
!
  do i=1,n
    do j=1,n
      b(i,j)=0.d0
      if( i == j ) b(i,j)=1.d0
    end do
  end do
!
  do j=1,n
    c=abs(a(1,j))
    do i=2,n
      c=max(c,abs(a(i,j)))
    end do
    c=1.d0/c
    do i=1,n
      a(i,j)=a(i,j)*c
    end do
    b(j,j)=b(j,j)*c
  end do
!
  do k=1,n1
    c=abs(a(k,k))
    kp=k+1
    jx=k
    do j=kp,n
      cc=abs(a(k,j))
      if ( cc < c ) cycle
      c=cc
      jx=j
    end do
    do i=k,n
      c=a(i,k)
      a(i,k)=a(i,jx)
      a(i,jx)=c
    end do
    do i=1,n
      c=b(i,k)
      b(i,k)=b(i,jx)
      b(i,jx)=c
    end do
    do j=kp,n
      c=a(k,j)/a(k,k)
      do ii=1,n
        b(ii,j)=b(ii,j)-c*b(ii,k)
      end do
      do i=k,n
        a(i,j)=a(i,j)-c*a(i,k)
      end do
    end do
  end do
!
  do ii=1,n
    x(ii,n)=b(ii,n)/a(n,n)
    do j=1,n1
      jr=n-j
      jp=jr+1
      xx=0.d0
      do i=jp,n
        xx=xx+a(i,jr)*x(ii,i)
      end do
      x(ii,jr)=(b(ii,jr)-xx)/a(jr,jr)
    end do
  end do
!
  do i=1,n
    do j=1,n
      ff(i,j)=x(i,j)
    end do
  end do
!
END SUBROUTINE mtx_inv_rg

END MODULE common_mtx


subroutine dist(coord1,coord2,n,dist_matrix)

! Obtains the distance matrix between sites in pymatgen structure, used to
! obtain a neighbour list for sites (and is faster than using the
! python version in pymatgen)
! Args:
!     coord1 ([[real,real,real],...]): array of site coords
!     coord2 ([[real,real,real],...]): array of site coords
!     n (int): number of elements in coord arrays
! Return:
!     dist_matrix([n X n array of reals]): dist matrix for sites

use omp_lib

IMPLICIT NONE

integer, intent(in) :: n

real,dimension(n,3),intent(in) :: coord1,coord2
real,dimension(n,n),intent(out) :: dist_matrix
integer:: i,j

!$OMP PARALLEL DO private(i,j) shared(coord1,coord2,dist_matrix)
do i=1,n
  do j=1,n
     dist_matrix(i,j) = ((coord1(i,1)-coord2(j,1))* (coord1(i,1)-coord2(j,1))+&
                        (coord1(i,2)-coord2(j,2))* (coord1(i,2)-coord2(j,2))+&
                        (coord1(i,3)-coord2(j,3))* (coord1(i,3)-coord2(j,3)))**0.5
  END DO
END DO
!$OMP END PARALLEL DO

end subroutine dist

subroutine shift_index(index_n,shift,new_index)

! Shifts the index of a site in the unit cell to the corresponding
! index in the 3x3x3 halo supercell.
! Used when getting neighbour list for supercell from unit cell neighbour list
!
! Args:
!    index_n (int): original index
!    shift ([int,int,int]): shift to image for which to obatin index eg. [-1,-1,-1]
!
! Returns:
!    new_index (int): index for image site in supercell

IMPLICIT NONE

integer, intent(in) :: index_n
integer, dimension(3), intent(in):: shift
integer, intent(out) :: new_index

integer::new_x,new_y,new_z

new_x = MODULO((MODULO(int(index_n/9),3)+shift(1)),3)
new_y = MODULO((MODULO(int(index_n/3),3)+shift(2)),3)
new_z = MODULO((MODULO(index_n,3)+shift(3)),3)

new_index = int(27*int(index_n/(27))+(MODULO(new_x,3)*9+MODULO(new_y,3)*3+MODULO(new_z,3)))
end subroutine shift_index


!
! Copyright (c) 2004-2005 The Trustees of Indiana University and Indiana
!                         University Research and Technology
!                         Corporation.  All rights reserved.
! Copyright (c) 2004-2005 The University of Tennessee and The University
!                         of Tennessee Research Foundation.  All rights
!                         reserved.
! Copyright (c) 2004-2005 High Performance Computing Center Stuttgart,
!                         University of Stuttgart.  All rights reserved.
! Copyright (c) 2004-2005 The Regents of the University of California.
!                         All rights reserved.
! $COPYRIGHT$
!
! Additional copyrights may follow
!
! $HEADER$
!
! print_prec_range.f90
!   - prints out values of precision and range for real types
!
program main
  real :: xr
  real(kind(1.0D0)) :: xd
  real(selected_real_kind(5)) :: x5
  real(selected_real_kind(6)) :: x6
  real(selected_real_kind(7)) :: x7
  real(selected_real_kind(14)) :: x14
  real(selected_real_kind(15)) :: x15
  real(selected_real_kind(16)) :: x16
  real(selected_real_kind(30)) :: x30
  real(selected_real_kind(31)) :: x31
  real(selected_real_kind(32)) :: x32

  print *, "precision(p=5) = ", precision(x5), " range(p=5) = ", range(x5)
  print *, "precision(p=6) = ", precision(x6), " range(p=6) = ", range(x6)
  print *, "precision(p=7) = ", precision(x7), " range(p=7) = ", range(x7)
  print *, "precision(p=14) = ", precision(x14), " range(p=14) = ", range(x14)
  print *, "precision(p=15) = ", precision(x15), " range(p=15) = ", range(x15)
  print *, "precision(p=16) = ", precision(x16), " range(p=16) = ", range(x16)
  print *, "precision(p=30) = ", precision(x30), " range(p=30) = ", range(x30)
  print *, "precision(p=31) = ", precision(x31), " range(p=31) = ", range(x31)
  print *, "precision(p=32) = ", precision(x32), " range(p=32) = ", range(x32)
  print *
  print *, "precision(r) = ", precision(xr), " range(r) = ", range(r)
  print *, "precision(d) = ", precision(xd), " range(d) = ", range(d)

end program main


module shared_data

  implicit none

  ! intrinsics

  integer :: out_unit = 10
  integer, parameter :: num=selected_real_kind(p=15)
  real(num) :: pi = 4.0_num * ATAN(1.0_num)
 ! core solver

  integer :: nx, ny
  integer :: ix, iy

  real(num) :: x_min, x_max
  real(num) :: y_min, y_max
  real(num) :: dx, dy

  real(num), dimension(:), allocatable :: xc, yc !xb, yc, yb

  real(num), dimension(:,:), allocatable :: phi

  contains

  subroutine setup

    ! two ghosts are allocated because thats what we have in CCAPS

    allocate(xc(-1:nx+2))
    allocate(yc(-1:ny+2))

    dx = (x_max - x_min) / real(nx,num)
    xc(-1) = x_min - 3.0_num * dx / 2.0_num
    do ix = 0,nx+2
      xc(ix) = xc(ix-1) + dx
    enddo

    dy = (y_max - y_min) / real(ny,num)
    yc(-1) = y_min - 3.0_num * dy / 2.0_num
    do iy = 0,ny+2
      yc(iy) = yc(iy-1) + dy
    enddo

    allocate(phi(-1:nx+2,-1:ny+2)) ! again, redundant ghosts but for comparison to CCAPS
    phi = 0.0_num
  end subroutine setup

end module shared_data


program floor_01
  real, parameter :: x1 = 3.3 ! 3
  real, parameter :: x2 = 3.5 ! 3
  real, parameter :: x3 = 3.7 ! 3
  real, parameter :: y1 = -3.3 ! -4
  real, parameter :: y2 = -3.5 ! -4
  real, parameter :: y3 = -3.7 ! -4
  print*, floor(x1), floor(x2), floor(x3)
  print*, floor(y1), floor(y2), floor(y3)
end program


module lnumz
    integer, parameter:: b4 = selected_real_kind(4)
end module
module pmatrix
interface print_matrix
      subroutine print_matrixc( desc, m, n, a, lda )
      use lnumz
      implicit none
      character*(*) desc
      integer m, n, lda
      complex(b4) a( lda, * )
      end subroutine print_matrixc
      subroutine print_matrixr( desc, m, n, a, lda )
      use lnumz
      implicit none
      character*(*) desc
      integer m, n, lda
      real(b4) a( lda, * )
      end subroutine print_matrixr
end interface
end module
module csolve
    use lnumz
    contains
        subroutine ludcmp(a,n,np,indx,d)
        use lnumz
        implicit none
        integer n,np,indx(n)
        complex(b4) a(np,*),tiny
        complex(b4) :: tmp
        complex(b4) :: sum
        integer d
        parameter (tiny=1.0e-20_b4)
        integer i,imax,j,k
        real(b4),allocatable :: vv(:)
        real(b4) :: aamax,dum
        allocate(vv(n))
        d=1.0_b4
        do i=1,n
          aamax=0.0_b4
          do j=1,n
             if(abs(a(i,j)) .gt.  aamax) aamax=abs(a(i,j))
          enddo
          if( aamax .eq. 0.0_b4)then
              write(*,*)"sigular matrix"
              stop
          endif
          vv(i)=1.0_b4/aamax
        enddo
        do j=1,n
          do i=1,j-1
            sum=a(i,j)
            do k=1,i-1
                sum=sum-a(i,k)*a(k,j)
            enddo
            a(i,j)=sum
          enddo
          aamax=0.0_b4
          do i=j,n
            sum=a(i,j)
            do k=1,j-1
              sum=sum-a(i,k)*a(k,j)
            enddo
            a(i,j)=sum
            dum=vv(i)*abs(sum)
            if (dum .ge. aamax)then
              imax=i
              aamax=dum
            endif
          enddo
          if ( j .ne. imax)then
            do k=1,n
              tmp=a(imax,k)
              a(imax,k)=a(j,k)
              a(j,k)=tmp
            enddo
            d=-d
            vv(imax)=vv(j)
          endif
          indx(j)=imax
          if(a(j,j) .eq. 0.0_b4)a(j,j)=tiny
          if(j .ne. n)then
            tmp=1.0_b4/a(j,j)
            do i=j+1,n
                a(i,j)=a(i,j)*tmp
            enddo
          endif
         enddo
         deallocate(vv)
         end subroutine

         subroutine lubksb(a,n,np,indx,b)
         use lnumz
         implicit none
         integer n,np,indx(n)
         complex(b4) :: a(np,np),b(n)
         integer i,ii,j,ll
         complex(b4) sum
         ii=0
         do i=1,n
           ll=indx(i)
           sum=b(ll)
           b(ll)=b(i)
           if (ii .ne. 0)then
             do j=ii,i-1
               sum=sum-a(i,j)*b(j)
             enddo
           else if (sum .ne. 0.0_b4) then
             ii=i
           endif
           b(i)=sum
         enddo
         do i=n,1,-1
           sum=b(i)
           do j=i+1,n
             sum=sum-a(i,j)*b(j)
           enddo
             b(i)=sum/a(i,i)
         enddo
         end subroutine
end module

program bonk
  use lnumz
  use pmatrix
  complex (b4) a(4,4),b(5,2)
  integer indx(4)
  integer nrhs,lda,ldb,info
  data  a/ &
      ( 1.23,-5.50),(-2.14,-1.12),(-4.30,-7.10),( 1.27, 7.29), &
      ( 7.91,-5.38),(-9.92,-0.79),(-6.47, 2.52),( 8.90, 6.92), &
      (-9.80,-4.86),(-9.18,-1.12),(-6.51,-2.67),(-8.82, 1.25), &
      (-7.32, 7.57),( 1.37, 0.43),(-5.86, 7.38),( 5.41, 5.37)  /
  data  b/ &
      ( 8.33,-7.32),(-6.18,-4.80),(-5.71,-2.80),(-1.60, 3.08), (123.0,   456.0), &
      (-6.11,-3.81),( 0.14,-7.71),( 1.41, 3.40),( 8.54,-4.05), (789.0,  1010.0) /
  n=4
  np=4
!  call ludcmp(a,n,np,indx,id)
!  call lubksb(a,n,np,indx,b)
  nrhs=2
  lda=4
  ldb=5
  call cgesv( n, nrhs, a, lda, indx, b, ldb, info )
  call print_matrix( "details of lu factorization", 4, 4, a, lda )
  call print_matrix( "solution", 4, 2, b, ldb )
end program

! solution
! ( -1.09, -0.18) (  1.28,  1.21)
! (  0.97,  0.52) ( -0.22, -0.97)
! ( -0.20,  0.19) (  0.53,  1.36)
! ( -0.59,  0.92) (  2.22, -1.00)
!
! details of lu factorization
! ( -4.30, -7.10) ( -6.47,  2.52) ( -6.51, -2.67) ( -5.86,  7.38)
! (  0.49,  0.47) ( 12.26, -3.57) ( -7.87, -0.49) ( -0.98,  6.71)
! (  0.25, -0.15) ( -0.60, -0.37) (-11.70, -4.64) ( -1.35,  1.38)
! ( -0.83, -0.32) (  0.05,  0.58) (  0.93, -0.50) (  2.66,  7.86)

subroutine cgesv( n, nrhs, a, lda, ipiv, b, ldb, info )
  use lnumz
  use csolve
  implicit none
  integer n,nrhs,lda,ldb,info
  integer j
  complex(b4) :: a(lda,*),b(ldb,*)
  integer ipiv(*)
  call ludcmp(a,n,lda,ipiv,info)
  do j=1,nrhs
    call lubksb(a,n,lda,ipiv,b(:,j))
  enddo
end subroutine

      subroutine print_matrixc( desc, m, n, a, lda )
      use lnumz
      implicit none
      character*(*)    desc
      integer          m, n, lda
      complex(b4)          a( lda, * )
!
      integer          i, j
!
      write(*,*)
      write(*,*) desc
      do i = 1, m
         write(*,9998) ( a( i, j ), j = 1, n )
      end do
!
 9998 format( 11(:,1x,'(',f6.2,',',f6.2,')') )
      return
      end subroutine

      subroutine print_matrixr( desc, m, n, a, lda )
      use lnumz
      implicit none
      character*(*)    desc
      integer          m, n, lda
      real(b4)          a( lda, * )
!
      integer          i, j
!
      write(*,*)
      write(*,*) desc
      do i = 1, m
         write(*,9998) ( a( i, j ), j = 1, n )
      end do
!
 9998 format( 22(:,1x,f6.2) )
      return
      end subroutine


! NOTE: this example is unsupported by the implementation
program monte_carlo_pi
  use iso_fortran_env, only : STAT_FAILED_IMAGE
  implicit none
  integer, parameter :: NFAIL=2, NSAMPLES=10**6
  integer :: i, status, n_i, n[*], active_images = 1
  double precision :: x, y

  call random_init(repeatable=.true., image_distinct=.true.)

  n = 0

  do i = 1, NSAMPLES
    call random_number(x); call random_number(y)
    if (hypot(x, y) <= 1) n = n + 1
  end do

  ! simulate failure in last NFAIL images
  if (num_images() - this_image() < NFAIL) fail image

  if (this_image() == 1) then
    do i = 2, num_images()
       sync images(i, stat=status)
       n_i = n[i, stat=status]
       if (status /= STAT_FAILED_IMAGE) then
          n = n + n_i
          active_images = active_images + 1
       end if
    end do
    write(*,*) (4.0d0 * n / NSAMPLES) / active_images
  else
     sync images(1)
  end if
end program monte_carlo_pi


program main
  implicit none
  integer :: i, n, sum

  n = 10
  sum = 0
  do i = 1, n
     sum = sum + i
  end do

  write(*,*)"calculated sum =",sum
  write(*,*)"expected   sum =",n*(n+1)/2

end program main


! fortran_lib.f90
!
! Basic examples of passing different data types to a FORTRAN function and subroutine.
!
! Compiled in Windows using:
! gfortran -fno-underscoring -fPIC fortran_lib.f90 -static -shared -o fortran_lib64.dll
!

! return the sum of two 8-bit signed integers
function sum_8bit(a, b) result(value)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'sum_8bit' :: sum_8bit
    implicit none
    integer(1) :: a, b, value
    value = a + b
end function sum_8bit

! return the sum of two 16-bit signed integers
function sum_16bit(a, b) result(value)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'sum_16bit' :: sum_16bit
    implicit none
    integer(2) :: a, b, value
    value = a + b
end function sum_16bit

! return the sum of two 32-bit signed integers
function sum_32bit(a, b) result(value)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'sum_32bit' :: sum_32bit
    implicit none
    integer(4) :: a, b, value
    value = a + b
end function sum_32bit

! return the sum of two 64-bit signed integers
function sum_64bit(a, b) result(value)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'sum_64bit' :: sum_64bit
    implicit none
    integer(8) :: a, b, value
    value = a + b
end function sum_64bit

! return the product of two 32-bit floating point numbers
function multiply_float32(a, b) result(value)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'multiply_float32' :: multiply_float32
    implicit none
    real(4) :: a, b, value
    value = a * b
end function multiply_float32

! return the product of two 64-bit floating point numbers
function multiply_float64(a, b) result(value)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'multiply_float64' :: multiply_float64
    implicit none
    real(8) :: a, b, value
    value = a * b
end function multiply_float64

! return True if 'a' > 0 else False
function is_positive(a) result(value)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'is_positive' :: is_positive
    implicit none
    logical :: value
    real(8) :: a
    value = a > 0.d0
end function is_positive

! if do_addition is True return a+b otherwise return a-b
function add_or_subtract(a, b, do_addition) result(value)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'add_or_subtract' :: add_or_subtract
    implicit none
    logical :: do_addition
    integer(4) :: a, b, value
    if (do_addition) then
        value = a + b
    else
        value = a - b
    endif
end function add_or_subtract

! compute the n'th factorial of a 8-bit signed integer, return a double-precision number
function factorial(n) result(value)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'factorial' :: factorial
    implicit none
    integer(1) :: n
    integer(4) :: i
    double precision value
    if (n < 0) then
        value = 0.d0
        print *, "Cannot compute the factorial of a negative number", n
    else
        value = 1.d0
        do i = 2, n
            value = value * i
        enddo
    endif
end function factorial

! calculate the standard deviation of an array.
function standard_deviation(a, n) result(var)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'standard_deviation' :: standard_deviation
    integer :: n ! the length of the array
    double precision :: var, a(n)
    var = SUM(a)/SIZE(a) ! SUM is a built-in fortran function
    var = SQRT(SUM((a-var)**2)/(SIZE(a)-1.0))
end function standard_deviation

! compute the Bessel function of the first kind of order 0 of x
function besselj0(x) result(val)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'besselj0' :: besselj0
    double precision :: x, val
    val = BESSEL_J0(x)
end function besselJ0

! reverse a string, 'n' is the length of the original string
subroutine reverse_string(original, n, reversed)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'reverse_string' :: reverse_string
    !DEC$ ATTRIBUTES REFERENCE :: original, reversed
    implicit none
    integer :: i, n
    character(len=n) :: original, reversed
    do i = 1, n
        reversed(i:i) = original(n-i+1:n-i+1)
    end do
end subroutine reverse_string

! element-wise addition of two 1D double-precision arrays
subroutine add_1d_arrays(a, in1, in2, n)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'add_1d_arrays' :: add_1d_arrays
    implicit none
    integer(4) :: n ! the length of the input arrays
    double precision :: in1(n), in2(n) ! the arrays to add (element-wise)
    double precision :: a(n) ! the array that will contain the element-wise sum
    a(:) = in1(:) + in2(:)
    end subroutine add_1D_arrays

! multiply two 2D, double-precision arrays.
! NOTE: multi-dimensional arrays are column-major order in FORTRAN,
!       whereas C (Python) is row-major order.
subroutine matrix_multiply(a, a1, r1, c1, a2, r2, c2)
    !DEC$ ATTRIBUTES DLLEXPORT, ALIAS:'matrix_multiply' :: matrix_multiply
    implicit none
    integer(4) :: r1, c1, r2, c2 ! the dimensions of the input arrays
    double precision :: a1(r1,c1), a2(r2,c2) ! the arrays to multiply
    double precision :: a(r1,c2) ! resultant array
    a = MATMUL(a1, a2)
end subroutine matrix_multiply


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: kB = 1.380649d-23, hbar = 1.05457266d-34, omegac = 1.d13, omegar = 1.d14
    real(dp) :: T, beta, x, y

    open(unit = 1,file = '3-C-T.txt',status = 'unknown')
    T = 0.0d0
    do while (T <= 600)
        beta = 1 / (kB * T)
        x = T
        y = 3 * kB *&
            ((beta * hbar * omegac)**2 * exp(beta * hbar * omegac) / (exp(beta * hbar * omegac) - 1)**2&
            + (beta * hbar * omegar)**2 * exp(beta * hbar * omegar) / (exp(beta * hbar * omegar) - 1)**2) / kB
        write(1,"(2f20.8)") x, y
        T = T + .1d0
    end do
    close(1)
end program main


C***************************************************************************
C************************ SUBROUTINE SCHMIT  *******************************
C***************************************************************************
C
C
       SUBROUTINE SCHMIT(X, Y, NP, NC, DELX, DELY, XORG, YORG, TOL,
     +                   MAX, NTOT, MX, MY, MXY, NM, NU, NL, FC, F, A,
     +                   ALPHA, BETA)
C
C
C      *                                                                    *
C      *          THIS SUBROUTINE COMPUTES LINEAR REGRESSION COEFFICIENTS   *
C      *      ALPHA AND BETA (INTERCEPT AND SLOPE) BY SCHMITT'S BINNED      *
C      *      METHOD. BECAUSE OF THE BINNING METHOD, FINER BINNING GIVES    *
C      *      BETTER RESULTS, THOUGH THE CPU TIME MAY INCREASE VERY         *
C      *      MUCH. ALSO IF THE BINS ARE TOO FINE, THE CENSORED POINTS      *
C      *      MAY NOT FALL ON THE DETECTIONS.                               *
C      *                                                                    *
C      *                                                                    *
C      *      INPUT                                                         *
C      *            X(I): INDEPENDENT VARIABLE                              *
C      *            Y(I): DEPENDENT VARIABLE                                *
C      *           NP(I): INDICATOR OF CENSORED STATUS                      *
C      *                  IF NP(I)=0  : DETECTION                           *
C      *                          =1  : Y(I) IS LOWER LIMIT                 *
C      *                          =2  : X(I) IS LOWER LIMIT                 *
C      *                          =3  : BOTH ARE LOWER LIMITS               *
C      *                          =4  : Y(I) IS LOWER AND X(I) IS UPPER     *
C      *                  FOR THE UPPER LIMITS, CHANGE THE SIGNS            *
C      *           NC(K): NUMBER OF CENSORED POINTS OF EACH TYPE            *
C      *           DELX : BIN SIZE OF X AXIS                                *
C      *           DELY : BIN SIZE OF Y AXIS                                *
C      *           XORG : ORIGIN OF X                                       *
C      *           YORG : ORIGIN OF Y                                       *
C      *           TOL  : TOLERANCE FOR COMPUTAION F(I,J)                   *
C      *           MAX  : MAXIMUM ITERATION                                 *
C      *           NTOT : NUMBER OF DATA POINTS                             *
C      *            MX  : NUMBER OF BINS IN THE INDEPENDENT VARIABLE        *
C      *            MY  : NUMBER OF BINS IN THE DEPENDENT VARIABLE          *
C      *            MXY : TOTAL NUMBER OF BINS                              *
C      *                                                                    *
C      *     OUTPUT                                                         *
C      *       NM(K)    : NUMBER OF LIMITS CHANGED TO DETECTIONS            *
C      *       NU(I,J)  : NUMBER OF UNCENSORED IN THE BIN(I,J)              *
C      *       NL(I,J,K): NUMBER OF Y LOWER LIMITS IN THE BIN(I,J)          *
C      *       FC(I,J)  : COPY OF F(I,J) (TO CHECK THE CONVERGENCE)         *
C      *        F(I,J)  : NUMBER OF DATA POINTS IN BIN(I,J)                 *
C      *        A(I,J)  : MATRIX WHICH CONTAINS INFORMATION OF BIN          *
C      *                  POSITION  I=1,4 AND J=1,MX*MY                     *
C      *          ALPHA : INTERCEPT COEFFICIENT                             *
C      *           BETA : SLOPE COEFFICIENT                                 *
C      *                                                                    *
C      *     WORK                                                           *
C      *       TH(I)    : VECTOR " A(I,J)*F(I,J), I=1,4                     *
C      *        SUM     : TOTAL NUMBER OF POINTS.  THIS IS APPROXIMATELY    *
C      *                  EQUAL TO NTOT.  THE DIFFERENCE BETWEEN THE TWO    *
C      *                  VALUES DEPENDS ON THE TOLERANCE LEVEL.            *
C      *                                                                    *
C      *     SUBROUTINES:                                                   *
C      *         GRDPRB : THE SUBROUTINE WHICH COMPUTES THE TWO-DIMENSIONAL *
C      *                  KAPLAN-MEIER PROBABILITY OF THE BINS              *
C      *                                                                    *

       IMPLICIT REAL*8 (A-H,O-Z), INTEGER (I-N)

       DIMENSION X(NTOT),Y(NTOT),NP(NTOT),NC(8),NM(8),NU(MX,MY)
       DIMENSION NL(MX,MY,8),FC(MX,MY),F(MX,MY),A(5,MXY),TH(5)
C
C      *                CALL SUBROUTINE GRDPRB                              *
C
       CALL GRDPRB (X, Y, NP, NC, DELX, DELY, XORG, YORG, TOL, MAX,
     +              NTOT, MX, MY, NM, NU, NL, FC, F)
C
C
C      *               MAKE MATRIX A(I,J)                                   *
C
       IJ = 0
       DO 1120 J = 1,MY
          DO 1110 I = 1,MX
             IJ = IJ + 1
             XB = XORG + DELX / 2.0 + DELX * (I - 1)
             YB = YORG + DELY / 2.0 + DELY * (J - 1)
C
             A(1,IJ) = XB
             A(2,IJ) = XB ** 2
             A(3,IJ) = XB * YB
             A(4,IJ) = YB
             A(5,IJ) = YB ** 2
 1110     CONTINUE
 1120  CONTINUE
C
C      *             COMPUTE THE VECTOR THETA : TH(I)                       *
C
       DO 1400 I = 1,5
          TH(I) = 0.0
 1400  CONTINUE

       IJ = 0
       DO 1430 J = 1,MY
          DO 1420 I = 1,MX
             IJ = IJ + 1
             DO 1410 K = 1,5
                TH(K) = TH(K) + A(K,IJ) * F(I,J) * NTOT
 1410        CONTINUE
 1420     CONTINUE
 1430  CONTINUE

       SUM = 0.0
       DO 1460 I = 1, MX
          DO 1450 J = 1, MY
             SUM = SUM + F(I,J) * NTOT
 1450     CONTINUE
 1460  CONTINUE

C
C      *     COMPUTE THE SLOPE COEFFICIENT : BETA, AND THE INTERCEPT        *
C      *     COEFFICIENT : ALPHA.                                           *
C
       DEN = SUM * TH(2) - TH(1) ** 2
       BETA = (SUM * TH(3) - TH(1) * TH(4)) / DEN
       ALPHA = (TH(2) * TH(4) - TH(1) * TH(3)) / DEN
C
       RETURN
       END


      REAL*8 FUNCTION GHANGL(TSEC50,KPRECES)
      IMPLICIT REAL*8(A-H,O-Z)
C
C  THIS ROUTINE COMPUTES THE GREENWICH HOUR ANGLE AT A GIVEN TIME FOR
C  EITHER A FIXED OR PRECESSING EQUINOX.
C
C  VARIABLE DIM  TYPE  I/O DESCRIPTION
C  -------- ---  ----  --- -----------
C
C  TSEC50    1   R*8    I  THE TIME FOR WHICH THE GREENWICH HOUR ANGLE
C                          IS WANTED. UNITS ARE MEAN SOLAR SECONDS
C                          SINCE 1/1/50, 0.0 HRS UT.
C                          TSEC50 MAY BE ANY VALUE, + OR -.
C
C                          TSEC50 SHOULD BE COMPUTED USING THE JULIAN
C                          DATE(UT) OF INTEREST MINUS THE JULIAN DATE
C                          OF 1/1/50 0.0 (=2433282.5) MULTIPLIED BY
C                          86400. THAT IS, DO NOT ADD IN LEAP SECONDS.
C
C  KPRECES   1   I*4    I  A FLAG INDICATING THE COORDINATE SYSTEM
C                          TO WHICH THE HOUR ANGLE IS REFERENCED.
C                          = 0, MEAN EQUATOR AND EQUINOX OF 1950.0
C                          = OTHERWISE, MEAN OF DATE.
C
C  GHANGL    1   R*8    O  THE GREENWICH HOUR ANGLE MEASURED IN A
C                          POSITIVE SENSE(EASTWARD) IN THE EQUATORIAL
C                          PLANE FROM THE EQUINOX(X-AXIS) TO THE
C                          GREENWICH MERIDIAN. IN RADIANS.
C
C**********************************************************************
C
C  CODED BY C PETRUZZO, 11/82.
C     MODIFIED....  7/83. CJP. COMMENT CLARIFICATION. CODE CLEANUP, AND
C                         CORRECTION TO METHOD OF HANDLING THE
C                         NON-PRECESSING EQUINOX.
C
C**********************************************************************
C
C
C  METHOD: AS IN THE ASTRONOMICAL ALMANAC, 1983, PAGE B-6. THOSE
C          FORMULAE ARE FOR MEAN OF DATE.
C
      REAL*8 SECDAY/86400.D0/,SECHR/3600.D0/,MINHR/60.D0/
      REAL*8 TWOPI/ 6.283185307179586D0 /
      REAL*8 DEGRAD/ 57.29577951308232D0 /
      INTEGER INIT/1/
C
C
      IF(INIT.NE.0) THEN    ! INITIALIZATION ON FIRST CALL.
        INIT=0
        CENT50=0.5D0  ! CENTURIES 1/0/1900, 12 HR, TO 1/1/50, 0 HR (UT).
        RADHR = 15.D0/DEGRAD   ! 15 (DEG/HR) / (DEG/RAD)= RAD/HR.
C       SET COEFFICIENTS FOR RU FORMULA, MEAN OF DATE CASE.
        C1=18.D0 + 38.D0/MINHR + 45.836D0/SECHR
        C2=8640184.542D0/SECHR
        C3=0.0929D0/SECHR
        END IF
C
C    CENT = FRAC OF A JULIAN CENTURY(MEAN SOLAR DAYS) FROM 1/0/00, 12 HR
      CENT = (TSEC50/SECDAY)/36525.D0 + CENT50
C    UT = UNIVERSAL TIME. HOURS.
      UT = DMOD(TSEC50/SECHR,24.D0)
C    RU = RACN OF FICTITIOUS MEAN SUN. HOURS.
      RU = C1 + C2*CENT + C3*CENT*CENT
C    GMST = GREENWICH MEAN SIDEREAL TIME(GHA OF MEAN EQNX OF DATE). HRS.
      GMST = UT + 12.D0 + RU
C    GHA = GREENWICH HOUR ANGLE. RADIANS.
      GHA = GMST * RADHR
C
C    GHA IS NOW IN MEAN OF DATE. CONVERT TO MEAN OF 1950.0 IF NEEDED.
      IF(KPRECES.EQ.0) THEN
        SHIFT=PRECES50(TSEC50,1)
      ELSE
        SHIFT=0.D0
        END IF
      GHA = GHA - SHIFT
C
C  WRAP IT UP.
      GHANGL = DMOD(GHA,TWOPI)
C
      RETURN
      END


************************************************************************
*     Author: R.K. Ellis & GZ                                               *
************************************************************************

      double complex function qlL0(x,y)
      implicit none
      include 'qlconstants.f'
      double complex qllnrat
      double precision x,y,denom
      denom=one-x/y
      if (abs(denom) .lt. 1d-7) then
      qlL0=-cone-dcmplx(denom*(half+denom/3d0))
      else
      qlL0=qllnrat(x,y)/dcmplx(denom)
      endif
      return
      end

      double complex function qlL1(x,y)
      implicit none
      include 'qlconstants.f'
      double precision x,y,denom
      double complex qlL0
      denom=one-x/y
      if (abs(denom) .lt. 1d-7) then
      qlL1=-half*cone-dcmplx(denom/3d0*(one+0.75d0*denom))
      else
      qlL1=(qlL0(x,y)+cone)/dcmplx(denom)
      endif
      return
      end

      double complex function qlL2(x,y)
      implicit none
      include 'qlconstants.f'
      double complex qllnrat
      double precision x,y,r,denom
      r=x/y
      denom=one-r
      if (abs(denom) .lt. 1d-7) then
      qlL2=(dcmplx(10d0)+denom*(dcmplx(15d0)+dcmplx(18d0)*denom))
     . /dcmplx(60d0)
      else
      qlL2=(qllnrat(x,y)-dcmplx(0.5d0*(r-1d0/r)))/dcmplx(denom)**3
      endif
      return
      end

      double complex function qlLsm1(x1,y1,x2,y2)
      implicit none
      include 'qlconstants.f'
      double precision x1,x2,y1,y2
      double complex qlLnrat,qlLi2omrat

      qlLsm1=qlLi2omrat(x1,y1)+qlLi2omrat(x2,y2)
     . +qllnrat(x1,y1)*qllnrat(x2,y2)-dcmplx(pisqo6)
      return
      end

      double complex function qlLsm1_2mht(s,t,p1sq,p2sq)
      implicit none
      include 'qlconstants.f'
      double precision s,t,p1sq,p2sq
      double complex qlLnrat,qlLi2omrat

      qlLsm1_2mht=
     & -qlLi2omrat(-p1sq,-t)
     & -qlLi2omrat(-p2sq,-t)
     & +half*(qllnrat(-s,-p1sq)*qllnrat(-s,-p2sq)-qllnrat(-s,-t)**2)
      return
      end

      double complex function qlLsm1_2me(s,t,p1sq,p3sq)
      implicit none
      include 'qlconstants.f'
      double precision s,t,p1sq,p3sq
      double complex qlLnrat,Li2(5),qlLi2omrat,qlLi2omx2

      Li2(1)=qlLi2omrat(-p1sq,-s)
      Li2(2)=qlLi2omrat(-p1sq,-t)
      Li2(3)=qlLi2omrat(-p3sq,-s)
      Li2(4)=qlLi2omrat(-p3sq,-t)
      Li2(5)=qlLi2omx2(-p1sq,-p3sq,-s,-t)
      qlLsm1_2me=Li2(5)-Li2(1)-Li2(2)-Li2(3)-Li2(4)
     . -half*qlLnrat(-s,-t)**2
      return
      end


program Newtonxiu
	real*8 x(2),t,g(2),A(2,2),Gni(2,2),b(2),f,p(2),ans,aro(2)
	data x /0,0/
	data A /8,0,0,4/
	data Gni /0.125,0.0,0.0,0.25/
	data b /9,-3/
	open(13,file="Newtonxiu")
	write(13,"(5A13)")"f","x1","x2","g1","g2"
	do
	g=matmul(A,x)+b
	f=10+x(1)+x(2)+4*(x(1)+1)**2+2*(x(2)-1)**2
	write(13,"(5f13.6)")f,x,g
	call onedimenmul(g,g,2,ans)
	if(ans<0.01) exit
	p=matmul(-Gni,g)
	aro=matmul(p,A)
	t=ans
	call onedimenmul(aro,g,2,ans)
	t=t/ans
	x=x-t*p
	end do
	close(13)
end program Newtonxiu

	subroutine onedimenmul(m1,m2,n,ans)
	integer n
	real*8 m1(n),m2(n),ans
	ans=0
	do i=1,n
		ans=m1(i)*m2(i)+ans
	end do
	end subroutine onedimenmul


! --------------------- BEGIN YINTRF ------------------------------------
      function yintrf( x, xin, yin, n)
!
! returns an interpolated value (yintrf) based on straight line
! interpolation of the data in xin and yin.

! Needs Numerical recipe routine locate

!
! dates:  3/14/85 - written
!        11/30/95 - substituted LOCATE instead of starting from beginning
!                   each time
!        03/13/96 - added code to deal with xin increasing or decreasing
!        12/12/00 - Stripped off "locate.for"
!        04/28/15 - Replaced comment characters * or C with ! (The Fortran 95 standard)

      dimension xin(1), yin(1)
      logical incrs

! Is xin increasing or decreasing?
      incrs = .true.
      if (xin(n) .lt. xin(1)) incrs = .false.

! Set value if x is outside the range of xin:
      if (incrs) then
        if ( x .le. xin(1) ) then
            yintrf = yin(1)
            return
        end if
        if ( x .ge. xin(n) ) then
            yintrf = yin(n)
            return
        end if
      else
        if ( x .ge. xin(1) ) then
            yintrf = yin(1)
            return
        end if
        if ( x .le. xin(n) ) then
            yintrf = yin(n)
            return
        end if
      end if

! Locate the proper cell and interpolate:
      call locate(xin, n, x, j)
      yintrf = yin(j) + (x-xin(j))*(yin(j+1) - yin(j))/
     * (xin(j+1)-xin(j))

      return
      end
! --------------------- END YINTRF ------------------------------------


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

	subroutine matvec(r_t,r_v,r_w)

c****************************************************************
c**
c**	FILE NAME: matvec.f
c**
c**     DATE WRITTEN: 7/20/90
c**
c**     PROGRAMMER:Scott Hensley
c**
c** 	FUNCTIONAL DESCRIPTION: The subroutine takes a 3x3 matrix
c**     and a 3x1 vector a multiplies them to return another 3x1
c**	vector.
c**
c**     ROUTINES CALLED:none
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c**
c*****************************************************************

       	implicit none

c	INPUT VARIABLES:
 	real*8 r_t(3,3)                            !3x3 matrix
        real*8 r_v(3)                              !3x1 vector

c   	OUTPUT VARIABLES:
        real*8 r_w(3)                              !3x1 vector

c	LOCAL VARIABLES:none

c  	PROCESSING STEPS:

c       compute matrix product

	r_w(1) = r_t(1,1)*r_v(1) + r_t(1,2)*r_v(2) + r_t(1,3)*r_v(3)
	r_w(2) = r_t(2,1)*r_v(1) + r_t(2,2)*r_v(2) + r_t(2,3)*r_v(3)
	r_w(3) = r_t(3,1)*r_v(1) + r_t(3,2)*r_v(2) + r_t(3,3)*r_v(3)

        end


SUBROUTINE twofft(data1,data2,fft1,fft2)
  USE nrtype
  USE nrutil, ONLY : assert,assert_eq
  USE nr, ONLY : four1
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2
  COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: fft1,fft2
  INTEGER(I4B) :: n,n2
  COMPLEX(SPC), PARAMETER :: C1=(0.5_sp,0.0_sp), C2=(0.0_sp,-0.5_sp)
  COMPLEX, DIMENSION(size(data1)/2+1) :: h1,h2
  n=assert_eq(size(data1),size(data2),size(fft1),size(fft2),'twofft')
  call assert(iand(n,n-1)==0, 'n must be a power of 2 in twofft')
  fft1=cmplx(data1,data2,kind=spc)
  call four1(fft1,1)
  fft2(1)=cmplx(aimag(fft1(1)),0.0_sp,kind=spc)
  fft1(1)=cmplx(real(fft1(1)),0.0_sp,kind=spc)
  n2=n/2+1
  h1(2:n2)=C1*(fft1(2:n2)+conjg(fft1(n:n2:-1)))
  h2(2:n2)=C2*(fft1(2:n2)-conjg(fft1(n:n2:-1)))
  fft1(2:n2)=h1(2:n2)
  fft1(n:n2:-1)=conjg(h1(2:n2))
  fft2(2:n2)=h2(2:n2)
  fft2(n:n2:-1)=conjg(h2(2:n2))
END SUBROUTINE twofft


program entropy
    USE yepLibrary, ONLY: yepLibrary_Init, yepLibrary_Release, yepLibrary_GetTimerFrequency, yepLibrary_GetTimerTicks
    USE yepCore, ONLY: yepCore_DotProduct_V64fV64f_S64f
    USE yepMath, ONLY: yepMath_Log_V64f_V64f
    USE ISO_C_BINDING, ONLY : C_SIZE_T, C_INT64_T, C_INT, C_DOUBLE
    implicit none
    INTEGER(C_SIZE_T), PARAMETER :: n = 1024*1024*16
    INTEGER(C_INT64_T) :: ticksStart, ticksEnd, frequency
    real(C_DOUBLE) :: p(n), logP(n), H
    integer(C_INT) :: s
    s = yepLibrary_Init()
    s = yepLibrary_GetTimerFrequency(frequency)
    call RANDOM_NUMBER(p)

    s = yepLibrary_GetTimerTicks(ticksStart)
    s = yepMath_Log_V64f_V64f(p, logP, n)
    s = yepCore_DotProduct_V64fV64f_S64f(p, logP, H, n)
    H = -H
    s = yepLibrary_GetTimerTicks(ticksEnd)
    print*, "Yeppp!"
    print*, "    Entropy =", H
    print*, "    Time =", REAL(ticksEnd - ticksStart) / REAL(frequency)

    s = yepLibrary_GetTimerTicks(ticksStart)
    H = -DOT_PRODUCT(p, LOG(p))
    s = yepLibrary_GetTimerTicks(ticksEnd)
    print*, "Naive"
    print*, "    Entropy =", H
    print*, "    Time =", REAL(ticksEnd - ticksStart) / REAL(frequency)
    s = yepLibrary_Release()
end


subroutine fort_set_rhs(rhs, lo, hi, nc, dx, a, b, sigma, w) bind(c)
  integer, intent(in) :: lo(2), hi(2)
  integer, intent(in), value :: nc
  double precision, intent(in), value :: a, b, sigma, w
  double precision, intent(inout) :: rhs(lo(1):hi(1),lo(2):hi(2),nc)
  double precision, intent(in) :: dx(2)

  integer :: i, j, n
  double precision :: x, y, r, pi, tpi, fpi, fac, theta, beta, dbdrfac

  pi = 4.d0 * datan(1.d0)
  tpi = 2.0d0 * pi
  fpi = 4.0d0 * pi
  fac = 2.0d0 * tpi**2

  theta = 0.5d0*log(3.0) / w

  do n = 1, nc
     do j = lo(2), hi(2)
        y = (dble(j)+0.5d0)*dx(2)
        do i = lo(1), hi(1)
           x = (dble(i)+0.5d0)*dx(1)

           r = sqrt((x-0.5d0)**2+(y-0.5d0)**2)

           beta = (sigma-1.d0)/2.d0*tanh(theta*(r-0.25d0)) + (sigma+1.d0)/2.d0
           beta = beta * b
           dbdrfac = (sigma-1.d0)/2.d0/(cosh(theta*(r-0.25d0)))**2 * theta/r
           dbdrfac = dbdrfac * b

           rhs(i,j,n) = beta*fac*(sin(tpi*x) * sin(tpi*y)  &
                &               + sin(fpi*x) * sin(fpi*y)) &
                &    + dbdrfac*((x-0.5d0)*(-tpi*cos(tpi*x) * sin(tpi*y)   &
                &                          - pi*cos(fpi*x) * sin(fpi*y))  &
                &             + (y-0.5d0)*(-tpi*sin(tpi*x) * cos(tpi*y)   &
                &                          - pi*sin(fpi*x) * cos(fpi*y))) &
                &    + a * (                    sin(tpi*x) * sin(tpi*y)   &
                &                    + 0.25d0 * sin(fpi*x) * sin(fpi*y))
        end do
     end do
  end do
end subroutine fort_set_rhs

subroutine fort_set_coef(xcoef, xlo, xhi, ycoef, ylo, yhi, nc, dx, sigma, w) bind(c)
  integer, intent(in) :: xlo(2), xhi(2), ylo(2), yhi(2)
  integer, intent(in), value :: nc
  double precision, intent(in), value :: sigma, w
  double precision, intent(inout) :: xcoef(xlo(1):xhi(1),xlo(2):xhi(2),nc)
  double precision, intent(inout) :: ycoef(ylo(1):yhi(1),ylo(2):yhi(2),nc)
  double precision, intent(in) :: dx(2)

  integer :: i, j, n
  double precision :: theta, x, y, r

  theta = 0.5d0*log(3.0) / w

  do n = 1, nc
     do j = xlo(2), xhi(2)
        y = (dble(j)+0.5d0)*dx(2)
        do i = xlo(1), xhi(1)
           x = (dble(i))*dx(1)

           r = sqrt((x-0.5d0)**2 + (y-0.5d0)**2)

           xcoef(i,j,n) = (sigma-1.d0)/2.d0*tanh(theta*(r-0.25d0)) &
                + (sigma+1.d0)/2.d0
        end do
     end do

     do j = ylo(2), yhi(2)
        y = (dble(j))*dx(2)
        do i = ylo(1), yhi(1)
           x = (dble(i)+0.5d0)*dx(1)

           r = sqrt((x-0.5d0)**2 + (y-0.5d0)**2)

           ycoef(i,j,n) = (sigma-1.d0)/2.d0*tanh(theta*(r-0.25d0)) &
                + (sigma+1.d0)/2.d0
        end do
     end do
  end do
end subroutine fort_set_coef


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

! Largest palindrome product
!
! A palindromic number reads the same both ways. The largest palindrome made
! from the product of two 2-digit numbers is 9009 = 91x99.?
! Find the largest palindrome made from the product of two 3-digit numbers.
module MPEProblem4

    implicit none
    private

    type, public :: TPEProblem4
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present
        write (*, '(A)') 'Problem 4. Largest palindrome product.'

        write (*, '(A, I)') 'Palindrome 1: ', palindrome()
    end subroutine

    function palindrome()
        integer palindrome
        integer current
        integer number1
        integer number2

        integer number
        integer digit
        integer remaining

        palindrome = 0

        do number1 = 999, 100, -1
            do number2 = 999, 100, -1
                current = number1 * number2

                number    = current
                remaining = 0
                do while (number .gt. 0)
                    digit     = mod(number, 10)
                    remaining = remaining * 10 + digit
                    number    = number / 10
                end do

                if (remaining .eq. current) then
                    if (current .gt. palindrome) then
                        palindrome = current
                    end if
                end if
            end do
        end do
    end function
end module


!--------------------------------------------------
!PHY1038 Assignment 4 - Matrix Geometry
!URN 6309823 - Penguin Lab Group 1
!May 5th 2015
!--------------------------------------------------

PROGRAM Matrix_Geometry
  IMPLICIT NONE

    REAL :: theta,j,k,l,h,m,n,xcom,ycom,alpha
    REAL, DIMENSION(1:3) :: a,b,c,e,i,p,newa,newb,newc

      !Step 1

      OPEN(unit=20,file='rotate.dat')

      WRITE(6,*) "The x value of the initial point to be rotated is:"
      READ(5,*) m

      WRITE(6,*) "The y value of the initial point to be rotated is:"
      READ(5,*) n

      !p=initial point to be rotated
      p=(/m,n,0.0/)

      WRITE(6,*) "Please input a value for the angle of rotation theta in radians:"
      READ(5,*) theta
      WRITE(6,*) " "
      WRITE(6,*) " "

      !a = [ 1 1 1 ]
      !b = [ 2 1 1 ]
      !c = [ 2 2 1 ]

      a=(/1.0,1.0,1.0/)
      b=(/2.0,1.0,1.0/)
      c=(/2.0,2.0,1.0/)
      e=(/1.0,1.0,1.0/)

      WRITE(6,*) "The angle through which the vectors are rotated is theta."
      WRITE(6,*) " "
      WRITE(6,*) "theta=", theta, "radians"
      WRITE(6,*) " "

      !This inputs the translated points and the original points to the file rotate.dat
      WRITE(20,*) f(a,theta), a, f(p,theta), p
      WRITE(20,*) f(b,theta), b
      WRITE(20,*) f(c,theta), c
      WRITE(20,*) f(e,theta), e

      WRITE(6,*) "Plot using GNU PLOT."

      !Write in Terminal 'gnuplot' then press ENTER"

      !In order to plot the vector inputed by the user, write in the terminal:
      !plot "rotate.dat" using 7:8, "rotate.dat" using 10:11
      !then press ENTER

      !In order to plot the triangle as a test, write in the terminal:
      !plot "rotate.dat" using 1:2 with lines, "rotate.dat" using 4:5 with lines
      !then press ENTER

      !Step 2

      OPEN(unit=19,file='translate.dat')

      WRITE(6,*) "Please input the x value of the initial point to be translated:"
      READ(5,*) l
      WRITE(6,*) " "
      WRITE(6,*) "Please input the y value of the initial point to be translated:"
      READ(5,*) h
      WRITE(6,*) " "

      !i=initial point to be translated
      i=(/l,h,1.0/)

      WRITE(6,*) " "
      WRITE(6,*) "The shape is translated in the x axis by:"
      READ(5,*) j
      WRITE(6,*) " "
      WRITE(6,*) "The shape is translated in the y axis by:"
      READ(5,*) k
      WRITE(6,*) " "
      WRITE(6,*) " "

      !This inputs the translated points and the original points to the file translate.dat
      WRITE(19,*) g(a,k,j), a, i, g(i,k,j)
      WRITE(19,*) g(b,k,j), b
      WRITE(19,*) g(c,k,j), c
      WRITE(19,*) g(e,k,j), e

      WRITE(6,*) "Plot using GNU PLOT."

      !Write in Terminal 'gnuplot' then press ENTER"

      !In order to plot the vector inputed by the user, write in the terminal:
      !plot "translate.dat" using 7:8, "translate.dat" using 10:11
      !then press ENTER

      !In order to plot the triangle as a test, write in the terminal:
      !plot "translate.dat" using 1:2 with lines, "translate.dat" using 4:5 with lines
      !then press ENTER

      !Step 3

      OPEN(unit=18,file='step3.dat')

      !The current centre of mass of the triangle is: (",xcom,",",ycom,")"
      xcom=(a(1)+b(1)+c(1))/3
      ycom=(a(2)+b(2)+c(2))/3

      WRITE(6,*) "Please input a value for the angle of rotation 'alpha' in radians:"
      READ(5,*) alpha
      WRITE(6,*) " "
      WRITE(6,*) " "

      newa=o(a,xcom,ycom,alpha)
      newb=o(b,xcom,ycom,alpha)
      newc=o(c,xcom,ycom,alpha)

      !This inputs the points rotated about the triangle's centre of mass and the original points to the file step3.dat
      WRITE(18,*) a,newa
      WRITE(18,*) b,newb
      WRITE(18,*) c,newc
      WRITE(18,*) a,newa

      WRITE(6,*) "The triangle has now been rotated about its centre of mass."
      WRITE(6,*) " "
      WRITE(6,*) " "
      WRITE(6,*) "Write 'gnuplot 6309823.gnu' in the terminal to create a .png file displaying the original triangle and the rotate triangle."

    CONTAINS

      !Rotation Function
      FUNCTION f(a,theta)
        IMPLICIT NONE
          REAL, INTENT(IN) :: theta
          REAL, DIMENSION(1:3) :: a,f
          REAL, DIMENSION(1:3,1:3) :: d

          !d = [cos(theta) -sin(theta) 0]
          !    [sin(theta)  cos(theta  0]
          !    [    0           0      1]

          d= RESHAPE( (/cos(theta),sin(theta),0.0,-sin(theta),cos(theta),0.0,0.0,0.0,1.0/), (/3,3/) )
          f=matmul(a,d)
      END FUNCTION f

      !Translation Function
      FUNCTION g(i,j,k)
        IMPLICIT NONE
          REAL, INTENT(IN) :: k,j
          REAL, DIMENSION(1:3) :: g,i
          REAL, DIMENSION(1:3,1:3) :: h

          !h = [ 1 0 j ]
          !    [ 0 1 k ]
          !    [ 0 0 1 ]

          h= RESHAPE( (/1.0,0.0,j,0.0,1.0,k,0.0,0.0,1.0/), (/3,3/) )
          g=MATMUL(i,h)
      END FUNCTION g

      !Function which rotates a triangle about its centre of mass
      FUNCTION o(a,xcom,ycom,alpha)
        IMPLICIT NONE
          REAL, INTENT(IN) :: xcom,ycom,alpha,a(3)
          REAL, DIMENSION(1:3) :: z,y,o

          z=g(a,-xcom,-ycom)
          y=f(z,alpha)
          o=g(y,xcom,ycom)
      END FUNCTION o

END PROGRAM Matrix_Geometry


program lineclip

    use, intrinsic:: ieee_arithmetic
    use lineclip,only: Ccohensutherland, cohensutherland
    use assert, only: wp, assert_isclose

    implicit none

    real(wp) :: L(8)[*]

    call coarray_lineclip(L)
!    if(this_image()==1)  print *,L

contains

subroutine coarray_lineclip(length)

    integer, parameter :: Np=8
    real(wp), dimension(Np) :: x1,x2,y1,y2
    real(wp),parameter :: xmin=1., ymax=5.,xmax=4., ymin=3.
    real(wp) :: truelength(Np) =[2.40370083, 3.,0.,0.,0.,0.,2.,2.5]
    real(wp) :: nan
    integer :: Ni, im, s0,s1
    real(wp),intent(out) :: length(Np)[*]

    Ni = num_images()
    im=this_image()

    nan = ieee_value(1.,ieee_quiet_nan)
    truelength(3:6) = nan

    x1=[0.,0.,0.,0.,0.,0.,0.,0.]
    y1=[0.,4.,1.,1.5,2.,2.5,3.0,3.5]
    x2=[4.,5.,1.,1.5,2.,2.5,3.0,3.5]
    y2=[6.,4.,1.,1.5,2.,2.5,3.0,3.5]

!------ slice problem
    s0 = (im-1)*Np/Ni+1
    s1 = im*Np/Ni
    print '(A,I3,A,I3,A,I3)','Image',im,' solved over indices ',s0,':',s1
!------- solve problem
    call cohensutherland(xmin,ymax,xmax,ymin, &
                x1(s0:s1), y1(s0:s1), x2(s0:s1), y2(s0:s1))

    length(s0:s1)[1] = hypot(x2(s0:s1) - x1(s0:s1), y2(s0:s1) - y1(s0:s1))
!-------- finish up
    sync all

    if (im==1) then
        call assert_isclose(length, truelength, equal_nan=.true.)
        print *, 'OK coarray_lineclip'
    endif

end subroutine coarray_lineclip

end program


PROGRAM PE2D_HF_FD
 USE PE2D_TYPE
 USE PE2D_VAR
 USE PE2D_AUX
 USE PE2D_GROUND
 IMPLICIT NONE
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) "========== Parabolic Equation Package =========="
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "University of Bristol"
 WRITE(*,*) "Aerodynamics and Aeroacoustics Research Group"
 WRITE(*,*) ""
 WRITE(*,*) "Codor Khodr, July 2016"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "PE2D_HFR"
 WRITE(*,*) "Dimension : 2D"
 WRITE(*,*) "Atmosphere : Homogeneous"
 WRITE(*,*) "Boundary : Flat"
 WRITE(*,*) "Impedance : Rigid"
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Enter inputs L, f, zs, As"
 WRITE(*,*) ""
 READ *, L, F, ZS, ABL
 WRITE(*,*) ""
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 C0 = 343.0_DP
 LMBDA0 = C0/F
 K0 = 2*PI*F/C0
 DZ = LMBDA0/10
 DR = LMBDA0/10
 H = 100*LMBDA0
 HABL = 30*LMBDA0
 N = FLOOR(H/DZ)
 M = FLOOR(L/DR)
 WRITE(*,*) "================================================"
 WRITE(*,*) ""
 WRITE(*,*) "Size of the system : ", N
 WRITE(*,*) "Number of steps : ", M
 WRITE(*,*) ""
 WRITE(*,*) "================================================"
 NS = MAX(1,FLOOR(ZS/DZ))
 NABL = FLOOR(HABL/DZ)
 A = IM/(2.0_DP*K0*DZ**2)
 KU = 1
 KL = 1
 NDIAG = KU+KL+1
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Memory allocation
 ALLOCATE(K(N), DK2(N), ALT(N), PHI(N,M+1), T(N,N), D(N,N), M1(N,N), &
 M2(N,N), I(N,N), P(N,M), LP(N,M), LP2(N,M), LPG(M), LPG2(M), E(N,N), &
 MB2(NDIAG,N), MB1(NDIAG,N), TEMP(N,1), M1T(N,N), M2T(N,N), IPIV(N), &
 GHX(3), MCOND(M,2), MB1T(NDIAG,N), MB2T(KL+NDIAG,N))
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 DO NZ = 1,N
  IF (NZ.GE.N-NABL) THEN
   K(NZ) = K0+ABL*IM*(NZ-N+NABL)**2/NABL**2
  ELSE
   K(NZ) = K0
  ENDIF
  DK2(NZ) = IM*(K(NZ)**2-K0**2)/(2*K0)
  ALT(NZ) = NZ*DZ
 END DO
 TAU1 = 4./(3.-2.*IM*K0*DZ)
 TAU2 = -1./(3.-2.*IM*K0*DZ)
 SIGMA1 = 4./3.
 SIGMA2 = -1./3.
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 A0 = 1.3717
 A2 = -0.3701
 B = 3.
 DO NZ = 1,N
  PHI(NZ,1) = SQRT(IM*K0)* &
              ((A0+A2*K0**2*(NZ*DZ-ZS)**2)*EXP(-K0**2*(NZ*DZ-ZS)**2/B) + &
              (A0+A2*K0**2*(NZ*DZ+ZS)**2)*EXP(-K0**2*(NZ*DZ+ZS)**2/B))
 END DO
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Initialization (Dense Matrices)
 !---------
 T(:,:) = 0._DP
 DO NZ = 2,N-1
  T(NZ,NZ-1) = T(NZ,NZ-1)+1.
  T(NZ,NZ) = T(NZ,NZ)-2.
  T(NZ,NZ+1) = T(NZ,NZ+1)+1.
 END DO
 T(1,1) = T(1,1)-2.+SIGMA1
 T(1,2) = T(1,2)+1.+SIGMA2
 T(N,N-1) = T(N,N-1)+1.+TAU2
 T(N,N) = T(N,N)-2.+TAU1
 E = DIAG(ALT,N)
 D = DIAG(DK2,N)
 I = EYE(N)
 !-----------------------------------------------------------
 !System - M1 and M2
 !---------
 ALPHA = CMPLX(1.0_DP,0.0_DP,KIND=DP)
 BETA = CMPLX(0.0_DP,0.0_DP,KIND=DP)
 BETA1 = 1.0_DP/(2.0_DP*IM*K0)+DR/2.0_DP
 BETA2 = 1.0_DP/(2.0_DP*IM*K0)-DR/2.0_DP
 M1 = I+A*BETA1*T+BETA1*D
 M2 = I+A*BETA2*T+BETA2*D
 MB1 = DENSE2BAND(M1,N,KL,KU)
 MB2 = DENSE2BAND(M2,N,KL,KU)
 MB1T = MB1
 MB2T(KL+1:KL+NDIAG,:) = MB2
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Forward-marching procedure
 CALL CPU_TIME(TI)
 !-----------------------------------------------------------
 DO MX = 2,M+1
  WRITE(*,*) "Step :", MX-1, "out of", M
  !-------------------------------
  !Right hand side multiplication
  !-------------------------------
  CALL ZGBMV('N',N,N,KL,KU,ALPHA,MB1,KL+KU+1,PHI(1:N,MX-1),1,BETA,TEMP(:,1),1)
  WRITE(*,*) ".... Right-hand side multiplied"
  WRITE(*,*)
  !-------------------------------
  !System solving
  !-------------------------------
  !MTEMP2 = M2
  !CALL ZGESV(N,1,M2T,N,IPIV,TEMP,N,INFO)                                                         !General matrix form
  CALL ZGBSV(N,KL,KU,1,MB2T,2*KL+KU+1,IPIV,TEMP,N,INFO)                                           !Band matrix form
  !CALL ZGTSV(N,1,MT2T(3,1:N-1),MT2T(2,1:N),MT2T(1,2:N),TEMP(:,1),N,INFO)                         !Tridiagonal matrix form
  IF (INFO.NE.0) THEN
   STOP "ERROR : Matrix is singular"
  END IF
  WRITE(*,*) ".... System solved"
  WRITE(*,*)
  PHI(1:N,MX) = TEMP(:,1)
  P(1:N,MX-1) = EXP(IM*K0*(MX-1)*DR)*PHI(1:N,MX)*(1/SQRT((MX-1)*DR))
 END DO
 !-----------------------------------------------------------
 CALL CPU_TIME(TF)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 !Transmission loss conversion
 P0 = ABS(P(NS,1))
 DO MX = 1,M
  DO NZ = 1,N
   LP(NZ,MX) = 20.*LOG10(ABS(P(NZ,MX))/P0)
  END DO
 END DO
 LPG = LP(1,1:M)
 LP2 = LP/SQRT(2.)
 LPG2 = LP2(1,1:M)
 !-----------------------------------------------------------
 !-----------------------------------------------------------
 IF (OUTPUT.EQ."Y") THEN
 !Output
  OPEN(UNIT=10,FILE="../results/Flat_LPg.dat")
  OPEN(UNIT=20,FILE="../results/Flat_LP.dat")
  OPEN(UNIT=30,FILE="../results/Flat_P.dat")
  DO MX = 1,M
   WRITE(10,100) MX*DR, LPG(MX), LPG2(MX)
   DO NZ = 1,N
    WRITE(20,100) MX*DR, NZ*DZ+TERR(MX), LP(NZ,MX)
    WRITE(30,101) MX*DR, NZ*DZ+TERR(MX), ABS(P(NZ,MX))
   END DO
   WRITE(20,*)
   WRITE(30,*)
  END DO
  100 FORMAT(3(3X,F12.3))
  101 FORMAT(2(3X,F12.3),3X,F12.3,SP,F12.3,SS,"i")
  !Plotting of results
  CALL SYSTEM('gnuplot -p plot_flat.plt')
 END IF
 PRINT *, "Main CPU time (s) :", TF-TI
 PRINT *, "Source pressure P0 (dB) :", 20*LOG10(ABS(P0))
 !-----------------------------------------------------------
 !-----------------------------------------------------------
END PROGRAM PE2D_HF_FD
!-----------------------------------------------------------
!-------------      EXTERNAL PROCEDURES      ---------------
!-----------------------------------------------------------


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

subroutine fungauss(n,f,J,x,y,w)

!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 1/11-2005                                                            !
!                                                                               !
!  Local variables                                                              !
!  x(n)      vector with parameter values                                       !
!  f(m)      vector with function values                                        !
!  J(m,n)    Jacobian matrix                                                    !
!                                                                               !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: i,n,nmid
double precision :: zeros(n),t(n),arg(n),exparg(n),x(5),y(n),ytilde(n),w(n),f(n)
double precision :: J(n,5),J1(n),J2(n),J3(n),J4(n),J5(n),Jb(n,5),A(2,2)
double precision :: Btilde(n,2),Btildeprim(n,2),c(2),cprim(2)

nmid = floor(x(1))
zeros = 0.d0
t = dble((/ (i, i = 1,n) /))
arg = (/ ((x(1)-t(1:nmid))/x(2))**x(3),((t(nmid+1:n)-x(1))/x(4))**x(5) /)
exparg = exp(-arg)

!---- Compute the Jacobian for asymmetric Gaussian ------------------------------

J1 = (/ -(x(3)/(x(1)-t(1:nmid)))*arg(1:nmid)*exparg(1:nmid), &
         (x(5)/(t(nmid+1:n)-x(1)))*arg(nmid+1:n)*exparg(nmid+1:n) /)
J2 = (/ (x(3)/x(2))*arg(1:nmid)*exparg(1:nmid), zeros(nmid+1:n) /)
J3 = (/ -log((x(1)-t(1:nmid))/x(2))*arg(1:nmid)*exparg(1:nmid), zeros(nmid+1:n) /)
J4 = (/ zeros(1:nmid) , (x(5)/x(4))*arg(nmid+1:n)*exparg(nmid+1:n) /)
J5 = (/ zeros(1:nmid) , -log((t(nmid+1:n)-x(1))/x(4))*arg(nmid+1:n)*exparg(nmid+1:n) /)
Jb = reshape(source = (/ J1,J2,J3,J4,J5 /), shape = (/ n,5 /))

ytilde = w*y
Btilde = reshape(source = (/ w, w*exparg /), shape = (/ n,2 /))
A(1:2,1:2) = matmul(transpose(Btilde),Btilde)
call gauss(2,A,matmul(ytilde,Btilde),c)
f = ytilde - matmul(c,transpose(Btilde))

do i = 1,5
  Btildeprim = reshape(source = (/ zeros, w*Jb(1:n,i)  /), shape = (/ n,2 /))
  call gauss(2,matmul(transpose(Btilde),Btilde),matmul(f,Btildeprim) &
                 - matmul(c,matmul(transpose(Btildeprim),Btilde)),cprim)
  J(1:n,i) = -matmul(c,transpose(Btildeprim)) - matmul(cprim,transpose(Btilde))
end do

end subroutine fungauss


!
! Newman-Penrose fields of definite spin and boost weight
! for the background Kerr spacetime.
! The fields have been rescaled by the highest power of R that allows
! them to remain regular and nonzero from the black hole horizon to
! future null infinity.
!
! rh_0:   rescaled by R
! mu_0:   rescaled by R
! ta_0:   rescaled by R^2
! pi_0:   rescaled by R^2
! ep_0:   rescaled by R^2
! psi2_0: rescaled by R^3
!
!=============================================================================
module mod_bkgrd_np
!=============================================================================
   use mod_prec
   use mod_params, only: &
      ZI, nx, ny, &
      cl=>compactification_length, &
      bhm=>black_hole_mass, &
      bhs=>black_hole_spin

   use mod_cheb, only: R=>Rarr
   use mod_swal, only: cy=>cyarr, sy=>syarr
!=============================================================================
   implicit none
   private

   public :: bkgrd_np_init

   complex(rp), allocatable, public, protected :: &
      mu_0(:,:), ta_0(:,:), pi_0(:,:), rh_0(:,:), ep_0(:,:), psi2_0(:,:)
!=============================================================================
contains
!=============================================================================
   subroutine bkgrd_np_init()
      allocate(mu_0(nx,ny))
      allocate(ta_0(nx,ny))
      allocate(pi_0(nx,ny))
      allocate(rh_0(nx,ny))
      allocate(ep_0(nx,ny))
      allocate(psi2_0(nx,ny))
      !----------------------------
      mu_0 = &
         1.0_rp / (-(cl**2) + ZI*bhs*R*cy)
      !----------------------------
      ta_0 = &
         (ZI*bhs*sy/sqrt(2.0_rp)) / ((cl**2 - ZI*bhs*R*cy)**2)
      !----------------------------
      pi_0 = &
      -  (ZI*bhs*sy/sqrt(2.0_rp)) / (cl**4 + (bhs*cy*R)**2)
      !----------------------------
      rh_0 = &
      -  0.5_rp*( &
            cl**4 - 2.0_rp*(cl**2)*bhm*R + (bhs*R)**2 &
         )/( &
            ((cl**2 - ZI*bhs*R*cy)**2)*(cl**2 + ZI*bhs*R*cy) &
         )
      !----------------------------
      ep_0 = &
         0.5_rp*( &
            (cl**2)*bhm - (bhs**2)*R - ZI*bhs*(cl**2-bhm*R)*cy &
         )/( &
            ((cl**2 - ZI*bhs*R*cy)**2)*(cl**2 + ZI*bhs*R*cy) &
         )
      !----------------------------
      psi2_0 = &
      -  bhm / ((cl**2 - ZI*bhs*R*cy)**3)
      !----------------------------
   end subroutine bkgrd_np_init
!=============================================================================
end module mod_bkgrd_np


      SUBROUTINE convlv(data,n,respns,m,isign,ans)
      INTEGER isign,m,n,NMAX
      REAL data(n),respns(n)
      COMPLEX ans(n)
      PARAMETER (NMAX=4096)
CU    USES realft,twofft
      INTEGER i,no2
      COMPLEX fft(NMAX)
      do 11 i=1,(m-1)/2
        respns(n+1-i)=respns(m+1-i)
11    continue
      do 12 i=(m+3)/2,n-(m-1)/2
        respns(i)=0.0
12    continue
      call twofft(data,respns,fft,ans,n)
      no2=n/2
      do 13 i=1,no2+1
        if (isign.eq.1) then
          ans(i)=fft(i)*ans(i)/no2
        else if (isign.eq.-1) then
          if (abs(ans(i)).eq.0.0) pause
     *'deconvolving at response zero in convlv'
          ans(i)=fft(i)/ans(i)/no2
        else
          pause 'no meaning for isign in convlv'
        endif
13    continue
      ans(1)=cmplx(real(ans(1)),real(ans(no2+1)))
      call realft(ans,n,-1)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/convlv.for


PROGRAM select_kinds
!
!  Purpose:
!    To illustrate the use of SELECTED_REAL_KIND to select
!    desired kinds of real variables in a processor-independent
!    manner.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     11/27/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Declare parameters:
INTEGER, PARAMETER :: SGL = SELECTED_REAL_KIND(p=6,r=37)
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13,r=200)

! Declare variables of each type:
REAL(kind=SGL) :: var1 = 0.
REAL(kind=DBL) :: var2 = 0._DBL

! Write characteristics of selected variables.
WRITE (*,100) 'var1', KIND(var1), PRECISION(var1), RANGE(var1)
WRITE (*,100) 'var2', KIND(var2), PRECISION(var2), RANGE(var2)
100 FORMAT(1X,A,': kind = ',I2,', Precision = ',I2,', Range = ',I3)

END PROGRAM


program lu1
  implicit none
  call check( reshape([real(8)::1,2,1,3,4,1,5,7,0                  ],[3,3]) )
  call check( reshape([real(8)::11,1,3,2,9,5,17,5,24,2,18,7,2,6,1,1],[4,4]) )

contains

  subroutine check(a)
    real(8), intent(in)   :: a(:,:)
    integer               :: i,j,n
    real(8), allocatable  :: aa(:,:),l(:,:),u(:,:)
    integer, allocatable  :: p(:,:)
    integer, allocatable  :: ipiv(:)
    n = size(a,1)
    allocate(aa(n,n),l(n,n),u(n,n),p(n,n),ipiv(n))
    forall (j=1:n,i=1:n)
      aa(i,j) = a(i,j)
      u (i,j) = 0d0
      p (i,j) = merge(1  ,0  ,i.eq.j)
      l (i,j) = merge(1d0,0d0,i.eq.j)
    end forall
    call lu(aa, ipiv)
    do i = 1,n
       l(i, :i-1) = aa(ipiv(i), :i-1)
       u(i,i:   ) = aa(ipiv(i),i:   )
    end do
    p(ipiv,:) = p
    call mat_print('a',a)
    call mat_print('p',p)
    call mat_print('l',l)
    call mat_print('u',u)
    print *, "residual"
    print *, "|| P.A - L.U || =  ", maxval(abs(matmul(p,a)-matmul(l,u)))
  end subroutine

  subroutine lu(a,p)
!   in situ decomposition, corresponds to LAPACK's dgebtrf
    real(8), intent(inout) :: a(:,:)
    integer, intent(out  ) :: p(:)
    integer                :: n, i,j,k,kmax
    n = size(a,1)
    p = [ ( i, i=1,n ) ]
    do k = 1,n-1
        kmax = maxloc(abs(a(p(k:),k)),1) + k-1
        if (kmax /= k ) p([k, kmax]) = p([kmax, k])
        a(p(k+1:),k) = a(p(k+1:),k) / a(p(k),k)
        forall (j=k+1:n) a(p(k+1:),j) = a(p(k+1:),j) - a(p(k+1:),k) * a(p(k),j)
    end do
  end subroutine

  subroutine mat_print(amsg,a)
    character(*), intent(in) :: amsg
    class    (*), intent(in) :: a(:,:)
    integer                  :: i
    print*,' '
    print*,amsg
    do i=1,size(a,1)
      select type (a)
        type is (real(8)) ; print'(100f8.2)',a(i,:)
        type is (integer) ; print'(100i8  )',a(i,:)
      end select
    end do
    print*,' '
  end subroutine

end program


module PCAClass
    use IOClass
    use MathClass
    use ArrayClass
    implicit none

    type :: PCA_
        logical :: columns_are_feature_names=.true.
        real(real64),allocatable :: DataFrame(:,:)
        real(real64),allocatable :: CovMatrix(:,:)
        real(real64),allocatable :: EigenVector(:,:)
        real(real64),allocatable :: EigenValue(:)
    contains
        procedure :: load => loadPCA
        procedure :: standarize => standarizePCA
        procedure :: run => runPCA
        procedure :: principalComponent =>principalComponentPCA
    end type
contains

! #############################################################
subroutine loadPCA(obj,filename,DataFrame,columns_are_feature_names,num_feature)
    class(PCA_),intent(inout) :: obj
    real(real64),optional,intent(in) :: DataFrame(:,:)
    character(*),optional,intent(in) :: filename
    logical,optional,intent(in) :: columns_are_feature_names
    integer(int32),optional,intent(in) :: num_feature
    type(IO_) ::f
    character(:),allocatable :: line
    integer(int32) :: n

    if(present(filename) )then
        if(.not.present(num_feature) )then
            print *, "ERROR :: LoadPCA >> Argument: num_feature should be set."
            stop
        endif
        n = f%numLine(filename)
        obj%DataFrame = zeros(n,num_feature)
        call f%open(filename,"r")
        n=1
        do while(n<=10)
            line = f%readline()
            print *, line
            read(line,*) obj%DataFrame(n,1:num_feature)
            n=n+1
        enddo
        call f%close()
        call print(obj%DataFrame)
    else
        if(present(columns_are_feature_names) )then
            obj%columns_are_feature_names = columns_are_feature_names
        endif
        obj%DataFrame = DataFrame
    endif

end subroutine
! #############################################################

! #############################################################
subroutine standarizePCA(obj)
    class(PCA_),intent(inout) :: obj
    real(real64) :: sdval, aveval
    integer(int32) :: n

    ! get covarianceMatrix
    if(.not.obj%columns_are_feature_names)then
        n=size(obj%DataFrame,1)
        obj%DataFrame = transpose(obj%DataFrame)
    endif

    do n=1,size(obj%DataFrame,2)
        sdval = standardDeviation(obj%DataFrame(:,n) )
        aveval = average( obj%DataFrame(:,n) )
        obj%DataFrame(:,n) =obj%DataFrame(:,n)-aveval
        obj%DataFrame(:,n) =obj%DataFrame(:,n)/sdval
    enddo

end subroutine
! #############################################################

! #############################################################
subroutine runPCA(obj)
    class(PCA_),intent(inout) :: obj
    integer(int32) :: i,j,n

    ! get covarianceMatrix
    if(obj%columns_are_feature_names)then
        n=size(obj%DataFrame,2)
        obj%CovMatrix = covarianceMatrix(obj%DataFrame,obj%DataFrame,n)
    else
        n=size(obj%DataFrame,1)
        obj%DataFrame = transpose(obj%DataFrame)
        obj%columns_are_feature_names = .true.
        obj%CovMatrix = covarianceMatrix(obj%DataFrame,&
            obj%DataFrame,n)
    endif

    call eigenValueAndVector(obj%CovMatrix,lambda=obj%EigenValue,x=obj%eigenVector)

    print *, "Eigen value::"
    call print(obj%EigenValue)
    do i=1,size(obj%EigenValue)
        print *, "Eigen Vector #"//str(i)
        print *, obj%eigenVector(:,i)
    enddo

end subroutine
! #############################################################

! #############################################################
function principalComponentPCA(obj) result(ret)
    class(PCA_),intent(in) :: obj
    real(real64),allocatable :: ret(:,:),Wmat(:,:)
    integer(int32) :: numdata, numfeature

    numdata   =size(obj%DataFrame,1)
    numfeature=size(obj%DataFrame,2)
    ret = zeros(numdata,2)
    Wmat = zeros(numfeature,2)
    Wmat(:,1) = obj%eigenVector(1,:)
    Wmat(:,2) = obj%eigenVector(2,:)

    ! First Principal Component
    ret(:,1:2) = matmul(obj%DataFrame,Wmat)

end function
! #############################################################

end module PCAClass


      PROGRAM xbrent
C     driver for routine brent
      REAL EQL,TOL
      PARAMETER(TOL=1.0E-6,EQL=1.E-4)
      INTEGER i,iflag,j,nmin
      REAL amin(20),ax,b,bx,cx,fa,fb,fc,xmin
      REAL bessj0,bessj1,brent,func
      EXTERNAL func
      nmin=0
      write(*,'(/1x,a)') 'Minima of the function BESSJ0'
      write(*,'(/1x,t6,a,t19,a,t28,a,t40,a/)') 'Min. #','X',
     *     'BESSJ0(X)','BESSJ1(X)'
      do 12 i=1,100
        ax=i
        bx=i+1.0
        call mnbrak(ax,bx,cx,fa,fb,fc,func)
        b=brent(ax,bx,cx,func,TOL,xmin)
        if (nmin.eq.0) then
          amin(1)=xmin
          nmin=1
          write(*,'(1x,5x,i2,3x,3f12.6)') nmin,xmin,
     *         bessj0(xmin),bessj1(xmin)
        else
          iflag=0
          do 11 j=1,nmin
            if (abs(xmin-amin(j)).le.EQL*xmin)
     *           iflag=1
11        continue
          if (iflag.eq.0) then
            nmin=nmin+1
            amin(nmin)=xmin
            write(*,'(1x,5x,i2,3x,3f12.6)') nmin,
     *           xmin,bessj0(xmin),bessj1(xmin)
          endif
        endif
12    continue
      END
      REAL FUNCTION func(x)
      REAL bessj0,x
      func=bessj0(x)
      return
      END

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