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

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

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

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

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE CALC_CB_MEFM_MPF

! Calculates the modal participation factors and modal mass via the technique described in my document MPF.doc:

!                                  MPF = EIGEN_VEC'(MLL*DLR + MRL)/GEN_MASS

! MPF has a number of rows equal to the number of eigenvectors and a number of columns equal to the number of L-set DOF's.
! In this subr the transpose of MPF (MPFt) is first calculated which is then transposed to get MPF, where MPFt is

!                                  MPFt = (MLL*DLR + MRL)'*EIGEN_VEC//GEN_MASS

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

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  WRT_ERR, WRT_LOG, ERR, F04, F06
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR,                                                                  &
                                         NDOFL, NDOFR, NTERM_MPF0 , NVEC
      USE TIMDAT, ONLY                :  TSEC
      USE CONSTANTs_1, ONLY           :  ZERO, ONE
      USE PARAMS, ONLY                :  MPFOUT
      USE SUBR_BEGEND_LEVELS, ONLY    :  CALC_CB_MEFM_MPF_BEGEND
      USE RIGID_BODY_DISP_MATS, ONLY  :  TR6_MEFM
      USE SPARSE_MATRICES, ONLY       :  I_MPF0 , J_MPF0 , MPF0 , SYM_MPF0
      USE SCRATCH_MATRICES, ONLY      :  I_CRS1, J_CRS1, CRS1
      USE EIGEN_MATRICES_1, ONLY      :  EIGEN_VEC, GEN_MASS, MEFFMASS, MPFACTOR_NR, MPFACTOR_N6

      USE CALC_CB_MEFM_MPF_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'CALC_CB_MEFM_MPF'
!                                                              'N' for nonsymmetric storage)

      INTEGER(LONG)                   :: I,J,K                   ! DO loop indices
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = CALC_CB_MEFM_MPF_BEGEND

      REAL(DOUBLE)                    :: DUM1(NDOFR,6)           ! Intermediate matrix
      REAL(DOUBLE)                    :: MEFW_MAT_RR(NDOFR,NDOFR)! Modal eff wgt for 1 mode for all R DOF's
      REAL(DOUBLE)                    :: MEFW_MAT_66(6,6)        ! Modal eff wgt for 1 mode transformed to CG via TR6_CG
      REAL(DOUBLE)                    :: MEFW_DIAG_NR(NVEC,NDOFR)! Matrix whose i-th row is the diagonal from MEFW for mode i
      REAL(DOUBLE)                    :: MPFt(NDOFR,NVEC)        ! Transpose of MPF
      REAL(DOUBLE)                    :: MPFi(1,NDOFR)           ! i-th row of MPF
      REAL(DOUBLE)                    :: MPFit(NDOFR,1)          ! MPFi'

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

! **********************************************************************************************************************************
      CALL ALLOCATE_EIGEN1_MAT ( 'MEFFMASS', NVEC, 6    , SUBR_NAME )
      CALL ALLOCATE_EIGEN1_MAT ( 'MPFACTOR_NR', NVEC, NDOFR, SUBR_NAME )

! Convert sparse NDOFRxNVEC matrix MPF0 = (MRL + DLRt*MLL)*EIGEN_VEC to full matrix. MPF0 is gen mass times transpose of MPFACTOR

      CALL SPARSE_CRS_TO_FULL  ( 'MPF0', NTERM_MPF0, NDOFR, NVEC, SYM_MPF0, I_MPF0, J_MPF0, MPF0, MPFt )

      DO I=1,NVEC                                          ! Scale by gen mass. Transpose is MPFACTOR matrix
         DO J=1,NDOFR
            MPFACTOR_NR(I,J) = MPFt(J,I)/GEN_MASS(I)
         ENDDO
      ENDDO

      IF (MPFOUT == '6') THEN
         CALL ALLOCATE_EIGEN1_MAT ( 'MPFACTOR_N6', NVEC, 6, SUBR_NAME )
         CALL MATMULT_FFF ( MPFACTOR_NR, TR6_MEFM, NVEC, NDOFR, 6, MPFACTOR_N6 )
      ENDIF

! Calculate modal effective mass from MPF's

      DO I=1,NVEC
                                                           ! MPF is an NVEC x NDOFR matrix of modal participation factors
         DO J=1,NDOFR
            MPFit(J,1) = MPFACTOR_NR(I,J)                  ! MPFit is a col vec equal to the I-th row of MPF (MPF's for mode i)
         ENDDO

         DO J=1,NDOFR
            MPFi(1,J)  = MPFACTOR_NR(I,J)                  ! MPFi is a row vec of the MPF's for mode i (MPFit = MPFi')
         ENDDO
                                                           ! MEFW_MAT_RR = MPFi'xMPFi ( a square matrix of NDOFR x NDOFR)
         CALL MATMULT_FFF ( MPFit, MPFi, NDOFR, 1, NDOFR, MEFW_MAT_RR )
         DO J=1,NDOFR
            DO K=1,NDOFR                                   ! Scale MEFW_MAT_RR by GEN_MASS
               MEFW_MAT_RR(J,K) = GEN_MASS(I)*MEFW_MAT_RR(J,K)
            ENDDO
         ENDDO

         DO J=1,NDOFR                                      ! MEFW_DIAG_NR are diagonals from MEFW_MAT_RR (NDOFR x NDOFR)
            MEFW_DIAG_NR(I,J) = MEFW_MAT_RR(J,J)
         ENDDO
                                                           ! Reduce NDOFR x NDOFR MEFW_MAT_RR to 6 x 6 MEFW_MAT_66
         CALL MATMULT_FFF   ( MEFW_MAT_RR, TR6_MEFM, NDOFR, NDOFR, 6, DUM1 )
         CALL MATMULT_FFF_T ( TR6_MEFM, DUM1, NDOFR, 6, 6, MEFW_MAT_66 )

         DO J=1,6                                          ! Get diags from MEFW_MAT_66 and put into the ith row of MEFFMASS
            MEFFMASS(I,J) = MEFW_MAT_66(J,J)
         ENDDO

      ENDDO

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

      RETURN

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

97865 format(32767(1es14.6))

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

      END SUBROUTINE CALC_CB_MEFM_MPF


      SUBROUTINE DL7TVM(N, X, L, Y)
C
C  ***  COMPUTE  X = (L**T)*Y, WHERE  L  IS AN  N X N  LOWER
C  ***  TRIANGULAR MATRIX STORED COMPACTLY BY ROWS.  X AND Y MAY
C  ***  OCCUPY THE SAME STORAGE.  ***
C
      INTEGER N
      DOUBLE PRECISION X(N), L(1), Y(N)
C     DIMENSION L(N*(N+1)/2)
      INTEGER I, IJ, I0, J
      DOUBLE PRECISION YI, ZERO
C/6
C     DATA ZERO/0.D+0/
C/7
      PARAMETER (ZERO=0.D+0)
C/
C
      I0 = 0
      DO 20 I = 1, N
         YI = Y(I)
         X(I) = ZERO
         DO 10 J = 1, I
              IJ = I0 + J
              X(J) = X(J) + YI*L(IJ)
 10           CONTINUE
         I0 = I0 + I
 20      CONTINUE
 999  RETURN
C  ***  LAST CARD OF DL7TVM FOLLOWS  ***
      END


      SUBROUTINE bandec(a,n,m1,m2,np,mp,al,mpl,indx,d)
      INTEGER m1,m2,mp,mpl,n,np,indx(n)
      REAL d,a(np,mp),al(np,mpl),TINY
      PARAMETER (TINY=1.e-20)
      INTEGER i,j,k,l,mm
      REAL dum
      mm=m1+m2+1
      if(mm.gt.mp.or.m1.gt.mpl.or.n.gt.np) pause 'bad args in bandec'
      l=m1
      do 13 i=1,m1
        do 11 j=m1+2-i,mm
          a(i,j-l)=a(i,j)
11      continue
        l=l-1
        do 12 j=mm-l,mm
          a(i,j)=0.
12      continue
13    continue
      d=1.
      l=m1
      do 18 k=1,n
        dum=a(k,1)
        i=k
        if(l.lt.n)l=l+1
        do 14 j=k+1,l
          if(abs(a(j,1)).gt.abs(dum))then
            dum=a(j,1)
            i=j
          endif
14      continue
        indx(k)=i
        if(dum.eq.0.) a(k,1)=TINY
        if(i.ne.k)then
          d=-d
          do 15 j=1,mm
            dum=a(k,j)
            a(k,j)=a(i,j)
            a(i,j)=dum
15        continue
        endif
        do 17 i=k+1,l
          dum=a(i,1)/a(k,1)
          al(k,i-k)=dum
          do 16 j=2,mm
            a(i,j-1)=a(i,j)-dum*a(k,j)
16        continue
          a(i,mm)=0.
17      continue
18    continue
      return
      END

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


! { dg-do run }
! { dg-additional-options "-msse2" { target sse2_runtime } }
! { dg-additional-options "-mavx" { target avx_runtime } }

module SIMD4_mod
contains
  subroutine work( b, n, m )
     implicit none
     real       :: b(n)
     integer    :: i,n,m

     call init(b, n)

     !$omp simd safelen(16)
     do i = m+1, n
        b(i) = b(i-m) - 1.0
     end do
  end subroutine work

  subroutine work_ref( b, n, m )
     implicit none
     real       :: b(n)
     integer    :: i,n,m

     call init(b, n)

     do i = m+1, n
        b(i) = b(i-m) - 1.0
     end do
  end subroutine work_ref

  subroutine init (b, n)
    real             :: b(*)
    integer          :: n, i, s

    s = -1
    do i = 1, n
      b(i) = i * i * s
      s = -s
    end do

  end subroutine

  subroutine check (a, b, n)
    integer :: i, n
    real, parameter :: EPS = 0.000001
    real :: diff, a(*), b(*)
    do i = 1, n
      diff = a(i) - b(i)
      if (diff > EPS .or. -diff > EPS) call abort
    end do
  end subroutine

end module

program SIMD4
  use SIMD4_mod
  real :: b(128), b_ref(128)

  call  work(b, 128, 32)
  call  work_ref(b_ref, 128, 32)

  call check(b, b_ref, 128)
end program


c
c     file tcud24sp.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213

c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c
c ... purpose
c
c     test program for the complex MUDPACK solver cud24sp
c
c ... required MUDPACK files
c
c     cud24sp.f, cud2sp.f, cudcom.f
c
c
c
c *********************************************************
c *********************************************************
c
c     sample program/test driver for cud24sp
c
c **********************************************************
c **********************************************************
c
c
c     a sample program/test driver for cud24sp is listed below.  it
c     can be executed as an initial test.  the output is listed for
c     the test case described.
c
c     test the driver below by solving the complex separable elliptic pde
c
c          cmplx(1.+x*x,1-x*x)*pxx + cmplx(exp(1.-y),exp(y))*(pyy-py) -
c
c          (cmplx(x,x) + cmplx(y,y))*pe(x,y) = r(x,y)
c
c     on the (x,y) region
c
c         [1/4,3/4] X [1/3,2/3]
c
c     with specified boundaries at upper x boundry xb = 3/4 and
c     the lower y boundary yc = 1/3 and mixed boundary conditions
c     at the lower x boundry xa = 1/4
c
c          dp/dx - p = g(y)
c
c     and upper y boundary yd = 2/3
c
c          dp/dy + p = h(x)
c
c     Use point relaxation, the default multigrid options and
c     the exact solution
c
c          pe(x,y) = cmplx(y**5,x**4+1.0)
c
c     to set the righthand side, boundary conditions, and compute
c     error.  the approximation is generated on a 129 by 97 grid.
c     First cud2sp is called to render a second-order approximation.
c     then cud24sp is called for a fourth-order estimate
c
c
c *************************************************************
c     output (64 bit floating point arithmetic)
c *************************************************************
c
c     cud2sp test
c
c     integer input arguments
c     intl =  0 nxa =  2 nxb =  1 nyc =  1 nyd =  2
c     ixp =  2 jyq =  3 iex =  7 jey =  6
c     nx = 129 ny =  97 iguess =  0 maxcy =  3
c     method =  0 work space estimate =   48976
c
c     multigrid option arguments
c     kcycle =  0
c     iprer =  0
c     ipost =  0
c     intpol =  0
c
c     floating point input parameters
c     xa =  0.000 xb =  1.000 yc =  0.000 yd =  1.000
c     tolerance (error control) =    0.000E+00
c
c     discretization call to cud2sp intl =  0
c     ierror =  0 minimum work space =   48976
c
c     approximation call to cud2sp
c     intl =  1 method =  0 iguess =  0
c     ierror =  0
c     maximum error  =   0.317E-03
c
c     cud24sp test  ierror =  0
c     maximum error  =   0.621E-06
c
c ***************************************************************
c      end of output
c ***************************************************************
c
      program tcud24sp
      implicit none
      integer iixp,jjyq,iiex,jjey,nnx,nny,llw
c
c     set grid sizes with parameter statements
c
      parameter (iixp = 2 , jjyq = 3 , iiex =7, jjey = 6)
      parameter (nnx=iixp*2**(iiex-1)+1, nny=jjyq*2**(jjey-1)+1)
c
c     set minimum required work space (see tmud2sp.f)
c
      parameter (llw = 48976)
c
c     dimension solution,right hand side, and work arrays
c
      complex p(nnx,nny),r(nnx,nny),w(llw)
c     put integer and floating point parameter names in contiguous
c     storeage for labelling purposes
c
      integer iprm(16),mgopt(4)
      real fprm(6)
      integer intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      common/itcud2sp/intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      real xa,xb,yc,yd,tolmax,relmax
      common/ftcud2sp/xa,xb,yc,yd,tolmax,relmax
      equivalence(intl,iprm)
      equivalence(xa,fprm)
      integer i,j,ierror
      complex pe,px,py,pxx,pyy,cxx,cyy,cx,cy,cex,cey,ce
      real dlx,dly,x,y,errmax
c
c     declare coefficient and boundary condition input subroutines external
c
      external cfx,cfy,bndc
c
c
c     set input integer arguments
c
      intl = 0
c
c     set boundary condition flags
c
      nxa = 2
      nxb = 1
      nyc = 1
      nyd = 2
c
c     set grid sizes from parameter statements
c
      ixp = iixp
      jyq = jjyq
      iex = iiex
      jey = jjey
      nx = nnx
      ny = nny
c
c     set three multigrid cycles
c
      maxcy = 3
c
c     set work space length approximation from parameter statement
c
      nwork = llw
c
c     set point relaxation
c
      method = 0
c
c     flag no initial guess (this sets full multigrid cycling)
c
      iguess = 0
c
c     set end points of solution rectangle in (x,y) space
c
      xa = 0.0
      xb = 1.0
      yc = 0.0
      yd = 1.0
c
c     set mesh increments
c
      dlx = (xb-xa)/float(nx-1)
      dly = (yd-yc)/float(ny-1)
c
c     set for no error control
c
      tolmax = 0.0
c
c     set right hand side in r
c     initialize p to zero
c
      do i=1,nx
	x = xa+float(i-1)*dlx
	call cfx(x,cxx,cx,cex)
	do j=1,ny
	  y = yc+float(j-1)*dly
	  call cfy(y,cyy,cy,cey)
	  ce = cex+cey
	  call exact(x,y,pxx,pyy,px,py,pe)
	  r(i,j) = cxx*pxx+cyy*pyy+cx*px+cy*py+ce*pe
	  p(i,j) = (0.0,0.0)
	end do
      end do
c
c     set specified boundaries in p
c
      x = xb
      do j=1,ny
	y = yc+float(j-1)*dly
	call exact(x,y,pxx,pyy,px,py,pe)
	p(nx,j) = pe
      end do
      y = yc
      do i=1,nx
	x = xa+float(i-1)*dlx
	call exact(x,y,pxx,pyy,px,py,pe)
	p(i,1) = pe
      end do
c
c     set default multigrid opitons
c
      mgopt(1) = 0
c
c     print input parameters (except multigrid options which are default)
c
      write(6,100)
  100 format(//' cud2sp test ')
      write (*,101) (iprm(i),i=1,15)
  101 format(/' integer input arguments ',
     +/'intl = ',i2,' nxa = ',i2,' nxb = ',i2,' nyc = ',i2,' nyd = ',i2,
     +/' ixp = ',i2,' jyq = ',i2,' iex = ',i2,' jey = ',i2
     +/' nx = ',i3,' ny = ',i3,' iguess = ',i2,' maxcy = ',i2,
     +/' method = ',i2, ' work space estimate = ',i7)
      write (*,102) (mgopt(i),i=1,4)
  102 format(/' multigrid option arguments ',
     +/' kcycle = ',i2,
     +/' iprer = ',i2,
     +/' ipost = ',i2
     +/' intpol = ',i2)
      write(*,103) xa,xb,yc,yd,tolmax
  103 format(/' floating point input parameters ',
     +/' xa = ',f6.3,' xb = ',f6.3,' yc = ',f6.3,' yd = ',f6.3,
     +/' tolerance (error control) =   ',e10.3)
c
c     intiialization call
c
      write(*,104) intl
  104 format(/' discretization call to cud2sp', ' intl = ', i2)
      call cud2sp(iprm,fprm,w,cfx,cfy,bndc,r,p,mgopt,ierror)
c
c     print error parameter and minimum work space requirement
c
      write (*,105) ierror,iprm(16)
  105 format(' ierror = ',i2, ' minimum work space = ',i7)
      if (ierror.gt.0) call exit(0)
c
c     attempt solution
c
      intl = 1
      write(*,106) intl,method,iguess
  106 format(/' approximation call to cud2sp ',
     +/' intl = ',i2, ' method = ',i2,' iguess = ',i2)
      call cud2sp(iprm,fprm,w,cfx,cfy,bndc,r,p,mgopt,ierror)
      write (*,107) ierror
  107 format(' ierror = ',i2)
c
c     compute and print exact maximum error
c
      errmax = 0.0
      do j=1,ny
	y = yc+(j-1)*dly
	do i=1,nx
	  x = xa+(i-1)*dlx
	  call exact(x,y,pxx,pyy,px,py,pe)
	  errmax = amax1(errmax,cabs((p(i,j)-pe)))
	end do
      end do
      write(*,108) errmax
  108 format(' maximum error  =  ',e10.3)
c
c     fourth-order estimate
c
      call cud24sp(w,p,ierror)
      write(*,109) ierror
  109 format(/' cud24sp test ', ' ierror = ',i2)
      errmax = 0.0
      do j=1,ny
	y = yc+(j-1)*dly
	do i=1,nx
	  x = xa+(i-1)*dlx
	  call exact(x,y,pxx,pyy,px,py,pe)
	  errmax = amax1(errmax,cabs((p(i,j)-pe)))
	end do
      end do
      write(*,108) errmax
      end

      subroutine cfx(x,cxx,cx,cex)
c
c     input x dependent complex coefficients
c
      implicit none
      real x
      complex cxx,cx,cex
      cxx = cmplx(1.+x*x,1.-x*x)
      cx = (0.,0.)
      cex = -cmplx(x,x)
      return
      end

      subroutine cfy(y,cyy,cy,cey)
c
c     input y dependent complex coefficients
c
      implicit none
      real y
      complex cyy,cy,cey
      cyy = cmplx(exp(1.0-y),exp(y))
      cy = -cyy
      cey = -cmplx(y,y)
      return
      end

      subroutine bndc(kbdy,xory,cons,gbdy)
c
c     input mixed complex derivative b.c. to cud2sp
c
      implicit none
      integer kbdy
      real xory,x,y
      complex cons,gbdy,pe,px,py,pxx,pyy
      real xa,xb,yc,yd,tolmax,relmax
      common/ftcud2sp/xa,xb,yc,yd,tolmax,relmax
      if (kbdy.eq.1) then
c
c     x=xa boundary
c
	y = xory
	x = xa
	cons =(-1.0,0.0)
	call exact(x,y,pxx,pyy,px,py,pe)
	gbdy = px + cons*pe
	return
      end if
      if (kbdy.eq.4) then
c
c     y=yd boundary
c
	y = yd
	x = xory
	cons = (1.0,0.0)
	call exact(x,y,pxx,pyy,px,py,pe)
	gbdy = py + cons*pe
	return
      end if
      end

      subroutine exact(x,y,pxx,pyy,px,py,pe)
c
c     set exact solution used for testing cud2sp
c
      implicit none
      real x,y
      complex pe,px,py,pxx,pyy
      pe = cmplx(y**5.,x**4+1.)
      px = cmplx(0.,4.*x**3)
      pxx = cmplx(0.,12.*x**2)
      py = cmplx(5.*y**4,0.)
      pyy = cmplx(20.*y**3,0.)
      return
      end


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM
! Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! Test for USE statement when there is rename of user-defined operator in the
! ONLY option.

module m
  interface operator(.add.)
    module procedure func
  end interface
contains
  integer function func(x, y)
    integer, intent(in) :: x, y
    func = x + y
  end function
end module

program p
  use m, only: operator(.localadd.) => operator(.add.)
  implicit none
  if ((1 .localadd. 2) /= 3) STOP 1
  print *, "PASS"
end program


module stuff
 contains
    subroutine subdomain( x,  iam, ipoints)
        real x(:)
        integer iam
        integer ipoints
        integer ibot,itop,i
        integer sum
        ibot=(iam)*ipoints+1
        itop=ibot+ipoints-1
        do i=ibot,itop
            x(i)=iam
        enddo
        sum=0
        do i=ibot,itop
            sum=sum+x(i)
        enddo
    !$omp critical
        write(*,*)" iam= ",iam," doing ",ibot,itop,sum/ipoints
    !$omp end critical
    end subroutine

    subroutine pdomain( x,  iam, ipoints)
        real x(:)
        integer iam,ipoints
        integer ibot,itop,i
        real  y
        ibot=(iam)*ipoints+1
        itop=ibot+ipoints-1
        write(*,*)" section= ",iam,"is from ",ibot," to ",itop
        y=x(ibot)
        do i=ibot,itop
            if(y .ne. x(i))y=x(i)
        enddo
        if(y .eq. x(ibot)) then
            write(*,*)" and contains",y
        else
            write(*,*)" failed"
        endif
    end subroutine
end module

program mymain
    use stuff
    integer omp_get_thread_num,omp_get_num_threads
    integer i,iam,np,npoints,ipoints
    real, allocatable :: x(:)
!   x=0
!$omp parallel shared(x,npoints,np) default(none) private(iam,ipoints)
        npoints=2*3*4*5*7
        iam = omp_get_thread_num()
        np = omp_get_num_threads()
!$omp single
            if(allocated(x))write(*,*)"single fails"
            allocate(x(npoints))
!$omp end single
!$omp barrier
        ipoints = npoints/np
        write(*,*)ipoints,iam
        call subdomain(x,iam,ipoints)
!$omp end parallel
    write(*,*)"outside of the parallel region"
    do i=0,np-1
       ipoints = npoints/np
       call pdomain(x,i,ipoints)
    enddo
end program


      subroutine runCY_00ll(k,l,Xtwiddle,Gtwiddle,Shat4,N0)
      implicit none
C---  Expression for Eq. 5.58a
C---  Calculates C00ll
C---  Small terms of order Xtwiddle(0,k)*Ciii,Xtwiddle(0,0)*Ciiii
C---  Denominator Gtwiddle(k,l)
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      integer ep,N0,k,l,np
      parameter(np=2)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat4(np,z3max,-2:0)

      do ep=-2,0
      Cv(czzii(z2(l,l))+N0,ep)=
     .  (Gtwiddle(k,1)*Shat4(1,z3(l,l,l),ep)
     .  +Gtwiddle(k,2)*Shat4(2,z3(l,l,l),ep)
     .  +Xtwiddle(0,k)*Cv(ciii(z3(l,l,l))+N0,ep)
     .  -Xtwiddle(0,0)*Cv(ciiii(z4(k,l,l,l))+N0,ep))/(6*Gtwiddle(k,l))
      enddo

      return
      end


program inverse
use cholesky
use cudafor
use cublas
integer, parameter :: n=1024
complex(8):: A_h(n,n),B_h(n,n)
complex(8),device :: B(n,n)

real*8:: x,y,threshold=1.d-14
integer:: info
type(dim3):: threads
type(cudaEvent):: startEvent,stopEvent
type(cusolverDnHandle):: h
real:: time
logical:: print=.false.

istat=cudaEventCreate(startEvent)
istat=cudaEventCreate(stopEvent)

! Generate hermitian positive definite matrix

do j=1,n
 do i=j,n
  call random_number(x)
  call random_number(y)
  A_h(i,j)=cmplx(x,y)
  A_h(j,i)=conjg(A_h(i,j))
  if (i==j) A_h(i,j)=real(A_h(i,j))
 end do
end do

call zgemm('N', 'C', N, N, N, cmplx(1.0, 0.0, 8), A_h, N, A_h, N, cmplx(0.0, 0.0, 8), B_h, N)
A_h=B_h

!A_h is an hermitian positive definite matrix

! Copy the matrix to the device
B=A_h

print *,"calling CPU zpotrf "
! Call Cholesky
call zpotrf('L', n, A_h, n, INFO )

if (info .lt.  0) print *,"Error in CPU path !!!!!!!!!!!!!",info

print *,"calling GPU zpotrf "
! Call Cholesky
call zpotrf('L', n, B, n, INFO )
if (info .lt.  0) print *,"Error in GPU path !!!!!!!!!!!!!",info

! Copy result back to host to compare it to CPU solution
B_h=B

print *,"Difference "
   print *,(B_h(1,1)-A_h(1,1))
   print *,(B_h(n/2,n/2)-A_h(n/2,n/2))
   print *,(B_h(n,n)-A_h(n,n))
end program inverse


      subroutine zpassb4 (ido,l1,cc,ch,wa1,wa2,wa3)
      implicit double precision (a-h,o-z)
      dimension       cc(ido,4,l1)           ,ch(ido,l1,4)           ,
     1                wa1(1)     ,wa2(1)     ,wa3(1)
      if (ido .ne. 2) go to 102
      do 101 k=1,l1
         ti1 = cc(2,1,k)-cc(2,3,k)
         ti2 = cc(2,1,k)+cc(2,3,k)
         tr4 = cc(2,4,k)-cc(2,2,k)
         ti3 = cc(2,2,k)+cc(2,4,k)
         tr1 = cc(1,1,k)-cc(1,3,k)
         tr2 = cc(1,1,k)+cc(1,3,k)
         ti4 = cc(1,2,k)-cc(1,4,k)
         tr3 = cc(1,2,k)+cc(1,4,k)
         ch(1,k,1) = tr2+tr3
         ch(1,k,3) = tr2-tr3
         ch(2,k,1) = ti2+ti3
         ch(2,k,3) = ti2-ti3
         ch(1,k,2) = tr1+tr4
         ch(1,k,4) = tr1-tr4
         ch(2,k,2) = ti1+ti4
         ch(2,k,4) = ti1-ti4
  101 continue
      return
  102 do 104 k=1,l1
         do 103 i=2,ido,2
            ti1 = cc(i,1,k)-cc(i,3,k)
            ti2 = cc(i,1,k)+cc(i,3,k)
            ti3 = cc(i,2,k)+cc(i,4,k)
            tr4 = cc(i,4,k)-cc(i,2,k)
            tr1 = cc(i-1,1,k)-cc(i-1,3,k)
            tr2 = cc(i-1,1,k)+cc(i-1,3,k)
            ti4 = cc(i-1,2,k)-cc(i-1,4,k)
            tr3 = cc(i-1,2,k)+cc(i-1,4,k)
            ch(i-1,k,1) = tr2+tr3
            cr3 = tr2-tr3
            ch(i,k,1) = ti2+ti3
            ci3 = ti2-ti3
            cr2 = tr1+tr4
            cr4 = tr1-tr4
            ci2 = ti1+ti4
            ci4 = ti1-ti4
            ch(i-1,k,2) = wa1(i-1)*cr2-wa1(i)*ci2
            ch(i,k,2) = wa1(i-1)*ci2+wa1(i)*cr2
            ch(i-1,k,3) = wa2(i-1)*cr3-wa2(i)*ci3
            ch(i,k,3) = wa2(i-1)*ci3+wa2(i)*cr3
            ch(i-1,k,4) = wa3(i-1)*cr4-wa3(i)*ci4
            ch(i,k,4) = wa3(i-1)*ci4+wa3(i)*cr4
  103    continue
  104 continue
      return
      end


      subroutine getperp(p,i1,i2,v1,v2)
************************************************************************
*                                                                      *
*     Given two momenta, p(i1,..) and p(i2, ..), construct two         *
*     vectors v1 and v2 that satisfy:                                  *
*                                                                      *
*      v1.p1 = 0, v1.p2 = 0                                            *
*      v2.p1 = 0, v2.p2 = 0                                            *
*      v1.v2 = 0                                                       *
*      v1.v1 = -1, v2.v2 = -1                                          *
*                                                                      *
*     Author: J.M.Campbell                                             *
*       Date: 19th March 2009                                          *
*                                                                      *
************************************************************************
      implicit none
      include 'constants.f'
      double precision p(mxpart,4),p1(4),p2(4),v1(4),v2(4),dotpr,p1Dp2,
     . offset,vsq,vDp1,vDp2,v1Dv2,tiny
      integer i1,i2,nu
      parameter(tiny=1d-15)

c--- set up vectors p1,p2 and normalize
      do nu=1,4
        p1(nu)=p(i1,nu)/p(i1,4)
        p2(nu)=p(i2,nu)/p(i2,4)
      enddo

      p1Dp2=dotpr(p1,p2)

c--- construct momentum v1 orthognal to p1 and p2

c--- offset is to avoid exceptional configurations, usually it is zero
      offset=0d0

   22 continue

      v1(4)=0d0
      v1(1)=5d0+offset
      v1(2)=3d0-offset
      v1(3)=4d0-offset

      vsq=dotpr(v1,v1)
      vDp1=dotpr(v1,p1)
      vDp2=dotpr(v1,p2)

c--- avoid the case where we construct a momentum v1 with v1.v1=0
      if (abs(vsq-2d0*vDp1*vDp2/p1Dp2) .lt. tiny) then
        offset=offset+0.7d0
        goto 22
      endif

      do nu=1,4
        v1(nu)=v1(nu)-(vDp1*p2(nu)+vDp2*p1(nu))/p1Dp2
      enddo

c--- normalize so that v1.v1=-1
      vsq=dotpr(v1,v1)
      do nu=1,4
        v1(nu)=v1(nu)/dsqrt(-vsq)
      enddo

c--- construct momentum v2 orthogonal to p1 and p2

c--- offset is to avoid exceptional configurations, usually it is zero
      offset=0d0

   33 continue

      v2(4)=0d0
      v2(1)=1d0-offset
      v2(2)=2d0+offset
      v2(3)=3d0+offset

      vsq=dotpr(v2,v2)
      vDp1=dotpr(v2,p1)
      vDp2=dotpr(v2,p2)

c--- avoid the case where we construct a momentum v2 with v2.v2=0
      if (abs(vsq-2d0*vDp1*vDp2/p1Dp2) .lt. tiny) then
        offset=offset+0.6d0
        goto 33
      endif

      do nu=1,4
        v2(nu)=v2(nu)-(vDp1*p2(nu)+vDp2*p1(nu))/p1Dp2
      enddo

c--- now ensure that v1.v2=0
      v1Dv2=dotpr(v1,v2)
      vsq=dotpr(v1,v1)
      do nu=1,4
        v2(nu)=v2(nu)-v1(nu)*v1Dv2/vsq
      enddo

c--- normalize so that v2.v2=-1
      vsq=dotpr(v2,v2)
c--- avoid the case where we construct a momentum v2 with v2.v2=0
c--- ( -vsq should be positive)
      if (-vsq .lt. tiny) then
        offset=offset+0.6d0
        goto 33
      endif

      do nu=1,4
        v2(nu)=v2(nu)/dsqrt(-vsq)
      enddo

c--- for checking
c      write(6,*) 'v1.v1 = ',dotpr(v1,v1)
c      write(6,*) 'v2.v2 = ',dotpr(v2,v2)
c      write(6,*) 'v1.v2 = ',dotpr(v1,v2)
c      write(6,*) 'v1.p1 = ',dotpr(v1,p1)
c      write(6,*) 'v1.p2 = ',dotpr(v1,p2)
c      write(6,*) 'v2.p1 = ',dotpr(v2,p1)
c      write(6,*) 'v2.p2 = ',dotpr(v2,p2)

      return
      end

      double precision function dotpr(p,q)
c--- returns the dot product of the two four vectors p(4) and q(4)
      implicit none
      double precision p(4),q(4)

      dotpr=p(4)*q(4)-p(1)*q(1)-p(2)*q(2)-p(3)*q(3)

      return
      end


      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION H(3),X(2),R(2),G(2),Z(2)
      EPS=1.D-06
      N=2
      A=100.
      B=1.
      C=-2.
      D=-198.
      E=0.
      F=99.
      X(1)=1.
      X(2)=10.
      WRITE (6,*) 'ENTER FUNCTION COEFFICIENTS (0. FOR TEST CASE)'
      WRITE (6,*) 'X**2'
      READ (5,*) AA
      IF(AA.EQ.0.) GOTO 2
      A=AA
      WRITE (6,*) 'Y**2'
      READ (5,*) B
      WRITE (6,*) 'XY'
      READ (5,*) C
      WRITE (6,*) 'X'
      READ (5,*) D
      WRITE (6,*) 'Y'
      READ (5,*) E
      WRITE (6,*) '0'
      READ (5,*) F
      WRITE (6,*) 'ENTER STARTING POINT'
      READ (5,*) X(1),X(2)
   2  WRITE (6,*) 'ENTER METHOD     0 = STEEPEST DESCENT'
      WRITE (6,*) '                 1 = CONJUGATE GRADIENT'
      READ (5,*) METH
      H(1)=A*2.
      H(2)=C
      H(3)=B*2.
      R(1)=-D
      R(2)=-E
      CALL MINIM (H,X,R,G,Z,EPS,F,N,METH)
      WRITE (6,*) METH
      STOP
      END
      SUBROUTINE MINIM (A,X,B,G,Z,EPS,F0,N,METH)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),X(1),B(1),G(1),Z(1)
      ZERO=0.D 00
      TOL=EPS*EPS
      PREC=TOL*1.D-06
      ZMOD=1.D 00
      TAU=ZERO
      ITER=0
      MAX=N*100
      IF(METH.EQ.1) MAX=N*2
      ICONJ=0
      WRITE (6,200)
      DO 1 I=1,N
   1  Z(I)=ZERO
C
   2  CONTINUE
      CALL TLVECT (A,X,G,N)
      FCT=F0+DOTPRO(X,G,N)/2.-DOTPRO(X,B,N)
      DO 4 I=1,N
   4  G(I)=G(I)-B(I)
C
      BR=ZMOD
      ZMOD=DOTPRO(G,G,N)
      CONV=DSQRT(ZMOD)
C
      WRITE (6,201) ITER,FCT,CONV,X(1),X(2),Z(1),Z(2),TAU
      ITER=ITER+1
      IF(ITER.GT.MAX) GOTO 99
      IF(ZMOD.LT.TOL) GOTO 99
C
      GAM=ZMOD/BR
      IF(ICONJ.EQ.0) GAM=ZERO
      IF(METH.EQ.0) GAM=ZERO
      ICONJ=1
      DO 6 I=1,N
   6  Z(I)=-G(I)+GAM*Z(I)
      CONV=DOTPRO(Z,G,N)
      CALL TLVECT (A,Z,G,N)
      TEST=DOTPRO (Z,G,N)
      IF(TEST.LT.PREC) TEST=PREC
      TAU=-CONV/TEST
C
      DO 10 I=1,N
  10  X(I)=X(I)+TAU*Z(I)
      GOTO 2
C
  99  RETURN
 200  FORMAT(' IT   FUNCTION        |G|       X(1)       X(2)',
     *       '       Z(1)       Z(2)       TAU'/1X,79(1H-))
 201  FORMAT(I3,7F11.3)
      END
      SUBROUTINE TLVECT(S,V1,V2,L)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION S(1),V1(L),V2(L)
      ZERO=0.D 00
      V2(1)=S(1)*V1(1)
      IF (L-1) 4,4,1
   1  IJ=1
      DO 3 I=2,L
      V2(I)=ZERO
      I1=I-1
      DO 2 J=1,I1
      IJ=IJ+1
      V2(I)=V2(I)+S(IJ)*V1(J)
   2  V2(J)=V2(J)+S(IJ)*V1(I)
      IJ=IJ+1
   3  V2(I)=V2(I)+S(IJ)*V1(I)
   4  RETURN
      END
      FUNCTION DOTPRO (A,B,M)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),B(1)
      DOTPRO=0.D 00
C
      DO 1 I=1,M
   1  DOTPRO=DOTPRO+A(I)*B(I)
C
      RETURN
      END


*----------------------------------------------------------------------*
      subroutine optc_diis_extr(xmat,xvec,ndim,ndel,xscr,kpiv)
*----------------------------------------------------------------------*
*
*     xmat contains the DIIS B-matrix; obtain the new extrapolation
*     weights on xvec
*
*----------------------------------------------------------------------*

      implicit none

      include 'stdunit.h'

      integer, parameter ::
     &     ntest = 00

      integer, intent(in) ::
     &     ndim
      integer, intent(out) ::
     &     ndel
      integer, intent(inout) ::
     &     kpiv(*)
      real(8), intent(in) ::
     &     xmat(*)
      real(8), intent(out) ::
     &     xvec(*)
      real(8), intent(inout) ::
     &     xscr(*)

      logical ::
     &     again
      integer ::
     &     ncdim, ii, jj, iioff, iioff2
      real(8) ::
     &     cond, xcorsum

      if (ntest.gt.0) then
        write(lulog,*) '===================='
        write(lulog,*) ' DIIS extrapolation'
        write(lulog,*) '===================='
      end if

      again = .true.
      ncdim = ndim
      do while(again)
        ndel = ndim - ncdim
        do ii = 1, ncdim
          iioff  = ii*(ii-1)/2
          iioff2 = (ii+ndel)*(ii+ndel-1)/2 + ndel
          do jj = 1, ii
            xscr(iioff+jj) = xmat(iioff2+jj)
          end do
        end do
        iioff = ncdim*(ncdim+1)/2
        do jj = 1, ncdim
          xscr(iioff+jj) = -1d0
        end do
        xscr(iioff+ncdim+1) = 0d0

        if (ntest.ge.20) then
          write(lulog,*) 'Augmented matrix passed to dspco:'
          call prtrlt(xscr,ncdim+1)
        end if

* solve DIIS problem to obtain new weights
        ! first factorize the DIIS matrix and get its condition number
        call dspco(xscr,ncdim+1,kpiv,cond,xvec)
        if (ntest.ge.15) write(lulog,*)'ncdim,condition number: ',
     &       ncdim,cond
        if (cond.eq.0d0) call quit(1,'optc_diis_extr',
     &       'condition number = 0. maxsub > # of parameters?')
        if (ntest.ge.30) then
          write(lulog,*) 'Factorized matrix from dspco:'
          call prtrlt(xscr,ncdim+1)
          write(lulog,*) 'Pivot array:'
          call iwrtma(kpiv,1,ncdim+1,1,ncdim+1)
        end if

        ! ... we set up the RHS vector and solve the DIIS equations
        xvec(1:ncdim) =  0d0
        xvec(ncdim+1) = -1d0
        call dspsl(xscr,ncdim+1,kpiv,xvec)
        if (ntest.ge.10) then
          write(lulog,*) 'result of dspsl:'
          write(lulog,*) 'w:', xvec(1:ncdim)
          write(lulog,*) 'l:', xvec(ncdim+1)
        end if

* analyze solution and request deletion of vectors, if necessary
        xcorsum = 0d0
c        do ii = 1, ncdim-1
c          xcorsum = xcorsum + abs(xvec(ii))
c        end do
c        if (xcorsum/abs(xvec(ncdim)).gt.1.2d0) then
c          ncdim = ncdim -1
c        else
          again = .false.
c        end if

      end do

      if (ncdim.lt.ndim) then
        ndel = ndim-ncdim
        do ii = ncdim, 1, -1
          xvec(ii+ndel) = xvec(ii)
        end do
        xvec(1:ndel) = 0d0
      end if

      if (ntest.ge.10) then
        write(lulog,*) 'final result for extrapolation weights:'
        call wrtmat2(xvec,1,ndim,1,ndim)
      end if

      return
      end


      SUBROUTINE STIMBR( LINE, NM, MVAL, NVAL, NK, KVAL, NNB, NBVAL,
     $                   NXVAL, NLDA, LDAVAL, TIMMIN, A, B, D, TAU,
     $                   WORK, RESLTS, LDR1, LDR2, LDR3, NOUT )
*
*  -- LAPACK timing routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      CHARACTER*80       LINE
      INTEGER            LDR1, LDR2, LDR3, NK, NLDA, NM, NNB, NOUT
      REAL               TIMMIN
*     ..
*     .. Array Arguments ..
      INTEGER            KVAL( * ), LDAVAL( * ), MVAL( * ), NBVAL( * ),
     $                   NVAL( * ), NXVAL( * )
      REAL               A( * ), B( * ), D( * ),
     $                   RESLTS( LDR1, LDR2, LDR3, * ), TAU( * ),
     $                   WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  STIMBR times SGEBRD, SORGBR, and SORMBR.
*
*  Arguments
*  =========
*
*  LINE    (input) CHARACTER*80
*          The input line that requested this routine.  The first six
*          characters contain either the name of a subroutine or a
*          generic path name.  The remaining characters may be used to
*          specify the individual routines to be timed.  See ATIMIN for
*          a full description of the format of the input line.
*
*  NM      (input) INTEGER
*          The number of values of M and N contained in the vectors
*          MVAL and NVAL.  The matrix sizes are used in pairs (M,N).
*
*  MVAL    (input) INTEGER array, dimension (NM)
*          The values of the matrix row dimension M.
*
*  NVAL    (input) INTEGER array, dimension (NM)
*          The values of the matrix column dimension N.
*
*  NK      (input) INTEGER
*          The number of values of K contained in the vector KVAL.
*
*  KVAL    (input) INTEGER array, dimension (NK)
*          The values of the matrix dimension K.
*
*  NNB     (input) INTEGER
*          The number of values of NB and NX contained in the
*          vectors NBVAL and NXVAL.  The blocking parameters are used
*          in pairs (NB,NX).
*
*  NBVAL   (input) INTEGER array, dimension (NNB)
*          The values of the blocksize NB.
*
*  NXVAL   (input) INTEGER array, dimension (NNB)
*          The values of the crossover point NX.
*
*  NLDA    (input) INTEGER
*          The number of values of LDA contained in the vector LDAVAL.
*
*  LDAVAL  (input) INTEGER array, dimension (NLDA)
*          The values of the leading dimension of the array A.
*
*  TIMMIN  (input) REAL
*          The minimum time a subroutine will be timed.
*
*  A       (workspace) REAL array, dimension (LDAMAX*NMAX)
*          where LDAMAX and NMAX are the maximum values of LDA and N.
*
*  B       (workspace) REAL array, dimension (LDAMAX*NMAX)
*
*  D       (workspace) REAL array, dimension
*                      (2*max(min(M,N))-1)
*
*  TAU     (workspace) REAL array, dimension
*                      (2*max(min(M,N)))
*
*  WORK    (workspace) REAL array, dimension (LDAMAX*NBMAX)
*          where NBMAX is the maximum value of NB.
*
*  RESLTS  (output) REAL array, dimension (LDR1,LDR2,LDR3,6)
*          The timing results for each subroutine over the relevant
*          values of (M,N), (NB,NX), and LDA.
*
*  LDR1    (input) INTEGER
*          The first dimension of RESLTS.  LDR1 >= max(1,NNB).
*
*  LDR2    (input) INTEGER
*          The second dimension of RESLTS.  LDR2 >= max(1,NM).
*
*  LDR3    (input) INTEGER
*          The third dimension of RESLTS.  LDR3 >= max(1,NLDA).
*
*  NOUT    (input) INTEGER
*          The unit number for output.
*
*  Internal Parameters
*  ===================
*
*  MODE    INTEGER
*          The matrix type.  MODE = 3 is a geometric distribution of
*          eigenvalues.  See CLATMS for further details.
*
*  COND    REAL
*          The condition number of the matrix.  The singular values are
*          set to values from DMAX to DMAX/COND.
*
*  DMAX    REAL
*          The magnitude of the largest singular value.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NSUBS
      PARAMETER          ( NSUBS = 3 )
      INTEGER            MODE
      REAL               COND, DMAX
      PARAMETER          ( MODE = 3, COND = 100.0E0, DMAX = 1.0E0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          LABK, LABM, LABN, SIDE, TRANS, VECT
      CHARACTER*3        PATH
      CHARACTER*6        CNAME
      INTEGER            I, I3, I4, IC, ICL, IK, ILDA, IM, INB, INFO,
     $                   INFO2, ISIDE, ISUB, ITOFF, ITRAN, IVECT, K, K1,
     $                   LDA, LW, M, M1, MINMN, N, N1, NB, NQ, NX
      REAL               OPS, S1, S2, TIME, UNTIME
*     ..
*     .. Local Arrays ..
      LOGICAL            TIMSUB( NSUBS )
      CHARACTER          SIDES( 2 ), TRANSS( 2 ), VECTS( 2 )
      CHARACTER*6        SUBNAM( NSUBS )
      INTEGER            ISEED( 4 ), RESEED( 4 )
*     ..
*     .. External Functions ..
      REAL               SECOND, SMFLOP, SOPLA
      EXTERNAL           SECOND, SMFLOP, SOPLA
*     ..
*     .. External Subroutines ..
      EXTERNAL           ATIMCK, ATIMIN, ICOPY, SGEBRD, SLACPY, SLATMS,
     $                   SORGBR, SORMBR, SPRTB4, SPRTB5, STIMMG, XLAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL
*     ..
*     .. Data statements ..
      DATA               SUBNAM / 'SGEBRD', 'SORGBR', 'SORMBR' / ,
     $                   SIDES / 'L', 'R' / , VECTS / 'Q', 'P' / ,
     $                   TRANSS / 'N', 'T' /
      DATA               ISEED / 0, 0, 0, 1 /
*     ..
*     .. Executable Statements ..
*
*     Extract the timing request from the input line.
*
      PATH( 1: 1 ) = 'Single precision'
      PATH( 2: 3 ) = 'BR'
      CALL ATIMIN( PATH, LINE, NSUBS, SUBNAM, TIMSUB, NOUT, INFO )
      IF( INFO.NE.0 )
     $   GO TO 220
*
*     Check that M <= LDA for the input values.
*
      CNAME = LINE( 1: 6 )
      CALL ATIMCK( 1, CNAME, NM, MVAL, NLDA, LDAVAL, NOUT, INFO )
      IF( INFO.GT.0 ) THEN
         WRITE( NOUT, FMT = 9999 )CNAME
         GO TO 220
      END IF
*
*     Check that N <= LDA and K <= LDA for SORMBR
*
      IF( TIMSUB( 3 ) ) THEN
         CALL ATIMCK( 2, CNAME, NM, NVAL, NLDA, LDAVAL, NOUT, INFO )
         CALL ATIMCK( 3, CNAME, NK, KVAL, NLDA, LDAVAL, NOUT, INFO2 )
         IF( INFO.GT.0 .OR. INFO2.GT.0 ) THEN
            WRITE( NOUT, FMT = 9999 )SUBNAM( 3 )
            TIMSUB( 3 ) = .FALSE.
         END IF
      END IF
*
*     Do for each pair of values (M,N):
*
      DO 140 IM = 1, NM
         M = MVAL( IM )
         N = NVAL( IM )
         MINMN = MIN( M, N )
         CALL ICOPY( 4, ISEED, 1, RESEED, 1 )
*
*        Do for each value of LDA:
*
         DO 130 ILDA = 1, NLDA
            LDA = LDAVAL( ILDA )
*
*           Do for each pair of values (NB, NX) in NBVAL and NXVAL.
*
            DO 120 INB = 1, NNB
               NB = NBVAL( INB )
               CALL XLAENV( 1, NB )
               NX = NXVAL( INB )
               CALL XLAENV( 3, NX )
               LW = MAX( M+N, MAX( 1, NB )*( M+N ) )
*
*              Generate a test matrix of size M by N.
*
               CALL ICOPY( 4, RESEED, 1, ISEED, 1 )
               CALL SLATMS( M, N, 'Uniform', ISEED, 'Nonsym', TAU, MODE,
     $                      COND, DMAX, M, N, 'No packing', B, LDA,
     $                      WORK, INFO )
*
               IF( TIMSUB( 1 ) ) THEN
*
*                 SGEBRD:  Block reduction to bidiagonal form
*
                  CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
                  IC = 0
                  S1 = SECOND( )
   10             CONTINUE
                  CALL SGEBRD( M, N, A, LDA, D, D( MINMN ), TAU,
     $                         TAU( MINMN+1 ), WORK, LW, INFO )
                  S2 = SECOND( )
                  TIME = S2 - S1
                  IC = IC + 1
                  IF( TIME.LT.TIMMIN ) THEN
                     CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
                     GO TO 10
                  END IF
*
*                 Subtract the time used in SLACPY.
*
                  ICL = 1
                  S1 = SECOND( )
   20             CONTINUE
                  S2 = SECOND( )
                  UNTIME = S2 - S1
                  ICL = ICL + 1
                  IF( ICL.LE.IC ) THEN
                     CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
                     GO TO 20
                  END IF
*
                  TIME = ( TIME-UNTIME ) / REAL( IC )
                  OPS = SOPLA( 'SGEBRD', M, N, 0, 0, NB )
                  RESLTS( INB, IM, ILDA, 1 ) = SMFLOP( OPS, TIME, INFO )
               ELSE
*
*                 If SGEBRD was not timed, generate a matrix and reduce
*                 it using SGEBRD anyway so that the orthogonal
*                 transformations may be used in timing the other
*                 routines.
*
                  CALL SLACPY( 'Full', M, N, B, LDA, A, LDA )
                  CALL SGEBRD( M, N, A, LDA, D, D( MINMN ), TAU,
     $                         TAU( MINMN+1 ), WORK, LW, INFO )
*
               END IF
*
               IF( TIMSUB( 2 ) ) THEN
*
*                 SORGBR:  Generate one of the orthogonal matrices Q or
*                 P' from the reduction to bidiagonal form
*                 A = Q * B * P'.
*
                  DO 50 IVECT = 1, 2
                     IF( IVECT.EQ.1 ) THEN
                        VECT = 'Q'
                        M1 = M
                        N1 = MIN( M, N )
                        K1 = N
                     ELSE
                        VECT = 'P'
                        M1 = MIN( M, N )
                        N1 = N
                        K1 = M
                     END IF
                     I3 = ( IVECT-1 )*NLDA
                     LW = MAX( 1, MAX( 1, NB )*MIN( M, N ) )
                     CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
                     IC = 0
                     S1 = SECOND( )
   30                CONTINUE
                     CALL SORGBR( VECT, M1, N1, K1, B, LDA, TAU, WORK,
     $                            LW, INFO )
                     S2 = SECOND( )
                     TIME = S2 - S1
                     IC = IC + 1
                     IF( TIME.LT.TIMMIN ) THEN
                        CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
                        GO TO 30
                     END IF
*
*                    Subtract the time used in SLACPY.
*
                     ICL = 1
                     S1 = SECOND( )
   40                CONTINUE
                     S2 = SECOND( )
                     UNTIME = S2 - S1
                     ICL = ICL + 1
                     IF( ICL.LE.IC ) THEN
                        CALL SLACPY( 'Full', M, N, A, LDA, B, LDA )
                        GO TO 40
                     END IF
*
                     TIME = ( TIME-UNTIME ) / REAL( IC )
*
*                    Op count for SORGBR:
*
                     IF( IVECT.EQ.1 ) THEN
                        IF( M1.GE.K1 ) THEN
                           OPS = SOPLA( 'SORGQR', M1, N1, K1, -1, NB )
                        ELSE
                           OPS = SOPLA( 'SORGQR', M1-1, M1-1, M1-1, -1,
     $                           NB )
                        END IF
                     ELSE
                        IF( K1.LT.N1 ) THEN
                           OPS = SOPLA( 'SORGLQ', M1, N1, K1, -1, NB )
                        ELSE
                           OPS = SOPLA( 'SORGLQ', N1-1, N1-1, N1-1, -1,
     $                           NB )
                        END IF
                     END IF
*
                     RESLTS( INB, IM, I3+ILDA, 2 ) = SMFLOP( OPS, TIME,
     $                  INFO )
   50             CONTINUE
               END IF
*
               IF( TIMSUB( 3 ) ) THEN
*
*                 SORMBR:  Multiply an m by n matrix B by one of the
*                 orthogonal matrices Q or P' from the reduction to
*                 bidiagonal form A = Q * B * P'.
*
                  DO 110 IVECT = 1, 2
                     IF( IVECT.EQ.1 ) THEN
                        VECT = 'Q'
                        K1 = N
                        NQ = M
                     ELSE
                        VECT = 'P'
                        K1 = M
                        NQ = N
                     END IF
                     I3 = ( IVECT-1 )*NLDA
                     I4 = 2
                     DO 100 ISIDE = 1, 2
                        SIDE = SIDES( ISIDE )
                        DO 90 IK = 1, NK
                           K = KVAL( IK )
                           IF( ISIDE.EQ.1 ) THEN
                              M1 = NQ
                              N1 = K
                              LW = MAX( 1, MAX( 1, NB )*N1 )
                           ELSE
                              M1 = K
                              N1 = NQ
                              LW = MAX( 1, MAX( 1, NB )*M1 )
                           END IF
                           ITOFF = 0
                           DO 80 ITRAN = 1, 2
                              TRANS = TRANSS( ITRAN )
                              CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
                              IC = 0
                              S1 = SECOND( )
   60                         CONTINUE
                              CALL SORMBR( VECT, SIDE, TRANS, M1, N1,
     $                                     K1, A, LDA, TAU, B, LDA,
     $                                     WORK, LW, INFO )
                              S2 = SECOND( )
                              TIME = S2 - S1
                              IC = IC + 1
                              IF( TIME.LT.TIMMIN ) THEN
                                 CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
                                 GO TO 60
                              END IF
*
*                             Subtract the time used in STIMMG.
*
                              ICL = 1
                              S1 = SECOND( )
   70                         CONTINUE
                              S2 = SECOND( )
                              UNTIME = S2 - S1
                              ICL = ICL + 1
                              IF( ICL.LE.IC ) THEN
                                 CALL STIMMG( 0, M1, N1, B, LDA, 0, 0 )
                                 GO TO 70
                              END IF
*
                              TIME = ( TIME-UNTIME ) / REAL( IC )
                              IF( IVECT.EQ.1 ) THEN
*
*                                Op count for SORMBR, VECT = 'Q':
*
                                 IF( NQ.GE.K1 ) THEN
                                    OPS = SOPLA( 'SORMQR', M1, N1, K1,
     $                                    ISIDE-1, NB )
                                 ELSE IF( ISIDE.EQ.1 ) THEN
                                    OPS = SOPLA( 'SORMQR', M1-1, N1,
     $                                    NQ-1, ISIDE-1, NB )
                                 ELSE
                                    OPS = SOPLA( 'SORMQR', M1, N1-1,
     $                                    NQ-1, ISIDE-1, NB )
                                 END IF
                              ELSE
*
*                                Op count for SORMBR, VECT = 'P':
*
                                 IF( NQ.GT.K1 ) THEN
                                    OPS = SOPLA( 'SORMLQ', M1, N1, K1,
     $                                    ISIDE-1, NB )
                                 ELSE IF( ISIDE.EQ.1 ) THEN
                                    OPS = SOPLA( 'SORMLQ', M1-1, N1,
     $                                    NQ-1, ISIDE-1, NB )
                                 ELSE
                                    OPS = SOPLA( 'SORMLQ', M1, N1-1,
     $                                    NQ-1, ISIDE-1, NB )
                                 END IF
                              END IF
*
                              RESLTS( INB, IM, I3+ILDA,
     $                           I4+ITOFF+IK ) = SMFLOP( OPS, TIME,
     $                           INFO )
                              ITOFF = NK
   80                      CONTINUE
   90                   CONTINUE
                        I4 = 2*NK + 2
  100                CONTINUE
  110             CONTINUE
               END IF
  120       CONTINUE
  130    CONTINUE
  140 CONTINUE
*
*     Print a table of results for each timed routine.
*
      DO 210 ISUB = 1, NSUBS
         IF( .NOT.TIMSUB( ISUB ) )
     $      GO TO 210
         WRITE( NOUT, FMT = 9998 )SUBNAM( ISUB )
         IF( NLDA.GT.1 ) THEN
            DO 150 I = 1, NLDA
               WRITE( NOUT, FMT = 9997 )I, LDAVAL( I )
  150       CONTINUE
         END IF
         IF( ISUB.EQ.1 ) THEN
            WRITE( NOUT, FMT = * )
            CALL SPRTB4( '(  NB,  NX)', 'M', 'N', NNB, NBVAL, NXVAL, NM,
     $                   MVAL, NVAL, NLDA, RESLTS( 1, 1, 1, ISUB ),
     $                   LDR1, LDR2, NOUT )
         ELSE IF( ISUB.EQ.2 ) THEN
            DO 160 IVECT = 1, 2
               I3 = ( IVECT-1 )*NLDA + 1
               IF( IVECT.EQ.1 ) THEN
                  LABK = 'N'
                  LABM = 'M'
                  LABN = 'K'
               ELSE
                  LABK = 'M'
                  LABM = 'K'
                  LABN = 'N'
               END IF
               WRITE( NOUT, FMT = 9996 )SUBNAM( ISUB ), VECTS( IVECT ),
     $            LABK, LABM, LABN
               CALL SPRTB4( '(  NB,  NX)', LABM, LABN, NNB, NBVAL,
     $                      NXVAL, NM, MVAL, NVAL, NLDA,
     $                      RESLTS( 1, 1, I3, ISUB ), LDR1, LDR2, NOUT )
  160       CONTINUE
         ELSE IF( ISUB.EQ.3 ) THEN
            DO 200 IVECT = 1, 2
               I3 = ( IVECT-1 )*NLDA + 1
               I4 = 3
               DO 190 ISIDE = 1, 2
                  IF( ISIDE.EQ.1 ) THEN
                     IF( IVECT.EQ.1 ) THEN
                        LABM = 'M'
                        LABN = 'K'
                     ELSE
                        LABM = 'K'
                        LABN = 'M'
                     END IF
                     LABK = 'N'
                  ELSE
                     IF( IVECT.EQ.1 ) THEN
                        LABM = 'N'
                        LABN = 'K'
                     ELSE
                        LABM = 'K'
                        LABN = 'N'
                     END IF
                     LABK = 'M'
                  END IF
                  DO 180 ITRAN = 1, 2
                     DO 170 IK = 1, NK
                        WRITE( NOUT, FMT = 9995 )SUBNAM( ISUB ),
     $                     VECTS( IVECT ), SIDES( ISIDE ),
     $                     TRANSS( ITRAN ), LABK, KVAL( IK )
                        CALL SPRTB5( 'NB', LABM, LABN, NNB, NBVAL, NM,
     $                               MVAL, NVAL, NLDA,
     $                               RESLTS( 1, 1, I3, I4 ), LDR1, LDR2,
     $                               NOUT )
                        I4 = I4 + 1
  170                CONTINUE
  180             CONTINUE
  190          CONTINUE
  200       CONTINUE
         END IF
  210 CONTINUE
  220 CONTINUE
 9999 FORMAT( 1X, A6, ' timing run not attempted', / )
 9998 FORMAT( / ' *** Speed of ', A6, ' in megaflops ***' )
 9997 FORMAT( 5X, 'line ', I2, ' with LDA = ', I5 )
 9996 FORMAT( / 5X, A6, ' with VECT = ''', A1, ''', ', A1, ' = MIN(',
     $      A1, ',', A1, ')', / )
 9995 FORMAT( / 5X, A6, ' with VECT = ''', A1, ''', SIDE = ''', A1,
     $      ''', TRANS = ''', A1, ''', ', A1, ' =', I6, / )
      RETURN
*
*     End of STIMBR
*
      END


c      program DRDXRK8
c>> 2008-02-24 DRDXRK8  Krogh -- Change dimenstions for new usage.
c>> 2001-05-25 DRDXRK8  Krogh -- Added comma to format.
c>> 1997-12-18 DRDXRK8  Krogh   Initial code
c--D replaces "?": DR?XRK8, ?XRK8, ?XRK8F, ?XRK8O
c Sample driver for DXRK8 --  Set up to solve simple two body problem
c with circular motion.
c
      integer NEQ, LIDAT, LDAT, LWORK
      parameter (NEQ=4, LIDAT=49+2, LDAT=32+2*NEQ+2+2, LWORK=9*4+6+8*4)
      integer IDAT(LIDAT)
      double precision DAT(LDAT), TS(3), TOL, Y(NEQ), WORK(LWORK)
      double precision OPT(6)
c++S Default SETTOL = 'TOL = 1.E-4'
c++  Default SETTOL = 'TOL = 1.D-10'
c++  Replace 'TOL = 1.D-10' = SETTOL
      parameter (TOL = 1.D-10)
      double precision XRKEND, XRKAE, XRKTDT
      parameter (XRKEND=0.D0, XRKAE=2.D0, XRKTDT=24.D0)
c            Abs. Err. tol.   Output at intervals of 2 Pi       End opt.
      data  OPT /XRKAE,TOL, XRKTDT,0.D0,6.283185307179586477D0, XRKEND/
      data   IDAT(4), IDAT(5), IDAT(6), IDAT(7) /
     1           NEQ,   LIDAT,    LDAT,   LWORK /
c      Starting:  T     H;  Final T.
      data  TS / 0.D0, 0.D0, 20.D0 /
c      Initial Y
      data Y / 1.D0, 0.D0, 0.D0, 1.D0 /
c
c Do the integration
      IDAT(1) = 0
  100 continue
         call DXRK8(TS, Y, OPT, IDAT, DAT, WORK)
         if (IDAT(1) .NE. 3) go to 100
      stop
      end

      subroutine DXRK8F(T, Y, F, IDAT)
c Sample derivative subroutine for use with DXRK8
c This evaluates derivatives for a simple two body problem.
c
      integer          IDAT(*)
      double precision T, Y(*), F(*), RQBI
c
c Evaluate the derivatives
      RQBI = 1.D0 / ((sqrt(Y(1)**2+Y(3)**2))**3)
      F(1) = Y(2)
      F(2) = -Y(1)*RQBI
      F(3) = Y(4)
      F(4) = -Y(3)*RQBI
      return
      end

      subroutine DXRK8O(TS, Y, IDAT, DAT)
c Sample output subroutine for use with DXRK8.
c This subroutine gives output for a simple two body problem.
c
      integer          IDAT(*)
      double precision TS(*), Y(*), DAT(*)
 1000 format (6X, 'RESULTS FOR A SIMPLE 2-BODY PROBLEM'//
     1   8X, 'T', 13X, 'U/V', 11X, 'UP/VP'/' ')
 1001 format (1P,3E15.6 / 15X, 2E15.6/' ')
c
c Do the output
      if (TS(1) .eq. 0.D0) then
        write (*, 1000)
      end if
      write (*, 1001) TS(1), Y(1), Y(2), Y(3), Y(4)
      return
      end


PROGRAM gs_heat_plate_mpi
  ! Description:
  !   This program solves the heat transfer in celsius of a plate in a square domain using the gauss-sidel method.
  ! Input files:
  !   The input to this file is inteded to come from stdin. However from the CLI a file
  !   is used with the < operator. In this file, the domain, heater_x,
  !   and heater_y should be specified in that order on seperate lines for it work wo/ user input.

  USE kind_module, ONLY : prec
  USE mympi
  USE mpi

  IMPLICIT NONE
  !
  ! Include statements
  ! Declarations must be of the form:
  ! [type] [VariableName]     !Description

  !Local parameters:

  !Local scalars:
  INTEGER :: i,j,iter=0 !- Loop variables
  REAL(kind = prec) :: elapsed_time
  INTEGER :: error
  LOGICAL :: quitProg = .FALSE.
  !
  ! The varaibles below are the initial temperatures for
  ! the boudaries of the plate and the value of convergence.
  !
  TYPE heat_info_type
      INTEGER :: domain ! The area that contains the nodes of the virtual plate
      INTEGER :: heater_x, heater_y  ! The x and y location of the heater
      INTEGER :: heater_rank ! the processor rank that contains the heater
      REAL(kind = prec) :: init_temp !-initial temperature of the plate
      REAL(kind = prec) :: heater_temp !-initial temperature of the heater
      REAL(kind = prec) :: heat_top, heat_bottom, heat_left, heat_right!-initial temperatures of the boundaries
      REAL(kind = prec) :: convergence !-convergence criteria to end program
  END TYPE heat_info_type

  TYPE(heat_info_type) :: heat_info ! heat information for each processor

  TYPE grid_info_type
     INTEGER :: p    ! total number of processors
     INTEGER :: commcart  ! grid communicator
     INTEGER :: rank     ! processors rank in the grid
     INTEGER :: north    ! north neighbor
     INTEGER :: south   ! south neighbor
     INTEGER :: east     ! east neighbor
     INTEGER :: west    ! west neighbor
     INTEGER :: nx       ! number of local points in the x direction
     INTEGER :: ny       ! number of local points in the y direction
     ! Start of receive buffers
     REAL(kind = prec), ALLOCATABLE :: rnorth_buffer(:)
     REAL(kind = prec), ALLOCATABLE :: rsouth_buffer(:)
     REAL(kind = prec), ALLOCATABLE :: rwest_buffer(:)
     REAL(kind = prec), ALLOCATABLE :: reast_buffer(:)
     ! Start of send buffers
     REAL(kind = prec), ALLOCATABLE :: snorth_buffer(:)
     REAL(kind = prec), ALLOCATABLE :: ssouth_buffer(:)
     REAL(kind = prec), ALLOCATABLE :: swest_buffer(:)
     REAL(kind = prec), ALLOCATABLE :: seast_buffer(:)
  END TYPE grid_info_type

  ! Type instantiations
  TYPE(grid_info_type) :: grid_info ! grid information for each processor

  !- Local arrays:
  REAL(prec), ALLOCATABLE, DIMENSION(:,:) :: t
  REAL(prec), ALLOCATABLE, DIMENSION(:,:) :: t_old

  !
  ! MPI variables
  !
  INTEGER :: ndummy = 1
  INTEGER :: globaliter = 0
  INTEGER :: mpierror, procs, myid !
  INTEGER :: nx !domain in x ;
  INTEGER :: ny !domain in y

  heat_info%domain = 500
  nx = heat_info%domain
  ny = heat_info%domain
!
!
! Initialize temperature variables
!
!
heat_info%heater_x = 251
heat_info%heater_y = 251
! check the bounds of the heaters location.
IF (heat_info%heater_x>heat_info%domain .OR. heat_info%heater_x<1 .OR. &
     &heat_info%heater_y < 1.OR. heat_info%heater_y>heat_info%domain) THEN
		WRITE(*,*) 'Error: invalid heater location - it is out of the domain.'
END IF

heat_info%init_temp = 21._prec !the initial temperature of the plate
heat_info%heater_temp = 29._prec !the initial temperature of the heater
!
! Start of boundary temperatures
!
heat_info%heat_top = 20._prec
heat_info%heat_bottom = 20._prec
heat_info%heat_left = 20._prec
heat_info%heat_right = 20._prec
!
!- End of boundary temperatures
!
heat_info%convergence = 0.0001_prec

  CALL MPI_INIT(mpierror)
  CALL MPI_COMM_SIZE(mpi_comm_world,procs,mpierror) ! store the number of processors
  CALL MPI_COMM_RANK(mpi_comm_world,myid,mpierror)

  ! print out the values used
  IF (myid == 0) THEN
	WRITE(*,*) "Values used: "
	WRITE(*,*) heat_info%domain, ' by', heat_info%domain, ' plate size'
	WRITE(*,*) 'Initial temperature of plate:', heat_info%init_temp
	WRITE(*,*) 'X location of heater:', heat_info%heater_x
	WRITE(*,*) 'Y location of heater:', heat_info%heater_y
	WRITE(*,*) 'Starting heater temperature:', heat_info%heater_temp
	WRITE(*,*) 'Top temperature:', heat_info%heat_top
	WRITE(*,*) 'Bottom temperature:', heat_info%heat_bottom
	WRITE(*,*) 'Right temperature:', heat_info%heat_right
	WRITE(*,*) 'Left temperature:', heat_info%heat_left
	WRITE(*,*) 'Convergence threshold used:',heat_info%convergence
        WRITE(*,*) 'Computing... Please wait... this could take a while'
  END IF

  elapsed_time = -mpi_wtime()

  CALL setup_grid(nx, ny, grid_info, heat_info)

  ! Allocate blocks on each processor
  ALLOCATE(t(1-ndummy:grid_info%nx+ndummy,1-ndummy:grid_info%ny+ndummy))
  ! Also make a second block to be able to check for convergence
  ALLOCATE(t_old(1-ndummy:grid_info%nx+ndummy,1-ndummy:grid_info%ny+ndummy))

  t(:,:) = REAL(heat_info%init_temp, prec) ! All the nodes have the same temperature

  ! setup heater
  IF(grid_info%rank == heat_info%heater_rank) THEN
    t(heat_info%heater_x,heat_info%heater_y) = heat_info%heater_temp
  END IF

  run: DO
    t_old(:,:) = t(:,:)
    iter = iter+1
    !run one gauss-seidel iterations on the domain then go back to exchange bounds
    DO j = 1, grid_info%ny
       DO i = 1, grid_info%nx
          IF(grid_info%rank == heat_info%heater_rank) THEN
             IF(i == heat_info%heater_x .AND. j == heat_info%heater_y) CYCLE
          END IF
          t(i,j) = 0.25_prec*(t(i-1,j)+t(i+1,j)+t(i,j-1)+t(i,j+1))
       END DO
    END DO
    CALL exchange_boundary(ndummy, grid_info,t,t_old, quitProg)
    ! check for convergence
    IF (quitProg .EQV. .TRUE.) THEN
	EXIT run
    END IF
  END DO run
  CALL mpi_barrier(grid_info%commcart,mpierror)

  elapsed_time = elapsed_time + mpi_wtime()

  CALL MPI_Allreduce(iter,globaliter,1,MPI_INTEGER, MPI_SUM, grid_info%commcart, mpierror)

  IF(grid_info%rank == 0) THEN
     WRITE(*,*)"Elapsed time",elapsed_time
     WRITE(*,*)"Number of iterations",globaliter
  ENDIF

  CALL mpi_finalize(mpierror)

CONTAINS

  SUBROUTINE setup_grid(gnx, gny, grid_info, heat_info)
   INTEGER, INTENT(in) :: gnx, gny ! size of domain in x and y
   TYPE(grid_info_type), INTENT(inout) :: grid_info
   TYPE(heat_info_type), INTENT(inout) :: heat_info
   INTEGER :: ndims = 2 ! number of dimensions in the grid
   LOGICAL :: reorder = .TRUE. ! do we want to re-order or not?
   INTEGER :: old_rank
   INTEGER :: psize(2) ! process grid dimensions
   INTEGER :: coords(2) !coordinates of the block in the grid
   LOGICAL :: periodic(2) = .FALSE. ! Is it perodic or not?
   INTEGER :: ierr
   CALL MPI_COMM_SIZE(mpi_comm_world,grid_info%p,ierr) ! store the number of processors
   CALL MPI_COMM_RANK(mpi_comm_world,old_rank,ierr) ! store the old ranks
   psize(:) = 0
   ! create a virtual grid
   CALL MPI_DIMS_CREATE(grid_info%p, ndims, psize, ierr)
   periodic(:) = .FALSE.
   ! create cartesian communicator
   !call MPI_Cart_create(mpi_comm_world,ndims,psize,periodic,1,grid_info%commcart,ierr)
   CALL MPI_CART_CREATE(mpi_comm_world,ndims,psize,periodic,reorder,grid_info%commcart,ierr)
   !Get new rank
   CALL MPI_COMM_RANK(grid_info%commcart, grid_info%rank, ierr)
   CALL MPI_CART_COORDS(grid_info%commcart, grid_info%rank, ndims, coords, ierr) ! get the coords from the rank
   !write(*,*) "Rank",grid_info%rank,"coords",coords(1),coords(2)
   ! Build the blocks
   grid_info%nx = block_size(grid_info%rank, psize(1), gnx)
   grid_info%ny = block_size(grid_info%rank, psize(2), gny)
   ! Deterimine the processor with the heater
   coords(1) = (heat_info%heater_x)/(grid_info%nx)
   coords(2) = (heat_info%heater_y)/(grid_info%ny)
   CALL MPI_CART_RANK(grid_info%commcart, coords, heat_info%heater_rank, ierr)
   ! The actual heater value will have to be initialize after the block is created...
   ! Update heater_x and heater_y (the locations of the heater) with the offset needed to place the heater
   heat_info%heater_x = heat_info%heater_x - coords(1)*grid_info%nx
   heat_info%heater_y = heat_info%heater_y - coords(2)*grid_info%ny
   ! Setup north and south for communication
   CALL MPI_CART_SHIFT(grid_info%commcart, 0, 1, grid_info%north, grid_info%south,ierr)
   ! Setup east and west for communication
   CALL MPI_CART_SHIFT(grid_info%commcart, 1, 1, grid_info%west, grid_info%east, ierr)

   !allocate east_buffer
   ALLOCATE(grid_info%seast_buffer(grid_info%ny))
   ALLOCATE(grid_info%reast_buffer(grid_info%ny))
   !allocate west buffer
   ALLOCATE(grid_info%swest_buffer(grid_info%ny))
   ALLOCATE(grid_info%rwest_buffer(grid_info%ny))
   !allocate north buffer
   ALLOCATE(grid_info%snorth_buffer(grid_info%nx))
   ALLOCATE(grid_info%rnorth_buffer(grid_info%nx))
   !allocate south buffer
   ALLOCATE(grid_info%ssouth_buffer(grid_info%nx))
   ALLOCATE(grid_info%rsouth_buffer(grid_info%nx))

   !add heat information to dummy points which have no neighbors
   IF(grid_info%north == MPI_PROC_NULL) THEN
      grid_info%rnorth_buffer=heat_info%heat_top
   ENDIF
   IF(grid_info%south == MPI_PROC_NULL) THEN
      grid_info%rsouth_buffer=heat_info%heat_bottom
   ENDIF
   IF(grid_info%east == MPI_PROC_NULL) THEN
      grid_info%reast_buffer=heat_info%heat_right
   ENDIF
   IF(grid_info%west == MPI_PROC_NULL) THEN
      grid_info%rwest_buffer=heat_info%heat_left
   ENDIF

END SUBROUTINE setup_grid

   SUBROUTINE exchange_boundary(ndummy, grid_info, t, t_old, quitProg)
     INTEGER, INTENT(in) :: ndummy
     TYPE(grid_info_type), INTENT(inout) :: grid_info
     REAL(kind = prec), INTENT(inout) :: t(1-ndummy:,1-ndummy:)
     REAL(kind = prec), INTENT(in) :: t_old(1-ndummy:,1-ndummy:)
     REAL(kind = prec) :: myDeltaT
     REAL(kind = prec) :: maxDeltaT
     LOGICAL, INTENT(inout) :: quitProg
     INTEGER :: my_tag = 13
     INTEGER :: comrequest(8) ! 4 sends and 4 receives total of 8 communication operations
     INTEGER :: ierr
     ! Setup a block to hold the previous value of t
     nx = grid_info%nx
     ny = grid_info%ny

     !initialize data that needs to be sent to other processors
     grid_info%seast_buffer = t(nx,1:ny)
     grid_info%swest_buffer = t(1,1:ny)
     grid_info%snorth_buffer = t(1:nx,1)
     grid_info%ssouth_buffer = t(1:nx,ny)
     ! generaly best to do recieves first
     CALL mpi_irecv(grid_info%reast_buffer, ny, MPI_DOUBLE_PRECISION, grid_info%east, my_tag,&
          & grid_info%commcart, comrequest(1), ierr)
     CALL mpi_irecv(grid_info%rwest_buffer, ny, MPI_DOUBLE_PRECISION, grid_info%west, my_tag, &
          &grid_info%commcart, comrequest(2), ierr)
     CALL mpi_irecv(grid_info%rnorth_buffer, nx, MPI_DOUBLE_PRECISION, grid_info%north, my_tag,&
          & grid_info%commcart, comrequest(3), ierr)
     CALL mpi_irecv(grid_info%rsouth_buffer, nx, MPI_DOUBLE_PRECISION, grid_info%south, my_tag,&
          & grid_info%commcart, comrequest(4), ierr)

     ! Now do all the sending
     CALL mpi_isend(grid_info%seast_buffer, ny, MPI_DOUBLE_PRECISION, grid_info%east, my_tag,&
          & grid_info%commcart, comrequest(5), ierr)
     CALL mpi_isend(grid_info%swest_buffer, ny, MPI_DOUBLE_PRECISION, grid_info%west, my_tag,&
          & grid_info%commcart, comrequest(6), ierr)
     CALL mpi_isend(grid_info%snorth_buffer, nx, MPI_DOUBLE_PRECISION, grid_info%north, my_tag,&
          & grid_info%commcart, comrequest(7), ierr)
     CALL mpi_isend(grid_info%ssouth_buffer, nx, MPI_DOUBLE_PRECISION, grid_info%south, my_tag,&
          & grid_info%commcart, comrequest(8), ierr)

     ! do something here to hide network speed :) Maybe check for convergance?
     ! each block will compute a finite differnce
     myDeltaT = MAXVAL(ABS(t(1:grid_info%nx,1:grid_info%ny) - t_old(1:grid_info%nx,1:grid_info%ny)))
     ! find the max difference value
     CALL MPI_Allreduce(myDeltaT,maxDeltaT,1,MPI_DOUBLE_PRECISION, MPI_MAX, grid_info%commcart, ierr)
     ! When the max difference is less than the convergance the program needs to quit
     WRITE (*,*) "Change in temperature: ", maxDeltaT
     IF (maxDeltaT < heat_info%convergence) THEN
        quitProg = .TRUE.
     END IF

     CALL mpi_waitall(8, comrequest, MPI_STATUSES_IGNORE, ierr) !this will become a dead lock if one of the processors is dead

     ! setup dummmy points with buffer information
     t(nx+1,1:ny)=grid_info%reast_buffer
     t(0,1:ny)=grid_info%rwest_buffer
     t(1:nx,ny+1)=grid_info%rsouth_buffer
     t(1:nx,0)=grid_info%rnorth_buffer
   END SUBROUTINE exchange_boundary
END PROGRAM gs_heat_plate_mpi


      Program CONVECT

C-----------------------------------------------------------------------
c
c  CONSTANT VELOCITY CONVECTION - LCPFCT Test # 1            August 1992
c
c  This program runs three periodic convection problems using LCPFCT and
c  the FCT utility routines .  The three profiles are the square wave, a
c  semicirle, and a Gaussian peak. The velocity is constant in space and
c  time and the grid is kept stationary.
c
C-----------------------------------------------------------------------
         use, intrinsic :: iso_fortran_env,only: stdout=>output_unit
         Implicit none

         Integer    NPT,           NX,            NXP
         Parameter  ( NPT = 202 )
         Logical    USE_LCP
         Integer    ISTEP,         JSTEP,         I
         Integer    MAXSTP,        IPRINT,        LOUT
         Real       DX, DT,        VELX,          TIME, XCELL
         Real       CSQUARE,       CCIRCLE,       CGAUSSP
         Real       ISQUARE,       ICIRCLE,       IGAUSSP
         Real       ESQUARE,       ECIRCLE,       EGAUSSP
         Real       ASQUARE(NPT),  ACIRCLE(NPT),  AGAUSSP(NPT)
         Real       SQUARE(NPT),   CIRCLE(NPT),   GAUSSP(NPT)
         Real       XINT(NPT),     VINT(NPT)

 1000 Format ( '1',/,'    LCPFCT Test #1 - Constant V Convection:',
     &         '   step =', I4, ' and TIME =', F7.3, /, 10X,
     &         'with DX =', F6.3, ' DT =', F6.3, ' and VX =', F6.3, /)
 1001 Format ( '    I     X(I)     Square    exact     Circle ',
     &         '   exact   Gaussian    exact' )
 1002 Format ( I5, 7F10.5 )
 1003 Format ( 1X, /, ' Conserved sums', 6F10.5 )
 1004 Format (        ' Absolute error', F10.5, 10X, F10.5, 10X, F10.5 )

c  The Constant Velocity Convection control parameters are initialized.
c  (change here for other cases) . . .
C-----------------------------------------------------------------------
      USE_LCP = .true. ! Use the LCPFCT routine rather than CNVFCT
      NX      =   50   ! Number of cells in the periodic system
      DX      =  1.0   ! Cell size
      DT      =  0.2   ! Timestep for the calculation
      VELX    =  1.0   ! Constant X velocity, VELX*DT/DX = 0.2
      MAXSTP  =  501   ! Number of timesteps, two cycles of the system
      LOUT    = stdout   ! Logical unit number of printed output device
      IPRINT  =  125   ! Printout frequency, fluid moves 25 cells

c  The grid, velocity, and three density profiles are initialized . . .
C-----------------------------------------------------------------------
      NXP = NX + 1
      Do I = 1, NXP
         XINT(I) = FLOAT(I-1)*DX
         VINT(I) = VELX
      Enddo

      Call PROFILE ( 1, TIME, SQUARE, XINT, NX, NXP, VELX )
      Call PROFILE ( 2, TIME, CIRCLE, XINT, NX, NXP, VELX )
      Call PROFILE ( 3, TIME, GAUSSP, XINT, NX, NXP, VELX )

c  Set residual diffusion, grid, and velocity factors in LCPFCT . . .
C-----------------------------------------------------------------------
      Call RESIDIFF ( 1.0000 )
      Call MAKEGRID ( XINT, XINT, 1, NXP, 1 )
      Call VELOCITY ( VINT, 1, NXP, DT )

c  Begin loop over timesteps . . .
C-----------------------------------------------------------------------
      TIME = 0.0
      Do 9999 ISTEP = 1, MAXSTP

c  Results are printed as required . . .
C-----------------------------------------------------------------------
         If ( MOD(ISTEP-1,IPRINT) .eq. 0 ) Then
            JSTEP = ISTEP - 1
            Write ( LOUT, 1000 ) JSTEP, TIME, DX, DT, VELX
            Write ( LOUT, 1001 )
            Call PROFILE ( 1, TIME, ASQUARE, XINT, NX,NXP, VELX )
            Call PROFILE ( 2, TIME, ACIRCLE, XINT, NX,NXP, VELX )
            Call PROFILE ( 3, TIME, AGAUSSP, XINT, NX,NXP, VELX )
            ESQUARE = 0.0
            ECIRCLE = 0.0
            EGAUSSP = 0.0
            Do I = 1, NX
               XCELL = XINT(I) + 0.5*DX
               ESQUARE = ESQUARE + ABS(SQUARE(I) - ASQUARE(I))
               ECIRCLE = ECIRCLE + ABS(CIRCLE(I) - ACIRCLE(I))
               EGAUSSP = EGAUSSP + ABS(GAUSSP(I) - AGAUSSP(I))
               Write ( LOUT, 1002 )  I, XCELL, SQUARE(I), ASQUARE(I),
     &            CIRCLE(I), ACIRCLE(I), GAUSSP(I), AGAUSSP(I)
            Enddo

            Call CONSERVE ( SQUARE, 1, NX, CSQUARE )
            Call CONSERVE ( CIRCLE, 1, NX, CCIRCLE )
            Call CONSERVE ( GAUSSP, 1, NX, CGAUSSP )
            If ( ISTEP .eq. 1 ) Then
               ISQUARE = CSQUARE
               ICIRCLE = CCIRCLE
               IGAUSSP = CGAUSSP
            End If
            Write ( LOUT, 1003) CSQUARE, ISQUARE, CCIRCLE, ICIRCLE,
     &                          CGAUSSP, IGAUSSP
            ESQUARE = ESQUARE/CSQUARE
            ECIRCLE = ECIRCLE/CCIRCLE
            EGAUSSP = EGAUSSP/CGAUSSP
            Write ( LOUT, 1004) ESQUARE, ECIRCLE, EGAUSSP
         End If

c    Advance the densities one timestep using LCPFCT and CNVFCT . . .
C-----------------------------------------------------------------------
         If ( USE_LCP ) Then
            Call LCPFCT ( SQUARE, SQUARE, 1, NX, 0.,0.,0.,0., .true.)
            Call LCPFCT ( CIRCLE, CIRCLE, 1, NX, 0.,0.,0.,0., .true.)
            Call LCPFCT ( GAUSSP, GAUSSP, 1, NX, 0.,0.,0.,0., .true.)
         Else
            Call CNVFCT ( SQUARE, SQUARE, 1, NX, 0.,0.,0.,0., .true.)
            Call CNVFCT ( CIRCLE, CIRCLE, 1, NX, 0.,0.,0.,0., .true.)
            Call CNVFCT ( GAUSSP, GAUSSP, 1, NX, 0.,0.,0.,0., .true.)
         End If
         TIME = TIME + DT

 9999 Continue           !  End of the timestep loop.

      End program

C=======================================================================

      Subroutine PROFILE ( TYPE, TIME, ARRAY, XINT, NX, NXP, VX )

C-----------------------------------------------------------------------
c
c  This subroutine computes three different analytic density profiles
c  depending on the value of TYPE . . .
c
c     TYPE = 1   Square wave profile between 0.0 and HEIGHT
c     TYPE = 2   Semicircular (elliptical) profile from 0.0 to HEIGHT
c     TYPE = 3   Gaussian peak profile between 0.0 and HEIGHT
c
c  The profiles are presented on a periodic domain NX cells long and a
c  crude integration is done within each cell to better approximate the
c  curved functions and to give an analytic approximation accounting for
c  convection across a partial cell.
c
C-----------------------------------------------------------------------

      Implicit   NONE
      Integer    TYPE, NX, NXP, I, K
      Real       ARRAY(NX), XINT(NXP), TIME,  VX, SYSLEN, ARG
      Real       HEIGHT, X0, WIDTH,    XLEFT, XK, XRIGHT, XCENT
      Data       HEIGHT, X0, WIDTH / 1.0, 20.0, 10.0 /

      SYSLEN = XINT(NXP)
      Go To ( 100, 200, 300 ), TYPE

c  Compute the profile of the square wave . . .
C-----------------------------------------------------------------------
  100    XLEFT = (X0 - WIDTH) + VX*TIME
  101    If ( XLEFT .gt. SYSLEN ) Then
            XLEFT = XLEFT - SYSLEN
            Go To 101
         End If
  102    If ( XLEFT .lt. 0.0 ) Then
            XLEFT = XLEFT + SYSLEN
            Go To 102
         End If
         XRIGHT = XLEFT + 2.0*WIDTH

c  Loop over the cells in the numerical profile to be determined . . .
         Do 120 I = 1, NX
            ARRAY(I) = 0.0
            Do 110 K = 1, 10
               XK = XINT(I) + 0.1*(FLOAT(K)-0.5)*(XINT(I+1) - XINT(I))
               If ( XK .gt. XLEFT .and. XK .lt. XRIGHT ) Then
                  ARRAY(I) = ARRAY(I) + 0.1*HEIGHT
               Else
                  XK = XK + SYSLEN
                  If ( XK .gt. XLEFT .and. XK .lt. XRIGHT ) Then
                     ARRAY(I) = ARRAY(I) + 0.1*HEIGHT
                  End If
               End If
  110       Continue
  120    Continue
      Return

c  Compute the profile of the semicircle density hump . . .
C-----------------------------------------------------------------------
  200    XLEFT = (X0 - WIDTH) + VX*TIME
  201    If ( XLEFT .gt. SYSLEN ) Then
            XLEFT = XLEFT - SYSLEN
            Go To 201
         End If
         XRIGHT = XLEFT + 2.0*WIDTH
  202    If ( XLEFT .lt. 0.0 ) Then
            XLEFT = XLEFT + SYSLEN
            Go To 202
         End If
         XRIGHT = XLEFT + 2.0*WIDTH

c  Loop over the cells in the numerical profile to be determined . . .
         Do 220 I = 1, NX
            ARRAY(I) = 0.0
            Do 210 K = 1, 10
               XK = XINT(I) + 0.1*(FLOAT(K)-0.5)*(XINT(I+1) - XINT(I))
               If ( XK .gt. XLEFT .and. XK .lt. XRIGHT ) Then
                  XCENT = XLEFT + WIDTH
                  ARRAY(I) = ARRAY(I) + 0.1*HEIGHT*
     &               SQRT ( 1.0 - ((XK - XCENT)/WIDTH)**2 )
               Else
                  XK = XK + SYSLEN
                  If ( XK .gt. XLEFT .and. XK .lt. XRIGHT ) Then
                     XCENT = XLEFT + WIDTH
                     ARRAY(I) = ARRAY(I) + 0.1*HEIGHT*
     &                 SQRT ( 1.0 - ((XK - XCENT)/WIDTH)**2 )
                  End If
               End If
  210       Continue
  220    Continue
      Return

c  Compute the profile of the Gaussian density hump  . . .
C-----------------------------------------------------------------------
  300    XCENT = X0 + VX*TIME
  301    If ( XCENT .gt. SYSLEN ) Then
            XCENT = XCENT - SYSLEN
            Go To 301
         End If
  302    If ( XCENT .lt. 0.0 ) Then
            XCENT = XCENT + SYSLEN
            Go To 302
         End If

c  Loop over the cells in the numerical profile to be determined . . .
         Do 320 I = 1, NX
            ARRAY(I) = 0.0
            Do 310 K = 1, 10
               XK = XINT(I) + 0.1*(FLOAT(K)-0.5)*(XINT(I+1) - XINT(I))
               If ( XK .gt. (XCENT + 0.5*SYSLEN) ) XK = XK - SYSLEN
               If ( XK .lt. (XCENT - 0.5*SYSLEN) ) XK = XK + SYSLEN
               ARG = 4.0*((XK - XCENT)/WIDTH)**2
               ARRAY(I) = ARRAY(I) + 0.1*HEIGHT/EXP(AMIN1(30.0,ARG))
  310       Continue
  320    Continue
      End subroutine profile


C***********************************************************************
C***********************************************************************
C
C   Version:        0.3
C   Last modified:  December 27, 1994
C   Authors:        Esmond G. Ng and Barry W. Peyton
C
C   Mathematical Sciences Section, Oak Ridge National Laboratory
C
C***********************************************************************
C***********************************************************************
C
C     -----------------------------------------
C     GATHER STATISTICS ABOUT FACTORIZATION ...
C     -----------------------------------------
C
      SUBROUTINE  LSTATS (  NSUPER, XSUPER, XLINDX, LINDX , XLNZ  ,
     &                      TMPSIZ, OUTUNT                          )
C
        INTEGER             NSUPER, OUTUNT, TMPSIZ
        INTEGER             XSUPER(*), XLINDX(*), LINDX(*), XLNZ(*)
C
        INTEGER             J     , JLEN  , JSIZE , JSUPER, MAXSUP,
     &                      N     , NCOLS , NOFNZ , NOFSUB, SUPSZE
        DOUBLE PRECISION    FCTOPS, SLVOPS
C
        N = XSUPER(NSUPER+1) - 1
C
        WRITE (OUTUNT,*) ' '
C       -------------------------------------------------------
C       DETERMINE THE NUMBER OF NONZEROS IN CHOLESKY FACTOR AND
C       THE NUMBER OF SUBSCRIPTS IN REPRESENTING THE SUPERNODAL
C       STRUCTURE.
C       -------------------------------------------------------
        NOFNZ = XLNZ(N+1) - 1
        NOFSUB = XLINDX(NSUPER+1) - 1
        WRITE (OUTUNT,1)
     &      '   NUMBER OF SUPERNODES               = ', NSUPER
        WRITE (OUTUNT,1)
     &      '   NUMBER OF NONZEROS IN L            = ', NOFNZ
        WRITE (OUTUNT,1)
     &      '   NUMBER OF SUBSCRIPTS IN L          = ', NOFSUB
C
C       -------------------------------------------------------
C       DETERMINE THE LARGEST SUPERNODE IN THE CHOLESKY FACTOR.
C       -------------------------------------------------------
        MAXSUP = 0
        SUPSZE = 0
        DO  100  JSUPER = 1, NSUPER
C           ---------------------------------------------------
C           NCOLS IS THE NUMBER OF COLUMNS IN SUPERNODE JSUPER.
C           ---------------------------------------------------
            NCOLS = XSUPER(JSUPER+1) - XSUPER(JSUPER)
            IF  ( NCOLS .GT. MAXSUP )  MAXSUP = NCOLS
C
C           ----------------------------------------------------
C           JSIZE IS THE NUMBER OF NONZEROS IN SUPERNDOE JSUPER.
C           ----------------------------------------------------
            JLEN = XLINDX(JSUPER+1) - XLINDX(JSUPER)
            JSIZE = ((2*JLEN - NCOLS + 1)*NCOLS)/2
            IF  ( JSIZE .GT. SUPSZE )  SUPSZE = JSIZE
  100   CONTINUE
        WRITE (OUTUNT,1)
     &      '   LARGEST SUPERNODE BY COLUMNS       = ', MAXSUP
        WRITE (OUTUNT,1)
     &      '   LARGEST SUPERNODE BY NONZEROS      = ', SUPSZE
C
        WRITE (OUTUNT,1)
     &      '   SIZE OF TEMPORARY WORK STORAGE     = ', TMPSIZ
C
C       ---------------------------
C       DETERMINE OPERATION COUNTS.
C       ---------------------------
        SLVOPS = 0.0
        FCTOPS = 0.0
        DO  400  J = 1, N
            JLEN = XLNZ(J+1) - XLNZ(J)
            SLVOPS = SLVOPS + 2*JLEN - 1
            FCTOPS = FCTOPS + JLEN**2 - 1
  400   CONTINUE
        SLVOPS = 2*SLVOPS
        WRITE (OUTUNT,2)
     &      '   FACTORIZATION OPERATION COUNT      = ', FCTOPS
        WRITE (OUTUNT,2)
     &      '   TRIANGULAR SOLN OPERATION COUNT    = ', SLVOPS
C
    1   FORMAT ( A40, I10 )
    2   FORMAT ( A40, 1PD20.10 )
        RETURN
      END


      module penta_functions_mod
	use penta_kind_mod
	implicit none
	contains

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c   Miscellaneous functions
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c----------------------------------------------------------------------
c   This function is used in conjunction with 'zeroin' to find
c    the solution to gamma_e=sum(Z*gamma_i).  Returns difference
c    in fluxes at Er_test, using spline parameters from Er_fit_pass.
c   JL 7/2009
c----------------------------------------------------------------------
c
      real(rknd) function rad_flux(Er_test)
      use penta_kind_mod
      use Er_fit_pass
      implicit none
      real(rknd) :: Er_test, Er_tmp, err
      call pol_int(Er_fit,diff_qg,size(Er_fit),Er_test,Er_tmp,err)
      rad_flux=Er_tmp
      return
      end function rad_flux
c
c-----------------------------------------------------------------------
c  Function zeroin
c  a zero of the function  f(x)  is computed in the interval ax,bx
c
c  input..
c
c  ax     left endpoint of initial interval
c  bx     right endpoint of initial interval
c  f      function subprogram which evaluates f(x) for any x in
c         the interval  ax,bx
c  tol    desired length of the interval of uncertainty of the
c         final result ( .ge. 0.0)
c
c
c  output..
c
c  zeroin abcissa approximating a zero of  f  in the interval ax,bx
c
c
c      it is assumed  that   f(ax)   and   f(bx)   have  opposite  signs
c  without  a  check.  zeroin  returns a zero  x  in the given interval
c  ax,bx  to within a tolerance  4*macheps*abs(x) + tol, where macheps
c  is the relative machine precision.
c      this function subprogram is a slightly  modified  translation  of
c  the algol 60 procedure  zero  given in  richard brent, algorithms for
c  minimization without derivatives, prentice - hall, inc. (1973).
c
c   modified by JL for kind precision and iteration limit 7/09
c
c----------------------------------------------------------------------------
c
      real(rknd) function zeroin(ax,bx,f,tol)
      use penta_kind_mod
      implicit none
      real(rknd) ax, bx, f, tol
      integer(iknd),save :: jfirst
      integer(iknd) :: iter
      integer(iknd), parameter :: max_iter = 1000_iknd
      real(rknd) :: a, b, c, d, e, eps, fa, fb, fc, tol1,
     1   xm, p, q, r, s
      external :: f

      !compute eps, the relative machine precision
      iter=0_iknd
      eps = epsilon(1._rknd)
      tol1 = 1._rknd + eps

      ! initialization
      a = ax
      b = bx
      fa = f(a)
      fb = f(b)

      ! begin step
   20 c = a
      fc = fa
      d = b - a
      e = d
   30 if (dabs(fc) .ge. dabs(fb)) go to 40
      a = b
      b = c
      c = a
      fa = fb
      fb = fc
      fc = fa

      ! convergence test
   40 tol1 = 2._rknd*eps*dabs(b) + 0.5_rknd*tol
      xm = .5_rknd*(c - b)
      iter=iter+1_iknd
      if (iter .gt. max_iter) then
        write(*,*) 'Maximum iterations exceeded in function zeroin:',
     1    max_iter
        stop
      endif
      if (dabs(xm) .le. tol1) go to 90
      if (fb .eq. 0._rknd) go to 90

      !is bisection necessary
      if (dabs(e) .lt. tol1) go to 70
      if (dabs(fa) .le. dabs(fb)) go to 70

      ! is quadratic interpolation possible
      if (a .ne. c) go to 50

      ! linear interpolation
      s = fb/fa
      p = 2._rknd*xm*s
      q = 1._rknd - s
      go to 60

      ! inverse quadratic interpolation
   50 q = fa/fc
      r = fb/fc
      s = fb/fa
      p = s*(2._rknd*xm*q*(q - r) - (b - a)*(r - 1._rknd))
      q = (q - 1._rknd)*(r - 1._rknd)*(s - 1._rknd)

      ! adjust signs
   60 if (p .gt. 0._rknd) q = -q
      p = dabs(p)

      ! is interpolation acceptable
      if ((2._rknd*p) .ge. (3._rknd*xm*q - dabs(tol1*q))) go to 70
      if (p .ge. dabs(0.5_rknd*e*q)) go to 70
      e = d
      d = p/q
      go to 80

      ! bisection
   70 d = xm
      e = d

      !complete step
   80 a = b
      fa = fb
      if (dabs(d) .gt. tol1) b = b + d
      if (dabs(d) .le. tol1) b = b + dsign(tol1, xm)
      fb = f(b)
      if ((fb*(fc/dabs(fc))) .gt. 0._rknd) go to 20
      go to 30

      ! done
   90 zeroin = b
      return
      end function zeroin
c
c-----------------------------------------------------------------------
c   This function calculates the error function for input xin
c-----------------------------------------------------------------------
c
      real(rknd) function derf(xin)
      use penta_kind_mod
      implicit none
      integer(iknd) :: k
      real(rknd) :: eps, pi, xin2, r, er, c0
      real(rknd), intent(in) :: xin

      eps=1.e-15_rknd
      pi=4._rknd*datan(1._rknd)
      xin2=xin*xin
      if (dabs(xin).lt. 3.5_rknd) then
        er=1._rknd
        r=1._rknd
        do k=1,50
            r=r*xin2/(k+0.5_rknd)
            er=er+r
            if (dabs(r).le.dabs(er)*eps) exit
        enddo
        c0=2._rknd/dsqrt(pi)*xin*dexp(-xin2)
        derf=c0*er
      else
        er=1._rknd
        r=1._rknd
        do k=1,12
            r=-r*(k-0.5_rknd)/xin2
            er=er+r
        enddo
        c0=dexp(-xin2)/(dabs(xin)*dsqrt(pi))
        derf=1.0D0-c0*er
        if (xin.lt.0.0) derf=-derf
      endif
      end function derf

c
c-----------------------------------------------------------------------
c   This function returns the integrand of the energy integral.
c       Collision frequencies are calculated using calc_perp_coll_freq.
c     Note the value set below for requested monoenergetic coefficients
c       out of range.
c   JL 7/2009 modified from don's fun123
c-----------------------------------------------------------------------
c
      real(rknd) function intfun(Ka)
      use penta_kind_mod
      use intfun_pass
      use thermal_pass
      use bspline
      use parameter_pass
      implicit none
      !dummy variable
      real(rknd) :: Ka
      !local variables
      real(rknd) :: efield, xa, va, nu_perp_aa, xb, Kb,
     1  nu_perp_a, cmul_K, ff, enrm
      real(rknd), allocatable :: nu_perp_ab(:)
      integer(iknd) :: ispec, svtb

      !normalized velocity and velocity
      xa=dsqrt(Ka)
      va=xa*vta

      !define |Er|/v and coefficient range
      efield=abs_Er/va

      !Define energy dependent collision frequencies
      svtb=size(vtb)
      call calc_perp_coll_freq(va,xa,qa,qa,ma,na,Ka,loglam,
     1  vta,Ka,nu_perp_aa)
      allocate(nu_perp_ab(svtb))

      !loop over field species to get collision frequency
      do ispec=1,svtb
        ! Field species norm. energy and velocity
        xb=xa*(vta/vtb(ispec))
        Kb=xb**2_iknd

        !Define energy dependent collision frequency
        call calc_perp_coll_freq(va,xb,qa,qb(ispec),ma,nb(ispec),Kb,
     1    loglam,vta,Ka,nu_perp_ab(ispec))
      enddo

      !define collisionality
      nu_perp_a=nu_perp_aa + sum(nu_perp_ab)
      cmul_K = nu_perp_a/va
      deallocate(nu_perp_ab)

      !use log interp or linear
      if ( log_interp ) then
        efield = dlog(efield)
        enrm = (efield - emin_pass)
     1    /(emax_pass - emin_pass)
        cmul_K=dlog(cmul_K)
      endif

      !Check for cmul or efield values out of range.  If efield is below the smallest database
      !  efield then use the smallest database efield.
      !Then look up coefficient at efield and cmul values from fits.  If the request
      ! is out of range use the value set below.
      if(efield .lt. emin_pass) efield = emin_pass                   !check for efield too small
      if(cmul_K .ge. cmin_pass .and. cmul_K .le. cmax_pass .and.     !check for out of range
     1       efield .ge. emin_pass .and. efield .le. emax_pass) then

        !interpolate database
        ff = dbs2vl(cmul_K,enrm,kcord,keord,xt_c_pass,xt_e_pass,
     1     num_c_pass,num_e_pass,c_spl_pass)

        !handle log of coefficient
        if( log_coeff ) then
          intfun=dexp(ff - Ka)*Ka**2*(Ka - 2.5_rknd)  !the K^2 instead of sqrt(K) accounts for K^1.5 dependance of the coefficients
     1      **(jval-1_iknd)
        else
          intfun=ff*dexp(-Ka)*Ka**2*(Ka - 2.5_rknd)
     1      **(jval-1_iknd)
        endif  !log coefficient
      else
        !handle out of range requests
        intfun = 0._rknd
      endif !range check
      end function intfun

      end module penta_functions_mod