! calculate bulk's energy band using wannier TB method
  subroutine fermisurface

     use wmpi
     use para

     implicit none

     integer :: ik, i, j, ikx, iky
     integer :: nkx
     integer :: nky

     integer :: ierr
     real(dp) :: kz
     real(Dp) :: k(2)

     ! Hamiltonian of bulk system
     complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

     real(dp) :: zmin, zmax
     real(dp) :: kxmin, kxmax, kymin, kymax
     real(dp) :: kxmin_shape, kxmax_shape, kymin_shape, kymax_shape

     real(dp), allocatable :: kxy(:,:)
     real(dp), allocatable :: kxy_shape(:,:)

     real(dp), allocatable :: dos(:)
     real(dp), allocatable :: dos_mpi(:)

     complex(dp), allocatable :: ones(:,:)

     nkx= Nk1
     nky= Nk2
     allocate( kxy(2, nkx*nky))
     allocate( kxy_shape(2, nkx*nky))
     kxy=0d0
     kxy_shape=0d0

     ik=0
     do ikx=1, Nk1
        do iky=1, Nk2
           ik= ik+ 1
           kxy(:, ik)= K2D_start+ K2D_vec1*(ikx-1)/dble(nk1-1)  &
                + K2D_vec2*(iky-1)/dble(nk2-1)
           kxy_shape(:, ik)= kxy(1,ik)*kua+ kxy(2, ik)*kub
        enddo
     enddo

     kxmin_shape= minval(kxy_shape(1, :))
     kxmax_shape= maxval(kxy_shape(1, :))
     kymin_shape= minval(kxy_shape(2, :))
     kymax_shape= maxval(kxy_shape(2, :))

     allocate( dos    (Nk1*Nk2))
     allocate( dos_mpi(Nk1*Nk2))
     dos    = 0d0
     dos_mpi= 0d0

     allocate(ones(Num_wann, Num_wann))
     ones= 0d0
     do i=1, Num_wann
        ones(i, i)= 1d0
     enddo
     do ik= 1+cpuid, Nk1*Nk2, num_cpu
        if (cpuid==0) write(stdout, *),'FS, ik, knv3' , ik, Nk1*Nk2

        k(1) = kxy(1, ik)
        k(2) = kxy(2, ik)

        ! calculation bulk hamiltonian
        Hamk_bulk= 0d0
        call ham_bulk(k, Hamk_bulk)

        Hamk_bulk= (E_arc -zi* eta_arc)* ones - Hamk_bulk
        call inv(Num_wann, Hamk_bulk)
        do i=1, Num_wann
           dos(ik)= dos(ik)+ aimag(Hamk_bulk(i, i))/pi
        enddo

     enddo

     call mpi_allreduce(dos,dos_mpi,size(dos),&
                       mpi_dp,mpi_sum,mpi_cmw,ierr)

     if (cpuid==0)then
        open(unit=14, file='fs.dat')

        do ik=1, Nk1*Nk2
           write(14, '(3f16.8)')kxy_shape(:, ik), log(dos_mpi(ik))
           if (mod(ik, nky)==0) write(14, *)' '
        enddo
        close(14)
     endif
     zmax= maxval(log(dos_mpi))
     zmin= minval(log(dos_mpi))

     !> minimum and maximum value of energy bands

     !> write script for gnuplot
     if (cpuid==0) then
        open(unit=101, file='fs.gnu')
        write(101, '(a)')"set encoding iso_8859_1"
        write(101, '(a)')'#set terminal  postscript enhanced color'
        write(101, '(a)')"#set output 'fs.eps'"
        write(101, '(3a)')'set terminal  pngcairo truecolor enhanced', &
           ' size 1920, 1680 font ",36"'
        write(101, '(a)')"set output 'fs.png'"
        write(101,'(a, f10.4, 2a, f10.4, a)') &
           'set palette defined ( ', zmin, ' "white", ', &
          '0 "black", ', zmax,'  "red" )'
        write(101, '(a)')'#set palette rgbformulae 33,13,10'
        write(101, '(a)')'unset ztics'
        write(101, '(a)')'unset key'
        write(101, '(a)')'set pm3d'
        write(101, '(a)')'#set view equal xyz'
        write(101, '(a)')'set view map'
        write(101, '(a)')'set border lw 3'
        write(101, '(a)')'#set xtics font ",24"'
        write(101, '(a)')'#set ytics font ",24"'
        write(101, '(a)')'set size ratio -1'
        write(101, '(a)')'unset xtics'
        write(101, '(a)')'unset ytics'
        write(101, '(a)')'set colorbox'
       !write(101, '(a, f10.5, a, f10.5, a)')'set xrange [', kxmin, ':', kxmax, ']'
       !write(101, '(a, f10.5, a, f10.5, a)')'set yrange [', kymin, ':', kymax, ']'
        write(101, '(a, f10.5, a, f10.5, a)')'set xrange [', kxmin_shape, ':', kxmax_shape, ']'
        write(101, '(a, f10.5, a, f10.5, a)')'set yrange [', kymin_shape, ':', kymax_shape, ']'
        write(101, '(a)')'set pm3d interpolate 2,2'
        write(101, '(2a)')"splot 'fs.dat' u 1:2:3 w pm3d"

        close(101)
     endif

   return
   end subroutine fermisurface

!  calculate bulk's energy band using wannier TB method
   subroutine gapshape

      use wmpi
      use para

      implicit none

      integer :: ik, i, j, ikx, iky
      integer :: nkx
      integer :: nky

      integer :: ierr, i1, i2
      real(Dp) :: k(2)

      ! Hamiltonian of bulk system
      complex(Dp) :: Hamk_bulk(Num_wann,Num_wann)

      real(dp) :: zmin, zmax
      real(dp) :: kxmin_shape, kxmax_shape, kymin_shape, kymax_shape

      real(dp), allocatable :: kxy(:,:)
      real(dp), allocatable :: kxy_shape(:,:)

      real(dp), allocatable :: gap(:, :)
      real(dp), allocatable :: gap_mpi(:, :)
      real(dp), allocatable :: W(:)

      complex(dp), allocatable :: ones(:,:)

      nkx= Nk
      nky= Nk
      allocate( kxy(2, nkx*nky))
      allocate( kxy_shape(2, nkx*nky))
      kxy=0d0
      kxy_shape=0d0

      ik=0
      do ikx=1, Nk1
         do iky=1, Nk2
            ik= ik+ 1
            kxy(:, ik)= K2D_start+ K2D_vec1*(ikx-1)/dble(nk1-1)  &
                 + K2D_vec2*(iky-1)/dble(nk2-1)
            kxy_shape(:, ik)= kxy(1,ik)*kua+ kxy(2, ik)*kub
         enddo
      enddo

      kxmin_shape=minval(kxy_shape(1,:))
      kxmax_shape=maxval(kxy_shape(1,:))
      kymin_shape=minval(kxy_shape(2,:))
      kymax_shape=maxval(kxy_shape(2,:))

      allocate( gap    (3, Nk1*Nk2))
      allocate( gap_mpi(3, Nk1*Nk2))
      gap    = 0d0
      gap_mpi= 0d0

      allocate(W(Num_wann))
      allocate(ones(Num_wann, Num_wann))
      W= 0d0
      ones= 0d0
      do i=1, Num_wann
         ones(i, i)= 1d0
      enddo

      if (Numoccupied> Num_wann) then
         stop 'Numoccupied should less than Num_wann'
      endif

      do ik= 1+cpuid, Nk1*Nk2, num_cpu
         if (cpuid==0)write(stdout, *)'Gap plane', ik, Nk1*Nk2

         k(1) = kxy(1, ik)
         k(2) = kxy(2, ik)

         !> calculation bulk hamiltonian
         Hamk_bulk= 0d0
         call ham_bulk(k, Hamk_bulk)

         !> diagonalization
         call eigensystem_c( 'N', 'U', Num_wann ,Hamk_bulk, W)
         gap(1, ik)= W(Numoccupied+1)- W(Numoccupied)
         gap(2, ik)= W(Numoccupied)
         gap(3, ik)= W(Numoccupied+1)

      enddo

      call mpi_allreduce(gap,gap_mpi,size(gap),&
                        mpi_dp,mpi_sum,mpi_cmw,ierr)

      if (cpuid==0)then
         open(unit=14, file='GapPlane.dat')

         write(14, '(100a16)')'# kx', 'ky', 'gap', 'Ev', 'Ec', 'k1', 'k2'
         do ik=1, Nk1*Nk2
            write(14, '(30f16.8)')kxy_shape(:, ik), (gap_mpi(:, ik)), kxy(:, ik)
            if (mod(ik, nky)==0) write(14, *)' '
         enddo
         close(14)

         open(unit=15, file='gap2d.dat')
         write(15, '(100a16)')'kx', 'ky', 'gap', 'Ev', 'Ec', 'k1', 'k2'
         do ik=1, Nk1*Nk2
            if (abs(gap_mpi(1, ik))< 0.10d0) then
               write(15, '(8f16.8)')kxy_shape(:, ik), (gap_mpi(:, ik)), kxy(:, ik)
            endif
         enddo
         close(15)

         open(unit=1116, file='GapPlane_matlab.dat')

         write(1116, '(100a16)')'% kx', 'ky', 'gap', 'Ev', 'Ec', 'k1', 'k2'
         do ik=1, Nk1*Nk2
            write(1116, '(30f16.8)')kxy_shape(:, ik), (gap_mpi(:, ik)), kxy(:, ik)
         enddo
         close(1116)

      endif

      !> minimum and maximum value of energy bands

      zmax= maxval(gap_mpi(1, :))
      zmin= minval(gap_mpi(1, :))

      !> write script for gnuplot
      if (cpuid==0) then
         open(unit=103, file='GapPlane.gnu')
         write(103, '(a)')"set encoding iso_8859_1"
         write(103, '(a)')'#set terminal  postscript enhanced color'
         write(103, '(a)')"#set output 'GapPlane.eps'"
         write(103, '(3a)')'#set terminal  pngcairo   truecolor enhanced', &
            '  size 1920, 1680 font ",60"'
         write(103, '(3a)')'set terminal  png   truecolor enhanced', &
            ' size 1920, 1680 font ",60"'
         write(103, '(a)')"set output 'GapPlane.png'"
         write(103,'(a, f10.4, a, f10.4, a, f10.4, a)') &
            'set palette defined ( ', zmin, ' "black", ', &
            (zmin+zmax)/20d0,' "orange", ',zmax,'  "white" )'
         write(103, '(a)')"set origin 0.10, 0.0"
         write(103, '(a)')"set size 0.85, 1.0"
         write(103, '(a)')'unset ztics'
         write(103, '(a)')'unset key'
         write(103, '(a)')'set pm3d'
         write(103, '(a)')'set view map'
         write(103, '(a)')'set border lw 3'
         write(103, '(a)')'#set size ratio -1'
         write(103, '(a)')'set title "Gap in k plane"'
         write(103, '(a)')'set xtics nomirror scale 0.5'
         write(103, '(a)')'set ytics nomirror scale 0.5'
         write(103, '(a)')"set xlabel 'k (1/{\305})'"
         write(103, '(a)')"set ylabel 'k (1/{\305})'"
         write(103, '(a)')'set colorbox'
         write(103, '(a)')'set xrange [ ] noextend'
         write(103, '(a)')'set yrange [ ] noextend'
         write(103, '(a)')'set pm3d interpolate 2,2'
         write(103, '(2a)')"splot 'GapPlane.dat' u 1:2:3 w pm3d"

         close(103)
      endif

      return
   end subroutine gapshape

   !> get fermilevel for the given hamiltonian
   subroutine get_fermilevel
      use wmpi
      use para
      implicit none

      integer :: i1
      integer :: i2
      integer :: i3
      integer :: io
      integer :: ik

      !> number of k points

      integer :: ierr
      integer :: iter
      integer :: itermax

      !> fermi level
      real(dp) :: EF

      real(dp) :: k(3)

      real(dp) ::  Beta

      real(dp) :: lmin
      real(dp) :: lmax
      real(dp) :: tot

      !> fermi-dirac distribution function
      real(dp), external :: fermi

      !> kpoint coordinates
      real(dp), allocatable :: kpoints(:, :)

      !> eigen value for each kpoint
      real(dp), allocatable :: W(:)
      real(dp), allocatable :: eigvals(:, :)
      real(dp), allocatable :: eigvals_mpi(:, :)

      complex(dp), allocatable :: ham(:, :)

      allocate(W(Num_wann))
      allocate(eigvals(Num_wann, Nk1*Nk2))
      allocate(eigvals_mpi(Num_wann, Nk1*Nk2))
      allocate(ham(Num_wann, Num_wann))
      allocate(kpoints(2, Nk1*Nk2))
      eigvals= 0d0
      eigvals_mpi= 0d0
      ham= 0d0
      kpoints= 0d0
      Beta= 200d0

      ik= 0
      do i1=1, Nk
      do i2=1, Nk
      do i3=1, Nk
         ik= ik+ 1
         kpoints(1, ik)= (i1-1d0)/dble(Nk)
         kpoints(2, ik)= (i2-1d0)/dble(Nk)
         kpoints(3, ik)= (i3-1d0)/dble(Nk)
      enddo
      enddo
      enddo

      do ik=1+ cpuid, Nk1*Nk2, num_cpu

         ham= 0d0
         k= kpoints(:, ik)
         call ham_bulk(k, ham)
         call eigensystem_c( 'N', 'U', num_wann, ham, W)
         eigvals_mpi(:, ik)= W
      enddo ! ik

      call mpi_allreduce(eigvals_mpi, eigvals, size(eigvals), &
                         mpi_dp, mpi_sum, mpi_cmw, ierr)

      ! using bisection algorithm to search the fermi level
      iter= 0
      itermax= 100
      tot= 9999d0
      lmin= minval(eigvals)
      lmax= maxval(eigvals)
      if (cpuid==0) print *, 'Emin= ', lmin
      if (cpuid==0) print *, 'Emax= ', lmax
      do while( abs(tot- Ntotch).gt. eps6 .and. iter.lt.itermax)

         iter= iter+ 1

         EF= (lmin+ lmax)* half

         tot= 0d0
         do ik=1, Nk1*Nk2
            do io=1, Num_wann
               tot= tot+ fermi(eigvals(io, ik)- EF, Beta)
            enddo ! io
         enddo ! ik
         tot= tot/dble(Nk1*Nk2)

         if (tot > Ntotch)then
            lmax= EF
         else
            lmin= EF
         endif

         if (cpuid==0) then
             write(stdout, 100)iter, tot-Ntotch, EF, '  Charge: ', tot
         endif
      100   format(2x,">iter",i4,2x,"diff:",f12.6,2x,"EF: ",f12.6,a,f12.6)

      enddo ! bisection

      E_fermi= EF

      return
   end subroutine get_fermilevel

   !------------+------------+------------+------------+------------+--------+!
   ! calculate the Fermi-Dirac distribution
   !------------+------------+------------+------------+------------+--------+!
   function fermi(omega, Beta) result(value)

      use para
      implicit none

      ! >> inout variables
      real(dp), intent(in) :: omega
      real(dp), intent(in) :: Beta

      ! return value
      real(dp) :: value

      ! avoid numerical instability
      if (beta*omega .ge. 20d0) then
         value = zero
      elseif (beta*omega.le. -20d0)then
         value = one
      else
         value= one/(one+exp(beta*omega))
      endif

      return
   end function fermi


      program prog
      i = 123
      do while (i .lt. 169)
        write(6, *) i
        i = i + 45
      enddo
      do 10 while (i .lt. 281)
        write(6, *) i
        i = i + 67
   10 enddo
      end


      SUBROUTINE sort(n,arr)
      INTEGER n,M,NSTACK
      REAL arr(n)
      PARAMETER (M=7,NSTACK=50)
      INTEGER i,ir,j,jstack,k,l,istack(NSTACK)
      REAL a,temp
      jstack=0
      l=1
      ir=n
1     if(ir-l.lt.M)then
        do 12 j=l+1,ir
          a=arr(j)
          do 11 i=j-1,l,-1
            if(arr(i).le.a)goto 2
            arr(i+1)=arr(i)
11        continue
          i=l-1
2         arr(i+1)=a
12      continue
        if(jstack.eq.0)return
        ir=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
      else
        k=(l+ir)/2
        temp=arr(k)
        arr(k)=arr(l+1)
        arr(l+1)=temp
        if(arr(l).gt.arr(ir))then
          temp=arr(l)
          arr(l)=arr(ir)
          arr(ir)=temp
        endif
        if(arr(l+1).gt.arr(ir))then
          temp=arr(l+1)
          arr(l+1)=arr(ir)
          arr(ir)=temp
        endif
        if(arr(l).gt.arr(l+1))then
          temp=arr(l)
          arr(l)=arr(l+1)
          arr(l+1)=temp
        endif
        i=l+1
        j=ir
        a=arr(l+1)
3       continue
          i=i+1
        if(arr(i).lt.a)goto 3
4       continue
          j=j-1
        if(arr(j).gt.a)goto 4
        if(j.lt.i)goto 5
        temp=arr(i)
        arr(i)=arr(j)
        arr(j)=temp
        goto 3
5       arr(l+1)=arr(j)
        arr(j)=a
        jstack=jstack+2
        if(jstack.gt.NSTACK)pause 'NSTACK too small in sort'
        if(ir-i+1.ge.j-l)then
          istack(jstack)=ir
          istack(jstack-1)=i
          ir=j-1
        else
          istack(jstack)=j-1
          istack(jstack-1)=l
          l=i
        endif
      endif
      goto 1
      END

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


MODULE point_module
IMPLICIT NONE

! Type definition
TYPE :: point
   REAL :: x
   REAL :: y
CONTAINS
   PROCEDURE,PASS :: add
END TYPE

CONTAINS

   TYPE(point) FUNCTION add(this, another_point)
   CLASS(point) :: this, another_point
   add%x = this%x + another_point%x
   add%y = this%y + another_point%y
   END FUNCTION add

END MODULE point_module


	integer function oil_spill_fill_nsew(datafield,ni,nj,mask)
        integer maskout(-1:ni+2,-1:nj+2)
        integer fieldout(-1:ni+2,-1:nj+2)
        maskout=0
        do j=1,nj  ! copy input array into center of output array
        do i=1,ni
          maskout(i,j)=mask(i,j)
          fieldout(i,j)=datafield(i,j)
        enddo
        enddo
        do i=1,ni    ! apply NORTH-SOUTH polar continuity rule
          ii=i+ni/2
          if(ii.gt.ni) ii=ii-ni

          maskout(i,   0) = maskout(ii,   1)
          maskout(i,  -1) = maskout(ii,   2)
          maskout(i,nj+1) = maskout(ii,  nj)
          maskout(i,nj+2) = maskout(ii,nj-1)

          fieldout(i,   0) = fieldout(ii,   1)
          fieldout(i,  -1) = fieldout(ii,   2)
          fieldout(i,nj+1) = fieldout(ii,  nj)
          fieldout(i,nj+2) = fieldout(ii,nj-1)
        enddo
        do j=-1,nj+2   ! apply EAST-WEST continuity rule

          maskout(   0,j) = maskout(  ni,j)
          maskout(  -1,j) = maskout(ni-1,j)
          maskout(ni+1,j) = maskout(   1,j)
          maskout(ni+2,j) = maskout(   2,j)

          fieldout(   0,j) = fieldout(  ni,j)
          fieldout(  -1,j) = fieldout(ni-1,j)
          fieldout(ni+1,j) = fieldout(   1,j)
          fieldout(ni+2,j) = fieldout(   2,j)
        enddo
        oil_spill_fill_ew=oil_spill_fill(fieldout,ni+4,nj+4,maskout)
        return
        end
	integer function oil_spill_fill(datafield,ni,nj,mask)
!
! fill array datafield that has holes (missing values) using the valid values
! array mask tells whether data points are valid or missing
! mask(i,J)==0 means datafield(i,j) is missing (hole)
!
! Missing values are filled using adjacent data points.
! In order to fill missing value datafield(i,j), it is necessary
! to have at least TWO valid (non missing) adjacent datapoints.
! The number of adjacent point is usually 8, except if point (i,j)
! lies on the boundary (first/last row or first/last column)
! This means that multiple filling passes will have to be performed
! in order to fill all missing values.
! Values filled during pass N can be used to compute fill values
! during subsequent passes (but not during pass N)
!
! The function returns the number of points it has not been able to fill.
! If a pass was unable to fill any point while there were still holes in the
! array, the function quits before entering an endless loop.
!
!         (i-1,j+1)        (i  ,J+1)      (i+1,j+1)
!
!
!         (i-1,j  )        (i  ,J  )      (i+1,j  )
!                        point to fill
!
!         (i-1,j-1)        (i  ,J-1)      (i+1,j-1)
!
	implicit none

	integer ni,nj
	real, dimension(ni,nj) :: datafield
	integer, dimension(ni,nj) :: mask

	integer, dimension(ni,nj,0:1) :: tempmask
	integer inmask,outmask
	integer i,j,ii,jj
	integer not_filled, neighbors, not_filled_on_last_pass
	real *8 sum, sumweight, weight
        integer, parameter :: R=1

	tempmask(:,:,0)=mask
	inmask=0
	outmask=1-inmask  ! if inmask is 0, then outmask is 1 and vice versa
	not_filled=ni*nj-1
	not_filled_on_last_pass=ni*nj

	do while(not_filled.ne.0)   ! loop until there are no missing values left
	not_filled_on_last_pass=not_filled
	not_filled=0
	do j=1,nj  ! loop over input grid
	do i=1,ni
	tempmask(i,j,outmask)=tempmask(i,j,inmask)
	if(tempmask(i,j,inmask).ne.0) cycle ! this point exists, no need to fill
	!    if(tempmask(i,j,inmask).ne.0) print *,'point',i,j,' exists'
	sum=0.0
	sumweight=0.0
	neighbors=0
	do jj=max(1,j-R),min(nj,j+R)              ! scan neighbors (with protection for border)
	do ii=max(1,i-R),min(ni,i+R)
	if(ii.ne.i .or. jj.ne.j) then           ! ignore the point itself
		if(tempmask(ii,jj,inmask).ne.0) then  !  point is not missing in grid
		weight=1.0/sqrt( 1.0*((ii-i)*(ii-i) + (jj-j)*(jj-j)) )   ! weight is inverse of distance in grid points
		sumweight=sumweight+weight          ! sum of weights
		sum=sum+weight*datafield(ii,jj)         ! weighted sum
		neighbors=neighbors+1
		endif
	endif
	enddo
	enddo
	if(neighbors .gt. 1) then     ! we need at least two existing neighboring points
	datafield(i,j)=sum/sumweight    ! weighted average of existing neighbors
	tempmask(i,j,outmask)=1     ! this point now exists (for next pass)
	else
	not_filled=not_filled+1             ! this point could not be filled
	endif
10 	continue
	enddo
	enddo
	inmask=outmask    ! swap inmask and outmask (this output is the input for next pass)
	outmask=1-inmask  ! if inmask is 0, then outmask is 1 and vice versa

	print *,'not_filled=',not_filled
	if(not_filled.eq.not_filled_on_last_pass) exit   ! we are stuck, no missing values got filled on this pass
	enddo

	oil_spill_fill=not_filled   ! return number of holes left

101 	format(8f6.3)
	return
	end


MODULE mod_constants
    IMPLICIT NONE

    INTEGER, PARAMETER :: sp_kind   = kind(1.0)  !< single precision
    INTEGER, PARAMETER :: dp_kind   = kind(1.d0) !< double precision
    INTEGER, PARAMETER :: sh_kind   = selected_int_kind(2)
    INTEGER, PARAMETER :: int_kind  = selected_int_kind(4)
    INTEGER, PARAMETER :: long_kind  = selected_int_kind(8)

    ! ratio of specific heats
    REAL(dp_kind), PARAMETER :: gamma = 1.4d00

    ! index of variables in the solution matrix
    INTEGER(sh_kind), PARAMETER :: i_rho   =  1
    INTEGER(sh_kind), PARAMETER :: i_u     =  2
    INTEGER(sh_kind), PARAMETER :: i_v     =  3
    INTEGER(sh_kind), PARAMETER :: i_P     =  4
    INTEGER(sh_kind), PARAMETER :: i_mx    =  5  ! x momentum
    INTEGER(sh_kind), PARAMETER :: i_my    =  6  ! y momentum
    INTEGER(sh_kind), PARAMETER :: i_eT    =  7  ! total energy
    INTEGER(sh_kind), PARAMETER :: i_e     =  8  ! internal energy
    INTEGER(sh_kind), PARAMETER :: i_c     =  9  ! sound speed
    INTEGER(sh_kind), PARAMETER :: i_schl  =  10
    !    INTEGER(kind=4), PARAMETER :: i_e    = 1

    ! indexes of conservative variables
    INTEGER(sh_kind), PARAMETER, DIMENSION(4) :: i_cons = (/i_rho, i_mx, i_my, i_eT/)

    ! number of variables
    INTEGER(sh_kind), PARAMETER :: nvar      = 10

    ! geometric values
    INTEGER :: num_cells,half_cells  ! number of cells per side: total num (n x n)

    REAL(dp_kind) :: Dx, Dy                   ! cell size

    REAL(dp_kind), ALLOCATABLE, DIMENSION(:,:,:) :: x,y,z

    REAL(dp_kind) :: HALF = 0.5d0
    REAL(dp_kind) :: ONE = 1.0d0

END MODULE mod_constants


module load_spec2_mod
  implicit none
  save
  contains

    subroutine load_spec2(filename,spectrum,unit_to_cm)
      use get_dim_mod
      use load_mod
      use interpolate_mod
      use grid_mod, ONLY: nwl
      !--------------------------------------------------------------------
      ! loads a spectrum and interpolates BETWEEN 280-nwl in bins of 1nm
      ! if reading from spec is less than zero we return 0
      ! OPTIONAL ARGUMENT convert_to_cm.....
      ! nwl, l(i) needs to be moduled
      !-------------------------------------------------------------------
      implicit none

      character*30, intent(in):: filename
      real*8, intent(in):: unit_to_cm
      integer :: length
      real*8, allocatable ::raw_data(:,:)
      real*8, intent(out) :: spectrum(nwl)
      real*8 :: l(nwl)
      real*8 :: interpol
      integer :: i

      !load in the raw data from the file
      call get_dim(filename,length)
      allocate(raw_data(2,length))
      call load(filename,length,raw_data)

      do i=1,nwl
           l(i)=280.+real(i) -1.
      enddo

      do i=1,nwl
         call interpolate(l(i),raw_data,interpol)
            if (interpol.lt.0.00) then
              interpol=0.00
              end if
              spectrum(i)=interpol*unit_to_cm

              enddo

      !      !deallocate(spectrum) ??
      return
    end subroutine load_spec2
end module load_spec2_mod


PROGRAM maswfa

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

!     ============================================================
!     Purpose: This program computes the prolate and oblate
!     spheroidal angular functions of the first
!     kind and their derivatives using subroutine ASWFA
!     Input :  m  --- Mode parameter,  m = 0,1,2,...
!     n  --- Mode parameter,  n = m,m+1,...
!     c  --- Spheroidal parameter
!     x  --- Argument of angular function, |x| < 1.0
!     KD --- Function code
!     KD=1 for prolate;  KD=-1 for oblate
!     cv --- Characteristic value
!     Output:  S1F --- Angular function of the first kind
!     S1D --- Derivative of the angular function of
!     the first kind
!     Examples:
!     KD = 1, m = 2, n = 3, c = 3.0 and cv = 14.8277782138
!     x         Smn(c,x)            Smn'(c,x)
!     --------------------------------------------
!     0.2      .28261309D+01       .12418631D+02
!     0.5      .49938554D+01       .92761604D+00
!     0.8      .31693975D+01      -.12646552D+02

!     KD =-1, m = 2, n = 3, c = 3.0 and cv = 8.8093939208
!     x         Smn(-ic,x)         Smn'(-ic,x)
!     --------------------------------------------
!     0.2      .29417848D+01       .14106305D+02
!     0.5      .64138827D+01       .76007194D+01
!     0.8      .60069873D+01      -.14387479D+02
!     ============================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION eg(200)
WRITE(*,*)'Please enter KD, m, n and c '
!     READ(*,*)KD,M,N,C
m=2
n=3
c=3.0
kd=1
WRITE(*,10)kd,m,n,c
CALL segv(m,n,c,kd,cv,eg)
WRITE(*,20)cv
WRITE(*,*)
IF (kd == 1 ) THEN
  WRITE(*,*)'    x         Smn(c,x)            Smn''(C,X)'
ELSE IF (kd == -1) THEN
  WRITE(*,*)'    x         Smn(-ic,x)         Smn''(-IC,X)'
END IF
WRITE(*,*)'  --------------------------------------------'
DO  i=0,20
  x=-1.0D0+0.1D0*i
  IF (i == 0)  x=0.0D0
  IF (i == 20) x=1.0D0
  CALL aswfa(m,n,c,x,kd,cv,s1f,s1d)
  WRITE(*,30)x,s1f,s1d
END DO
10   FORMAT(1X,'KD ='i2,', ','m =',i2,', ','n =',i2,', ','c =',f5.1)
20   FORMAT(1X,' cv =',f18.10)
30   FORMAT(1X,f5.1,2D20.8)
END PROGRAM maswfa

SUBROUTINE aswfa(m,n,c,x,kd,cv,s1f,s1d)

!     ===========================================================
!     Purpose: Compute the prolate and oblate spheroidal angular
!     functions of the first kind and their derivatives
!     Input :  m  --- Mode parameter,  m = 0,1,2,...
!     n  --- Mode parameter,  n = m,m+1,...
!     c  --- Spheroidal parameter
!     x  --- Argument of angular function, |x| < 1.0
!     KD --- Function code
!     KD=1 for prolate;  KD=-1 for oblate
!     cv --- Characteristic value
!     Output:  S1F --- Angular function of the first kind
!     S1D --- Derivative of the angular function of
!     the first kind
!     Routine called:
!     SCKB for computing expansion coefficients ck
!     ===========================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN OUT)         :: c
DOUBLE PRECISION, INTENT(IN OUT)         :: x
INTEGER, INTENT(IN OUT)                  :: kd
DOUBLE PRECISION, INTENT(IN OUT)         :: cv
DOUBLE PRECISION, INTENT(OUT)            :: s1f
DOUBLE PRECISION, INTENT(OUT)            :: s1d
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION ck(200),df(200)

eps=1.0D-14
x0=x
x=DABS(x)
ip=1
IF (n-m == 2*INT((n-m)/2)) ip=0
nm=40+INT((n-m)/2+c)
nm2=nm/2-2
CALL sdmn(m,n,c,cv,kd,df)
CALL sckb(m,n,c,df,ck)
x1=1.0D0-x*x
IF (m == 0.AND.x1 == 0.0D0) THEN
  a0=1.0D0
ELSE
  a0=x1**(0.5D0*m)
END IF
su1=ck(1)
DO  k=1,nm2
  r=ck(k+1)*x1**k
  su1=su1+r
  IF (k >= 10.AND.DABS(r/su1) < eps) EXIT
END DO
15   s1f=a0*x**ip*su1
IF (x == 1.0D0) THEN
  IF (m == 0) s1d=ip*ck(1)-2.0D0*ck(2)
  IF (m == 1) s1d=-1.0D+100
  IF (m == 2) s1d=-2.0D0*ck(1)
  IF (m >= 3) s1d=0.0D0
ELSE
  d0=ip-m/x1*x**(ip+1.0D0)
  d1=-2.0D0*a0*x**(ip+1.0D0)
  su2=ck(2)
  DO  k=2,nm2
    r=k*ck(k+1)*x1**(k-1.0D0)
    su2=su2+r
    IF (k >= 10.AND.DABS(r/su2) < eps) EXIT
  END DO
  25    s1d=d0*a0*su1+d1*su2
END IF
IF (x0 < 0.0D0.AND.ip == 0) s1d=-s1d
IF (x0 < 0.0D0.AND.ip == 1) s1f=-s1f
x=x0
RETURN
END SUBROUTINE aswfa

SUBROUTINE sckb(m,n,c,df,ck)

!     ======================================================
!     Purpose: Compute the expansion coefficients of the
!     prolate and oblate spheroidal functions
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     DF(k) --- Expansion coefficients dk
!     Output:  CK(k) --- Expansion coefficients ck;
!     CK(1), CK(2), ... correspond to
!     c0, c2, ...
!     ======================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN OUT)         :: c
DOUBLE PRECISION, INTENT(IN)             :: df(200)
DOUBLE PRECISION, INTENT(OUT)            :: ck(200)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

sw=0.0
IF (c <= 1.0D-10) c=1.0D-10
nm=25+INT(0.5*(n-m)+c)
ip=1
IF (n-m == 2*INT((n-m)/2)) ip=0
reg=1.0D0
IF (m+nm > 80) reg=1.0D-200
fac=-0.5D0**m
DO  k=0,nm-1
  fac=-fac
  i1=2*k+ip+1
  r=reg
  DO  i=i1,i1+2*m-1
    r=r*i
  END DO
  i2=k+m+ip
  DO  i=i2,i2+k-1
    r=r*(i+0.5D0)
  END DO
  sum=r*df(k+1)
  DO  i=k+1,nm
    d1=2.0D0*i+ip
    d2=2.0D0*m+d1
    d3=i+m+ip-0.5D0
    r=r*d2*(d2-1.0D0)*i*(d3+k)/(d1*(d1-1.0D0)*(i-k)*d3)
    sum=sum+r*df(i+1)
    IF (DABS(sw-sum) < DABS(sum)*1.0D-14) EXIT
    sw=sum
  END DO
  25    r1=reg
  DO  i=2,m+k
    r1=r1*i
  END DO
  ck(k+1)=fac*sum/r1
END DO
RETURN
END SUBROUTINE sckb

SUBROUTINE sdmn(m,n,c,cv,kd,df)

!     =====================================================
!     Purpose: Compute the expansion coefficients of the
!     prolate and oblate spheroidal functions, dk
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     cv --- Characteristic value
!     KD --- Function code
!     KD=1 for prolate; KD=-1 for oblate
!     Output:  DF(k) --- Expansion coefficients dk;
!     DF(1), DF(2), ... correspond to
!     d0, d2, ... for even n-m and d1,
!     d3, ... for odd n-m
!     =====================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: c
DOUBLE PRECISION, INTENT(IN OUT)         :: cv
INTEGER, INTENT(IN)                      :: kd
DOUBLE PRECISION, INTENT(OUT)            :: df(200)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION a(200),d(200),g(200)

sw=0.0
fl=0.0
nm=25+INT(0.5*(n-m)+c)
IF (c < 1.0D-10) THEN
  DO  i=1,nm
    df(i)=0D0
  END DO
  df((n-m)/2+1)=1.0D0
  RETURN
END IF
cs=c*c*kd
ip=1
IF (n-m == 2*INT((n-m)/2)) ip=0
DO  i=1,nm+2
  IF (ip == 0) k=2*(i-1)
  IF (ip == 1) k=2*i-1
  dk0=m+k
  dk1=m+k+1
  dk2=2*(m+k)
  d2k=2*m+k
  a(i)=(d2k+2.0)*(d2k+1.0)/((dk2+3.0)*(dk2+5.0))*cs
  d(i)=dk0*dk1+(2.0*dk0*dk1-2.0*m*m-1.0)/((dk2-1.0) *(dk2+3.0))*cs
  g(i)=k*(k-1.0)/((dk2-3.0)*(dk2-1.0))*cs
END DO
fs=1.0D0
f1=0.0D0
f0=1.0D-100
kb=0
df(nm+1)=0.0D0
DO  k=nm,1,-1
  f=-((d(k+1)-cv)*f0+a(k+1)*f1)/g(k+1)
  IF (DABS(f) > DABS(df(k+1))) THEN
    df(k)=f
    f1=f0
    f0=f
    IF (DABS(f) > 1.0D+100) THEN
      DO  k1=k,nm
        df(k1)=df(k1)*1.0D-100
      END DO
      f1=f1*1.0D-100
      f0=f0*1.0D-100
    END IF
  ELSE
    kb=k
    fl=df(k+1)
    f1=1.0D-100
    f2=-(d(1)-cv)/a(1)*f1
    df(1)=f1
    IF (kb == 1) THEN
      fs=f2
    ELSE IF (kb == 2) THEN
      df(2)=f2
      fs=-((d(2)-cv)*f2+g(2)*f1)/a(2)
    ELSE
      df(2)=f2
      DO  j=3,kb+1
        f=-((d(j-1)-cv)*f2+g(j-1)*f1)/a(j-1)
        IF (j <= kb) df(j)=f
        IF (DABS(f) > 1.0D+100) THEN
          DO  k1=1,j
            df(k1)=df(k1)*1.0D-100
          END DO
          f=f*1.0D-100
          f2=f2*1.0D-100
        END IF
        f1=f2
        f2=f
      END DO
      fs=f
    END IF
    EXIT
  END IF
END DO
35   su1=0.0D0
r1=1.0D0
DO  j=m+ip+1,2*(m+ip)
  r1=r1*j
END DO
su1=df(1)*r1
DO  k=2,kb
  r1=-r1*(k+m+ip-1.5D0)/(k-1.0D0)
  su1=su1+r1*df(k)
END DO
su2=0.0D0
DO  k=kb+1,nm
  IF (k /= 1) r1=-r1*(k+m+ip-1.5D0)/(k-1.0D0)
  su2=su2+r1*df(k)
  IF (DABS(sw-su2) < DABS(su2)*1.0D-14) EXIT
  sw=su2
END DO
55   r3=1.0D0
DO  j=1,(m+n+ip)/2
  r3=r3*(j+0.5D0*(n+m+ip))
END DO
r4=1.0D0
DO  j=1,(n-m-ip)/2
  r4=-4.0D0*r4*j
END DO
s0=r3/(fl*(su1/fs)+su2)/r4
DO  k=1,kb
  df(k)=fl/fs*s0*df(k)
END DO
DO  k=kb+1,nm
  df(k)=s0*df(k)
END DO
RETURN
END SUBROUTINE sdmn

SUBROUTINE segv(m,n,c,kd,cv,eg)

!     =========================================================
!     Purpose: Compute the characteristic values of spheroidal
!     wave functions
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     KD --- Function code
!     KD=1 for Prolate; KD=-1 for Oblate
!     Output:  CV --- Characteristic value for given m, n and c
!     EG(L) --- Characteristic value for mode m and n'
!     ( L = n' - m + 1 )
!     =========================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: c
INTEGER, INTENT(IN)                      :: kd
DOUBLE PRECISION, INTENT(OUT)            :: cv
DOUBLE PRECISION, INTENT(OUT)            :: eg(200)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION b(100),h(100),d(300),e(300),f(300),cv0(100),a(300) ,g(300)

IF (c < 1.0D-10) THEN
  DO  i=1,n
    eg(i)=(i+m)*(i+m-1.0D0)
  END DO
ELSE
  icm=INT((n-m+2)/2)
  nm=10+INT(0.5*(n-m)+c)
  cs=c*c*kd
  DO  l=0,1
    DO  i=1,nm
      IF (l == 0) k=2*(i-1)
      IF (l == 1) k=2*i-1
      dk0=m+k
      dk1=m+k+1
      dk2=2*(m+k)
      d2k=2*m+k
      a(i)=(d2k+2.0)*(d2k+1.0)/((dk2+3.0)*(dk2+5.0))*cs
      d(i)=dk0*dk1+(2.0*dk0*dk1-2.0*m*m-1.0)/((dk2-1.0) *(dk2+3.0))*cs
      g(i)=k*(k-1.0)/((dk2-3.0)*(dk2-1.0))*cs
    END DO
    DO  k=2,nm
      e(k)=DSQRT(a(k-1)*g(k))
      f(k)=e(k)*e(k)
    END DO
    f(1)=0.0D0
    e(1)=0.0D0
    xa=d(nm)+DABS(e(nm))
    xb=d(nm)-DABS(e(nm))
    nm1=nm-1
    DO  i=1,nm1
      t=DABS(e(i))+DABS(e(i+1))
      t1=d(i)+t
      IF (xa < t1) xa=t1
      t1=d(i)-t
      IF (t1 < xb) xb=t1
    END DO
    DO  i=1,icm
      b(i)=xa
      h(i)=xb
    END DO
    DO  k=1,icm
      DO  k1=k,icm
        IF (b(k1) < b(k)) THEN
          b(k)=b(k1)
          EXIT
        END IF
      END DO
      35      IF (k /= 1.AND.h(k) < h(k-1)) h(k)=h(k-1)
      DO WHILE (1==1)
        40       x1=(b(k)+h(k))/2.0D0
        cv0(k)=x1
        IF (DABS((b(k)-h(k))/x1) < 1.0D-14) EXIT
        j=0
        s=1.0D0
        DO  i=1,nm
          IF (s == 0.0D0) s=s+1.0D-30
          t=f(i)/s
          s=d(i)-t-x1
          IF (s < 0.0D0) j=j+1
        END DO
        IF (j < k) THEN
          h(k)=x1
        ELSE
          b(k)=x1
          IF (j >= icm) THEN
            b(icm)=x1
          ELSE
            IF (h(j+1) < x1) h(j+1)=x1
            IF (x1 < b(j)) b(j)=x1
          END IF
        END IF
      END DO
      50      cv0(k)=x1
      IF (l == 0) eg(2*k-1)=cv0(k)
      IF (l == 1) eg(2*k)=cv0(k)
    END DO
  END DO
END IF
70   cv=eg(n-m+1)
RETURN
END SUBROUTINE segv


#INCLUDE 'MR_H_PROGRAM_METADATA.H'
!***********************************************************************************************************************************
! UNIT:
!
!  (PROGRAM)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  PROGRAM MR_REDS_AVERAGE

    USE MR_0_SKIP_MODE

    USE MR_ERRORS_FILE_MANIPULATE

    USE MR_MOD_CTRL_RETRY_CREATING_FILES

    USE MR_KINDS

    USE MR_DEF_TIMING , ONLY : DT
    USE MR_DEF_CONSTS_N_REF_PARS , ONLY : COR

    USE MR_MOD_INIT_PRJ
    USE MR_MOD_INIT_RANKS
    USE MR_MOD_INIT_RANKS_PLUS
    USE MR_MOD_INIT_SLOPE

    USE MR_MOD_MALLOC_GRID_SYS
    USE MR_MOD_MALLOC_CURVED_GEOS
    USE MR_MOD_MALLOC_FIELD_VARS
    USE MR_MOD_MALLOC_FIELD_VARS_AVERAGE
    USE MR_MOD_MALLOC_ACTIVITY

    USE MR_MOD_INIT_CONSTS_N_REF_PARS
    USE MR_MOD_INIT_GRID_SYS
    USE MR_MOD_INIT_CURVED_GEOS

    USE MR_MOD_INIT_OUTPUT_AVERAGE

    USE MR_MOD_GET_TIMES
    USE MR_MOD_INPUT
    USE MR_MOD_UPDT_FIELD_VARS_AVERAGE
    USE MR_MOD_OUTPUT_AVERAGE

    IMPLICIT NONE

    CHARACTER( 2**08 ) :: FILE_XMDF
    CHARACTER( 2**08 ) :: FILE_PRJ
    CHARACTER( 2**08 ) :: FILE_AVERAGE

    INTEGER(TSID_KIND) :: NTSS
    INTEGER(TSID_KIND) :: ITS

    REAL   (TMRD_KIND) :: T

    INTEGER            :: ERROR
    CHARACTER( 2**10 ) :: ERRMSG

   !BLOCK
  ! MANAGE THE VERSION
    WRITE(*,'( A ,"_Average by ", A ," [ver.", A ,"]")') TRIM(INNERNAME) , TRIM(CONTRIBUTOR) , TRIM(SEMVER)
   !END BLOCK

  ! GET COMMAND ARGUMENTS FROM COMMAND LINE
  ! AND SET OUTPUT FILES'S PATH\NAMES
    CALL MR_INIT_COMMAND_LINE( ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
      WRITE(*,'(/,"PLEASE RUN ", A ," with the following command arguments:")') TRIM(INNERNAME)
      WRITE(*,'(  "  1- (non-optional)")')
      WRITE(*,'(  "      Mesh file''s path\name, in XMDF format;")')
      WRITE(*,'(  "  2- (optional)")')
      WRITE(*,'(  "      Project file''s path\name, which specifies the running parameters, in TEXT format;")')
      WRITE(*,'(  "    Or,")')
      WRITE(*,'(  "      If omitted, default values will be assigned to these parameters;")')
      WRITE(*,'(  "  3- (optional)")')
      WRITE(*,'(  "      An alternative option, which tells the program to run on skip mode so that all")')
      WRITE(*,'(  "    the runtime inputs from user can be skipped, with the following format:")')
      WRITE(*,'(  "        --skip")')
      WRITE(*,'(  "      Careful with this option and make sure you really know what will be skipped;")')
      WRITE(*,'(  "    Or,")')
      WRITE(*,'(  "      If omitted, the program will by default run on non-skip mode;")')
      WRITE(*,'(  "Note,")')
      WRITE(*,'(  "  ALL the arguments 1--3 MUST be given in sequence.")')
      STOP
    END IF
  ! CREATE OUTPUT FILES
    CALL MR_INIT_OUTPUT_FILES( ERROR , ERRMSG , OVERWRITE=.FALSE. )
    IF( ERROR == ERROR_CANNOT_CREATE_NEW_FILE ) THEN
      WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
      WRITE(*,'(/,"Files with the same names may already exist.")')
      CALL MR_CTRL_RETRY_CREATING_FILES
      CALL MR_INIT_OUTPUT_FILES( ERROR , ERRMSG , OVERWRITE=.TRUE. )
      IF( ERROR < 0 ) THEN
        WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
        STOP
      END IF
    ELSE IF( ERROR < 0 ) THEN
      WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
      STOP
    END IF

    WRITE(*,'( )')

    WRITE(*,'("Initialize project... ", $ )')
    IF( FILE_PRJ /= "" ) THEN
      CALL MR_INIT_PRJ( FILE_PRJ , ERROR , ERRMSG )
      IF( ERROR < 0 ) THEN
        WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
        STOP
      END IF
    END IF
    CALL MR_INIT_RANKS( FILE_XMDF , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
      STOP
    END IF
    CALL MR_INIT_RANKS_PLUS( FILE_XMDF , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
      STOP
    END IF
    CALL MR_INIT_SLOPE( FILE_XMDF , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
      STOP
    END IF
    WRITE(*,'("Done!")')

    WRITE(*,'( )')

    WRITE(*,'(2X,"Allocate memories... ", $ )')
    CALL MR_MALLOC_GRID_SYS
    CALL MR_MALLOC_CURVED_GEOS
    CALL MR_MALLOC_FIELD_VARS
    CALL MR_MALLOC_FIELD_VARS_AVERAGE
    CALL MR_MALLOC_ACTIVITY
    WRITE(*,'("Done!")')

    WRITE(*,'( )')

    WRITE(*,'("Initialize constants and reference parameters... ", $ )')
    CALL MR_INIT_CONSTS_N_REF_PARS( ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
      STOP
    END IF
    WRITE(*,'("Done!")')

    WRITE(*,'("Initialize grid system... ", $ )')
    CALL MR_INIT_GRID_SYS( FILE_XMDF , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
      STOP
    END IF
    WRITE(*,'("Done!")')

    WRITE(*,'("Initialize curved geometry... ", $ )')
    CALL MR_INIT_CURVED_GEOS( FILE_XMDF , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
      STOP
    END IF
    WRITE(*,'("Done!")')

    WRITE(*,'("Initialize output... ", $ )')
    CALL MR_INIT_OUTPUT_AVERAGE( FILE_AVERAGE , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      WRITE(*,'(/,2X, A ,"!")') TRIM(ERRMSG)
      STOP
    END IF
    WRITE(*,'("Done!")')

    WRITE(*,'( )')

    WRITE(*,'(8X,"Average...  0.00%", A , $ )') ACHAR(13)

  ! GET NTSS
    CALL MR_GET_NTSS( FILE_XMDF , NTSS , ERROR , ERRMSG )
    IF( ERROR < 0 ) THEN
      WRITE(*,'(//,2X, A ,"!")') TRIM(ERRMSG)
      STOP
    END IF

    DT = DT * COR   ! NONDIMENSIONALIZE DT

    DO ITS = 0 , NTSS

    ! GET T OF ITS
      CALL MR_GET_T_ITS( FILE_XMDF , NTSS , ITS , T , ERROR , ERRMSG )
      IF( ERROR < 0 ) THEN
        WRITE(*,'(//,2X, A ,"!")') TRIM(ERRMSG)
        STOP
      END IF

      CALL MR_INPUT( FILE_XMDF , ITS , ERROR , ERRMSG )
      IF( ERROR < 0 ) THEN
        WRITE(*,'(//,2X, A ,"!")') TRIM(ERRMSG)
        STOP
      END IF

      CALL MR_UPDT_FIELD_VARS_AVERAGE

      CALL MR_OUTPUT_AVERAGE( FILE_AVERAGE , T , ERROR , ERRMSG )
      IF( ERROR < 0 ) THEN
        WRITE(*,'(//,2X, A ,"!")') TRIM(ERRMSG)
        STOP
      END IF

      WRITE(*,'(8X,"Average...",F6.2,"%", A , $ )') REAL(ITS+1)/REAL(NTSS+1)*100.00 , ACHAR(13)

    END DO

    WRITE(*,'(8X,"Average... Done! ")')

    WRITE(*,'(/,"The result has been written into the file:",/,4X, A )') TRIM(FILE_AVERAGE)

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_INIT_COMMAND_LINE( ERROR , ERRMSG )

    USE MR_MOD_OPEN_N_CLOSE_FILE_DEFAULT
    USE MR_MOD_OPEN_N_CLOSE_FILE_XMDF

    USE MR_MOD_OPERATOR_CHAR_STRING

    IMPLICIT NONE

    CHARACTER( 2**08 )               :: CHAR_ARGUMENT
    CHARACTER( 2**03 )               :: I_ARG_CHAR
    INTEGER                          :: I_ARG

    INTEGER                          :: FILE_ID

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    ERRMSG = ""

  ! HELP DETECT
    IF( COMMAND_ARGUMENT_COUNT() == 1 ) THEN
      CALL GET_COMMAND_ARGUMENT( 1 , CHAR_ARGUMENT , STATUS=ERROR )
      IF( ERROR /= 0 ) THEN
        ERROR = - ABS(ERROR)
        ERRMSG = "Error in getting command arguments"
        RETURN
      ELSE
        SELECT CASE( .MRCHARUPPER.(TRIM(CHAR_ARGUMENT)) )
        CASE( "--HELP" , "-HELP" , "--H" , "-H" )
          ERROR = - 1
          ERRMSG = "Help information is displayed as below"
          RETURN
        END SELECT
      END IF
    END IF

    I_ARG = 0

    I_ARG = I_ARG + 1
    IF( COMMAND_ARGUMENT_COUNT() < I_ARG ) THEN
      ERROR = - 1
      ERRMSG = "Not enough command arguments"
      RETURN
    ELSE
      WRITE( I_ARG_CHAR , '(I<LEN(I_ARG_CHAR)>)' ) I_ARG
    ! GET XMDF FILE'S PATH\NAME
      CALL GET_COMMAND_ARGUMENT( I_ARG , FILE_XMDF , STATUS=ERROR )
      IF( ERROR == - 1 ) THEN
        ERRMSG = "Mesh file's path\name too long!"
        RETURN
      ELSE IF( ERROR /= 0 ) THEN
        ERROR = - ABS(ERROR)
        ERRMSG = "Error in getting command argument no."//TRIM(ADJUSTL(I_ARG_CHAR))//" as mesh file"
        RETURN
      ELSE
      ! VERIFY XMDF FILE'S OPENING AND CLOSING
        CALL MR_OPEN_FILE_XMDF( FILE_XMDF , FILE_ID , ERROR , ERRMSG )
        IF( ERROR < 0 ) THEN
          ERRMSG = TRIM(ERRMSG)//" "//TRIM(FILE_XMDF)//" as mesh file"
          RETURN
        ELSE
          CALL MR_CLOSE_FILE_XMDF( FILE_ID , ERROR , ERRMSG )
          IF( ERROR < 0 ) THEN
            ERRMSG = TRIM(ERRMSG)//" "//TRIM(FILE_XMDF)
            RETURN
          END IF
        END IF
      END IF
    END IF

  ! SET AVERAGE FILE'S PATH\NAME
    FILE_AVERAGE = TRIM(FILE_XMDF)//".average.txt"

    I_ARG = I_ARG + 1
    IF( COMMAND_ARGUMENT_COUNT() < I_ARG ) THEN
     !BLOCK
    ! ASSIGN DEFAULT VALUES TO OPTIONAL ARGUMENTS
      FILE_PRJ = ""
     !END BLOCK
    ELSE
      WRITE( I_ARG_CHAR , '(I<LEN(I_ARG_CHAR)>)' ) I_ARG
    ! GET PROJECT FILE'S PATH\NAME
      CALL GET_COMMAND_ARGUMENT( I_ARG , CHAR_ARGUMENT , STATUS=ERROR )
      IF( ERROR /= 0 ) THEN
        ERROR = - ABS(ERROR)
        ERRMSG = "Error in getting command argument no."//TRIM(ADJUSTL(I_ARG_CHAR))
        RETURN
      ELSE IF( CHAR_ARGUMENT(1:2) == "--" ) THEN
       !BLOCK
        I_ARG = I_ARG - 1
      ! ASSIGN DEFAULT VALUES TO OPTIONAL ARGUMENTS
        FILE_PRJ = ""
       !END BLOCK
      ELSE
        FILE_PRJ = TRIM(CHAR_ARGUMENT)
      ! VERIFY PROJECT FILE'S OPENING AND CLOSING
        CALL MR_OPEN_FILE_DEFAULT( FILE_PRJ , FILE_ID , ERROR , ERRMSG )
        IF( ERROR < 0 ) THEN
          ERRMSG = TRIM(ERRMSG)//" "//TRIM(FILE_PRJ)//" as project file"
          RETURN
        ELSE
          CALL MR_CLOSE_FILE_DEFAULT( FILE_ID , ERROR , ERRMSG )
          IF( ERROR < 0 ) THEN
            ERRMSG = TRIM(ERRMSG)//" "//TRIM(FILE_PRJ)
            RETURN
          END IF
        END IF
      END IF
    END IF

    I_ARG = I_ARG + 1
  ! LOOP FOR ALTERNATIVE OPTIONS
    DO WHILE( I_ARG <= COMMAND_ARGUMENT_COUNT() )

      WRITE( I_ARG_CHAR , '(I<LEN(I_ARG_CHAR)>)' ) I_ARG
    ! GET ALTERNATIVE OPTION IDENTIFIER
      CALL GET_COMMAND_ARGUMENT( I_ARG , CHAR_ARGUMENT , STATUS=ERROR )
      IF( ERROR /= 0 ) THEN
        ERROR = - ABS(ERROR)
        ERRMSG = "Error in getting command argument no."//TRIM(ADJUSTL(I_ARG_CHAR))
        RETURN
      ELSE IF( CHAR_ARGUMENT(1:2) /= "--" ) THEN
        ERROR = - 1
        ERRMSG = "There ought to be an alternative option identifier started with ""--"" "   &
        //"in command argument no."//TRIM(ADJUSTL(I_ARG_CHAR))
        RETURN
      ELSE

        SELECT CASE( .MRCHARUPPER.(TRIM(CHAR_ARGUMENT)) )
        CASE( "--SKIP" )
          IF( RUN_ON_SKIP_MODE == .FALSE. ) THEN
            RUN_ON_SKIP_MODE = .TRUE.
          ELSE
            ERROR = - 1
            ERRMSG = TRIM(CHAR_ARGUMENT)//" has been specified more than once"
            RETURN
          END IF

          I_ARG = I_ARG + 1

        CASE DEFAULT
          ERROR = - 1
          ERRMSG = "Illegal alternative option identifier from command argument no."//TRIM(ADJUSTL(I_ARG_CHAR))
          RETURN
        END SELECT

      END IF

    END DO

  END SUBROUTINE MR_INIT_COMMAND_LINE

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_INIT_OUTPUT_FILES( ERROR , ERRMSG , OVERWRITE )

    USE MR_MOD_CREATE_FILE_DEFAULT

    IMPLICIT NONE

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    LOGICAL            , INTENT(IN ) :: OVERWRITE

    CALL MR_CREATE_FILE_DEFAULT( FILE_AVERAGE , ERROR , ERRMSG , OVERWRITE )
    IF( ERROR < 0 ) THEN
      ERRMSG = TRIM(ERRMSG)//" "//TRIM(FILE_AVERAGE)//" as output file"
      RETURN
    END IF

  END SUBROUTINE MR_INIT_OUTPUT_FILES

  END PROGRAM MR_REDS_AVERAGE


      subroutine gofr
     x  (dl_fmt,atnam1,atnam2,fname,title,name,mxrad,mxatms,natms,
     x  nconf,ncorr,isampl,numfil,rcut,avcell,rdf,xyz,vel,frc,cell,
     x  bcell,weight,chge,status)

c*********************************************************************
c
c     dl_poly program to calculate radial distribution function
c     for selected atoms
c
c     copyright daresbury laboratory 1999
c     author  w.smith march 1999
c
c*********************************************************************

      implicit none

      real*8 pi
      parameter (pi=3.1415926536d0)

      logical dl_fmt,all,new
      character*2 fnum
      character*40 fname
      character*80 title
      integer i,iconf,iflg,ii,imcon,isampl,j,jj,k,keytrj,last,matm1
      integer matm2,matms,mxatms,mxrad,natms,nconf,nstep,nta,ntb
      integer numfil,ncorr,status,kk
      character*8 atnam1,atnam2,name(mxatms)
      real*8 delr,det,f1,f2,rcut,rcut2,rmsx,rmsy,rmsz,rnorm
      real*8 rrr,rsq,timstp,uuu,volm,vvv,www,xxx,yyy,zzz,tcut
      real*8 rdf(mxrad),avcell(9),cell(9),bcell(10),weight(mxatms)
      real*8 xyz(3,mxatms),vel(3,mxatms),frc(3,mxatms),rcell(9)
      real*8 chge(mxatms)

      status=0

      call strcut(atnam1,8)
      call strcut(atnam2,8)
      call strcut(fname,40)

      all=(atnam1.eq."ALL".or.atnam2.eq."ALL".or.
     x     atnam1.eq."all".or.atnam2.eq."all")

      if(all)then

         atnam1="ALL"
         atnam2="ALL"

      endif

c     open report file

      open(9, file="RDFPRG.rep")

      write(9,'(a)')
     x  'Radial Distribution Function Program'

c     check rdf array dimension

      if(ncorr.gt.mxrad)then

        write(9,'(a,i5)')'Warning - RDF array dimension reset to',ncorr

      endif

      rcut2=rcut**2
      delr=rcut/dble(ncorr)

      write(9,'(a,a40)')'Label  of target HISTORY file : ',fname
      write(9,'(a,a8)')'Label  of first atom          : ',atnam1
      write(9,'(a,a8)')'Label  of second atom         : ',atnam2
      write(9,'(a,i6)')'Length of RDF arrays          : ',ncorr
      write(9,'(a,i6)')'Number of requested configs.  : ',nconf
      write(9,'(a,i6)')'Sampling interval             : ',isampl
      write(9,'(a,f6.3)')'Selected cutoff radius        : ',rcut
      write(9,'(a,f6.3)')'Bin width in RDF              : ',delr

c     initialise rdf array

      do i=1,mxrad

        rdf(i)=0.d0

      enddo

c     initialize average cell vectors

      do i=1,9

        avcell(i)=0.d0

      enddo

c     set default cell vectors

      do i=1,9
        cell(i)=0.d0
      enddo
      cell(1)=1.d0
      cell(5)=1.d0
      cell(9)=1.d0

      iflg=0
      keytrj=0
      new=.true.

      do iconf=0,nconf-1

        if(dl_fmt)then

          call hread
     x      (new,fname,title,name,iflg,imcon,keytrj,natms,nstep,timstp,
     x      cell,chge,weight,xyz,vel,frc,status)

        else

          call uread
     x      (new,fname,title,name,iflg,imcon,keytrj,natms,nstep,timstp,
     x      cell,chge,weight,xyz,vel,frc,status)

        endif

c     check specified cutoff

        if(iconf.eq.0)then

          call dcell(cell,bcell)

          tcut=0.5d0*min(bcell(7),bcell(8),bcell(9))
          if(rcut.gt.tcut)then

            rcut=tcut
            rcut2=rcut**2
            delr=rcut/dble(ncorr)
            write(9,'(a,f10.6)')'Warning - RDF  cutoff  reset to',tcut
            write(9,'(a,f10.6)')'Warning - RDF binwidth reset to',delr

          endif

        endif

        if(iflg.lt.0)go to 100

c     check boundary condition

        if(imcon.ge.1.and.imcon.le.3)then

          call invert(cell,rcell,det)

        else

          write(9,'(a)')
     x      'Error - incorrect boundary condition'
          status=-2
          return

        endif

        j=0
        do i=1,natms

          if(all.or.name(i).eq.atnam1.or.name(i).eq.atnam2)then

            j=j+1
            name(j)=name(i)
            xxx=xyz(1,i)
            yyy=xyz(2,i)
            zzz=xyz(3,i)
            xyz(1,j)=xxx*rcell(1)+yyy*rcell(4)+zzz*rcell(7)
            xyz(2,j)=xxx*rcell(2)+yyy*rcell(5)+zzz*rcell(8)
            xyz(3,j)=xxx*rcell(3)+yyy*rcell(6)+zzz*rcell(9)
          endif

        enddo

        matms=j

c     running average of cell vectors

        f1=(dble(iconf)/dble(iconf+1))
        f2=1.d0/dble(iconf+1)
        do i=1,9

          avcell(i)= f1*avcell(i)+f2*cell(i)

        enddo

        last=matms
        matm1=matms/2
        matm2=(matms-1)/2

        do kk=1,matm1

          if(kk.gt.matm2)last=matm1

          do ii=1,last

            jj=ii+kk
            if(jj.gt.matms)jj=jj-matms

            if(all.or.
     x        (atnam1.eq.name(ii).and.atnam2.eq.name(jj)).or.
     x        (atnam1.eq.name(jj).and.atnam2.eq.name(ii)))then

              uuu=xyz(1,ii)-xyz(1,jj)
              vvv=xyz(2,ii)-xyz(2,jj)
              www=xyz(3,ii)-xyz(3,jj)

              uuu=uuu-nint(uuu)
              vvv=vvv-nint(vvv)
              www=www-nint(www)

              rmsx=uuu*avcell(1)+vvv*avcell(4)+www*avcell(7)
              rmsy=uuu*avcell(2)+vvv*avcell(5)+www*avcell(8)
              rmsz=uuu*avcell(3)+vvv*avcell(6)+www*avcell(9)

              rsq=rmsx**2+rmsy**2+rmsz**2

              if(rsq.lt.rcut2)then

                k=int(sqrt(rsq)/delr)+1
                rdf(k)=rdf(k)+1.d0

              endif

            endif

          enddo

        enddo

      enddo

  100 continue

      if(iflg.lt.0)iconf=iconf-1
      write(9,'(a,i6)')'Number of configurations sampled: ',iconf

c     normalise and print radial distribution function

      volm=abs(avcell(1)*(avcell(5)*avcell(9)-avcell(6)*avcell(8))
     x  +avcell(4)*(avcell(3)*avcell(8)-avcell(2)*avcell(9))
     x  +avcell(7)*(avcell(2)*avcell(6)-avcell(3)*avcell(5)))

      if(all)then

         nta=matms
         ntb=matms

      else

         nta=0
         ntb=0
         do i=1,matms

            if(name(i).eq.atnam1)nta=nta+1
            if(name(i).eq.atnam2)ntb=ntb+1

         enddo

      endif

c     open the correlation data files

      numfil=numfil+1
      if(numfil.gt.99)then
        fnum="XX"
        close (88)
        open(88,file='RDFDAT.'//fnum)
      else
        write(fnum,'(i2.2)')numfil
        close(88)
        open(88,file='RDFDAT.'//fnum)
      endif

      write(88,'(a80)')title
      write(88,'(2i10)')1,ncorr

      if(atnam1.eq.atnam2) then

        rnorm=volm/(2.d0*pi*delr**3*dble(nta)*dble(nta)*dble(iconf))
        write(88,'(2a8,1pe14.6)')atnam1,atnam1,rcut

      else

        rnorm=volm/(4.d0*pi*delr**3*dble(nta)*dble(ntb)*dble(iconf))
        write(88,'(2a8,1pe14.6)')atnam1,atnam2,rcut

      endif

      do i=1,ncorr

        rdf(i)=rnorm*rdf(i)/((dble(i)-0.5d0)**2+1.d0/12.d0)

      enddo

      do i=1,ncorr

        rrr=delr*(dble(i)-0.5d0)
        write(88,'(1p,2e14.6)')rrr,rdf(i)

      enddo

      close(88)
      write(9,'(a)')'RDF file RDFDAT.'//fnum//' created'
      close(9)
      return
      end
      subroutine strcut(a,n)

      character*1 a(n)
      logical y

      y=.false.
      do i=1,n

        if(ichar(a(i)).eq.0)y=.true.
        if(y)a(i)=" "

      enddo
      return
      end
      subroutine hread
     x  (new,history,cfgname,name,iflg,imcon,keytrj,natms,
     x   nstep,tstep,cell,chge,weight,xyz,vel,frc,status)

c
c***********************************************************************
c
c     dl_poly subroutine for reading the formatted history file
c
c     copyright - daresbury laboratory 1996
c     author    - w. smith jan 1996.
c
c     single processor version
c
c***********************************************************************
c

      implicit none

      logical new

      character*80 cfgname
      character*40 history
      character*8 name(*),step

      integer iflg,imcon,keytrj,natms,nstep,status,nhist,ktrj,matms,i,j

      real*8 tstep,vx,vy,vz,fx,fy,fz

      real*8 cell(9)
      real*8 chge(*),weight(*)
      real*8 xyz(3,*),vel(3,*),frc(3,*)

      save ktrj
      data nhist/77/

      status=0

c     open history file if new job

      if(new)then

        open(nhist,file=history,status='old',err=100)

        read(nhist,'(a80)',err=200) cfgname
        write(*,'(a,a)')'History file header: ',cfgname
        read(nhist,'(2i10)',end=200) ktrj,imcon
        if(keytrj.gt.ktrj)then

          if(ktrj.eq.0)then

            write(*,'(a)')'Error - no velocities in file'
            status=-1
            close (nhist)
            new=.true.
            return

          endif
          if(keytrj.gt.1)then

            write(*,'(a)')'Error - no forces in file'
            status=-2
            close (nhist)
            new=.true.
            return

          endif
        endif

        new=.false.

      endif

      read(nhist,'(a8,4i10,f12.6)',end=200)
     x     step,nstep,matms,ktrj,imcon,tstep

      if(matms.gt.natms)then

        write(*,'(a)')'Error - too many atoms in MD cell'
        write(*,'(a,i6,a)')'File contains',matms,' atoms'
        status=-3
        close (nhist)
        new=.true.
        return

      endif

      natms=matms

      if(imcon.gt.0) then

         read(nhist,*,end=200) cell(1),cell(2),cell(3)
         read(nhist,*,end=200) cell(4),cell(5),cell(6)
         read(nhist,*,end=200) cell(7),cell(8),cell(9)

      endif

      do i = 1,natms

        read(nhist,'(a8,i10,2f12.6)',end=200)
     x    name(i),j,weight(i),chge(i)
        read(nhist,*,end=200) xyz(1,i),xyz(2,i),xyz(3,i)
        if(keytrj.ge.1)then
          read(nhist,*,end=200) vel(1,i),vel(2,i),vel(3,i)
        else if(ktrj.ge.1)then
          read(nhist,*,end=200) vx,vy,vz
        endif
        if(keytrj.ge.2)then
          read(nhist,*,end=200) frc(1,i),frc(2,i),frc(3,i)
        else if(ktrj.ge.2)then
          read(nhist,*,end=200) fx,fy,fz
        endif

      enddo

      if(iflg.lt.0)then

        close (nhist)
        new=.true.

      endif

      return

  100 continue

      write(*,'(a)')'Error - History file not found'
      status=-4
      return

  200 continue
      write(*,'(a)')'Warning - end of History file encountered'
      close (nhist)
      iflg=-1
      new=.true.

      return
      end


! Module for setting float precision and integer width program-wide
! Use the variables defined in ISO_FORTRAN_ENV, default compiler kinds, or
! custom kinds
! Intrinsic select_int_kind(r) should return the shortest integer kind that can
! accomodate an integer range from -10^r to 10^r
! Intrinsic select_real_kind(p,r) should return the shortest real kind that can
! accomodate a real number with decimal precision of at least p digits and an
! exponent range from 10^-r to 10^r. it is not necessary to specify r.

MODULE kindprecision
  USE ISO_FORTRAN_ENV
  IMPLICIT NONE
  INTEGER, PARAMETER                    :: default_int = kind(1)
  INTEGER, PARAMETER                    :: default_float = kind(1.0e0)
  INTEGER, PARAMETER                    :: default_double = kind(1.0d0)
  INTEGER, PARAMETER                    :: IP = default_int
  INTEGER, PARAMETER                    :: LI = selected_int_kind(10)
  INTEGER, PARAMETER                    :: SI = selected_int_kind(4)
  INTEGER, PARAMETER                    :: SP = default_float
  INTEGER, PARAMETER                    :: DP = default_double
  INTEGER, PARAMETER                    :: StrBuffLen = 256

CONTAINS

  SUBROUTINE print_precision_and_range_external(fd)
    IMPLICIT NONE
    INTEGER(kind=IP),INTENT(IN)         :: fd   ! Unit number/file descriptor
    INTEGER(kind=default_int)           :: aa
    INTEGER(kind=IP)                    :: ab
    INTEGER(kind=SI)                    :: ac
    INTEGER(kind=LI)                    :: ad
    REAL(kind=SP)                       :: fa
    REAL(kind=DP)                       :: da

    WRITE(fd,*) "Range of default integer kind is ",-HUGE(aa)-1," to ",HUGE(aa)
    WRITE(fd,*) "Range of selected integer kind is ",-HUGE(ab)-1," to ",HUGE(ab)
    WRITE(fd,*) "Range of selected short integer kind is ",-HUGE(ac)-1," to ",HUGE(ac)
    WRITE(fd,*) "Range of selected long integer kind is ",-HUGE(ad)-1," to ",HUGE(ad)
    WRITE(fd,'(A,I3,A,I5,A)') " Default single precision kind has ",PRECISION(1.0e0),&
                              " decimal digits of precision and an exponent range of +/-",&
                              RANGE(1.0e0)
    WRITE(fd,'(A,I3,A,I5,A)') " Selected single precision kind has ",PRECISION(fa),&
                              " decimal digits of precision and an exponent range of +/-",&
                              RANGE(fa)
    WRITE(fd,*) "The smallest single precision number is ",TINY(fa)
    WRITE(fd,*) "The largest single precision number is ",HUGE(fa)
    WRITE(fd,'(A,I3,A,I5,A)') " Default double precision kind has ",PRECISION(1.0d0),&
                              " decimal digits of precision and an exponent range of +/-",&
                              RANGE(1.0d0)
    WRITE(fd,'(A,I3,A,I5,A)') " Selected double precision kind has ",PRECISION(da),&
                              " decimal digits of precision and an exponent range of +/-",&
                              RANGE(da)
    WRITE(fd,*) "The smallest double precision number is ",TINY(da)
    WRITE(fd,*) "The largest double precision number is ",HUGE(da)
  END SUBROUTINE print_precision_and_range_external
END MODULE kindprecision


MODULE VCA_OMEGA
  !
  USE VCA_GF_SHARED
  USE VCA_BATH_FUNCTIONS
  USE VCA_GF_NORMAL
  USE SF_INTEGRATE
  USE SF_LINALG
  USE SF_IOTOOLS, only: splot
  !
  implicit none
  private

  public                                            :: sum_kmesh
  public                                            :: frequency_integration
  public                                            :: frequency_integration_finite_t

  public                                            :: reconstruct_g
  public                                            :: test_g

  !public                                            :: frequency_integration_sample

  !public                                            :: test_ksum

  complex(8),allocatable,dimension(:,:,:,:,:,:)     :: gfprime ![Nlat][Nlat][Nspin][Nspin][Norb][Norb]

  complex(8),allocatable,dimension(:,:,:,:,:,:,:)   :: gftest ![Nlat][Nlat][Nspin][Nspin][Norb][Norb]
  real(8)                                           :: integrationR

contains

  !+------------------------------------------------------------------+
  !PURPOSE  : Function that does the k-sum in the RBZ of the VCA variational function(al)
  !+------------------------------------------------------------------+
  function sum_kmesh(omega) result(out_1)
    integer                                                  :: ii,jj,kk
    complex(8)                                               :: omega
    real(8)                                                  :: out_1
    complex(8),allocatable,dimension(:,:)                    :: tmp_mat
    complex(8),allocatable,dimension(:,:,:,:,:,:)            :: deltamat
    !
    out_1=0.d0
    !
    !
    if(allocated(tmp_mat))deallocate(tmp_mat)
    if(allocated(gfprime))deallocate(gfprime)
    if(allocated(deltamat))deallocate(deltamat)
    !
    allocate(tmp_mat(Nlat*Nspin*Norb,Nlat*Nspin*Norb))
    allocate(deltamat(Nlat,Nlat,Nspin,Nspin,Norb,Norb))
    allocate(gfprime(Nlat,Nlat,Nspin,Nspin,Norb,Norb))
    !
    tmp_mat=zero
    gfprime=zero
    deltamat=zero
    !
    !
    call vca_gf_cluster(omega,gfprime)
    if(Nbath>0)then
      deltamat=delta_bath_freq(omega,vca_bath)
    endif
    !
    do ii=1,size(impHk,7)
       tmp_mat=eye(Nlat*Nspin*Norb)+matmul(vca_nnn2lso_reshape(deltamat+impHloc-impHk(:,:,:,:,:,:,ii),Nlat,Nspin,Norb),vca_nnn2lso_reshape(gfprime,Nlat,Nspin,Norb))
       out_1=out_1+log(abs(det(tmp_mat)))
    enddo
    out_1=out_1/size(impHk,7)
    !
    deallocate(tmp_mat)
    deallocate(gfprime)
    return
    !
  end function sum_kmesh

  function sum_kmesh_complex(omega) result(out_1)
    integer                                                  :: ii,jj,kk
    complex(8)                                               :: omega
    complex(8)                                               :: out_1
    complex(8),allocatable,dimension(:,:)                    :: tmp_mat
    complex(8),allocatable,dimension(:,:,:,:,:,:)            :: deltamat
    !
    out_1=0.d0
    !
    !
    if(allocated(tmp_mat))deallocate(tmp_mat)
    if(allocated(gfprime))deallocate(gfprime)
    if(allocated(deltamat))deallocate(deltamat)
    !
    allocate(tmp_mat(Nlat*Nspin*Norb,Nlat*Nspin*Norb))
    allocate(deltamat(Nlat,Nlat,Nspin,Nspin,Norb,Norb))
    allocate(gfprime(Nlat,Nlat,Nspin,Nspin,Norb,Norb))
    !
    tmp_mat=zero
    gfprime=zero
    deltamat=zero
    !
    !
    call vca_gf_cluster(omega,gfprime)
    if(Nbath>0)then
      deltamat=delta_bath_freq(omega,vca_bath)
    endif
    !
    do ii=1,size(impHk,7)
       tmp_mat=eye(Nlat*Nspin*Norb)+matmul(vca_nnn2lso_reshape(deltamat+impHloc-impHk(:,:,:,:,:,:,ii),Nlat,Nspin,Norb),vca_nnn2lso_reshape(gfprime,Nlat,Nspin,Norb))
       out_1=out_1+log(det(tmp_mat))
    enddo
    out_1=out_1/size(impHk,7)
    !
    deallocate(tmp_mat)
    deallocate(gfprime)
    return
    !
  end function sum_kmesh_complex

  !+------------------------------------------------------------------+
  !PURPOSE  : Do the frequency sum at zero T
  !+------------------------------------------------------------------+

  function frequency_integration() result(out_2)
    integer                         :: inf
    real(8)                         :: out_2,spin_multiplicity
    !
    out_2=0.d0
    spin_multiplicity=3.d0-Nspin
    !
    !
    write(LOGfile,"(A)")"Calculating Omega"
    call quad(imaginary_axis,a=0.0d0,inf=1,verbose=(verbose>=3),result=out_2,strict=.false.)
    !
    out_2=spin_multiplicity*out_2/pi
    return
  end function frequency_integration

 function imaginary_axis(zeta) result(f)
    real(8)                 :: zeta,f
    complex(8)              :: w
    !
    w=xi*zeta
    !
    f=sum_kmesh(w)
 end function imaginary_axis

  !+------------------------------------------------------------------+
  !PURPOSE  : Do the frequency sum at finite T
  !+------------------------------------------------------------------+

  function frequency_integration_finite_t() result(out_2)
    integer                         :: inf,Nmax,ii
    real(8)                         :: out_2,spin_multiplicity,omegamax,integralpart
    !
    !1) Find the real omegamax
    nmax=int(2*(abs(max_exc)+bandwidth)*beta/pi)
    if (mod(nmax,2)==0)then
      nmax=nmax/2
    else
      nmax=(nmax+1)/2
    endif
    integrationR=2*(nmax+1)*pi/beta
    print*,"NMAX=",nmax
    print*,"INTEGRATION R=",integrationR
    !2) Evaluate discrete sum
    !
    out_2=0.d0
    do ii=0,Nmax
      out_2=out_2+dreal(sum_kmesh_complex(xi*(2*ii+1)*pi/beta))
    enddo
    !
    out_2=2.d0*(1/beta)*out_2
    print*,"SUM PART = ",out_2
    !
    !3) Evaluate integral part
    integralpart=0.d0
    call quad(integral_contour,a=0.0d0,b=pi,verbose=(verbose>=3),key=6,result=integralpart,strict=.false.)
    !
    print*,"INTEGRAL PART = ",integralpart
    !4) Sum all
    out_2=out_2+integralpart
    !5) Spin trick
    spin_multiplicity=3.d0-Nspin
    out_2=spin_multiplicity*out_2
    return
  end function frequency_integration_finite_t

 function integral_contour(zeta) result(f)
    real(8)                 :: zeta,f
    complex(8)              :: w,fermi
    !
    w=integrationR*exp(xi*zeta)
    if(dreal((w-XMU)*beta)>= 100)then
      fermi=0.d0
    else
      fermi=(1/(exp(beta*(w-XMU))+1))
    endif
    !
    f=dreal((1/pi)*w*fermi*sum_kmesh_complex(w))
    !print*,zeta,f,fermi,sum_kmesh(w)
 end function integral_contour

 !+------------------------------------------------------------------+
  !PURPOSE  : DEBUG
  !+------------------------------------------------------------------+

  subroutine reconstruct_g
    complex(8),allocatable,dimension(:,:)                    :: tmp_mat
    character(len=64)                                        :: suffix
    integer                                                  :: ilat,jlat,iorb,jorb,ispin,ifreq
    !
    allocate(gftest(Nlat,Nlat,Nspin,Nspin,Norb,Norb,Lmats))
    gftest=0
    !
    !
    if(.not.allocated(wm))allocate(wm(Lmats))
    wm     = pi/beta*real(2*arange(1,Lmats)-1,8)
    !
    do ifreq=1,size(wm)
        call vca_gf_cluster(xi*wm(ifreq),gftest(:,:,:,:,:,:,ifreq))
    enddo
    !
    do ilat=1,Nlat
       do jlat=1,Nlat
          do iorb=1,Norb
            do jorb=1,Norb
             do ispin=1,Nspin
                suffix="_Isite"//str(ilat,4)//"_Jsite"//str(jlat,4)//"_l"//str(iorb)//str(jorb)//"_s"//str(ispin)
                call splot("Gtest"//reg(suffix)//"_iw"//reg(file_suffix)//".vca"   ,wm,gftest(ilat,jlat,ispin,ispin,iorb,jorb,:))
             enddo
            enddo
          enddo
       enddo
    enddo
    !
    if(allocated(wm))deallocate(wm)
    if(allocated(gftest))deallocate(gftest)
    !
  end subroutine reconstruct_g

  subroutine test_g
    complex(8),allocatable,dimension(:,:)                    :: tmp_mat
    character(len=64)                                        :: suffix
    integer                                                  :: ilat,jlat,iorb,ispin,ifreq
    !
    allocate(gftest(Nlat,Nlat,Nspin,Nspin,Norb,Norb,Lmats))
    gftest=0
    !
    !
    call vca_gf_cluster(xi*0.5d0,gftest(:,:,:,:,:,:,1))
    if(allocated(gftest))deallocate(gftest)
    !
  end subroutine test_g

  !subroutine test_ksum
  !  integer                                                  :: ii,jj,kk
  !  real(8)                                                  :: omega
  !  real(8)                                                  :: out_1
  !  complex(8),allocatable,dimension(:,:)                    :: tmp_mat
  !  !
  !  out_1=0.d0
  !  omega=1.0d0
  !  !
  !  !
  !  if(allocated(tmp_mat))deallocate(tmp_mat)
  !  if(allocated(gfprime))deallocate(gfprime)
  !  !
  !  allocate(tmp_mat(Nlat*Nspin*Norb,Nlat*Nspin*Norb))
  !  allocate(gfprime(Nlat,Nlat,Nspin,Nspin,Norb,Norb))
  !  !
  !  tmp_mat=zero
  !  gfprime=zero
  !  !
  !  call vca_gf_cluster(xi*omega,gfprime)
  !  do ii=1,size(impHk,7)
  !     print*,"ITERATION",ii
  !     !print*,"OMEGA",xi*omega
  !     !print*,"AAAAAAAAA",matmul(vca_nnn2lso_reshape(impHk(:,:,:,:,:,:,ii)-impHloc,Nlat,Nspin,Norb),vca_nnn2lso_reshape(gfprime,Nlat,Nspin,Norb))
  !     !print*,"BBBBBBBBB",vca_nnn2lso_reshape(impHk(:,:,:,:,:,:,ii)-impHloc,Nlat,Nspin,Norb)
  !     tmp_mat=eye(Nlat*Nspin*Norb)+matmul(vca_nnn2lso_reshape(impHk(:,:,:,:,:,:,ii)-impHloc,Nlat,Nspin,Norb),vca_nnn2lso_reshape(gfprime,Nlat,Nspin,Norb))
  !     out_1=out_1+log(abs(REAL(det(tmp_mat))))
  !     print*,"CCCCCCCCC",(vca_nnn2lso_reshape(impHk(:,:,:,:,:,:,ii)-impHloc,Nlat,Nspin,Norb))
  !  enddo
  !  out_1=out_1/size(impHk,7) !*(pi**Ndim)
  !  !
  !  deallocate(tmp_mat)
  !  deallocate(gfprime)
  ! return
  ! !
  !end subroutine test_ksum

  !function frequency_integration_sample() result(out_2)
  !    integer                          :: N,i
  !    real(8),dimension(:),allocatable :: x,func
  !    real(8)                          :: out_2,a,b,spin_multiplicity
  !    !
  !    a=0.0001d0
  !    b=99999.d0
  !    N=1000
  !   out_2=0.d0
  !    spin_multiplicity=2.d0
  !    allocate(x(N),func(N))
  !    x = linspace(a,b,N)
  !    do i=1,N
  !       func(i) = sum_kmesh(xi*x(i))
  !    enddo
  !    call quad(func,a,b,Ninterp=3,key=6,epsabs=0d0,epsrel=1d-4,verbose=.true.,result=out_2)
  !    out_2=spin_multiplicity*out_2/pi
  !    deallocate(x,func)
  !    return
  !end function frequency_integration_sample

end MODULE VCA_OMEGA


! This contains the algorithms needed to calculate the distance between atoms.
!
! Copyright (C) 2013, Joshua More and Michele Ceriotti
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:

! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!
! Functions:
!    vector_separation: Calculates the vector separating two atoms.
!    separation: Calculates the square distance between two vectors.
!    nearest_neighbours: Generates arrays to calculate the pairs of atoms within
!       a certain radius of each other.

      MODULE DISTANCE
      IMPLICIT NONE

      CONTAINS

         SUBROUTINE vector_separation(cell_h, cell_ih, ri, rj, rij, r2)
            ! Calculates the vector separating two atoms.
            !
            ! Note that minimum image convention is used, so only the image of
            ! atom j that is the shortest distance from atom i is considered.
            !
            ! Also note that while this may not work if the simulation
            ! box is highly skewed from orthorhombic, as
            ! in this case it is possible to return a distance less than the
            ! nearest neighbour distance. However, this will not be of
            ! importance unless the cut-off radius is more than half the
            ! width of the shortest face-face distance of the simulation box,
            ! which should never be the case.
            !
            ! Args:
            !    cell_h: The simulation box cell vector matrix.
            !    cell_ih: The inverse of the simulation box cell vector matrix.
            !    ri: The position vector of atom i.
            !    rj: The position vector of atom j
            !    rij: The vector separating atoms i and j.
            !    r2: The square of the distance between atoms i and j.

            DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: cell_h
            DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: cell_ih
            DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: ri
            DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: rj
            DOUBLE PRECISION, DIMENSION(3), INTENT(OUT) :: rij
            DOUBLE PRECISION, INTENT(OUT) :: r2

            INTEGER k
            DOUBLE PRECISION, DIMENSION(3) :: sij
            ! The separation in a basis where the simulation box
            ! is a unit cube.

            sij = matmul(cell_ih, ri - rj)
            DO k = 1, 3
               ! Finds the smallest separation of all the images of atom i and j
               sij(k) = sij(k) - dnint(sij(k))
            ENDDO
            rij = matmul(cell_h, sij)
            r2 = dot_product(rij,rij)

         END SUBROUTINE

         SUBROUTINE separation(cell_h, cell_ih, ri, rj, r2)
            ! Calculates the squared distance between two position vectors.
            !
            ! Note that minimum image convention is used, so only the image of
            ! atom j that is the shortest distance from atom i is considered.
            !
            ! Also note that while this may not work if the simulation
            ! box is highly skewed from orthorhombic, as
            ! in this case it is possible to return a distance less than the
            ! nearest neighbour distance. However, this will not be of
            ! importance unless the cut-off radius is more than half the
            ! width of the shortest face-face distance of the simulation box,
            ! which should never be the case.
            !
            ! Args:
            !    cell_h: The simulation box cell vector matrix.
            !    cell_ih: The inverse of the simulation box cell vector matrix.
            !    ri: The position vector of atom i.
            !    rj: The position vector of atom j
            !    r2: The square of the distance between atoms i and j.

            DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: cell_h
            DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: cell_ih
            DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: ri
            DOUBLE PRECISION, DIMENSION(3), INTENT(IN) :: rj
            DOUBLE PRECISION, INTENT(OUT) :: r2

            INTEGER k
            ! The separation in a basis where the simulation box
            ! is a unit cube.
            DOUBLE PRECISION, DIMENSION(3) :: sij
            DOUBLE PRECISION, DIMENSION(3) :: rij

            sij = matmul(cell_ih, ri - rj)
            DO k = 1, 3
               ! Finds the smallest separation of all the images of atom i and j
               sij(k) = sij(k) - dnint(sij(k))
            ENDDO
            rij = matmul(cell_h, sij)
            r2 = dot_product(rij, rij)

         END SUBROUTINE

         SUBROUTINE nearest_neighbours(rn, natoms, atoms, cell_h, cell_ih, index_list, n_list)
            ! Creates a list of all the pairs of atoms that are closer together
            ! than a certain distance.
            !
            ! This takes all the positions, and calculates which ones are
            ! shorter than the distance rn. This creates two vectors, index_list
            ! and n_list. index_list(i) gives the last index of n_list that
            ! corresponds to a neighbour of atom i.
            !
            !
            ! Args:
            !    rn: The nearest neighbour list cut-off parameter. This should
            !       be larger than the potential cut-off radius.
            !    natoms: The number of atoms in the system.
            !    atoms: A vector holding all the atom positions.
            !    cell_h: The simulation box cell vector matrix.
            !    cell_ih: The inverse of the simulation box cell vector matrix.
            !    index_list: A array giving the last index of n_list that
            !       gives the neighbours of a given atom. Essentially keeps
            !       track of how many atoms neighbour a given atom.
            !    n_list: An array giving the indices of the atoms that neighbour
            !       the atom determined by index_list. Essentially keeps track
            !       of which atoms neighbour a given atom.

            DOUBLE PRECISION, INTENT(IN) :: rn
            INTEGER, INTENT(IN) :: natoms
            DOUBLE PRECISION, DIMENSION(:,:), INTENT(IN) :: atoms
            DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: cell_h
            DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN) :: cell_ih
            INTEGER, DIMENSION(natoms), INTENT(OUT) :: index_list
            INTEGER, DIMENSION(natoms*(natoms-1)/2), INTENT(OUT) :: n_list

            INTEGER :: i, j
            DOUBLE PRECISION r2

         index_list(1) = 0

         DO i = 1, natoms - 1
            DO j = i + 1, natoms
               CALL separation(cell_h, cell_ih, atoms(i,:), atoms(j,:), r2)
               IF (r2 < rn*rn) THEN
                  ! We have found an atom that neighbours atom i, so the
                  ! i-th index of index_list is incremented by one, and a new
                  ! entry is added to n_list.
                  index_list(i) = index_list(i) + 1
                  n_list(index_list(i)) = j
               ENDIF
            ENDDO
            index_list(i+1) = index_list(i)
         ENDDO

         END SUBROUTINE

      END MODULE


      SUBROUTINE SLARRE( N, D, E, TOL, NSPLIT, ISPLIT, M, W, WOFF,
     $                   GERSCH, WORK, INFO )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            INFO, M, N, NSPLIT
      REAL               TOL
*     ..
*     .. Array Arguments ..
      INTEGER            ISPLIT( * )
      REAL               D( * ), E( * ), GERSCH( * ), W( * ), WOFF( * ),
     $                   WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  Given the tridiagonal matrix T, SLARRE sets "small" off-diagonal
*  elements to zero, and for each unreduced block T_i, it finds
*  (i) the numbers sigma_i
*  (ii) the base T_i - sigma_i I = L_i D_i L_i^T representations and
*  (iii) eigenvalues of each L_i D_i L_i^T.
*  The representations and eigenvalues found are then used by
*  SSTEGR to compute the eigenvectors of a symmetric tridiagonal
*  matrix. Currently, the base representations are limited to being
*  positive or negative definite, and the eigenvalues of the definite
*  matrices are found by the dqds algorithm (subroutine SLASQ2). As
*  an added benefit, SLARRE also outputs the n Gerschgorin
*  intervals for each L_i D_i L_i^T.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix.
*
*  D       (input/output) REAL array, dimension (N)
*          On entry, the n diagonal elements of the tridiagonal
*          matrix T.
*          On exit, the n diagonal elements of the diagonal
*          matrices D_i.
*
*  E       (input/output) REAL array, dimension (N)
*          On entry, the (n-1) subdiagonal elements of the tridiagonal
*          matrix T; E(N) need not be set.
*          On exit, the subdiagonal elements of the unit bidiagonal
*          matrices L_i.
*
*  TOL     (input) REAL
*          The threshold for splitting. If on input |E(i)| < TOL, then
*          the matrix T is split into smaller blocks.
*
*  NSPLIT  (input) INTEGER
*          The number of blocks T splits into. 1 <= NSPLIT <= N.
*
*  ISPLIT  (output) INTEGER array, dimension (2*N)
*          The splitting points, at which T breaks up into submatrices.
*          The first submatrix consists of rows/columns 1 to ISPLIT(1),
*          the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
*          etc., and the NSPLIT-th consists of rows/columns
*          ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
*
*  M       (output) INTEGER
*          The total number of eigenvalues (of all the L_i D_i L_i^T)
*          found.
*
*  W       (output) REAL array, dimension (N)
*          The first M elements contain the eigenvalues. The
*          eigenvalues of each of the blocks, L_i D_i L_i^T, are
*          sorted in ascending order.
*
*  WOFF    (output) REAL array, dimension (N)
*          The NSPLIT base points sigma_i.
*
*  GERSCH  (output) REAL array, dimension (2*N)
*          The n Gerschgorin intervals.
*
*  WORK    (input) REAL array, dimension (4*N???)
*          Workspace.
*
*  INFO    (output) INTEGER
*          Output error code from SLASQ2
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Inderjit Dhillon, IBM Almaden, USA
*     Osni Marques, LBNL/NERSC, USA
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, TWO, FOUR, FOURTH
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
     $                   FOUR = 4.0E0, FOURTH = ONE / FOUR )
*     ..
*     .. Local Scalars ..
      INTEGER            CNT, I, IBEGIN, IEND, IN, J, JBLK, MAXCNT
      REAL               DELTA, EPS, GL, GU, NRM, OFFD, S, SGNDEF,
     $                   SIGMA, TAU, TMP1, WIDTH
*     ..
*     .. External Functions ..
      REAL               SLAMCH
      EXTERNAL           SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SLASQ2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      EPS = SLAMCH( 'Precision' )
*
*     Compute Splitting Points
*
      NSPLIT = 1
      DO 10 I = 1, N - 1
         IF( ABS( E( I ) ).LE.TOL ) THEN
            ISPLIT( NSPLIT ) = I
            NSPLIT = NSPLIT + 1
         END IF
   10 CONTINUE
      ISPLIT( NSPLIT ) = N
*
      IBEGIN = 1
      DO 170 JBLK = 1, NSPLIT
         IEND = ISPLIT( JBLK )
         IF( IBEGIN.EQ.IEND ) THEN
            W( IBEGIN ) = D( IBEGIN )
            WOFF( JBLK ) = ZERO
            IBEGIN = IEND + 1
            GO TO 170
         END IF
         IN = IEND - IBEGIN + 1
*
*        Form the n Gerschgorin intervals
*
         GL = D( IBEGIN ) - ABS( E( IBEGIN ) )
         GU = D( IBEGIN ) + ABS( E( IBEGIN ) )
         GERSCH( 2*IBEGIN-1 ) = GL
         GERSCH( 2*IBEGIN ) = GU
         GERSCH( 2*IEND-1 ) = D( IEND ) - ABS( E( IEND-1 ) )
         GERSCH( 2*IEND ) = D( IEND ) + ABS( E( IEND-1 ) )
         GL = MIN( GERSCH( 2*IEND-1 ), GL )
         GU = MAX( GERSCH( 2*IEND ), GU )
         DO 20 I = IBEGIN + 1, IEND - 1
            OFFD = ABS( E( I-1 ) ) + ABS( E( I ) )
            GERSCH( 2*I-1 ) = D( I ) - OFFD
            GL = MIN( GERSCH( 2*I-1 ), GL )
            GERSCH( 2*I ) = D( I ) + OFFD
            GU = MAX( GERSCH( 2*I ), GU )
   20    CONTINUE
         NRM = MAX( ABS( GL ), ABS( GU ) )
*
*        Find the number SIGMA where the base representation
*        T - sigma I = L D L^T is to be formed.
*
         WIDTH = GU - GL
         DO 30 I = IBEGIN, IEND - 1
            WORK( I ) = E( I )*E( I )
   30    CONTINUE
         DO 50 J = 1, 2
            IF( J.EQ.1 ) THEN
               TAU = GL + FOURTH*WIDTH
            ELSE
               TAU = GU - FOURTH*WIDTH
            END IF
            TMP1 = D( IBEGIN ) - TAU
            IF( TMP1.LT.ZERO ) THEN
               CNT = 1
            ELSE
               CNT = 0
            END IF
            DO 40 I = IBEGIN + 1, IEND
               TMP1 = D( I ) - TAU - WORK( I-1 ) / TMP1
               IF( TMP1.LT.ZERO )
     $            CNT = CNT + 1
   40       CONTINUE
            IF( CNT.EQ.0 ) THEN
               GL = TAU
            ELSE IF( CNT.EQ.IN ) THEN
               GU = TAU
            END IF
            IF( J.EQ.1 ) THEN
               MAXCNT = CNT
               SIGMA = GL
               SGNDEF = ONE
            ELSE
               IF( IN-CNT.GT.MAXCNT ) THEN
                  SIGMA = GU
                  SGNDEF = -ONE
               END IF
            END IF
   50    CONTINUE
*
*        Find the base L D L^T representation
*
         WORK( 3*IN ) = ONE
         DELTA = EPS
         TAU = SGNDEF*NRM
   60    CONTINUE
         SIGMA = SIGMA - DELTA*TAU
         WORK( 1 ) = D( IBEGIN ) - SIGMA
         J = IBEGIN
         DO 70 I = 1, IN - 1
            WORK( 2*IN+I ) = ONE / WORK( 2*I-1 )
            TMP1 = E( J )*WORK( 2*IN+I )
            WORK( 2*I+1 ) = ( D( J+1 )-SIGMA ) - TMP1*E( J )
            WORK( 2*I ) = TMP1
            J = J + 1
   70    CONTINUE
         DO 80 I = IN, 1, -1
            TMP1 = SGNDEF*WORK( 2*I-1 )
            IF( TMP1.LT.ZERO .OR. WORK( 2*IN+I ).EQ.ZERO .OR. .NOT.
     $          ( TMP1.GT.ZERO .OR. TMP1.LT.ONE ) ) THEN
               DELTA = TWO*DELTA
               GO TO 60
            END IF
            J = J - 1
   80    CONTINUE
*
         J = IBEGIN
         D( IBEGIN ) = WORK( 1 )
         WORK( 1 ) = ABS( WORK( 1 ) )
         DO 90 I = 1, IN - 1
            TMP1 = E( J )
            E( J ) = WORK( 2*I )
            WORK( 2*I ) = ABS( TMP1*WORK( 2*I ) )
            J = J + 1
            D( J ) = WORK( 2*I+1 )
            WORK( 2*I+1 ) = ABS( WORK( 2*I+1 ) )
   90    CONTINUE
*
         CALL SLASQ2( IN, WORK, INFO )
*
         TAU = SGNDEF*WORK( IN )
         WORK( 3*IN ) = ONE
         DELTA = TWO*EPS
  100    CONTINUE
         TAU = TAU*( ONE-DELTA )
*
         S = -TAU
         J = IBEGIN
         DO 110 I = 1, IN - 1
            WORK( I ) = D( J ) + S
            WORK( 2*IN+I ) = ONE / WORK( I )
*           WORK( N+I ) = ( E( I ) * D( I ) ) / WORK( I )
            WORK( IN+I ) = ( E( J )*D( J ) )*WORK( 2*IN+I )
            S = S*WORK( IN+I )*E( J ) - TAU
            J = J + 1
  110    CONTINUE
         WORK( IN ) = D( IEND ) + S
*
*        Checking to see if all the diagonal elements of the new
*        L D L^T representation have the same sign
*
         DO 120 I = IN, 1, -1
            TMP1 = SGNDEF*WORK( I )
            IF( TMP1.LT.ZERO .OR. WORK( 2*IN+I ).EQ.ZERO .OR. .NOT.
     $          ( TMP1.GT.ZERO .OR. TMP1.LT.ONE ) ) THEN
               DELTA = TWO*DELTA
               GO TO 100
            END IF
  120    CONTINUE
*
         SIGMA = SIGMA + TAU
         CALL SCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
         CALL SCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
         WOFF( JBLK ) = SIGMA
*
*        Update the n Gerschgorin intervals
*
         DO 130 I = IBEGIN, IEND
            GERSCH( 2*I-1 ) = GERSCH( 2*I-1 ) - SIGMA
            GERSCH( 2*I ) = GERSCH( 2*I ) - SIGMA
  130    CONTINUE
*
*        Compute the eigenvalues of L D L^T.
*
         J = IBEGIN
         DO 140 I = 1, IN - 1
            WORK( 2*I-1 ) = ABS( D( J ) )
            WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
            J = J + 1
  140    CONTINUE
         WORK( 2*IN-1 ) = ABS( D( IEND ) )
*
         CALL SLASQ2( IN, WORK, INFO )
*
         J = IBEGIN
         IF( SGNDEF.GT.ZERO ) THEN
            DO 150 I = 1, IN
               W( J ) = WORK( IN-I+1 )
               J = J + 1
  150       CONTINUE
         ELSE
            DO 160 I = 1, IN
               W( J ) = -WORK( I )
               J = J + 1
  160       CONTINUE
         END IF
         IBEGIN = IEND + 1
  170 CONTINUE
      M = N
*
      RETURN
*
*     End of SLARRE
*
      END


! This program calculates elastic constants
! Must be used with in.comb-elastic script,
! and reads a LAMMPS log file from standard input:
!
! f95 -O -o elastic.x elastic.f90
! ./elastic.x < log.lammps
!
! Written by T-R Shan, MSE, UF, Feb 2010

PROGRAM main
  IMPLICIT NONE

  INTEGER, PARAMETER :: dbl=8
  INTEGER :: i,j,k,l
  REAL(kind=dbl) :: box(6,11),force(6,11),vol(11),eps(11),strbox(6,11)
  REAL(kind=dbl) :: sumx,sumx2,sumy,sumxy
  REAL(kind=dbl) :: c11,c12,c13,c14,c15,c16,c33,c44,c66
  REAL(kind=dbl) :: bulk,shear
  CHARACTER*7  :: header1

!  open(5,status='old',file='log.lammps')

  DO i=1,500
      READ(5,'(a7)') header1
      IF(header1.EQ.'Step Lx')THEN
          DO j=1,11
              READ(5,*) k,(box(l,j),l=1,6),(force(l,j),l=1,6)
              vol(j)=box(1,j)*box(2,j)*box(3,j) * dsqrt(1-(box(4,j)/box(1,j)) &
                  *(box(4,j)/box(1,j))-(box(6,j)/box(3,j))*(box(6,j)/box(3,j) &
                  -(box(5,j)/box(3,j))*(box(5,j)/box(3,j))))
              eps(j)=(box(1,j)-box(1,1))/box(1,1)
              DO l=1,6
                  strbox(l,j)=force(l,j)/vol(j)/1.0d4
              ENDDO
          ENDDO
          EXIT
      ENDIF
  ENDDO

  !!    C11
  sumx = 0.0_dbl; sumx2 = 0.0_dbl; sumy = 0.0_dbl; sumxy = 0.0_dbl
  DO j=2,11
      sumx = sumx + eps(j)
      sumx2= sumx2+ eps(j)*eps(j)
      sumy = sumy + strbox(1,j)
      sumxy= sumxy+ strbox(1,j)*eps(j)
  ENDDO
  c11 = (sumxy-sumx*sumy/10.0_dbl)/(sumx2-sumx*sumx/10.0_dbl)
  !!    C12
  sumy = 0.0_dbl; sumxy = 0.0_dbl
  DO j=2,11
      sumy = sumy + strbox(2,j)
      sumxy= sumxy+ strbox(2,j)*eps(j)
  ENDDO
  c12 = (sumxy-sumx*sumy/10.0_dbl)/(sumx2-sumx*sumx/10.0_dbl)
  !!    C13
  sumy = 0.0_dbl; sumxy = 0.0_dbl
  DO j=2,11
      sumy = sumy + strbox(3,j)
      sumxy= sumxy+ strbox(3,j)*eps(j)
  ENDDO
  c13 = (sumxy-sumx*sumy/10.0_dbl)/(sumx2-sumx*sumx/10.0_dbl)
  !!    C14
  sumy = 0.0_dbl; sumxy = 0.0_dbl
  DO j=2,11
      sumy = sumy + strbox(4,j)
      sumxy= sumxy+ strbox(4,j)*eps(j)
  ENDDO
  c14 = (sumxy-sumx*sumy/10.0_dbl)/(sumx2-sumx*sumx/10.0_dbl)
  !!    C15
  sumy = 0.0_dbl; sumxy = 0.0_dbl
  DO j=2,11
      sumy = sumy + strbox(5,j)
      sumxy= sumxy+ strbox(5,j)*eps(j)
  ENDDO
  c15 = (sumxy-sumx*sumy/10.0_dbl)/(sumx2-sumx*sumx/10.0_dbl)
  !!    C16
  sumy = 0.0_dbl; sumxy = 0.0_dbl
  DO j=2,11
      sumy = sumy + strbox(6,j)
      sumxy= sumxy+ strbox(6,j)*eps(j)
  ENDDO
  c16 = (sumxy-sumx*sumy/10.0_dbl)/(sumx2-sumx*sumx/10.0_dbl)

  !!    C33
  DO i=1,500
      READ(5,'(a7)') header1
      IF(header1.EQ.'Step Lx')THEN
          DO j=1,11
              READ(5,*) k,(box(l,j),l=1,6),(force(l,j),l=1,6)
              vol(j)=box(1,j)*box(2,j)*box(3,j) * dsqrt(1-(box(4,j)/box(1,j)) &
                  *(box(4,j)/box(1,j))-(box(6,j)/box(3,j))*(box(6,j)/box(3,j) &
                  -(box(5,j)/box(3,j))*(box(5,j)/box(3,j))))
              eps(j)=(box(3,j)-box(3,1))/box(3,1)
              DO l=1,6
                  strbox(l,j)=force(l,j)/vol(j)/1.0d4
              ENDDO
          ENDDO
          EXIT
      ENDIF
  ENDDO

  sumx = 0.0_dbl; sumx2 = 0.0_dbl; sumy = 0.0_dbl; sumxy = 0.0_dbl
  DO j=2,11
      sumx = sumx + eps(j)
      sumx2= sumx2+ eps(j)*eps(j)
      sumy = sumy + strbox(3,j)
      sumxy= sumxy+ strbox(3,j)*eps(j)
  ENDDO
  c33 = (sumxy-sumx*sumy/10.0_dbl)/(sumx2-sumx*sumx/10.0_dbl)

  !!    C44
  DO i=1,500
      READ(5,'(a7)') header1
      IF(header1.EQ.'Step Lx')THEN
          DO j=1,11
              READ(5,*) k,(box(l,j),l=1,6),(force(l,j),l=1,6)
              vol(j)=box(1,j)*box(2,j)*box(3,j)*dsqrt(1.0-(box(4,j)/box(1,j)) &
                  *(box(4,j)/box(1,j))-(box(6,j)/box(3,j))*(box(6,j)/box(3,j) &
                  -(box(5,j)/box(3,j))*(box(5,j)/box(3,j))))
              DO l=1,6
                  strbox(l,j)=force(l,j)/vol(j)/1.0d4
              ENDDO
          ENDDO
          EXIT
      ENDIF
  ENDDO

  sumx = 0.0_dbl; sumx2 = 0.0_dbl; sumy = 0.0_dbl; sumxy = 0.0_dbl
  DO j=2,11
      eps(j)=ASIN(box(6,j)/box(3,j))
      sumx = sumx + eps(j)
      sumx2= sumx2+ eps(j)*eps(j)
      sumy = sumy + strbox(6,j)
      sumxy= sumxy+ strbox(6,j)*eps(j)
  enddo
  c44 = (sumxy-sumx*sumy/10.0_dbl)/(sumx2-sumx*sumx/10.0_dbl)

  !!    C66
  DO i=1,500
      READ(5,'(a7)') header1
      IF(header1.EQ.'Step Lx')THEN
          DO j=1,11
              READ(5,*) k,(box(l,j),l=1,6),(force(l,j),l=1,6)
              vol(j)=box(1,j)*box(2,j)*box(3,j)*dsqrt(1.0-(box(4,j)/box(1,j)) &
                  *(box(4,j)/box(1,j))-(box(6,j)/box(3,j))*(box(6,j)/box(3,j) &
                  -(box(5,j)/box(3,j))*(box(5,j)/box(3,j))))
              DO l=1,6
                  strbox(l,j)=force(l,j)/vol(j)/1.0d4
              ENDDO
          ENDDO
          EXIT
      ENDIF
  ENDDO

  sumx = 0.0_dbl; sumx2 = 0.0_dbl; sumy = 0.0_dbl; sumxy = 0.0_dbl
  DO j=2,11
      eps(j)=ASIN(box(4,j)/box(1,j))
      sumx = sumx + eps(j)
      sumx2= sumx2+ eps(j)*eps(j)
      sumy = sumy + strbox(4,j)
      sumxy= sumxy+ strbox(4,j)*eps(j)
  ENDDO
  c66 = (sumxy-sumx*sumy/10.0_dbl)/(sumx2-sumx*sumx/10.0_dbl)

  bulk=(c11*2.0_dbl+c33)/9.0_dbl+2.0_dbl*(c12+c13*2.0_dbl)/9.0_dbl
  shear=(2.0_dbl*c11+c33-c12-2.0_dbl*c13)/15.0_dbl+(2.0_dbl*c44+c66)/5.0_dbl

  WRITE(*,*)
  WRITE(*,*)'Elastic constants (GPa):'
  WRITE(*,101) 'C11 = ',c11
  WRITE(*,101) 'C12 = ',c12
  WRITE(*,101) 'C13 = ',c13
  WRITE(*,101) 'C14 = ',c14
  WRITE(*,101) 'C15 = ',c15
  WRITE(*,101) 'C16 = ',c16
  WRITE(*,101) 'C33 = ',c33
  WRITE(*,101) 'C44 = ',c44
  WRITE(*,101) 'C66 = ',c66
  WRITE(*,101) 'B = ',bulk
  WRITE(*,101) 'G = ',shear

  ! WRITE(5,*)
  ! WRITE(5,*)'Elastic constants (GPa):'
  ! WRITE(5,101) 'C11 = ',c11
  ! WRITE(5,101) 'C12 = ',c12
  ! WRITE(5,101) 'C13 = ',c13
  ! WRITE(5,101) 'C14 = ',c14
  ! WRITE(5,101) 'C15 = ',c15
  ! WRITE(5,101) 'C16 = ',c16
  ! WRITE(5,101) 'C33 = ',c33
  ! WRITE(5,101) 'C44 = ',c44
  ! WRITE(5,101) 'C66 = ',c66
  ! WRITE(5,101) 'B = ',bulk
  ! WRITE(5,101) 'G = ',shear

101 FORMAT(a6,f11.3)

  STOP
END PROGRAM main


program pure_fortran
implicit none

interface
    subroutine init_matrix(m)
        real(kind=8), allocatable, dimension(:,:), intent(inout) :: m
    end subroutine init_matrix
end interface

integer :: n, i, j
real(kind=8), allocatable, dimension(:,:) :: a, b, c
character(len=1024) :: argv
real :: start_time, end_time

if (command_argument_count() > 0) then
    call get_command_argument(1, argv)
    read (argv, fmt=*), n
else
    n = 5
end if

print *, "initializing a..."
call cpu_time(start_time)
allocate(a(n, n))
call init_matrix(a)
call cpu_time(end_time)
print *, "initialized a: ", end_time - start_time
print *, "initializing b..."
call cpu_time(start_time)
allocate(b(n, n))
call init_matrix(b)
call cpu_time(end_time)
print *, "initialized b: ", end_time - start_time
allocate(c(n, n))
print *, "multiplying..."
call cpu_time(start_time)
c = matmul(a, b)
call cpu_time(end_time)
print *, "multiplied: ", end_time - start_time

deallocate(a)
deallocate(b)
deallocate(c)

end program pure_fortran

subroutine init_matrix(m)
    implicit none
    real(kind=8), allocatable, dimension(:,:), intent(inout) :: m
    integer :: n, i, j
    real(kind=8) :: r
    n = size(m, 1)
    do j = 1, n
        do i = 1, n
            call random_number(r)
            m(i, j) = 5
        end do
    end do
end subroutine init_matrix


subroutine vort_3d(lo, hi, d, nComps, dlo, dhi, vel, vort, delta) bind(c)
    use amrex_fort_module, only : amrex_real
    implicit none
    integer, intent(in) :: lo(3), hi(3), dlo(3), dhi(3), nComps
    real(amrex_real), intent(inout) :: d(dlo(1):dhi(1), dlo(2):dhi(2), dlo(3):dhi(3), 0:(nComps - 1))
    integer, intent(in) :: vel(3), vort(3)
    real(amrex_real), intent(in) :: delta(3)
    real(amrex_real) :: tdx(3)
    integer :: i, j, k
    real(amrex_real) :: uy, uz, vx, vz, wx, wy

    do i = 1, 3
        tdx(i) = REAL(1.0, amrex_real) / (2 * delta(i))
    enddo

    do k = lo(3),hi(3)
        do j = lo(2),hi(2)
            do i = lo(1),hi(1)
                uy = (d(i, j + 1, k, vel(1)) - d(i, j - 1, k, vel(1))) * tdx(2)
                uz = (d(i, j, k + 1, vel(1)) - d(i, j, k - 1, vel(1))) * tdx(3)
                vx = (d(i + 1, j, k, vel(2)) - d(i - 1, j, k, vel(2))) * tdx(1)
                vz = (d(i, j, k + 1, vel(2)) - d(i, j, k - 1, vel(2))) * tdx(3)
                wx = (d(i + 1, j, k, vel(3)) - d(i - 1, j, k, vel(3))) * tdx(1)
                wy = (d(i, j + 1, k, vel(3)) - d(i, j - 1, k, vel(3))) * tdx(2)

                d(i, j, k, vort(1)) = wy - vz
                d(i, j, k, vort(2)) = uz - wx
                d(i, j, k, vort(3)) = vx - uy
            end do
        end do
    end do
end

subroutine divu_3d(lo, hi, d, nComps, dlo, dhi, vel, divu, delta) bind(c)
    use amrex_fort_module, only : amrex_real
    implicit none
    integer, intent(in) :: lo(3), hi(3), dlo(3), dhi(3), nComps
    real(amrex_real), intent(inout) :: d(dlo(1):dhi(1), dlo(2):dhi(2), dlo(3):dhi(3), 0:(nComps - 1))
    integer, intent(in) :: vel(3), divu
    real(amrex_real), intent(in) :: delta(3)
    real(amrex_real) :: tdx(3)
    integer :: i, j, k
    real(amrex_real) :: ux, vy, wz

    do i = 1, 3
        tdx(i) = REAL(1.0, amrex_real) / (2 * delta(i))
    enddo

    do k = lo(3), hi(3)
        do j = lo(2), hi(2)
            do i = lo(1), hi(1)
                ux = (d(i + 1, j, k, vel(1)) - d(i - 1, j, k, vel(1))) * tdx(1)
                vy = (d(i, j + 1, k, vel(2)) - d(i, j - 1, k, vel(2))) * tdx(2)
                wz = (d(i, j, k + 1, vel(3)) - d(i, j, k - 1, vel(3))) * tdx(3)

                d(i, j, k, divu) = ux + vy + wz
            end do
        end do
    end do
end

subroutine copy_3d(                                         &
    srclo, srchi, srcd, srcNComps, srcdlo, srcdhi,          &
    dstlo, dsthi, dstd, dstNComps, dstdlo, dstdhi,          &
    srccomp, dstcomp) bind(c)
    use amrex_fort_module, only : amrex_real
    implicit none
    integer, intent(in) ::                                  &
        srclo(3), srchi(3), srcdlo(3), srcdhi(3), srccomp
    integer, intent(in) ::                                  &
        dstlo(3), dsthi(3), dstdlo(3), dstdhi(3), dstcomp
    integer, intent(in) :: srcNComps, dstNComps
    real(amrex_real), intent(in) :: srcd(                   &
        srcdlo(1):srcdhi(1),                                &
        srcdlo(2):srcdhi(2),                                &
        srcdlo(3):srcdhi(3),                                &
        0:(srcNComps - 1)                                   &
        )
    real(amrex_real), intent(inout) :: dstd(                &
        dstdlo(1):dstdhi(1),                                &
        dstdlo(2):dstdhi(2),                                &
        dstdlo(3):dstdhi(3),                                &
        0:(dstNComps - 1)                                   &
        )
    integer :: i, j, k

    do k = dstdlo(3), dstdhi(3)
        do j = dstdlo(2), dstdhi(2)
            do i = dstdlo(1), dstdhi(1)
                dstd(i, j, k, dstcomp) = srcd(i, j, k, srccomp)
            end do
        end do
    end do
end


program test
  real :: pi1
  real(kind=8) :: pi2

  pi1 = 3.14
  pi2 = 3.1423

  print *, exp(pi1)

  print *, exp(pi2)
end program test


function ffun(x, y)
    implicit none
    !DEC$ ATTRIBUTES DLLEXPORT, STDCALL, REFERENCE :: FFUN
    double precision :: x, y, ffun
    ffun = x + y * y
end function