cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c        this is the end of the debugging code and the
c        start of the actual quadrature routines.
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
c
        subroutine adapgaus(ier,a,b,fun,par1,par2,m,eps,
     1      rint,maxrec,numint)
        implicit real *8 (a-h,o-z)
        save
        dimension t(100),w(100),stack(400),vals(200),
     1      par1(1),par2(1)
        data m7/-2341034/
c
c       this subroutine uses the adaptive chebychev quadrature
c       to evaluate the integral of the user-supplied function
c       fun on the user-specified interval [a,b]
c
c                       input parameters:
c
c  a,b - the ends of the interval on which the integral is to
c       be evaluated
c  fun - the user-supplied function to be integrated. the calling
c       sequence of fun must be
c
c        fun(x,par1,par2).                            (1)
c
c        in (1), x is a point on the interval [a,b] where
c        the function is to be evaluated, and par1, par2
c        are two parameters to be used by fun; they can be
c        variables or arrays, real or integer, as desired.
c        fun is assumed to be real *8.
c  par1, par2 - partameters to be used by the user-supplied
c       function fun (see above)
c  m - the order of the quadrature to me used on each subinterval
c  eps - the accuracy (absolute) to which the integral will be
c       evaluated
c
c                       output parameters:
c
c  ier - error return code.
c          ier=0 means normal conclusion
c          ier=8 means that at some point, one subinterval in the
c                subdivision was smaller than (b-a)/2**200. this
c                is a fatal error.
c          ier=16 means that the total number of subintervals in the
c                adaptive subdivision of [a,b] turned out to be greater
c                than 100000.  this is a fatal error.
c
c  rint - the integral as evaluated
c  maxrec - the maximum depth to which the recursion went at its
c         deepest point. can not be greater than 200, since at that
c         point ier is set to 8 and the execution of the subroutine
c         terminated.
c  numint - the totla number of intervals in the subdivision. can not
c         be greater than 100000,  since at that
c         point ier is set to 16 and the execution of the subroutine
c         terminated.
c
c
c          . . . check if the gauss quadarture has been
c                initialized at a preceeding call to this routine
c
        if(m .eq. m7) goto 1200
cccc        call gauswhts(m,t,w)
c
        ifwhts=1
        call legewhts(m,t,w,ifwhts)
c
        m7=m
 1200 continue
c
c        integrate the user-supplied function using the
c        adaptive gaussian quadratures
c
        nnmax=100000
        maxdepth=200
c
        call adinrec(ier,stack,a,b,fun,par1,par2,t,w,m,
     1      vals,nnmax,eps,rint,maxdepth,maxrec,numint)
        return
        end
c
c
c
c
c
        subroutine adinrec(ier,stack,a,b,fun,
     1      par1,par2,t,w,m,vals,nnmax,eps,
     2      rint,maxdepth,maxrec,numint)
        implicit real *8 (a-h,o-z)
        save
        dimension stack(2,1),t(1),w(1),vals(1),par1(1),par2(1)
c
c       start the recursion
c
        stack(1,1)=a
        stack(2,1)=b
        call oneint(a,b,fun,par1,par2,t,w,m,vals(1))
c
c       recursively integrate the thing
c
        j=1
        rint=0
        ier=0
        maxrec=0
        do 3000 i=1,nnmax
ccc        call prinf('i=*',i,1)
        numint=i
        if(j .gt. maxrec) maxrec=j
ccc        call prinf('j=*',j,1)
c
c       subdivide the current subinterval
c
         c=(stack(1,j)+stack(2,j))/2
        call oneint(stack(1,j),c,fun,
     1      par1,par2,t,w,m,value2)
c
        call oneint(c,stack(2,j),fun,
     1      par1,par2,t,w,m,value3)
c
        dd=dabs(value2+value3-vals(j))
cccc         call prin2('in adinrec, dd=*',dd,1)
        ifdone=0
        if(dd .le. eps) ifdone=1
c
c       if the function on this subinterval has been
c       integrated with sufficient accuracy - add the
c       value to that of the global integral and move up
c       in the stack
c
        if(ifdone  .eq. 0) goto 2000
c
        rint=rint+value2+value3
        j=j-1
c
c        if the whole thing has been integrated - return
c
        if(j .eq. 0) return
        goto 3000
 2000 continue
c
c       if the function on this subinterval has not been
c       integrated with sufficient accuracy - move
c       down the stack
c
        stack(1,j+1)=stack(1,j)
        stack(2,j+1)=(stack(1,j)+stack(2,j))/2
        vals(j+1)=value2
c
        stack(1,j)=(stack(1,j)+stack(2,j))/2
        vals(j)=value3
c
        j=j+1
c
c       if the depth of the recursion has become excessive - bomb
c
        if(j .le. maxdepth) goto 3000
        ier=8
        return
 3000 continue
        ier=16
        return
        end
c
c
c
c
c
        subroutine oneint(a,b,fun,par1,par2,t,w,m,rint)
        implicit real *8 (a-h,o-z)
        save
        dimension t(1),w(1),par1(1),par2(1)
c
c       integrate the function fun on the interval [a,b]
c
        rint=0
        u=(b-a)/2
        v=(b+a)/2
        do 1200 i=1,m
        tt=u*t(i)+v
        rint=rint+fun(tt,par1,par2)*w(i)
 1200 continue
        rint=rint*u
        return
        end


FUNCTION rootlay(rtdepth,lthick,nlay)
!
IMPLICIT NONE
!
! Function arguments
!
INTEGER :: nlay
REAL :: rtdepth
REAL,DIMENSION(nlay) :: lthick
INTEGER :: rootlay
!
! Local variables
!
REAL :: d
INTEGER :: i
!
IF ((rtdepth*1000.0).LT.lthick(1)) THEN
  rootlay = 1
  GO TO 99999
END IF
d = lthick(1)
DO i = 2,nlay
  d = d + lthick(i)
  IF ((rtdepth*1000.0).LT.d) THEN
     IF ((d-(rtdepth*1000.)).LT.((rtdepth*1000.)-(d-lthick(i)))) THEN
        rootlay = i
     ELSE
        rootlay = i - 1
     END IF
     GO TO 99999
  END IF
  rootlay = nlay
END DO
!
99999 END FUNCTION rootlay

Project Documents/Source Code Original/Rootlay.f90


*DECK DBESKS
      SUBROUTINE DBESKS (XNU, X, NIN, BK)
C***BEGIN PROLOGUE  DBESKS
C***PURPOSE  Compute a sequence of modified Bessel functions of the
C            third kind of fractional order.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B3
C***TYPE      DOUBLE PRECISION (BESKS-S, DBESKS-D)
C***KEYWORDS  FNLIB, FRACTIONAL ORDER, MODIFIED BESSEL FUNCTION,
C             SEQUENCE OF BESSEL FUNCTIONS, SPECIAL FUNCTIONS,
C             THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBESKS computes a sequence of modified Bessel functions of the third
C kind of order XNU + I at X, where X .GT. 0, XNU lies in (-1,1),
C and I = 0, 1, ... , NIN - 1, if NIN is positive and I = 0, 1, ... ,
C NIN + 1, if NIN is negative.  On return, the vector BK(.) contains
C the results at X for order starting at XNU.  XNU, X, and BK are
C double precision.  NIN is an integer.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, DBSKES, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DBESKS
      DOUBLE PRECISION XNU, X, BK(*), EXPXI, XMAX, D1MACH
      SAVE XMAX
      DATA XMAX / 0.D0 /
C***FIRST EXECUTABLE STATEMENT  DBESKS
      IF (XMAX.EQ.0.D0) XMAX = -LOG (D1MACH(1))
C
      IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBESKS',
     +   'X SO BIG BESSEL K UNDERFLOWS', 1, 2)
C
      CALL DBSKES (XNU, X, NIN, BK)
C
      EXPXI = EXP (-X)
      N = ABS (NIN)
      DO 20 I=1,N
        BK(I) = EXPXI * BK(I)
 20   CONTINUE
C
      RETURN
      END


       do  step = 1, niter
!$MON user region
         if (mod(step, 20) .eq. 0 .or. step .eq. 1) then
            if (myid .eq. root) write(*, 200) step
 200        format(' Time step ', i4)
         endif

         call exch_qbc(u, qbc_ou, qbc_in, nx, nxmax, ny, nz,
     $                 0)

         do iz = 1, proc_num_zones
           zone = proc_zone_id(iz)
           call adi(rho_i(start1(iz)), us(start1(iz)),
     $              vs(start1(iz)), ws(start1(iz)),
     $              qs(start1(iz)), square(start1(iz)),
     $              rhs(start5(iz)), forcing(start5(iz)),
     $              u(start5(iz)),
     $              nx(zone), nxmax(zone), ny(zone), nz(zone))
         end do
!$MON end user region
       end do


!
 module SelfEnMod
  use PrecisionMod
  implicit none
!
!
  contains
!------------------------------------------------
  subroutine SelfEnInit2(casename, Numspin, Numorbitals, Niwnmax, InverseTemperature, SelfEn)
   use MathConstantsMod,  only : xi, pi_d
   implicit none
!
   character(len=100) :: casename
   integer(i4b), intent(in) :: Numspin, Numorbitals, NiwnMax
   real(dp), intent(in) :: InverseTemperature
   complex(dpc), dimension(Numorbitals, NumOrbitals, 0:Niwnmax, NumSpin) :: SelfEn
!
   integer(i4b), parameter :: NUnitIn = 111
   integer(i4b) :: n, m, Ns, Nnd, Nw
   integer(i4b) :: norb1, norb2, i, error
   real(dp) :: beta, omega_n
   real(dp), dimension(2*NumOrbitals**2) :: val
   character(len=100) :: filename
!
   do ns = 1, NumSpin
     SelfEn(:,:,:,Ns) = (0.0_dp,0.0_dp)
!
     if (NumSpin .eq. 1) then
       filename = './Input/'//trim(casename)//'.SelfEnIA'
     else
       if (ns .eq. 1) then
         filename = './Input/'//trim(casename)//'.SelfEnIAup'
       else
         filename = './Input/'//trim(casename)//'.SelfEnIAdn'
       end if
     end if
!
     open(NUnitIn, file=filename, status='old', form='formatted', position='REWIND', action='READ')
!
     do n = 0, Niwnmax
       read(NUnitIn,*) m, Omega_n, val
       i = 1
       do norb1=1,NumOrbitals
         do norb2=1,NumOrbitals
           SelfEn(Norb1, Norb2,m,Ns) = val(i)+xi*val(i+1)
	   i = i+2
         end do
       end do
     end do
     close(NUnitIn)
!
     beta = (dble(2*Niwnmax)+1.0_dp)*pi_d/Omega_n
     if(abs(beta - InverseTemperature) .gt. 1.0D-4) stop 'ReadSelfEn:  Inverse temperatures do not match in two files'
!
   end do
!
  end subroutine SelfEnInit2
!
!------------------------------------------------
 end module SelfEnMod


! { dg-options "-O3 -ffast-math" }

      DIMENSION FPQR(25,25,25)
      INTEGER P,Q,R
            DO 130 R=1,N4MAX,2
               IF(P.GT.1) THEN
                  FPQR(P,Q,R)= RM2*FPQR(P,Q,R-2)*REC(P+Q+R-2)
               END IF
  130       RM2= RM2+TWO
      END