SUBROUTINE shape_fun(fun,points,i)
!
!   This subroutine computes the values of the shape functions.
!   to local coordinates
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER,INTENT(in)::i
 REAL(iwp),INTENT(IN)::points(:,:)
 REAL(iwp),INTENT(OUT)::fun(:)
 REAL(iwp)::eta,xi,etam,etap,xim,xip,zetam,zetap,c1,c2,c3
 REAL(iwp)::t1,t2,t3,t4,t5,t6,t7,t8,t9
 REAL(iwp)::zeta,xi0,eta0,zeta0
 INTEGER::xii(20),etai(20),zetai(20),l,ndim,nod
 REAL,PARAMETER::pt125=0.125_iwp,pt25=0.25_iwp,pt5=0.5_iwp,pt75=0.75_iwp, &
   one=1.0_iwp,two=2.0_iwp,d3=3.0_iwp,d4=4.0_iwp,d8=8.0_iwp,d9=9.0_iwp,   &
   d16=16.0_iwp,d27=27.0_iwp,d32=32.0_iwp,d64=64.0_iwp,d128=128.0_iwp
 ndim=UBOUND(points,2)
 nod=UBOUND(fun,1)
 SELECT CASE(ndim)
 CASE(1) ! one dimensional case
   xi=points(i,1)
   SELECT CASE(nod)
   CASE(2)
     t1=-one-xi
     t2= one-xi
     fun(1)=t2/two
     fun(2)=-t1/two
   CASE(3)
     t1=-one-xi
     t2=-xi
     t3=one-xi
     fun(1)=t2*t3/two
     fun(2)=-t1*t3
     fun(3)=t1*t2/two
   CASE(4)
     t1=-one-xi
     t2=-one/d3-xi
     t3=one/d3-xi
     t4=one-xi
     fun(1)=t2*t3*t4*d9/d16
     fun(2)=-t1*t3*t4*d27/d16
     fun(3)=t1*t2*t4*d27/d16
     fun(4)=-t1*t2*t3*d9/d16
   CASE(5)
     t1=-one -xi
     t2=-pt5-xi
     t3=-xi
     t4=pt5-xi
     t5=one-xi
     fun(1)=t2*t3*t4*t5*two/d3
     fun(2)=-t1*t3*t4*t5*d8/d3
     fun(3)=t1*t2*t4*t5*d4
     fun(4)=-t1*t2*t3*t5*d8/d3
     fun(5)=t1*t2*t3*t4*two/d3
   CASE DEFAULT
     WRITE(*,*)"wrong number of nodes in shape_fun"
   END SELECT
 CASE(2) ! two dimensional case
   c1=points(i,1)
   c2=points(i,2)
   c3=one-c1-c2
   xi=points(i,1)
   eta=points(i,2)
   etam=pt25*(one-eta)
   etap=pt25*(one+eta)
   xim=pt25*(one-xi)
   xip=pt25*(one+xi)
   SELECT CASE(nod)
   CASE(3)
     fun = (/c1,c3,c2/)
   CASE(6)
     fun(1)=(two*c1-one)*c1
     fun(2)=d4*c3*c1
     fun(3)=(two*c3-one)*c3
     fun(4)=d4*c2*c3
     fun(5)=(two*c2-one)*c2
     fun(6)=d4*c1*c2
   CASE(10)
     fun(1)= ((d3*c1-one)*(d3*c1-two)*c1)/two
     fun(2)= -(d9*(d3*c1-one)*(c1+c2-one)*c1)/two
     fun(3)=  (d9*(d3*c1+d3*c2-two)*(c1+c2-one)*c1)/two
     fun(4)=-((d3*c1+d3*c2-one)*(d3*c1+d3*c2-two)*(c1+c2-one))/two
     fun(5)=  (d9*(d3*c1+d3*c2-two)*(c1+c2-one)*c2)/two
     fun(6)= -(d9*(c1+c2-one)*(d3*c2-one)*c2)/two
     fun(7)= ((d3*c2-one)*(d3*c2-two)*c2)/two
     fun(8)=  (d9*(d3*c2-one)*c1*c2)/two
     fun(9)=  (d9*(d3*c1-one)*c1*c2)/two
     fun(10)=-d27*((c2-one)+c1)*c1*c2
   CASE(15)
     t1=c1-pt25
     t2=c1-pt5
     t3=c1-pt75
     t4=c2-pt25
     t5=c2-pt5
     t6=c2-pt75
     t7=c3-pt25
     t8=c3-pt5
     t9=c3-pt75
     fun(1)=d32/d3*c1*t1*t2*t3
     fun(2)=d128/d3*c3*c1*t1*t2
     fun(3)=d64*c3*c1*t1*t7
     fun(4)=d128/d3*c3*c1*t7*t8
     fun(5)=d32/d3*c3*t7*t8*t9
     fun(6)=d128/d3*c2*c3*t7*t8
     fun(7)=d64*c2*c3*t4*t7
     fun(8)=d128/d3*c2*c3*t4*t5
     fun(9)=d32/d3*c2*t4*t5*t6
     fun(10)=d128/d3*c1*c2*t4*t5
     fun(11)=d64*c1*c2*t1*t4
     fun(12)=d128/d3*c1*c2*t1*t2
     fun(13)=d128*c1*c2*t1*c3
     fun(15)=d128*c1*c2*c3*t4
     fun(14)=d128*c1*c2*c3*t7
   CASE(4)
     fun=(/d4*xim*etam,d4*xim*etap,d4*xip*etap,d4*xip*etam/)
   CASE(5)
     fun=(/d4*xim*etam-pt25*(one-xi**2)*(one-eta**2),			  &
           d4*xim*etap-pt25*(one-xi**2)*(one-eta**2),			  &
           d4*xip*etap-pt25*(one-xi**2)*(one-eta**2),			  &
           d4*xip*etam-pt25*(one-xi**2)*(one-eta**2),			  &
           (one-xi**2)*(one-eta**2)/)
   CASE(8)
     fun=(/d4*etam*xim*(-xi-eta-one),d32*etam*xim*etap,                   &
           d4*etap*xim*(-xi+eta-one),d32*xim*xip*etap,                    &
           d4*etap*xip*(xi+eta-one), d32*etap*xip*etam,                   &
           d4*xip*etam*(xi-eta-one), d32*xim*xip*etam/)
   CASE(9)
     etam=eta-one
     etap=eta+one
     xim=xi-one
     xip=xi+one
     fun=(/pt25*xi*xim*eta*etam,-pt5*xi*xim*etap*etam,                    &
           pt25*xi*xim*eta*etap,-pt5*xip*xim*eta*etap,                    &
           pt25*xi*xip*eta*etap,-pt5*xi*xip*etap*etam,                    &
           pt25*xi*xip*eta*etam,-pt5*xip*xim*eta*etam,                    &
           xip*xim*etap*etam/)
   CASE DEFAULT
     WRITE(*,*)"wrong number of nodes in shape_fun"
   END SELECT
 CASE(3) ! d3 dimensional case
   xi=points(i,1)
   eta=points(i,2)
   zeta=points(i,3)
   etam=one-eta
   xim=one-xi
   zetam=one-zeta
   etap=eta+one
   xip=xi+one
   zetap=zeta+one
   SELECT CASE(nod)
   CASE(4)
     fun(1)=xi
     fun(2)=eta
     fun(3)=zeta
     fun(4)=one-fun(1)-fun(2)-fun(3)
   CASE(8)
     fun=(/pt125*xim*etam*zetam,pt125*xim*etam*zetap,                     &
           pt125*xip*etam*zetap,pt125*xip*etam*zetam,                     &
           pt125*xim*etap*zetam,pt125*xim*etap*zetap,                     &
           pt125*xip*etap*zetap,pt125*xip*etap*zetam/)
   CASE(14) ! type 6 element
     fun(1) = (xi*eta+xi*zeta+two*xi+eta*zeta+two*eta+two*zeta+two)*      &
       (xi-one)*(eta-one)*(zeta-one)/d8
     fun(2) =-(xi*eta-xi*zeta+two*xi-eta*zeta+two*eta-two*zeta+two)*      &
       (xi-one)*(eta-one)*(zeta+one)/d8
     fun(3) =-(xi*eta-xi*zeta+two*xi+eta*zeta-two*eta+two*zeta-two)*      &
       (xi+one)*(eta-one)*(zeta+one)/d8
     fun(4) = (xi*eta+xi*zeta+two*xi-eta*zeta-two*eta-two*zeta-two)*      &
       (xi+one)*(eta-one)*(zeta-one)/d8
     fun(5) =-(xi+one)*(xi-one)*(eta-one)*(zeta+one)*(zeta-one)/two
     fun(6) =-(xi-one)*(eta+one)*(eta-one)*(zeta+one)*(zeta-one)/two
     fun(7) = (xi+one)*(xi-one)*(eta+one)*(eta-one)*(zeta+one)/two
     fun(8) = (xi+one)*(eta+one)*(eta-one)*(zeta+one)*(zeta-one)/two
     fun(9) =-(xi+one)*(xi-one)*(eta+one)*(eta-one)*(zeta-one)/two
     fun(10)= (xi*eta-xi*zeta-two*xi+eta*zeta+two*eta-two*zeta-two)*      &
       (xi-one)*(eta+one)*(zeta-one)/d8
     fun(11)=-(xi*eta+xi*zeta-two*xi-eta*zeta+two*eta+two*zeta-two)*      &
       (xi-one)*(eta+one)*(zeta+one)/d8
     fun(12)=-(xi*eta+xi*zeta-two*xi+eta*zeta-two*eta-two*zeta+two)*      &
       (xi+one)*(eta+one)*(zeta+one)/d8
     fun(13)= (xi*eta-xi*zeta-two*xi-eta*zeta-two*eta+two*zeta+two)*      &
       (xi+one)*(eta+one)*(zeta-one)/d8
     fun(14)= (xi+one)*(xi-one)*(eta+one)*(zeta+one)*(zeta-one)/two
   CASE(20)
     xii=(/-1,-1,-1,0,1,1,1,0,-1,-1,1,1,-1,-1,-1,0,1,1,1,0/)
     etai=(/-1,-1,-1,-1,-1,-1,-1,-1,0,0,0,0,1,1,1,1,1,1,1,1/)
     zetai=(/-1,0,1,1,1,0,-1,-1,-1,1,1,-1,-1,0,1,1,1,0,-1,-1/)
     DO l=1,20
       xi0=xi*xii(l)
       eta0=eta*etai(l)
       zeta0=zeta*zetai(l)
       IF(l==4.OR.l==8.OR.l==16.OR.l==20)THEN
         fun(l)=pt25*(one-xi*xi)*(one+eta0)*(one+zeta0)
       ELSE IF(l>=9.AND.l<=12)THEN
         fun(l)=pt25*(one+xi0)*(one-eta*eta)*(one+zeta0)
       ELSE IF(l==2.OR.l==6.OR.l==14.OR.l==18)THEN
         fun(l)=pt25*(one+xi0)*(one+eta0)*(one-zeta*zeta)
       ELSE
         fun(l)=pt125*(one+xi0)*(one+eta0)*(one+zeta0)*(xi0+eta0+zeta0-2)
       END IF
     END DO
   CASE DEFAULT
     WRITE(*,*)"wrong number of nodes in shape_fun"
   END SELECT
 CASE DEFAULT
   WRITE(*,*)"wrong number of dimensions in shape_fun"
 END SELECT
RETURN
END SUBROUTINE shape_fun


module fftpack_library

    use fftpack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    use complex_transform_routines

    use real_transform_routines

    use cosine_transform_routines

    use sine_transform_routines

    use quarter_cosine_transform_routines

    use quarter_sine_transform_routines

    use type_FFTpack, only: &
        FFTpack

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: wp, ip
    public :: FFTpack
    public :: cfft1i, cfft1b, cfft1f, cfft2i, cfft2b, cfft2f, cfftmi, cfftmb, cfftmf
    public :: rfft1i, rfft1b, rfft1f, rfft2i, rfft2b, rfft2f, rfftmi, rfftmb, rfftmf
    public :: cost1i, cost1b, cost1f, costmi, costmb, costmf
    public :: sint1i, sint1b, sint1f, sintmi, sintmb, sintmf
    public :: cosq1i, cosq1b, cosq1f, cosqmi, cosqmb, cosqmf
    public :: sinq1i, sinq1b, sinq1f, sinqmi, sinqmb, sinqmf

end module fftpack_library


      subroutine gfun (t, y, g, mb)
c This subroutine computes the right-hand side function g(y,t).
c It uses r6d = 1/(6*dx), eodsq(*) = eta(*)/dx**2, nip,
c and nm1 = nip - 1 from the Common block par.
c
      integer mb,  ncomp, nip, nm1,  i, k
      double precision t, y, g,  r6d, eodsq,  cc, cl, cr, dli, dri, two
      dimension g(mb,*), y(mb,*)
      common /par/ r6d, eodsq(3), ncomp, nip, nm1
      data two/2.0d0/
c
c left-most interior point (k = 1)
      cc = y(1,1) + y(2,1) + y(3,1)
      cr = y(1,2) + y(2,2) + y(3,2)
      do 10 i = 1,mb
        dri = y(i,2) - y(i,1)
        g(i,1) = -r6d*(two*cc*y(i,2) + cr*dri)
     1         + eodsq(i)*(dri - y(i,1))
 10     continue
c
c interior points k = 2 to nip-1
      do 20 k = 2,nm1
        cl = y(1,k-1) + y(2,k-1) + y(3,k-1)
        cc = y(1,k) + y(2,k) + y(3,k)
        cr = y(1,k+1) + y(2,k+1) + y(3,k+1)
        do 15 i = 1,mb
          dli = y(i,k) - y(i,k-1)
          dri = y(i,k+1) - y(i,k)
          g(i,k) = -r6d*(cl*dli + two*cc*(dli + dri) + cr*dri)
     1           + eodsq(i)*(dri - dli)
 15       continue
 20     continue
c
c right-most interior point (k = nip)
      cl = y(1,nm1) + y(2,nm1) + y(3,nm1)
      cc = y(1,nip) + y(2,nip) + y(3,nip)
      do 30 i = 1,mb
        dli = y(i,nip) - y(i,nm1)
        g(i,nip) = -r6d*(cl*dli - two*cc*y(i,nm1))
     1           - eodsq(i)*(y(i,nip) + dli)
 30     continue
c
        t = t
      return
c end of subroutine gfun
      end


SUBROUTINE input(qdfile, xsfile, srcfile, mtfile, bcfile, iexit)

!-------------------------------------------------------------
!
!    Read the input from the input file
!
!    Comments below demonstrate order of the reading
!
!    Dependency:
!           angle   = gets the angular quadrature data
!           readxs  = reads the cross sections
!           readsrc = reads the source distribution
!           readmt  = read the material map
!           readbc  = read the boundary conditions
!           check   = input check on all the values
!
!    Allows for dynamic allocation. Uses module to hold all
!      input variables: invar, totvar
!
!-------------------------------------------------------------

USE invar
USE totvar
IMPLICIT NONE
INTEGER :: i, j, n, ierr
INTEGER, INTENT(OUT) :: iexit
INTEGER, DIMENSION(16) :: ipak
! File Names
CHARACTER(8), INTENT(OUT) :: qdfile, xsfile, srcfile, mtfile, bcfile
LOGICAL :: ex1, ex2, ex3, ex4, ex5
REAL*8 :: wtsum
REAL*8, DIMENSION(3) :: rpak

INCLUDE 'mpif.h'

! Read the title of the case
READ(7,103) title
103 FORMAT(A80)

! Read Problem Size Specification:
!   lambda => LAMDBA, the AHOT spatial order
!   meth  => = 0/1 = AHOT-N/AHOT-N-ITM
!   qdord => Angular quadrature order
!   qdtyp => Angular quadrature type = 0/1/2 = TWOTRAN/EQN/Read-in
!   nxt    => Number of 'x' cells
!   nyt    => Number of 'y' cells
!   npx   => Number of processes in x-dimension
!   npy   => Number of processes in y-dimension
!   ng    => Number of groups
!   nm    => Number of materials

READ(7,*) lambda, meth
READ(7,*) qdord, qdtyp

iexit = 0

! Check that the order given greater than zero and is even
IF (qdord <= 0) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal value for qdord. Must be greater than zero."
   iexit = iexit + 1
ELSE IF (MOD(qdord,2) /= 0) THEN
   WRITE(8,'(/,3x,A)') "ERROR: Illegal value for the quadrature order. Even #s only."
   iexit = iexit + 1
END IF

! Finish reading problem size
READ(7,*) nxt, nyt
READ(7,*) npx, npy
READ(7,*) ng, nm

! Set sizes for spatial mesh, read mesh sizes
!   dxt  => cell x-dimension
!   dyt  => cell y-dimension
ALLOCATE(dxt(nxt), dyt(nyt))

READ(7,*) (dxt(i), i = 1, nxt)
READ(7,*) (dyt(j), j = 1, nyt)

! Read the boundary condition flags
!   *bc = 0/1 = Vacuum/Value from bcfile
READ(7,*) q1bc, q2bc, q3bc, q4bc

! Read the names of files with cross sections and source distribution
READ(7,104) mtfile
READ(7,104) qdfile
READ(7,104) xsfile
READ(7,104) srcfile
READ(7,104) bcfile
104 FORMAT(A8)

! Perform quick checks on the files
INQUIRE(FILE = mtfile, EXIST = ex4)
INQUIRE(FILE = xsfile, EXIST = ex1)
INQUIRE(FILE = srcfile, EXIST = ex2)
IF (ex1 == .FALSE. .OR. ex2 == .FALSE. .OR. ex4 == .FALSE.) THEN
   WRITE(8,'(/,3X,A)') "ERROR: File does not exist for reading."
   iexit = iexit + 1
END IF
IF (q1bc==1 .OR. q2bc==1 .OR. q3bc==1 .OR. q4bc==1) THEN
   INQUIRE(FILE = bcfile, EXIST = ex5)
   IF (ex5 == .FALSE.) THEN
      WRITE(8,'(/,3X,A)') "ERROR: File does not exist for reading."
      iexit = iexit + 1
   END IF
END IF

! Read the iteration parameters
!   err    => Pointwise relative convergence criterion
!   bitmx  => Parallel block Jacobi maximum number of iterations
!   itmx   => Maximum number of iterations
!   iall   => Scalar Flux Spatial Moments Converged [0->LAMBDA]
!   tolr   => Tolerence for Convergence Check: determine whether abs or rel difference
READ(7,*) err, bitmx, itmx, iall, tolr

! Read the Solution Check Control:
!   ichk    => Frequency of check, 0 implies skip check
!   tchk    => Tolerence of solution check
READ(7,*) ichk, tchk

! Read the optional editing parameters
!   momp   => highest moment to be printed, [0->LAMBDA]
!   pmoaf  => flag to print moments of angular flux at boundaries: 0 for none, 1 for zero moment, 2 for all moments
READ(7,*) momp
READ(7,*) pmoaf

! Set up the extra needed info from the read input
apo = (qdord*(qdord+2))/8
order = lambda+1
ordsq = order*order

! Material Map
CALL readmt(mtfile)

   ! Angular quadrature
ALLOCATE(ang(apo,2), w(apo))
IF (qdtyp == 2) THEN
   INQUIRE(FILE=qdfile, EXIST=ex3)
   IF (qdfile == '        ' .OR. ex3 == .FALSE.) THEN
      WRITE(8,'(/,3x,A)') "ERROR: illegal entry for the qdfile name."
      iexit = iexit + 1
   END IF
   OPEN(UNIT=10, FILE=qdfile)
   READ(10,*)
   READ(10,*) (ang(n,1),ang(n,2),w(n),n=1,apo)
   ! Renormalize all the weights
   wtsum = SUM(w)
   DO n = 1, apo
      w(n) = w(n) * 0.25/wtsum
   END DO
ELSE
   CALL angle(iexit)
END IF

IF (qdtyp == 2) CLOSE(UNIT=10)

   ! Call for the input check
CALL check(iexit)

   ! Call to read the cross sections and source; do their own input check
CALL readxs(xsfile,iexit)
CALL readsrc(srcfile,iexit)

   ! Call to read the boundary condition input file; does own input check
CALL readbc(bcfile)

! Prepare initial information to go to all the processes in the system
! Integer package
ipak(1) = lambda
ipak(2) = meth
ipak(3) = nxt
ipak(4) = nyt
ipak(5) = npx
ipak(6) = npy
ipak(7) = ng
ipak(8) = nm
ipak(9) = bitmx
ipak(10) = itmx
ipak(11) = iall
ipak(12) = ichk
ipak(13) = apo
ipak(14) = order
ipak(15) = ordsq
ipak(16) = iexit
! Prepare the real package
rpak(1) = err
rpak(2) = tolr
rpak(3) = tchk
! Broadcast the information
CALL MPI_BCAST(ipak,16,MPI_INTEGER,irank,MPI_COMM_WORLD,ierr)
CALL MPI_BCAST(rpak,3,MPI_DOUBLE_PRECISION,irank,MPI_COMM_WORLD,ierr)
CALL MPI_BCAST(ang,(2*apo),MPI_DOUBLE_PRECISION,irank,MPI_COMM_WORLD,ierr)
CALL MPI_BCAST(w,apo,MPI_DOUBLE_PRECISION,irank,MPI_COMM_WORLD,ierr)
CALL MPI_BCAST(sigt,(ng*nm),MPI_DOUBLE_PRECISION,irank,MPI_COMM_WORLD,ierr)
CALL MPI_BCAST(sigs,(ng*ng*nm),MPI_DOUBLE_PRECISION,irank,MPI_COMM_WORLD,ierr)

RETURN
END SUBROUTINE input