  subroutine slogtab(nearest,ntab,vtab, ndat,vdat,indx,wght)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-----------------------------------------------------------------------
!
! !ROUTINE: slogtab - set indices and log-linear weights to a table
!
! !INTERFACE:
! end subroutine slogtab
!
! !DESCRIPTION:
!	*slogtab()* sets indices and log-linear weights for a given data
!	list *vdat(ndat)* respect to a given lookup table *vtab(ntab)*.
!	If *nearest* is .false., indices *indx* point to *vtab(ntab)*
!	entries of nearest (in a log-linear sense) values, with
!	*wght(ndat)* defined within the range [-.5,+.5).  If *nearest*
!	is .true., indices *indx* are lower entries of table intervals,
!	with *wght* defined withing [0,1).
!
!	*nearest*=.true. may be used to create an index table for
!	direct table reference, while *nearest*=.false. may be used to
!	create an index table with weights for log-linear interpolating
!	functions.
!
!	Notice that *vtab(ntab)* must be in a sorted order.  Values in
!	both *vtab(ntab)* and *vdat(ndat)* must be positive for a
!	properly defined log-linear.
!
! !EXAMPLES:
!
! !BUGS:
!
! !SEE ALSO:
!
! !SYSTEM ROUTINES:
!
! !FILES USED:
!
! !REVISION HISTORY:
!	18May96 - J. Guo	- Fixed a problem with out-of-ranged
!				  data
! 	05Dec95 - J. Guo	- initial coding
!_______________________________________________________________________
    implicit none
!@interface

    logical, intent(in)		:: nearest	! nearest entries?
    integer, intent(in)		:: ntab		! size of vtab
      real,    intent(in)	:: vtab(ntab)	! a lookup table

    integer, intent(in)		:: ndat		! size of vdat
      real,    intent(in)	:: vdat(ndat)	! a list of values

    integer, intent(out)	:: indx(ndat)	! indices to vtab
    real,    intent(out)	:: wght(ndat)	! weights of vtab

!@end/interface
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! local vars.
	integer i,j
	real v
!_______________________________________________________________________

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
	! extreme condition.  Treated as normal

	if(ntab.le.0) return

!  ..Index the array to the lower index entry of an intervals in vtab.
	call vindex(ntab,vtab,ndat,vdat,indx)

!  ..Compute the linear weights, and adjust the indices if needed.
	do i=1,ndat
	  j=indx(i)

	  v=0.
	  if(j.lt.ntab) v=log(vdat(i)/vtab(j))/log(vtab(j+1)/vtab(j))
	  v=min(max(0.,v),1.)

	  if(nearest) then
		! indx(i) is the index to the nearest entry in vtab,
		! with wght(i) is within [-.5,+.5).  It is likely to
		! be used for direct table reference

	    indx(i)=j + nint(v)
	    wght(i)=v - nint(v)

	  else
		! indx(i) is the lower index of an interval in vtab,
		! with wght(i) is in [0,1).

	    wght(i)=v
	  endif
	end do
!_______________________________________________________________________
	end
!.


! complex version
! a subroutine to calculate eigenvector and eigenvalue
  subroutine eigensystem_c(JOBZ,UPLO,N,A,W)

     use para, only : Dp, stdout
     implicit none

!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
     character*1, intent(in) :: JOBZ

!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
     character*1, intent(in) :: UPLO

!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
     integer,   intent(in) :: N

!  A       (input/output) COMPLEX*16 array, dimension (LDA, N)
!          On entry, the Hermitian matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
!          orthonormal eigenvectors of the matrix A.
!          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
!          or the upper triangle (if UPLO='U') of A, including the
!          diagonal, is destroyed.

     complex(Dp),intent(inout) :: A(N,N)

!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.

     real(Dp), intent(inout) :: W(N)

     integer :: info

     real(Dp),allocatable ::  rwork(:)

     complex(Dp),allocatable :: work(:)

     allocate(rwork(16*N))
     allocate( work(16*N))
     rwork= 0d0
     work= 0d0

     info=0
     W=0.0d0

     if (N==1) then
        W=A(1, 1)
        A(1, 1)= 1d0
        return
     endif

     call zheev( JOBZ, UPLO, N, A, N,  &
              W, work, 16*N, rwork, info )

     if (info.ne.0) then
        write(stdout, *) 'ERROR : something wrong with zheev'
        stop
     endif

     deallocate(rwork, work)
     return
  end subroutine eigensystem_c

! real version
! a subroutine to calculate eigenvector and eigenvalue
  subroutine eigensystem_r (JOBZ,UPLO,N,A,W)

     use para, only : Dp, stdout
     implicit none

!  JOBZ    (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
     character*1, intent(in) :: JOBZ

!  UPLO    (input) CHARACTER*1
!          = 'U':  Upper triangle of A is stored;
!          = 'L':  Lower triangle of A is stored.
     character*1, intent(in) :: UPLO

!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
     integer,   intent(in) :: N

!  A       (input/output) COMPLEX*16 array, dimension (LDA, N)
!          On entry, the Hermitian matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
!          orthonormal eigenvectors of the matrix A.
!          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
!          or the upper triangle (if UPLO='U') of A, including the
!          diagonal, is destroyed.

     real(Dp),intent(inout) :: A(N,N)

!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.

     real(Dp), intent(inout) :: W(N)

     integer :: info

     real(Dp),allocatable :: work(:)

     allocate( work(16*N))
     work= 0d0

     if (N==1) then
        W=A(1, 1)
        A(1, 1)= 1d0
        return
     endif

     info=0
     W=0.0d0
     call dsyev( JOBZ, UPLO, N, A, N,  &
              W, work, 16*N, info )

     if (info.ne.0) then
        write(stdout, *) 'ERROR : something wrong with dsyev'
        stop
     endif

     deallocate(work)
     return
  end subroutine eigensystem_r

! a subroutine to calculate eigenvector and eigenvalue
  subroutine zgeev_pack(N, A, W)

     use para, only : Dp
     implicit none

!  JOBVL   (input) CHARACTER*1
!  JOBVR   (input) CHARACTER*1
!          = 'N':  Compute eigenvalues only;
!          = 'V':  Compute eigenvalues and eigenvectors.
!
     character*1 :: JOBVL
     character*1 :: JOBVR

!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
     integer,   intent(in) :: N

!  A       (input/output) COMPLEX*16 array, dimension (LDA, N)
!          On entry, the Hermitian matrix A.  If UPLO = 'U', the
!          leading N-by-N upper triangular part of A contains the
!          upper triangular part of the matrix A.  If UPLO = 'L',
!          the leading N-by-N lower triangular part of A contains
!          the lower triangular part of the matrix A.
!          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
!          orthonormal eigenvectors of the matrix A.
!          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
!          or the upper triangle (if UPLO='U') of A, including the
!          diagonal, is destroyed.

     complex(Dp),intent(inout) :: A(N, N)

!  W       (output) DOUBLE PRECISION array, dimension (N)
!          If INFO = 0, the eigenvalues in ascending order.

!    eigenvalues
     complex(Dp), intent(out) :: W(N)

!    left eigenvectors
     complex(dp), allocatable :: VL(:, :)

!    right eigenvectors
     complex(dp), allocatable :: VR(:, :)

     integer :: info

     integer :: lda
     integer :: ldvl
     integer :: ldvr

     integer :: lwork

     real(dp),allocatable ::  rwork(:)

     complex(dp),allocatable :: work(:)

     !> only calculate eigenvalues
     JOBVL= 'N'
     JOBVR= 'N'

     lda=N
     ldvl=N
     ldvr=N
     lwork= 16*N
     allocate(VL(N, N))
     allocate(VR(N, N))

     allocate(rwork(16*N))
     allocate( work(lwork))
     VL= 0d0
     VR= 0d0
     rwork= 0d0
     work= 0d0

     info=0
     W=0.0d0

     if (N==1) then
        W=A(1, 1)
        VL(1, 1)= 1d0
        VR(1, 1)= 1d0
        return
     endif

     call  ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, &
                        WORK, LWORK, RWORK, INFO )
     if (info /= 0) then
        stop ">>> Error : something wrong happens in zgeev_pack"
     endif

     return
  end subroutine zgeev_pack


FUNCTION igamma_s(a,x)
  USE mo_kind, only: sp
  USE mo_nrutil, ONLY : assert
  use mo_nr, ONLY : gcf,gser
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: a,x
  REAL(SP) :: gln
  REAL(SP) :: igamma_s
  call assert( x >= 0.0,  a > 0.0, 'igamma_s args')
  if (x<a+1.0_sp) then
     igamma_s=1.0_sp-gser(a,x,gln)
  else
     igamma_s=gcf(a,x,gln)
  end if
  igamma_s = igamma_s * exp(gln)
END FUNCTION igamma_s

FUNCTION igamma_v(a,x)
  USE mo_kind, only: sp, i4, lgt
  USE mo_nrutil, ONLY : assert, assert_eq
  use mo_nr, ONLY : gcf,gser
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: a,x
  REAL(SP), DIMENSION(size(a)) :: gln
  REAL(SP), DIMENSION(size(a)) :: igamma_v
  LOGICAL(LGT), DIMENSION(size(x)) :: mask
  INTEGER(I4) :: ndum
  ndum=assert_eq(size(a),size(x),'igamma_v')
  call assert( all(x >= 0.0),  all(a > 0.0), 'igamma_v args')
  mask = (x<a+1.0_sp)
  igamma_v=merge(1.0_sp-gser(a,merge(x,0.0_sp,mask),gln), &
       gcf(a,merge(x,0.0_sp,.not. mask),gln),mask)
  igamma_v = igamma_v * exp(gln)
END FUNCTION igamma_v

FUNCTION digamma_s(a,x)
  USE mo_kind, only: dp
  USE mo_nrutil, ONLY : assert
  use mo_nr, ONLY : gcf,gser
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: a,x
  REAL(DP) :: gln
  REAL(DP) :: digamma_s
  call assert( x >= 0.0_dp,  a > 0.0_dp, 'digamma_s args')
  if (x<a+1.0_dp) then
     digamma_s=1.0_dp-gser(a,x,gln)
  else
     digamma_s=gcf(a,x,gln)
  end if
  digamma_s = digamma_s * exp(gln)
END FUNCTION digamma_s

FUNCTION digamma_v(a,x)
  USE mo_kind, only: dp, i4, lgt
  USE mo_nrutil, ONLY : assert, assert_eq
  use mo_nr, ONLY : gcf, gser
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: a,x
  REAL(DP), DIMENSION(size(a)) :: gln
  REAL(DP), DIMENSION(size(a)) :: digamma_v
  LOGICAL(LGT), DIMENSION(size(x)) :: mask
  INTEGER(I4) :: ndum
  ndum=assert_eq(size(a),size(x),'digamma_v')
  call assert( all(x >= 0.0_dp),  all(a > 0.0_dp), 'digamma_v args')
  mask = (x<a+1.0_dp)
  digamma_v=merge(1.0_dp-gser(a,merge(x,0.0_dp,mask),gln), &
       gcf(a,merge(x,0.0_dp,.not. mask),gln),mask)
  digamma_v = digamma_v * exp(gln)
END FUNCTION digamma_v


program gen_diamond

   !-------------------------------------------------------------
   ! Program to generate a diamond lattice with given
   ! lengths in the x-, y-, and z- directions.
   ! The lattice is centerd at (0,0,0)
   !-------------------------------------------------------------

   implicit none

   integer :: i, j, k, ipm, jpm, kpm, coordinate, atom, p, q
   integer :: n1, n2, n3 ! how many times to translate in
                              ! each direction. Will translate that many
                              ! times in both the plus and minus
                              ! directions
   real(kind=8), parameter :: d1 = 8.0d0 ! length in x-direction in angst.
   real(kind=8), parameter :: d2 = 8.0d0 ! length in y-direction in angst.
   real(kind=8), parameter :: d3 = 8.0d0 ! length in z-direction in angst.
   real(kind=8), parameter :: a = 3.57d0 !lattice constant of diamond (ang.)
   real(kind=8), dimension(2), parameter :: pm = (/ 1.0d0, -1.0d0 /) ! plus
                                                                     ! or
                                                                     ! minus
   real(kind=8), dimension(3) :: center ! center of mass
   real(kind=8), dimension(3) :: atom_coordinates
   real(kind=8), dimension(8,3) :: unit_cell
   real(kind=8), dimension(3,8) :: transposed_unit_cell
   real(kind=8), allocatable, dimension(:,:) :: first_cell
   integer :: io, nlines
   character(len=12) :: read_char
   character(len=200) :: current_line

   ! Determine how many times you want to translate in each direction:
   ! (some large enough number of times)
   n1 = int( (d1/a)/2.0d0 + 3.0d0 )
   n2 = int( (d2/a)/2.0d0 + 3.0d0 )
   n3 = int( (d3/a)/2.0d0 + 3.0d0 )

   ! Independent (basis) points in graphite:
   unit_cell = transpose(reshape( (/ 0.0d0, 0.0d0, 0.0d0, &
      0.5d0, 0.5d0, 0.0d0, 0.5d0, 0.0d0, 0.5d0, 0.0d0, &
      0.5d0, 0.5d0, 3.0d0/4.0d0, 3.0d0/4.0d0, 3.0d0/4.0d0, &
      3.0d0/4.0d0, 1.0d0/4.0d0, 1.0d0/4.0d0, 1.0d0/4.0d0, &
      3.0d0/4.0d0, 1.0d0/4.0d0, 1.0d0/4.0d0, 1.0d0/4.0d0, &
      3.0d0/4.0d0 /), shape(transposed_unit_cell) ))

   ! Scale the basis points by the lattice constant:
   do i = 1, size(unit_cell,1)
      do j = 1, size(unit_cell,2)
         unit_cell(i,j) = unit_cell(i,j)*a
      end do
   end do

   ! Write the first cell
   open (unit=7, file='first_cell', status='new', action='write')
   do i = 0,1
      do j = 0,1
         do k = 0,1
            ! for the plus directio:
            ipm = 1
            jpm = 1
            kpm = 1
            ! For each atom in the unit cell:
            do atom = 1, size(unit_cell,1)
               ! For each coordinate of that atom
               atom_coordinates(1) = unit_cell(atom,1) + &
                  a*pm(ipm)*dble(i)
               atom_coordinates(2) = unit_cell(atom,2) + &
                  a*pm(jpm)*dble(j)
               atom_coordinates(3) = unit_cell(atom,3) + &
                  a*pm(kpm)*dble(k)
               ! If the coordinates of this atom are
               ! within the requested dimensions of the slab,
               ! then write them to the output file:
               if (atom_coordinates(1) <= a+0.1) then
                  if (atom_coordinates(2) <= a+0.1) then
                     if (atom_coordinates(3) <= a+0.1) then
                        write(7,*) (atom_coordinates(coordinate), &
                        coordinate = 1, 3)
                     end if
                  end if
               end if
            end do
         end do
      end do
   end do
   close(7)

   ! Read the first cell:
   open (unit=8, file='first_cell', status='old', action='read')
   ! count the number of lines in first_cell:
   nlines = 0
   do
      read(8,*,iostat=io) read_char
      if (io/=0) exit
      nlines = nlines + 1
      write(*,*) nlines
   end do

   rewind(8)
   allocate(first_cell(nlines,3))
   do p = 1, nlines
      read(8,*) first_cell(p,1), first_cell(p,2), first_cell(p,3)
      write(*,*) (first_cell(p,q), q = 1,3)
   end do
   close(8)

   ! Find center of mass of unit cell (first_cell is the
   ! actual unit cell):
   do i = 1,3
      center(i) = 0.0d0
      do j = 1, size(first_cell,1)
         center(i) = center(i) + first_cell(j,i)
      end do
      center(i) = center(i) / dble(size(first_cell,1))
   end do
   write(*,*) "center:", center
   deallocate(first_cell)

   ! move center of mass to 0,0,0
   do i = 1, 3
      do j = 1, size(unit_cell,1)
         unit_cell(j,i) = unit_cell(j,i) - center(i)
      end do
   end do

   ! Write the .in file with the geometry of the
   ! generated diamond lattice:
   open (unit=2, file='diamond.in', status='new', action='write')

   write(2,*) "O", 0.0d0, 0.0d0, 0.0d0
   write(2,*) "N", center(1), center(2), center(3)

   ! For the number of times the unit cell has to be repliicated
   ! in the x-direction
   do i = 0,n1
      ! For the number of times the unit cell has to be repliicated
      ! in the y-direction
      do j = 0, n2
         ! For the number of times the unit cell has to be repliicated
         ! in the z-direction
         do k = 0, n3
            ! for the plus and minus of x:
            do ipm = 1, 2
               ! for the plus and minus of y:
               do jpm = 1, 2
                  ! for the plus and minus of z:
                  do kpm = 1,2
                     if ( i == 0 ) then
                        if ( ipm == 2 ) then
                           cycle ! Do not repeat twice for +0 and -0
                        end if
                     end if
                     if ( j == 0 ) then
                        if ( jpm == 2 ) then
                           cycle
                        end if
                     end if
                     if ( k == 0 ) then
                        if ( kpm == 2 ) then
                           cycle
                        end if
                     end if
                     ! For each atom in the unit cell:
                     do atom = 1, size(unit_cell,1)
                        ! For each coordinate of that atom
                        atom_coordinates(1) = unit_cell(atom,1) + &
                           a*pm(ipm)*dble(i)
                        atom_coordinates(2) = unit_cell(atom,2) + &
                           a*pm(jpm)*dble(j)
                        atom_coordinates(3) = unit_cell(atom,3) + &
                           a*pm(kpm)*dble(k)
                        ! If the coordinates of this atom are
                        ! within the requested dimensions of the slab,
                        ! then write them to the output file:
                        if (dabs(atom_coordinates(1)) <= d1/2.0d0) then
                           if (dabs(atom_coordinates(2)) <= d2/2.0d0) then
                              if (dabs(atom_coordinates(3)) <= d3/2.0d0) then
                                 write(2,'(A1,A4,3F15.9)') "C", "    ",&
                                    (atom_coordinates(coordinate), &
                                    coordinate = 1, 3)
                              end if
                           end if
                        end if
                     end do
                  end do
               end do
            end do
         end do
      end do
   end do

   close(2)

   ! Write a .xyz file:
   open (unit=3, file='diamond.in', status='old', action='read')

   ! count the number of lines in particle.in:
   nlines = 0
   do
      read(3,*,iostat=io) read_char
      if (io/=0) exit
      nlines = nlines + 1
   end do

   rewind(3)

   open (unit=4, file='diamond.xyz', status='new', action='write')

   write(4,*) nlines
   write(4,*) 'kflklv'
   do i = 1, nlines
      read(3,'(A100)') current_line
      write(4,*) trim(current_line)
   end do

   close(3)
   close(4)

end program gen_diamond


program mxm
  integer, parameter :: r8  = selected_real_kind(p=15,r=307)
  parameter(N=4000)
  real(r8) a(N,N), b(N,N) , c(N,N), temp
  integer i, j, l, c1, c2

  call random_number(a)
  call random_number(b)

  call system_clock(count=c1)

!$acc kernels
  do j = 1,N
     do l = 1,N
       do i = 1,N
         c(i,j) = c(i,j) + a(i,l)*b(l,j)
       enddo
     enddo
  enddo
!$acc end kernels
  call system_clock(count=c2)

  write(*,*) "Calc time : ",(c2-c1)/1e6," secs"
  write(*,*) c(1,1), c(N,N), sum(c)
end program mxm


       PARAMETER (NSTEP=25)
       DIMENSION PHI(0:NSTEP)

       GAUSS(X,T)=EXP(-20.*(X-.5)**2/(1.+80*T))/SQRT(1+80*T)
       EXACT(X,T)=GAUSS(X,T)-GAUSS(X-1.,T)-GAUSS(X+1.,T)

       H=1./NSTEP

50     PRINT *, ' Enter time step and total time (0 to stop)'
       READ *,DT,TIME
       IF (DT .EQ. 0.) STOP
       NITER=TIME/DT
       DTH=DT/H**2

       T=0.
       PHI(0)=0.
       PHI(NSTEP)=0.
       DO 10 IX=1,NSTEP-1
          PHI(IX)=EXACT(IX*H,T)
10     CONTINUE

       DO 20 ITER=1,NITER
          POLD=0.
          DO 30 IX=1,NSTEP-1
             PNEW=PHI(IX)+DTH*(POLD+PHI(IX+1)-2*PHI(IX))
             POLD=PHI(IX)
             PHI(IX)=PNEW
30        CONTINUE
          IF (MOD(ITER,10) .EQ. 0) THEN
             PRINT *, ' iteration = ', ITER, ' time = ',ITER*DT
             T=ITER*DT
             DO 40 IX=1,NSTEP-1
                DIFF=PHI(IX)-EXACT(IX*H,T)
                PRINT *, ' phi = ', PHI(IX),' error = ', DIFF
40           CONTINUE
          END IF
20     CONTINUE

       GOTO 50
       END


*DECK CHFIE
      REAL FUNCTION CHFIE (X1, X2, F1, F2, D1, D2, A, B)
C***BEGIN PROLOGUE  CHFIE
C***SUBSIDIARY
C***PURPOSE  Evaluates integral of a single cubic for PCHIA
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      SINGLE PRECISION (CHFIE-S, DCHFIE-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C          CHFIE:  Cubic Hermite Function Integral Evaluator.
C
C     Called by  PCHIA  to evaluate the integral of a single cubic (in
C     Hermite form) over an arbitrary interval (A,B).
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        REAL  X1, X2, F1, F2, D1, D2, A, B
C        REAL  VALUE, CHFIE
C
C        VALUE = CHFIE (X1, X2, F1, F2, D1, D2, A, B)
C
C   Parameters:
C
C     VALUE -- (output) value of the requested integral.
C
C     X1,X2 -- (input) endpoints if interval of definition of cubic.
C
C     F1,F2 -- (input) function values at the ends of the interval.
C
C     D1,D2 -- (input) derivative values at the ends of the interval.
C
C     A,B -- (input) endpoints of interval of integration.
C
C***SEE ALSO  PCHIA
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   820730  DATE WRITTEN
C   820805  Converted to SLATEC library version.
C   870813  Minor cosmetic changes.
C   890411  1. Added SAVE statements (Vers. 3.2).
C           2. Added SIX to REAL declaration.
C   890411  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated AUTHOR section in prologue.  (WRB)
C   930503  Corrected to set VALUE=0 when IERR.ne.0.  (FNF)
C   930504  Eliminated IERR and changed name from CHFIV to CHFIE.  (FNF)
C***END PROLOGUE  CHFIE
C
C  Programming notes:
C  1. There is no error return from this routine because zero is
C     indeed the mathematically correct answer when X1.EQ.X2 .
C**End
C
C  DECLARE ARGUMENTS.
C
      REAL  X1, X2, F1, F2, D1, D2, A, B
C
C  DECLARE LOCAL VARIABLES.
C
      REAL  DTERM, FOUR, FTERM, H, HALF, PHIA1, PHIA2, PHIB1, PHIB2,
     *      PSIA1, PSIA2, PSIB1, PSIB2, SIX, TA1, TA2, TB1, TB2, THREE,
     *      TWO, UA1, UA2, UB1, UB2
      SAVE HALF, TWO, THREE, FOUR, SIX
C
C  INITIALIZE.
C
      DATA  HALF /0.5/,  TWO /2./,  THREE /3./,  FOUR /4./,  SIX /6./
C
C  VALIDITY CHECK INPUT.
C
C***FIRST EXECUTABLE STATEMENT  CHFIE
      IF (X1 .EQ. X2)  THEN
         CHFIE = 0
      ELSE
         H = X2 - X1
         TA1 = (A - X1) / H
         TA2 = (X2 - A) / H
         TB1 = (B - X1) / H
         TB2 = (X2 - B) / H
C
         UA1 = TA1**3
         PHIA1 = UA1 * (TWO - TA1)
         PSIA1 = UA1 * (THREE*TA1 - FOUR)
         UA2 = TA2**3
         PHIA2 =  UA2 * (TWO - TA2)
         PSIA2 = -UA2 * (THREE*TA2 - FOUR)
C
         UB1 = TB1**3
         PHIB1 = UB1 * (TWO - TB1)
         PSIB1 = UB1 * (THREE*TB1 - FOUR)
         UB2 = TB2**3
         PHIB2 =  UB2 * (TWO - TB2)
         PSIB2 = -UB2 * (THREE*TB2 - FOUR)
C
         FTERM =   F1*(PHIA2 - PHIB2) + F2*(PHIB1 - PHIA1)
         DTERM = ( D1*(PSIA2 - PSIB2) + D2*(PSIB1 - PSIA1) )*(H/SIX)
C
         CHFIE = (HALF*H) * (FTERM + DTERM)
      ENDIF
C
      RETURN
C------------- LAST LINE OF CHFIE FOLLOWS ------------------------------
      END


subroutine mg_correction(u_h, nx, ny, xi, xf, e_h, alpha)
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi, xf
real(kind=dp), intent(in), dimension(nx,xi-1:xf+1):: e_h
real(kind=dp), intent(inout), dimension(nx,xi-1:xf+1):: u_h
real(kind=dp), intent(in):: alpha
integer:: i,j
! Correct the values of u_h using e_h
! Input
! u_h   Variable in grid h
! e_h   Estimated error in grid h
! h     grid spacing
!
! Output
! u_h   Updated value of u_h

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012

do j = xi,xf

    do i = 2,nx-1

        u_h(i,j) = u_h(i,j) + alpha*e_h(i,j)

    end do

end do

call exchange_data(u_h, nx, xi, xf)

end subroutine


!##############################################################################
!# Tutorial 003c: Using the parser
!##############################################################################

module tutorial003c

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput
  use fparser

  implicit none
  private

  public :: start_tutorial003c

contains

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

  subroutine start_tutorial003c

    ! Declare some variables
    integer :: ix,iy
    real(DP) :: dval1, dval2

    type(t_fparser) :: rparser
    character(LEN=1), dimension(2), parameter :: Svariables = (/ "X", "Y" /)
    real(DP), dimension(2) :: Dparams

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 003c")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Initialise the parser.
    ! =================================

    call fparser_init()

    ! =================================
    ! Evaluate the functions in the
    ! points of a 5x5 mesh.
    ! =================================

    ! ----------------
    ! Parse functions
    ! ----------------
    call fparser_create (rparser, 2)
    call fparser_parseFunction (rparser, 1, "SIN(_PI*X) * SIN(_PI*Y)", Svariables)
    call fparser_parseFunction (rparser, 2, "16*X*Y*(1-X)*(1-Y)", Svariables)

    ! ----------------
    ! Evaluate
    ! ----------------
    do iy = 0,4
      do ix = 0,4

        ! Prepare the input variables. The variables are in the same
        ! order and the same number as prescribed by Svariables above
        Dparams = (/ real(ix,DP) / 4.0_DP, &
                     real(iy,DP) / 4.0_DP /)

        ! Evaluate
        call fparser_evalFunction (rparser, 1, Dparams, dval1)
        call fparser_evalFunction (rparser, 2, Dparams, dval2)

        call output_line (" f ("  // trim(sys_sdL(Dparams(1),3)) // &
                          ", "    // trim(sys_sdL(Dparams(2),3)) // &
                          ") = "  // trim(sys_sdL(dval1,3))      // &
                          ",  " // &
                          " g ("  // trim(sys_sdL(Dparams(1),3)) // &
                          ", "    // trim(sys_sdL(Dparams(2),3)) // &
                          ") = "  // trim(sys_sdL(dval2,3)) )
      end do
    end do

    ! ----------------
    ! Release
    ! ----------------
    call fparser_release (rparser)

    ! =================================
    ! Cleanup
    ! =================================

    call fparser_done ()

  end subroutine

end module


MODULE nrtype
  INTEGER, PARAMETER :: DP = KIND(1.0D0)
  REAL(DP), PARAMETER :: PI=3.141592653589793238462643383279502884197_dp
  REAL(DP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_dp
  REAL(DP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_dp
END MODULE nrtype

Module fft_coeff
  IMPLICIT NONE
  COMPLEX(KIND=8), ALLOCATABLE, DIMENSION(:) :: coef_d1, coef_d2, coef_d3, coef_d4
  INTEGER(KIND=4) :: fft_coeff_flag =0, fft_plan_flag=0, nend

  INTEGER(KIND=8) :: p_bw0, p_fw2
  REAL(KIND=8), ALLOCATABLE, DIMENSION(:) :: hh, hh2
  COMPLEX(KIND=8), ALLOCATABLE, DIMENSION(:) :: h_fft, h2_fft

  INCLUDE 'fftw3.f90'

  CONTAINS

    SUBROUTINE calculate_modes_r2c(nn, ll)
      USE nrtype
      IMPLICIT NONE

      INTEGER(KIND=4), INTENT(IN) :: nn
      REAL(KIND=8), INTENT(IN) :: ll
      INTEGER(KIND=4) :: k, kend

      fft_coeff_flag = 1
!
! nend: total number of Fourier coefficients
!
      IF(MOD(nn,2).EQ.0)THEN
         kend = nn/2
         nend = nn/2+1
      ELSE
         kend = (nn+1)/2
         nend = (nn+1)/2
      END IF

      ALLOCATE(coef_d1(1:nend))
      ALLOCATE(coef_d2(1:nend))
      ALLOCATE(coef_d3(1:nend))
      ALLOCATE(coef_d4(1:nend))
!
!  Setup fourier coefficients of derivatives
!
      coef_d1(1)=(0.0d0, 0.0d0)
      coef_d2(1)=(0.0d0, 0.0d0)
      coef_d3(1)=(0.0d0, 0.0d0)
      coef_d4(1)=(0.0d0, 0.0d0)
      DO k = 2, kend
         coef_d1(k) = DCMPLX(0.0d0, TWOPI*DBLE(k-1)/ll)
         coef_d2(k) = DCMPLX(-(TWOPI*DBLE(k-1)/ll)**2, 0.0d0)
         coef_d3(k) = DCMPLX(0.0d0, -(TWOPI*DBLE(k-1)/ll)**3)
         coef_d4(k) = DCMPLX((TWOPI*DBLE(k-1)/ll)**4, 0.0d0)
      END DO
!
!  Coefficients for the Nyquist mode
!
      IF(MOD(nn,2).EQ.0)THEN
         coef_d1(nend) = (0.0d0, 0.0d0)
         coef_d2(nend) = DCMPLX(-(TWOPI*DBLE(nn/2)/ll)**2, 0.0d0)
         coef_d3(nend) = (0.0d0, 0.0d0)
         coef_d4(nend) = DCMPLX((TWOPI*DBLE(nn/2)/ll)**4, 0.0d0)
      END IF

      RETURN
    END SUBROUTINE calculate_modes_r2c

    SUBROUTINE create_fftw_plan(nn)
      IMPLICIT NONE
      INTEGER(KIND=4), INTENT(IN) :: nn
      INTEGER :: kend

      fft_plan_flag = 1

      IF(MOD(nn,2).EQ.0)THEN
         kend = nn/2+1
      ELSE
         kend = (nn+1)/2
      END IF

      ALLOCATE(hh(1:nn))
      ALLOCATE(hh2(1:nn))

      ALLOCATE(h_fft(1:kend))
      ALLOCATE(h2_fft(1:kend))

      CALL dfftw_plan_dft_c2r_1d(p_bw0, nn, h_fft,  hh,      FFTW_MEASURE+FFTW_PRESERVE_INPUT)
      CALL dfftw_plan_dft_r2c_1d(p_fw2, nn, hh2,    h2_fft,  FFTW_MEASURE)

      RETURN
    END SUBROUTINE create_fftw_plan

END Module fft_coeff

!----------------------------------------------------------------------
!----------------------------------------------------------------------
!  ks : Kuramoto-Sivashinski equation
!
!   h_t - c*h_x + h*h_x + h_xx + nu*h_xxxx=0, x\in[-pi,pi]
!   with periodic boundary conditions
!
!  Only derivatives are calculated using FFTW in the Fourier space
!
!----------------------------------------------------------------------
SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
  USE nrtype
  USE fft_coeff
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
  REAL(DP), INTENT(IN) :: U(NDIM), PAR(*)
  REAL(DP), INTENT(OUT) :: F(NDIM), DFDU(NDIM,NDIM), DFDP(NDIM,*)
  COMPLEX(KIND=8) :: F_fft(NDIM)

  INTEGER :: nn, kk
  REAL(DP) :: nu, cc

  nn = NDIM

! Initialisation: calculate fourier modes
  IF(fft_coeff_flag.EQ.0) CALL calculate_modes_r2c(nn, TWOPI)

! Initilize FFTW and create plans
  IF(fft_plan_flag.EQ.0) CALL create_fftw_plan(nn)

! obtain cc and h_fft
  cc = U(1)
  h_fft(1) = DCMPLX(0.0d0, 0.0d0)
  IF(MOD(nn,2).EQ.0)THEN
     DO kk = 2, nn/2
        h_fft(kk) = DCMPLX(U(2*kk-2), U(2*kk-1))
     END DO
     h_fft(nend) = DCMPLX(U(nn), 0.0d0)
  ELSE
     DO kk = 2, (nn+1)/2
        h_fft(kk) = DCMPLX(U(2*kk-2), U(2*kk-1))
     END DO
  END IF

! Compute hh from h_fft:
  CALL dfftw_execute_dft_c2r(p_bw0, h_fft, hh)
  DO kk=1, nn
     hh(kk) = hh(kk)/DBLE(nn)
  END DO

! Compute h^2
  DO kk=1, nn
     hh2(kk) = hh(kk)**2
  END DO

! Compute h2_fft: Fourier(h^2)
  CALL dfftw_execute_dft_r2c(p_fw2, hh2, h2_fft)

  nu   = PAR(1)

  DO kk=1, nend
     F_fft(kk) = coef_d1(kk)*(cc*h_fft(kk) - 0.5d0*h2_fft(kk)) &
          - (coef_d2(kk)+nu*coef_d4(kk))*h_fft(kk)
  END DO

  F(1) = U(2)
  IF(MOD(nn,2).EQ.0)THEN
     DO kk = 2, nn/2
        F(2*kk-2) = DREAL(F_fft(kk))
        F(2*kk-1) = DIMAG(F_fft(kk))
     END DO
     F(nn) = DREAL(F_fft(nend))
  ELSE
     DO kk = 2, (nn+1)/2
        F(2*kk-2) = DREAL(F_fft(kk))
        F(2*kk-1) = DIMAG(F_fft(kk))
     END DO
  END IF

  RETURN
END SUBROUTINE FUNC

SUBROUTINE STPNT(NDIM,U,PAR,T)
  USE nrtype
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  REAL(DP), INTENT(INOUT) :: U(NDIM),PAR(*)
  REAL(DP), INTENT(IN) :: T
  INTEGER :: nn, kk
  REAL(DP) :: nu

  nn = NDIM

! Initialise the equation parameters:
!  nu = 1.0d0
  nu = 1.0d0/(2.0d0**2)
!  nu = 1.0d0/(4.0d0**2)

  PAR(1) = nu

!  par(11) = 1.0; ! Internal period, set to one and do not touch

! Initial condition
! U(1) is the traveling wave speed
  DO kk = 1, NDIM
     U(kk) = 0.0d0
  END DO

!  U(3) = 1.0d-2
  U(5) = 1.0d-1
!  U(7) = 1.0d-2
!  U(9) = 1.0d-2

  RETURN
END SUBROUTINE STPNT

SUBROUTINE BCND
  RETURN
END SUBROUTINE BCND

SUBROUTINE ICND
  RETURN
END SUBROUTINE ICND

SUBROUTINE PVLS(NDIM,U,PAR)
!     ---------- ----

  USE nrtype
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  REAL(DP), INTENT(IN) :: U(NDIM)
  REAL(DP), INTENT(INOUT) :: PAR(*)

  REAL(DP), EXTERNAL :: GETP
  INTEGER :: k
  REAL(DP) :: sumall

  sumall = 0.0d0
  DO k=2, NDIM
     sumall = sumall + 2.0d0*(getp("NRM", k, U)**2)
  END DO
  PAR(45) = DSQRT(sumall)/DBLE(NDIM)

  RETURN
END SUBROUTINE PVLS

SUBROUTINE FOPT
  RETURN
END SUBROUTINE FOPT


PROGRAM F006

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER :: N, N_SUM, SQUARE_OF_SUM, SUM_OF_SQUARE

    N = 100
    N_SUM = (N * (N + 1)) / 2
    SQUARE_OF_SUM = N_SUM * N_SUM;
    SUM_OF_SQUARE = (N * (N + 1) * ((2 * N) + 1)) / 6;

    PRINT ('(I0)'), SQUARE_OF_SUM - SUM_OF_SQUARE

END PROGRAM F006


C+PGCT01    -- function defining standard colour table

      REAL FUNCTION PGCT01 (RGB, CI, CIMIN, CIMAX)
      INTEGER RGB,CI,CIMIN,CIMAX
C-----------------------------------------------------------------------
C Function defining standard colour table 01.  This function can be used
C as an argument to routine PGSCT.
C
C Returns:
C  PGCT01   : The red, green or blue intensity for a given colour index,
C             as a real number in the range 0.0 to 1.0, for the colour
C             table defined by:
C
C                red   = sin(3x)**2,
C                green = sin(5x)**2,
C                blue  = sin(7x)**2,   x = (ci-cimin)/(cimax-cimin)
C
C Arguments:
C  RGB (input, integer) : colour (red=1, green=2, blue=3)
C  CI (input, integer) : colour index in the range [CIMIN,CIMAX]
C  CIMIN (input, integer) : minimum colour index
C  CIMAX (input, integer) : maximum colour index
C
C 29-May-1989 - [DJT].
C-----------------------------------------------------------------------
      REAL X
      INTEGER R,G,B
      PARAMETER (R=1,G=2,B=3)
C
      X = FLOAT(CI-CIMIN)/FLOAT(CIMAX-CIMIN)
      IF (RGB.EQ.R) THEN
        PGCT01 = SIN(X*3.)**2
      ELSEIF (RGB.EQ.G) THEN
        PGCT01 = SIN(X*5.)**2
      ELSEIF (RGB.EQ.B) THEN
        PGCT01 = SIN(X*7.)**2
      ENDIF
C
      END
C
C
C+PGSCT     -- set colour tables

      SUBROUTINE PGSCT (FUNC)
C-----------------------------------------------------------------------
C Sets colour tables, for devices supporting colour graphics.
C
C
C-----------------------------------------------------------------------

      REAL      FUNC
      INTEGER   ICOL,ICMIN,ICMAX
      INTEGER   R,G,B
      PARAMETER (R=1,G=2,B=3)
C
      CALL PGQCIR( ICMIN, ICMAX )
      DO ICOL=ICMIN,ICMAX
            CALL PGSCR(ICOL,FUNC(R,ICOL,ICMIN,ICMAX),
     :                      FUNC(G,ICOL,ICMIN,ICMAX),
     :                      FUNC(B,ICOL,ICMIN,ICMAX))
      ENDDO
C
      CALL PGUPDT
C
      END
C
C
       real*4 function ct_enh_col( rgb, ci, cimin, cimax )
C      ---------------------------------------------------
C
C Function defining an enhanced colour-scale.
C
C defining:
C             x = (ci-cimin)/(cimax-cimin)
C then:
C   ct_enh_col = ((x-start_colour)/(upper_bound-lower_bound))**power_law
C
C for:
C  lower_bound,start_colour  <=  x  <=  upper_bound
C
C otherwise:
C   ct_enh_col = 0.0 or 1.0
C
C Where the parameters upper_bound, lower_bound and power_law are passed
C in common and depend on the colour index
*-

       include 'pg_cttools.inc'

       integer        rgb, ci, cimin, cimax
       real*4         x

       x  = (float(ci-cimin)/float(cimax-cimin))
       if (x.ge.lower_bound .and. x.le.upper_bound) then
         if ((x-lower_bound).ge.col_starts(rgb)) then
           ct_enh_col = (       (x-col_starts(rgb))
     *                     /(upper_bound-col_starts(rgb))
     *                  )**col_power_law(rgb)
         else
           ct_enh_col = 0.0
         end if
       else if (x.lt.lower_bound) then
         ct_enh_col = 0.0
       else
         ct_enh_col = 1.0
       end if
       end
C
       real*4 function ct_enh_grey( rgb, ci, cimin, cimax )
C      ----------------------------------------------------
C
C Function defining an enhanced grey-scale.
C
C defining:
C             x = (ci-cimin)/(cimax-cimin)
C then:
C   ct_enh_grey = ((x-lower_bound)/(upper_bound-lower_bound))**power_law
C
C for:
C  lower_bound  <=  x  <=  upper_bound
C
C otherwise:
C   ct_enh_grey = 0.0
C
C Where the parameters upper_bound, lower_bound and power_law are passed
C in common.
*-

       include 'pg_cttools.inc'

       integer        rgb, ci, cimin, cimax
       real*4         x
       x  = (float(ci-cimin)/float(cimax-cimin))
       if (x.ge.lower_bound .and. x.le.upper_bound) then
         ct_enh_grey = ((x-lower_bound)/(upper_bound-lower_bound))**
     *                 power_law
       else if (x.lt.lower_bound) then
         ct_enh_grey = 0.0
       else
         ct_enh_grey = 1.0
       end if
       end
C
       real*4 function ct_enh_inv_grey( rgb, ci, cimin, cimax )
C      --------------------------------------------------------
C
C Function defining an enhanced grey-scale.
C
C defining:
C             x = (cimax-ci)/(cimax-cimin)
C then:
C   ct_enh_inv_grey = ((x-lower_bound)/(upper_bound-lower_bound))**power
C
C for:
C  lower_bound  <=  x  <=  upper_bound
C
C otherwise:
C   ct_enh_inv_grey = 0.0
C
C Where the parameters upper_bound, lower_bound and power_law are passed
C in common.
*-

       include 'pg_cttools.inc'

       integer        rgb, ci, cimin, cimax
       real*4         x
       x  = (float(ci-cimin)/float(cimax-cimin))
       if (x.ge.lower_bound .and. x.le.upper_bound) then
         ct_enh_inv_grey = ((upper_bound-x)/(upper_bound-lower_bound))**
     *                 power_law
       else if (x.lt.lower_bound) then
         ct_enh_inv_grey = 1.0
       else
         ct_enh_inv_grey = 0.0
       end if
       end
C
C
       real*4 function ct_lin_grey( rgb, ci, cimin, cimax )
C      ----------------------------------------------------
C
C Function defining a standard linear grey-scale.
C
C    ct_lin_grey = (ci-cimin)/(cimax-cimin)
C
*-

       integer        rgb, ci, cimin, cimax
       ct_lin_grey  = (float(ci-cimin)/float(cimax-cimin))
       end
C
       real*4 function ct_lin_inv_grey( rgb, ci, cimin, cimax )
C      --------------------------------------------------------
C
C Function defining a standard linear inverted grey-scale.
C
C    ct_lin_inv_grey = (cimax-ci)/(cimax-cimin)
C
*-

       integer        rgb, ci, cimin, cimax
       ct_lin_inv_grey  = (float(cimax-ci)/float(cimax-cimin))
       end
C
C
       real*4 function ct_standard( rgb, ci, cimin, cimax )
C      ----------------------------------------------------
C
C Function defining an standard colour-scale.
C
C defining:
C             x = (ci-cimin)/(cimax-cimin)
C then:
C                red   = sin(power(red)*x)**2,
C                green = sin(power(green)*x)**2,
C                blue  = sin(power(blue)*x)**2
*-

       include 'pg_cttools.inc'

       integer        rgb, ci, cimin, cimax
       real*4         x

       x  = (float(ci-cimin)/float(cimax-cimin))
       ct_standard = (sin( col_index(rgb)*x ))**2
       end
C
C

       subroutine pgplotctmod(type,rvals)
C      ----------------------------------
C
C Modification of the colour lookup table
C
C Given:
C   type
       integer   type
C   control values
       real*4    rvals(*)
C
C-
       include 'pg_cttools.inc'

       real*4         pgct01, ct_lin_grey, ct_enh_grey, ct_enh_col
       real*4         ct_lin_inv_grey, ct_enh_inv_grey
       external       pgct01, ct_standard
       external       ct_lin_grey, ct_enh_grey
       external       ct_enh_col, ct_lin_inv_grey, ct_enh_inv_grey

       integer        n

       do n=1,18
          ct_vals(n) = rvals(n)
       enddo
       if (type.eq.1) then
         call pgsct(pgct01)
       elseif (type.eq.2) then
         call pgsct(ct_standard)
       elseif (type.eq.3) then
         call pgsct(ct_lin_grey)
       elseif (type.eq.4) then
         call pgsct(ct_enh_grey)
       elseif (type.eq.5) then
         call pgsct(ct_lin_inv_grey)
       elseif (type.eq.6) then
         call pgsct(ct_enh_inv_grey)
       elseif (type.eq.7) then
         call pgsct(ct_enh_col)
       endif

       end


module test_stats_randn

    use forlab_stats, only: randn, mean
    use stdlib_error, only: check
    implicit none
    private

    public :: test_stats_randn_real

contains

    subroutine test_stats_randn_real

        print *, "*<DEBUG>* checking `test_stats_randn_real`.."

        call check(mean(randn(mean=0.0, std=2.0, ndim=100)) <=  2.0, &
                   msg="mean(randn(mean=0.0, std=2.0, ndim=10) <=  2.0) failed.")
        call check(mean(randn(mean=0.0, std=2.0, ndim=100)) >= -2.0, &
                   msg="mean(randn(mean=0.0, std=2.0, ndim=10) >= -2.0) failed.")

    end subroutine test_stats_randn_real

end module test_stats_randn


PROGRAM  Particle_2D_Box
    IMPLICIT NONE

    REAL, PARAMETER :: pi = acos(-1.0)
    REAL:: bl1, bl2, x, y, psi         ! bl is bond length
    CHARACTER*10:: filename
    INTEGER:: i, j, n1, n2, outunit
    bl1 = 1.
    bl2 = 1.
    WRITE(*, *) "Enter the quantum number n1, n2"
    READ *, n1, n2

    ! WRITE(fiblame, 10) "psi.", n
    ! 10 FORMAT(a, i0)
    WRITE(filename, fmt = "(a, i0, i0)") "psi.", n1, n2
    OPEN(UNIT = outunit, FILE = filename, FORM = "formatted")
    x = -0.01
    DO i = 1, 101
        x = x + 0.01
        y = -0.01
        DO j = 1, 101
            y = y + 0.01
            psi = 2.0 * sqrt(1./bl1*bl2) * sin(n1 * pi * x/bl1) * sin(n2 * pi * y/bl2);
            WRITE(outunit, *) x, y, psi, psi**2
        ENDDO
        WRITE(outunit, *)
    ENDDO
    CLOSE(outunit)
END


!> @file
!! check to see if value exceeds threshold

!  --------------------------------------------------------------
!> @brief Check if the gradient exceeds the threshold
!!
!! @param[in] blockno the block number
!! @param[in] qval the
!! @param[in] qmin the minimum q value
!! @param[in] qmax the maximum q value
!! @param[in] quad the value and adjacent values of q
!! @param[in] dx, dy the spacing in the x and y directions
!! @param[in] xc, yc the coordinate of the cell
!! @param[in] threshold the threshold
!! @param[in] init_flag true if in init stage
!! @param[in] is_ghost true if cell is a ghost cell
!! @return 1 if exceeds threshold, 0 if not, -1 if inconclusive.
!  --------------------------------------------------------------
integer function fclaw2d_clawpatch_gradient_exceeds_th(blockno,&
                                     qval,qmin,qmax,quad, &
                                     dx,dy,xc,yc,threshold, &
                                     init_flag, is_ghost)
    implicit none

    double precision :: qval,qmin,qmax,threshold
    double precision :: quad(-1:1,-1:1)
    double precision :: dx,dy, xc, yc
    integer :: blockno, init_flag
    logical(kind=4) :: is_ghost

    double precision :: dqx, dqy
    double precision :: xp, yp, zp, xpp, ypp, zpp, xpm, ypm, zpm
    double precision, dimension(3) :: t1, t2, t1inv, t2inv
    double precision, dimension(2,2) :: gmat, gmatinv
    double precision :: grad(3), dx2, dy2, d, ds

    integer*8 :: cont, get_context
    integer :: fclaw2d_map_is_used

    double precision :: clawpatch_gradient_dot
    integer :: refine
    integer :: m

    if (is_ghost) then
!!      # quad may have uninitialized values.  Test is inconclusive
        fclaw2d_clawpatch_gradient_exceeds_th = -1
        return
    endif

    cont = get_context()

    dx2 = 2*dx
    dy2 = 2*dy

    dqx = (quad(1,0) - quad(-1,0))/dx2
    dqy = (quad(0,1) - quad(0,-1))/dy2

    refine = 0
    if (fclaw2d_map_is_used(cont) .ne. 0) THEN
        CALL fclaw2d_map_c2m(cont,blockno,xc,yc,xp,yp,zp)
        CALL fclaw2d_map_c2m(cont,blockno,xc+dx,yc,xpp,ypp,zpp)
        CALL fclaw2d_map_c2m(cont,blockno,xc-dx,yc,xpm,ypm,zpm)
        t1(1) = (xpp - xpm)/dx2
        t1(2) = (ypp - ypm)/dx2
        t1(3) = (zpp - zpm)/dx2

        CALL fclaw2d_map_c2m(cont,blockno,xc,yc+dy,xpp,ypp,zpp)
        CALL fclaw2d_map_c2m(cont,blockno,xc,yc-dy,xpm,ypm,zpm)
        t2(1) = (xpp - xpm)/dy2
        t2(2) = (ypp - ypm)/dy2
        t2(3) = (zpp - zpm)/dy2

        gmat(1,1) = clawpatch_gradient_dot(t1,t1)
        gmat(1,2) = clawpatch_gradient_dot(t1,t2)
        gmat(2,1) = gmat(1,2)
        gmat(2,2) = clawpatch_gradient_dot(t2,t2)

        d = gmat(1,1)*gmat(2,2) - gmat(1,2)*gmat(2,1)

        gmatinv(1,1) = gmat(2,2)/d
        gmatinv(2,2) = gmat(1,1)/d
        gmatinv(1,2) = -gmat(1,2)/d
        gmatinv(2,1) = -gmat(2,1)/d

        do m = 1,3
            t1inv(m) = gmatinv(1,1)*t1(m) + gmatinv(1,2)*t2(m)
            t2inv(m) = gmatinv(2,1)*t1(m) + gmatinv(2,2)*t2(m)
            grad(m) = dqx*t1inv(m) + dqy*t2inv(m)
        end do
    else
        grad(1) = dqx
        grad(2) = dqy
        grad(3) = 0
    endif

    ds = sqrt(clawpatch_gradient_dot(grad,grad))

    if (ds .gt. threshold) then
        refine = 1
    endif

    fclaw2d_clawpatch_gradient_exceeds_th = refine

end function fclaw2d_clawpatch_gradient_exceeds_th

!  --------------------------------------------------------------
!> @brief Dot product of two vector
!!
!! @param[in] u, v the vectors
!! @return the dot product
!  --------------------------------------------------------------
double precision function clawpatch_gradient_dot(u,v)
    implicit none

    double precision :: u(3), v(3)

    clawpatch_gradient_dot = u(1)*v(1) + u(2)*v(2) + u(3)*v(3)

end function clawpatch_gradient_dot


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine hns(b,theta,rho,dg,sqrts0,xflow,h1,h2)
!
!     determine the flow depth h2 downstream of a hydraulic jump,
!     corresponding to a upstream flow depth of h1
!
      implicit none
!
      real*8 b,rho,dg,sqrts0,xflow,h1,h2,c2,f,df,dh2,hk,
     &  xflow2,tth,A1,yg1,A2,yg2,dA2dh2,dyg2dh2,theta
!
      call hcrit(xflow,rho,b,theta,dg,sqrts0,hk)
!
      h2=h1*(-1.d0+dsqrt(1.d0+8.d0*(hk/h1)**3))/2.d0
!
      if(dabs(theta).lt.1.d-10) return
!
!     hns for a trapezoid, non-rectangular cross section
!
      c2=rho*rho*dg*sqrts0
      xflow2=xflow*xflow
      tth=dtan(theta)
      A1=h1*(b+h1*tth)
      yg1=h1*(3.d0*b+2.d0*h1*tth)/(6.d0*(b+h1*tth))
!
!     Newton-Raphson iterations
!
      do
         A2=h2*(b+h2*tth)
         yg2=h2*(3.d0*b+2.d0*h2*tth)/(6.d0*(b+h2*tth))
         dA2dh2=b+2.d0*h2*tth
         dyg2dh2=((3.d0*b+4.d0*h2*tth)*(b+tth)
     &                    -tth*h2*(3.d0*b+2.d0*h2*tth))/
     &                    (6.d0*(b+h2*tth)**2)
         f=A2*xflow2+c2*(A1*A1*A2*yg1-A1*A2*A2*yg2)-A1*xflow2
         df=dA2dh2*xflow2+c2*(A1*A1*yg1*dA2dh2-2.d0*A1*A2*dA2dh2*yg2
     &                       -A1*A2*A2*dyg2dh2)
         dh2=f/df
         if(dabs(dh2)/h2.lt.1.d-3) exit
         h2=h2-dh2
      enddo
!
      write(*,*) 'hns ','h1= ',h1,'h2= ',h2,'hk= ',hk
!
      return
      end


! Harmonic Series
!
! How We Got From There To Here:
! A Story of Real Analysis
! page 130 - 132

      program Gamma
         implicit none
         integer :: n
         integer, parameter :: rp = selected_real_kind(15)
         integer :: i
         Real (kind = rp) :: a, gama, nPlusOne
         n = 1000000000
         nPlusOne = n + 1.0_rp
         a = 0.0_rp
         do i = 1,n,1
            a = (a + (1.0_rp/i))
         end do
         print *, a
         gama = a - log(nPlusOne)
         print *, "N + 1 = ", nPlusOne
         print *, "Gamma is approx: " , gama
      end program Gamma


MODULE PS4PARA
    IMPLICIT NONE
    INTEGER:: I ! FOR ITER
    REAL(KIND=8), PARAMETER:: ALPHA=1.5, BETA=0.9932
    REAL(KIND=8), DIMENSION(2), PARAMETER:: STATES=(/1.0, 0.5/)
    INTEGER, PARAMETER:: NZ=SIZE(STATES), NA=700
    REAL(KIND=8), DIMENSION(NZ, NZ), PARAMETER:: PI=TRANSPOSE(RESHAPE((/0.97, 0.03,0.5,0.5/),(/2,2/)))
    REAL(KIND=8), PARAMETER:: A_MIN=-2., A_MAX=5., STEPS=(A_MAX-A_MIN)/(FLOAT(NA)-1.)
    REAL(KIND=8), DIMENSION(NA), PARAMETER:: A_GRID=(/(I*STEPS, I=1, NA)/) + A_MIN - STEPS
    LOGICAL:: COMPLETE=.FALSE. ! COMPLETE MARKET IF 1 OR INCOMPLETE MARKET IF 0
END MODULE

MODULE PS4RES
    USE PS4PARA
    IMPLICIT NONE
    REAL(KIND=8):: HIGH_Q=1., LOW_Q=0.9932, Q
    REAL(KIND=8), DIMENSION(NA,NZ):: VFUNC=0., VFUNC_NEW=0., CONSUM_ARR, LAMBDA
    REAL(KIND=8), DIMENSION(NA*NZ):: STAT_DIST
    REAL(KIND=8), DIMENSION(NA*NZ,NA*NZ):: A_CHANGE_MAT
    REAL(KIND=8), DIMENSION(700):: LORENZ
    INTEGER, DIMENSION(NA,NZ):: PFUNC=0
END MODULE

PROGRAM PS4
    USE PS4PARA
    USE PS4RES
    IMPLICIT NONE
    INTEGER:: SROWIDX
    REAL(KIND=8):: ERROR_Q=100., ERROR_VFI, CRIT=1e-3
    REAL(KIND=8), DIMENSION(NA,NZ):: VFUNC_INCOMPLETE=0.

    DO WHILE (ERROR_Q> CRIT)
        PRINT*, "Q", Q
        Q = (HIGH_Q+LOW_Q)/2.
        ERROR_VFI=100.
        IF (COMPLETE) THEN
                ! MUST RUN THE INCOMPLETE VERSION PRIOR TO
                OPEN(UNIT=13, FILE='VFUNC', STATUS='OLD')
                DO SROWIDX=1,NA
                    READ(UNIT=13, FMT=*) VFUNC_INCOMPLETE(SROWIDX,:)
                ENDDO
                CLOSE(UNIT=13)
            DO WHILE (ERROR_VFI> CRIT)
                CALL BELLMAN_COMPLETE(ERROR_VFI, VFUNC_INCOMPLETE)
            ENDDO
        ELSE
            DO WHILE (ERROR_VFI> CRIT)
                CALL BELLMAN(ERROR_VFI)
            ENDDO
        ENDIF
        CALL POP_A_CHANGE_MAT()
        CALL FIND_STAT_DIST()
        CALL COMPUTE_ERROR(ERROR_Q)
    ENDDO
    PRINT*, "Q", Q
    CALL FIND_LORENZ()
    IF (COMPLETE) THEN
        CALL WELFARE(VFUNC_INCOMPLETE)
    ENDIF
    CALL WRITE_ALL()
END PROGRAM PS4

SUBROUTINE BELLMAN(ERROR_VFI)
    USE PS4PARA
    USE PS4RES
    IMPLICIT NONE
    REAL(KIND=8), INTENT(OUT):: ERROR_VFI
    REAL(KIND=8):: CONSUM, UTIL, COND_UTIL, CU, NU
    REAL(KIND=8), DIMENSION(NA,NZ):: ABS_DIFF
    INTEGER:: RIDX, CIDX, CHOICE

    DO RIDX=1, NA
        DO CIDX=1, NZ
            COND_UTIL=-1e10
            DO CHOICE=1, NA
                CONSUM = STATES(CIDX) + A_GRID(RIDX) - Q*A_GRID(CHOICE)
                IF (CONSUM>0.) THEN
                    CU = CONSUM**(1-ALPHA)/(1-ALPHA) ! CURRENT UTIL
                    NU = SUM(PI(CIDX,:)*VFUNC(CHOICE,:))! NEXT EXPECTED UTIL
                    UTIL = CU + BETA*NU
                    IF (UTIL>COND_UTIL) THEN
                        VFUNC_NEW(RIDX, CIDX)=UTIL
                        PFUNC(RIDX, CIDX)=CHOICE
                        COND_UTIL=UTIL
                        CONSUM_ARR(RIDX, CIDX) = CONSUM
                    ENDIF
                ENDIF
            ENDDO
        ENDDO
    ENDDO
    ABS_DIFF = ABS(VFUNC_NEW-VFUNC)
    ERROR_VFI = MAXVAL(ABS_DIFF)
    VFUNC = VFUNC_NEW

END SUBROUTINE

SUBROUTINE BELLMAN_COMPLETE(ERROR_VFI, VFUNC_INCOMPLETE)
    USE PS4PARA
    USE PS4RES
    IMPLICIT NONE
    REAL(KIND=8), INTENT(OUT):: ERROR_VFI
    REAL(KIND=8):: CONSUM, UTIL, COND_UTIL, CU, NOM, DENOM
    REAL(KIND=8), DIMENSION(NA,NZ):: ABS_DIFF
    REAL(KIND=8), DIMENSION(NA,NZ), INTENT(IN):: VFUNC_INCOMPLETE
    INTEGER:: RIDX, CIDX, CHOICE

    DO RIDX=1, NA
        DO CIDX=1, NZ
            COND_UTIL=-1e10
            DO CHOICE=1, NA
                CONSUM = STATES(CIDX) + A_GRID(RIDX) - Q*A_GRID(CHOICE)
                IF (CONSUM>0.) THEN
                    CU = CONSUM**(1-ALPHA)/(1-ALPHA) ! CURRENT UTIL
                    UTIL = CU ! COMPLETE MARKET NEXT UTIL= CURRENT UTIL
                    IF (UTIL>COND_UTIL) THEN
                        VFUNC_NEW(RIDX, CIDX)=UTIL
                        PFUNC(RIDX, CIDX)=CHOICE
                        COND_UTIL=UTIL
                        CONSUM_ARR(RIDX, CIDX) = CONSUM
                    ENDIF
                ENDIF
            ENDDO
        NOM = VFUNC_NEW(RIDX, CIDX) + 1/((1-ALPHA)*(1-BETA))
        DENOM = VFUNC_INCOMPLETE(RIDX, CIDX) + 1/((1-ALPHA)*(1-BETA))
        LAMBDA(RIDX, CIDX) = (NOM/DENOM)**(1/(1-ALPHA))-1
        ENDDO
    ENDDO
    ABS_DIFF = ABS(VFUNC_NEW-VFUNC)
    ERROR_VFI = MAXVAL(ABS_DIFF)
    VFUNC = VFUNC_NEW

END SUBROUTINE

SUBROUTINE POP_A_CHANGE_MAT()
    USE PS4PARA
    USE PS4RES
    IMPLICIT NONE
    INTEGER:: RIDX, CIDX, CUR_IDX, NEXT_IDX, CHOICE, NEXT_Z

    A_CHANGE_MAT=0.
    DO RIDX=1, NA
        DO CIDX=1, NZ
            CUR_IDX = 2*RIDX -2 + CIDX
            CHOICE=PFUNC(RIDX, CIDX)
            DO NEXT_Z=1, NZ
                NEXT_IDX= 2*CHOICE -2 + NEXT_Z
                A_CHANGE_MAT(CUR_IDX, NEXT_IDX) = A_CHANGE_MAT(CUR_IDX, NEXT_IDX)+ PI(CIDX, NEXT_Z)
            ENDDO
        ENDDO
    ENDDO
END SUBROUTINE

SUBROUTINE FIND_STAT_DIST()
    USE PS4PARA
    USE PS4RES
    IMPLICIT NONE
    REAL(KIND=8):: ERROR_STAT, CRIT_STAT=1e-3
    REAL(KIND=8), DIMENSION(NA*NZ) :: STAT_DIST_NEW, ABS_DIFF

    STAT_DIST= 1/(FLOAT(NA)*2.)
    ERROR_STAT=100.
    DO WHILE (ERROR_STAT>CRIT_STAT)
        STAT_DIST_NEW = MATMUL(STAT_DIST, A_CHANGE_MAT)
        ABS_DIFF = ABS(STAT_DIST_NEW-STAT_DIST)
        ERROR_STAT = MAXVAL(ABS_DIFF)
        STAT_DIST = STAT_DIST_NEW
    ENDDO
END SUBROUTINE

SUBROUTINE COMPUTE_ERROR(ERROR_Q)
    USE PS4PARA
    USE PS4RES
    IMPLICIT NONE
    REAL(KIND=8), INTENT(OUT):: ERROR_Q
    INTEGER:: RIDX, CIDX
    REAL(KIND=8):: NET_ASSET! MARKET CLEARING

    NET_ASSET = 0.
    DO RIDX=1, NA
        DO CIDX=1, NZ
            NET_ASSET = NET_ASSET + A_GRID(PFUNC(RIDX, CIDX))*STAT_DIST(2*RIDX -2 + CIDX)
        ENDDO
    ENDDO

    IF (NET_ASSET>0.) THEN
        HIGH_Q=Q
    ELSE
        LOW_Q = Q
    ENDIF
    ERROR_Q = ABS(HIGH_Q-LOW_Q)
END SUBROUTINE

SUBROUTINE FIND_LORENZ()
    USE PS4PARA
    USE PS4RES
    IMPLICIT NONE
    INTEGER:: RIDX
    REAL(KIND=8):: GINI
    REAL(KIND=8), DIMENSION(NA):: DEGREE

    DEGREE=(/(I*(1./FLOAT(NA)), I=1,NA)/)

    GINI= 0.
    LORENZ(1) = STAT_DIST(1)
      DO RIDX = 2, 700
          LORENZ(RIDX)= LORENZ(RIDX-1) + STAT_DIST(RIDX*2-2+1) + STAT_DIST(RIDX*2-2+2)
          GINI = GINI + ABS(DEGREE(RIDX)-LORENZ(RIDX))
      ENDDO
    PRINT*, "degree", degree(na), degree(na-1)
    PRINT*,"GINI", GINI/FLOAT(NA)
END SUBROUTINE

SUBROUTINE WRITE_ALL()
    USE PS4PARA
    USE PS4RES
    IMPLICIT NONE
    INTEGER:: SROWIDX
    INTEGER, DIMENSION(2):: SIDX
    CHARACTER(LEN=130):: PATH="./"
    CHARACTER(LEN=150):: FILE_NAME

        FILE_NAME = TRIM(PATH)//"VFUNC"
        OPEN(UNIT=1, FILE=FILE_NAME, STATUS='REPLACE') ! START WITH THE TWO VALUE FUNCTIONS
        DO SROWIDX=1, NA
            WRITE(UNIT=1,FMT=*) VFUNC(SROWIDX,:)
        ENDDO
        CLOSE(UNIT=1)

        FILE_NAME = TRIM(PATH)//"PFUNC"
        OPEN(UNIT=2, FILE=FILE_NAME, STATUS='REPLACE') ! ALSO SAVE POLICY FUNCTIONS
        DO SROWIDX=1, NA
            WRITE(UNIT=2,FMT=*) PFUNC(SROWIDX,:)
        ENDDO
        CLOSE(UNIT=2)

        FILE_NAME = TRIM(PATH)//"STATDIST"
        OPEN(UNIT=3, FILE=FILE_NAME, STATUS='REPLACE') ! ALSO SAVE POLICY FUNCTIONS
        DO SROWIDX=1, NA
            SIDX = (/SROWIDX*2-1, SROWIDX*2/)
            WRITE(UNIT=3,FMT=*) STAT_DIST(SIDX)
        ENDDO
        CLOSE(UNIT=3)

        FILE_NAME = TRIM(PATH)//"AGRID"
        OPEN(UNIT=4, FILE=FILE_NAME, STATUS='REPLACE') ! FOR HAVING THE X-AXIS OF PLOT
        DO SROWIDX=1, NA
            WRITE(UNIT=4,FMT=*) A_GRID(SROWIDX)
        ENDDO
        CLOSE(UNIT=4)

        FILE_NAME = TRIM(PATH)//"LORENZ"
        OPEN(UNIT=5, FILE=FILE_NAME, STATUS='REPLACE') ! FOR HAVING THE X-AXIS OF PLOT
        DO SROWIDX=1, 100
            WRITE(UNIT=5,FMT=*) LORENZ(SROWIDX)
        ENDDO
        CLOSE(UNIT=5)

        IF (COMPLETE) THEN
            FILE_NAME = TRIM(PATH)//"LAMBDA"
            OPEN(UNIT=6, FILE=FILE_NAME, STATUS='REPLACE') ! FOR HAVING THE X-AXIS OF PLOT
            DO SROWIDX=1, NA
                WRITE(UNIT=6,FMT=*) LAMBDA(SROWIDX,:)
            ENDDO
            CLOSE(UNIT=6)
        ENDIF
END SUBROUTINE

SUBROUTINE WELFARE(VFUNC_INCOMPLETE)
    USE PS4PARA
    USE PS4RES
    IMPLICIT NONE
    REAL(KIND=8):: WG=0., WINC=0., WFB=0., VOTE=0.
    INTEGER:: RIDX, CIDX, DIS_LOC
    REAL(KIND=8), DIMENSION(NA,NZ), INTENT(IN):: VFUNC_INCOMPLETE
    PRINT*, SUM(STAT_DIST), "STAT"
    DO RIDX=1,NA
        DO CIDX=1, NZ
            DIS_LOC = RIDX*2-2 + CIDX
            WG = WG+ LAMBDA(RIDX, CIDX)* STAT_DIST(DIS_LOC)
            WINC = WINC +VFUNC_INCOMPLETE(RIDX, CIDX)*STAT_DIST(DIS_LOC)
            WFB = WFB + VFUNC(RIDX, CIDX)*STAT_DIST(DIS_LOC)
            IF (LAMBDA(RIDX, CIDX)>0.) THEN
                VOTE = VOTE + STAT_DIST(DIS_LOC)
            ENDIF
        ENDDO
    ENDDO
    PRINT*, "FRIST BEST", WFB
    PRINT*, "WINC", WINC
    PRINT*, "WG", WG
    PRINT*, "VOTING FOR", VOTE
END SUBROUTINE


!*********************************************************************
! This file is part of Polylogarithm.
!
! Polylogarithm is licenced under the MIT License.
!*********************************************************************

!*********************************************************************
!> @brief Complex trilogarithm \f$\mathrm{Li}_3(z)\f$
!> @param z complex argument
!> @return \f$\mathrm{Li}_3(z)\f$
!> @author Alexander Voigt
!*********************************************************************
double complex function cdli3(z)
  implicit none
  double complex :: z, u, u2, u4, u8, c0, c1, lmz, rest, fast_pos_cdlog
  double precision :: rz, iz, nz, pz, lnz, arg
  double precision, parameter :: PI    = 3.1415926535897932D0
  double precision, parameter :: zeta2 = 1.6449340668482264D0
  double precision, parameter :: zeta3 = 1.2020569031595943D0
  double precision, parameter :: bf(18) = (/           &
      1.0D0                 , -3.0D0/8.0D0           , &
      17.0D0/216.0D0        , -5.0D0/576.0D0         , &
      1.2962962962962963D-04,  8.1018518518518519D-05, &
     -3.4193571608537595D-06, -1.3286564625850340D-06, &
      8.6608717561098513D-08,  2.5260875955320400D-08, &
     -2.1446944683640648D-09, -5.1401106220129789D-10, &
      5.2495821146008294D-11,  1.0887754406636318D-11, &
     -1.2779396094493695D-12, -2.3698241773087452D-13, &
      3.1043578879654623D-14,  5.2617586299125061D-15  /)
  double precision, parameter :: cs(7) = (/            &
     -3.4722222222222222D-03,  1.1574074074074074D-05, &
     -9.8418997228521038D-08,  1.1482216343327454D-09, &
     -1.5815724990809166D-11,  2.4195009792525152D-13, &
     -3.9828977769894877D-15                           /)

  rz = real(z)
  iz = aimag(z)

   if (iz .eq. 0) then
      if (rz .eq. 0) then
         cdli3 = 0
         return
      endif
      if (rz .eq. 1) then
         cdli3 = zeta3
         return
      endif
      if (rz .eq. -1) then
         cdli3 = -0.75D0*zeta3
         return
      endif
      if (rz .eq. 0.5D0) then
         cdli3 = 0.53721319360804020D0
         return
      endif
   endif

   nz  = rz**2 + iz**2
   pz  = datan2(iz, rz)
   lnz = 0.5D0*log(nz)

   if (lnz**2 + pz**2 .lt. 1) then ! |log(z)| < 1
      u = dcmplx(lnz, pz) ! log(z)
      u2 = u**2
      u4 = u2**2
      u8 = u4**2
      c0 = zeta3 + u*(zeta2 - u2/12)
      c1 = 0.25D0*(3 - 2*fast_pos_cdlog(-u))
      cdli3 =                                            &
         c0 +                                            &
         c1*u2 +                                         &
         u4*(cs(1) + u2*cs(2)) +                         &
         u8*(cs(3) + u2*cs(4) + u4*(cs(5) + u2*cs(6))) + &
         u8*u8*cs(7)
      return
   endif

   if (nz .le. 1) then
      u = -fast_pos_cdlog(1 - z)
      rest = 0
   else ! nz > 1
      if (pz .gt. 0) then
         arg = pz - PI
      else
         arg = pz + PI
      endif
      lmz = dcmplx(lnz, arg) ! log(-z)
      u = -fast_pos_cdlog(1 - 1/z)
      rest = -lmz*(lmz**2/6 + zeta2)
   endif

   u2 = u**2
   u4 = u2**2
   u8 = u4**2

   cdli3 =                                                   &
      rest +                                                 &
      u*bf(1) +                                              &
      u2*(bf(2) + u*bf(3)) +                                 &
      u4*(bf(4) + u*bf(5) + u2*(bf(6) + u*bf(7))) +          &
      u8*(bf(8) + u*bf(9) + u2*(bf(10) + u*bf(11)) +         &
          u4*(bf(12) + u*bf(13) + u2*(bf(14) + u*bf(15)))) + &
      u8*u8*(bf(16) + u*bf(17) + u2*bf(18))

end function cdli3


        ! Implicit FTSC FDM Solver using TDMA algorithm and ADI method for parabolic 2D heat transfer equation
        !-------------------------------------------------------------
        !------------------By Arthur Rostami -------------------------
        !-------------------------------------------------------------

program CFD_FIRST_PROJECT_IMPLICIT
    implicit none
    !_____________________________Variables_____________________________
    integer:: i,j,k,xF,yF,xG,yG,L,H,time
    real:: e,alpha,dx,dt,w,t_st,t_fin,m,n
    real,allocatable:: T(:,:),x(:),y(:),er(:,:),TF(:,:),TG(:,:),T0(:,:),T1(:,:),T2(:,:),T3(:,:),T4(:,:)
    real,allocatable:: a(:,:),b(:,:),c(:,:),d(:,:),c_new(:,:),d_new(:,:),temp1(:,:),temp2(:,:)

    !_____________________________Define Parameters_____________________
    print*, 'This Method is always stable, you can choose any positive value for dx and dt!'
    print*, 'Please enter delta x:'
    read*, dx
    print*, 'Please enter delta t:'
    read*, dt
    L=2.0                   ! Length of the plate
    H=1.5                 ! Height of the plate
    m=(L/dx)+1            ! number of grid points in x direction
    n=(H/dx)+1            ! number of grid points in x direction
    alpha=23.1E-6         ! thermal diffusivity, m2/s
    w=(alpha*dt)/(dx**2)

    allocate(T(m,n),x(m),y(n),er(m,n),TF(1,100000),TG(1,100000),T0(m,n),T1(m,n),T2(m,n),T3(m,n),T4(m,n),temp1(m,n),temp2(m,n))
    allocate(a(2:m-1,2:n-1),b(2:m-1,2:n-1),c(2:m-1,2:n-1),d(2:m-1,2:n-1),c_new(2:m-1,2:n-1),d_new(2:m-1,2:n-1))
    !_____________________________Defining F & G locations_____________________
    xF=(0.5/dx)+1 !point F location
    yF=(0.5/dx)+1

    xG=(1/dx)+1   !point G location
    yG=(0.75/dx)+1

    !_____________________________Mesh Generation_____________________________
    do i=1,m
        x(i)=(i-1)*dx
    end do
    do j=1,n
        y(j)=(j-1)*dx
    end do

    !_____________________________Initial Condition____________________________
    do i=1,m
        do j=1,n
            T(i,j)=25
            temp1(i,j)=25
            temp2(i,j)=25
        end do
    end do
    !_____________________________________________________________________________
    !____________________FTCS Implicit Solver Using ADI method____________________
    !_____________________________________________________________________________
    k=1 !time step counter
    call cpu_time(t_st)
do
    !_____________________________Boundary condition_____________________________
    do j=2,n-1
        T(1,j)=(T(2,j)+10*dx)/(0.5*dx+1)!BC on wall AB
        temp1(i,j)=(temp1(2,j)+10*dx)/(0.5*dx+1)
        temp2(i,j)=(temp2(2,j)+10*dx)/(0.5*dx+1)
    end do

    do i=1,m
        T(i,1)=T(i,2) !BC on wall BD
        temp1(i,1)=temp1(i,2)
        temp2(i,1)=temp1(i,2)
    end do

    do i=1,m
        T(i,n)=100 !BC on wall AC
        temp1(i,n)=100
        temp2(i,n)=100
    end do

    do j=2,n-1
        T(m,j)=25 !BC on wall CD
        temp1(m,j)=25
        temp2(m,j)=25
    end do

    !_____________________________Saving Temp at chosen times and locations F and G_____________________________
    if(k==1)     T0(:,:)=T(:,:)       !saving temperature at t=0*dt
    if(k==2000)  T1(:,:)=T(:,:)       !saving temperature at t=2000*dt
    if(k==10000) T2(:,:)=T(:,:)       !saving temperature at t=10000*dt
    if(k==50000) T3(:,:)=T(:,:)       !saving temperature at t=50000*dt
    if(k==100000)T4(:,:)=T(:,:)       !saving temperature at t=100000*dt
    TF(1,k)=T(xF,yF)                  !saving temperature of point F for different times
    TG(1,k)=T(xG,yG)                  !saving temperature of point G for different times

    !_____ADI for first half-step_______
    !___________________________________
            do j=2,n-1
                do i=3,m-2
                    a(i,j)=w
                    b(i,j)=-2-2*w
                    c(i,j)=w
                    d(i,j)=-w*T(i,j+1)-w*T(i,j-1)+(-2+2*w)*T(i,j)
                end do

                a(2,j)=0
                b(2,j)=-2-2*w+1/(1+0.5*dx)
                c(2,j)=w
                d(2,j)=-w*T(i,j+1)-w*T(i,j-1)+(-2+2*w)*T(i,j)-10*dx/(1+0.5*dx)

                a(m-1,j)=w
                b(m-1,j)=-2-2*w
                c(m-1,j)=0
                d(m-1,j)=-w*T(i,j+1)-w*T(i,j-1)+(-2+2*w)*T(i,j)-w*T(m,j)

            end do
                !_____TDMA Solver_____
                do j=2,n-1
                    c_new(2,j)=c(2,j)/b(2,j)
                    d_new(2,j)=d(2,j)/b(2,j)
                    do i=3,m-1
                        c_new(i,j)=c(i,j)/(b(i,j)-a(i,j)*c_new(i-1,j))
                        d_new(i,j)=(d(i,j)-a(i,j)*d_new(i-1,j))/(b(i,j)-a(i,j)*c_new(i-1,j))
                    end do
                    temp1(m-1,j)=d_new(m-1,j)
                    do i=m-2,2,-1
                        temp1(i,j)=d_new(i,j)-c_new(i,j)*temp1(i+1,j) ! Saving half-step(k+0.5) values in a temporary variable
                    end do
                end do
    !_____ADI for second half-step_______
    !____________________________________
            do i=2,m-1
                do j=3,n-2
                    a(i,j)=w
                    b(i,j)=-2-2*w
                    c(i,j)=w
                    d(i,j)=-w*temp1(i+1,j)-w*temp1(i-1,j)+(-2+2*w)*temp1(i,j)
                end do

                a(i,2)=0
                b(i,2)=-2-w
                c(i,2)=w
                d(i,2)=-w*temp1(i+1,j)-w*temp1(i-1,j)+(-2+2*w)*temp1(i,j)

                a(i,n-1)=w
                b(i,n-1)=-2-2*w
                c(i,n-1)=0
                d(i,n-1)=-w*temp1(i+1,j)-w*temp1(i-1,j)+(-2+2*w)*temp1(i,j)-w*T(i,n)

            end do

                !_____TDMA Solver_____
                do i=2,m-1
                    c_new(i,2)=c(i,2)/b(i,2)
                    d_new(i,2)=d(i,2)/b(i,2)
                    do j=3,n-1
                        c_new(i,j)=c(i,j)/(b(i,j)-a(i,j)*c_new(i,j-1))
                        d_new(i,j)=(d(i,j)-a(i,j)*d_new(i,j-1))/(b(i,j)-a(i,j)*c_new(i,j-1))
                    end do
                    temp2(i,n-1)=d_new(i,n-1)
                    do j=n-2,2,-1
                        temp2(i,j)=d_new(i,j)-c_new(i,j)*temp2(i,j+1) ! Saving second half-step(k+1)
                    end do
                end do

    er(:,:)=ABS(temp2(:,:)-T(:,:)) ! This variable is defined to determine the time the solution will reach steady state
    e=maxval(er) !Maximum difference
    T(:,:)=temp2(:,:)

    if(e<0.0001) exit
    k=k+1
end do
    call cpu_time(t_fin)
    !_____________________________Reporting solution information_____________________________
    print*, 'w=                                                 ',w
    print*, 'Number of iterations to reach steady state:    ',k
    print*, 'Maximum difference between the last two time steps:',e, 'Celsius'
    print*, 'Solution will be Steady at:                        ',k*dt,'seconds'
    print*, 'Calculation time is:                               ',t_fin-t_st, 'seconds'

    !_____________________________Saving the results_____________________________

    open(10,file='Temp contour.plt')
    write(10,*)'VARIABLES = "X", "Y", "T"'
    do j=1,n
        do i=1,m
            write(10,*) x(i),y(j),T(i,j)
        end do
    end do

    open(20,file='Midline temp at SS.dat')
    write(20,*)"VARIABLES=X,TEMPERATURE"
    do i=1,m
        write(20,*) (i-1)*dx,T(i,yG)
    end do

    open(30,file='Midline initial temp.dat')
    write(30,*)"VARIABLES=X,TEMPERATURE"
    do i=1,m
        write(30,*) (i-1)*dx,T0(i,yG)
    end do

    open(40,file='Midline temp at t=2000dt.dat')
    write(40,*)"VARIABLES=X,TEMPERATURE"
    do i=1,m
        write(40,*) (i-1)*dx,T1(i,yG)
    end do

    open(50,file='Midline temp at t=10000dt.dat')
    write(50,*)"VARIABLES=X,TEMPERATURE"
    do i=1,m
        write(50,*) (i-1)*dx,T2(i,yG)
    end do

    open(60,file='Midline temp at t=50000dt.dat')
    write(60,*)"VARIABLES=X,TEMPERATURE"
    do i=1,m
        write(60,*) (i-1)*dx,T3(i,yG)
    end do

    open(70,file='Midline temp at t=100000dt.dat')
    write(70,*)"VARIABLES=X,TEMPERATURE"
    do i=1,m
        write(70,*) (i-1)*dx,T4(i,yG)
    end do

    open(80,file='Temp at F.dat')
    write(80,*)"VARIABLES=t,TEMPERATURE"
    do time=1,k
        write(80,*) (time-1)*dt,TF(1,time)
    end do

    open(90,file='Temp at G.dat')
    write(90,*)"VARIABLES=t,TEMPERATURE"
    do time=1,k
        write(90,*) (i-1)*dt,TG(1,time)
    end do

end program CFD_FIRST_PROJECT_IMPLICIT


integer :: i
integer, dimension (10, 10) :: a = reshape ((/(i * i, i = 1, 100)/), (/10, 10/))


!***********************************************************************
!* Butterworth Filter Routines:
!*  BWFILT_S - In-place filter (overwrites input array)
!*  BWFILT_SN - Out-of-place filter (outputs to separate array)
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      SUBROUTINE BWFILT_S( Y, NFP, NLP, DEL, FCUT )

!***********************************************************************
!* In-Place Second-Order Butterworth Filter of Time Series
!*
!* Function:
!*  Filters data forward and backward with a second order
!*  Butterworth algorithm, giving zero phase shift and -3dB
!*  at the specified cutoff frequency.
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      ! Arguments ______________________________________________________

      INTEGER NFP ! Index of first data point

      INTEGER NLP ! Index of last data point

      REAL Y(NFP:NLP) ! Time series data array (send Y(NFP))

      REAL DEL ! Time step (delta-t) (sec) of time series data (>0)

      REAL FCUT ! Cutoff frequency (Hz) desired

      ! Perform the in-place filter
      CALL BWFILT_SN( Y, Y, NFP, NLP, DEL, FCUT )

      RETURN
      END

      SUBROUTINE BWFILT_SN( Y, YF, NFP, NLP, DEL, FCUT )

!***********************************************************************
!* Second-Order Butterworth Filter of Time Series Files
!*
!* Function:
!*  Filters data forward and backward with a second order Butterworth
!*  algorithm giving zero phase shift and -3dB at the specified cutoff
!*  frequency
!*
!* Language: Fortran
!*
!* Author: C. Louie - 1978/11
!*         Stuart G. Mentzer
!*
!* Date: 1999/08/20
!***********************************************************************

      ! Arguments ______________________________________________________

      INTEGER NFP ! Index of first data point

      INTEGER NLP ! Index of last data point

      REAL Y(NFP:NLP) ! Time series data array (send Y(NFP))

      REAL YF(NFP:NLP) ! Filtered time series data array (send YF(NFP))
      ! Can be passed the same array as Y to overwrite the input array

      REAL DEL ! Time step (delta-t) (sec) of time series data (>0)

      REAL FCUT ! Cutoff frequency (Hz) desired

      ! Variables ______________________________________________________

      INTEGER NTP, NTPH, I

      REAL FM6DB, PI, WD, WA, B0, B1, B2, A1, A2,
     & X0, X1, X2, Y0, Y1, Y2, YNFP2

      ! Check positive frequency and time step
      IF ( ( DEL .LE. 0. ) .OR. ( FCUT .LE. 0. ) ) THEN
        WRITE( *, * )
     &     '*** BWFILT Error - Nonpositive time step or cutoff'
        RETURN
      END IF

      ! Check if the sampling rate can support this cutoff frequency
      !
      ! sampling rate is lower than the cutoff frequency - return true
      ! BwFilt goes unstable as fCut approaches 0.5/del
      !
      IF ( FCUT .GT. ( ( 0.5 / DEL ) * 0.775 ) ) THEN
        WRITE( *, * )
     &     '*** BWFILT Error - '//
     &     'Sampling rate is lower than cutoff frequency'
        RETURN
      END IF

      ! Set 6dB attenuation frequency
      FM6DB = FCUT * 1.25

      ! Compute filter coefficients
      PI = 3.141592654
      WD = 2 * PI * FM6DB
      WA = SIN(WD*DEL/2.) / COS(WD*DEL/2.)
      B0 = WA**2 / (1.+SQRT(2.)*WA+WA**2)
      B1 = 2 * B0
      B2 = B0
      A1 = -2.*(WA**2-1.) / (1.+SQRT(2.)*WA+WA**2)
      A2 = (-1.+SQRT(2.)*WA-WA**2) / (1.+SQRT(2.)*WA+WA**2)

      ! Set the number of tail points to use
      NTP = MAX( NINT( .1 / ( FCUT * DEL ) ), 1 )
      NTP = MIN( NTP, NLP - NFP + 1 )
      NTPH = ( NTP / 2 ) + 1

      ! Set up pre-start array - Inverted mirror
      YNFP2 = 2 * Y(NFP)
      X1 = YNFP2 - Y(NFP+NTP)
      X0 = YNFP2 - Y(NFP+NTP-1)
      Y1 = 0.
      DO I = -NTP, -NTPH
        Y1 = Y1 + Y(NFP-I)
      END DO
      Y1 = YNFP2 - ( Y1 / ( NTP - NTPH + 1 ) )
      Y0 = Y1
      DO I = -NTP+2, -1
        X2 = X1
        X1 = X0
        X0 = YNFP2 - Y(NFP-I)
        Y2 = Y1
        Y1 = Y0
        Y0 = B0*X0 + B1*X1 + B2*X2 + A1*Y1 + A2*Y2
      END DO

      ! Filter forward
      DO I = NFP, NLP
        X2 = X1
        X1 = X0
        X0 = Y(I)
        Y2 = Y1
        Y1 = Y0
        Y0 = B0*X0 + B1*X1 + B2*X2 + A1*Y1 + A2*Y2
        YF(I) = Y0
      END DO

      ! Filter backwards
      X1 = 2 * YF(NLP) - YF(NLP-2)
      X0 = 2 * YF(NLP) - YF(NLP-1)
      Y1 = 2 * Y(NLP) - Y(NLP-2)
      Y0 = 2 * Y(NLP) - Y(NLP-1)
      DO I = NLP, NFP, -1
        X2 = X1
        X1 = X0
        X0 = YF(I)
        Y2 = Y1
        Y1 = Y0
        Y0 = B0*X0 + B1*X1 + B2*X2 + A1*Y1 + A2*Y2
        YF(I) = Y0
      END DO

      RETURN
      END


module aconite_function_mod

	public :: acm, mass_resp, daylength, GDD_calc,area_resp,atkin_resp,ryan_resp, clm_resp

contains

!-------PHENOLOGY GROWING DEGREE DAY CALCULATOR
double precision function GDD_calc(tmax,tmin,GDD,doy)
	double precision, intent(in):: tmax, tmin, GDD
	integer, intent(in):: doy
	double precision :: tav

    tav = (tmax + tmin)/2.
    if(doy == 1) then
      GDD_calc = 0
    elseif(tav - 8 > 0) then
      GDD_calc = GDD + tav - 8
    endif
  End Function
!-------------------------------------------------

!--------DAY LENGTH CALCULATOR
double precision function  daylength(Lat,doy)
	double precision, parameter :: pi = 3.14159265359
	double precision, intent(in) :: Lat
	integer, intent(in):: doy
	double precision :: LatRad, r, z, decl,z2,h,TA,AC

    LatRad = Lat * (2.0 * pi) / 360.0
    r = 1 - (0.0167 * COS(0.0172 * (doy - 3)))
    z = 0.39785 * sin(4.868961 + 0.017203 * doy + 0.033446 *SIN(6.224111 + 0.017202 * doy))
    if (ABS(z) < 0.7) then
      decl = ATAN(z / (sqrt(1.0 - (z**2))))
    else
      decl = pi / 2.0 - atan(sqrt(1 - z**2) / z)
    endif

    if (abs(LatRad) >= (pi/2.0)) then
      if (Lat < 0) then
        LatRad = (-1.0) * (pi/2.0 - 0.01);
      else
        LatRad = (1.0) * (pi/2.0 - 0.01);
      endif
    endif

    z2 = -TAN(decl) * TAN(LatRad);
    if (z2 >= 1.0) then
      h = 0;
    elseif (z2 <= -1.0) then
      h = pi;
    else
      TA = abs(z2);
      if (TA < 0.7)then
        AC = 1.570796 - atan(TA / sqrt(1.0 - (TA**2)));
      else
        AC = atan(sqrt(1 - (TA**2)) / TA);
      endif
      if (z2 < 0) then
        h = pi-AC;
      else
        h = AC;
      endif
    endif
    daylength = 2.0 * (h*24.0) / (2.0*pi);
End function

!-------  ACM PHOTOSYNTHESIS MODEL
  double precision function acm(N,lai,tmax,tmin,DL,rad,co2,param,psid,rtot,leafgrow_doy,leaf_drop_occured,doy)
  	double precision, intent(in) :: N, lai, tmax,tmin,DL,rad,co2, param(16), psid,rtot, &
  									leafgrow_doy,leaf_drop_occured
  	double precision ::  tav,gs,pp,trange,qq,ci,e0,cps
  		integer, intent(in):: doy

    tav = (tmax + tmin)/2.
    if(tmin > param(15) .AND. doy >= leafgrow_doy .AND. doy < leaf_drop_occured) then
      trange = tmax - tmin ! daily temperature range (C)
      gs = abs(psid)**param(10) / ((param(6)* rtot + 0.5*trange))
      pp = (N * param(1) * exp(param(8) * tmax))/gs
      qq = param(3) - param(4)
      ci = 0.5 * (co2 + qq - pp + sqrt((co2 + qq - pp)**2 - 4 * (co2 * qq - pp * param(3))))
      e0 = param(7) * lai**2/(lai**2 + param(9))
      cps = (e0* rad * gs * (co2 - ci))/(e0 * rad + gs * (co2-ci))
      acm = cps * (param(2) * DL + param(5))
    else
      acm = 0.
    endif

end function

!-------NON-LINEAR RESPIRATION MODEL (REICH ET AL. 2008): MASS
  double precision function  mass_resp(tissueC,tissueN,resp_parm1,resp_parm2,resp_parm3,twq)
  	double precision, intent(in) ::   tissueC,tissueN,resp_parm1,resp_parm2,twq,resp_parm3
  	double precision :: total_biomass,mmolesN_per_biomass,nmolesC_per_biomass_per_sec, &
  						gC_per_biomass_per_sec,gC_per_sec

    if(tissueC > 0.0 .AND. tissueN > 0.0) then
      total_biomass = tissueC/0.5
      mmolesN_per_biomass = ((tissueN/14.)*1000)/total_biomass

      !nmolesC_per_biomass_per_sec =exp(mass_param1+mass_param2*log(mmolesN_per_biomass))
      nmolesC_per_biomass_per_sec = resp_parm1 + log10(mmolesN_per_biomass)*resp_parm2
      gC_per_biomass_per_sec =((10**nmolesC_per_biomass_per_sec)/10**9)*12.
      gC_per_sec = gC_per_biomass_per_sec * total_biomass
      mass_resp = gC_per_sec * (60.*60.*24.)
      !print *, mmolesN_per_biomass,10**nmolesC_per_biomass_per_sec
      !nmolesC_per_biomass_per_sec = resp_parm1 * (mmolesN_per_biomass ** resp_parm2)
      !gC_per_biomass_per_sec =(nmolesC_per_biomass_per_sec/10**9)*12.
      !gC_per_sec = gC_per_biomass_per_sec * total_biomass
      !mass_resp = gC_per_sec * (60.*60.*24.)
      !print *, mmolesN_per_biomass,nmolesC_per_biomass_per_sec
    else
      mass_resp = 0.0
    endif
end function

!-------NON-LINEAR RESPIRATION MODEL (REICH ET AL. 2008) :AREA
  double precision function  area_resp(LAI,tissueN,resp_parm1,resp_parm2,resp_parm3,twq)
  	double precision, intent(in) ::   LAI,tissueN,resp_parm1,resp_parm2,twq,resp_parm3
  	double precision :: total_biomass,N_per_area,gC_per_area_per_sec, &
  						gC_per_sec

    if(LAI > 0.0 .AND. tissueN > 0.0) then
       N_per_area = (tissueN/LAI)
       umolC_per_area_per_sec = ((resp_parm1-resp_parm3*twq)* (N_per_area ** resp_parm2))
       gC_per_area_per_sec = (umolC_per_area_per_sec/10**6)*12.
       gC_per_sec = gC_per_area_per_sec*LAI
       area_resp = gC_per_sec * (60.*60.*24.)
    else
      area_resp = 0.0
    endif
end function

!-------AKTIN EQUATION
  double precision function  atkin_resp(LAI,tissueN,twq,resp_parm1,resp_parm2,resp_parm3)
  	double precision, intent(in) ::   LAI,tissueN,twq,resp_parm1,resp_parm2,resp_parm3
  	double precision :: total_biomass,N_per_area,gC_per_area_per_sec, &
  						gC_per_sec

    if(tissueC > 0.0 .AND. tissueN > 0.0) then
       N_per_area = (tissueN/LAI)
       umolC_per_area_per_sec  = resp_parm1 + (N_per_area * resp_parm2) - resp_parm3*twq
       gC_per_area_per_sec = (umolC_per_area_per_sec/10**6)*12.
       gC_per_sec = gC_per_area_per_sec*LAI
       atkin_resp = gC_per_sec * (60.*60.*24.)
       atkin_resp = max(atkin_resp,0.0)
    else
      atkin_resp = 0.0
    endif
end function

!-------RYAN EQUATION
  double precision function  ryan_resp(tissueN,tissueC,resp_parm1)
  	double precision, intent(in) ::   tissueN,tissueC, resp_parm1
  	double precision ::  gC_per_sec,mol_C,mmol_N,mmolN_per_molC,mmol_per_mol_per_hr, &
  		mmol_per_mol_per_second, mmol_per_second

    if(tissueC > 0.0 .AND. tissueN > 0.0) then
       mol_C = tissueC / 12.0
       mmol_N = (tissueN/14.0)*1000
       mmolN_per_molC = mmol_N/mol_C

       mmol_per_mol_per_hr = resp_parm1 * mmolN_per_molC
       mmol_per_mol_per_second = mmol_per_mol_per_hr/(60.*60.)
       mmol_per_second = mmol_per_mol_per_second*mol_C
       gC_per_sec = (mmol_per_second*12.0)/1000
       ryan_resp = gC_per_sec * (60.*60.*24.)
    else
      ryan_resp = 0.0
    endif

end function

!-------CLM EQUATION
  double precision function  clm_resp(tissueN,tissueC,resp_parm1)
  	double precision, intent(in) ::   tissueN,tissueC, resp_parm1
  	double precision ::  gC_per_sec,mol_C,mmol_N,mmolN_per_molC,mmol_per_mol_per_hr, &
  		mmol_per_mol_per_second, mmol_per_second

    if(tissueC > 0.0 .AND. tissueN > 0.0) then
       gC_per_sec = TissueN * resp_parm1
       clm_resp = gC_per_sec * (60.*60.*24.)
    else
       clm_resp = 0.0
    endif

end function

end module


geqrhs(0) = (-(2*vel(2)*vel(3)*(pot(2)*dpot(5,2)-dpot(2,2)*pot(5)&
&))/(2*pot(1)*pot(5)+2*pot(2)**2))-(2*vel(1)*vel(3)*(pot(2)*dpot(5&
&,1)-dpot(2,1)*pot(5)))/(2*pot(1)*pot(5)+2*pot(2)**2)-(2*vel(0)*ve&
&l(2)*(dpot(1,2)*pot(5)+pot(2)*dpot(2,2)))/(2*pot(1)*pot(5)+2*pot(&
&2)**2)-(2*vel(0)*vel(1)*(dpot(1,1)*pot(5)+pot(2)*dpot(2,1)))/(2*p&
&ot(1)*pot(5)+2*pot(2)**2)

geqrhs(1) = ((vel(3)**2*dpot(5,1))/pot(3))/2.d+0+((vel(2)**2*dpot&
&(4,1))/pot(3))/2.d+0-(vel(1)*vel(2)*dpot(3,2))/pot(3)-((vel(1)**2&
&*dpot(3,1))/pot(3))/2.d+0+(vel(0)*dpot(2,1)*vel(3))/pot(3)-((vel(&
&0)**2*dpot(1,1))/pot(3))/2.d+0

geqrhs(2) = ((vel(3)**2*dpot(5,2))/pot(4))/2.d+0-((vel(2)**2*dpot&
&(4,2))/pot(4))/2.d+0-(vel(1)*vel(2)*dpot(4,1))/pot(4)+((vel(1)**2&
&*dpot(3,2))/pot(4))/2.d+0+(vel(0)*dpot(2,2)*vel(3))/pot(4)-((vel(&
&0)**2*dpot(1,2))/pot(4))/2.d+0

geqrhs(3) = (-(2*vel(2)*vel(3)*(pot(1)*dpot(5,2)+pot(2)*dpot(2,2)&
&))/(2*pot(1)*pot(5)+2*pot(2)**2))-(2*vel(1)*vel(3)*(pot(1)*dpot(5&
&,1)+pot(2)*dpot(2,1)))/(2*pot(1)*pot(5)+2*pot(2)**2)-(2*vel(0)*ve&
&l(2)*(pot(1)*dpot(2,2)-dpot(1,2)*pot(2)))/(2*pot(1)*pot(5)+2*pot(&
&2)**2)-(2*vel(0)*vel(1)*(pot(1)*dpot(2,1)-dpot(1,1)*pot(2)))/(2*p&
&ot(1)*pot(5)+2*pot(2)**2)


      SUBROUTINE SFFTFU( X, Y, N, M, ITYPE )
c
c  Decimation-in-time radix-2 split-radix complex FFT
c
c  Arguments:
c     X - real part of data sequence (in/out)
c     Y - imag part of data sequence (in/out)
c     N,M - integers such that N = 2**M (in)
c     ITYPE - integer transform type (in)
c         ITYPE .ne. -1 --> forward transform
c         ITYPE .eq. -1 --> backward transform
c
c  The forward transform computes
c     X(k) = sum_{j=0}^{N-1} x(j)*exp(-2ijk*pi/N)
c
c  The backward transform computes
c     x(j) = (1/N) * sum_{k=0}^{N-1} X(k)*exp(2ijk*pi/N)
c
c
c  Here is the original program header...
c
C-------------------------------------------------------------C
C  A Duhamel-Hollman Split-Radix DIT FFT                      C
C  Reference:  Electronics Letters, January 5, 1984           C
C  Complex input and output in data arrays X and Y            C
C  Length is N = 2**M                                         C
C                                                             C
C  H.V. Sorensen        Rice University         Dec 1984      C
C-------------------------------------------------------------C
c
c ... Scalar arguments ...
      INTEGER  N, M, ITYPE
c ... Array arguments ...
      REAL  X(*), Y(*)
c ... Local scalars ...
      INTEGER  I, J, K, N1, N2, N4, IS, ID, I0, I1, I2, I3
      REAL  TWOPI, A, A3, E, XT, R1, R2, R3, S1, S2
      REAL  CC1, CC3, SS1, SS3
c ... Parameters ...
      PARAMETER  ( TWOPI = 6.283185307179586476925287 )
c ... Intrinsic functions ...
      INTRINSIC  SIN, COS
c
c ... Exe. statements ...
c
c ... Quick return ...
      IF ( N .EQ. 1 ) RETURN
c
c ... Conjugate if necessary ...
      IF ( ITYPE .EQ. -1 ) THEN
         DO 1, I = 1, N
            Y(I) = - Y(I)
 1       CONTINUE
      ENDIF
c
c ... Bit reversal permutation ...
 100  J = 1
      N1 = N - 1
      DO 104, I = 1, N1
	 IF ( I .GE. J ) GOTO 101
	 XT = X(J)
	 X(J) = X(I)
	 X(I) = XT
	 XT = Y(J)
	 Y(J) = Y(I)
	 Y(I) = XT
 101     K = N / 2
 102     IF ( K .GE. J ) GOTO 103
	 J = J - K
	 K = K / 2
	 GOTO 102
 103     J = J + K
 104  CONTINUE
c
c ... Length two transforms ...
      IS = 1
      ID = 4
 70   DO 60, I0 = IS, N, ID
	 I1 = I0 + 1
	 R1 = X(I0)
	 X(I0) = R1 + X(I1)
	 X(I1) = R1 - X(I1)
	 R1 = Y(I0)
	 Y(I0) = R1 + Y(I1)
	 Y(I1) = R1 - Y(I1)
 60   CONTINUE
      IS = 2 * ID - 1
      ID = 4 * ID
      IF ( IS .LT. N ) GOTO 70
c
c ... L shaped butterflies ...
      N2 = 2
      DO 10, K = 2, M
	 N2 = N2 * 2
	 N4 = N2 / 4
	 E = TWOPI / N2
	 A = 0.0
	 DO 20, J = 1, N4
	    A3 = 3 * A
	    CC1 = COS( A )
	    SS1 = SIN( A )
	    CC3 = COS( A3 )
	    SS3 = SIN( A3 )
	    A = J * E
	    IS = J
	    ID = 2 * N2
 40         DO 30, I0 = IS, N-1, ID
	       I1 = I0 + N4
	       I2 = I1 + N4
	       I3 = I2 + N4
	       R1 = X(I2) * CC1 + Y(I2) * SS1
	       S1 = Y(I2) * CC1 - X(I2) * SS1
	       R2 = X(I3) * CC3 + Y(I3) * SS3
	       S2 = Y(I3) * CC3 - X(I3) * SS3
	       R3 = R1 + R2
	       R2 = R1 - R2
	       R1 = S1 + S2
	       S2 = S1 - S2
	       X(I2) = X(I0) - R3
	       X(I0) = X(I0) + R3
	       X(I3) = X(I1) - S2
	       X(I1) = X(I1) + S2
	       Y(I2) = Y(I0) - R1
	       Y(I0) = Y(I0) + R1
	       Y(I3) = Y(I1) + R2
	       Y(I1) = Y(I1) - R2
 30         CONTINUE
	    IS = 2 * ID - N2 + J
	    ID = 4 * ID
	    IF ( IS .LT. N ) GOTO 40
 20      CONTINUE
 10   CONTINUE
c
c ... Conjugate and normalize if necessary ...
      IF ( ITYPE .EQ. -1 ) THEN
         DO 2, I = 1, N
	    Y(I) = - Y(I) / N
	    X(I) = X(I) / N
 2       CONTINUE
      ENDIF
c
      RETURN
c
c ... End of subroutine SFFTFU ...
c
      END


c
c     ==========================================
      subroutine mapc2m(x1,y1,xp,yp,zp)
c     ==========================================
c
c     Map computational point (x1,y1) to the point (xp,yp,zp)
c     on the sphere
c
c     Points in [-1,1]x[-1,1]  are mapped to the upper hemisphere
c     Points in [-3,-1]x[-1,1] are mapped to the lower hemisphere
c
      implicit real*8(a-h,o-z)

      r1 = 1.d0
      xc = x1
      yc = y1

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

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

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

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

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

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

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

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


      MODULE HYD_COL_RATE

      IMPLICIT NONE

      PRIVATE

      PUBLIC :: HYDCOLRATE

      CONTAINS

      FUNCTION HYDCOLRATE(nl, nu, T) RESULT(ColRate)

      USE MATH
      USE PHYS

!     e - H collisional rates according to L. C. Johnson, "Approximations For Collisional
!     And Radiative Transition Rates In Atomic Hydrogen", 1972, ApJ, 174, 227

!     The procedure works for ionization rates as well, in this case nu is equal to 11 and is not the principal quantum number

      INTEGER, INTENT(IN) :: nl, nu ! Principal numbers of upper and lower levels

      REAL*8, INTENT(IN) :: T ! Temperature

      REAL*8 :: ColRate ! Resulting collision rate (in cgs units)

      REAL*8 :: rnlnu

      REAL*8, DIMENSION(3) :: g

      REAL*8 :: gf

      REAL*8 :: Anlnu, Bnlnu

      REAL*8 :: Anl, Bnl

      REAL*8 :: C1, C2, C3, C4 ! Constant factors in the corresponding formulas

      REAL*8 :: B1, B2, B3 ! Bracket factors in the corresponding formulas

      REAL*8 :: x, y, z

      REAL*8 :: ynl, znl

      C1 = DSQRT(8.0D0 * boltz * T / pai / elec_mass)

      C4 = 32.0D0 / 3.0D0 / DSQRT(3.0D0) / pai

      g(1 : 3) = gfc(nl)

      IF (nu .NE. 11) THEN ! nl -> nu excitation collisional coefficient

         x = 1.0D0 - (ISQ(nl) / ISQ(nu))

         y = x * DABS(HYD_LEV_ENERGY(nl)) / boltz / T

         rnlnu = r(nl) * x

         z = rnlnu + y

         C2 = 2.0D0 * ISQ(nl) / x

         C3 = pai * DSQ(bohr_rad * y)

         B1 = (1.0D0 / y + 0.5D0) * EXPINT(1, y) - (1.0D0 / z + 0.5D0) * EXPINT(1, z)

         gf = g(1) + g(2) / x + g(3) / DSQ(x)

         Anlnu = C2 * C4 * nl * gf / DCUBE(nu * x)

         Bnlnu = (DSQ(C2) / ICUBE(nu)) * (1.0D0 + 4.0D0 / 3.0D0 / x + b(nl) / DSQ(x))

         B2 = Bnlnu - Anlnu * DLOG(C2)

         B3 = EXPINT(2, y) / y - EXPINT(2, z) / z

         ColRate = C1 * C2 * C3 * (Anlnu * B1 + B2 * B3)! * DEXP(y) / DSQRT(T)

      ELSE ! Ionization collisional coefficient

         ynl = DABS(HYD_LEV_ENERGY(nl)) / boltz / T

         znl = r(nl) + ynl

         C2 = 2.0D0 * pai * DSQ(nl * bohr_rad * ynl)

         B1 = EXPINT(1, ynl) / ynl - EXPINT(1, znl) / znl

         Bnl = 2.0D0 * ISQ(nl) * (5.0D0 + b(nl)) / 3.0D0

         Anl = C4 * nl * (g(1) / 3.0D0 + g(2) / 4.0D0 + g(3) / 5.0D0)

         B2 = Bnl - Anl * DLOG(2.0D0 * ISQ(nl))

         B3 = ksi(ynl) - ksi(znl)

         ColRate = C1 * C2 * (Anl * B1 + B2 * B3)! * DEXP(ynl) / DSQRT(T)

      ENDIF

      RETURN

      END FUNCTION HYDCOLRATE

      REAL*8 FUNCTION r(n)

      INTEGER, INTENT(IN) :: n

      IF (n .EQ. 1) THEN; r = 0.45D0; ELSE; r = 1.94D0 * DBLE(n)**(-1.57D0); ENDIF

      RETURN

      END FUNCTION r

      FUNCTION gfc(n) RESULT(g)

      INTEGER, INTENT(IN) :: n

      REAL*8, DIMENSION(3) :: g

      IF (n .EQ. 1) THEN

         g = (/1.1330D0, -0.4059D0, 0.07014D0/)

      ELSEIF (n .EQ. 2) THEN

         g = (/1.0785D0, -0.2319D0, 0.02947D0/)

      ELSE

         g(1) = 0.9935D0 + 0.2328D0 / n - 0.1296D0 / n / n

         g(2) = (-0.6282D0 + 0.5598D0 / n - 0.5299D0 / n / n) / n

         g(3) = (0.3887D0 - 1.181D0 / n + 1.470D0 / n / n) / n / n

      ENDIF

      RETURN

      END FUNCTION gfc

      REAL*8 FUNCTION b(n)

      INTEGER, INTENT(IN) :: n

      IF (n .EQ. 1) THEN

          b = -0.603D0

      ELSE

          b = (4.0D0 - 18.63D0 / n + 36.24D0 / n / n - 28.09D0 / n / n / n) / n

      ENDIF

      RETURN

      END FUNCTION b

      REAL*8 FUNCTION ksi(t)

      USE MATH

      REAL*8, INTENT(IN) :: t

      ksi = EXPINT(0, t) - 2.0D0 * EXPINT(1, t) + EXPINT(2, t)

      RETURN

      END FUNCTION ksi

      END MODULE HYD_COL_RATE


module pde

  ! This module contains the kinetic equation PDE, aka the Boltzmann equation,
  ! or whatever other equation (Vlasov / BGK / ...) according to the collision
  ! operator that we employ.
  ! Hyper2D is still two-dimensional, meaning that the kinetic equation will
  ! be 1D1V: 1D in space and 1V in the velocity.
  ! Dimension "x" refers to the space coordinate, while dimension "y" is a
  ! velocity "v".

  use global_module

  implicit none

  real(kind=8), parameter :: M = 6.6337d-26   ! [kg] particle mass
  real(kind=8), parameter :: q = 1.602176d-19 ! [C] particle charge

  real(kind=8), parameter :: kB  = 1.3806503d-23 ! [J/K] Boltzmann constant
  real(kind=8), parameter :: PI  = 3.1415926535

  integer, parameter :: Neq = 1 ! Number of equations: (x, v, f)

  ! Name of primitive variables, used ONLY for exporting the solution to VTK file
  ! NOTE: To initialize it here, all entries need to have the same length!!!
  !       I'm using three letters for simplicity.
  character(len=20), dimension(Neq) :: prim_names = (/'f'/)

  contains

  ! ============================================================

  subroutine initialize_solution(U)

    implicit none

    real(kind=8), dimension(:,:,:), intent(inout) :: U

    integer      :: i, j
    real(kind=8) :: x, v

    ! Initialize all cells with a single-velocity (1V) Maxwellian VDF
    do j = 1, Ny

      v = compute_v_from_j(j)

      do i = 1, Nx

        ! x = x_min + dx/2.0 + real(i-1)*dx

        U(1,i,j) = n0*sqrt(M/(2.0*PI*kB*T0))*exp(-M/(2.0*kB*T0)*(v - u0)*(v - u0))

      end do

    end do

  end subroutine

  ! ============================================================

  function compute_x_from_i(i)

    implicit none

    integer, intent(in) :: i
    real(kind=8)        :: compute_x_from_i

    compute_x_from_i = x_min + dx/2.0 + real(i-1)*dx

  end function

  ! ============================================================

  function compute_v_from_j(j)

    implicit none

    integer, intent(in) :: j
    real(kind=8)        :: compute_v_from_j

    compute_v_from_j = y_min + dy/2.0 + real(j-1)*dy

  end function

  ! ============================================================

  subroutine assign_BCs(U)

    implicit none

    real(kind=8), dimension(:,:,:), intent(inout) :: U

    integer :: i, j

    ! Periodic BCs
    if (X_PERIODIC_BOOL) then
      U(:,1,:)    = U(:,Nx-3,:)
      U(:,2,:)    = U(:,Nx-2,:)
      U(:,Nx-1,:) = U(:,3,:)
      U(:,Nx,:)   = U(:,4,:)
    end if

  end subroutine

  ! =========================================================================

  function E_field(x)

    implicit none

    real(kind=8), intent(in) :: x
    real(kind=8) :: E_field

    real(kind=8) :: k

    ! Cosinusoidal electric field profile
    k       = 2.0*PI*4.0/(x_max-x_min)
    E_field = 10.0*k*cos(k*x)

  end function

!!   ! ==========================================================================
!!
!!   subroutine compute_moments(U, i, n, u_ave, T)
!!
!!     implicit none
!!
!!     real(kind=8), dimension(Neq,Nx,Ny), intent(in)  :: U
!!     integer,      intent(in)  :: i
!!     real(kind=8), intent(out) :: n, u_ave, T
!!
!!     integer :: j
!!
!!     real(kind=8) :: n_u, rhoE, v
!!
!!     ! For every position along x, integrate in velocity
!!     n     = 0.0
!!     n_u   = 0.0
!!     u_ave = 0.0
!!     T     = 0.0
!!     rhoE  = 0.0
!!
!!     do j = 1, Ny
!!
!!       v    = compute_v_from_j(j)
!!
!!       n     = n     + U(1,i,j)*dy
!!       n_u   = n_u   + v*U(1,i,j)*dy
!!       rhoE  = rhoE  + M*v*v/2.0*U(1,i,j)*dy
!!
!!     end do
!!
!!     u_ave = n_u/n ! Average velocity
!!     T     = (rhoE - n*M*u_ave*u_ave/2.0)*2.0/(n*kB)
!!
!!   end subroutine

end module


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

        subroutine enubasis(r_lat,r_lon,r_enumat)

c****************************************************************
c**
c**     FILE NAME: enubasis.f
c**
c**     DATE WRITTEN: 7/22/93
c**
c**     PROGRAMMER:Scott Hensley
c**
c**     FUNCTIONAL DESCRIPTION:Takes a lat and lon and returns a
c**     change of basis matrix from ENU to geocentric coordinates.
c**
c**     ROUTINES CALLED:none
c**
c**     NOTES: none
c**
c**     UPDATE LOG:
c****************************************************************

        implicit none

c       INPUT VARIABLES:
        real*8 r_lat                   !latitude (deg)
        real*8 r_lon                   !longitude (deg)

c       OUTPUT VARIABLES:
        real*8 r_enumat(3,3)

c       LOCAL VARIABLES:
        real*8 r_slt,r_clt,r_clo,r_slo

c       DATA STATEMENTS:

C       FUNCTION STATEMENTS:

c       PROCESSING STEPS:

        r_clt = cos(r_lat)
        r_slt = sin(r_lat)
        r_clo = cos(r_lon)
        r_slo = sin(r_lon)

c     North  vector

        r_enumat(1,2) = -r_slt*r_clo
        r_enumat(2,2) = -r_slt*r_slo
        r_enumat(3,2) = r_clt

c     East vector

        r_enumat(1,1) = -r_slo
        r_enumat(2,1) = r_clo
        r_enumat(3,1) = 0.d0

c     Up vector

        r_enumat(1,3) = r_clt*r_clo
        r_enumat(2,3) = r_clt*r_slo
        r_enumat(3,3) = r_slt

        end


       include'intde2.f'
	   program main
	   integer alp
	   integer lenaw
	   double precision tiny,aw
	   parameter (lenew=8000)
	   parameter(tiny=1.d-307)
	   dimension aw(0:lenaw-1)
	   common/bl1/aw
	   common /bl2/alp
	   external h
!---------------------------------------------------------------
       open(1,file="data.dat", status="unknown")
	   call intdeini(lenaw,tiny,1.d-15,aw)
	   do 2 alp = 1,100
	   call intde(h,0.d0,1.d0,aw,s,err)
	   if(err.lt.0.d0)then
	          write(*,*) 'err=', err
			  pause
	   endif
	   write(*,*) 'tich phan=', s*alp**2
	   write(1,*) s*alp**2
  2	   enddo
	   stop
	   end
!----------------------------------------------------------------
       function h(rr)
	   double precision h
	   double precision rr
	   double precision rho,phi,z
	   double precision aw
	   double precision s,err,pi
	   common/bl/rho,phi,z
	   common/bl1/ aw
	   external g
	   pi = 3.14d0
	   rho = rr
	   call intde(g,pi,2.d0*pi,aw,s,err)
	   if(err.lt.0.d0)then
	          write(*,*) 'err=', err
			  pause
	   endif
	   h = s
       return
       end
!----------------------------------------------------------------
       function g(pp)
	   double precision g
	   double precision rr
	   double precision rho,phi,z
	   double precision aw
	   double precision s,err
	   common/bl/rho,phi,z
	   common/bl1/aw
	   external f
	   phi = pp
	   call intde(f,0.d0,1.d0,aw,s,err)
	   if(err.lt.0.d0)then
	          write(*,*) 'err=', err
			  pause
	   endif
	   g = s
       return
       end
!----------------------------------------------------------------
       function f(zz)
	   double precision f
	   double precision zz
	   double precision rho,phi,z
	   common/bl/rho,phi,z
	   z = zz
	   f = func(rho,phi,z)
       return
       end
!----------------------------------------------------------------
       function func(rho,phi,z)
	   double precision rho,phi,z
	   double precision func
	   integer alp
	   common /bl2/alp
	   func = rho**2*phi*DSQRT(z)
       return
       end
!----------------------------------------------------------------