    Subroutine nagf_blas_zmload(matrix, m, n, con, diag, a, lda)

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     NAGF_BLAS_ZMLOAD forms the m by n matrix A given by

!     a( i, j ) = (  diag  i.eq.j,
!                  (
!                  ( const  i.ne.j.

!     If   MATRIX = 'G' or 'g'   then  A  is regarded  as a general matrix,
!     if   MATRIX = 'U' or 'u'   then  A  is regarded  as upper triangular,
!                              and only  elements  for which  i.le.j  are
!                              referenced,
!     if   MATRIX = 'L' or 'l'   then  A  is regarded  as lower triangular,
!                              and only  elements  for which  i.ge.j  are
!                              referenced.

!     Nag Fortran 77 O( n**2 ) basic linear algebra routine.

!     -- Written on 21-November-1986.
!     Sven Hammarling, Nag Central Office.

!     .. Use Statements ..
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Scalar Arguments ..
      Complex (Kind=dp), Intent (In) :: con, diag
      Integer, Intent (In) :: lda, m, n
      Character (1), Intent (In) :: matrix
!     .. Array Arguments ..
      Complex (Kind=dp), Intent (Inout) :: a(lda, *)
!     .. Local Scalars ..
      Integer :: i, j
!     .. Intrinsic Procedures ..
      Intrinsic :: min
!     .. Executable Statements ..
      Continue

      If ((matrix=='G') .Or. (matrix=='g')) Then
        Do j = 1, n
          Do i = 1, m
            a(i, j) = con
          End Do
        End Do
        If (con/=diag) Then
          Do i = 1, min(m, n)
            a(i, i) = diag
          End Do
        End If
      Else If ((matrix=='U') .Or. (matrix=='u')) Then
        Do j = 1, n
          Do i = 1, min(m, j)
            a(i, j) = con
          End Do
        End Do
        If (con/=diag) Then
          Do i = 1, min(m, n)
            a(i, i) = diag
          End Do
        End If
      Else If ((matrix=='L') .Or. (matrix=='l')) Then
        Do j = 1, min(m, n)
          Do i = j, m
            a(i, j) = con
          End Do
        End Do
        If (con/=diag) Then
          Do i = 1, min(m, n)
            a(i, i) = diag
          End Do
        End If
      End If

      Return

!     End of NAGF_BLAS_ZMLOAD.

    End Subroutine


!************************************************************
!
!  This example shows how to read and write floating point
!  datatypes to an attribute.  The program first writes
!  floating point numbers to an attribute with a dataspace of
!  DIM0xDIM1, then closes the file.  Next, it reopens the
!  file, reads back the data, and outputs it to the screen.
!
!  This file is intended for use with HDF5 Library version 1.8
!  with --enable-fortran2003
!
!************************************************************
PROGRAM main

  USE HDF5
  USE ISO_C_BINDING

  IMPLICIT NONE
  ! This should map to REAL*8 on most modern processors
  INTEGER, PARAMETER :: real_kind_15 = SELECTED_REAL_KIND(Fortran_REAL_8)

  CHARACTER(LEN=22), PARAMETER :: filename  = "h5ex_t_floatatt_F03.h5"
  CHARACTER(LEN=3) , PARAMETER :: dataset   = "DS1"
  CHARACTER(LEN=2) , PARAMETER :: attribute = "A1"
  INTEGER          , PARAMETER :: dim0      = 4
  INTEGER          , PARAMETER :: dim1      = 7

  INTEGER(HID_T)  :: file, space, dset, attr ! Handles
  INTEGER :: hdferr

  INTEGER(hsize_t),   DIMENSION(1:2) :: dims = (/dim0, dim1/)
  REAL(KIND=real_kind_15), DIMENSION(1:dim0, 1:dim1), TARGET :: wdata ! Write buffer
  REAL(KIND=real_kind_15), DIMENSION(:,:), ALLOCATABLE, TARGET :: rdata ! Read buffer
  INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
  INTEGER :: i, j
  TYPE(C_PTR) :: f_ptr
  !
  ! Initialize FORTRAN interface.
  !
  CALL h5open_f(hdferr)
  !
  ! Initialize DATA.
  !
  DO i = 1, dim0
     DO j = 1, dim1
        wdata(i,j) = REAL(i-1,real_kind_15) / ( REAL(j-1,real_kind_15)+0.5_real_kind_15) + j-1
     ENDDO
  ENDDO
  !
  ! Create a new file using the default properties.
  !
  CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, hdferr)
  !
  ! Create dataspace with a null dataspace.
  !
  CALL H5Screate_f(H5S_NULL_F, space, hdferr)
  CALL h5dcreate_f(file, dataset, H5T_STD_I32LE, space, dset, hdferr)
  CALL h5sclose_f(space, hdferr)
  !
  ! Create dataspace.  Setting maximum size to be the current size.
  !
  CALL h5screate_simple_f(2, dims, space, hdferr)
  !
  ! Create the attribute and write the floating point data to it.
  ! In this example we will save the data as 64 bit little endian
  ! IEEE floating point numbers, regardless of the native type.  The
  ! HDF5 library automatically converts between different floating
  ! point types.
  !
  CALL H5Acreate_f(dset, attribute, H5T_IEEE_F64LE, space, attr, hdferr)
  f_ptr = C_LOC(wdata(1,1))
  CALL H5Awrite_f(attr, H5T_NATIVE_DOUBLE, f_ptr, hdferr)
  !
  ! Close and release resources.
  !
  CALL H5Aclose_f(attr, hdferr)
  CALL H5Dclose_f(dset, hdferr)
  CALL H5Fclose_f(file, hdferr)
  !
  ! Now we begin the read section of this example.
  !
  ! Open file and dataset, and attribute.
  !
  CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, hdferr)
  CALL h5dopen_f(file, dataset, dset, hdferr)
  CALL h5aopen_f(dset, attribute, attr, hdferr)
  !
  ! Get dataspace and allocate memory for read buffer.
  !
  CALL h5aget_space_f(attr, space, hdferr)
  CALL h5sget_simple_extent_dims_f(space, dims, maxdims, hdferr)

  ALLOCATE(rdata(1:dims(1),1:dims(2)))
  !
  ! Read the data.
  !
  f_ptr = C_LOC(rdata(1,1))
  CALL h5aread_f( attr, H5T_NATIVE_DOUBLE, f_ptr, hdferr)
  !
  ! Output the data to the screen.
  !
  WRITE(*, '(A,":")') attribute
  DO i=1, dims(1)
     WRITE(*,'(" [")', ADVANCE='NO')
     WRITE(*,'(80(x,f9.4))', ADVANCE='NO') rdata(i,1:dims(2))
     WRITE(*,'(" ]")')
  ENDDO
  !
  ! Close and release resources.
  !
  DEALLOCATE(rdata)
  CALL h5aclose_f(attr , hdferr)
  CALL h5dclose_f(dset , hdferr)
  CALL h5sclose_f(space, hdferr)
  CALL h5fclose_f(file , hdferr)
END PROGRAM main


! Part of the LLVM Project, under the Apache License v2.0 with LLVM          Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! Tests "generic procedure interfaces named the same as a type in the same
! module", a.k.a. "Type Overloading"

! This is a slightly modified version of Figure 17.1 in
! Fortran 95/2003 Explained by Metcalf, Reid & Cohen.
! All modifications are marked.
!

!this module is check for accessing member variables of type real16

module oop_quad_module
  private
  public :: myquad
  type myquad
    real(16) :: x
    contains
      procedure :: getx
  end type
    contains
      real(16) function getx(this)
        class(myquad) :: this
        getx = this%x
      end function getx
end module oop_quad_module

program myuse
  use oop_quad_module
    logical rslt, expect
    type(myquad) :: a
    rslt = .false.
    expect = .true.

    a = myquad(x = 1.0)
    rslt = a%getx() .eq. 1.0

    call check(rslt,expect,1)

end program myuse


    subroutine DOfA(O2,out)
!   ***********************
    implicit none
    include 'combine_foam.inc'

    out=4.7862d+01*O2*O2*O2*O2-3.6086d+1*O2*O2*O2 &
        +6.3448*O2*O2-2.2631*O2+1.0000

!   O.414 [] en moles / m3 de l'oxygene / degré d'anoxie

    if (O2.gt.0.414) then
        out=0.
    endif
!    ! no Oxygen P-feedback
!    out=0.495
    return
    end


! ------------------------
      program qm
      use mass
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccccccc Coupled Morse oscillators ccccccccccccccccccccccccccccccccccccc
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

	implicit real*8 (a-h,o-z)
	integer*4 ni,nj
	parameter (ni=128, nj=512)
	real*8 ak2(ni,nj),norm,akx(ni,nj),aky(ni,nj)
	complex*16 v(ni,nj)
	complex*16 im,psi(ni,nj),hpsi(ni,nj)
	complex*16 psi0(ni,nj),c1,c2,po,ki
	real*8 :: corr,wx,wy,hbar
      integer*4 ipot
	common /params/ d,x0,y0,di,wi
	common /para/ hbar
	common /para1/wx,wy,corr
	common /grid/ xmin,ymin,xmax,ymax,dx,dy
	common /ini/ qx0,qy0,px0,py0
	common /wav/ ax,ay
      common /pes/ ipot
      common /four/emin,emax,DE
C
C
	im=(0.d0,1.d0)
	pi=4.d0*atan(1.d0)
	N2=ni*nj
	d=160d0
	X0=0d0
	y0=0d0
c	hbar=0.06d0
c	z0=1.04435d0
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	open(15,file='cor1')
	open(16,file='cor2')
	open(17,file='wf0')
	open(18,file='wft')
	open(19,file='xav')
	open(20,file='en.dat')
      open(21,file='cwf')
      open(22,file='cor')
      open(23, file = 'norm.dat')
      open(120,file='ps.dat')
	open(5,file='IN')
c time propagation parameters
	read(5,*) dt,kmax,nout
	read(5,*) mx,my
c initial wave packet parameters
	read(5,*) ax,ay
	read(5,*) qx0,qy0
	read(5,*) px0,py0
c potential surface parameters
        read(5,*) DI,WI
	read(5,*) xmin,ymin
	read(5,*) xmax,ymax
	read(5,*) wx,wy
	read(5,*) corr
      read(5,*) ipot
	close(5)
c inverse mass prefactor 1/2/m
c hydrogen
c deuterium m=2*mh
c	am=0.5d0
c	alfa=alfa*sqrt(2.d0)
cc tritium=3*mh
c	am=1.d0/3.d0
cc	alfa=alfa*sqrt(3.d0)
cc
C	ax=wx*sqrt(mx)/(2d0)
C	ay=wy*sqrt(my)/(2d0)
	dx=(xmax-xmin)/ni
	dy=(ymax-ymin)/nj
	ds=dx*dy

      hbar = 1d0

      emin = 0.001
      emax = 4d0
      de = 0.001d0
c--------------------------------------------------
c 	print out initial conditions
c--------------------------------------------------
        write(*,*)'initial state'
	print *,'constants for initial wavefunction'
	print *,'ax =',ax
	print *,'ay =',ay
	print *,'initial center of  wavepacket'
	print *,'qx0 =',qx0
	print *,'qy0 =',qy0
	print *,'initial momentum'
	print *,'px0 =',px0
	print *,'py0 =',py0
	print *,'grid size'
	print *,'xmin =',xmin
	print *,'ymin =',ymin
	print *,'xmax =',xmax
	print *,'ymax =',ymax
	print *,'dx =',dx
	print *,'dy =',dy
	print *,'mass'
	print *,'mx =',mx
	print *,'my =',my
c----------------------------------------
c 	define vector ak2
c----------------------------------------
	consI=2.d0*hbar*pi/dx/ni
	consJ=2.d0*hbar*pi/dy/nj
	ni2=ni/2
	nj2=nj/2
	do j=1,nj
	 akj=(j-1)*consj
	 if (j.gt.nj2) akj=-(nj+1-j)*consj
	 do  i=1,ni
	  aki=(i-1)*consi
	  if (i.gt.ni2) aki=-(ni+1-i)*consi
	akx(i,j)=(aki*aki/(2d0*mx))
	aky(i,j)=(akj*akj/(2d0*my))
	ak2(i,j)=aki*aki/(2d0*mx)+akj*akj/(2d0*my)
        enddo
        enddo
c------------ set up the initial wavefunction -----------------------
      an0=hbar*pi/2d0/dsqrt(ax*ay)
      an0=1d0/dsqrt(an0)

	ch_n=0d0
	 do j=1,nj
         y=ymin+dy*(j-1)
          do i=1,ni
           x=xmin+dx*(i-1)
           psi(i,j)= exp(-ax*(x-qx0)**2/hbar-ay*(y-qy0)**2/hbar
     &             + im*px0*(x-qx0)/hbar+im*py0*(y-qy0)/hbar)
          psi(i,j) = an0*psi(i,j)

	   !if(abs(psi(i,j)).gt.1d-3)
	 write(17,*) x,y,abs(psi(i,j))
         ch_n=ch_n+conjg(psi(i,j))*psi(i,j)*ds
	enddo
	write (17,*) ' '
	enddo

      write(*,*) 'NORM=',ch_n

      psi0 = psi
cccccccccccccccccc propagate psi ccccccccccccccccccccccccccccccccc
	call ham(ni,nj,N2,ak2,akx,aky,psi,v,hpsi,en0,enx,eny,po,ki)
	call correl(ni,nj,psi0,psi,c1,c2)
	t=0.d0
	write(15,1000) t,c1,abs(c1)
	write(16,1000) 2d0*t,c2,abs(c2)
      print *,'proceeding........'
	call split(kmax,nout,ni,nj,N2,dt,t,v,ak2,akx,aky,psi0,psi)
c------------ print the final  wavefunction -----------------------
c	norm=0d0
	do j=1,nj
         y=ymin+(j-1)*dy
	 do i=1,ni
	  x=xmin+dx*(i-1)
	  if(abs(psi(i,j)).gt.1d-3) then
c	norm=norm+conjg(psi(i,j))*psi(i,j)*ds
	    write(18,*) x,y,abs(psi(i,j))
          endif
	enddo
	write (18,*) ' '
	enddo
c	print *,'Norm_Final =',norm

c--------------------------------------------------------------------

1000  format(1000(e14.7,1x))
	stop
	end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	subroutine ham(ni,nj,N2,ak2,akx,aky,psi,v,hpsi,
     &   en0,enx,eny,po,ki)
	implicit real*8(a-h,o-z)
	integer*4,intent(IN) :: ni,nj
	complex*16 psi(ni,nj),hpsi(ni,nj),tpsi(ni,nj),vpsi(ni,nj),
     & aux(ni,nj),auy(ni,nj),vxpsi(ni,nj),vypsi(ni,nj)
	real*8,intent(IN):: ak2(ni,nj),akx(ni,nj),aky(ni,nj)
	complex*16 v(ni,nj),c,enkx,enky,po,ki
        real*8,intent(OUT)::en0,enx,eny
	real*8 :: evx,evy
	common /grid/ xmin,ymin,xmax,ymax,dx,dy
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	call potpsi(ni,nj,v,psi,vpsi)
	call aver(ni,nj,psi,vpsi,po)
c	en0=dreal(po)
c	call aver(ni,nj,psi,vxpsi,envx)
c	call aver(ni,nj,psi,vypsi,envy)
c	write(*,*) 'potential energy',C

	call kinpsi(ni,nj,N2,ak2,psi,tpsi)
	call aver(ni,nj,psi,tpsi,ki)
	call kinpsi(ni,nj,N2,akx,psi,aux)
	call aver(ni,nj,psi,aux,enkx)
	call kinpsi(ni,nj,N2,aky,psi,auy)
	call aver(ni,nj,psi,auy,enky)
	call xex2(ni,nj,psi,evx,evy)
c	write(*,*) 'kinetic energy', C
	en0=dreal(ki+po)
	enx=dreal(enkx)+evx
	eny=dreal(enky)+evy
C	write(*,*) 'TOTAL E', en0
	do  j=1,nj
	 do  i=1,ni
	  hpsi(i,j)=tpsi(i,j)+vpsi(i,j)
	enddo
	enddo
	return
	end subroutine

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	subroutine potpsi(ni,nj,v,psi,vpsi)
	implicit real*8(a-h,o-z)
	integer*4,intent(IN) :: ni,nj
      integer*4 ipot
	real*8 corr,wx,wy,De,Xe,k2
      complex*16,intent(IN)::psi(ni,nj)
      complex*16::v(ni,nj),vx(ni,nj),vy(ni,nj)
	complex*16,intent(OUT)::vpsi(ni,nj)
C
	common /params/ d,x0,y0,di,wi
	common /grid/ xmin,ymin,xmax,ymax,dx,dy
	common /para1/wx,wy,corr
      common /pes/ ipot
c------------- set up potetial -------------------------------------------
c--------------------------------------------
      k2=0.3696726511d0
      De=160d0
      Xe=1.4d0
      epi = 0.d0

      DO j=1,nj
         y=ymin+(j-1)*dy
      DO i=1,ni
         x=xmin+(i-1)*dx
C Morse
      IF(IPOT .EQ. 1) THEN
      v(i,j)=De*(1d0-exp(-(x-xe)))**2+y**2/2d0
      vpsi(i,j)=psi(i,j)*v(i,j)
C Eckart
      ELSEIF(IPOT .EQ. 2) THEN
      v(i,j)=0.063740d0-0.060553d0/(1d0+exp(-1.5d0*x))-
     & 0.0981148d0/(cosh(0.75d0*x))**2+k2*(y-1.40d0)**2/2d0
      vpsi(i,j)=psi(i,j)*v(i,j)
C Henon-Hails
      ELSEIF(IPOT .eq. 3) THEN
        v(i,j)=(x**2 + y**2)/2d0 + epi*x*y

! --- reactive scattering
      elseif(ipot == 4) then

      ak1 = 5.0
      ak2 = 15.0
      b = 0.5d0
      v0 = 16d0
      g = 1.3624d0

      ak = 0.5*(ak1+ak2)+0.5*(ak2-ak1)*tanh(b*y)
      v(i,j) = 0.5*ak*x**2 + v0/cosh(g*y)**2
c        vx(i,j)=wx**2*x**2/2d0
c        vy(i,j)=wy**2*y**2/2d0
c          if(vr.gt.5d0*d) vr=5d0*d
c          vi=0d0
c          r=dsqrt(rx*rx+ry*ry)
c          if(r.gt.wi) vi=vi+di*(r-wi)**2
c          v(i,j)=vr-im*vi
        vpsi(i,j)=psi(i,j)*v(i,j)
c        vxpsi(i,j)=psi(i,j)*vx(i,j)
c        vypsi(i,j)=psi(i,j)*vy(i,j)
      ENDIF
	enddo
	enddo
        return
        end subroutine

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
        subroutine kinpsi(ni,nj,N2,ak2,cx1,aux)
        implicit real*8(a-h,o-z)
c	parameter(nij=512)
	integer*4,intent(IN) :: ni,nj
        dimension ak2(ni,nj)
        complex*16 cx1(ni,nj),aux(ni,nj)
        dimension nn(2)
        nn(1)=ni
        nn(2)=nj
        do 10 j=1,nj
         do 10 i=1,ni
10      aux(i,j)=cx1(i,j)
        call fourn(aux,nn,2,1)
        do 11 j=1,nj
         do 11 i=1,ni
11      aux(i,j)=aux(i,j)*ak2(i,j)
        isign=-1
        call fourn(aux,nn,2,-1)
        do 12 j=1,nj
         do 12 i=1,ni
12      aux(i,j)=aux(i,j)/N2
        return
        end

c-------------------------------------------------------
c-------------------------------------------------------
      subroutine split(kmax,nout,ni,nj,N2,dt,t,v,ak2,akx,
     &  aky,psi0,psi)
      use mass
      use sci

      implicit real*8(a-h,o-z)
      integer*4,intent(IN)::ni,nj
      dimension ak2(ni,nj),akx(ni,nj),aky(ni,nj)
      dimension nn(2)
      complex*16:: psi(ni,nj),v(ni,nj),po,ki,cor(kmax)
      complex*16 psi0(ni,nj),hpsi(ni,nj),c1,c2,out(kmax)

      real (kind = 8), dimension(ni,nj) ::  dphi,phi
      real (kind = 8) fd4(5)

	common /grid/ xmin,ymin,xmax,ymax,dx,dy
      common/correlation/cor_d
      common/four/emin,emax,de
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      open(23,file = 'den.dat' )
      open(24,file = 'norm.dat')

      dt2=dt*0.5
	n2=ni*nj
      nn(1)=ni
      nn(2)=nj

      do 11 k=1,kmax
	  t=t+dt

! --- nonlinear operator exp(-i*dt*L)
! --- subtract quantum potential of CDOF

        call cqpot(ni,nj,psi,dt)

         call fourn(psi,nn,2,1)
         call diff(psi,ak2,dt2,ni,nj)
         call fourn(psi,nn,2,-1)
         do 12 j=1,nj
          do 12 i=1,ni
12       psi(i,j)=psi(i,j)/N2

         call phase(psi,v,dt2,ni,nj)
         call fourn(psi,nn,2,1)
         call diff(psi,ak2,dt2,ni,nj)
         call fourn(psi,nn,2,-1)
         do 13 j=1,nj
          do 13 i=1,ni
13       psi(i,j)=psi(i,j)/N2
      call phase(psi,v,dt2,ni,nj)

! --- observables

      call correl(ni,nj,psi0,psi,c1,c2)
      cor(k) = c1

      call ham(ni,nj,N2,ak2,akx,aky,psi,v,hpsi,en0,enx,eny,po,ki)
!	call xex(ni,nj,psi,xav,yav,xx,yy,ex)
!	call cor(ni,nj,psi0,psi,auto,au_x,au_y)
!      write(22,1000) t,cor_d
      write(20,1000) t,po,ki,en0
	write(15,1000) t,c1,abs(c1)
!	write(16,1000) 2d0*t,c2,abs(c2)
!	write(19,1000) t,xav,yav,xx,yy,auto,au_x,au_y
cccccc 	print out the wavefunction for every time step
C	do s=1,100
C	if(k==s*kmax/100) then
C	do j=1,nj
C		y=ymin+(j-1)*dy
C	do i=1,ni
C		x=xmin+(i-1)*dx
C	write(21,*) x,y,abs(psi(i,j))
C	enddo
C	write(21,*) ' '
C	enddo
C	write(21,*) ' '
C	write(21,*) ' '
C	endif
C	enddo

! --- normalization
      a1 = 0d0
	do j=1,nj
	  y=ymin+(j-1)*dy
	do i=1,ni
	  x=xmin+(i-1)*dx
	  a1 = a1 + abs(psi(i,j))**2*dx*dy
      enddo
      enddo
      write(100,1000) t,a1

      ak1 = 15d0
!      ak2 = 15d0
      pi = 4d0*atan(1.0)
      alfa = dsqrt(ak1)/2d0
      anrm = dsqrt(alfa/pi)

      d0 = 0d0
      d1 = 0d0
      do j=1,nj
        y=ymin+(j-1)*dy
      if( y > 0d0) then
      do i=1,ni
        x=xmin+(i-1)*dx
        d0 = d0+abs(psi(i,j))**2*exp(-alfa*x**2)*dy*dx
        d1 = d1+abs(psi(i,j))**2*x**2*exp(-alfa*x**2)*dx*dy
      enddo
      endif
      enddo

      d0 = d0*anrm
      d1 = d1*dsqrt(alfa/pi)*(2d0*alfa)

      write(23,1000) t,d0,d1

11	enddo

      close(23)

      call fourier(cor,kmax,dt,out)

      i=1
      do while (Emin+(i-1)*De<Emax .and. i<=kmax)
        en = Emin + (i-1)*de
        write(120,1000) en, out(i)
        i = i+1
      enddo

1000  format(1000(e14.7,1x))
15	return
	end

!-----fourier transform----------------------
      subroutine fourier(data,Nt,dt,out)
      implicit real*8(a-h,o-z)
      integer*4, intent(in) :: nt
      complex*16 :: im,data(Nt),out(Nt)
      common/four/Emin,Emax,de

      im = (0d0,1d0)
      Pi = 4.0d0*atan(1d0)
!      alfa = 1d0/2d0**4
      alfa = 0d0

      out = (0d0,0d0)

        i = 1
        do while (Emin+(i-1)*De<Emax.and.i<=Nt)
        en = Emin + (i-1)*de
        do j=1,Nt
          t = 0d0 +j*dt
          out(i) = 1d0/2d0/Pi*2d0*real(data(j)*exp(im*en*t))*
     +             exp(-alfa*t**2)*dt + out(i)
        enddo
        i=i+1
        end do

        return
        end subroutine
!------------------------------------------------
c-------------------------------------------------------
	subroutine diff(cwf,ak2,ts,ni,nj)
	implicit real*8(a-h,o-z)
	integer*4,intent(IN)::ni,nj
	complex*16 nim,cwf(ni,nj)
	dimension ak2(ni,nj)
	real*8 :: hbar
	common /para/ hbar
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	nim=(0.d0,-1.d0)
	do 11 j=1,nj
	 do 11 i=1,ni
11	cwf(i,j)=cwf(i,j)*exp(nim*ts*ak2(i,j)/hbar)
	return
	end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine phase(cwf,v,ts,ni,nj)
	implicit real*8(a-h,o-z)
	complex*16 nim,cwf(ni,nj)
	complex*16 v(ni,nj)
	real*8 :: hbar
	common /para/ hbar
cccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	nim=(0.d0,-1.d0)
	do 11 j=1,nj
	 do 11 i=1,ni
	if (ts.ge.0) cwf(i,j)=cwf(i,j)*exp(nim*ts*v(i,j)/hbar)
11	if (ts.lt.0) cwf(i,j)=cwf(i,j)*exp(nim*ts*conjg(v(i,j))/hbar)
	return
	end

c-------------------------------------------------------
c-------------------------------------------------------
	subroutine correl(ni,nj,psi0,psi,c1,c2)
	implicit real*8(a-h,o-z)
      integer*4,intent(IN)::ni,nj
	complex*16 psi0(ni,nj),psi(ni,nj),c1,c2
	common /grid/ xmin,ymin,xmax,ymax,dx,dy
ccc---------- compute correlation functions ------------------------
	c1=(0d0,0d0)
	c2=(0d0,0d0)

      do 10 j=1,nj
	 y=ymin+(j-1)*dy
	  do 10 i=1,ni
	    x=xmin+(i-1)*dx
          c1=c1+conjg(psi0(i,j))*psi(i,j)*dx*dy
          c2=c2+psi(i,j)**2*dx*dy
10	continue
C        c1=c1*dx*dy
C        c2=c2*dx*dy
	return
	end subroutine

c-------------------------------------------------------
c-------------------------------------------------------
        subroutine aver(ni,nj,psi0,psi,c)
        implicit real*8(a-h,o-z)
c        parameter(ij=512)
        integer*4,intent(IN)::ni,nj
        complex*16 c,psi0(ni,nj),psi(ni,nj)
	common /grid/ xmin,ymin,xmax,ymax,dx,dy
	c=(0.d0,0.d0)
	ct=0.d0
        do 11 j=1,nj
         do 11 i=1,ni
	ct=ct+abs(psi0(i,j))**2
11      c=c+psi(i,j)*conjg(psi0(i,j))*dx*dy
        return
        end

      SUBROUTINE fourn(data,nn,ndim,isign)
      INTEGER isign,ndim,nn(ndim)
      REAL*8 data(*)
      INTEGER i1,i2,i2rev,i3,i3rev,ibit,idim,ifp1,ifp2,ip1,ip2,ip3,k1,
     *k2,n,nprev,nrem,ntot
      REAL*8 tempi,tempr
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      ntot=1
      do 11 idim=1,ndim
        ntot=ntot*nn(idim)
11    continue
      nprev=1
      do 18 idim=1,ndim
        n=nn(idim)
        nrem=ntot/(n*nprev)
        ip1=2*nprev
        ip2=ip1*n
        ip3=ip2*nrem
        i2rev=1
        do 14 i2=1,ip2,ip1
          if(i2.lt.i2rev)then
            do 13 i1=i2,i2+ip1-2,2
              do 12 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
12            continue
13          continue
          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
14      continue
        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 17 i3=1,ifp1,ip1
            do 16 i1=i3,i3+ip1-2,2
              do 15 i2=i1,ip3,ifp2
                k1=i2
                k2=k1+ifp1
                tempr=sngl(wr)*data(k2)-sngl(wi)*data(k2+1)
                tempi=sngl(wr)*data(k2+1)+sngl(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
15            continue
16          continue
            wtemp=wr
            wr=wr*wpr-wi*wpi+wr
            wi=wi*wpr+wtemp*wpi+wi
17        continue
          ifp1=ifp2
        goto 2
        endif
        nprev=n*nprev
18    continue
      return
      END

      subroutine cqpot(ni,nj,psi,dt)
      use mass
      use sci

      implicit real (kind = 8) (a-h, o-z)
      real (kind = 8), dimension(ni,nj) :: psi,phi,dphi
      real (kind = 8) fd4(5)

      common/grid/xmin,ymin,xmax,ymax,dx,dy

      fd4 = (/-1.0,16.0,-30.0,16.0,-1.0/) ! fourth-order finite-difference coefficients
      dt2 = dt/2d0
      del = 1d-8

      do j=1,nj
      do i=1,ni
        phi(i,j) = abs(psi(i,j))
      enddo
      enddo

      dphi = 0d0
      do j=3,nj-2
        do i=1,ni
        dphi(i,j) = (fd4(1)*phi(i,j+2)+fd4(2)*phi(i,j+1)+
     &       fd4(3)*phi(i,j)+fd4(4)*phi(i,j-1)+
     &       fd4(5)*phi(i,j-2))/12d0/dy**2
        enddo
      enddo

! ---- boundary points, treat out-of-boundary points as 0
      j = nj-1
      do i=1,ni
        dphi(i,j) = (fd4(2)*phi(i,j+1)+
     &       fd4(3)*phi(i,j)+fd4(4)*phi(i,j-1)+
     &       fd4(5)*phi(i,j-2))/12d0/dy**2
      enddo

      j = nj
      do i=1,ni
        dphi(i,j) = (fd4(3)*phi(i,j)+fd4(4)*phi(i,j-1)+
     &       fd4(5)*phi(i,j-2))/12d0/dy**2
      enddo

      j = 2
      do i=1,ni
        dphi(i,j) = (fd4(1)*phi(i,j+2)+fd4(2)*phi(i,j+1)+
     &       fd4(3)*phi(i,j)+fd4(4)*phi(i,j-1))/12d0/dy**2
      enddo

      j = 1
      do i=1,ni
        dphi(i,j) = (fd4(1)*phi(i,j+2)+fd4(2)*phi(i,j+1)+
     &       fd4(3)*phi(i,j))/12d0/dy**2
      enddo

!      do i=1,ni
!        dphi(i,1) = (phi(i,3)+phi(i,1)-2d0*phi(i,2))/dy**2
!      enddo
!      do i=1,ni
!        dphi(i,nj) = (phi(i,nj)+phi(i,nj-2)-2d0*phi(i,nj-1))/dy**2
!      enddo

      do j=1,nj
        do i=1,ni
          psi(i,j) = psi(i,j) - im*dt*psi(i,j)*dphi(i,j)/
     &               (2d0*my*(phi(i,j)+del))
        enddo
      enddo

      return
      end subroutine


      double complex function qlI4(p1,p2,p3,p4,s12,s23,
     . m1,m2,m3,m4,mu2,ep)
      implicit none
      double precision p1,p2,p3,p4,s12,s23,m1,m2,m3,m4,mu2,newmu2
      integer ep,j
C     pi=p(i)^2, i=1,2,3,4 are momentum squared of the external lines
C     mi=m(i)^2  i=1,2,3,4 are masses squared of the internal lines
C     sij=(pi+pj)^2 are external invariants
C     mu2 is the square of the scale mu
C     ep=-2,-1,0 chooses the coefficient in the Laurent series.
      double precision xpi(13),scalefac
      double complex qlI4array

C     Uses the ordering for the routine xpi wanted by FF
C     psq(1) lies between msq(1) and msq(2) and so on
C     xpi(1-4) = msq(1),msq(2),msq(3),msq(4)
C     xpi(5-8) = psq(1),psq(2),psq(3),psq(4)
C     xpi(9-10) = s12,s23
C     xpi(11) = +xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
C     xpi(12) = -xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
C     xpi(13) = +xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)

      xpi(1)=m1
      xpi(2)=m2
      xpi(3)=m3
      xpi(4)=m4
      xpi(5)=p1
      xpi(6)=p2
      xpi(7)=p3
      xpi(8)=p4
      xpi(9)=s12
      xpi(10)=s23
      xpi(11)=+xpi(5)+xpi(6)+xpi(7)+xpi(8)-xpi(9)-xpi(10)
      xpi(12)=-xpi(5)+xpi(6)-xpi(7)+xpi(8)+xpi(9)+xpi(10)
      xpi(13)=+xpi(5)-xpi(6)+xpi(7)-xpi(8)+xpi(9)+xpi(10)
      scalefac=max(abs(s12),abs(s23),abs(p1),abs(p2),abs(p3),abs(p4))
      do j=1,13
      xpi(j)=xpi(j)/scalefac
      enddo
      newmu2=mu2/scalefac
      qlI4=qlI4array(xpi,newmu2,ep)/scalefac**2
      return
      end


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!>  \brief   This subroutine read in used-defined material properties
!>  tangent
module mUmat
  implicit none

  integer, parameter, private :: kreal = kind(0.0d0)

contains

  subroutine mate( matl, strain, D, fstat )

    implicit none

    real(kind=kreal), intent(in)  :: strain(6) !< Green-Lagrangen strain
    real(kind=kreal), intent(in)  :: matl(:)   !< material properties
    real(kind=kreal), intent(out) :: D(:,:)    !< strain-stress relation
    real(kind=kreal), intent(inout)  :: fstat(:)
    real(kind=kreal) :: EE, PP

    real(kind=kreal) :: damage
    real(kind=kreal) :: sdev(6), I1, J2
    real(kind=kreal) :: epse, eps0, gf
    real(kind=kreal) :: kcomp

    D(:,:) = 0.d0
    damage = 0.d0

    EE = matl(1)
    PP = matl(2)

    !
    kcomp = matl(5)
    !
    I1      = strain(1)+strain(2)+strain(3)
    sdev(:) = strain(:)-1.d0/3.d0*I1
    J2 = 0.5d0*( sdev(1)**2.d0+sdev(2)**2.d0+sdev(3)**2.d0 &
              &  + 2.d0*(sdev(4)**2.d0+sdev(5)**2.d0+sdev(6)**2.d0) )
    epse = (kcomp-1.d0)/(2.d0*kcomp*(1.d0-2.d0*PP))
    epse = epse &
         &  + 1.d0/(2.d0*kcomp)*sqrt(((kcomp-1)*I1/(1.d0-2.d0*PP))**2.d0+12.d0*kcomp*J2/(1.d0+PP)**2.d0)
    eps0 = matl(3)
    !
    epse = max( epse, fstat(1) )
    fstat(1) = epse
    !
    !epse = strain(3)
    !
    if( epse>eps0 ) then
      gf     = matl(4)
      damage = 1.d0-(eps0/epse)*exp(-1.d0*EE*eps0*(epse-eps0)/gf)
      damage = min( damage,0.9995d0 )
      !write(*,*) damage, epse, strain(:)
      !write(*,*) damage, exp(-1.d0*EE*eps0*(epse-eps0)/gf), (-1.d0*EE*eps0*(epse-eps0)/gf), epse, I1, J2!, ( (kcomp-1.d0)/( 2.0d0 * ( 1.0d0 - 2.0d0 * PP ) ) )
      !write(*,*) damage, exp(-1.d0*EE*eps0*(epse-eps0)/gf), (-1.d0*EE*eps0*(epse-eps0)/gf), epse, I1, J2, (kcomp-1.d0)/( 2.d0 * kcomp * (1.d0-2.d0*PP) )
      !1.d0/(2.d0*kcomp)*sqrt(((kcomp-1)*I1/(1.d0-2.d0*PP))**2.d0+12.d0*kcomp*J2/(1.d0+PP)**2.d0)
      !damage = min(damage,0.995d0)
      !damage = min(damage,0.99d0)
      !EE = EE *(1.d0-damage)
    ! damage = max(damage,1.d-3)
    ! damage = 1.d0-damage
    endif
    !
    D(1,1)=EE*(1.d0-PP)/(1.d0-2.d0*PP)/(1.d0+PP)
    D(1,2)=EE*PP/(1.d0-2.d0*PP)/(1.d0+PP)
    D(1,3)=D(1,2)
    D(2,1)=D(1,2)
    D(2,2)=D(1,1)
    D(2,3)=D(1,2)
    D(3,1)=D(1,3)
    D(3,2)=D(2,3)
    D(3,3)=D(1,1)
    D(4,4)=EE/(1.d0+PP)*0.5d0
    D(5,5)=EE/(1.d0+PP)*0.5d0
    D(6,6)=EE/(1.d0+PP)*0.5d0

    D(:,:) = (1.d0-damage)*D(:,:)

  end subroutine mate

  !> This subroutine calculates constitutive matrix
  subroutine uMatlMatrix( mname, matl, strain, stress, fstat, D  &
      , dtime, ttime, temperature )
    character(len=*), intent(in)  :: mname     !< material name
    real(kind=kreal), intent(in)  :: matl(:)   !< material properties
    real(kind=kreal), intent(in)  :: strain(6) !< Green-Lagrangen strain
    real(kind=kreal), intent(in)  :: stress(6) !< 2nd Piola-Kirchhiff stress tensor
    real(kind=kreal), intent(inout)  :: fstat(:)  !< state variables
    real(kind=kreal), intent(out) :: D(:,:)    !< strain-stress relation
    real(kind=kreal), intent(in)  :: dtime     !< time increment
    real(kind=kreal), intent(in)  :: ttime     !< total time at the start of the current increment
    real(kind=kreal), optional    :: temperature !< temprature

    !
    call mate( matl(:), strain, D, fstat )

  end subroutine

  !> This subroutine calculate strain and stress increment
  subroutine uUpdate(  mname, matl, strain, stress, fstat, dtime, ttime, temperature )
    character(len=*), intent(in)    :: mname      !< material name
    real(kind=kreal), intent(in)    :: matl(:)    !< material properties
    real(kind=kreal), intent(in)    :: strain(6)  !< strain
    real(kind=kreal), intent(inout) :: stress(6)  !< 2nd Piola-Kirchhiff stress tensor
    real(kind=kreal), intent(inout) :: fstat(:)   !< state variables
    real(kind=kreal), intent(in)    :: dtime     !< time increment
    real(kind=kreal), intent(in)    :: ttime     !< total time at the start of the current increment
    real(kind=kreal), optional      :: temperature !< temperature

    real(kind=kreal) :: D(6,6)

    !call uElasticMatrix( matl(:2), strain, D )
    call mate( matl(:), strain, D, fstat )

    if( fstat(1) < matl(3) ) then
      stress = matmul( D, strain ) + stress
    else
      !stress = -1.d0*matmul( D, strain ) + stress
      stress = matmul( D, strain )
    endif

  end subroutine

end module


C     SUBROUTINE NNLS  (A,MDA,M,N,B,X,RNORM,W,ZZ,INDEX,MODE)
C
C  Algorithm NNLS: NONNEGATIVE LEAST SQUARES
C
C  The original version of this code was developed by
C  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
C  1973 JUN 15, and published in the book
C  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
C  Revised FEB 1995 to accompany reprinting of the book by SIAM.
C
C     GIVEN AN M BY N MATRIX, A, AND AN M-VECTOR, B,  COMPUTE AN
C     N-VECTOR, X, THAT SOLVES THE LEAST SQUARES PROBLEM
C
C                      A * X = B  SUBJECT TO X .GE. 0
C     ------------------------------------------------------------------
C                     Subroutine Arguments
C
C     A(),MDA,M,N     MDA IS THE FIRST DIMENSIONING PARAMETER FOR THE
C                     ARRAY, A().   ON ENTRY A() CONTAINS THE M BY N
C                     MATRIX, A.           ON EXIT A() CONTAINS
C                     THE PRODUCT MATRIX, Q*A , WHERE Q IS AN
C                     M BY M ORTHOGONAL MATRIX GENERATED IMPLICITLY BY
C                     THIS SUBROUTINE.
C     B()     ON ENTRY B() CONTAINS THE M-VECTOR, B.   ON EXIT B() CON-
C             TAINS Q*B.
C     X()     ON ENTRY X() NEED NOT BE INITIALIZED.  ON EXIT X() WILL
C             CONTAIN THE SOLUTION VECTOR.
C     RNORM   ON EXIT RNORM CONTAINS THE EUCLIDEAN NORM OF THE
C             RESIDUAL VECTOR.
C     W()     AN N-ARRAY OF WORKING SPACE.  ON EXIT W() WILL CONTAIN
C             THE DUAL SOLUTION VECTOR.   W WILL SATISFY W(I) = 0.
C             FOR ALL I IN SET P  AND W(I) .LE. 0. FOR ALL I IN SET Z
C     ZZ()     AN M-ARRAY OF WORKING SPACE.
C     INDEX()     AN INTEGER WORKING ARRAY OF LENGTH AT LEAST N.
C                 ON EXIT THE CONTENTS OF THIS ARRAY DEFINE THE SETS
C                 P AND Z AS FOLLOWS..
C
C                 INDEX(1)   THRU INDEX(NSETP) = SET P.
C                 INDEX(IZ1) THRU INDEX(IZ2)   = SET Z.
C                 IZ1 = NSETP + 1 = NPP1
C                 IZ2 = N
C     MODE    THIS IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING
C             MEANINGS.
C             1     THE SOLUTION HAS BEEN COMPUTED SUCCESSFULLY.
C             2     THE DIMENSIONS OF THE PROBLEM ARE BAD.
C                   EITHER M .LE. 0 OR N .LE. 0.
C             3    ITERATION COUNT EXCEEDED.  MORE THAN 3*N ITERATIONS.
C
C     ------------------------------------------------------------------
      SUBROUTINE NNLS (A,MDA,M,N,B,X,RNORM,W,ZZ,INDEX,MODE)
C     ------------------------------------------------------------------
      integer I, II, IP, ITER, ITMAX, IZ, IZ1, IZ2, IZMAX, J, JJ, JZ, L
      integer M, MDA, MODE,N, NPP1, NSETP, RTNKEY
C     integer INDEX(N)
C     double precision A(MDA,N), B(M), W(N), X(N), ZZ(M)
      integer INDEX(*)
      double precision A(MDA,*), B(*), W(*), X(*), ZZ(*)
      double precision ALPHA, ASAVE, CC, DIFF, DUMMY, FACTOR, RNORM
      double precision SM, SS, T, TEMP, TWO, UNORM, UP, WMAX
      double precision ZERO, ZTEST
      parameter(FACTOR = 0.01d0)
      parameter(TWO = 2.0d0, ZERO = 0.0d0)
C     ------------------------------------------------------------------
      MODE=1
      IF (M .le. 0 .or. N .le. 0) then
         MODE=2
         RETURN
      endif
      ITER=0
      ITMAX=3*N
C
C                    INITIALIZE THE ARRAYS INDEX() AND X().
C
          DO 20 I=1,N
          X(I)=ZERO
   20     INDEX(I)=I
C
      IZ2=N
      IZ1=1
      NSETP=0
      NPP1=1
C                             ******  MAIN LOOP BEGINS HERE  ******
   30 CONTINUE
C                  QUIT IF ALL COEFFICIENTS ARE ALREADY IN THE SOLUTION.
C                        OR IF M COLS OF A HAVE BEEN TRIANGULARIZED.
C
      IF (IZ1 .GT.IZ2.OR.NSETP.GE.M) GO TO 350
C
C         COMPUTE COMPONENTS OF THE DUAL (NEGATIVE GRADIENT) VECTOR W().
C
      DO 50 IZ=IZ1,IZ2
         J=INDEX(IZ)
         SM=ZERO
         DO 40 L=NPP1,M
   40        SM=SM+A(L,J)*B(L)
         W(J)=SM
   50 continue
C                                   FIND LARGEST POSITIVE W(J).
   60 continue
      WMAX=ZERO
      DO 70 IZ=IZ1,IZ2
         J=INDEX(IZ)
         IF (W(J) .gt. WMAX) then
            WMAX=W(J)
            IZMAX=IZ
         endif
   70 CONTINUE
C
C             IF WMAX .LE. 0. GO TO TERMINATION.
C             THIS INDICATES SATISFACTION OF THE KUHN-TUCKER CONDITIONS.
C
      IF (WMAX .le. ZERO) go to 350
      IZ=IZMAX
      J=INDEX(IZ)
C
C     THE SIGN OF W(J) IS OK FOR J TO BE MOVED TO SET P.
C     BEGIN THE TRANSFORMATION AND CHECK NEW DIAGONAL ELEMENT TO AVOID
C     NEAR LINEAR DEPENDENCE.
C
      ASAVE=A(NPP1,J)
      CALL H12 (1,NPP1,NPP1+1,M,A(1,J),1,UP,DUMMY,1,1,0)
      UNORM=ZERO
      IF (NSETP .ne. 0) then
          DO 90 L=1,NSETP
   90       UNORM=UNORM+A(L,J)**2
      endif
      UNORM=sqrt(UNORM)
      IF (DIFF(UNORM+ABS(A(NPP1,J))*FACTOR,UNORM) .gt. ZERO) then
C
C        COL J IS SUFFICIENTLY INDEPENDENT.  COPY B INTO ZZ, UPDATE ZZ
C        AND SOLVE FOR ZTEST ( = PROPOSED NEW VALUE FOR X(J) ).
C
         DO 120 L=1,M
  120        ZZ(L)=B(L)
         CALL H12 (2,NPP1,NPP1+1,M,A(1,J),1,UP,ZZ,1,1,1)
         ZTEST=ZZ(NPP1)/A(NPP1,J)
C
C                                     SEE IF ZTEST IS POSITIVE
C
         IF (ZTEST .gt. ZERO) go to 140
      endif
C
C     REJECT J AS A CANDIDATE TO BE MOVED FROM SET Z TO SET P.
C     RESTORE A(NPP1,J), SET W(J)=0., AND LOOP BACK TO TEST DUAL
C     COEFFS AGAIN.
C
      A(NPP1,J)=ASAVE
      W(J)=ZERO
      GO TO 60
C
C     THE INDEX  J=INDEX(IZ)  HAS BEEN SELECTED TO BE MOVED FROM
C     SET Z TO SET P.    UPDATE B,  UPDATE INDICES,  APPLY HOUSEHOLDER
C     TRANSFORMATIONS TO COLS IN NEW SET Z,  ZERO SUBDIAGONAL ELTS IN
C     COL J,  SET W(J)=0.
C
  140 continue
      DO 150 L=1,M
  150    B(L)=ZZ(L)
C
      INDEX(IZ)=INDEX(IZ1)
      INDEX(IZ1)=J
      IZ1=IZ1+1
      NSETP=NPP1
      NPP1=NPP1+1
C
      IF (IZ1 .le. IZ2) then
         DO 160 JZ=IZ1,IZ2
            JJ=INDEX(JZ)
            CALL H12 (2,NSETP,NPP1,M,A(1,J),1,UP,A(1,JJ),1,MDA,1)
  160    continue
      endif
C
      IF (NSETP .ne. M) then
         DO 180 L=NPP1,M
  180       A(L,J)=ZERO
      endif
C
      W(J)=ZERO
C                                SOLVE THE TRIANGULAR SYSTEM.
C                                STORE THE SOLUTION TEMPORARILY IN ZZ().
      RTNKEY = 1
      GO TO 400
  200 CONTINUE
C
C                       ******  SECONDARY LOOP BEGINS HERE ******
C
C                          ITERATION COUNTER.
C
  210 continue
      ITER=ITER+1
      IF (ITER .gt. ITMAX) then
         MODE=3
         write (*,'(/a)') ' NNLS quitting on iteration count.'
         GO TO 350
      endif
C
C                    SEE IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE.
C                                  IF NOT COMPUTE ALPHA.
C
      ALPHA=TWO
      DO 240 IP=1,NSETP
         L=INDEX(IP)
         IF (ZZ(IP) .le. ZERO) then
            T=-X(L)/(ZZ(IP)-X(L))
            IF (ALPHA .gt. T) then
               ALPHA=T
               JJ=IP
            endif
         endif
  240 CONTINUE
C
C          IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE THEN ALPHA WILL
C          STILL = 2.    IF SO EXIT FROM SECONDARY LOOP TO MAIN LOOP.
C
      IF (ALPHA.EQ.TWO) GO TO 330
C
C          OTHERWISE USE ALPHA WHICH WILL BE BETWEEN 0. AND 1. TO
C          INTERPOLATE BETWEEN THE OLD X AND THE NEW ZZ.
C
      DO 250 IP=1,NSETP
         L=INDEX(IP)
         X(L)=X(L)+ALPHA*(ZZ(IP)-X(L))
  250 continue
C
C        MODIFY A AND B AND THE INDEX ARRAYS TO MOVE COEFFICIENT I
C        FROM SET P TO SET Z.
C
      I=INDEX(JJ)
  260 continue
      X(I)=ZERO
C
      IF (JJ .ne. NSETP) then
         JJ=JJ+1
         DO 280 J=JJ,NSETP
            II=INDEX(J)
            INDEX(J-1)=II
            CALL G1 (A(J-1,II),A(J,II),CC,SS,A(J-1,II))
            A(J,II)=ZERO
            DO 270 L=1,N
               IF (L.NE.II) then
C
C                 Apply procedure G2 (CC,SS,A(J-1,L),A(J,L))
C
                  TEMP = A(J-1,L)
                  A(J-1,L) = CC*TEMP + SS*A(J,L)
                  A(J,L)   =-SS*TEMP + CC*A(J,L)
               endif
  270       CONTINUE
C
C                 Apply procedure G2 (CC,SS,B(J-1),B(J))
C
            TEMP = B(J-1)
            B(J-1) = CC*TEMP + SS*B(J)
            B(J)   =-SS*TEMP + CC*B(J)
  280    continue
      endif
C
      NPP1=NSETP
      NSETP=NSETP-1
      IZ1=IZ1-1
      INDEX(IZ1)=I
C
C        SEE IF THE REMAINING COEFFS IN SET P ARE FEASIBLE.  THEY SHOULD
C        BE BECAUSE OF THE WAY ALPHA WAS DETERMINED.
C        IF ANY ARE INFEASIBLE IT IS DUE TO ROUND-OFF ERROR.  ANY
C        THAT ARE NONPOSITIVE WILL BE SET TO ZERO
C        AND MOVED FROM SET P TO SET Z.
C
      DO 300 JJ=1,NSETP
         I=INDEX(JJ)
         IF (X(I) .le. ZERO) go to 260
  300 CONTINUE
C
C         COPY B( ) INTO ZZ( ).  THEN SOLVE AGAIN AND LOOP BACK.
C
      DO 310 I=1,M
  310     ZZ(I)=B(I)
      RTNKEY = 2
      GO TO 400
  320 CONTINUE
      GO TO 210
C                      ******  END OF SECONDARY LOOP  ******
C
  330 continue
      DO 340 IP=1,NSETP
          I=INDEX(IP)
  340     X(I)=ZZ(IP)
C        ALL NEW COEFFS ARE POSITIVE.  LOOP BACK TO BEGINNING.
      GO TO 30
C
C                        ******  END OF MAIN LOOP  ******
C
C                        COME TO HERE FOR TERMINATION.
C                     COMPUTE THE NORM OF THE FINAL RESIDUAL VECTOR.
C
  350 continue
      SM=ZERO
      IF (NPP1 .le. M) then
         DO 360 I=NPP1,M
  360       SM=SM+B(I)**2
      else
         DO 380 J=1,N
  380       W(J)=ZERO
      endif
      RNORM=sqrt(SM)
      RETURN
C
C     THE FOLLOWING BLOCK OF CODE IS USED AS AN INTERNAL SUBROUTINE
C     TO SOLVE THE TRIANGULAR SYSTEM, PUTTING THE SOLUTION IN ZZ().
C
  400 continue
      DO 430 L=1,NSETP
         IP=NSETP+1-L
         IF (L .ne. 1) then
            DO 410 II=1,IP
               ZZ(II)=ZZ(II)-A(II,JJ)*ZZ(IP+1)
  410       continue
         endif
         JJ=INDEX(IP)
         ZZ(IP)=ZZ(IP)/A(IP,JJ)
  430 continue
      go to (200, 320), RTNKEY
      END


c gmm01f
c For each sphere j, calculates the expansion
c a1(m n j) and b1(m n j)
c of the field originating from the other spheres l != j
c in the basis of VSWF M1(m n j) and N1(m n j)
c in the j-centered coordinate system.
c The input fields are given as expansions
c a(mu nu l) and b(mu nu l)
c in the basis of VSWF M3(mu nu l) and N3(mu nu l)
c in the l-centered coordinate systems.
c The formulas (xuy95, part of eq. 30) are:
c a1(m n j)) = Sum_{l != j, mu; nu} [
c       a(mu nu l) A(mu nu m n l j) +
c       b(mu nu l) B(mu nu m n l j)]
c and
c b1(m n j) = Sum_{l:l!=j, mu, nu} [
c       a(mu nu l) B(mu nu m n l j) +
c       b(mu nu l) A(mu nu m n l j)]
c @param nL number of particles
c @param r0
c @param nmax maximum order
c @param uvmax maximum value for uv index
c @param fint interaction index; from input file; see comment in gmm01f
c @param atr0 the translation coefficients A
c @param btr0 the translation coefficients B
c @param ek exp(i m phi); which phi?
c @param drot rotation coefficients (?)
c @param as the input scattering coefficients a(mu nu l)
c @param bs the scattering coefficients a(mu nu l)
c @param as1 the result coefficients a1(m n l)
c @param bs1 the result coefficients b1(m n l)
c @param ind polarization
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
      subroutine trans(nL,r0,nmax,uvmax,fint,atr0,btr0,ek,
     +                   drot,as,bs,as1,bs1,ind)
      implicit double precision (a-h,o-z)
      include 'gmm01f.par'
      parameter (nmp=np*(np+2))
      parameter (ni0=np*(np+1)*(2*np+1)/3+np*np)
      parameter (nrc=4*np*(np+1)*(np+2)/3+np)
      parameter (nij=nLp*(nLp-1)/2)
      integer v,nmax(nLp),uvmax(nLp),ind(nL)
      double precision r0(6,nLp),drot(nrc,nij)
      complex*16 atr(2,np,nmp),atr0(ni0,nij),btr0(ni0,nij),
     +     ek(np,nij),as(nLp,nmp),bs(nLp,nmp),as1(nLp,nmp),
     +     bs1(nLp,nmp),at1(2,nmp),bt1(2,nmp)
          common/tran/atr
      do i=1,nL
         if(ind(i).gt.0) goto 11
             do imn=1,uvmax(i)
                as1(i,imn)=dcmplx(0.d0,0.d0)
            bs1(i,imn)=dcmplx(0.d0,0.d0)
         enddo
         do 10 j=1,nL
            if(j.eq.i) goto 10
            x0=r0(1,i)-r0(1,j)
            y0=r0(2,i)-r0(2,j)
            z0=r0(3,i)-r0(3,j)
            d=dsqrt(x0*x0+y0*y0+z0*z0)
            temp=(r0(4,i)+r0(4,j))/d
            if(temp.le.fint) goto 10
            if(i.lt.j) then
                   ij=(j-1)*(j-2)/2+j-i
                else
                   ij=(i-1)*(i-2)/2+i-j
                endif
                nlarge=max(nmax(i),nmax(j))
                itrc=0
                nsmall=min(nmax(i),nmax(j))
                do m=-nsmall,nsmall
                   n1=max(1,iabs(m))
                   do n=n1,nlarge
                      do v=n1,nlarge
                         itrc=itrc+1
                         iuv=v*(v+1)+m
                         atr(1,n,iuv)=atr0(itrc,ij)
                         atr(2,n,iuv)=btr0(itrc,ij)
                         if(x0.eq.0.d0.and.y0.eq.0.d0) then
                            if(z0.lt.0.d0) goto 20
                         else
                            if(j.lt.i) goto 20
                         endif
                         goto 21
 20                      sic=dble((-1)**(n+v))
                         atr(1,n,iuv)=sic*atr(1,n,iuv)
                         atr(2,n,iuv)=-sic*atr(2,n,iuv)
 21                      continue
                      enddo
                   enddo
                enddo
                do iuv=1,uvmax(j)
                   at1(1,iuv)=as(j,iuv)
                   at1(2,iuv)=bs(j,iuv)
                enddo
                if(x0.eq.0.d0.and.y0.eq.0.d0) then
                   call trv(at1,nmax(j),nmax(i))
                else
                   call rtr(at1,nmax(j),nmax(i),ek(1,ij),drot(1,ij))
                endif
                do imn=1,uvmax(i)
                   as1(i,imn)=as1(i,imn)+at1(1,imn)
                   bs1(i,imn)=bs1(i,imn)+at1(2,imn)
                enddo
 10	     continue
 11	     continue
      enddo
      return
      end


c####&

c Eigenvector/eigenvalue problem for isotropic and anisotropic layers.
c Real values only.

      subroutine isotroc(a,rho,p1,p2,eval,evec)
c   Obtain isotropic eigenvectors/values. This is a little obscure,
c   but it's just the Zoeppritz equations.

        implicit none
        real a(3,3,3,3),rho,p1,p2
        complex eval(6),evec(6,6)
        complex vp2,vs2,mu,pp,p,qdp,qds,qup,qus
        real xnorm
        integer i,j

c        write (*,*) 'isotroc, (p1,p2):',p1,p2

c   Load up some convenient values
        vp2=a(3,3,3,3)
        vs2=a(2,3,2,3)
        mu=rho*vs2
        pp=p1*p1+p2*p2
        p=sqrt(pp)

c    Set eigenvalues
c        write (*,*) 1./vp2,1./vs2,pp
        qdp=sqrt(1/vp2-pp)
        qds=sqrt(1/vs2-pp)
        qup=-qdp
        qus=-qds
        eval(1)=qdp
        eval(2)=qds
        eval(3)=qds
        eval(4)=qup
        eval(5)=qus
        eval(6)=qus

c    Set eigenvector matrix, column by column,
c      N(1:6,1)=[p1,p2,qdp,2*mu*p1*qdp,2*mu*p2*qdp,(rho-2*mu*pp)]'
        evec(1,1)=p1
        evec(2,1)=p2
        evec(3,1)=qdp
        evec(4,1)=2.*mu*p1*qdp
        evec(5,1)=2.*mu*p2*qdp
        evec(6,1)=rho-2.*mu*pp
c      N(1:6,2)=[p1,p2,-pp/qds,p1*N(6,1)/qds,p2*N(6,1)/qds,-2*mu*pp]';
        evec(1,2)=p1
        evec(2,2)=p2
        evec(3,2)=-pp/qds
        evec(4,2)=p1*evec(6,1)/qds
        evec(5,2)=p2*evec(6,1)/qds
        evec(6,2)=-2.*mu*pp
c      N(1:6,3)=[-p2,p1,0,-p2*qds*mu,p1*qds*mu,0]'
        evec(1,3)=-p2
        evec(2,3)=p1
        evec(3,3)=0.
        evec(4,3)=-p2*qds*mu
        evec(5,3)=p1*qds*mu
        evec(6,3)=0.
c      N(1:6,4)=[p1,p2,qup,2*mu*p1*qup,2*mu*p2*qup,N(6,1)]';
        evec(1,4)=p1
        evec(2,4)=p2
        evec(3,4)=qup
        evec(4,4)=2.*mu*p1*qup
        evec(5,4)=2.*mu*p2*qup
        evec(6,4)=evec(6,1)
c      N(1:6,5)=[p1,p2,-pp/qus,p1*N(6,1)/qus,p2*N(6,1)/qus,-2*mu*pp]';
        evec(1,5)=p1
        evec(2,5)=p2
        evec(3,5)=-pp/qus
        evec(4,5)=p1*evec(6,1)/qus
        evec(5,5)=p2*evec(6,1)/qus
        evec(6,5)=-2.*mu*pp
c      N(1:6,6)=[-p2,p1,0,-p2*qus*mu,p1*qus*mu,0]'
        evec(1,6)=-p2
        evec(2,6)=p1
        evec(3,6)=0.
        evec(4,6)=-p2*qus*mu
        evec(5,6)=p1*qus*mu
        evec(6,6)=0.

c      Normalize wrt displacement magnitude:
        do j=1,6
          xnorm=sqrt(real(evec(1,j))**2+real(evec(2,j))**2+
     &               real(evec(3,j))**2)
          do i=1,6
            evec(i,j)=evec(i,j)/xnorm
          end do
        end do

c        write(*,*) 'Isotroc: eigens'
c        write(*,*) eval
c        do i=1,6
c          write (*,*) real(evec(i,1)),real(evec(i,2)),real(evec(i,3)),
c     &                real(evec(i,4)),real(evec(i,5)),real(evec(i,6))
c        end do

      end

c ---------------------------------------

      subroutine anisotroc(a,rho,p1,p2,eval,evec)
c   Obtain anisotropic eigenvectors/values. Rather hairy.

        implicit none
        real a(3,3,3,3),rho,p1,p2
        complex eval(6),evec(6,6)

c        integer worksize
c        parameter (worksize=100)
        real AA(6,6),CC(3,3,3,3),iC33(3,3),T(3,3),S(3,3),p(3)
        real wrk1(3,3),wrk2(3,3),wrk3(3,3),wrk4(3,3),eye(3,3)
        real zero6(6,6),evalr(6),evecr(6,6),evali(6),eveci(6,6)
c        real dummy(1,6),evec_la(6,6),work_la(worksize)
        integer i,j,k,l,ierr
        real xnorm

c       Identity matrix
        data eye(1,1)/1./,eye(1,2)/0./,eye(1,3)/0./
        data eye(2,1)/0./,eye(2,2)/1./,eye(2,3)/0./
        data eye(3,1)/0./,eye(3,2)/0./,eye(3,3)/1./

c        write (*,*) 'anisotroc, (p1,p2):',p1,p2

c       Build partion matrices CIJ where CIJ(k,l)=rho*a(k,i,l,j)
        do i=1,3
          do j=1,3
            do k=1,3
              do l=1,3
                CC(k,l,i,j)=rho*a(k,i,l,j)
              end do
            end do
          end do
        end do

c        write (*,*) 'anisotroc -- c(:,:,1,1)'
c        do i=1,3
c          write (*,*) a(1,i,1,1)*rho,a(2,i,1,1)*rho,a(3,i,1,1)
c        end do

        call rmatinv3(CC(1,1,3,3),iC33)

c       T=(-p1*C13-p2*C23)*iC33
        call rmatlincomb3(-p1,CC(1,1,1,3),-p2,CC(1,1,2,3),wrk1)
        call rmatmul3(wrk1,iC33,T)

c       S=rho*eye(3,3)-sum(i=1:2,j=1:2,p(i)*p(j)*(Cij-Ci3*C33^(-1)*C3j))
        p(1)=p1
        p(2)=p2
        do i=1,3
          do j=1,3
            wrk1(i,j)=0
          end do
        end do
        do j=1,2
          call rmatmul3(iC33,CC(1,1,3,j),wrk2)
          do i=1,2
            call rmatmul3(CC(1,1,i,3),wrk2,wrk3)
            call rmatlincomb3(1.,CC(1,1,i,j),-1.,wrk3,wrk4)
            call rmatlincomb3(1.,wrk1,p(i)*p(j),wrk4,wrk3)
            call rmatcopy3(wrk3,wrk1)
          end do
        end do
        call rmatlincomb3(rho,eye,-1.,wrk1,S)

c       Build system matrix AA=[T',iC33;S,T]
        do i=1,3
          do j=1,3
            AA(i,j)=T(j,i)
            AA(i,j+3)=iC33(i,j)
            AA(i+3,j)=S(i,j)
            AA(i+3,j+3)=T(i,j)
          end do
        end do

c        write (*,*) 'anisotroc: system sub-matrices'
c        write (*,*) 'T='
c        do i=1,3
c          write (*,*) T(i,1),T(i,2),T(i,3)
c        end do
c        write (*,*) 'iC33='
c        do i=1,3
c          write (*,*) iC33(i,1),iC33(i,2),iC33(i,3)
c        end do
c        write (*,*) 'S='
c        do i=1,3
c          write (*,*) S(i,1),S(i,2),S(i,3)
c        end do

c        write (*,*) 'anisotroc: system matrix'
c        do i=1,6
c          write (*,*) AA(i,1),AA(i,2),AA(i,3),AA(i,4),AA(i,5),AA(i,6)
c        end do

c       Obtain eigenvalues/vectors using EISPACK.
        do i=1,6
          do j=1,6
            zero6(i,j)=0.
          end do
        end do
        call cg(6,6,AA,zero6,evalr,evali,1,evecr,eveci,
     &          wrk1,wrk2,wrk3,ierr)
        if (ierr .ne. 0) then
          write (*,*) '*** Error from EISPACK cg : ',ierr
        end if

c       Obtain eigenvalues/vectors using LAPACK. Hopefully will
c       give better results than EISPACK,although the way that it
c       stores eigenvectors is supremely annoying.
c        call sgeev('N','V',6,AA,6,evalr,evali,dummy,1,evec_la,6,
c     &       work_la,worksize,ierr)
c        if (ierr .ne. 0) then
c          write (*,*) '*** Error from LAPACK sgeev : ',ierr
c        end if
c        j=1
cc       Rearrange evecs in a more reasonable fashion
c        do while (j .le. 6)
c          if (evali(j) .eq. 0.) then
c            do i=1,6
c              evecr(i,j)=evec_la(i,j)
c              eveci(i,j)=0.
c            end do
c            j=j+1
c          else
cc          Complex eigens are in conjugate pairs -- rearrange and skip
c            do i=1,6
c              evecr(i,j)=evec_la(i,j)
c              evecr(i,j+1)=evec_la(i,j)
c              eveci(i,j)=evec_la(i,j+1)
c              eveci(i,j+1)=-evec_la(i,j+1)
c            end do
c            j=j+2
c          end if
c        end do

c        write (*,*) 'Anisotroc: unsorted eigenvalues:',evalr
c        write (*,*) 'Anisotroc: unsorted eigenvectors'
c        do i=1,6
c          write (*,*) evecr(i,1),evecr(i,2),evecr(i,3),evecr(i,4),
c     &                evecr(i,5),evecr(i,6)
c        end do

c        Sort evecs/evals
        call sort_evec(evalr,evali,evecr,eveci,eval,evec)

c        Normalize evecs to unit displacement
        do j=1,6
          xnorm=sqrt(real(evec(1,j))**2+real(evec(2,j))**2+
     &               real(evec(3,j))**2)
          do i=1,6
            evec(i,j)=evec(i,j)/xnorm
          end do
        end do

c        write (*,*) 'Anisotroc: sorted, normalized eigens'
c        write (*,*) 'evals:',eval
c        write (*,*) 'evec:'
c        do i=1,6
c          write (*,*) real(evec(i,1)),real(evec(i,2)),real(evec(i,3)),
c     &                real(evec(i,4)),real(evec(i,5)),real(evec(i,6))
c        end do

      end

c --------------------

c Sort eigenvectors in the same manner as the MATLAB anisotroc.m
c routine. If all evals are real, the order will be like [1 2 3
c -1 -2 3]; otherwise, evanescent waves go first, e.g. [2i,1+2i,
c 1 -2i, -1-2i, -1].
      subroutine sort_evec(evalr,evali,evecr,eveci,eval,evec)

        implicit none
        include 'params.h'

        real evalr(6),evali(6),evecr(6,6),eveci(6,6)
        complex eval(6),evec(6,6)
        integer i,index(6),imagpos(6),imagneg(6),realpos(6),realneg(6)
        integer nrp,nrn,nip,nin
        integer j

c Got burned by using a DATA statement here...
        nrp=0
        nrn=0
        nip=0
        nin=0

c Divide eigenvalues up into real positive, real negative, complex
c positive, complex negative.
        do i=1,6
c         Is it real?
          if (abs(evali(i)/evalr(i)) .lt. ztol*100) then
            evali(i)=0
            do j=1,6
              eveci(j,i)=0
            end do
            if (evalr(i) .ge. 0.) then
              nrp=nrp+1
              realpos(nrp)=i
            else
              nrn=nrn+1
              realneg(nrn)=i
            end if
          else
            if (evali(i) .ge. 0.) then
              nip=nip+1
              imagpos(nip)=i
            else
              nin=nin+1
              imagneg(nin)=i
            end if
          end if
        end do

c        print *,nip,nrp,nin,nrn

c        Sort sub-groups
        call sort(evalr,realpos,6,nrp)
        call sort(evalr,realneg,6,nrn)
        call sort(evali,imagpos,6,nip)
        call sort(evali,imagneg,6,nin)

c        Assemble sub-ranges
        do i=1,nip
          index(i)=imagpos(i)
        end do
        do i=1,nrp
          index(i+nip)=realpos(i)
        end do
        do i=1,nin
          index(i+nip+nrp)=imagneg(nin-i+1)
        end do
        do i=1,nrn
          index(i+nip+nrp+nin)=realneg(nrn-i+1)
        end do

c        print *,'sort-evec:',evalr
c        print *,'sort-evec:',evali
c        print *,'sort-evec:',index

c        write (*,*) 'sort-evec: index is',index

        call reorder_evec(evalr,evali,evecr,eveci,index,eval,evec)

      end

c ----------------------------------------------------------

      subroutine reorder_evec(evalr,evali,evecr,eveci,index,eval,evec)

        implicit none
        real evalr(6),evali(6),evecr(6,6),eveci(6,6)
        integer index(6),j,k
        complex eval(6),evec(6,6)

        do j=1,6
          eval(j)=cmplx(evalr(index(j)),evali(index(j)))
          do k=1,6
            evec(k,j)=cmplx(evecr(k,index(j)),eveci(k,index(j)))
          end do
        end do

      end

c ----------------------------------------------------------

c Sort an array of n real-valued elements, from smallest (most negative)
c to largest (most positive). Actual elements aren't moved -- index
c returns new positions. Uses a basic algorithm (insertion sort)
c since we're sorting few elements. m is the number of elements in a;
c n is the number of elements in index (n <= m).
c
c Index should be pre-initialized with initial locations.

      subroutine sort(a,index,m,n)

        implicit none
        integer m,n
        integer index(n),j,pos,i
        real a(m),value

        if (n .le. 1) then
          return
        end if

        do j=2,n
          i=index(j)
          value=a(i)
          pos=j
          do while ((pos .gt. 1) .and. (value .lt. a(index(pos-1))))
            index(pos)=index(pos-1)
            pos=pos-1
          end do
          index(pos)=i
        end do

      end


      subroutine initgr(nowcrp)
c
c     + + + PURPOSE + + +
c     Called to initialize perennial growth after plant has been frozen
c     and is starting to grow.  Estimates the vegetative dry matter at
c     maturity (VDMT).
c
c     Called from PTGRP, INIT1
c     Author(s):  Alberts, Ghiddey, Ferris, Arnold
c     Reference in User Guide:
c
c     Changes:
c
c     Version: This module recoded from WEPP Version 92.25.
c     Date recoded: 08/25/92.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
      include 'pntype.inc'
      include 'pmxpln.inc'
      include 'pmxcrp.inc'
      include 'pmxres.inc'
      include 'pmxtls.inc'
      include 'pmxtil.inc'
      include 'pmxhil.inc'
      include 'pmxnsl.inc'
      include 'pmxcut.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer nowcrp
c
c     + + + ARGUMENT DEFINITIONS + + +
c     nowcrp - the current crop
c
c     + + + COMMON BLOCKS + + +
      include 'ccover.inc'
c       read: cancov(mxplan)
c      write: canhgt(mxplan)
c
      include 'ccrpvr2.inc'
c     modify: vdmt(mxplan)
c
      include 'ccrpvr3.inc'
c       read: hmax(ntype), gddmaxi(ntype), bb(ntype), bbb(ntype),
c             xmxlai(ntype)
c     modify: sumgdd(mxplan)
c
      include 'ccrpprm.inc'
c       read: itype(mxcrop,mxplan)
c
      include 'ccrpout.inc'
c     modify: lai(mxplan)
c
      include 'cperen.inc'
c       read: imngmt(mxcrop,mxplan)
c
      include 'cstruc.inc'
c       read: iplane
c
c     + + + END SPECIFICATIONS + + +
c
c
c ---- Compute vegetative dry matter (VDMT), from canopy cover (CANCOV).
      vdmt(iplane) = log(1.0-cancov(iplane)) / (-
     1    bb(itype(nowcrp,iplane)))
      if (vdmt(iplane).lt.0.) vdmt(iplane) = 0.0
c
c     ---- Compute canopy height (CANHGT), from vegetative dry matter (VDMT)
c     and plant height at maturity (HMAX).
      canhgt(iplane) = (1.-exp(-bbb(itype(nowcrp,iplane))*vdmt(iplane)))
     1    * hmax(itype(nowcrp,iplane))
c
c     ---- Compute leaf area index (LAI), from maximum leaf area index
c     (XMXLAI) and vegetative dry matter (VDMT).
c     ** CROPLAND ANNUALS **
      if (imngmt(nowcrp,iplane).eq.1) then
        lai(iplane) = (xmxlai(itype(nowcrp,iplane))*vdmt(iplane)) / (
     1      vdmt(iplane)+0.5512*exp(-6.8*vdmt(iplane)))
c
c     ** PERENNIALS OR RANGELAND **
      else
        lai(iplane) = (xmxlai(itype(nowcrp,iplane))*vdmt(iplane)) / (
     1      vdmt(iplane)+0.2756*exp(-13.6*vdmt(iplane)))
      end if
c
c     ---- Compute cumulative growing degree days (SUMGDD), from growing
c     degree days at maturity (GDDMAX), leaf area index (LAI), and
c     maximum leaf area index (XMXLAI).
      sumgdd(iplane) = gddmax(itype(nowcrp,iplane)) * lai(iplane) /
     1    xmxlai(itype(nowcrp,iplane))
c
c     Handle the case of a winter annual which has relatively low
c     cover -- so low that calculation of sumgdd is below value of
c     the critical value of growing degree days for emergence (CRIT).
c
      if ((jdharv(nowcrp,iplane).lt.jdplt(nowcrp,iplane)).and.(
     1    sumgdd(iplane).lt.crit(itype(nowcrp,iplane))))
     1    sumgdd(iplane) = crit(itype(nowcrp,iplane)) + 0.1
c
      return
      end


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! 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 and documentation.

! 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.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE INTERFACE_FORCE_LTM

! Merges matrices to get the interface force Loads Transformation Matrix (LTM):

!            IF_LTM   = | MRRcb  MRN    KRRcb |

! For a description of Craig-Bamptom analyses, see Appendix D to the MYSTRAN User's Referance Manual

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR, NDOFR, NTERM_KRRcb, NTERM_KRRcbn, NTERM_MRRcbn, NTERM_MRN  ,     &
                                         NTERM_IF_LTM  , NVEC
      USE PARAMS, ONLY                :  PRTIFLTM, SPARSTOR
      USE TIMDAT, ONLY                :  TSEC

      USE SPARSE_MATRICES, ONLY       :  SYM_KRRcb, SYM_KRRcbn, SYM_MRN  , SYM_MRRcbn, SYM_IF_LTM

      USE SPARSE_MATRICES, ONLY       :  I_MRRcbn   , J_MRRcbn   , MRRcbn   , I_MRN      , J_MRN      , MRN      ,                 &
                                         I_KRRcb    , J_KRRcb    , KRRcb    , I_KRRcbn   , J_KRRcbn   , KRRcbn   ,                 &
                                         I_IF_LTM   , J_IF_LTM   , IF_LTM

      USE SCRATCH_MATRICES, ONLY      :  I_CRS1, J_CRS1, CRS1

      USE SUBR_BEGEND_LEVELS, ONLY    :  INTERFACE_FORCE_LTM_BEGEND

      USE INTERFACE_FORCE_LTM_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'INTERFACE_FORCE_LTM'

      INTEGER(LONG)                   :: I,J               ! DO loop indices
      INTEGER(LONG)                   :: NCOL_CRS1         ! Number of cols in scratch matrix CRS1
      INTEGER(LONG)                   :: NTERM_CRS1        ! Number of nonzero terms in scratch matrix CRS1
      INTEGER(LONG)                   :: NUM_KRRcb_DIAG_0  ! Number of zeros on the diagonal of matrix KRRcb
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = INTERFACE_FORCE_LTM_BEGEND

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Set KRRcbn based on SPARSTOR (we need KRRcb in nonsym format since IF_LTM   will be nonsym

      IF      (SPARSTOR == 'SYM   ') THEN                  ! Convert KRRcb (stored symmetric) to KRRcbn (stored nonsymmetric)

         CALL SPARSE_MAT_DIAG_ZEROS ( 'KRRcb', NDOFR, NTERM_KRRcb, I_KRRcb, J_KRRcb, NUM_KRRcb_DIAG_0 )
         NTERM_KRRcbn = 2*NTERM_KRRcb  - (NDOFR - NUM_KRRcb_DIAG_0)
         CALL ALLOCATE_SPARSE_MAT ( 'KRRcbn', NDOFR, NTERM_KRRcbn, SUBR_NAME )
         CALL CRS_SYM_TO_CRS_NONSYM ( 'KRRcb' , NDOFR, NTERM_KRRcb , I_KRRcb , J_KRRcb , KRRcb,                                    &
                                      'KRRcbn',        NTERM_KRRcbn, I_KRRcbn, J_KRRcbn, KRRcbn, 'Y' )
      ELSE IF (SPARSTOR == 'NONSYM') THEN

         NTERM_KRRcbn = NTERM_KRRcb                        ! If SPARSTOR is nonsym, then KRRcb is also stored nonsym
         CALL ALLOCATE_SPARSE_MAT ( 'KRRcbn', NDOFR, NTERM_KRRcbn, SUBR_NAME )
         DO I=1,NDOFR+1
            I_KRRcbn(I) = I_KRRcb(I)
         ENDDO
         DO J=1,NTERM_KRRcbn
            J_KRRcbn(J) = J_KRRcb(J)
              KRRcbn(J) =   KRRcb(J)
         ENDDO

      ELSE

         WRITE(ERR,932) SUBR_NAME, SPARSTOR
         WRITE(F06,932) SUBR_NAME, SPARSTOR
         FATAL_ERR = FATAL_ERR + 1
         CALL OUTA_HERE ( 'Y' )

      ENDIF

! Allocate enough memory for merge of cols of MRRcbn with MRN

      NTERM_CRS1 = NTERM_MRRcbn+NTERM_MRN
      CALL ALLOCATE_SCR_CRS_MAT ( 'CRS1', NDOFR, NTERM_CRS1, SUBR_NAME )

! Merge MRRcbn and MRN   (both in nonsym format) into nonsym format temporary scratch matrix CRS1.

      CALL MERGE_MAT_COLS_SSS ( 'MRRcbn' , NTERM_MRRcbn   , I_MRRcbn, J_MRRcbn, MRRcbn, SYM_MRRcbn, NDOFR,                         &
                                'MRN  '  , NTERM_MRN      , I_MRN   , J_MRN   , MRN   , SYM_MRN   , NDOFR,                         &
                                'MRRcbn merged with MRN  ', I_CRS1  , J_CRS1  , CRS1  , 'N'        )

! Merge CRS1 with KRRcb to get IF_LTM

      NCOL_CRS1      = NDOFR + NVEC
      NTERM_IF_LTM   = NTERM_CRS1 + NTERM_KRRcbn
      CALL ALLOCATE_SPARSE_MAT ( 'IF_LTM  ', NDOFR, NTERM_IF_LTM  , SUBR_NAME )
      CALL MERGE_MAT_COLS_SSS ( 'CRS1'    , NTERM_CRS1    , I_CRS1    , J_CRS1    , CRS1    , 'N'         , NCOL_CRS1,             &
                                'KRRcbn'  , NTERM_KRRcbn  , I_KRRcbn  , J_KRRcbn  , KRRcbn  , SYM_KRRcbn  , NDOFR,                 &
                                'IF_LTM',                   I_IF_LTM  , J_IF_LTM  , IF_LTM  , SYM_IF_LTM   )
      CALL DEALLOCATE_SCR_MAT ( 'CRS1' )
      CALL DEALLOCATE_SPARSE_MAT ( 'KRRcbn' )

      IF (PRTIFLTM > 0) THEN
         CALL WRITE_SPARSE_CRS ( 'IF_LTM  ','  ','  ', NTERM_IF_LTM  , NDOFR, I_IF_LTM  , J_IF_LTM  , IF_LTM   )
      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
  932 FORMAT(' *ERROR   932: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' PARAMETER SPARSTOR MUST BE EITHER "SYM" OR "NONSYM" BUT VALUE IS ',A)

! **********************************************************************************************************************************

      END SUBROUTINE INTERFACE_FORCE_LTM


module m_hashtable
  implicit none

  type :: hashbucket
    integer :: nitems
    integer,allocatable :: items(:,:)
  end type hashbucket

  type :: hashtable_t
    integer :: bucketsize
    integer :: bucketstep
    integer :: nbuckets
    type(hashbucket),allocatable :: buckets(:)
  end type hashtable_t

  contains
  type(hashtable_t) function hashtable_init(nbuckets,bucketsize,bucketstep) result(new)
    ! Create the hashtable structure
    integer,intent(in) :: bucketsize, bucketstep, nbuckets
    integer :: ibucket

    new%nbuckets = nbuckets
    new%bucketsize = bucketsize
    new%bucketstep = bucketstep
    allocate(new%buckets(nbuckets))
    do ibucket=1,nbuckets
      allocate(new%buckets(ibucket)%items(2,new%bucketsize))
      new%buckets(ibucket)%nitems = 0
    end do
  end function hashtable_init

  pure function compute_hash(self,key) result(ihash)
    type(hashtable_t),intent(in) :: self
    integer,intent(in) :: key
    integer :: ihash
    ihash = mod(key-1,self%nbuckets)+1
  end function compute_hash

  subroutine hashtable_add(self, key, val)
    ! Add a key to the hashtable structure
    type(hashtable_t) :: self
    integer,intent(in) :: key, val
    integer :: ihash, item, nitems
    integer,allocatable :: new_items(:,:)
    ! Compute bucket for this element
    ihash = mod(key,self%nbuckets)+1
    nitems = self%buckets(ihash)%nitems
    ! Check if the element already exists in the bucket
    do item=1,nitems
      if (self%buckets(ihash)%items(1,item) /= key) cycle
      ! Replace value
      self%buckets(ihash)%items(2,item) = val
      return
    end do
    ! Check if the buckets are full
    if (size(self%buckets(ihash)%items,2)==nitems) then
      allocate(new_items(2,nitems+self%bucketstep))
      new_items(:,:nitems) = self%buckets(ihash)%items(:,:nitems)
      new_items(:,nitems+1:) = 0
      call move_alloc(new_items,self%buckets(ihash)%items)
    end if
    ! Add the element to the bucket
    nitems = nitems + 1
    self%buckets(ihash)%items(:,nitems) = [key,val]
    self%buckets(ihash)%nitems = nitems
  end subroutine hashtable_add

  subroutine hashtable_print(self)
    ! Print the hashtable data
    type(hashtable_t) :: self
    integer :: ibucket,item
    do ibucket=1,self%nbuckets
      do item=1,self%buckets(ibucket)%nitems
        write(*,*) ibucket, self%buckets(ibucket)%items(:,item)
      end do
    end do
  end subroutine hashtable_print

  subroutine hashtable_get(self,key,val,ierr)
    ! Get the value of a key in the hashtable
    type(hashtable_t) :: self
    integer,intent(in)  :: key
    integer,intent(out) :: val,ierr
    integer :: item, ihash
    ierr = 0
    ihash = mod(key,self%nbuckets)+1
    do item=1,self%buckets(ihash)%nitems
      if (self%buckets(ihash)%items(1,item) /= key) cycle
      val = self%buckets(ihash)%items(2,item)
      return
    end do
    ierr = 1
  end subroutine hashtable_get

  subroutine hashtable_keys(self,keys)
    ! Get an array with all the keys in hashtable
    type(hashtable_t) ::  self
    integer :: item,ibucket,idx
    integer,allocatable :: keys(:)
    allocate(keys(sum(self%buckets(:)%nitems)))
    idx = 0
    do ibucket=1,self%nbuckets
      do item=1,self%buckets(ibucket)%nitems
        idx = idx + 1
        keys(idx) = self%buckets(ibucket)%items(1,item)
      end do
    end do
  end subroutine hashtable_keys

  subroutine hashtable_items(self,items)
    ! Get an array with all the keys in hashtable
    type(hashtable_t) ::  self
    integer :: item,ibucket,idx
    integer,allocatable :: items(:,:)
    allocate(items(2,sum(self%buckets(:)%nitems)))
    idx = 0
    do ibucket=1,self%nbuckets
      do item=1,self%buckets(ibucket)%nitems
        idx = idx + 1
        items(:,idx) = self%buckets(ibucket)%items(:,item)
      end do
    end do
  end subroutine hashtable_items

  subroutine hashtable_cleanup(self)
    ! Free up memory in all the buckets
    ! this should be done only after all the add operations are finished
    type(hashtable_t) ::  self
    integer :: ibucket,nitems
    integer,allocatable :: new_items(:,:)
    do ibucket=1,self%nbuckets
      ! get size of buckets and free unecessary memory
      nitems = self%buckets(ibucket)%nitems
      allocate(new_items(2,nitems))
      new_items = self%buckets(ibucket)%items(:,:nitems)
      call move_alloc(new_items,self%buckets(ibucket)%items)
    end do
  end subroutine hashtable_cleanup

  integer function hashtable_size(self) result(bsize)
    type(hashtable_t) ::  self
    integer :: ibucket
    ! Return the size of the hashtable in bytes
    bsize = storage_size(self%buckets)*self%nbuckets
    do ibucket=1,self%nbuckets
      bsize = bsize + storage_size(self%buckets(ibucket)%items)*size(self%buckets(ibucket)%items,2)*2
    end do
    bsize = bsize/8
  end function hashtable_size

  subroutine hashtable_free(self)
    type(hashtable_t) ::  self
    integer :: ibucket
    do ibucket=1,self%nbuckets
      deallocate(self%buckets(ibucket)%items)
    end do
    deallocate(self%buckets)
  end subroutine hashtable_free
end module m_hashtable

program hash_main
  use m_hashtable
  implicit none
  type(hashtable_t) :: hash
  integer :: val, ierr, ii
  integer,allocatable :: keys(:), items(:,:)

  hash = hashtable_init(10,1,1)
  call hashtable_add(hash,1,3)
  call hashtable_add(hash,2,2)
  call hashtable_add(hash,7,2)
  call hashtable_add(hash,30,1235)
  call hashtable_add(hash,30,1236)
  call hashtable_add(hash,1000,123)
  call hashtable_add(hash,34,143)
  call hashtable_cleanup(hash)
  call hashtable_print(hash)
  call hashtable_get(hash,30,val,ierr)
  write(*,*) val, ierr

  call hashtable_keys(hash,keys)
  write(*,*) keys
  deallocate(keys)

  call hashtable_items(hash,items)
  do ii=1,size(items,2)
    write(*,'(i5,a,i5)') items(1,ii),'->',items(2,ii)
  end do
  deallocate(items)

  call hashtable_free(hash)

end program hash_main


MODULE GRAPH_PARTITION

USE MPI
USE MESH
USE PARAM, ONLY: RANK, NUM_PROC

IMPLICIT NONE

INTEGER, ALLOCATABLE, DIMENSION(:) :: GROUP ! GROUP(ELEMENT_I) = NUM_OF_PROC

INTEGER, ALLOCATABLE, DIMENSION(:, :) :: DUAL_LAPLACIAN

CONTAINS

SUBROUTINE BFS
!-----------------------------------------------------------------------
! BRESDTH-FIRST-SEARCH
! (1) BFS ASSIGNS EVERY VERTEX TO A LEVEL
! (2) STOPS WHEN ABOUT 1/2VERTICES ARE VISITED
! NUM OF PARITION SHOULD BE 2^N
!-----------------------------------------------------------------------
    INTEGER :: PARTITION_NUM    ! NUM OF PARTIITON
    INTEGER :: SEARCH_ELEM_NUM   ! SEARCH FOR 1/2VERTICES
    INTEGER, ALLOCATABLE, DIMENSION(:) :: ELEM_INDEX  ! THE INDEX OF THE ELEM IN THE SAME GROUP
    INTEGER :: ILAYER, I, INEIGHBOR, J, IROW
    INTEGER :: ELEM_FIND, ELEM_SUBTRACT
    INTEGER :: IGROUP

    ! DO THE DOMAIN PARTITION ON PROC 1---------------------------------
    IF (RANK == 0) THEN

        ! GENERATE THE DUAL GRAPH LAPLACIAN-----------------------------
        CALL GEN_DUAL_LAPLACIAN
        !---------------------------------------------------------------

        ! --------------------------------------------------------------
        ALLOCATE(GROUP(NEL_TOTAL))
        !---------------------------------------------------------------

        ! NUM OF PARITIOTN  = PROC NUM----------------------------------
!        PARITIOTN_NUM = NUM_PROC
        PARTITION_NUM = 4
        !---------------------------------------------------------------

        IF (PARTITION_NUM == 1) THEN
            GROUP = 0
        ELSE    ! PARTITION NUMBER >= 2
            !-----------------------------------------------------------
            SEARCH_ELEM_NUM = NEL_TOTAL/2     ! SUBTRUCT TEH FISRT ELEM
            !-----------------------------------------------------------

            ! ALLOCATE--------------------------------------------------
            ALLOCATE(ELEM_INDEX(NEL_TOTAL))
            !-----------------------------------------------------------

            !-----------------------------------------------------------
            GROUP = 0
            ELEM_INDEX = 0
            ELEM_FIND = 1
            IGROUP = 1
            IROW = 1
            !-----------------------------------------------------------

            !-----------------------------------------------------------
            GROUP(1) = 1
            ELEM_INDEX(1) = 1
            !-----------------------------------------------------------

            !-----------------------------------------------------------
            DO ILAYER=2, NEL_TOTAL
                INEIGHBOR = 0
                !-------------------------------------------------------
                DO I=1, NEL_TOTAL
                    IF(DUAL_LAPLACIAN(IROW, I) == -1) THEN

                        INEIGHBOR = INEIGHBOR+1

                        IF (GROUP(I) == 0 ) THEN
!                            LAYER(INEIGHBOR, IEL+1) = I
                            ELEM_FIND = ELEM_FIND+1
                            GROUP(I) = IGROUP
                            ELEM_INDEX(ELEM_FIND) = I
                        ENDIF

                        IF (INEIGHBOR == DUAL_LAPLACIAN(IROW, IROW)) EXIT
                    ENDIF
                ENDDO
                !-------------------------------------------------------

                IROW = ELEM_INDEX(ILAYER)

                !-------------------------------------------------------
                IF(ELEM_FIND > SEARCH_ELEM_NUM) THEN
                    ELEM_SUBTRACT = ELEM_FIND-SEARCH_ELEM_NUM
                    DO J=1, ELEM_SUBTRACT
                        GROUP(ELEM_INDEX(ELEM_FIND)) = IGROUP-1
                        ELEM_FIND = ELEM_FIND-1
                    ENDDO

                ENDIF
                !-------------------------------------------------------

                IF(ELEM_FIND == SEARCH_ELEM_NUM) THEN
                    EXIT
                ELSEIF(ELEM_FIND > SEARCH_ELEM_NUM) THEN
                    PRINT *, "BUGS IN 'ELEM_FIND'"
                    STOP
                ENDIF

            ENDDO
            !-----------------------------------------------------------

            ! THE OTHER HALF--------------------------------------------
            DO I=1, NEL_TOTAL
                IF(GROUP(I) /= IGROUP) THEN
                    GROUP(I) = IGROUP+1
                ENDIF
            ENDDO
            !-----------------------------------------------------------
        ENDIF
    ENDIF
    !-------------------------------------------------------------------

END SUBROUTINE BFS

SUBROUTINE BFS_NEW

    INTEGER :: PARTITION_NUM    ! NUM OF PARTIITON
    INTEGER :: SEARCH_ELEM_NUM   ! SEARCH FOR 1/2VERTICES
    INTEGER, ALLOCATABLE, DIMENSION(:, :) :: ELEM_INDEX  ! THE INDEX OF THE ELEM IN THE SAME GROUP
    INTEGER :: ILAYER, I, INEIGHBOR, J, IROW
    INTEGER :: ELEM_FIND, ELEM_SUBTRACT
    INTEGER :: IGROUP, IPARTITION, IGROUP_OLD
    INTEGER, DIMENSION(NEL_TOTAL, NEL_TOTAL) :: DUAL_LAPLACIAN_NEW
    INTEGER, ALLOCATABLE, DIMENSION(:) :: GROUP_ELEM_NUM
!    INTEGER :: K

    LOGICAL :: START = .TRUE.

    ! DO THE DOMAIN PARTITION ON PROC 1---------------------------------
    IF (RANK == 0) THEN

        ! GENERATE THE DUAL GRAPH LAPLACIAN-----------------------------
        CALL GEN_DUAL_LAPLACIAN
        !---------------------------------------------------------------

        ! --------------------------------------------------------------
        ALLOCATE(GROUP(NEL_TOTAL))
        !---------------------------------------------------------------

        !---------------------------------------------------------------
        GROUP = 0
        !---------------------------------------------------------------

        ! NUM OF PARITIOTN  = PROC NUM----------------------------------
!        PARITIOTN_NUM = NUM_PROC
        PARTITION_NUM = 4
        !---------------------------------------------------------------

        IF (PARTITION_NUM == 1) THEN
            GROUP = 1
        ELSE    ! PARTITION NUMBER >= 2

            ! ALLOCATE--------------------------------------------------
            ALLOCATE(ELEM_INDEX(NEL_TOTAL, PARTITION_NUM))
            ALLOCATE(GROUP_ELEM_NUM(PARTITION_NUM))
            !-----------------------------------------------------------

            !-----------------------------------------------------------
            ELEM_INDEX = 0
            GROUP_ELEM_NUM = 0
            GROUP_ELEM_NUM(1) = NEL_TOTAL
            GROUP(:) = 1
            !-----------------------------------------------------------

            !-----------------------------------------------------------
            DO I=1, NEL_TOTAL
                ELEM_INDEX(I, 1) = I
            ENDDO
            !-----------------------------------------------------------

            !-----------------------------------------------------------
            DO WHILE(START)
!            DO K=1, 1
                !-------------------------------------------------------
                ELEM_FIND = 1
                !-------------------------------------------------------

                IGROUP_OLD = MAXLOC(GROUP_ELEM_NUM, 1)

                CALL GEN_SUB_DUAL_GRAPH(IGROUP_OLD, &
                                        DUAL_LAPLACIAN_NEW)

                IROW = ELEM_INDEX(1, IGROUP_OLD)

                IGROUP = MAXVAL(GROUP) + 1

                ELEM_INDEX(1, IGROUP) = IROW

                GROUP(IROW) = IGROUP

                SEARCH_ELEM_NUM = GROUP_ELEM_NUM(IGROUP_OLD)/2

!                PRINT *, "IGROUP_OLD", IGROUP_OLD, "IGROUP", IGROUP, "IROW", IROW
!                PRINT *, "SEARCH_ELEM", SEARCH_ELEM_NUM

                !-------------------------------------------------------
                DO ILAYER=2, NEL_TOTAL
                    INEIGHBOR = 0
                    !---------------------------------------------------
                    DO I=1, NEL_TOTAL
                        IF(DUAL_LAPLACIAN_NEW(IROW, I) == -1) THEN

                            INEIGHBOR = INEIGHBOR+1

                            IF (GROUP(I) == IGROUP_OLD ) THEN
                                ELEM_FIND = ELEM_FIND+1
                                GROUP(I) = IGROUP
                                ELEM_INDEX(ELEM_FIND, IGROUP) = I
                            ENDIF

!                            PRINT *, "ELEM_FIND", ELEM_FIND

                            IF (INEIGHBOR == DUAL_LAPLACIAN_NEW(IROW, IROW)) EXIT
                            IF (ELEM_FIND == SEARCH_ELEM_NUM) EXIT
                        ENDIF
                    ENDDO
                    !---------------------------------------------------

                    IROW = ELEM_INDEX(ILAYER, IGROUP)

                    !---------------------------------------------------
                    IF(ELEM_FIND > SEARCH_ELEM_NUM) THEN
!                        PRINT *, "ELEM_FIND > SEARCH_ELEM_NUM"
                        ELEM_SUBTRACT = ELEM_FIND-SEARCH_ELEM_NUM
                        DO J=1, ELEM_SUBTRACT
                            GROUP(ELEM_INDEX(ELEM_FIND, IGROUP)) = IGROUP_OLD
                            ELEM_INDEX(ELEM_FIND, IGROUP) = 0
                            ELEM_FIND = ELEM_FIND-1
                        ENDDO

                    ENDIF
                    !---------------------------------------------------

                    !---------------------------------------------------
                    IF(ELEM_FIND == SEARCH_ELEM_NUM) THEN
                        GROUP_ELEM_NUM(IGROUP) = ELEM_FIND

                        CALL UPDATE_ELEM_INDEX(IGROUP, ELEM_INDEX, &
                                PARTITION_NUM, GROUP_ELEM_NUM, &
                                IGROUP_OLD, ELEM_FIND)

                        GROUP_ELEM_NUM(IGROUP_OLD) = GROUP_ELEM_NUM(IGROUP_OLD) &
                                                    - ELEM_FIND

                        EXIT
                    ELSEIF(ELEM_FIND > SEARCH_ELEM_NUM) THEN
                        PRINT *, "BUGS IN 'ELEM_FIND'"
                        STOP
                    ENDIF
                    !---------------------------------------------------

                ENDDO
                !-------------------------------------------------------

!                IF(MAXVAL(GROUP) == 4) THEN
!                    PRINT *, GROUP_ELEM_NUM
!                ENDIF

                !-------------------------------------------------------
                IF(MAXVAL(GROUP) == PARTITION_NUM) EXIT
                !-------------------------------------------------------

            ENDDO
            !-----------------------------------------------------------
        ENDIF

        !---------------------------------------------------------------
        DEALLOCATE(ELEM_INDEX)
        DEALLOCATE(GROUP_ELEM_NUM)
        !---------------------------------------------------------------

    ENDIF
    !-------------------------------------------------------------------

END SUBROUTINE BFS_NEW

SUBROUTINE GEN_DUAL_LAPLACIAN
!-----------------------------------------------------------------------
! GENERATE THE DUAL GRAPH LAPLACIAN
!-----------------------------------------------------------------------

    INTEGER :: IEL, J

    !-------------------------------------------------------------------
    ALLOCATE(DUAL_LAPLACIAN(NEL_TOTAL, NEL_TOTAL))

    DUAL_LAPLACIAN = 0
    !-------------------------------------------------------------------

    ! ADJECENCY---------------------------------------------------------
    DO IEL=1, NEL_TOTAL
        DO J=1, 4
            IF(NEIGHBOR_ELEM(J, IEL) /= 0) THEN
                DUAL_LAPLACIAN(IEL, NEIGHBOR_ELEM(J, IEL)) = -1
            ENDIF
        ENDDO

    ENDDO
    !-------------------------------------------------------------------

    ! DEGREE------------------------------------------------------------
    DO IEL=1, NEL_TOTAL
        DUAL_LAPLACIAN(IEL, IEL) = ABS(SUM(DUAL_LAPLACIAN(IEL, :)))
    ENDDO
    !-------------------------------------------------------------------

END SUBROUTINE GEN_DUAL_LAPLACIAN

SUBROUTINE GEN_SUB_DUAL_GRAPH(IGROUP_OLD, DUAL_LAPLACIAN_NEW)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: IGROUP_OLD
    INTEGER, DIMENSION(NEL_TOTAL, NEL_TOTAL) :: DUAL_LAPLACIAN_NEW
    INTEGER :: I, J

    DUAL_LAPLACIAN_NEW = 0

    !-------------------------------------------------------------------
    DO I=1, NEL_TOTAL
        IF(GROUP(I) == IGROUP_OLD) THEN

            DO J=1, NEL_TOTAL

                IF((DUAL_LAPLACIAN(I, J) == -1) .AND. &
                    (GROUP(J) == IGROUP_OLD)) THEN

                    DUAL_LAPLACIAN_NEW(I, J) = -1

                ENDIF

            ENDDO

            DUAL_LAPLACIAN_NEW(I, I) = ABS(SUM(DUAL_LAPLACIAN_NEW(I, :)))

        ENDIF

    ENDDO
    !-------------------------------------------------------------------

END SUBROUTINE GEN_SUB_DUAL_GRAPH

SUBROUTINE UPDATE_ELEM_INDEX(IGROUP, ELEM_INDEX, &
                            PARTITION_NUM, GROUP_ELEM_NUM, IGROUP_OLD, &
                            ELEM_FIND)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: IGROUP, PARTITION_NUM, IGROUP_OLD, ELEM_FIND
    INTEGER, DIMENSION(NEL_TOTAL, PARTITION_NUM) :: ELEM_INDEX
    INTEGER, DIMENSION(PARTITION_NUM) :: GROUP_ELEM_NUM
    INTEGER, ALLOCATABLE, DIMENSION(:) :: REMAIN
    INTEGER :: I, J, IEL, K

    LOGICAL :: STAY

    ALLOCATE(REMAIN(GROUP_ELEM_NUM(IGROUP_OLD)-ELEM_FIND))

    REMAIN=0
    K=1

    !-------------------------------------------------------------------
    DO J=1, GROUP_ELEM_NUM(IGROUP_OLD)

        IEL=ELEM_INDEX(J, IGROUP_OLD)
        STAY = .FALSE.

        DO I=1, GROUP_ELEM_NUM(IGROUP)
            IF(IEL == ELEM_INDEX(I, IGROUP)) THEN
                STAY = .FALSE.
                EXIT
            ELSE
                STAY = .TRUE.
            ENDIF
        ENDDO

        IF(STAY) THEN
            REMAIN(K) = IEL
            K=K+1
        ENDIF

    ENDDO
    !-------------------------------------------------------------------

    ELEM_INDEX(:, IGROUP_OLD) = 0

    DO I=1, K-1
        ELEM_INDEX(I, IGROUP_OLD) = REMAIN(I)
    ENDDO

    DEALLOCATE(REMAIN)

END SUBROUTINE UPDATE_ELEM_INDEX

END MODULE GRAPH_PARTITION


*DECK DPODI
      SUBROUTINE DPODI (A, LDA, N, DET, JOB)
C***BEGIN PROLOGUE  DPODI
C***PURPOSE  Compute the determinant and inverse of a certain real
C            symmetric positive definite matrix using the factors
C            computed by DPOCO, DPOFA or DQRDC.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1B, D3B1B
C***TYPE      DOUBLE PRECISION (SPODI-S, DPODI-D, CPODI-C)
C***KEYWORDS  DETERMINANT, INVERSE, LINEAR ALGEBRA, LINPACK, MATRIX,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DPODI computes the determinant and inverse of a certain
C     double precision symmetric positive definite matrix (see below)
C     using the factors computed by DPOCO, DPOFA or DQRDC.
C
C     On Entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the output  A  from DPOCO or DPOFA
C                or the output  X  from DQRDC.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        JOB     INTEGER
C                = 11   both determinant and inverse.
C                = 01   inverse only.
C                = 10   determinant only.
C
C     On Return
C
C        A       If DPOCO or DPOFA was used to factor  A , then
C                DPODI produces the upper half of INVERSE(A) .
C                If DQRDC was used to decompose  X , then
C                DPODI produces the upper half of inverse(TRANS(X)*X)
C                where TRANS(X) is the transpose.
C                Elements of  A  below the diagonal are unchanged.
C                If the units digit of JOB is zero,  A  is unchanged.
C
C        DET     DOUBLE PRECISION(2)
C                determinant of  A  or of  TRANS(X)*X  if requested.
C                Otherwise not referenced.
C                Determinant = DET(1) * 10.0**DET(2)
C                with  1.0 .LE. DET(1) .LT. 10.0
C                or  DET(1) .EQ. 0.0 .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains
C        a zero on the diagonal and the inverse is requested.
C        It will not occur if the subroutines are called correctly
C        and if DPOCO or DPOFA has set INFO .EQ. 0 .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DPODI
      INTEGER LDA,N,JOB
      DOUBLE PRECISION A(LDA,*)
      DOUBLE PRECISION DET(2)
C
      DOUBLE PRECISION T
      DOUBLE PRECISION S
      INTEGER I,J,JM1,K,KP1
C***FIRST EXECUTABLE STATEMENT  DPODI
C
C     COMPUTE DETERMINANT
C
      IF (JOB/10 .EQ. 0) GO TO 70
         DET(1) = 1.0D0
         DET(2) = 0.0D0
         S = 10.0D0
         DO 50 I = 1, N
            DET(1) = A(I,I)**2*DET(1)
            IF (DET(1) .EQ. 0.0D0) GO TO 60
   10       IF (DET(1) .GE. 1.0D0) GO TO 20
               DET(1) = S*DET(1)
               DET(2) = DET(2) - 1.0D0
            GO TO 10
   20       CONTINUE
   30       IF (DET(1) .LT. S) GO TO 40
               DET(1) = DET(1)/S
               DET(2) = DET(2) + 1.0D0
            GO TO 30
   40       CONTINUE
   50    CONTINUE
   60    CONTINUE
   70 CONTINUE
C
C     COMPUTE INVERSE(R)
C
      IF (MOD(JOB,10) .EQ. 0) GO TO 140
         DO 100 K = 1, N
            A(K,K) = 1.0D0/A(K,K)
            T = -A(K,K)
            CALL DSCAL(K-1,T,A(1,K),1)
            KP1 = K + 1
            IF (N .LT. KP1) GO TO 90
            DO 80 J = KP1, N
               T = A(K,J)
               A(K,J) = 0.0D0
               CALL DAXPY(K,T,A(1,K),1,A(1,J),1)
   80       CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        FORM  INVERSE(R) * TRANS(INVERSE(R))
C
         DO 130 J = 1, N
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 120
            DO 110 K = 1, JM1
               T = A(K,J)
               CALL DAXPY(K,T,A(1,J),1,A(1,K),1)
  110       CONTINUE
  120       CONTINUE
            T = A(J,J)
            CALL DSCAL(J,T,A(1,J),1)
  130    CONTINUE
  140 CONTINUE
      RETURN
      END


SUBROUTINE amrclaw_compute_error(level,naux,nvar,time)

    use amr_module, only: alloc, node, rnode, lstart, hxposs, hyposs, store1, storeaux, &
               nestlevel, ndihi, ndjhi,ndilo,ndjlo,nestlevel, &
               timemult, nghost, cornxlo,cornylo,mcapa, levelptr
    IMPLICIT NONE

    INTEGER naux, nvar, level
    DOUBLE PRECISION time

!!      double precision error(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
!!      double precision soln(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)

    INTEGER mx,my,mbc,meqn, blockno, maux
    DOUBLE PRECISION dx, dy, xlower, ylower, t, err(3), total_area

    INTEGER mitot, mjtot, loc, locaux
    integer iaddq, iaddaux

    integer i,j,m, mptr

    if (level .ne. 1) then
        write(6,*) 'amrclaw_compute_error : level .ne. 1'
        stop
    endif

    !! convert from AMRClaw parameters to Clawpack parameters

    meqn  = nvar
    maux  = naux
    mbc   = nghost

    dx     = hxposs(level)
    dy     = hyposs(level)
    t      = time

    do m = 1,3
        err(m) = 0
    end do
    total_area = 0

!!  Loop over all grids at level 'level'

    mptr = lstart(level)
20  if (mptr .eq. 0) go to 85

        mx = node(ndihi,mptr) - node(ndilo,mptr) + 1
        my = node(ndjhi,mptr) - node(ndjlo,mptr) + 1

        xlower = rnode(cornxlo,mptr)
        ylower = rnode(cornylo,mptr)

        !! Compute location of q and aux in allocation array 'alloc'
        !! Use hints from 'conck.f'.

        loc    = node(store1,mptr)
        locaux = node(storeaux,mptr)

        !! Accumulate error
        CALL torus46_compute_error(blockno,mx,my,mbc,meqn, maux, mcapa, &
                                   dx,dy,xlower,ylower,t, alloc(locaux), &
                                   alloc(loc),err,total_area)

        mptr = node(levelptr,mptr) !! Linked list?
        GO TO 20

85  continue
    err(1) = err(1)/total_area
    err(2) = sqrt(err(2)/total_area)

    do m = 1,meqn
        write(6,100) m, err(1), err(2), err(3)
    end do

100 format('error[',I1,']',3E12.4)

END SUBROUTINE amrclaw_compute_error

SUBROUTINE torus46_compute_error(blockno,mx,my,mbc,meqn, maux, mcapa, &
           dx,dy,xlower,ylower,t,aux,q,err,total_area)

    IMPLICIT NONE

    INTEGER mx,my,mbc,meqn, maux, blockno, mcapa
    DOUBLE PRECISION dx, dy, xlower, ylower, t
    DOUBLE PRECISION q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
    DOUBLE PRECISION aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)
    DOUBLE PRECISION err(3), total_area

    INTEGER example
    COMMON /example_comm/ example

    !!integer*8 cont, get_context

    INTEGER i,j,m
    DOUBLE PRECISION xc,yc, qexact
    DOUBLE PRECISION xc1, yc1, zc1, x,y

    DOUBLE PRECISION torus_divergence
    INTEGER flow_flag

    DOUBLE PRECISION soln, errval, dxdy, area

    IF (example .eq. 0) THEN
!!      # non-divergent flow
        flow_flag = 0
    ELSE
!!       # Divergent flow
         flow_flag = 1
    ENDIF

!!  # Assume a single field variable only
    dxdy = dx*dy
    DO j = 1,my
        DO i = 1,mx
            xc = xlower + (i-0.5)*dx
            yc = ylower + (j-0.5)*dy

            IF (t .eq. 0) THEN
               soln = q(1,i,j)
            ELSE
               !! Pass computational coordinates to qexact
               soln = qexact(xc,yc,t,flow_flag)
            ENDIF

            errval = abs(q(1,i,j) - soln)
            IF (mcapa .eq. 0) THEN
               area = dxdy
            ELSE
               area = aux(mcapa,i,j)*dxdy
            ENDIF

            err(1) = err(1) + errval*area
            err(2) = err(2) + errval**2*area
            err(3) = max(err(3),errval)
            total_area = total_area + area
        END DO
    END DO

END SUBROUTINE torus46_compute_error