        program chkfmt
c----------------------------------------------------------------------c
c                          S P A R S K I T                             c
c----------------------------------------------------------------------c
c test suite for the Formats routines.                                 c
c tests all of the routines in the module formats.                     c
c----------------------------------------------------------------------c
c Note: the comments may not have been updated.
c
c Here is the sequence of what is done by this program.
c 1) call gen57bl togenerate a block matrix associated with a simple
c     5-point matrix on a 4 x 2 grid (2-D) with 2 degrees of freedom
c     per grid point.  Thus N = 16. This is produced in BSR format.
c    the pattern of the reduced  matrix is written in csr.mat.
c
c 2) the block format is translated into a compressed sparse row
c    format by bsrcsr. The result is dumped in file csr.mat
c    matrix is converted back to bsr format. block pattern shown again
c
c 3) the matrix is translated in dense format by csrdns.
c    result a 16 x 16 matrix is written in unit dns.mat.
c    This is a good file to look at to see what the matrix is
c    and to compare results of other formats with.
c 4) the dense matrix obtained in 3) is reconverted back to
c    csr format using dnscsr. Result appended to file csr.mat
c 5) The matrix obtained in 4) is converted in coordinate format
c    and the resulting matrix is written in file coo.mat
c 6) the result is converted back to csr format. matrix
c    appended to csr.mat.
c 7) result of 6) is converted to symmetric sparse row storage
c    (ssr) and the result is appended to csr.mat
c 8) result of 7) converted back to csr format and result is
c    appended to csr.mat
c 9) matrix resulting from 8) is converted to modified sparse
c    row format using csrmsr and result is written in msr.mat.
c10) the resulting matrix is converted back to csrformat and
c    result is appended to csr.mat
c11) result is converted to ellpack-itpack format with
c    csrell and result is printed in itp.mat
c12) result is converted back to csr format and appended to csr.mat
c12) result converted to csc format (transposition) using csrcsc
c    which should produce the same matrix here. result appended
c    to csr.mat. A second call to csrcsc is made on resulting
c    matrix.
c13) the subroutine csrdia is used to extract two diagonals
c    (offsets -1 and 0) and then all the diagonals of matrix.
c    results in dia.mat
c14) diacsr is then called to convert the diagonally stored matrix
c    back to csr format. result appended to csr.mat
c15) result is converted to band format (bnd) by calling
c    csrbnd. result dumped to bnd.mat
c16) result is converted back to csr format and appended to csr.mat
c17) result sorted by a call to csrcsc and then converted to
c    block format (csrbsr) and then back to csr format again.
c    result appedned to csr.mat.
c18) matrix converted to symmetric skyline format. result appended
c    to file band.mat
c19) matrix converted back to csr format and result appended to
c    csr.mat.
c20) result converted to jad format. result output in jad.mat
c21) result concverted back to csr fromat. appended to csr.mat
c------------------------------------------------------------------
      implicit none
      integer ndns, nxmax, nmx, nnzmax
      parameter (nxmax = 10, nmx = nxmax*nxmax, nnzmax=10*nmx)
      integer ia(nmx+1),ja(nnzmax),ia1(nnzmax),ja1(nnzmax),
     *         iwk(nmx*2+1),ioff(20),iwk2(nmx+1)
      real*8 stencil(7,100),a(nnzmax),a1(nnzmax),dns(20,20),wk(nmx)
c
      integer k,nx,ny,nz,nfree,na,nr,n,iout,nnz,i,ierr,
     *     maxcol, ndiag,job,lowd,len,imod,j,kend,k1,k2,
     *     kstart,mu,ml,idiag,idiag0,kdiag
c-----------------------------------------------------------------------
      data ndns/20/
c----- open statements ----------------
      open (unit=7,file='csr.mat')
      open (unit=8,file='dns.mat')
      open (unit=9,file='coo.mat')
      open (unit=10,file='msr.mat')
      open (unit=11,file='itp.mat')
      open (unit=12,file='dia.mat')
      open (unit=13,file='bnd.mat')
      open (unit=14,file='jad.mat')
c
c---- dimension of grid
c
      nx = 4
      ny = 2
      nz = 1
      nfree = 2
c
c---- generate grid problem.
c
c      na = nx*ny*nz*5
      na = nfree*nfree
      call gen57bl (nx,ny,nz,nfree,na,nr,a1,ja1,ia1,iwk,stencil)
c      nr = n / nfree
      n = nr*nfree
c
c---- dump the reduced matrix
c
      iout = 7
      nnz = ia(n+1)-1
      write (iout,*) '-----------------------------------------'
      write (iout,*) '  +++ Pattern of block matrix  (CSR) +++ '
      write (iout,*) '-----------------------------------------'
c
      call dump(1,nr,.false.,a1,ja1,ia1,7)
c
c---- convert to CSR format and dump result
c
      call bsrcsr (1,nr,nfree,na,a1,ja1,ia1,a,ja,ia)
      iout = 7
      nnz = ia(n+1)-1
      write (iout,*) '-----------------------------------------'
      write (iout,*) '  +++  initial matrix in CSR format +++ '
      write (iout,*) '-----------------------------------------'
      call dump(1,n,.true.,a,ja,ia,7)
c
c---- convert back to BSR format and dump pattern again.
c
      call csrbsr (1,n,nfree,na,a,ja,ia,a1,ja1,ia1,iwk2,ierr)
      write (iout,*) '-----------------------------------------'
      write (iout,*) '  +++ Pattern of block matrix  (CSR) +++ '
      write (iout,*) '-----------------------------------------'
      call dump(1,nr,.false.,a1,ja1,ia1,7)
c
c----- convert to BSR format.
c
      call bsrcsr (1,nr,nfree,na,a1,ja1,ia1,a,ja,ia)
      iout = 7
      nnz = ia(n+1)-1
      write (iout,*) '-----------------------------------------'
      write (iout,*) ' +++  matrix after BSRCSR conversion +++ '
      write (iout,*) '-----------------------------------------'
      call dump(1,n,.true.,a,ja,ia,7)
c
c----- convert to dense format.
c
      call csrdns(n,n,a,ja,ia,dns,ndns,ierr)
c
      iout = iout+1
      write (iout,*) '-----------------------------------------'
      write (iout,*) '  +++  initial matrix in DENSE format+++ '
      write (iout,*) '-----------------------------------------'
      write (iout,'(4x,16i4)') (j,j=1,n)
      write (iout,'(3x,65(1h-))')
      do 3  i=1,n
         write (8,102) i,(dns(i,j), j=1,n)
 102     format(1h ,i2,1h|,16f4.1)
 3    continue
c
c----- convert back to sparse format.
c
      call dnscsr(n,n,nnzmax,dns,ndns,a1,ja1,ia1,ierr)
      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion from dnscsr +++ '
      write (7,*) '-----------------------------------------'
      if (ierr .ne. 0) write (7,*) ' ***** ERROR FROM DNSCSR'
      if (ierr .ne. 0) write (7,*)  '     IERR = ', ierr
      call dump(1,n,.true.,a1,ja1,ia1,7)
c
c     convert it to coordinate format.
c
      call csrcoo(n,3,nnzmax,a,ja,ia,nnz,a1,ia1,ja1,ierr)
      iout = iout+ 1
      if (ierr .ne. 0) write (iout,*) ' ***** ERROR IN CSRCOO'
      if (ierr .ne. 0) write (iout,*)   '     IERR = ', ierr
      write (iout,*) '-----------------------------------------'
      write(iout,*) ' +++ Matrix in coordinate format +++ '
      write (iout,*) '-----------------------------------------'
      write(iout,103) (ia1(j),ja1(j),a1(j),j=1,nnz)
 103  format (' i =', i3,'    j = ',i3,'     a(i,j) = ',f4.1)
c
c     convert it back again to csr format
c
      call coocsr(n,nnz,a1,ia1,ja1,a,ja,ia)

      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion from coocsr +++ '
      write (7,*) '-----------------------------------------'
      call dump(1,n,.true.,a,ja,ia,7)
c
c     going to srs format
c
      call csrssr(n,a,ja,ia,nnzmax,a1,ja1,ia1,ierr)
      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion to ssr format +++ '
      write (7,*) '      (lower part only stored in csr format)    '
      write (7,*) '-----------------------------------------'
      call dump(1,n,.true.,a1,ja1,ia1,7)
c     back to csr
      call ssrcsr (3,1,n,a1,ja1,ia1,nnzmax,a,ja,ia,iwk,iwk2,ierr)
      if (ierr .ne. 0) write(7,*) ' error in ssrcsr-IERR=',ierr
      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion from ssrcsr +++ '
      write (7,*) '-----------------------------------------'
      call dump(1,n,.true.,a,ja,ia,7)
c---- msr format
      iout = iout+1
      call csrmsr (n,a,ja,ia,a1,ja1,a1,ja1)
      write (iout,*) '-----------------------------------------'
      write (iout,*) '  +++ matrix in modified sparse row format +++'
      write (iout,*) '-----------------------------------------'
      write (iout,*) ' ** MAIN DIAGONAL '
      write (iout,'(16f4.1)') (a1(k),k=1,n)
      write (iout,*) ' ** POINTERS: '
      write (iout,'(17i4)') (ja1(k),k=1,n+1)
      write (iout,*) ' ** REMAINDER :'
      call dump(1,n,.true.,a1,ja1,ja1,iout)
c-------
      call msrcsr (n,a1,ja1,a,ja,ia,wk,iwk2)
      write (7,*) '-----------------------------------------'
      write (7,*) ' +++ matrix after conversion from msrcsr +++'
      write (7,*) '-----------------------------------------'
c
      call dump(1,n,.true.,a,ja,ia,7)
c
      maxcol = 13
c
      call csrell (n,a,ja,ia,maxcol,a1,ja1,n,ndiag,ierr)
      iout = iout+1
      if (ierr .ne. 0) write (iout,*) ' ***** ERROR IN CSRELL'
      if (ierr .ne. 0) write (iout,*)   '     IERR = ', ierr
      write (iout,*) '-----------------------------------------'
      write (iout,*) '  +++ matrix in ELLPACK-ITPACK format +++ '
      write (iout,*) '-----------------------------------------'
      do 12 i=1,ndiag
         write (iout,*) ' Column number: ', i
         write (iout,104) (a1(n*(i-1)+k),k=1,n)
 104     format(9h COEF  = ,16f4.0)
         write (iout,105) (ja1(n*(i-1)+k),k=1,n)
 105     format (9h JCOEF = ,16i4)
 12   continue
      call ellcsr (n,a1,ja1,n,ndiag,a,ja,ia,nnzmax,ierr)
      if (ierr .ne. 0) write (7,*) ' ***** ERROR IN ELLCSR'
      if (ierr .ne. 0) write (7,*)   '     IERR = ', ierr
      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion from ellcsr +++'
      write (7,*) '-----------------------------------------'
      call dump(1,n,.true.,a,ja,ia,7)
c
      call csrcsc(n,1,1,a,ja,ia, a1,ja1,ia1)
      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion from csrcsc  +++ '
      write (7,*) '-----------------------------------------'
      call dump(1,n,.true.,a1,ja1,ia1,7)
      call csrcsc(n,1,1,a1,ja1,ia1, a,ja,ia)
c
c--------test 1 : get main diagonal and subdiagonal
c     get some info on diagonals
      call infdia(n,ja,ia,iwk,idiag0)
      job = 0
      ioff(1) = 0
      ioff(2) = -1
      idiag = 2
      call csrdia (n,idiag,job,a,ja,ia,ndns,dns,ioff,a1,ja1,ia1,iwk)
      iout = iout+1
      write (iout,*) '-----------------------------------------'
      write (iout,*) '  +++  diagonal format +++ '
      write (iout,*) '-----------------------------------------'
      write (iout,*) '  diagonals ioff = 0 and ioff = -1 '
      write (iout,*) ' number of diag.s returned from csrdia=',idiag
      do 13 kdiag = 1, idiag
	 write (iout,*) ' diagonal offset = ', ioff(kdiag)
         write (iout,'(16f4.1)') (dns(k,kdiag),k=1,n)
 13   continue
c     reverse conversion
      ndiag = ndns
      idiag = idiag0
      job = 10
      call csrdia (n,idiag,job,a,ja,ia,ndns,dns,ioff,a1,ja1,ia1,iwk)
      write (iout,*) '-----------------------------------------'
      write (iout,*) '  +++  second test diagonal format +++ '
      write (iout,*) '         ** all diagonals of A  ** '
      write (iout,*) '-----------------------------------------'
      write (iout,*) ' number of diagonals on return from csrdia=',
     *     idiag
      do 131 kdiag = 1, idiag
	 write (iout,*) ' diagonal offset = ', ioff(kdiag)
         write (iout,'(16f4.1)') (dns(k,kdiag),k=1,n)
 131  continue
c
c     reverse conversion
c
      job = 0
      call diacsr (n,job,idiag,dns,ndns,ioff,a,ja,ia)
c--------
      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion from diacsr  +++ '
      write (7,*) '-----------------------------------------'
      call dump(1,n,.true.,a,ja,ia,7)
c
c     checking the banded format
c
      lowd = 0
      job = 1
      call csrbnd(n,a,ja,ia,job,dns,ndns,lowd,ml,mu,ierr)
      iout = iout+1
      if (ierr .ne. 0) write (iout,*) ' ***** ERROR IN CSRBND'
      if (ierr .ne. 0) write (iout,*)   '     IERR = ', ierr
      write (iout,*) '-----------------------------------------'
      write (iout,*) '       +++  banded  format +++ '
      write (iout,*) ' bandwidth values found ml=',ml,'  mu=',mu
      write (iout,*) '-----------------------------------------'
      write (iout,'(4x,16i4)') (j,j=1,n)
      write (iout,'(3x,65(1h-))')
      do 14  i=1, lowd
         write (iout,102) i, (dns(i,j), j=1,n)
 14   continue
c
c     convert back to a, ja, ia format.
c
      len = nnzmax
c--------
      call bndcsr(n,dns,ndns,lowd,ml,mu,a,ja,ia,len,ierr)
      write (7,*) ' IERR IN BNDCSR = ', ierr
      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion from bndcsr +++'
      write (7,*) '-----------------------------------------'
      call dump(1,n,.true.,a,ja,ia,7)
c
c     make sure it is sorted
c
      call csrcsc(n,1,1,a,ja,ia, a1,ja1,ia1)
c
c     checking skyline format.
c
      imod = 1
      call csrssk (n,imod,a1,ja1,ia1,a,ia,nnzmax,ierr)
c
      if (ierr .ne. 0) write (iout,*)   '     IERR = ', ierr
      write (iout,*) '-----------------------------------------'
      write (iout,*) '    +++ Sym. Skyline format +++ '
      write (iout,*) '-----------------------------------------'
      write (iout,'(3x,65(1h-))')
c---------------------
c     create column values.
c---------------------
      do 15  i=1, n
         kend = ia(i+1)-1
         kstart = ia(i)
         do k=kstart,kend
            ja(k) =  i-(kend-k)
         enddo
 15   continue
c
      call dump(1,n,.true.,a,ja,ia,iout)
c
c     back to ssr format..
c
      call sskssr (n,imod,a,ia,a1,ja1,ia1,nnzmax,ierr)
      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion from sskcsr +++'
      write (7,*) '-----------------------------------------'
      call dump(1,n,.true.,a1,ja1,ia1,7)
c
c     checking jad format -----
c
c     first go back to the csr format ----
c
      call ssrcsr (3,1,n,a1,ja1,ia1,nnzmax,a,ja,ia,iwk,iwk2,ierr)
c
      call csrjad (n, a, ja, ia, ndiag, iwk, a1, ja1, ia1)
c
      iout = iout+1
      write (iout,*) '-----------------------------------------'
      write (iout,*) '   +++   matrix in JAD format +++ '
      write (iout,*) '-----------------------------------------'
c
c     permutation array
c
      write (iout,*) ' ** PERMUTATION ARRAY '
      write (iout,'(17i4)') (iwk(k),k=1,n)
c     ------ diagonals
      do 16 i=1,ndiag
         write (iout,*) ' J-diagonal number: ', i
         k1 = ia1(i)
         k2 = ia1(i+1)-1
         write (iout,104) (a1(k),k=k1,k2)
         write (iout,105) (ja1(k),k=k1,k2)
 16   continue
c
c     back to csr format..
c
      call jadcsr (n, ndiag, a1, ja1, ia1, iwk, a, ja, ia)
c
      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion from jadcsr +++'
      write (7,*) '-----------------------------------------'
      call dump(1,n,.true.,a,ja,ia,7)
c-----------------------------------------------------------------------
c     checking the linked list format
c-----------------------------------------------------------------------
c
      nnz = ia(n+1) - ia(1)
      call csrlnk (n, a, ja, ia, iwk)
c
c     print links in file 7 (no need for another file)
c
      iout = 7
      write (iout,*) '-----------------------------------------'
      write (iout,*) '   +++   matrix in LNK format +++ '
      write (iout,*) '-----------------------------------------'
c
c     permutation array
c
      write (iout,*) ' LINK ARRAY '
      write (iout,*) ' ---------- '
      write (iout,'(17i4)') (iwk(k),k=1,nnz)
c
c     back to csr format..
c
      call lnkcsr (n, a, ja, ia, iwk, a1, ja1, ia1)
c
      write (7,*) '-----------------------------------------'
      write (7,*) '  +++ matrix after conversion from lnkcsr +++'
      write (7,*) '-----------------------------------------'
      call dump(1,n,.true.,a,ja,ia,7)
c------------------------------------------------------------
      stop
c-----------------------------------------------------------------------
c-----------end-of-chkfmt1----------------------------------------------
      end


*> \brief \b ZDROT
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S )
*
*       .. Scalar Arguments ..
*       INTEGER            INCX, INCY, N
*       DOUBLE PRECISION   C, S
*       ..
*       .. Array Arguments ..
*       COMPLEX*16         CX( * ), CY( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> Applies a plane rotation, where the cos and sin (c and s) are real
*> and the vectors cx and cy are complex.
*> jack dongarra, linpack, 3/11/78.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>           On entry, N specifies the order of the vectors cx and cy.
*>           N must be at least zero.
*> \endverbatim
*>
*> \param[in,out] CX
*> \verbatim
*>          CX is COMPLEX*16 array, dimension at least
*>           ( 1 + ( N - 1 )*abs( INCX ) ).
*>           Before entry, the incremented array CX must contain the n
*>           element vector cx. On exit, CX is overwritten by the updated
*>           vector cx.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*>          INCX is INTEGER
*>           On entry, INCX specifies the increment for the elements of
*>           CX. INCX must not be zero.
*> \endverbatim
*>
*> \param[in,out] CY
*> \verbatim
*>          CY is COMPLEX*16 array, dimension at least
*>           ( 1 + ( N - 1 )*abs( INCY ) ).
*>           Before entry, the incremented array CY must contain the n
*>           element vector cy. On exit, CY is overwritten by the updated
*>           vector cy.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*>          INCY is INTEGER
*>           On entry, INCY specifies the increment for the elements of
*>           CY. INCY must not be zero.
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*>          C is DOUBLE PRECISION
*>           On entry, C specifies the cosine, cos.
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*>          S is DOUBLE PRECISION
*>           On entry, S specifies the sine, sin.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level1
*
*  =====================================================================
      SUBROUTINE ZDROT( N, CX, INCX, CY, INCY, C, S )
*
*  -- Reference BLAS level1 routine (version 3.7.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      INTEGER            INCX, INCY, N
      DOUBLE PRECISION   C, S
*     ..
*     .. Array Arguments ..
      COMPLEX*16         CX( * ), CY( * )
*     ..
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IX, IY
      COMPLEX*16         CTEMP
*     ..
*     .. Executable Statements ..
*
      IF( N.LE.0 )
     $   RETURN
      IF( INCX.EQ.1 .AND. INCY.EQ.1 ) THEN
*
*        code for both increments equal to 1
*
         DO I = 1, N
            CTEMP = C*CX( I ) + S*CY( I )
            CY( I ) = C*CY( I ) - S*CX( I )
            CX( I ) = CTEMP
         END DO
      ELSE
*
*        code for unequal increments or equal increments not equal
*          to 1
*
         IX = 1
         IY = 1
         IF( INCX.LT.0 )
     $      IX = ( -N+1 )*INCX + 1
         IF( INCY.LT.0 )
     $      IY = ( -N+1 )*INCY + 1
         DO I = 1, N
            CTEMP = C*CX( IX ) + S*CY( IY )
            CY( IY ) = C*CY( IY ) - S*CX( IX )
            CX( IX ) = CTEMP
            IX = IX + INCX
            IY = IY + INCY
         END DO
      END IF
      RETURN
      END


program test_ewald4

! This test compares lattice energy calculated from the Ewald summation
! against the energy calculated using the Madelung constant for various lattice
! constants L. The agreement is essentially to machine precision.

! This test is testing the example from section 4.1 in [1].
!
! [1] Pask, J. E., Sukumar, N., & Mousavi, S. E. (2012). Linear scaling
! solution of the all-electron Coulomb problem in solids. International Journal
! for Multiscale Computational Engineering, 10(1), 83–99.
! doi:10.1615/IntJMultCompEng.2011002201

use types, only: dp
use constants, only: ang2bohr, kJmol2Ha
use ewald_sums, only: ewald_box, ewald_fft1, fred2fcart
use utils, only: assert, init_random
implicit none

integer :: natom, ntypat
real(dp), parameter :: Llist(4) = [2 / sqrt(3._dp), 1._dp, 2._dp, 3._dp]
real(dp), parameter :: alpha = 0.90980836237716_dp ! Madelung constant
real(dp), parameter :: stress0 = 1.213077816502878_dp

real(dp) :: stress(6)
real(dp), allocatable :: xred(:, :), forces(:, :), q(:)
real(dp) :: L, E_ewald, E_ewald_fft, E_madelung
integer :: i

natom = 2
ntypat = 1
allocate(xred(3, natom), forces(3, natom), q(natom))
xred(:, 1) = [0, 0, 0]
xred(:, 2) = [1, 1, 1] / 2._dp
q = [1, 1]

do i = 1, size(Llist)
    L = Llist(i)
    call ewald_box(L, xred*L, q, E_ewald, forces, stress)
    E_ewald = E_ewald / (natom/ntypat)

    call ewald_fft1(L, xred*L, q, 64, 0.25_dp*L, E_ewald_fft)
    E_ewald_fft = E_ewald_fft / (natom/ntypat)

    E_madelung = -2*alpha/L

    print *, "a =", L/ang2bohr*100, "pm"
    print *, "Madelung: ", E_madelung / kJmol2Ha, "kJ/mol =", E_madelung, "a.u."
    print *, "Ewald:    ", E_ewald / kJmol2Ha, "kJ/mol =", E_ewald, "a.u."
    print *, "Ewald FFT:", E_ewald_fft / kJmol2Ha, "kJ/mol =",E_ewald_fft,"a.u."
    print *, "Ewald error:     ", abs(E_ewald - E_madelung), "a.u."
    print *, "Ewald FFT error: ", abs(E_ewald_fft - E_madelung), "a.u."
    call assert(abs(E_ewald - E_madelung) < 5e-14_dp)
    call assert(abs(E_ewald_fft - E_madelung) < 5e-12_dp)
    call assert(all(abs(forces) < 1e-15_dp))
    call assert(all(abs(stress - (-stress0/L)*[1, 1, 1, 0, 0, 0]) < 1e-15_dp))
end do

end program


MODULE source

  USE precise, ONLY : defaultp

  IMPLICIT NONE    ! makes sure the compiler complains about
                   ! undeclared variables
  INTEGER, PARAMETER, PRIVATE :: WP=defaultp
  real, parameter, private :: e=2.718281828459045

CONTAINS

  FUNCTION source1(X,Y) result(S1)
    !
    ! Function to compute a
    ! Scalar source term
    !

    REAL(wp) :: X, Y, S1

    S1=X*(e**Y)

   END FUNCTION source1

   Function sourceC(c, dt, dx) result(nu)

    REAL(wp) :: c, dt, dx, nu

     nu=c*dt/dx

   End Function sourceC

END MODULE source


PROGRAM main
  USE, INTRINSIC :: ISO_FORTRAN_ENV, &
  & ONLY : DFP=>real64, I4B=>int32
  IMPLICIT NONE

  ABSTRACT INTERFACE
    PURE FUNCTION func( x ) RESULT( Ans )
    IMPORT :: DFP
    REAL( DFP ), INTENT( IN ) :: x
    REAL( DFP ) :: Ans
    END FUNCTION func
  END INTERFACE

  PROCEDURE( func ), POINTER :: f => NULL()
  INTEGER( I4B ) :: n

  WRITE( *, "(A)", ADVANCE="NO" ) &
    & "Enter the value of case (n) :: "
  READ( *, * ) n

  SELECT CASE( n )
  CASE( 1 )
    f => func_1
  CASE( 2 )
    f => func_2
  CASE( 3 )
    f =>  func_3
  CASE DEFAULT
    f => func_1
  END SELECT

  WRITE( *, * ) f( 2.0_DFP )

  CONTAINS
    PURE FUNCTION func_1( x ) RESULT( Ans )
      REAL( DFP ), INTENT( IN ) :: x
      REAL( DFP ) :: Ans
      Ans = SIN( x )
    END FUNCTION func_1

    PURE FUNCTION func_2( x ) RESULT( Ans )
      REAL( DFP ), INTENT( IN ) :: x
      REAL( DFP ) :: Ans
      Ans = COS( x )
    END FUNCTION func_2

    PURE FUNCTION func_3( x ) RESULT( Ans )
      REAL( DFP ), INTENT( IN ) :: x
      REAL( DFP ) :: Ans
      Ans = TAN( x )
    END FUNCTION func_3
END PROGRAM main


!
!  Author: Amir H. T.
!  Email: a.hajibabaei.86@gmail.com
!
!  use histpgram, only: hist1d
!  ...
!  type(hist1d) :: h
!  call h%init(x1,x2,dx)
!  call h%gather(x)        ! x is scalar or 1d array
!  call h%write(unit,[str],[ints],...)
!
!
   module histogram
   use iso_fortran_env, only: real32, int64, real64
   implicit none
   private
   public  hist1d , hist2d

      integer, parameter          :: pr = real32

      type              hist1d
            real(pr)              :: x1, x2, dx
            integer               :: bins
            integer, allocatable  :: count(:)
            integer(int64)        :: miss1, hit, miss2, total
         contains
            procedure             :: init, write, reset
            procedure, private    :: gather_a, gather_s
            generic               :: gather => gather_s, gather_a
      end type          hist1d

      type              hist2d
            real(pr)              :: x1, x2, dx
            real(pr)              :: y1, y2, dy
            integer               :: xbins, ybins
            integer, allocatable  :: count(:,:)
            integer(int64)        :: xmiss1, ymiss1, hit, &
                                     xmiss2, ymiss2, total
         contains
            procedure             :: init   => init_2d
            procedure             :: write  => write_2d
            procedure             :: reset  => reset_2d
            procedure, private    :: gather_a_2d, gather_s_2d
            generic               :: gather => gather_s_2d, gather_a_2d
      end type          hist2d

   contains

      !////////////////////////////////////////////
      !////////////////////////////////////////////    hist1d
      !////////////////////////////////////////////

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

      subroutine init(h,x1,x2,dx)
      implicit none
      class(hist1d), intent(inout)   :: h
      real(pr),      intent(in)      :: x1, x2, dx
      h%x1   = min(x1,x2)
      h%x2   = max(x1,x2)
      h%dx   = abs(dx)
      h%bins = floor( (h%x2-h%x1)/h%dx )
      allocate(h%count(0:h%bins))
      h%count = 0
      h%miss1 = 0
      h%hit   = 0
      h%miss2 = 0
      h%total = 0
      end subroutine init

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

      subroutine gather_s(h,x)
      implicit none
      class(hist1d), intent(inout) :: h
      real(pr),      intent(in)    :: x
      integer                      :: k
      k = floor( (x-h%x1)/h%dx )
      if( k<0 ) then
         h%miss1 = h%miss1 + 1
      else if( k>h%bins ) then
         h%miss2 = h%miss2 + 1
      else
         h%hit = h%hit + 1
         h%count(k) = h%count(k) + 1
      end if
      h%total = h%total + 1
      end subroutine gather_s

      subroutine gather_a(h,x)
      implicit none
      class(hist1d), intent(inout) :: h
      real(pr),      intent(in)    :: x(:)
      integer                      :: i
      do i = 1, size(x)
         call gather_s(h,x(i))
      end do
      end subroutine gather_a

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

      subroutine reset(h)
      implicit none
      class(hist1d), intent(inout) :: h
      h%count = 0
      h%miss1 = 0
      h%hit   = 0
      h%miss2 = 0
      h%total = 0
      end subroutine reset

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

      subroutine write(h,handle,string,ints,reals,rescale_x_by_fac)
      implicit none
      class(hist1d), intent(in)      :: h
      class(*),     intent(in)       :: handle
      character(len=*), intent(in), &
                         optional    :: string
      class(*), intent(in), optional :: ints(:)
      real(pr), intent(in), optional :: reals(:)
      real(pr), intent(in), optional :: rescale_x_by_fac
      integer                        :: i, uout
      character(len=30)              :: str1, str2, str3
      real(real64)                   :: p, xf
      !
      select type (handle)
      type is (integer)
         uout = handle
      type is (character(len=*))
         open(newunit=uout,file=handle)
      end select
      ! 2 empty lines
      write(uout,*)
      write(uout,*)
      ! header: 3 lines
      if( present(string) ) then
         write(uout,*) "# ", string
      else
         write(uout,*) "# "
      end if
      if( present(ints) ) then
         select type (ints)
         type is (integer(int64))
            write(uout,*) "# ", ints
         type is (integer)
            write(uout,*) "# ", ints
         end select
      else
         write(uout,*) "# "
      end if
      if( present(reals) ) then
         write(uout,*) "# ", reals
      else
         write(uout,*) "# "
      end if
      ! xfactor
      xf = 1.0_pr
      if( present(rescale_x_by_fac) ) xf = rescale_x_by_fac
      ! abstract: 3 lines
      write(str1,*) ( h%x1 )*xf
      write(str2,*) ( h%x1 + (h%bins+1)*h%dx )*xf
      str1 = "# x<"//trim(adjustl(str1))
      str2 = "# x>="//trim(adjustl(str2))
      str3 = "# else"
      write(uout,*) str1, h%miss1, dble(h%miss1)/h%total
      write(uout,*) str2, h%miss2, dble(h%miss2)/h%total
      write(uout,*) str3, h%hit,   dble(h%hit)/h%total
      write(uout,*) "# ", h%bins + 1, h%x1*xf, h%dx*xf
      ! body
      do i = 0, h%bins
         p = dble(h%count(i))/h%total
         write(uout,*) ( h%x1 + i*h%dx )*xf, h%count(i), p, p/h%dx
      end do
      !
      select type (handle)
      type is (character(len=*))
         close(uout)
      end select
      end subroutine write

      !////////////////////////////////////////////
      !////////////////////////////////////////////    hist2d
      !////////////////////////////////////////////

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

      subroutine init_2d(h,x1,x2,dx,y1,y2,dy)
      implicit none
      class(hist2d), intent(inout)   :: h
      real(pr),      intent(in)      :: x1, x2, dx
      real(pr),      intent(in)      :: y1, y2, dy
      h%x1   = min(x1,x2)                ; h%y1   = min(y1,y2)
      h%x2   = max(x1,x2)                ; h%y2   = max(y1,y2)
      h%dx   = abs(dx)                   ; h%dy   = abs(dy)
      h%xbins = floor( (h%x2-h%x1)/h%dx ); h%ybins = floor( (h%y2-h%y1)/h%dy )
      allocate(h%count(0:h%xbins,0:h%ybins))
      h%count  = 0
      h%xmiss1 = 0; h%ymiss1 = 0
      h%hit    = 0
      h%xmiss2 = 0; h%ymiss2 = 0
      h%total  = 0
      end subroutine init_2d

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

      subroutine gather_s_2d(h,x,y)
      implicit none
      class(hist2d), intent(inout) :: h
      real(pr),      intent(in)    :: x, y
      integer                      :: k, j
      k = floor( (x-h%x1)/h%dx )
      if( k<0 ) then
         h%xmiss1 = h%xmiss1 + 1
      else if( k>h%xbins ) then
         h%xmiss2 = h%xmiss2 + 1
      else
          j = floor( (y-h%y1)/h%dy )
          if( j<0 ) then
             h%ymiss1 = h%ymiss1 + 1
          else if( j>h%ybins ) then
             h%ymiss2 = h%ymiss2 + 1
          else
             h%hit = h%hit + 1
             h%count(k,j) = h%count(k,j) + 1
          end if
      end if
      h%total = h%total + 1
      end subroutine gather_s_2d

      subroutine gather_a_2d(h,x,y)
      implicit none
      class(hist2d), intent(inout) :: h
      real(pr),      intent(in)    :: x(:),y(:)
      integer                      :: i
      do i = 1, size(x)
         call gather_s_2d(h,x(i),y(i))
      end do
      end subroutine gather_a_2d

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

      subroutine reset_2d(h)
      implicit none
      class(hist2d), intent(inout) :: h
      h%count  = 0
      h%xmiss1 = 0
      h%ymiss1 = 0
      h%hit    = 0
      h%xmiss2 = 0
      h%ymiss2 = 0
      h%total  = 0
      end subroutine reset_2d

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

      subroutine write_2d(h,handle,string,ints,reals)
      implicit none
      class(hist2d), intent(in)      :: h
      class(*),     intent(in)       :: handle
      character(len=*), intent(in), &
                         optional    :: string
      class(*), intent(in), optional :: ints(:)
      real(pr), intent(in), optional :: reals(:)
      integer                        :: i, j, uout
      character(len=20)              :: str1, str2, str3, &
                                        str4, str5
      real(real64)                   :: p
      !
      select type (handle)
      type is (integer)
         uout = handle
      type is (character(len=*))
         open(newunit=uout,file=handle)
      end select
      ! 2 empty lines
      write(uout,*)
      write(uout,*)
      ! header: 3 lines
      if( present(string) ) then
         write(uout,*) "# ", string
      else
         write(uout,*) "# "
      end if
      if( present(ints) ) then
         select type (ints)
         type is (integer(int64))
            write(uout,*) "# ", ints
         type is (integer)
            write(uout,*) "# ", ints
         end select
      else
         write(uout,*) "# "
      end if
      if( present(reals) ) then
         write(uout,*) "# ", reals
      else
         write(uout,*) "# "
      end if
      ! abstract: 3 lines
      write(str1,*)h%x1
      write(str2,*)h%x1 + (h%xbins+1)*h%dx
      str1 = "# x<"//trim(adjustl(str1))
      str2 = "# x>="//trim(adjustl(str2))
      write(str4,*)h%y1
      write(str5,*)h%y1 + (h%ybins+1)*h%dy
      str4 = "# y<"//trim(adjustl(str4))
      str5 = "# y>="//trim(adjustl(str5))
      str3 = "# else"
      write(uout,*) str1, h%xmiss1, dble(h%xmiss1)/h%total
      write(uout,*) str2, h%xmiss2, dble(h%xmiss2)/h%total
      write(uout,*) "# x in range, but"
      write(uout,*) str4, h%ymiss1, dble(h%ymiss1)/h%total
      write(uout,*) str5, h%ymiss2, dble(h%ymiss2)/h%total
      write(uout,*) str3, h%hit,    dble(h%hit)/h%total
      write(uout,*) "# ", h%xbins + 1, h%x1, h%dx
      write(uout,*) "# ", h%ybins + 1, h%y1, h%dy
      ! body
      do j = 0, h%ybins
         do i = 0, h%xbins
            p = dble(h%count(i,j))/h%total
            write(uout,*) h%x1 + i*h%dx, h%y1 + j*h%dy, &
                          h%count(i,j), p, p/(h%dx*h%dy)
         end do
      end do
      !
      select type (handle)
      type is (character(len=*))
         close(uout)
      end select
      end subroutine write_2d

   end module histogram

   ! example:

!   program main
!   use histogram, only: hist1d
!   use iso_fortran_env, only: real32, output_unit
!   implicit none
!   integer, parameter :: pr = real32
!   type(hist1d) :: h
!   real(pr) :: x(10), xx
!   integer  :: i
!   call h%init(0.1_pr, 0.6_pr, 0.1_pr)
!   do i=1,10**5
!      call random_number(x)
!      call h%gather(x)
!      call random_number(xx)
!      call h%gather(xx)
!   end do
!   call h%write(output_unit)
!   end program main

!   program main
!   use histogram, only: hist2d
!   use iso_fortran_env, only: real32, output_unit
!   implicit none
!   integer, parameter :: pr = real32
!   type(hist2d) :: h
!   real(pr) :: x(10), xx
!   real(pr) :: y(10), yy
!   integer  :: i
!   call h%init(0.1_pr, 0.6_pr, 0.1_pr, 0.2_pr, 0.8_pr, 0.2_pr)
!   do i=1,10**5
!      call random_number(x)
!      call random_number(y)
!      call h%gather(x,y)
!      call random_number(xx)
!      call random_number(yy)
!      call h%gather(xx,yy)
!   end do
!   call h%write(output_unit)
!   end program main


program findroot

  implicit none

  real(8) :: x   ! solution variable
  real(8) :: xl  ! lower bound
  real(8) :: xr  ! upper bound
  real(8) :: f   ! final residual
  real(8) :: tol ! tolerance

  ! function declaration
  external myfun

  ! ask user for guess
  x=1.2

  ! ask for bounds
  xl=0.1
  xr=2.0

  ! ask for tolerance
  tol=0.01

  ! call the bisection
  call bisect(myfun,xl,xr,x,f,tol)

  ! print result
  print *,'Solution is:',x,' with final residual F0.4:',f

end program findroot


SUBROUTINE bilinear_interpolation(nrow, ncol, coordinator, s1, s2, s3, s4, &
                                  cstart, cend, centreline, res)

        integer, intent(in) :: nrow, ncol
        integer, dimension(9, 2), intent(in) :: coordinator
        real*4, dimension(4), intent(in) :: s1, s2, s3, s4
        integer, dimension(ncol), intent(in) :: cstart, cend, centreline
        real*4, dimension(nrow, ncol), intent(inout) :: res

        integer, parameter :: nr=4, nl=4
        real*4, dimension(4, 4) :: a1, a2, a3, a4
        real*4, dimension(4) :: xx, yy
        double precision, dimension(4) :: cof1, cof2, cof3, cof4
        logical solut
        integer i, j, jj, line, istart, iend, icenter

!f2py depend(ncol), cstart, cend, centreline
!f2py depend(nrow, ncol), res

!       the result array, res, is transposed as it is passed into
!       fortran. So nrow, and ncol labelled here in fortran are the
!       cols and rows back in python land.
!       The program was originally written by Fuqin Li,
!       and now converted to a python module via f2py

!       cof is bilinear coefficients
!       boxline (line, istart, iend); now replaced by cstart, cend.

!       program is used to interpolate modtran output from four coordinators
!       nrow image lines, ncol, image column
!       nr,nl are the four coordinators which are used to
!       generate the binear interpolation
!       bilinear equation is expressed as:
!       f(x,y)=a+b(x-x0)+c(y-y0)+d(x-x0)(y-y0)
!       where a,b,c,d are the four coefficients you need to calculate
!       from here. x,y are the pixel coordinator and x0,y0 are the
!       centre pixel coordinators of box

!       reference the 9 point coordinates
        ixul = coordinator(1, 1)
        iyul = coordinator(1, 2)
        ixum = coordinator(2, 1)
        iyum = coordinator(2, 2)
        ixur = coordinator(3, 1)
        iyur = coordinator(3, 2)
        ixml = coordinator(4, 1)
        iyml = coordinator(4, 2)
        ixmm = coordinator(5, 1)
        iymm = coordinator(5, 2)
        ixmr = coordinator(6, 1)
        iymr = coordinator(6, 2)
        ixll = coordinator(7, 1)
        iyll = coordinator(7, 2)
        ixlm = coordinator(8, 1)
        iylm = coordinator(8, 2)
        ixlr = coordinator(9, 1)
        iylr = coordinator(9, 2)

!       for first box
        ix01=(ixul+ixml)/2-ixul+1
        iy01=(iyul+iyum)/2-iyul+1
        xx(1)=ixul-ixul+1
        yy(1)=iyul-iyul+1
        xx(2)=ixum-ixul+1
        yy(2)=iyum-iyul+1
        xx(3)=ixml-ixul+1
        yy(3)=iyml-iyml+1
        xx(4)=ixmm-ixum+1
        yy(4)=iymm-iyml+1
        do i=1,nr
          do j=1,nl
            a1(i,1)=1
            a1(i,2)=(xx(i)-ix01)
            a1(i,3)=(yy(i)-iy01)
            a1(i,4)=(xx(i)-ix01)*(yy(i)-iy01)
          enddo
        enddo

!       for the second box
        ix02=(ixum+ixmm)/2-ixum+1
        iy02=(iyur+iyum)/2-iyul+1
        xx(1)=ixum-ixum+1
        yy(1)=iyum-iyul+1
        xx(2)=ixur-ixur+1
        yy(2)=iyur-iyul+1
        xx(3)=ixmm-ixum+1
        yy(3)=iymm-iyml+1
        xx(4)=ixmr-ixur+1
        yy(4)=iymr-iyml+1
        do i=1,nr
          do j=1,nl
            a2(i,1)=1
            a2(i,2)=(xx(i)-ix02)
            a2(i,3)=(yy(i)-iy02)
            a2(i,4)=(xx(i)-ix02)*(yy(i)-iy02)
          enddo
        enddo

!       for the third box
        ix03=(ixml+ixll)/2-ixul+1
        iy03=(iyml+iymm)/2-iyml+1
        xx(1)=ixml-ixul+1
        yy(1)=iyml-iyml+1
        xx(2)=ixmm-ixum+1
        yy(2)=iymm-iyml+1
        xx(3)=ixll-ixul+1
        yy(3)=iyll-iyll+1
        xx(4)=ixlm-ixum+1
        yy(4)=iylm-iyll+1
        do i=1,nr
          do j=1,nl
            a3(i,1)=1
            a3(i,2)=(xx(i)-ix03)
            a3(i,3)=(yy(i)-iy03)
            a3(i,4)=(xx(i)-ix03)*(yy(i)-iy03)
          enddo
        enddo

!       for the fourth box
        ix04=(ixmm+ixlm)/2-ixum+1
        iy04=(iymm+iymr)/2-iyml+1
        xx(1)=ixmm-ixum+1
        yy(1)=iymm-iyml+1
        xx(2)=ixmr-ixur+1
        yy(2)=iymr-iyml+1
        xx(3)=ixlm-ixum+1
        yy(3)=iylm-iyll+1
        xx(4)=ixlr-ixur+1
        yy(4)=iylr-iyll+1
        do i=1,nr
          do j=1,nl
            a4(i,1)=1
            a4(i,2)=(xx(i)-ix04)
            a4(i,3)=(yy(i)-iy04)
            a4(i,4)=(xx(i)-ix04)*(yy(i)-iy04)
          enddo
        enddo

        call gauss(a1,nr,nl,s1,cof1,solut)

        call gauss(a2,nr,nl,s2,cof2,solut)

        call gauss(a3,nr,nl,s3,cof3,solut)

        call gauss(a4,nr,nl,s4,cof4,solut)

!       calculate bilinear coefficients for four box
        do i=1,ncol
           istart = cstart(i)
           iend = cend(i)
           icenter = centreline(i)

          do j=1,nrow
            jj=j-istart+1
            if (i .lt. ixml) then
              if (j .ge. istart .and.j .lt.icenter) then
!               box 1
                res(j,i)=cof1(1)+cof1(2)*(i-ix01)+cof1(3)*(jj-iy01)+ &
                 cof1(4)*(i-ix01)*(jj-iy01)
              elseif (j .ge. icenter .and.j .le.iend) then
!               box2
                res(j,i)=cof2(1)+cof2(2)*(i-ix02)+cof2(3)*(jj-iy02)+ &
                 cof2(4)*(i-ix02)*(jj-iy02)
              else
                res(j,i)=-999
              endif
            elseif (i .ge. ixml .and. i .le.ixll) then
              if (j .ge. istart .and.j .lt.icenter) then
!               box 3
                res(j,i)=cof3(1)+cof3(2)*(i-ix03)+cof3(3)*(jj-iy03)+ &
                  cof3(4)*(i-ix03)*(jj-iy03)
              elseif (j .ge. icenter .and.j .le.iend) then
!               box4
                res(j,i)=cof4(1)+cof4(2)*(i-ix04)+cof4(3)*(jj-iy04)+ &
                 cof4(4)*(i-ix04)*(jj-iy04)
              else
                res(j,i)=-999
              endif
            else
              res(j,i)=-999
            endif
          enddo
        enddo
        return
END SUBROUTINE bilinear_interpolation

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

SUBROUTINE gauss(a,m,n,b,x,solut)
!     gauss elimination solve ax=b with row and column pivotion
        real a(m,n),b(m)
        double precision x(m)
        logical solut
        integer m, n, k
!       elimination
!       k----eliminate column
        do 30 k=1,n
          ik=k
!         find the best pivot element
          call spiv(a,m,n,b,ik,solut)
          if(solut) then
            do 20 i=k,m
              c=a(i,k)
              if (abs(c) .ne.0.0) then
                do 10 j=k,n
                  a(i,j)=a(i,j)/c
                  if(i.gt.k) then
                    a(i,j)=a(i,j)-a(k,j)
                  endif
10              continue
                b(i)=b(i)/c
                if (i.gt.k) then
                  b(i)=b(i)-b(k)
                endif
              endif
20          continue
          else
            return
          endif
30      continue
!       now back-substiute
        x(m)=b(m)
        do 60 i=m-1,1,-1
          sum=b(i)
          do 50 j=i+1,4
            sum=sum-a(i,j)*x(j)
50        continue
          x(i)=sum
60      continue
        return
END SUBROUTINE gauss

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

SUBROUTINE spiv(a,m,n,b,k,solut)
        real a(m,n),b(m)
        logical solut
        integer k
        integer n, m
        solut=.false.
        do i=k,m
          if (a(i,k).ne.0.0) then
            solut=.true.
          endif
        enddo
        if (solut) then
          l=k
          do j=k,m
            if (abs(a(j,k)).gt.abs(a(l,k))) then
              l=j
            endif
          enddo
          if (l.ne.k) then
            tm=b(k)
            b(k)=b(l)
            b(l)=tm
            do j=k,m
              tm=a(k,j)
              a(k,j)=a(l,j)
              a(l,j)=tm
            enddo
          endif
        endif
        return
END SUBROUTINE spiv


module light_methods

use real_precision

contains

!**********************************************************************!
!                                                                      !
!                     dayl :: light_methods                            !
!                     ---------------------                            !
!                                                                      !
! real(dp) function dayl(lat,day)                                               !
!                                                                      !
!----------------------------------------------------------------------!
!> @brief
!! @details
!! @author Mark Lomas
!! @date Feb 2006
!----------------------------------------------------------------------!
real(dp) function dayl(lat,day)
!**********************************************************************!
implicit none
real(dp) :: lat,del,has,tem
integer :: day
real(dp), parameter :: conv = 1.74532925e-2
!----------------------------------------------------------------------!

del=-23.4*cos(conv*360.0*(day + 10.0)/365.0)
tem=-tan(lat*conv)*tan(del*conv)

if (abs(tem)<1.0) then
  has  = acos(tem)/conv
  dayl = 2.0*has/15.0
elseif (tem>0.0) then
  dayl =  0.0
else
  dayl = 24.0
endif

end function dayl

!**********************************************************************!
!                                                                      !
!                     pfd :: light_methods                             !
!                     --------------------                             !
!                                                                      !
! SUBROUTINE pfd(lat,day,hrs,cloud,direct,diffuse,total)               !
!                                                                      !
!----------------------------------------------------------------------!
!> @brief
!! @details
!! @author Mark Lomas
!! @date Feb 2006
!----------------------------------------------------------------------!
subroutine pfd(lat,day,hrs,cloud,direct,diffuse,total)
!**********************************************************************!
implicit none
real(dp) :: lat,hrs,del,rlat,toa,cloud,diffprop,alpha,beta, &
 sigma,dawn_angle,coscst,direct,diffuse,total,clearness
integer :: day
real(dp), parameter :: conv = 1.74532925e-2, pi = 3.1415927
!----------------------------------------------------------------------!

if (hrs>1e-6) then
  del  = -23.4*cos(conv*360.0*(day+10.0)/365.0)
  del  = del*conv
  rlat = lat*conv

!     solar radiation in watts/m2 average over the day
!     (between sun rise en sun set)

  dawn_angle = (hrs/2.0)*(2.0*pi/24.0)

!Top of atmosphere irradiance, average over the day (daylength).
! 1370 = solar constant in W/m2
  toa = 1370.0*24.0/(pi*hrs)*(sin(rlat)*sin(del)*dawn_angle + &
 cos(rlat)*cos(del)*sin(dawn_angle))

!Account for cloud cover

  coscst = 1.0-1.3614*cos(rlat)
  alpha = 18.0 - 64.884*coscst
  alpha = alpha*4.1842*1.0d4 ! convert from cal/cm to J/m2
  alpha = alpha/(24.0*3600.0) ! convert into w/m2

  beta = 0.682 - 0.3183*coscst

  sigma = 0.02*log(max(cloud,0.001))+0.03259

!Calculate the total irradiance
  total = toa*(beta-sigma*cloud*10.0)-alpha
  if (total<0.0) total=0.0

  clearness= total/toa

!Calculate diffuse irradiance (from Forest ETP WG)

  if(clearness<0.07) then
     diffprop = 1.0
  else if(clearness<0.35) then
     diffprop = 1.0-2.3*(clearness-0.07)**2
  else if(clearness<0.75) then
     diffprop = 1.33-1.46*clearness
  else
     diffprop = 0.23
  endif

  diffuse=total*diffprop

! PAR is about 48% of the total irradiance. A better formula could be
! found.
  total = 0.48*total
  diffuse = 0.48*diffuse ! not sure this is really right (Ghislain)

!Convert in mol/m2/sec 1W/m2=4.6e-6 mol/s/m2 for PAR radiation

  total = 4.6d-6*total
  diffuse = 4.6d-6*diffuse
  direct= total - diffuse
else
  total=0.0
  diffuse=0.0
  direct=0.0
endif

end subroutine pfd

!**********************************************************************!
!                                                                      !
!               pfd_without_cloud :: light_methods                     !
!               ----------------------------------                     !
!                                                                      !
! real(dp) pfd_without_cloud(lat,day,hrs)                              !
!                                                                      !
!----------------------------------------------------------------------!
!> @brief Photon Flux Density
!! @details
!! @author Mark Lomas
!! @date Feb 2006
!----------------------------------------------------------------------!
real(dp) function pfd_without_cloud(lat,day,hrs)
!**********************************************************************!
real(dp) :: lat,hrs,del,rlat,r,sinbt,cloud,st,sdiff,trans
integer :: day
real(dp), parameter :: conv = 1.74532925e-2, pi = 3.1415927
!----------------------------------------------------------------------!

cloud = 0.50

if (hrs>1e-6) then
  del  = -23.4*cos(conv*360.0*(day+10.0)/365.0)
  del  = del*conv
  rlat = lat*conv

  trans = 0.3 + (0.35*(1.0 - cloud))

! solar radiation in watts/m2 at midday
  sinbt = sin(rlat)*sin(del) + cos(rlat)*cos(del)

  if (sinbt>1e-6) then
    r = 1370.0*trans**(1.0/sinbt)*sinbt
    sdiff = 0.3*(1.0 - trans**(1.0/sinbt))*1370.0*sinbt
    st = r + sdiff
    pfd_without_cloud = 2.0*st/pi*(0.5 + cos(rlat)/2.0)*2.1/1.0e+6
  else
   pfd_without_cloud = 0.0
  endif
else
  pfd_without_cloud = 0.0
endif

end function pfd_without_cloud

!**********************************************************************!
!                                                                      !
!                     pfd2 :: light_methods                            !
!                     ---------------------                            !
!                                                                      !
! real(dp) function pfd2(lat,day,hrs)                                           !
!                                                                      !
!----------------------------------------------------------------------!
!> @brief Photon Flux Density
!! @details
!! @author Mark Lomas
!! @date Feb 2006
!----------------------------------------------------------------------!
real(dp) function pfd2(lat,day,hrs)
!**********************************************************************!
real(dp) :: lat,hrs,del,rlat,r,sinbt,rad
integer :: day
real(dp), parameter :: conv = 1.74532925e-2, pi = 3.1415927
!----------------------------------------------------------------------!

if (hrs>1e-6) then
  del  = -23.4*cos(conv*360.0*(day+10.0)/365.0)
  del  = del*conv
  rlat = lat*conv

! solar radiation in watts/m2 at midday
  sinbt = sin(rlat)*sin(del) + cos(rlat)*cos(del)
  r = 1360.0*0.7**1.32*sinbt

! convert to Langleys/day
  r = r/0.485

! account for cloud cover (assume 0.0)
  rad = r*(-0.21843*20.0 + 58.94408)/100.0

! solve for daily maximum (mol/m2/sec)
  pfd2 = (rad*41868.0*pi)/(hrs*2.0*3600.0)
  pfd2 = pfd2*0.5*4.255e-6
else
  pfd2 = 0.0
endif

end function pfd2

!**********************************************************************!
!                                                                      !
!                     pfds :: light_methods                            !
!                     ---------------------                            !
!                                                                      !
! real(dp) function pfds(tdss,hrs)                                              !
!                                                                      !
!----------------------------------------------------------------------!
!> @brief Photon Flux Density
!! @details From Total Downward Shortwave at the Surface (TDSS) -
!! for use with GCM data.
!! @author Mark Lomas
!! @date Feb 2006
!----------------------------------------------------------------------!
real(dp) function pfds(tdss,hrs)
!**********************************************************************!
real(dp) :: tdss,hrs
real(dp), parameter :: pi = 3.1415927
!----------------------------------------------------------------------!

if (hrs>1e-6) then
!Solve for daily maximum (mol/m2/sec)
  pfds = (tdss*pi*24.0)/(hrs*2.0)*4.255e-6
!  pfds = pfds*0.5*4.255E-6
else
  pfds = 0.0
endif

end function pfds

end module light_methods


PROGRAM  question2
    IMPLICIT NONE

    INTEGER:: i, j
    REAL, DIMENSION(3, 5):: matrix, tempMat

    OPEN(UNIT = 11, FILE = "q2_input.txt", STATUS = "OLD", ACTION = "READ")
    DO i = 1, 3
        READ (11, *) (matrix(i, j), j = 1, 5)
    ENDDO
    CLOSE(11)

    OPEN(UNIT = 12, FILE = "q2_output.txt", ACTION = "WRITE", POSITION = "APPEND")

    WRITE(12, *) "The Original Matrix is"
    DO i = 1, 3
        WRITE(12, *) (matrix(i, j), j = 1, 5)
    ENDDO
    WRITE(12, *)

    ! 2a ==> Multiply each of these numbers by 10, and write the output to another text file.

    tempMat = matrix
    tempMat = tempMat * 10

    WRITE(12, *) "2a. After Multiply with 10 matrix is"
    DO i = 1, 3
        WRITE(12, *) (tempMat(i, j), j = 1, 5)
    ENDDO
    WRITE(12, *)
    ! --------------------------------------------------------------------------------------

    ! 2b ==> Multiply elements of the second row by 5.5, and print the whole array.

    DO j = 1, 5
        matrix(2, j) = matrix(2, j) * 5.5
    ENDDO

    WRITE(12, *) "2b. After Multiply Second Row with 5.5 the array is"
    WRITE(12, *) (matrix(2, j), j = 1, 5)
    WRITE(12, *)
    ! -----------------------------------------------------------------------------

    ! 2c ==> Multiply elements of the 3rd column by 5.5, and print the whole array.

    DO j = 1, 5
        matrix(3, j) = matrix(3, j) * 5.5
    ENDDO

    WRITE(12, *) "2c. After Multiply Third Row with 5.5 the array is"
    WRITE(12, *) (matrix(3, j), j = 1, 5)
    ! -------------------------------------------------------------------------------

    CLOSE(12)

END


      SUBROUTINE AVENOR(BUF,OBUF,INDXS,OLEVS,NSAMPS, lprint, last )
!     AVENOR PERFORMS AVERAGE AMPLITUDE NORMALIZATION IN MEMORY.  THE AP VERSION
!  IS AVEVFC.  AVERAGE AMPLITUDE NORMALIZE ADJUSTS THE AVERAGE ABSOLUTE AMPLITUDE
!  WITHIN EACH WINDOW TO A SPECIFIED LEVEL.  IT DOES THIS BY DIVIDING THE
!  LEVEL BY THE AVERAGE ABSOLUTE VALUE OF THE WINDOW IN ORDER TO FORM A
!  MULTIPLIER THAT WILL BE APPLIED TO THE CENTER POINT OF THE WINDOW.
!  DATA UP TO THE FIRST WINDOW MIDPOINT RECEIVE THE FIRST MULTIPLIER.
!  MULTIPLIERS BETWEEN WINDOW MIDPOINTS ARE LINEARLY INTERPOLATED.
!  DATA AFTER THE MIDPOINT OF THE LAST WINDOW RECEIVE THE MULTIPLIER OF THE
!  LAST WINDOW.  (A ONE WINDOW AVENOR RESULTS IS ALL DATA GETTING THE SAME
!  MULTIPLIER).
!      ANY NUMBER OF WINDOWS MAY BE GIVEN, BUT THE LAST WINDOW MUST BE ZERO TIME.
!
!  COPYRIGHTED BY:
!  PAUL HENKART, SEISMIC REFLECTION PROCESSORS, SAN DIEGO, CA.
!  16 JANUARY 1983.  ALL RIGHTS RESERVED.
!
!  mod 11 Oct 02 - Add argument last, which when set non-zero means
!                  to use the multipliers from the last trace rather
!                  than calculate new ones.  The windows/indices may
!                  be different.
!  mod 19 Oct 02 - Print the values on the trace being held (last).
!
!  ARGUMENTS:
!  BUF    - THE INPUT ARRAY
!  OBUF   - THE OUTPUT ARRAY.  THE OUTPUT MAY NOT BE THE SAME AS THE INPUT,
!           EXCEPT WHEN ONLY ONE WINDOW IS GIVEN.
!  INDXS  - AN ARRAY OF INDEXES DEFINING THE WINDOWS.  THE INDEXES MUST BE
!           GIVEN IN PAIRS, START INDEX FOLLOWED BY THE END INDEX.  AS NOTED
!           ABOVE, THE LAST INDEXES MUST BE 0.  THEREFORE, THERE MUST BE
!           2*(THE NUMBER OF WINDOWS)+2 INDEXES.
!  OLEVS  - AN ARRAY OF OUTPUT WINDOW LEVELS.  THERE MUST BE A LEVEL FOR EACH
!           WINDOW.
!  NSAMPS - THE TOTAL NUMBER OF SAMPLES IN THE TRACE
!
!
      DIMENSION INDXS(1),OLEVS(1),BUF(1),OBUF(1)
      DIMENSION rmult_last(4)
      SAVE rmult_last, iprint
      DATA iprint/1/
!
      ICOUNT=-1
      IC=1
   10 ICOUNT=ICOUNT+2                                                   ! SET UP FOR THE NEXT WINDOW
      ISTART=INDXS(ICOUNT)                                              ! THE START INDEX OF THE WINDOW
      IEND=INDXS(ICOUNT+1)                                              ! THE END INDEX OF THE WINDOW
      IF(IEND.LE.ISTART) GO TO 300
      MIDPT=ISTART+(IEND-ISTART)/2                                      ! FIND THE MID POINT OF THE WINDOW
      OLEV=OLEVS(IC)                                                    ! GET THE OUTPUT LEVEL FOR THIS WINDOW
      IC=IC+1
      IF( last .NE. 0 ) THEN
          rmult = rmult_last(ic-1)
          GOTO 110
      ENDIF
      REALN=FLOAT(IEND-ISTART)                                          ! THE WINDOW LENGTH
      AVE=0.
      DO I=ISTART,IEND                                              ! FIND THE AVERAGE ABSOLUTE VALUE
         AVE=AVE+ABS(BUF(I))                                               !  WATCH OUT FOR OVERFLOW !!!!!!!!!
      ENDDO
      AVE=AVE/REALN                                                     ! THESE 2 LINES COULD BE REPLACE BY THE SINGLE LINE
!  100 AVE=AVE+ABS(BUF(I))/REALN                                        ! BUT I DISLIKE DIVIDES ($$$$)
      RMULT=1.
      IF(AVE.NE.0.) RMULT=OLEV/AVE                                      ! WATCH OUT FOR DIVIDE BY ZERO!
      rmult_last(ic-1) = rmult
  110 CONTINUE
      IF( IAND(lprint,4) .NE. 0 ) PRINT *,' Average absolute ave  = ',
     &     ave,' multiplier=',rmult
      IF( iprint .NE. 0 .AND. last .NE. 0 )
     &    PRINT *,ic-1,' multiplier =',rmult
      IF(ICOUNT.NE.1) GO TO 200
      DO I=1,MIDPT                                                  ! DO THE FIRST WINDOW
         OBUF(I)=BUF(I)*RMULT                                              ! MULTIPLY EVERYTHING UP TO AND INCLUDING THE MIDPT
      ENDDO
      RMULT1=RMULT                                                      ! SAVE THE MULTIPLIER
      MIDPT1=MIDPT                                                      ! SAVE THE MIDPOINT
      GO TO 10                                                          ! GO GET THE NEXT WINDOW
!****
!****   DO THE WINDOW IF IT'S NOT THE FIRST OR LAST WINDOW
!****
  200 TEMP=(RMULT-RMULT1)/(MIDPT-MIDPT1+1)                              ! GET THE INTERPOLATOR
      X=0.
      DO I=MIDPT1,MIDPT                                             ! REMBER THAT MIDPT1 WAS THE MIDPOINT OF THE LAST WINDOW
         X=X+1.
         OBUF(I)=BUF(I)*(RMULT1+X*TEMP)
      ENDDO
      RMULT1=RMULT                                                      ! SAVE THE MULTIPLIER AND MIDPOINT FOR THE NEXT WINDOW
      MIDPT1=MIDPT
      GO TO 10                                                          ! GET ANOTHER WINDOW
!****
!****    THIS IS THE LAST WINDOW
!****
  300 DO I=MIDPT1,NSAMPS                                            ! DO IT TO THE END OF THE TRACE
         OBUF(I)=BUF(I)*RMULT                                              ! USE THE MULTIPLIER OF THE LAST WINDOW TO THE END
      ENDDO
      IF( iprint .NE. 0 .AND. last .NE. 0 ) iprint = 0
      RETURN
      END


! This file is part of NHDS
! Copyright (C) 2020 Daniel Verscharen (d.verscharen@ucl.ac.uk)
!All rights reserved.
!
!Redistribution and use in source and binary forms, with or without
!modification, are permitted provided that the following conditions are met:
!
!1. Redistributions of source code must retain the above copyright notice, this
!   list of conditions and the following disclaimer.
!2. Redistributions in binary form must reproduce the above copyright notice,
!   this list of conditions and the following disclaimer in the documentation
!   and/or other materials provided with the distribution.
!
!THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
!ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
!WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
!DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
!ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
!(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
!LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
!ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
!(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
!SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!The views and conclusions contained in the software and documentation are those
!of the authors and should not be interpreted as representing official policies,
!either expressed or implied, of the NHDS project.

subroutine newton_method(x,kz,kperp,quality)
use input_params
implicit none
double  complex :: determinant,prevx,x,detprevx,detx,jump
integer :: iter
double precision :: kperp,kz,dblabs,quality
logical :: go_for_newton

prevx=x-1.d-5-1.d-5*uniti
! newton iteration for the secant method
detprevx=determinant(prevx,kz,kperp)
iter = 0
go_for_newton=.TRUE.
do while((iter.LT.numiter).AND.(go_for_newton))
   iter=iter+1
   detx=determinant(x,kz,kperp)
   if ((dblabs(detx-detprevx).LT.1.d-80).OR.(dblabs(detx).LT.det_D_threshold)) then
        jump=0.d0
        go_for_newton=.FALSE.
   else
      jump=detx*(x-prevx)/(detx-detprevx)
   endif
   prevx=x
   x=x-jump
   detprevx=detx
enddo
if ((iter.GE.numiter).AND.(output_warning)) then
  write (*,*) "WARNING: Insufficient number of iterations (numiter)."
  stop
endif

quality=1.d0*dblabs(detx)

end subroutine

double complex function determinant(x,kz,kperp)
use input_params
implicit none
double complex :: x,D(3,3)
double precision :: kz,kperp

call disptensor(D,x,kz,kperp)

determinant=D(1,1)*D(2,2)*D(3,3)
determinant=determinant+D(1,2)*D(2,3)*D(3,1)+D(1,3)*D(2,1)*D(3,2)
determinant=determinant-D(3,1)*D(2,2)*D(1,3)-D(3,2)*D(2,3)*D(1,1)-D(3,3)*D(2,1)*D(1,2)

end function

double precision function dblabs(z)
implicit none
double complex :: z
double precision :: realpart,imagpart

realpart=1.d0*real(z)
imagpart=1.d0*aimag(z)

dblabs=dsqrt(realpart*realpart+imagpart*imagpart)

end function


c-----------------------------------------------------------------------
      subroutine eval(dimn,x,rslt)
      integer dimn
      real*8 x(1)
      real*8 rslt
      real*8 center

      integer d

      rslt=1
      center=0.1

      do d=1,dimn
        rslt=rslt*tanh(x(d)-center)
        center=center+0.1
      enddo

      end
c-----------------------------------------------------------------------
      program test

      include 'ceedf.h'

      integer ceed,err
      integer x,xq,u,uq
      integer bxl,bul,bxg,bug
      integer dimn,d
      integer i
      integer q
      parameter(q=10)
      integer maxdim
      parameter(maxdim=3)
      integer qdimmax
      parameter(qdimmax=q**maxdim)
      integer xdimmax
      parameter(xdimmax=2**maxdim)
      integer qdim,xdim

      real*8 xx(xdimmax*maxdim)
      real*8 xxx(maxdim)
      real*8 xxq(qdimmax*maxdim)
      real*8 uuq(qdimmax)
      real*8 fx
      integer*8 offset1,offset2

      character arg*32

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      do dimn=1,maxdim
        qdim=q**dimn
        xdim=2**dimn

        do d=0,dimn-1
          do i=1,xdim
            if ((mod(i-1,2**(dimn-d))/(2**(dimn-d-1))).ne.0) then
              xx(d*xdim+i)=1
            else
              xx(d*xdim+i)=-1
            endif
          enddo
        enddo

        call ceedvectorcreate(ceed,xdim*dimn,x,err)
        call ceedvectorsetarray(x,ceed_mem_host,ceed_use_pointer,xx,err)
        call ceedvectorcreate(ceed,qdim*dimn,xq,err)
        call ceedvectorsetvalue(xq,0.d0,err)
        call ceedvectorcreate(ceed,qdim,u,err)
        call ceedvectorsetvalue(u,0.d0,err)
        call ceedvectorcreate(ceed,qdim,uq,err)

        call ceedbasiscreatetensorh1lagrange(ceed,dimn,dimn,2,q,
     $    ceed_gauss_lobatto,bxl,err)
        call ceedbasiscreatetensorh1lagrange(ceed,dimn,1,q,q,
     $    ceed_gauss_lobatto,bul,err)

        call ceedbasisapply(bxl,1,ceed_notranspose,ceed_eval_interp,
     $    x,xq,err)

        call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err)
        do i=1,qdim
          do d=0,dimn-1
            xxx(d+1)=xxq(d*qdim+i+offset1)
          enddo
          call eval(dimn,xxx,uuq(i))
        enddo
        call ceedvectorrestorearrayread(xq,xxq,offset1,err)
        call ceedvectorsetarray(uq,ceed_mem_host,ceed_use_pointer,
     $    uuq,err)

        call ceedbasisapply(bul,1,ceed_transpose,ceed_eval_interp,
     $    uq,u,err)

        call ceedbasiscreatetensorh1lagrange(ceed,dimn,dimn,2,q,
     $    ceed_gauss,bxg,err)
        call ceedbasiscreatetensorh1lagrange(ceed,dimn,1,q,q,
     $    ceed_gauss,bug,err)

        call ceedbasisapply(bxg,1,ceed_notranspose,ceed_eval_interp,
     $    x,xq,err)
        call ceedbasisapply(bug,1,ceed_notranspose,ceed_eval_interp,
     $    u,uq,err)

        call ceedvectorgetarrayread(xq,ceed_mem_host,xxq,offset1,err)
        call ceedvectorgetarrayread(uq,ceed_mem_host,uuq,offset2,err)
        do i=1,qdim
          do d=0,dimn-1
            xxx(d+1)=xxq(d*qdim+i+offset1)
          enddo
          call eval(dimn,xxx,fx)

          if(dabs(uuq(i+offset2)-fx) > 1.0D-4) then
          write(*,*) uuq(i+offset2),' not eqaul to ',fx,dimn,i
          endif
        enddo
        call ceedvectorrestorearrayread(xq,xxq,offset1,err)
        call ceedvectorrestorearrayread(uq,uuq,offest2,err)

        call ceedvectordestroy(x,err)
        call ceedvectordestroy(xq,err)
        call ceedvectordestroy(u,err)
        call ceedvectordestroy(uq,err)
        call ceedbasisdestroy(bxl,err)
        call ceedbasisdestroy(bul,err)
        call ceedbasisdestroy(bxg,err)
        call ceedbasisdestroy(bug,err)
      enddo

      call ceeddestroy(ceed,err)
      end
c-----------------------------------------------------------------------


      SUBROUTINE DGBFA(ABD, LDA, N, ML, MU, IPVT, INFO)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE idamax_I
      USE dscal_I
      USE daxpy_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: LDA
      INTEGER , INTENT(IN) :: N
      INTEGER , INTENT(IN) :: ML
      INTEGER , INTENT(IN) :: MU
      INTEGER , INTENT(OUT) :: INFO
      INTEGER , INTENT(INOUT) :: IPVT(1)
      REAL(DOUBLE)  :: ABD(LDA,1)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, I0, J, JU, JZ, J0, J1, K, KP1, L, LM, M, MM, NM1
      REAL(DOUBLE) :: T
!-----------------------------------------------
!
!     DGBFA FACTORS A DOUBLE PRECISION BAND MATRIX BY ELIMINATION.
!
!     DGBFA IS USUALLY CALLED BY DGBCO, BUT IT CAN BE CALLED
!     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
!
!     ON ENTRY
!
!        ABD     DOUBLE PRECISION(LDA, N)
!                CONTAINS THE MATRIX IN BAND STORAGE.  THE COLUMNS
!                OF THE MATRIX ARE STORED IN THE COLUMNS OF  ABD  AND
!                THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS
!                ML+1 THROUGH 2*ML+MU+1 OF  ABD .
!                SEE THE COMMENTS BELOW FOR DETAILS.
!
!        LDA     INTEGER
!                THE LEADING DIMENSION OF THE ARRAY  ABD .
!                LDA MUST BE .GE. 2*ML + MU + 1 .
!
!        N       INTEGER
!                THE ORDER OF THE ORIGINAL MATRIX.
!
!        ML      INTEGER
!                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
!                0 .LE. ML .LT. N .
!
!        MU      INTEGER
!                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
!                0 .LE. MU .LT. N .
!                MORE EFFICIENT IF  ML .LE. MU .
!     ON RETURN
!
!        ABD     AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
!                THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
!                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
!                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
!                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
!
!        IPVT    INTEGER(N)
!                AN INTEGER VECTOR OF PIVOT INDICES.
!
!        INFO    INTEGER
!                = 0  NORMAL VALUE.
!                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
!                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
!                     INDICATE THAT DGBSL WILL DIVIDE BY ZERO IF
!                     CALLED.  USE  RCOND  IN DGBCO FOR A RELIABLE
!                     INDICATION OF SINGULARITY.
!
!     BAND STORAGE
!
!           IF  A  IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT
!           WILL SET UP THE INPUT.
!
!                   ML = (BAND WIDTH BELOW THE DIAGONAL)
!                   MU = (BAND WIDTH ABOVE THE DIAGONAL)
!                   M = ML + MU + 1
!                   DO 20 J = 1, N
!                      I1 = MAX0(1, J-MU)
!                      I2 = MIN0(N, J+ML)
!                      DO 10 I = I1, I2
!                         K = I - J + M
!                         ABD(K,J) = A(I,J)
!                10    CONTINUE
!                20 CONTINUE
!
!           THIS USES ROWS  ML+1  THROUGH  2*ML+MU+1  OF  ABD .
!           IN ADDITION, THE FIRST  ML  ROWS IN  ABD  ARE USED FOR
!           ELEMENTS GENERATED DURING THE TRIANGULARIZATION.
!           THE TOTAL NUMBER OF ROWS NEEDED IN  ABD  IS  2*ML+MU+1 .
!           THE  ML+MU BY ML+MU  UPPER LEFT TRIANGLE AND THE
!           ML BY ML  LOWER RIGHT TRIANGLE ARE NOT REFERENCED.
!
!     LINPACK. THIS VERSION DATED 08/14/78 .
!     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
!
!     SUBROUTINES AND FUNCTIONS
!
!     BLAS DAXPY,DSCAL,IDAMAX
!     FORTRAN MAX0,MIN0
!
!     INTERNAL VARIABLES
!
!
!
      M = ML + MU + 1
      INFO = 0
!
!     ZERO INITIAL FILL-IN COLUMNS
!
      J0 = MU + 2
      J1 = MIN0(N,M) - 1
      IF (J1 >= J0) THEN
         DO JZ = J0, J1
            I0 = M + 1 - JZ
            ABD(I0:ML,JZ) = 0.0D0
         END DO
      ENDIF
      JZ = J1
      JU = 0
!
!     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
!
      NM1 = N - 1
      IF (NM1 >= 1) THEN
         DO K = 1, NM1
            KP1 = K + 1
!
!        ZERO NEXT FILL-IN COLUMN
!
            JZ = JZ + 1
            IF (JZ <= N) THEN
               IF (ML >= 1) THEN
                  ABD(:ML,JZ) = 0.0D0
               ENDIF
            ENDIF
!
!        FIND L = PIVOT INDEX
!
            LM = MIN0(ML,N - K)
            L = IDAMAX(LM + 1,ABD(M,K),1) + M - 1
            IPVT(K) = L + K - M
!
!        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
!
            IF (ABD(L,K) /= 0.0D0) THEN
!
!           INTERCHANGE IF NECESSARY
!
               IF (L /= M) THEN
                  T = ABD(L,K)
                  ABD(L,K) = ABD(M,K)
                  ABD(M,K) = T
               ENDIF
!
!           COMPUTE MULTIPLIERS
!
               T = -1.0D0/ABD(M,K)
               CALL DSCAL (LM, T, ABD(M+1,K), 1)
!
!           ROW ELIMINATION WITH COLUMN INDEXING
!
               JU = MIN0(MAX0(JU,MU + IPVT(K)),N)
               MM = M
               IF (JU >= KP1) THEN
                  DO J = KP1, JU
                     L = L - 1
                     MM = MM - 1
                     T = ABD(L,J)
                     IF (L /= MM) THEN
                        ABD(L,J) = ABD(MM,J)
                        ABD(MM,J) = T
                     ENDIF
                     CALL DAXPY (LM, T, ABD(M+1,K), 1, ABD(MM+1,J), 1)
                  END DO
               ENDIF
            ELSE
               INFO = K
            ENDIF
         END DO
      ENDIF
      IPVT(N) = N
      IF (ABD(M,N) == 0.0D0) INFO = N
      RETURN
      END SUBROUTINE DGBFA


! multidimensional FFT from Numerical Recipes in Fortran 77, Press et al.
!234567890
      subroutine fourn(data,nn,ndim,isign)
      integer isign,ndim,nn(ndim)
      double precision data(*)
      integer ii,i2,i2rev,i3,i3rev,ibit,idim,ifp1,ifp2,ip1,ip2
      integer ip3,k1,k2,n,nprev,nrem,ntot
      double precision tempi,tempr
      double precision theta,wi,wpi,wpr,wr,wtemp

      ntot=1
      do idim=1,ndim
        ntot=ntot*nn(idim)
      enddo
      nprev=1

      do idim=1,ndim
        n=nn(idim)
        nrem=ntot/(n*nprev)
        ip1=2*nprev
        ip2=ip1*n
        ip3=ip2*nrem
        i2rev=1
        do i2=1,ip2,ip1
          if (i2.lt.i2rev) then
            do i1=i2,i2+ip1-2,2
              do i3=i1,ip3,ip2
                i3rev=i2rev+i3-i2
                tempr=data(i3)
                tempi=data(i3+1)
                data(i3)=data(i3rev)
                data(i3+1)=data(i3rev+1)
                data(i3rev)=tempr
                data(i3rev+1)=tempi
              enddo
            enddo
          endif
          ibit=ip2/2
 1        if ((ibit.ge.ip1).and.(i2rev.gt.ibit)) then
            i2rev=i2rev-ibit
            ibit=ibit/2
          goto 1
          endif
          i2rev=i2rev+ibit
        enddo
        ifp1=ip1
 2      if (ifp1.lt.ip2) then
          ifp2=2*ifp1
          theta=isign*6.28318530717959d0/(ifp2/ip1)
          wpr=-2.d0*sin(0.5d0*theta)**2
          wpi=sin(theta)
          wr=1.d0
          wi=0.d0
          do i3=1,ifp1,ip1
            do i1=i3,i3+ip1-2,2
              do i2=i1,ip3,ifp2
                k1=i2
                k2=k1+ifp1
                tempr=wr*data(k2)-wi*data(k2+1)
                tempi=wr*data(k2+1)+wi*data(k2)
                data(k2)=data(k1)-tempr
                data(k2+1)=data(k1+1)-tempi
                data(k1)=data(k1)+tempr
                data(k1+1)=data(k1+1)+tempi
              enddo
            enddo
            wtemp=wr
            wr=wr*wpr-wi*wpi+wr
            wi=wi*wpr+wtemp*wpi+wi
          enddo
          ifp1=ifp2
        goto 2
        endif
        nprev=n*nprev
      enddo

      return
      end