      subroutine dspdi(ap,n,kpvt,det,inert,work,job)
      integer n,job
      double precision ap(1),work(1)
      double precision det(2)
      integer kpvt(1),inert(3)
c
c     dspdi computes the determinant, inertia and inverse
c     of a double precision symmetric matrix using the factors from
c     dspfa, where the matrix is stored in packed form.
c
c     on entry
c
c        ap      double precision (n*(n+1)/2)
c                the output from dspfa.
c
c        n       integer
c                the order of the matrix a.
c
c        kpvt    integer(n)
c                the pivot vector from dspfa.
c
c        work    double precision(n)
c                work vector.  contents ignored.
c
c        job     integer
c                job has the decimal expansion  abc  where
c                   if  c .ne. 0, the inverse is computed,
c                   if  b .ne. 0, the determinant is computed,
c                   if  a .ne. 0, the inertia is computed.
c
c                for example, job = 111  gives all three.
c
c     on return
c
c        variables not requested by job are not used.
c
c        ap     contains the upper triangle of the inverse of
c               the original matrix, stored in packed form.
c               the columns of the upper triangle are stored
c               sequentially in a one-dimensional array.
c
c        det    double precision(2)
c               determinant of original matrix.
c               determinant = det(1) * 10.0**det(2)
c               with 1.0 .le. dabs(det(1)) .lt. 10.0
c               or det(1) = 0.0.
c
c        inert  integer(3)
c               the inertia of the original matrix.
c               inert(1)  =  number of positive eigenvalues.
c               inert(2)  =  number of negative eigenvalues.
c               inert(3)  =  number of zero eigenvalues.
c
c     error condition
c
c        a division by zero will occur if the inverse is requested
c        and  dspco  has set rcond .eq. 0.0
c        or  dspfa  has set  info .ne. 0 .
c
c     linpack. this version dated 08/14/78 .
c     james bunch, univ. calif. san diego, argonne nat. lab.
c
c     subroutines and functions
c
c     blas daxpy,dcopy,ddot,dswap
c     fortran dabs,iabs,mod
c
c     internal variables.
c
      double precision akkp1,ddot,temp
      double precision ten,d,t,ak,akp1
      integer ij,ik,ikp1,iks,j,jb,jk,jkp1
      integer k,kk,kkp1,km1,ks,ksj,kskp1,kstep
      logical noinv,nodet,noert
c
      noinv = mod(job,10) .eq. 0
      nodet = mod(job,100)/10 .eq. 0
      noert = mod(job,1000)/100 .eq. 0
c
      if (nodet .and. noert) go to 140
         if (noert) go to 10
            inert(1) = 0
            inert(2) = 0
            inert(3) = 0
   10    continue
         if (nodet) go to 20
            det(1) = 1.0d0
            det(2) = 0.0d0
            ten = 10.0d0
   20    continue
         t = 0.0d0
         ik = 0
         do 130 k = 1, n
            kk = ik + k
            d = ap(kk)
c
c           check if 1 by 1
c
            if (kpvt(k) .gt. 0) go to 50
c
c              2 by 2 block
c              use det (d  s)  =  (d/t * c - t) * t  ,  t = dabs(s)
c                      (s  c)
c              to avoid underflow/overflow troubles.
c              take two passes through scaling.  use  t  for flag.
c
               if (t .ne. 0.0d0) go to 30
                  ikp1 = ik + k
                  kkp1 = ikp1 + k
                  t = dabs(ap(kkp1))
                  d = (d/t)*ap(kkp1+1) - t
               go to 40
   30          continue
                  d = t
                  t = 0.0d0
   40          continue
   50       continue
c
            if (noert) go to 60
               if (d .gt. 0.0d0) inert(1) = inert(1) + 1
               if (d .lt. 0.0d0) inert(2) = inert(2) + 1
               if (d .eq. 0.0d0) inert(3) = inert(3) + 1
   60       continue
c
            if (nodet) go to 120
               det(1) = d*det(1)
               if (det(1) .eq. 0.0d0) go to 110
   70             if (dabs(det(1)) .ge. 1.0d0) go to 80
                     det(1) = ten*det(1)
                     det(2) = det(2) - 1.0d0
                  go to 70
   80             continue
   90             if (dabs(det(1)) .lt. ten) go to 100
                     det(1) = det(1)/ten
                     det(2) = det(2) + 1.0d0
                  go to 90
  100             continue
  110          continue
  120       continue
            ik = ik + k
  130    continue
  140 continue
c
c     compute inverse(a)
c
      if (noinv) go to 270
         k = 1
         ik = 0
  150    if (k .gt. n) go to 260
            km1 = k - 1
            kk = ik + k
            ikp1 = ik + k
            kkp1 = ikp1 + k
            if (kpvt(k) .lt. 0) go to 180
c
c              1 by 1
c
               ap(kk) = 1.0d0/ap(kk)
               if (km1 .lt. 1) go to 170
                  call dcopy(km1,ap(ik+1),1,work,1)
                  ij = 0
                  do 160 j = 1, km1
                     jk = ik + j
                     ap(jk) = ddot(j,ap(ij+1),1,work,1)
                     call daxpy(j-1,work(j),ap(ij+1),1,ap(ik+1),1)
                     ij = ij + j
  160             continue
                  ap(kk) = ap(kk) + ddot(km1,work,1,ap(ik+1),1)
  170          continue
               kstep = 1
            go to 220
  180       continue
c
c              2 by 2
c
               t = dabs(ap(kkp1))
               ak = ap(kk)/t
               akp1 = ap(kkp1+1)/t
               akkp1 = ap(kkp1)/t
               d = t*(ak*akp1 - 1.0d0)
               ap(kk) = akp1/d
               ap(kkp1+1) = ak/d
               ap(kkp1) = -akkp1/d
               if (km1 .lt. 1) go to 210
                  call dcopy(km1,ap(ikp1+1),1,work,1)
                  ij = 0
                  do 190 j = 1, km1
                     jkp1 = ikp1 + j
                     ap(jkp1) = ddot(j,ap(ij+1),1,work,1)
                     call daxpy(j-1,work(j),ap(ij+1),1,ap(ikp1+1),1)
                     ij = ij + j
  190             continue
                  ap(kkp1+1) = ap(kkp1+1)
     *                         + ddot(km1,work,1,ap(ikp1+1),1)
                  ap(kkp1) = ap(kkp1)
     *                       + ddot(km1,ap(ik+1),1,ap(ikp1+1),1)
                  call dcopy(km1,ap(ik+1),1,work,1)
                  ij = 0
                  do 200 j = 1, km1
                     jk = ik + j
                     ap(jk) = ddot(j,ap(ij+1),1,work,1)
                     call daxpy(j-1,work(j),ap(ij+1),1,ap(ik+1),1)
                     ij = ij + j
  200             continue
                  ap(kk) = ap(kk) + ddot(km1,work,1,ap(ik+1),1)
  210          continue
               kstep = 2
  220       continue
c
c           swap
c
            ks = iabs(kpvt(k))
            if (ks .eq. k) go to 250
               iks = (ks*(ks - 1))/2
               call dswap(ks,ap(iks+1),1,ap(ik+1),1)
               ksj = ik + ks
               do 230 jb = ks, k
                  j = k + ks - jb
                  jk = ik + j
                  temp = ap(jk)
                  ap(jk) = ap(ksj)
                  ap(ksj) = temp
                  ksj = ksj - (j - 1)
  230          continue
               if (kstep .eq. 1) go to 240
                  kskp1 = ikp1 + ks
                  temp = ap(kskp1)
                  ap(kskp1) = ap(kkp1)
                  ap(kkp1) = temp
  240          continue
  250       continue
            ik = ik + k
            if (kstep .eq. 2) ik = ik + k + 1
            k = k + kstep
         go to 150
  260    continue
  270 continue
      return
      end
      subroutine dspfa(ap,n,kpvt,info)
      integer n,kpvt(1),info
      double precision ap(1)
c
c     dspfa factors a double precision symmetric matrix stored in
c     packed form by elimination with symmetric pivoting.
c
c     to solve  a*x = b , follow dspfa by dspsl.
c     to compute  inverse(a)*c , follow dspfa by dspsl.
c     to compute  determinant(a) , follow dspfa by dspdi.
c     to compute  inertia(a) , follow dspfa by dspdi.
c     to compute  inverse(a) , follow dspfa by dspdi.
c
c     on entry
c
c        ap      double precision (n*(n+1)/2)
c                the packed form of a symmetric matrix  a .  the
c                columns of the upper triangle are stored sequentially
c                in a one-dimensional array of length  n*(n+1)/2 .
c                see comments below for details.
c
c        n       integer
c                the order of the matrix  a .
c
c     output
c
c        ap      a block diagonal matrix and the multipliers which
c                were used to obtain it stored in packed form.
c                the factorization can be written  a = u*d*trans(u)
c                where  u  is a product of permutation and unit
c                upper triangular matrices , trans(u) is the
c                transpose of  u , and  d  is block diagonal
c                with 1 by 1 and 2 by 2 blocks.
c
c        kpvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if the k-th pivot block is singular. this is
c                     not an error condition for this subroutine,
c                     but it does indicate that dspsl or dspdi may
c                     divide by zero if called.
c
c     packed storage
c
c          the following program segment will pack the upper
c          triangle of a symmetric matrix.
c
c                k = 0
c                do 20 j = 1, n
c                   do 10 i = 1, j
c                      k = k + 1
c                      ap(k)  = a(i,j)
c             10    continue
c             20 continue
c
c     linpack. this version dated 08/14/78 .
c     james bunch, univ. calif. san diego, argonne nat. lab.
c
c     subroutines and functions
c
c     blas daxpy,dswap,idamax
c     fortran dabs,dmax1,dsqrt
c
c     internal variables
c
      double precision ak,akm1,bk,bkm1,denom,mulk,mulkm1,t
      double precision absakk,alpha,colmax,rowmax
      integer idamax,ij,ijj,ik,ikm1,im,imax,imaxp1,imim,imj,imk
      integer j,jj,jk,jkm1,jmax,jmim,k,kk,km1,km1k,km1km1,km2,kstep
      logical swap
c
c
c     initialize
c
c     alpha is used in choosing pivot block size.
      alpha = (1.0d0 + dsqrt(17.0d0))/8.0d0
c
      info = 0
c
c     main loop on k, which goes from n to 1.
c
      k = n
      ik = (n*(n - 1))/2
   10 continue
c
c        leave the loop if k=0 or k=1.
c
c     ...exit
         if (k .eq. 0) go to 200
         if (k .gt. 1) go to 20
            kpvt(1) = 1
            if (ap(1) .eq. 0.0d0) info = 1
c     ......exit
            go to 200
   20    continue
c
c        this section of code determines the kind of
c        elimination to be performed.  when it is completed,
c        kstep will be set to the size of the pivot block, and
c        swap will be set to .true. if an interchange is
c        required.
c
         km1 = k - 1
         kk = ik + k
         absakk = dabs(ap(kk))
c
c        determine the largest off-diagonal element in
c        column k.
c
         imax = idamax(k-1,ap(ik+1),1)
         imk = ik + imax
         colmax = dabs(ap(imk))
         if (absakk .lt. alpha*colmax) go to 30
            kstep = 1
            swap = .false.
         go to 90
   30    continue
c
c           determine the largest off-diagonal element in
c           row imax.
c
            rowmax = 0.0d0
            imaxp1 = imax + 1
            im = imax*(imax - 1)/2
            imj = im + 2*imax
            do 40 j = imaxp1, k
               rowmax = dmax1(rowmax,dabs(ap(imj)))
               imj = imj + j
   40       continue
            if (imax .eq. 1) go to 50
               jmax = idamax(imax-1,ap(im+1),1)
               jmim = jmax + im
               rowmax = dmax1(rowmax,dabs(ap(jmim)))
   50       continue
            imim = imax + im
            if (dabs(ap(imim)) .lt. alpha*rowmax) go to 60
               kstep = 1
               swap = .true.
            go to 80
   60       continue
            if (absakk .lt. alpha*colmax*(colmax/rowmax)) go to 70
               kstep = 1
               swap = .false.
            go to 80
   70       continue
               kstep = 2
               swap = imax .ne. km1
   80       continue
   90    continue
         if (dmax1(absakk,colmax) .ne. 0.0d0) go to 100
c
c           column k is zero.  set info and iterate the loop.
c
            kpvt(k) = k
            info = k
         go to 190
  100    continue
         if (kstep .eq. 2) go to 140
c
c           1 x 1 pivot block.
c
            if (.not.swap) go to 120
c
c              perform an interchange.
c
               call dswap(imax,ap(im+1),1,ap(ik+1),1)
               imj = ik + imax
               do 110 jj = imax, k
                  j = k + imax - jj
                  jk = ik + j
                  t = ap(jk)
                  ap(jk) = ap(imj)
                  ap(imj) = t
                  imj = imj - (j - 1)
  110          continue
  120       continue
c
c           perform the elimination.
c
            ij = ik - (k - 1)
            do 130 jj = 1, km1
               j = k - jj
               jk = ik + j
               mulk = -ap(jk)/ap(kk)
               t = mulk
               call daxpy(j,t,ap(ik+1),1,ap(ij+1),1)
               ijj = ij + j
               ap(jk) = mulk
               ij = ij - (j - 1)
  130       continue
c
c           set the pivot array.
c
            kpvt(k) = k
            if (swap) kpvt(k) = imax
         go to 190
  140    continue
c
c           2 x 2 pivot block.
c
            km1k = ik + k - 1
            ikm1 = ik - (k - 1)
            if (.not.swap) go to 160
c
c              perform an interchange.
c
               call dswap(imax,ap(im+1),1,ap(ikm1+1),1)
               imj = ikm1 + imax
               do 150 jj = imax, km1
                  j = km1 + imax - jj
                  jkm1 = ikm1 + j
                  t = ap(jkm1)
                  ap(jkm1) = ap(imj)
                  ap(imj) = t
                  imj = imj - (j - 1)
  150          continue
               t = ap(km1k)
               ap(km1k) = ap(imk)
               ap(imk) = t
  160       continue
c
c           perform the elimination.
c
            km2 = k - 2
            if (km2 .eq. 0) go to 180
               ak = ap(kk)/ap(km1k)
               km1km1 = ikm1 + k - 1
               akm1 = ap(km1km1)/ap(km1k)
               denom = 1.0d0 - ak*akm1
               ij = ik - (k - 1) - (k - 2)
               do 170 jj = 1, km2
                  j = km1 - jj
                  jk = ik + j
                  bk = ap(jk)/ap(km1k)
                  jkm1 = ikm1 + j
                  bkm1 = ap(jkm1)/ap(km1k)
                  mulk = (akm1*bk - bkm1)/denom
                  mulkm1 = (ak*bkm1 - bk)/denom
                  t = mulk
                  call daxpy(j,t,ap(ik+1),1,ap(ij+1),1)
                  t = mulkm1
                  call daxpy(j,t,ap(ikm1+1),1,ap(ij+1),1)
                  ap(jk) = mulk
                  ap(jkm1) = mulkm1
                  ijj = ij + j
                  ij = ij - (j - 1)
  170          continue
  180       continue
c
c           set the pivot array.
c
            kpvt(k) = 1 - k
            if (swap) kpvt(k) = -imax
            kpvt(k-1) = kpvt(k)
  190    continue
         ik = ik - (k - 1)
         if (kstep .eq. 2) ik = ik - (k - 2)
         k = k - kstep
      go to 10
  200 continue
      return
      end
      double precision function pythag(a,b)
      double precision a,b
c
c     finds dsqrt(a**2+b**2) without overflow or destructive underflow
c
      double precision p,r,s,t,u
      p = dmax1(dabs(a),dabs(b))
      if (p .eq. 0.0d0) go to 20
      r = (dmin1(dabs(a),dabs(b))/p)**2
   10 continue
         t = 4.0d0 + r
         if (t .eq. 4.0d0) go to 20
         s = r/t
         u = 1.0d0 + 2.0d0*s
         p = u*p
         r = (s/u)**2 * r
      go to 10
   20 pythag = p
      return
      end
      subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr)
c
      integer n,nm,ierr,matz
      double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n)
c
c     this subroutine calls the recommended sequence of
c     subroutines from the eigensystem subroutine package (eispack)
c     to find the eigenvalues and eigenvectors (if desired)
c     of a real symmetric matrix.
c
c     on input
c
c        nm  must be set to the row dimension of the two-dimensional
c        array parameters as declared in the calling program
c        dimension statement.
c
c        n  is the order of the matrix  a.
c
c        a  contains the real symmetric matrix.
c
c        matz  is an integer variable set equal to zero if
c        only eigenvalues are desired.  otherwise it is set to
c        any non-zero integer for both eigenvalues and eigenvectors.
c
c     on output
c
c        w  contains the eigenvalues in ascending order.
c
c        z  contains the eigenvectors if matz is not zero.
c
c        ierr  is an integer output variable set equal to an error
c           completion code described in the documentation for tqlrat
c           and tql2.  the normal completion code is zero.
c
c        fv1  and  fv2  are temporary storage arrays.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (n .le. nm) go to 10
      ierr = 10 * n
      go to 50
c
   10 if (matz .ne. 0) go to 20
c     .......... find eigenvalues only ..........
      call  tred1(nm,n,a,w,fv1,fv2)
*  tqlrat encounters catastrophic underflow on the Vax
*     call  tqlrat(n,w,fv2,ierr)
      call  tql1(n,w,fv1,ierr)
      go to 50
c     .......... find both eigenvalues and eigenvectors ..........
   20 call  tred2(nm,n,a,w,fv1,z)
      call  tql2(nm,n,w,fv1,z,ierr)
   50 return
      end
      subroutine tql1(n,d,e,ierr)
c
      integer i,j,l,m,n,ii,l1,l2,mml,ierr
      double precision d(n),e(n)
      double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag
c
c     this subroutine is a translation of the algol procedure tql1,
c     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
c     wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
c
c     this subroutine finds the eigenvalues of a symmetric
c     tridiagonal matrix by the ql method.
c
c     on input
c
c        n is the order of the matrix.
c
c        d contains the diagonal elements of the input matrix.
c
c        e contains the subdiagonal elements of the input matrix
c          in its last n-1 positions.  e(1) is arbitrary.
c
c      on output
c
c        d contains the eigenvalues in ascending order.  if an
c          error exit is made, the eigenvalues are correct and
c          ordered for indices 1,2,...ierr-1, but may not be
c          the smallest eigenvalues.
c
c        e has been destroyed.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the j-th eigenvalue has not been
c                     determined after 30 iterations.
c
c     calls pythag for  dsqrt(a*a + b*b) .
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      if (n .eq. 1) go to 1001
c
      do 100 i = 2, n
  100 e(i-1) = e(i)
c
      f = 0.0d0
      tst1 = 0.0d0
      e(n) = 0.0d0
c
      do 290 l = 1, n
         j = 0
         h = dabs(d(l)) + dabs(e(l))
         if (tst1 .lt. h) tst1 = h
c     .......... look for small sub-diagonal element ..........
         do 110 m = l, n
            tst2 = tst1 + dabs(e(m))
            if (tst2 .eq. tst1) go to 120
c     .......... e(n) is always zero, so there is no exit
c                through the bottom of the loop ..........
  110    continue
c
  120    if (m .eq. l) go to 210
  130    if (j .eq. 30) go to 1000
         j = j + 1
c     .......... form shift ..........
         l1 = l + 1
         l2 = l1 + 1
         g = d(l)
         p = (d(l1) - g) / (2.0d0 * e(l))
         r = pythag(p,1.0d0)
         d(l) = e(l) / (p + dsign(r,p))
         d(l1) = e(l) * (p + dsign(r,p))
         dl1 = d(l1)
         h = g - d(l)
         if (l2 .gt. n) go to 145
c
         do 140 i = l2, n
  140    d(i) = d(i) - h
c
  145    f = f + h
c     .......... ql transformation ..........
         p = d(m)
         c = 1.0d0
         c2 = c
         el1 = e(l1)
         s = 0.0d0
         mml = m - l
c     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            c3 = c2
            c2 = c
            s2 = s
            i = m - ii
            g = c * e(i)
            h = c * p
            r = pythag(p,e(i))
            e(i+1) = s * r
            s = e(i) / r
            c = p / r
            p = c * d(i) - s * g
            d(i+1) = h + s * (c * g + s * d(i))
  200    continue
c
         p = -s * s2 * c3 * el1 * e(l) / dl1
         e(l) = s * p
         d(l) = c * p
         tst2 = tst1 + dabs(e(l))
         if (tst2 .gt. tst1) go to 130
  210    p = d(l) + f
c     .......... order eigenvalues ..........
         if (l .eq. 1) go to 250
c     .......... for i=l step -1 until 2 do -- ..........
         do 230 ii = 2, l
            i = l + 2 - ii
            if (p .ge. d(i-1)) go to 270
            d(i) = d(i-1)
  230    continue
c
  250    i = 1
  270    d(i) = p
  290 continue
c
      go to 1001
c     .......... set error -- no convergence to an
c                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end
      subroutine tql2(nm,n,d,e,z,ierr)
c
      integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr
      double precision d(n),e(n),z(nm,n)
      double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag
c
c     this subroutine is a translation of the algol procedure tql2,
c     num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and
c     wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 227-240(1971).
c
c     this subroutine finds the eigenvalues and eigenvectors
c     of a symmetric tridiagonal matrix by the ql method.
c     the eigenvectors of a full symmetric matrix can also
c     be found if  tred2  has been used to reduce this
c     full matrix to tridiagonal form.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        d contains the diagonal elements of the input matrix.
c
c        e contains the subdiagonal elements of the input matrix
c          in its last n-1 positions.  e(1) is arbitrary.
c
c        z contains the transformation matrix produced in the
c          reduction by  tred2, if performed.  if the eigenvectors
c          of the tridiagonal matrix are desired, z must contain
c          the identity matrix.
c
c      on output
c
c        d contains the eigenvalues in ascending order.  if an
c          error exit is made, the eigenvalues are correct but
c          unordered for indices 1,2,...,ierr-1.
c
c        e has been destroyed.
c
c        z contains orthonormal eigenvectors of the symmetric
c          tridiagonal (or full) matrix.  if an error exit is made,
c          z contains the eigenvectors associated with the stored
c          eigenvalues.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the j-th eigenvalue has not been
c                     determined after 30 iterations.
c
c     calls pythag for  dsqrt(a*a + b*b) .
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      if (n .eq. 1) go to 1001
c
      do 100 i = 2, n
  100 e(i-1) = e(i)
c
      f = 0.0d0
      tst1 = 0.0d0
      e(n) = 0.0d0
c
      do 240 l = 1, n
         j = 0
         h = dabs(d(l)) + dabs(e(l))
         if (tst1 .lt. h) tst1 = h
c     .......... look for small sub-diagonal element ..........
         do 110 m = l, n
            tst2 = tst1 + dabs(e(m))
            if (tst2 .eq. tst1) go to 120
c     .......... e(n) is always zero, so there is no exit
c                through the bottom of the loop ..........
  110    continue
c
  120    if (m .eq. l) go to 220
  130    if (j .eq. 30) go to 1000
         j = j + 1
c     .......... form shift ..........
         l1 = l + 1
         l2 = l1 + 1
         g = d(l)
         p = (d(l1) - g) / (2.0d0 * e(l))
         r = pythag(p,1.0d0)
         d(l) = e(l) / (p + dsign(r,p))
         d(l1) = e(l) * (p + dsign(r,p))
         dl1 = d(l1)
         h = g - d(l)
         if (l2 .gt. n) go to 145
c
         do 140 i = l2, n
  140    d(i) = d(i) - h
c
  145    f = f + h
c     .......... ql transformation ..........
         p = d(m)
         c = 1.0d0
         c2 = c
         el1 = e(l1)
         s = 0.0d0
         mml = m - l
c     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            c3 = c2
            c2 = c
            s2 = s
            i = m - ii
            g = c * e(i)
            h = c * p
            r = pythag(p,e(i))
            e(i+1) = s * r
            s = e(i) / r
            c = p / r
            p = c * d(i) - s * g
            d(i+1) = h + s * (c * g + s * d(i))
c     .......... form vector ..........
            do 180 k = 1, n
               h = z(k,i+1)
               z(k,i+1) = s * z(k,i) + c * h
               z(k,i) = c * z(k,i) - s * h
  180       continue
c
  200    continue
c
         p = -s * s2 * c3 * el1 * e(l) / dl1
         e(l) = s * p
         d(l) = c * p
         tst2 = tst1 + dabs(e(l))
         if (tst2 .gt. tst1) go to 130
  220    d(l) = d(l) + f
  240 continue
c     .......... order eigenvalues and eigenvectors ..........
      do 300 ii = 2, n
         i = ii - 1
         k = i
         p = d(i)
c
         do 260 j = ii, n
            if (d(j) .ge. p) go to 260
            k = j
            p = d(j)
  260    continue
c
         if (k .eq. i) go to 300
         d(k) = d(i)
         d(i) = p
c
         do 280 j = 1, n
            p = z(j,i)
            z(j,i) = z(j,k)
            z(j,k) = p
  280    continue
c
  300 continue
c
      go to 1001
c     .......... set error -- no convergence to an
c                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end
      subroutine tred1(nm,n,a,d,e,e2)
c
      integer i,j,k,l,n,ii,nm,jp1
      double precision a(nm,n),d(n),e(n),e2(n)
      double precision f,g,h,scale
c
c     this subroutine is a translation of the algol procedure tred1,
c     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
c
c     this subroutine reduces a real symmetric matrix
c     to a symmetric tridiagonal matrix using
c     orthogonal similarity transformations.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        a contains the real symmetric input matrix.  only the
c          lower triangle of the matrix need be supplied.
c
c     on output
c
c        a contains information about the orthogonal trans-
c          formations used in the reduction in its strict lower
c          triangle.  the full upper triangle of a is unaltered.
c
c        d contains the diagonal elements of the tridiagonal matrix.
c
c        e contains the subdiagonal elements of the tridiagonal
c          matrix in its last n-1 positions.  e(1) is set to zero.
c
c        e2 contains the squares of the corresponding elements of e.
c          e2 may coincide with e if the squares are not needed.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      do 100 i = 1, n
         d(i) = a(n,i)
         a(n,i) = a(i,i)
  100 continue
c     .......... for i=n step -1 until 1 do -- ..........
      do 300 ii = 1, n
         i = n + 1 - ii
         l = i - 1
         h = 0.0d0
         scale = 0.0d0
         if (l .lt. 1) go to 130
c     .......... scale row (algol tol then not needed) ..........
         do 120 k = 1, l
  120    scale = scale + dabs(d(k))
c
         if (scale .ne. 0.0d0) go to 140
c
         do 125 j = 1, l
            d(j) = a(l,j)
            a(l,j) = a(i,j)
            a(i,j) = 0.0d0
  125    continue
c
  130    e(i) = 0.0d0
         e2(i) = 0.0d0
         go to 300
c
  140    do 150 k = 1, l
            d(k) = d(k) / scale
            h = h + d(k) * d(k)
  150    continue
c
         e2(i) = scale * scale * h
         f = d(l)
         g = -dsign(dsqrt(h),f)
         e(i) = scale * g
         h = h - f * g
         d(l) = f - g
         if (l .eq. 1) go to 285
c     .......... form a*u ..........
         do 170 j = 1, l
  170    e(j) = 0.0d0
c
         do 240 j = 1, l
            f = d(j)
            g = e(j) + a(j,j) * f
            jp1 = j + 1
            if (l .lt. jp1) go to 220
c
            do 200 k = jp1, l
               g = g + a(k,j) * d(k)
               e(k) = e(k) + a(k,j) * f
  200       continue
c
  220       e(j) = g
  240    continue
c     .......... form p ..........
         f = 0.0d0
c
         do 245 j = 1, l
            e(j) = e(j) / h
            f = f + e(j) * d(j)
  245    continue
c
         h = f / (h + h)
c     .......... form q ..........
         do 250 j = 1, l
  250    e(j) = e(j) - h * d(j)
c     .......... form reduced a ..........
         do 280 j = 1, l
            f = d(j)
            g = e(j)
c
            do 260 k = j, l
  260       a(k,j) = a(k,j) - f * e(k) - g * d(k)
c
  280    continue
c
  285    do 290 j = 1, l
            f = d(j)
            d(j) = a(l,j)
            a(l,j) = a(i,j)
            a(i,j) = f * scale
  290    continue
c
  300 continue
c
      return
      end
      subroutine tred2(nm,n,a,d,e,z)
c
      integer i,j,k,l,n,ii,nm,jp1
      double precision a(nm,n),d(n),e(n),z(nm,n)
      double precision f,g,h,hh,scale
c
c     this subroutine is a translation of the algol procedure tred2,
c     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
c
c     this subroutine reduces a real symmetric matrix to a
c     symmetric tridiagonal matrix using and accumulating
c     orthogonal similarity transformations.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        a contains the real symmetric input matrix.  only the
c          lower triangle of the matrix need be supplied.
c
c     on output
c
c        d contains the diagonal elements of the tridiagonal matrix.
c
c        e contains the subdiagonal elements of the tridiagonal
c          matrix in its last n-1 positions.  e(1) is set to zero.
c
c        z contains the orthogonal transformation matrix
c          produced in the reduction.
c
c        a and z may coincide.  if distinct, a is unaltered.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      do 100 i = 1, n
c
         do 80 j = i, n
   80    z(j,i) = a(j,i)
c
         d(i) = a(n,i)
  100 continue
c
      if (n .eq. 1) go to 510
c     .......... for i=n step -1 until 2 do -- ..........
      do 300 ii = 2, n
         i = n + 2 - ii
         l = i - 1
         h = 0.0d0
         scale = 0.0d0
         if (l .lt. 2) go to 130
c     .......... scale row (algol tol then not needed) ..........
         do 120 k = 1, l
  120    scale = scale + dabs(d(k))
c
         if (scale .ne. 0.0d0) go to 140
  130    e(i) = d(l)
c
         do 135 j = 1, l
            d(j) = z(l,j)
            z(i,j) = 0.0d0
            z(j,i) = 0.0d0
  135    continue
c
         go to 290
c
  140    do 150 k = 1, l
            d(k) = d(k) / scale
            h = h + d(k) * d(k)
  150    continue
c
         f = d(l)
         g = -dsign(dsqrt(h),f)
         e(i) = scale * g
         h = h - f * g
         d(l) = f - g
c     .......... form a*u ..........
         do 170 j = 1, l
  170    e(j) = 0.0d0
c
         do 240 j = 1, l
            f = d(j)
            z(j,i) = f
            g = e(j) + z(j,j) * f
            jp1 = j + 1
            if (l .lt. jp1) go to 220
c
            do 200 k = jp1, l
               g = g + z(k,j) * d(k)
               e(k) = e(k) + z(k,j) * f
  200       continue
c
  220       e(j) = g
  240    continue
c     .......... form p ..........
         f = 0.0d0
c
         do 245 j = 1, l
            e(j) = e(j) / h
            f = f + e(j) * d(j)
  245    continue
c
         hh = f / (h + h)
c     .......... form q ..........
         do 250 j = 1, l
  250    e(j) = e(j) - hh * d(j)
c     .......... form reduced a ..........
         do 280 j = 1, l
            f = d(j)
            g = e(j)
c
            do 260 k = j, l
  260       z(k,j) = z(k,j) - f * e(k) - g * d(k)
c
            d(j) = z(l,j)
            z(i,j) = 0.0d0
  280    continue
c
  290    d(i) = h
  300 continue
c     .......... accumulation of transformation matrices ..........
      do 500 i = 2, n
         l = i - 1
         z(n,l) = z(l,l)
         z(l,l) = 1.0d0
         h = d(i)
         if (h .eq. 0.0d0) go to 380
c
         do 330 k = 1, l
  330    d(k) = z(k,i) / h
c
         do 360 j = 1, l
            g = 0.0d0
c
            do 340 k = 1, l
  340       g = g + z(k,i) * z(k,j)
c
            do 360 k = 1, l
               z(k,j) = z(k,j) - g * d(k)
  360    continue
c
  380    do 400 k = 1, l
  400    z(k,i) = 0.0d0
c
  500 continue
c
  510 do 520 i = 1, n
         d(i) = z(n,i)
         z(n,i) = 0.0d0
  520 continue
c
      z(n,n) = 1.0d0
      e(1) = 0.0d0
      return
      end


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE ROTEYE (EYE, ROTCEN, ROTMAT, *)
C=======================================================================

C   --*** ROTEYE *** (MESH) Get rotation matrix from eye position
C   --   Written by Amy Gilkey - revised 10/21/86
C   --
C   --ROTEYE derives the rotation matrix from the given eye position.
C   --Rotation matrix gives an X rotation followed by a Y rotation.
C   --
C   --Parameters:
C   --   EYE - IN - the eye position
C   --   ROTCEN - IN - the center of rotation
C   --   ROTMAT - OUT - the rotation matrix
C   --   * - return statement if error in eye position

      REAL EYE(3)
      REAL ROTCEN(3)
      REAL ROTMAT(3,3)

      X = EYE(1) - ROTCEN(1)
      Y = EYE(2) - ROTCEN(2)
      Z = EYE(3) - ROTCEN(3)
      VMAG1 = SQRT (Y*Y + Z*Z)
      VMAG2 = SQRT (X*X + Y*Y + Z*Z)
      IF (VMAG1 .EQ. 0.0) GOTO 100
      COS1 = Z / VMAG1
      SIN1 = Y / VMAG1
      COS2 = VMAG1 / VMAG2
      SIN2 = -X / VMAG2

      ROTMAT(1,1) = COS2
      ROTMAT(2,1) = SIN1 * SIN2
      ROTMAT(3,1) = COS1 * SIN2
      ROTMAT(1,2) = 0.0
      ROTMAT(2,2) = COS1
      ROTMAT(3,2) = - SIN1
      ROTMAT(1,3) = - SIN2
      ROTMAT(2,3) = SIN1 * COS2
      ROTMAT(3,3) = COS1 * COS2

      RETURN

  100 CONTINUE
      CALL PRTERR ('CMDERR', 'Eye cannot be exactly on center')
      RETURN 1
      END


#include "../defines.inc"
!---------------------------------------------------------------!
!
!     This subroutine calculates the change in the energy resulting
!     from interbead potentials.
!
!     Written by Quinn 2/27/19
!------------------------------------------------

function two_bead_potential(x, bead1, bead2) result(potential)
   use params, only: dp
   use polydispersity, only: chain_ID
   implicit none
   real(dp) x
   real(dp) potential
   integer, intent(in) :: bead1
   integer, intent(in) :: bead2
   if (abs(bead1 - bead2) <= WLC_P__EXCLUDE_NEIGHBORS_IN_POTENTIAL &
       .and. chain_ID(bead1) == chain_ID(bead2)) then
      potential = 0.0_dp
      return
   endif
   !if (chain_ID(bead1).ne.chain_ID(bead2)) then
   !    potential = 0.0_dp
   !    return
   !endif
   if (x > 1.9999999_dp*WLC_P__CHAIN_D) then
      potential = 0.0_dp
      return
   endif

   potential = exp(-x**2/(WLC_P__CHAIN_D**2))
   return
end function

subroutine mc_2bead_potential(MCTYPE)
! values from wlcsim_data
   use params, only: wlc_R, wlc_RP, dp, &
                     wlc_nPointsMoved, wlc_pointsMoved, nMoveTypes, wlc_bin
   use binning, only: binType, find_neighbors, countBeads
   use energies, only: energyOf, twoBody_
   implicit none
   real(dp) two_bead_potential
   integer, intent(in) :: MCTYPE
   integer ii, jj, kk, ll
   integer, parameter  :: maxNeighbors = WLC_P__NT ! equal length of lists
   integer nNeighbors !number of neighbors found (so far)
   integer neighbors(maxNeighbors) ! list of bead ID's
   real(dp) distances(maxNeighbors) ! list of |r-r| values
   real(dp) radius, distance
   integer otherBead
   integer temp

   radius = WLC_P__CHAIN_D*2.0_dp  ! 2 because I want to go to exp(-4)

   do jj = 1, wlc_nPointsMoved
      ii = wlc_pointsMoved(jj)
      !  ---   Energy between moved beads and unmoved beads ---
      ! plus new
      nNeighbors = 0
      call find_neighbors(wlc_bin, wlc_RP(:, ii), radius, wlc_R, &
                          WLC_P__NT, maxNeighbors, neighbors, distances, nNeighbors)
      do kk = 1, nNeighbors
         otherBead = neighbors(kk)

         ! vvvvvvvvvvvvvvvvvvvvvvv Testing vvvvvvvvvvvvvvvvv
         if (.not. isnan(wlc_RP(1, otherBead)) .and. .FALSE.) then
            temp = 0
            do ll = 1, wlc_nPointsMoved
               if (otherBead == wlc_pointsMoved(ll)) then
                  temp = 1
                  exit
               endif
            enddo
            if (temp == 0) then
               print *, "Points Moved", wlc_pointsMoved(1:wlc_nPointsMoved)
               print *, "otherBead", otherBead, " RP", wlc_RP(1, otherBead), " R", wlc_R(1, otherBead)
               print *, "found error"
               stop
            endif
         endif
         !^^^^^^^^^^^^^^^^^^^^^ end testing ^^^^^^^^^^^^^^^^^^^

         if (.not. isnan(wlc_RP(1, otherBead))) cycle ! exclude moved beads
         distance = distances(kk)
         energyOf(twoBody_)%dx = energyOf(twoBody_)%dx + &
                                 two_bead_potential(distance, ii, otherBead)
      enddo
      ! minus old
      nNeighbors = 0
      call find_neighbors(wlc_bin, wlc_R(:, ii), radius, wlc_R, &
                          WLC_P__NT, maxNeighbors, neighbors, distances, nNeighbors)
      do kk = 1, nNeighbors
         otherBead = neighbors(kk)
         if (.not. isnan(wlc_RP(1, otherBead))) cycle ! exclude moved beads
         distance = distances(kk)
         energyOf(twoBody_)%dx = energyOf(twoBody_)%dx - &
                                 two_bead_potential(distance, ii, otherBead)
      enddo

      !  ---  Between moved beads ---
      do kk = jj, wlc_nPointsMoved
         ll = wlc_pointsMoved(kk)
         distance = norm2(wlc_RP(:, ll) - wlc_RP(:, ii))
         if (distance <= radius) then
            energyOf(twoBody_)%dx = energyOf(twoBody_)%dx + &
                                    two_bead_potential(distance, ii, ll)
         endif
         distance = norm2(wlc_R(:, ll) - wlc_R(:, ii))
         if (distance <= radius) then
            energyOf(twoBody_)%dx = energyOf(twoBody_)%dx - &
                                    two_bead_potential(distance, ii, ll)
         endif
      enddo
   enddo

   RETURN
END

!---------------------------------------------------------------!
subroutine mc_2bead_potential_from_scratch()
! values from wlcsim_data
   use params, only: wlc_R
   use energies, only: energyOf, twoBody_
   use params, only: dp
   use polydispersity, only: chain_ID
   implicit none
   real(dp) two_bead_potential
   integer ii, jj
   real(dp) distance, radius

   radius = WLC_P__CHAIN_D*2.0_dp  ! 2 because I want to go to exp(-4)

   do ii = 1, WLC_P__NT
      do jj = ii, WLC_P__NT
         distance = norm2(wlc_R(:, ii) - wlc_R(:, jj))
         if (distance > radius) cycle
         energyOf(twoBody_)%dx = energyOf(twoBody_)%dx + &
                                 two_bead_potential(distance, ii, jj)
      enddo
   enddo

   RETURN
END

!---------------------------------------------------------------!


      subroutine runP_ii(k,i1,i2,f,Gr,Shat3,N0)
      implicit none
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,i1,i2,np
      parameter(np=3)
      double precision f(np),Gr(np,np)
      double complex Shat3(np,z2max,-2:0)

      do ep=-2,0
      Dv(dii(z2(i1,i2))+N0,ep)=
     . (Shat3(k,z2(i1,i2),ep)
     . -2d0*delta(k,i1)*Dv(dzzi(i2)+N0,ep)
     . -2d0*delta(k,i2)*Dv(dzzi(i1)+N0,ep)
     . -Gr(k,1)*Dv(diii(z3(1,i1,i2))+N0,ep)
     . -Gr(k,2)*Dv(diii(z3(2,i1,i2))+N0,ep)
     . -Gr(k,3)*Dv(diii(z3(3,i1,i2))+N0,ep))/f(k)
      enddo

      return
      end


! This routine should be a simplified version of src2
! which applies source terms for a 1-d slice of data along the
! edge of a grid.  This is called only from qad where the conservative
! fix-up is applied and is used to apply source terms over partial
! time steps to the coarse grid cell values used in solving Riemann
! problems at the interface between coarse and fine grids.
subroutine src1d(meqn,mbc,mx1d,q1d,maux,aux1d,t,dt)

    use geoclaw_module, only: g => grav, rho, coriolis_forcing, coriolis
    use geoclaw_module, only: friction_forcing, friction_depth
    use geoclaw_module, only: omega, coordinate_system, manning_coefficient
    use geoclaw_module, only: manning_break, num_manning, dry_tolerance, rho_air

    use storm_module, only: wind_forcing, pressure_forcing, wind_drag
    use storm_module, only: wind_index, pressure_index
    use storm_module, only: storm_direction, storm_location

    use friction_module, only: variable_friction, friction_index

    implicit none

    ! Input
    integer, intent(in) :: meqn, mbc, mx1d, maux
    real(kind=8), intent(in) :: t, dt
    real(kind=8), intent(inout) :: q1d(meqn, mx1d), aux1d(maux, mx1d)

    ! Local storage
    integer :: i, nman
    logical :: found
    real(kind=8) :: h, hu, hv, gamma, dgamma, y, fdt, a(2,2), coeff, tau
    real(kind=8) :: wind_speed, theta, P_atmos_x, P_atmos_y

    ! Algorithm parameters
    ! Parameter controls when to zero out the momentum at a depth in the
    ! friction source term
    real(kind=8), parameter :: depth_tolerance = 1.0d-30

    ! Friction forcing
    if (friction_forcing) then

        do i=1,mx1d

            ! Extract depths
            h = q1d(1,i)
            hu = q1d(2,i)
            hv = q1d(3,i)

            ! If depth is near-zero, set momentum to zero
            if (h < depth_tolerance) then
                q1d(2:3,i) = 0.d0
                cycle
            endif

            ! Apply friction source term only if in shallower water
            if (h <= friction_depth) then
                if (.not.variable_friction) then
                    do nman = num_manning, 1, -1
                        if (aux1d(1,i) .lt. manning_break(nman)) then
                            coeff = manning_coefficient(nman)
                        endif
                    enddo
                else
                    coeff = aux1d(friction_index, i)
                end if

                ! Calculate source term
                gamma = sqrt(hu**2 + hv**2) * (g * coeff**2) / h**(7.d0/3.d0)
                dgamma = 1.d0 + dt * gamma
                q1d(2, i) = q1d(2, i) / dgamma
                q1d(3, i) = q1d(3, i) / dgamma
            endif
        enddo
    endif

    ! Only lat-long coordinate system supported here right now
    if (coriolis_forcing .and. coordinate_system == 2) then

        do i=1,mx1d
            ! aux(3,:,:) stores the y coordinates multiplied by deg2rad
            fdt = 2.d0 * omega * sin(aux1d(3,i)) * dt

            ! Calculate matrix components
            a(1,1) = 1.d0 - 0.5d0 * fdt**2 + fdt**4 / 24.d0
            a(1,2) =  fdt - fdt**3 / 6.d0
            a(2,1) = -fdt + fdt**3 / 6.d0
            a(2,2) = a(1,1)

            q1d(2,i) = q1d(2,i) * a(1,1) + q1d(3,i) * a(1,2)
            q1d(3,i) = q1d(2,i) * a(2,1) + q1d(3,i) * a(2,2)
        enddo
    endif

    ! = Wind Forcing =========================================================
    if (wind_forcing) then
        ! Cannot use sector based wind mappings here due to lack of information
        ! sloc = storm_location(t)
        ! theta = storm_direction(t)
        do i=1,mx1d
            if (q1d(1,i) > dry_tolerance) then
                wind_speed = sqrt(aux1d(wind_index,i)**2 &
                                + aux1d(wind_index+1,i)**2)
                tau = wind_drag(wind_speed,theta) * rho_air * wind_speed / rho(1)
                q1d(2,i) = q1d(2,i) + dt * tau * aux1d(wind_index,i)
                q1d(3,i) = q1d(3,i) + dt * tau * aux1d(wind_index+1,i)
            endif
        enddo
    endif
    ! ========================================================================

    ! == Pressure Forcing ====================================================
    ! Handled in Riemann solver

    ! Need to add dx and dy to calling signature from qad in order for this to
    ! work, can probably get it from amr_module but need to know which grid we
    ! are working on
    ! if (.false.) then
    !     stop "Not sure how to proceed, need direction and the right dx or dy."
    ! endif

end subroutine src1d


      subroutine compute_c5psi(n_C5s,n_psi,Nx,res)
      implicit none
      integer i
      integer Nx
      real*8 n_C5s(Nx)
      real*8 n_psi(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = n_C5s(i) * n_psi(i) ** 5
      res(i)=qb
      end do
      END


! { dg-do run }
!
! PR 41139: [4.5 Regression] a procedure pointer call as actual argument
!
! Contributed by Janus Weil <janus@gcc.gnu.org>

PROGRAM test

 type :: t
   PROCEDURE(add), POINTER, nopass :: f
 end type
 type(t) :: o
 logical :: g

 o%f => add
 g=greater(4.,o%f(1.,2.))
 if (.not. g) STOP 1

CONTAINS

 REAL FUNCTION add(x,y)
   REAL, INTENT(in) :: x,y
   add = x+y
 END FUNCTION add

 LOGICAL FUNCTION greater(x,y)
   REAL, INTENT(in) :: x, y
   print *,"greater:",x,y
   greater = (x > y)
 END FUNCTION greater

END PROGRAM test


      subroutine runCF_00i(i1,f,Gr,Shat3,N0)
C---  Expression for rearrangement of Eq. 5.68
C---  Calculates C00i
C---  Small terms of order f(i)*Cij,Gr(i,j)*Cijk
      implicit none
      include 'pvCnames.f'
      include 'pvCv.f'
      include 'Carraydef.f'
      include 'Carrays.f'
      include 'pvweenumber.f'
      integer ep,N0,i1,np
      parameter(np=2)
      double precision f(np),Gr(np,np)
      double complex Shat3(np,z2max,-2:0)

      do ep=-2,0
      Cv(czzi(i1)+N0,ep)=
     . (Shat3(i1,z2(i1,i1),ep)
     . -f(i1)*Cv(cii(z2(i1,i1))+N0,ep)
     . -Gr(i1,1)*Cv(ciii(z3(1,i1,i1))+N0,ep)
     . -Gr(i1,2)*Cv(ciii(z3(2,i1,i1))+N0,ep))/4d0

      enddo

      return
      end


      subroutine nut_solp

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine calculates the amount of phosphorus lost from the soil
!!    profile in runoff and the movement of soluble phosphorus from the first
!!    to the second layer via percolation

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name          |units        |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ihru          |none         |HRU number
!!    surfq(:)      |mm H2O       |surface runoff generated on day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Min, Max

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use basin_module
      use organic_mineral_mass_module
      use hru_module, only : hru, surqsolp, percp, surfq, i_sep, ihru, qtile
      use soil_module

      implicit none

      integer :: j           !none          |HRU number
      real :: xx             !none          |variable to hold intermediate calculation
                             !              |result
      real :: vap            !kg P/ha       |amount of P leached from soil layer
      integer :: ii          !none          |counter

      j = ihru

!! compute soluble P lost in surface runoff
      xx = soil(j)%phys(1)%bd * soil(j)%phys(1)%d * bsn_prm%phoskd
      surqsolp(j) = rsd1(j)%mp%lab  * surfq(j) / (xx + 1.)   !dont merge
        !!units ==> surqsolp = [kg/ha * mm] / [t/m^3 * mm * m^3/t] = kg/ha
      surqsolp(j) = Min(surqsolp(j), rsd1(j)%mp%lab)
      surqsolp(j) = Max(surqsolp(j), 0.)
      rsd1(j)%mp%lab = rsd1(j)%mp%lab - surqsolp(j)

!! compute soluble P leaching
      vap = rsd1(j)%mp%lab * soil(j)%ly(1)%prk /                   &
        ((soil(j)%phys(1)%conv_wt/ 1000.) * bsn_prm%pperco + .1)   !dont merge
      vap = Min(vap, .5 * rsd1(j)%mp%lab)
      rsd1(j)%mp%lab = rsd1(j)%mp%lab - vap
      if (soil(j)%nly >= 2) then
        soil1(j)%mp(2)%lab = soil1(j)%mp(2)%lab + vap
      end if

      do ii = 2, soil(j)%nly-1
        vap = 0.
	   if (ii/=i_sep(j)) then
         vap = soil1(j)%mp(ii)%lab * soil(j)%ly(ii)%prk /                &
          ((soil(j)%phys(ii)%conv_wt / 1000.) * bsn_prm%pperco + .1)
	     vap = Min(vap, .2 * soil1(j)%mp(ii)%lab)
	     soil1(j)%mp(ii)%lab = soil1(j)%mp(ii)%lab - vap
	     soil1(j)%mp(ii+1)%lab = soil1(j)%mp(ii+1)%lab + vap
         if (ii == hru(j)%lumv%ldrain) then
           vap = soil1(j)%mp(ii)%lab * qtile /                        &
              (soil(j)%phys(ii)%conv_wt / 1000. * bsn_prm%pperco + .1)  !dont merge
           vap = Min(vap, soil1(j)%mp(ii)%lab)
           soil1(j)%mp(ii)%lab = soil1(j)%mp(ii)%lab - vap
         endif
	   endif
	 end do
	 percp(j) = vap

      return
      end subroutine nut_solp


!
! Copyright (C) 2001-2006 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!----------------------------------------------------------------------------
subroutine stres_gradcorr( rho, rhog, rho_core, rhog_core, nspin, &
                           nr1, nr2, nr3, nrxx, nl, &
                           ngm, g, alat, omega, sigmaxc )
  !----------------------------------------------------------------------------
  !
  USE kinds,            ONLY : DP
  use funct,            ONLY : gcxc, gcx_spin, gcc_spin, & !!$gcc_spin_more, &
                               dft_is_gradient, get_igcc
  USE mp_global,        ONLY : intra_pool_comm, intra_bgrp_comm
  USE mp,               ONLY : mp_sum
  !
  IMPLICIT NONE
  !
  integer :: nspin, nr1, nr2, nr3, nrxx, ngm, nl (ngm)
  real(DP) :: rho (nrxx, nspin), rho_core (nrxx), g (3, ngm), &
       alat, omega, sigmaxc (3, 3)
  complex(DP) :: rhog(ngm, nspin), rhog_core(ngm)
  integer :: k, l, m, ipol, is, nspin0
  real(DP) , allocatable :: grho (:,:,:)
  real(DP), parameter :: epsr = 1.0d-6, epsg = 1.0d-10, e2 = 2.d0
  real(DP) :: grh2, grho2 (2), sx, sc, v1x, v2x, v1c, v2c, fac, &
       v1xup, v1xdw, v2xup, v2xdw, v1cup, v1cdw, v2cup, v2cdw, v2cud, &
       zeta, rh, rup, rdw, grhoup, grhodw, grhoud, grup, grdw, &
       sigma_gradcorr (3, 3), rhok
  logical :: igcc_is_lyp

  if ( .not. dft_is_gradient() ) return

  igcc_is_lyp = (get_igcc() == 3)

  sigma_gradcorr(:,:) = 0.d0

  allocate (grho( 3, nrxx, nspin))
  nspin0=nspin
  if (nspin==4) nspin0=1
  fac = 1.d0 / DBLE (nspin0)
  !
  !    calculate the gradient of rho+rhocore in real space
  !
  DO is = 1, nspin0
     !
     rho(:,is)  = fac * rho_core(:)  + rho(:,is)
     rhog(:,is) = fac * rhog_core(:) + rhog(:,is)
     !
     CALL gradrho( nrxx, rhog(1,is), ngm, g, nl, grho(1,1,is) )
     !
  END DO
  !
  if (nspin.eq.1) then
     !
     !    This is the LDA case
     !
     ! sigma_gradcor_{alpha,beta} ==
     !     omega^-1 \int (grad_alpha rho) ( D(rho*Exc)/D(grad_alpha rho) ) d3
     !
     do k = 1, nrxx
        grho2 (1) = grho(1,k,1)**2 + grho(2,k,1)**2 + grho(3,k,1)**2
        if (abs (rho (k, 1) ) .gt.epsr.and.grho2 (1) .gt.epsg) then
           call gcxc (rho (k, 1), grho2(1), sx, sc, v1x, v2x, v1c, v2c)
           do l = 1, 3
              do m = 1, l
                 sigma_gradcorr (l, m) = sigma_gradcorr (l, m) + &
                                grho(l,k,1) * grho(m,k,1) * e2 * (v2x + v2c)
              enddo
           enddo
        endif

     enddo
  else
     !
     !    This is the LSDA case
     !
     do k = 1, nrxx
        grho2 (1) = grho(1,k,1)**2 + grho(2,k,1)**2 + grho(3,k,1)**2
        grho2 (2) = grho(1,k,2)**2 + grho(2,k,2)**2 + grho(3,k,2)**2

        if ( (abs (rho (k, 1) ) .gt.epsr.and.grho2 (1) .gt.epsg) .and. &
             (abs (rho (k, 2) ) .gt.epsr.and.grho2 (2) .gt.epsg) ) then
           call gcx_spin (rho (k, 1), rho (k, 2), grho2 (1), grho2 (2), &
                sx, v1xup, v1xdw, v2xup, v2xdw)
           rh = rho (k, 1) + rho (k, 2)
           if (rh.gt.epsr) then
              if ( igcc_is_lyp ) then
                 call errore('stres_gradcor','lyp type functionals not available in mini_DFT',1)
!!$                 rup = rho (k, 1)
!!$                 rdw = rho (k, 2)
!!$                 grhoup = grho(1,k,1)**2 + grho(2,k,1)**2 + grho(3,k,1)**2
!!$                 grhodw = grho(1,k,2)**2 + grho(2,k,2)**2 + grho(3,k,2)**2
!!$                 grhoud = grho(1,k,1) * grho(1,k,2) + &
!!$                          grho(2,k,1) * grho(2,k,2) + &
!!$                          grho(3,k,1) * grho(3,k,2)
!!$                 call gcc_spin_more(rup, rdw, grhoup, grhodw, grhoud, sc, &
!!$                                 v1cup, v1cdw, v2cup, v2cdw, v2cud)
              else
                 zeta = (rho (k, 1) - rho (k, 2) ) / rh

                 grh2 = (grho (1, k, 1) + grho (1, k, 2) ) **2 + &
                        (grho (2, k, 1) + grho (2, k, 2) ) **2 + &
                        (grho (3, k, 1) + grho (3, k, 2) ) **2
                 call gcc_spin (rh, zeta, grh2, sc, v1cup, v1cdw, v2c)
                 v2cup = v2c
                 v2cdw = v2c
                 v2cud = v2c
              end if
           else
              sc = 0.d0
              v1cup = 0.d0
              v1cdw = 0.d0
              v2c = 0.d0
              v2cup = 0.d0
              v2cdw = 0.d0
              v2cud = 0.d0
           endif
           do l = 1, 3
              do m = 1, l
                 !    exchange
                 sigma_gradcorr (l, m) = sigma_gradcorr (l, m) + &
                      grho (l, k, 1) * grho (m, k, 1) * e2 * v2xup + &
                      grho (l, k, 2) * grho (m, k, 2) * e2 * v2xdw
                 !    correlation
                 sigma_gradcorr (l, m) = sigma_gradcorr (l, m) + &
                     ( grho (l, k, 1) * grho (m, k, 1) * v2cup + &
                       grho (l, k, 2) * grho (m, k, 2) * v2cdw + &
                      (grho (l, k, 1) * grho (m, k, 2) +         &
                       grho (l, k, 2) * grho (m, k, 1) ) * v2cud ) * e2
              enddo
           enddo
        endif
     enddo

  endif
  do l = 1, 3
     do m = 1, l - 1
        sigma_gradcorr (m, l) = sigma_gradcorr (l, m)
     enddo

  enddo
  call mp_sum(  sigma_gradcorr, intra_bgrp_comm )

  call dscal (9, 1.d0 / (nr1 * nr2 * nr3), sigma_gradcorr, 1)

  call daxpy (9, 1.d0, sigma_gradcorr, 1, sigmaxc, 1)

  DO is = 1, nspin0
     !
     rho(:,is)  = rho(:,is)  - fac * rho_core(:)
     rhog(:,is) = rhog(:,is) - fac * rhog_core(:)
     !
  END DO
  !
  deallocate(grho)
  return

end subroutine stres_gradcorr


module get_atomic_masses
implicit none

double precision, dimension(43) :: ams  = (/ 1.007825d0, 4.0026d0, 7.01600d0, 9.01218d0, 11.00931d0, 12.0d0, &
         14.00307d0, 15.99491d0, 18.99840d0, 19.99244d0, 22.9898d0,      &
         23.98504d0, 26.98153d0, 27.97693d0, 30.97376d0, 31.97207d0,     &
         34.96885d0, 39.948d0, 38.96371d0, 39.96259d0, 44.95592d0,       &
         47.90d0, 50.9440d0, 51.9405d0, 54.9381d0, 55.9349d0, 58.9332d0, &
         57.9353d0, 62.9298d0, 63.9291d0, 68.9257d0, 73.9219d0,          &
         74.9216d0, 79.9165d0, 78.9183d0, 83.9115d0, 84.9117d0,          &
         87.9056d0, 89.9054d0, 89.9043d0, 92.9060d0, 97.9055d0, 97.0d0 /)
end module get_atomic_masses

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

                ! SOURCE !

!Hydrogen    H    1    1.007825d0
!Helium      He   2    4.0026
!Lithium     Li   3    7.01600
!Beryllium   Be   4    9.01218
!Boron       B    5    11.00931
!Carbon      C    6    12.0
!Nitrogen    N    7    14.00307d0
!Oxygen      O    8    15.99491d0
!Fluorine    F    9    18.99840
!Neon        Ne   10   19.99244
!Sodium      Na   11   22.9898
!Magnesium   Mg   12   23.98504
!Aluminium   Al   13   26.98153
!Silicon     Si   14   27.97693
!Phosphorus  P    15   30.97376
!Sulfur      S    16   31.97207
!Chlorine    Cl   17   34.96885
!Argon       Ar   18   39.948
!Potassium   K    19   38.96371
!Calcium     Ca   20   39.96259
!Scandium    Sc   21   44.95592
!Titanium    Ti   22   47.90
!Vanadium    V    23   50.9440
!Chromium    Cr   24   51.9405
!Manganese   Mn   25   54.9381
!Iron        Fe   26   55.9349
!Cobalt      Co   27   58.9332
!Nickel      Ni   28   57.9353
!Copper      Cu   29   62.9298
!Zinc        Zn   30   63.9291
!Gallium     Ga   31   68.9257
!Germanium   Ge   32   73.9219
!Arsenic     As   33   74.9216
!Selenium    Se   34   79.9165
!Bromine     Br   35   78.9183
!Krypton     Kr   36   83.9115
!Rubidium    Rb   37   84.9117
!Strontium   Sr   38   87.9056
!Yttrium     Y    39   89.9054
!Zirconium   Zr   40   89.9043
!Niobium     Nb   41   92.9060
!Molybdenur  Mo   42   97.9055
!Technetium  Tc   43   97.0
!======================================!


! starfield.f90
!
! X11 starfield demo for EGGX/ProCALL.
!
! Author:  Philipp Engel
! Licence: ISC
module starfield
    implicit none
    private

    type, public :: point_type
        real :: x, y
    end type point_type

    type, public :: star_type
        real :: x, y, z
    end type star_type

    public :: starfield_init
    public :: starfield_move
    public :: starfield_project
contains
    subroutine starfield_init(stars, width, height, max_depth)
        !! Initialises the starfield to given viewport width and height, with
        !! respect to maximum depth in Z.
        type(star_type), intent(inout) :: stars(:)
        real,            intent(in)    :: width
        real,            intent(in)    :: height
        real,            intent(in)    :: max_depth
        integer                        :: i
        real                           :: r(3)

        do i = 1, size(stars)
            call random_number(r)
            stars(i) = star_type(x = (width / 2) - (r(1) * width), &
                                 y = (height / 2) - (r(2) * height), &
                                 z = r(3) * max_depth)
        end do
    end subroutine starfield_init

    subroutine starfield_move(stars, width, height, max_depth, dz)
        !! Moves starfield in camera direction by `dz`. Stars passing the camera
        !! will be reset to a random X, Y position, and Z set to `max_depth`.
        type(star_type), intent(inout) :: stars(:)
        real,            intent(in)    :: width
        real,            intent(in)    :: height
        real,            intent(in)    :: max_depth
        real,            intent(in)    :: dz
        integer                        :: i
        real                           :: r(2)

        do i = 1, size(stars)
            stars(i)%z = stars(i)%z - dz

            if (stars(i)%z < 0.0) then
                call random_number(r)
                stars(i) = star_type(x = (width / 2) - (r(1) * width), &
                                     y = (height / 2) - (r(2) * height), &
                                     z = max_depth)
            end if
        end do
    end subroutine starfield_move

    subroutine starfield_project(stars, width, height, points)
        !! Projects star coordinates from 3D into 2D.
        type(star_type),  intent(inout) :: stars(:)
        real,             intent(in)    :: width
        real,             intent(in)    :: height
        type(point_type), intent(inout) :: points(:)
        integer                         :: i
        real                            :: k

        do i = 1, size(stars)
            k = 128.0 / stars(i)%z
            points(i)%x = stars(i)%x * k + (width / 2)
            points(i)%y = stars(i)%y * k + (height / 2)
        end do
    end subroutine starfield_project
end module starfield

program main
    use, intrinsic :: iso_c_binding, only: c_null_char
    use :: procall
    use :: starfield
    implicit none

    real,    parameter :: WIDTH      = 640.                 ! Viewport width.
    real,    parameter :: HEIGHT     = 480.                 ! Viewport height.
    real,    parameter :: MAX_DEPTH  = 800.                 ! Max. Z of stars.
    real,    parameter :: DZ         = 2.0                  ! Stars movement in Z.
    integer, parameter :: NSTARS     = 128                  ! Number of stars.
    integer, parameter :: WIN_WIDTH  = int(WIDTH)           ! Window width.
    integer, parameter :: WIN_HEIGHT = int(HEIGHT)          ! Window height.
    integer, parameter :: DELAY      = 10                   ! Frame delay in msec.

    type(star_type)  :: stars(NSTARS)
    type(point_type) :: points(NSTARS)
    integer          :: i
    integer          :: r, g, b
    integer          :: win

    ! Initialise PRNG.
    call random_seed()

    ! Initialise the starfield.
    call starfield_init(stars, WIDTH, HEIGHT, MAX_DEPTH)

    call gopen(WIN_WIDTH, WIN_HEIGHT, win)                  ! Open X11 window.
    call winname(win, 'Fortran Starfield' // c_null_char)   ! Set window title.
    call gsetbgcolor(win, 'black' // c_null_char)           ! Set background colour.
    call layer(win, 0, 1)                                   ! Enable double buffering.

    do
        ! Move starfield and project from 3D to 2D.
        call starfield_move(stars, WIDTH, HEIGHT, MAX_DEPTH, DZ)
        call starfield_project(stars, WIDTH, HEIGHT, points)

        ! Clear draw area and draw points.
        call gclr(win)

        do i = 1, NSTARS
            ! Get RGB values from colour gradient, set pen colour, and draw
            ! single pixel. Stars farther away will be darker.
            call makecolor(0, MAX_DEPTH * 1.5, 0.0, stars(i)%z, r, g, b)
            call newrgbcolor(win, r, g, b)
            call pset(win, points(i)%x - 1, points(i)%y - 1)
        end do

        ! Copy layer to window and sleep.
        call copylayer(win, 1, 0)
        call msleep(DELAY)
    end do

    ! Close all windows.
    call gcloseall()
end program main