#pragma -xO
!     real*4 function amod(a, b)
!     implicit real*8 (a-z)
!     amod = a - int(a / b) * b
!     return
!     end

!     integer*4 function ifix(a)
!     implicit real*8 (a-z)
!     ifix = int(a)
!     return
!     end

!     integer*4 function idint(a)
!     implicit real*8 (a-z)
!     idint = int(a)
!     return
!     end

!     subroutine caxpy(n,ca,cx,incx,cy,incy)
!     complex cx(1),cy(1),ca
!     canorm = abs(real(ca)) + abs(aimag(ca))
!     if(n.le.0.or.canorm.eq.0.e0) return
!     if(incx.eq.incy.and.incx.gt.0) go to 20
!     kx = 1
!     ky = 1
!     if(incx.lt.0) kx = 1+(1-n)*incx
!     if(incy.lt.0) ky = 1+(1-n)*incy
!         do 10 i = 1,n
!         cy(ky) = cy(ky) + ca*cx(kx)
!         kx = kx + incx
!         ky = ky + incy
!  10 continue
!     return
!  20 continue
!     ns = n*incx
!         do 30 i=1,ns,incx
!         cy(i) = ca*cx(i) + cy(i)
!  30     continue
!     return
!     end

!     subroutine ccopy(n,cx,incx,cy,incy)
!     complex cx(1),cy(1)
!     if(n .le. 0)return
!     if(incx.eq.incy.and.incx.gt.0) go to 20
!     kx = 1
!     ky = 1
!     if(incx.lt.0) kx = 1+(1-n)*incx
!     if(incy.lt.0) ky = 1+(1-n)*incy
!         do 10 i = 1,n
!         cy(ky) = cx(kx)
!         kx = kx + incx
!         ky = ky + incy
!  10 continue
!     return
!  20 continue
!     ns = n*incx
!         do 30 i=1,ns,incx
!         cy(i) = cx(i)
!  30     continue
!     return
!     end

!     complex function cdotc(n,cx,incx,cy,incy)
!     complex cx(1),cy(1)
!     cdotc = (0.,0.)
!     if(n .le. 0)return
!     if(incx.eq.incy.and.incx.gt.0) go to 20
!     kx = 1
!     ky = 1
!     if(incx.lt.0) kx = 1+(1-n)*incx
!     if(incy.lt.0) ky = 1+(1-n)*incy
!         do 10 i = 1,n
!         cdotc = cdotc + conjg(cx(kx))*cy(ky)
!         kx = kx + incx
!         ky = ky + incy
!  10     continue
!     return
!  20 continue
!     ns = n*incx
!         do 30 i=1,ns,incx
!         cdotc = conjg(cx(i))*cy(i) + cdotc
!  30     continue
!     return
!     end

!     complex function cdotu(n,cx,incx,cy,incy)
!     complex cx(1),cy(1)
!     cdotu = (0.,0.)
!     if(n .le. 0)return
!     if(incx.eq.incy.and.incx.gt.0) go to 20
!     kx = 1
!     ky = 1
!     if(incx.lt.0) kx = 1+(1-n)*incx
!     if(incy.lt.0) ky = 1+(1-n)*incy
!         do 10 i = 1,n
!         cdotu = cdotu + cx(kx)*cy(ky)
!         kx = kx + incx
!         ky = ky + incy
!  10     continue
!     return
!  20 continue
!     ns = n*incx
!         do 30 i=1,ns,incx
!         cdotu = cdotu + cx(i)*cy(i)
!  30     continue
!     return
!     end

!     subroutine crotg(ca,cb,c,s)
!     complex ca,cb,s
!     real c
!     real norm,scale
!     complex alpha
!     if (cabs(ca) .ne. 0.) go to 10
!        c = 0.
!        s = (1.,0.)
!        ca = cb
!        go to 20
!  10 continue
!        scale = cabs(ca) + cabs(cb)
!        norm = scale * sqrt((cabs(ca/scale))**2 + (cabs(cb/scale))**2)
!        alpha = ca /cabs(ca)
!        c = cabs(ca) / norm
!        s = alpha * conjg(cb) / norm
!        ca = alpha * norm
!  20 continue
!     return
!     end

!     subroutine cscal(n,ca,cx,incx)
!     complex ca,cx(1)
!     if(n .le. 0) return
!     ns = n*incx
!         do 10 i = 1,ns,incx
!         cx(i) = ca*cx(i)
!  10     continue
!     return
!     end

!     subroutine csscal(n,sa,cx,incx)
!     complex cx(1)
!     real    sa
!     if(n .le. 0) return
!     ns = n*incx
!         do 10 i = 1,ns,incx
!         cx(i) = sa*cx(i)
!  10     continue
!     return
!     end

!     subroutine cswap(n,cx,incx,cy,incy)
!     complex cx(1),cy(1),ctemp
!     if(n .le. 0)return
!     if(incx.eq.incy.and.incx.gt.0) go to 20
!     kx = 1
!     ky = 1
!     if(incx.lt.0) kx = 1+(1-n)*incx
!     if(incy.lt.0) ky = 1+(1-n)*incy
!         do 10 i = 1,n
!         ctemp = cx(kx)
!         cx(kx) = cy(ky)
!         cy(ky) = ctemp
!         kx = kx + incx
!         ky = ky + incy
!  10 continue
!     return
!  20 continue
!     ns = n*incx
!         do 30 i=1,ns,incx
!         ctemp = cx(i)
!         cx(i) = cy(i)
!         cy(i) = ctemp
!  30     continue
!     return
!     end

!     double precision function dasum(n,dx,incx)
!     double precision dx(1)
!     dasum = 0.d0
!     if(n.le.0)return
!     if(incx.eq.1)goto 20
!     ns = n*incx
!         do 10 i=1,ns,incx
!         dasum = dasum + dabs(dx(i))
!  10     continue
!     return
!  20 m = mod(n,6)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!        dasum = dasum + dabs(dx(i))
!  30 continue
!     if( n .lt. 6 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,6
!        dasum = dasum + dabs(dx(i)) + dabs(dx(i+1)) + dabs(dx(i+2))
!    1   + dabs(dx(i+3)) + dabs(dx(i+4)) + dabs(dx(i+5))
!  50 continue
!     return
!     end

!     subroutine daxpy(n,da,dx,incx,dy,incy)
!     double precision dx(1),dy(1),da
!     if(n.le.0.or.da.eq.0.d0) return
!     if(incx.eq.incy) if(incx-1) 5,20,60
!   5 continue
!     ix = 1
!     iy = 1
!     if(incx.lt.0)ix = (-n+1)*incx + 1
!     if(incy.lt.0)iy = (-n+1)*incy + 1
!     do 10 i = 1,n
!       dy(iy) = dy(iy) + da*dx(ix)
!       ix = ix + incx
!       iy = iy + incy
!  10 continue
!     return
!  20 m = mod(n,4)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!       dy(i) = dy(i) + da*dx(i)
!  30 continue
!     if( n .lt. 4 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,4
!       dy(i) = dy(i) + da*dx(i)
!       dy(i + 1) = dy(i + 1) + da*dx(i + 1)
!       dy(i + 2) = dy(i + 2) + da*dx(i + 2)
!       dy(i + 3) = dy(i + 3) + da*dx(i + 3)
!  50 continue
!     return
!  60 continue
!     ns = n*incx
!         do 70 i=1,ns,incx
!         dy(i) = da*dx(i) + dy(i)
!  70     continue
!     return
!     end

!     subroutine dcopy(n,dx,incx,dy,incy)
!     double precision dx(1),dy(1)
!     if(n.le.0)return
!     if(incx.eq.incy) if(incx-1) 5,20,60
!   5 continue
!     ix = 1
!     iy = 1
!     if(incx.lt.0)ix = (-n+1)*incx + 1
!     if(incy.lt.0)iy = (-n+1)*incy + 1
!     do 10 i = 1,n
!       dy(iy) = dx(ix)
!       ix = ix + incx
!       iy = iy + incy
!  10 continue
!     return
!  20 m = mod(n,7)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!       dy(i) = dx(i)
!  30 continue
!     if( n .lt. 7 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,7
!       dy(i) = dx(i)
!       dy(i + 1) = dx(i + 1)
!       dy(i + 2) = dx(i + 2)
!       dy(i + 3) = dx(i + 3)
!       dy(i + 4) = dx(i + 4)
!       dy(i + 5) = dx(i + 5)
!       dy(i + 6) = dx(i + 6)
!  50 continue
!     return
!  60 continue
!     ns=n*incx
!         do 70 i=1,ns,incx
!         dy(i) = dx(i)
!  70     continue
!     return
!     end

!     double precision function ddot(n,dx,incx,dy,incy)
!     double precision dx(1),dy(1)
!     ddot = 0.d0
!     if(n.le.0)return
!     if(incx.eq.incy) if(incx-1) 5,20,60
!   5 continue
!     ix = 1
!     iy = 1
!     if(incx.lt.0)ix = (-n+1)*incx + 1
!     if(incy.lt.0)iy = (-n+1)*incy + 1
!     do 10 i = 1,n
!        ddot = ddot + dx(ix)*dy(iy)
!       ix = ix + incx
!       iy = iy + incy
!  10 continue
!     return
!  20 m = mod(n,5)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!        ddot = ddot + dx(i)*dy(i)
!  30 continue
!     if( n .lt. 5 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,5
!        ddot = ddot + dx(i)*dy(i) + dx(i+1)*dy(i+1) +
!    1   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
!  50 continue
!     return
!  60 continue
!     ns = n*incx
!         do 70 i=1,ns,incx
!         ddot = ddot + dx(i)*dy(i)
!  70     continue
!     return
!     end

!     double precision function dnrm2 ( n, dx, incx)
!     integer          next
!     double precision   dx(1), cutlo, cuthi, hitest, sum, xmax,zero,one
!     data   zero, one /0.0d0, 1.0d0/
!     data cutlo, cuthi / 8.232d-11,  1.304d19 /
!     if(n .gt. 0) go to 10
!        dnrm2  = zero
!        go to 300
!  10 assign 30 to next
!     sum = zero
!     nn = n * incx
!     i = 1
!  20    go to next,(30, 50, 70, 110)
!  30 if( dabs(dx(i)) .gt. cutlo) go to 85
!     assign 50 to next
!     xmax = zero
!  50 if( dx(i) .eq. zero) go to 200
!     if( dabs(dx(i)) .gt. cutlo) go to 85
!     assign 70 to next
!     go to 105
! 100 i = j
!     assign 110 to next
!     sum = (sum / dx(i)) / dx(i)
! 105 xmax = dabs(dx(i))
!     go to 115
!  70 if( dabs(dx(i)) .gt. cutlo ) go to 75
! 110 if( dabs(dx(i)) .le. xmax ) go to 115
!        sum = one + sum * (xmax / dx(i))**2
!        xmax = dabs(dx(i))
!        go to 200
! 115 sum = sum + (dx(i)/xmax)**2
!     go to 200
!  75 sum = (sum * xmax) * xmax
!  85 hitest = cuthi/float( n )
!     do 95 j =i,nn,incx
!     if(dabs(dx(j)) .ge. hitest) go to 100
!  95    sum = sum + dx(j)**2
!     dnrm2 = dsqrt( sum )
!     go to 300
! 200 continue
!     i = i + incx
!     if ( i .le. nn ) go to 20
!     dnrm2 = xmax * dsqrt(sum)
! 300 continue
!     return
!     end

!     subroutine drot(n,dx,incx,dy,incy,dc,ds)
!     double precision dx,dy,dc,ds,zero,one,w,z
!     dimension dx(1),dy(1)
!     data zero,one/0.d0,1.d0/
!     if(n .le. 0 .or. (ds .eq. zero .and. dc .eq. one)) go to 40
!     if(.not. (incx .eq. incy .and. incx .gt. 0)) go to 20
!          nsteps=incx*n
!          do 10 i=1,nsteps,incx
!               w=dx(i)
!               z=dy(i)
!               dx(i)=dc*w+ds*z
!               dy(i)=-ds*w+dc*z
!  10           continue
!          go to 40
!  20 continue
!          kx=1
!          ky=1
!          if(incx .lt. 0) kx=1-(n-1)*incx
!          if(incy .lt. 0) ky=1-(n-1)*incy
!          do 30 i=1,n
!               w=dx(kx)
!               z=dy(ky)
!               dx(kx)=dc*w+ds*z
!               dy(ky)=-ds*w+dc*z
!               kx=kx+incx
!               ky=ky+incy
!  30           continue
!  40 continue
!     return
!     end

!     subroutine drotg(da,db,dc,ds)
!     double precision  da, db, dc, ds, u, v, r
!     if (dabs(da) .le. dabs(db)) go to 10
!     u = da + da
!     v = db / u
!     r = dsqrt(.25d0 + v**2) * u
!     dc = da / r
!     ds = v * (dc + dc)
!     db = ds
!     da = r
!     return
!  10 if (db .eq. 0.d0) go to 20
!     u = db + db
!     v = da / u
!     da = dsqrt(.25d0 + v**2) * u
!     ds = db / da
!     dc = v * (ds + ds)
!     if (dc .eq. 0.d0) go to 15
!     db = 1.d0 / dc
!     return
!  15 db = 1.d0
!     return
!  20 dc = 1.d0
!     ds = 0.d0
!     return
!     end

!     subroutine drotm (n,dx,incx,dy,incy,dparam)
!     double precision dflag,dh12,dh22,dx,two,z,dh11,dh21,
!    1 dparam,dy,w,zero
!     dimension dx(1),dy(1),dparam(5)
!     data zero,two/0.d0,2.d0/
!     dflag=dparam(1)
!     if(n .le. 0 .or.(dflag+two.eq.zero)) go to 140
!         if(.not.(incx.eq.incy.and. incx .gt.0)) go to 70
!              nsteps=n*incx
!              if(dflag) 50,10,30
!  10          continue
!              dh12=dparam(4)
!              dh21=dparam(3)
!                   do 20 i=1,nsteps,incx
!                   w=dx(i)
!                   z=dy(i)
!                   dx(i)=w+z*dh12
!                   dy(i)=w*dh21+z
!  20               continue
!              go to 140
!  30          continue
!              dh11=dparam(2)
!              dh22=dparam(5)
!                   do 40 i=1,nsteps,incx
!                   w=dx(i)
!                   z=dy(i)
!                   dx(i)=w*dh11+z
!                   dy(i)=-w+dh22*z
!  40               continue
!              go to 140
!  50          continue
!              dh11=dparam(2)
!              dh12=dparam(4)
!              dh21=dparam(3)
!              dh22=dparam(5)
!                   do 60 i=1,nsteps,incx
!                   w=dx(i)
!                   z=dy(i)
!                   dx(i)=w*dh11+z*dh12
!                   dy(i)=w*dh21+z*dh22
!  60               continue
!              go to 140
!  70     continue
!         kx=1
!         ky=1
!         if(incx .lt. 0) kx=1+(1-n)*incx
!         if(incy .lt. 0) ky=1+(1-n)*incy
!         if(dflag)120,80,100
!  80     continue
!         dh12=dparam(4)
!         dh21=dparam(3)
!              do 90 i=1,n
!              w=dx(kx)
!              z=dy(ky)
!              dx(kx)=w+z*dh12
!              dy(ky)=w*dh21+z
!              kx=kx+incx
!              ky=ky+incy
!  90          continue
!         go to 140
! 100     continue
!         dh11=dparam(2)
!         dh22=dparam(5)
!              do 110 i=1,n
!              w=dx(kx)
!              z=dy(ky)
!              dx(kx)=w*dh11+z
!              dy(ky)=-w+dh22*z
!              kx=kx+incx
!              ky=ky+incy
! 110          continue
!         go to 140
! 120     continue
!         dh11=dparam(2)
!         dh12=dparam(4)
!         dh21=dparam(3)
!         dh22=dparam(5)
!              do 130 i=1,n
!              w=dx(kx)
!              z=dy(ky)
!              dx(kx)=w*dh11+z*dh12
!              dy(ky)=w*dh21+z*dh22
!              kx=kx+incx
!              ky=ky+incy
! 130          continue
! 140     continue
!         return
!         end

!     subroutine drotmg (dd1,dd2,dx1,dy1,dparam)
!     double precision gam,one,rgamsq,dd2,dh11,dh21,dparam,dp2,
!    1 dq2,du,dy1,zero,gamsq,dd1,dflag,dh12,dh22,dp1,dq1,
!    2 dtemp,dx1,two
!     dimension dparam(5)
!     data zero,one,two /0.d0,1.d0,2.d0/
!     data gam,gamsq,rgamsq/4096.d0,16777216.d0,5.9604645d-8/
!     if(.not. dd1 .lt. zero) go to 10
!         go to 60
!  10 continue
!     dp2=dd2*dy1
!     if(.not. dp2 .eq. zero) go to 20
!         dflag=-two
!         go to 260
!  20 continue
!     dp1=dd1*dx1
!     dq2=dp2*dy1
!     dq1=dp1*dx1
!     if(.not. dabs(dq1) .gt. dabs(dq2)) go to 40
!         dh21=-dy1/dx1
!         dh12=dp2/dp1
!         du=one-dh12*dh21
!         if(.not. du .le. zero) go to 30
!              go to 60
!  30     continue
!              dflag=zero
!              dd1=dd1/du
!              dd2=dd2/du
!              dx1=dx1*du
!              go to 100
!  40 continue
!         if(.not. dq2 .lt. zero) go to 50
!              go to 60
!  50     continue
!              dflag=one
!              dh11=dp1/dp2
!              dh22=dx1/dy1
!              du=one+dh11*dh22
!              dtemp=dd2/du
!              dd2=dd1/du
!              dd1=dtemp
!              dx1=dy1*du
!              go to 100
!  60 continue
!         dflag=-one
!         dh11=zero
!         dh12=zero
!         dh21=zero
!         dh22=zero
!         dd1=zero
!         dd2=zero
!         dx1=zero
!         go to 220
!  70 continue
!     if(.not. dflag .ge. zero) go to 90
!         if(.not. dflag .eq. zero) go to 80
!         dh11=one
!         dh22=one
!         dflag=-one
!         go to 90
!  80     continue
!         dh21=-one
!         dh12=one
!         dflag=-one
!  90 continue
!     go to igo,(120,150,180,210)
! 100 continue
! 110     continue
!         if(.not. dd1 .le. rgamsq) go to 130
!              if(dd1 .eq. zero) go to 160
!              assign 120 to igo
!              go to 70
! 120          continue
!              dd1=dd1*gam**2
!              dx1=dx1/gam
!              dh11=dh11/gam
!              dh12=dh12/gam
!         go to 110
! 130 continue
! 140     continue
!         if(.not. dd1 .ge. gamsq) go to 160
!              assign 150 to igo
!              go to 70
! 150          continue
!              dd1=dd1/gam**2
!              dx1=dx1*gam
!              dh11=dh11*gam
!              dh12=dh12*gam
!         go to 140
! 160 continue
! 170     continue
!         if(.not. dabs(dd2) .le. rgamsq) go to 190
!              if(dd2 .eq. zero) go to 220
!              assign 180 to igo
!              go to 70
! 180          continue
!              dd2=dd2*gam**2
!              dh21=dh21/gam
!              dh22=dh22/gam
!         go to 170
! 190 continue
! 200     continue
!         if(.not. dabs(dd2) .ge. gamsq) go to 220
!              assign 210 to igo
!              go to 70
! 210          continue
!              dd2=dd2/gam**2
!              dh21=dh21*gam
!              dh22=dh22*gam
!         go to 200
! 220 continue
!         if(dflag)250,230,240
! 230     continue
!              dparam(3)=dh21
!              dparam(4)=dh12
!              go to 260
! 240     continue
!              dparam(2)=dh11
!              dparam(5)=dh22
!              go to 260
! 250     continue
!              dparam(2)=dh11
!              dparam(3)=dh21
!              dparam(4)=dh12
!              dparam(5)=dh22
! 260 continue
!         dparam(1)=dflag
!         return
!     end

!     subroutine dscal(n,da,dx,incx)
!     double precision da,dx(1)
!     if(n.le.0)return
!     if(incx.eq.1)goto 20
!     ns = n*incx
!         do 10 i = 1,ns,incx
!         dx(i) = da*dx(i)
!  10     continue
!     return
!  20 m = mod(n,5)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!       dx(i) = da*dx(i)
!  30 continue
!     if( n .lt. 5 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,5
!       dx(i) = da*dx(i)
!       dx(i + 1) = da*dx(i + 1)
!       dx(i + 2) = da*dx(i + 2)
!       dx(i + 3) = da*dx(i + 3)
!       dx(i + 4) = da*dx(i + 4)
!  50 continue
!     return
!     end

!     double precision function dsdot(n,sx,incx,sy,incy)
!     real sx(1),sy(1)
!     dsdot = 0.d0
!     if(n .le. 0)return
!     if(incx.eq.incy.and.incx.gt.0) go to 20
!     kx = 1
!     ky = 1
!     if(incx.lt.0) kx = 1+(1-n)*incx
!     if(incy.lt.0) ky = 1+(1-n)*incy
!         do 10 i = 1,n
!         dsdot = dsdot + dble(sx(kx))*dble(sy(ky))
!         kx = kx + incx
!         ky = ky + incy
!  10 continue
!     return
!  20 continue
!     ns = n*incx
!         do 30 i=1,ns,incx
!         dsdot = dsdot + dble(sx(i))*dble(sy(i))
!  30     continue
!     return
!     end

!     subroutine dswap(n,dx,incx,dy,incy)
!     double precision dx(1),dy(1),dtemp1,dtemp2,dtemp3
!     if(n.le.0)return
!     if(incx.eq.incy) if(incx-1) 5,20,60
!   5 continue
!     ix = 1
!     iy = 1
!     if(incx.lt.0)ix = (-n+1)*incx + 1
!     if(incy.lt.0)iy = (-n+1)*incy + 1
!     do 10 i = 1,n
!       dtemp1 = dx(ix)
!       dx(ix) = dy(iy)
!       dy(iy) = dtemp1
!       ix = ix + incx
!       iy = iy + incy
!  10 continue
!     return
!  20 m = mod(n,3)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!       dtemp1 = dx(i)
!       dx(i) = dy(i)
!       dy(i) = dtemp1
!  30 continue
!     if( n .lt. 3 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,3
!       dtemp1 = dx(i)
!       dtemp2 = dx(i+1)
!       dtemp3 = dx(i+2)
!       dx(i) = dy(i)
!       dx(i+1) = dy(i+1)
!       dx(i+2) = dy(i+2)
!       dy(i) = dtemp1
!       dy(i+1) = dtemp2
!       dy(i+2) = dtemp3
!  50 continue
!     return
!  60 continue
!     ns = n*incx
!       do 70 i=1,ns,incx
!       dtemp1 = dx(i)
!       dx(i) = dy(i)
!       dy(i) = dtemp1
!  70   continue
!     return
!     end

!     integer function icamax(n,cx,incx)
!     complex cx(1)
!     icamax = 0
!     if(n.le.0) return
!     icamax = 1
!     if(n .le. 1) return
!     ns = n*incx
!     ii = 1
!     summax = abs(real(cx(1))) + abs(aimag(cx(1)))
!         do 20 i=1,ns,incx
!         sumri = abs(real(cx(i))) + abs(aimag(cx(i)))
!         if(summax.ge.sumri) go to 10
!         summax = sumri
!         icamax = ii
!  10     ii = ii + 1
!  20     continue
!     return
!     end

!     integer function idamax(n,dx,incx)
!     double precision dx(1),dmax,xmag
!     idamax = 0
!     if(n.le.0) return
!     idamax = 1
!     if(n.le.1)return
!     if(incx.eq.1)goto 20
!     dmax = dabs(dx(1))
!     ns = n*incx
!     ii = 1
!         do 10 i = 1,ns,incx
!         xmag = dabs(dx(i))
!         if(xmag.le.dmax) go to 5
!         idamax = ii
!         dmax = xmag
!   5     ii = ii + 1
!  10     continue
!     return
!  20 dmax = dabs(dx(1))
!     do 30 i = 2,n
!         xmag = dabs(dx(i))
!         if(xmag.le.dmax) go to 30
!         idamax = i
!         dmax = xmag
!  30 continue
!     return
!     end

!     integer function isamax(n,sx,incx)
!     real sx(1),smax,xmag
!     isamax = 0
!     if(n.le.0) return
!     isamax = 1
!     if(n.le.1)return
!     if(incx.eq.1)goto 20
!     smax = abs(sx(1))
!     ns = n*incx
!     ii = 1
!         do 10 i=1,ns,incx
!         xmag = abs(sx(i))
!         if(xmag.le.smax) go to 5
!         isamax = ii
!         smax = xmag
!   5     ii = ii + 1
!  10     continue
!     return
!  20 smax = abs(sx(1))
!     do 30 i = 2,n
!        xmag = abs(sx(i))
!        if(xmag.le.smax) go to 30
!        isamax = i
!        smax = xmag
!  30 continue
!     return
!     end

!     real function sasum(n,sx,incx)
!     real sx(1)
!     sasum = 0.0e0
!     if(n.le.0)return
!     if(incx.eq.1)goto 20
!     ns = n*incx
!         do 10 i=1,ns,incx
!         sasum = sasum + abs(sx(i))
!  10     continue
!     return
!  20 m = mod(n,6)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!       sasum = sasum + abs(sx(i))
!  30 continue
!     if( n .lt. 6 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,6
!       sasum = sasum + abs(sx(i)) + abs(sx(i + 1)) + abs(sx(i + 2))
!    1  + abs(sx(i + 3)) + abs(sx(i + 4)) + abs(sx(i + 5))
!  50 continue
!     return
!     end

!     subroutine saxpy(n,sa,sx,incx,sy,incy)
!     real sx(1),sy(1),sa
!     if(n.le.0.or.sa.eq.0.e0) return
!     if(incx.eq.incy) if(incx-1) 5,20,60
!   5 continue
!     ix = 1
!     iy = 1
!     if(incx.lt.0)ix = (-n+1)*incx + 1
!     if(incy.lt.0)iy = (-n+1)*incy + 1
!     do 10 i = 1,n
!       sy(iy) = sy(iy) + sa*sx(ix)
!       ix = ix + incx
!       iy = iy + incy
!  10 continue
!     return
!  20 m = mod(n,4)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!       sy(i) = sy(i) + sa*sx(i)
!  30 continue
!     if( n .lt. 4 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,4
!       sy(i) = sy(i) + sa*sx(i)
!       sy(i + 1) = sy(i + 1) + sa*sx(i + 1)
!       sy(i + 2) = sy(i + 2) + sa*sx(i + 2)
!       sy(i + 3) = sy(i + 3) + sa*sx(i + 3)
!  50 continue
!     return
!  60 continue
!     ns = n*incx
!         do 70 i=1,ns,incx
!         sy(i) = sa*sx(i) + sy(i)
!  70     continue
!     return
!     end

!     function scasum(n,cx,incx)
!     complex cx(1)
!     scasum=0.
!     if(n .le. 0) return
!     ns = n*incx
!         do 10 i=1,ns,incx
!         scasum = scasum + abs(real(cx(i))) + abs(aimag(cx(i)))
!  10     continue
!     return
!     end

!     real function scnrm2( n, cx, incx)
!     logical imag, scale
!     integer          next
!     real         cutlo, cuthi, hitest, sum, xmax, absx, zero, one
!     complex      cx(1)
!     data         zero, one /0.0e0, 1.0e0/
!     data cutlo, cuthi / 4.441e-16,  1.304e19 /
!     if(n .gt. 0) go to 10
!        scnrm2  = zero
!        go to 300
!  10 assign 30 to next
!     sum = zero
!     nn = n * incx
!     do 210 i=1,nn,incx
!        absx = abs(real(cx(i)))
!        imag = .false.
!        go to next,(30, 50, 70, 90, 110)
!  30 if( absx .gt. cutlo) go to 85
!     assign 50 to next
!     scale = .false.
!  50 if( absx .eq. zero) go to 200
!     if( absx .gt. cutlo) go to 85
!     assign 70 to next
!     go to 105
! 100 assign 110 to next
!     sum = (sum / absx) / absx
! 105 scale = .true.
!     xmax = absx
!     go to 115
!  70 if( absx .gt. cutlo ) go to 75
! 110 if( absx .le. xmax ) go to 115
!        sum = one + sum * (xmax / absx)**2
!        xmax = absx
!        go to 200
! 115 sum = sum + (absx/xmax)**2
!     go to 200
!  75 sum = (sum * xmax) * xmax
!  85 assign 90 to next
!     scale = .false.
!     hitest = cuthi/float( n )
!  90 if(absx .ge. hitest) go to 100
!        sum = sum + absx**2
! 200 continue
!     if(imag) go to 210
!        absx = abs(aimag(cx(i)))
!        imag = .true.
!     go to next,(  50, 70, 90, 110 )
! 210 continue
!     scnrm2 = sqrt(sum)
!     if(scale) scnrm2 = scnrm2 * xmax
! 300 continue
!     return
!     end

!     subroutine scopy(n,sx,incx,sy,incy)
!     real sx(1),sy(1)
!     if(n.le.0)return
!     if(incx.eq.incy) if(incx-1) 5,20,60
!   5 continue
!     ix = 1
!     iy = 1
!     if(incx.lt.0)ix = (-n+1)*incx + 1
!     if(incy.lt.0)iy = (-n+1)*incy + 1
!     do 10 i = 1,n
!       sy(iy) = sx(ix)
!       ix = ix + incx
!       iy = iy + incy
!  10 continue
!     return
!  20 m = mod(n,7)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!       sy(i) = sx(i)
!  30 continue
!     if( n .lt. 7 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,7
!       sy(i) = sx(i)
!       sy(i + 1) = sx(i + 1)
!       sy(i + 2) = sx(i + 2)
!       sy(i + 3) = sx(i + 3)
!       sy(i + 4) = sx(i + 4)
!       sy(i + 5) = sx(i + 5)
!       sy(i + 6) = sx(i + 6)
!  50 continue
!     return
!  60 continue
!     ns = n*incx
!         do 70 i=1,ns,incx
!         sy(i) = sx(i)
!  70     continue
!     return
!     end

!     real function sdot(n,sx,incx,sy,incy)
!     real sx(1),sy(1)
!     sdot = 0.0e0
!     if(n.le.0)return
!     if(incx.eq.incy) if(incx-1)5,20,60
!   5 continue
!     ix = 1
!     iy = 1
!     if(incx.lt.0)ix = (-n+1)*incx + 1
!     if(incy.lt.0)iy = (-n+1)*incy + 1
!     do 10 i = 1,n
!       sdot = sdot + sx(ix)*sy(iy)
!       ix = ix + incx
!       iy = iy + incy
!  10 continue
!     return
!  20 m = mod(n,5)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!       sdot = sdot + sx(i)*sy(i)
!  30 continue
!     if( n .lt. 5 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,5
!       sdot = sdot + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) +
!    1   sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4)
!  50 continue
!     return
!  60 continue
!     ns=n*incx
!     do 70 i=1,ns,incx
!       sdot = sdot + sx(i)*sy(i)
!  70   continue
!     return
!     end

!     real function sdsdot(n,sb,sx,incx,sy,incy)
!     real              sx(1),sy(1),sb
!     double precision dsdot
!     dsdot = dble(sb)
!     if(n .le. 0) go to 30
!     if(incx.eq.incy.and.incx.gt.0) go to 40
!     kx = 1
!     ky = 1
!     if(incx.lt.0) kx = 1+(1-n)*incx
!     if(incy.lt.0) ky = 1+(1-n)*incy
!         do 10 i = 1,n
!         dsdot = dsdot + dble(sx(kx))*dble(sy(ky))
!         kx = kx + incx
!         ky = ky + incy
!  10     continue
!  30 sdsdot = sngl(dsdot)
!     return
!  40 continue
!     ns = n*incx
!         do 50 i=1,ns,incx
!         dsdot = dsdot + dble(sx(i))*dble(sy(i))
!  50     continue
!     sdsdot = sngl(dsdot)
!     return
!     end

!     real function snrm2 ( n, sx, incx)
!     integer          next
!     real   sx(1),  cutlo, cuthi, hitest, sum, xmax, zero, one
!     data   zero, one /0.0e0, 1.0e0/
!     data cutlo, cuthi / 4.441e-16,  1.304e19 /
!     if(n .gt. 0) go to 10
!        snrm2  = zero
!        go to 300
!  10 assign 30 to next
!     sum = zero
!     nn = n * incx
!     i = 1
!  20    go to next,(30, 50, 70, 110)
!  30 if( abs(sx(i)) .gt. cutlo) go to 85
!     assign 50 to next
!     xmax = zero
!  50 if( sx(i) .eq. zero) go to 200
!     if( abs(sx(i)) .gt. cutlo) go to 85
!     assign 70 to next
!     go to 105
! 100 i = j
!     assign 110 to next
!     sum = (sum / sx(i)) / sx(i)
! 105 xmax = abs(sx(i))
!     go to 115
!  70 if( abs(sx(i)) .gt. cutlo ) go to 75
! 110 if( abs(sx(i)) .le. xmax ) go to 115
!        sum = one + sum * (xmax / sx(i))**2
!        xmax = abs(sx(i))
!        go to 200
! 115 sum = sum + (sx(i)/xmax)**2
!     go to 200
!  75 sum = (sum * xmax) * xmax
!  85 hitest = cuthi/float( n )
!     do 95 j =i,nn,incx
!     if(abs(sx(j)) .ge. hitest) go to 100
!  95    sum = sum + sx(j)**2
!     snrm2 = sqrt( sum )
!     go to 300
! 200 continue
!     i = i + incx
!     if ( i .le. nn ) go to 20
!     snrm2 = xmax * sqrt(sum)
! 300 continue
!     return
!     end

!     subroutine srot(n,sx,incx,sy,incy,sc,ss)
!     real             sx,sy,sc,ss,zero,one,w,z
!     dimension sx(1),sy(1)
!     data zero,one/0.e0,1.e0/
!     if(n .le. 0 .or. (ss .eq. zero .and. sc .eq. one)) go to 40
!     if(.not. (incx .eq. incy .and. incx .gt. 0)) go to 20
!          nsteps=incx*n
!          do 10 i=1,nsteps,incx
!               w=sx(i)
!               z=sy(i)
!               sx(i)=sc*w+ss*z
!               sy(i)=-ss*w+sc*z
!  10           continue
!          go to 40
!  20 continue
!          kx=1
!          ky=1
!          if(incx .lt. 0) kx=1-(n-1)*incx
!          if(incy .lt. 0) ky=1-(n-1)*incy
!          do 30 i=1,n
!               w=sx(kx)
!               z=sy(ky)
!               sx(kx)=sc*w+ss*z
!               sy(ky)=-ss*w+sc*z
!               kx=kx+incx
!               ky=ky+incy
!  30           continue
!  40 continue
!     return
!     end

!     subroutine srotg(sa,sb,sc,ss)
!     if (abs(sa) .le. abs(sb)) go to 10
!     u = sa + sa
!     v = sb / u
!     r = sqrt(.25 + v**2) * u
!     sc = sa / r
!     ss = v * (sc + sc)
!     sb = ss
!     sa = r
!     return
!  10 if (sb .eq. 0.) go to 20
!     u = sb + sb
!     v = sa / u
!     sa = sqrt(.25 + v**2) * u
!     ss = sb / sa
!     sc = v * (ss + ss)
!     if (sc .eq. 0.) go to 15
!     sb = 1. / sc
!     return
!  15 sb = 1.
!     return
!  20 sc = 1.
!     ss = 0.
!     return
!     end

!     subroutine srotm (n,sx,incx,sy,incy,sparam)
!     dimension sx(1),sy(1),sparam(5)
!     data zero,two/0.e0,2.e0/
!     sflag=sparam(1)
!     if(n .le. 0 .or.(sflag+two.eq.zero)) go to 140
!         if(.not.(incx.eq.incy.and. incx .gt.0)) go to 70
!              nsteps=n*incx
!              if(sflag) 50,10,30
!  10          continue
!              sh12=sparam(4)
!              sh21=sparam(3)
!                   do 20 i=1,nsteps,incx
!                   w=sx(i)
!                   z=sy(i)
!                   sx(i)=w+z*sh12
!                   sy(i)=w*sh21+z
!  20               continue
!              go to 140
!  30          continue
!              sh11=sparam(2)
!              sh22=sparam(5)
!                   do 40 i=1,nsteps,incx
!                   w=sx(i)
!                   z=sy(i)
!                   sx(i)=w*sh11+z
!                   sy(i)=-w+sh22*z
!  40               continue
!              go to 140
!  50          continue
!              sh11=sparam(2)
!              sh12=sparam(4)
!              sh21=sparam(3)
!              sh22=sparam(5)
!                   do 60 i=1,nsteps,incx
!                   w=sx(i)
!                   z=sy(i)
!                   sx(i)=w*sh11+z*sh12
!                   sy(i)=w*sh21+z*sh22
!  60               continue
!              go to 140
!  70     continue
!         kx=1
!         ky=1
!         if(incx .lt. 0) kx=1+(1-n)*incx
!         if(incy .lt. 0) ky=1+(1-n)*incy
!         if(sflag)120,80,100
!  80     continue
!         sh12=sparam(4)
!         sh21=sparam(3)
!              do 90 i=1,n
!              w=sx(kx)
!              z=sy(ky)
!              sx(kx)=w+z*sh12
!              sy(ky)=w*sh21+z
!              kx=kx+incx
!              ky=ky+incy
!  90          continue
!         go to 140
! 100     continue
!         sh11=sparam(2)
!         sh22=sparam(5)
!              do 110 i=1,n
!              w=sx(kx)
!              z=sy(ky)
!              sx(kx)=w*sh11+z
!              sy(ky)=-w+sh22*z
!              kx=kx+incx
!              ky=ky+incy
! 110          continue
!         go to 140
! 120     continue
!         sh11=sparam(2)
!         sh12=sparam(4)
!         sh21=sparam(3)
!         sh22=sparam(5)
!              do 130 i=1,n
!              w=sx(kx)
!              z=sy(ky)
!              sx(kx)=w*sh11+z*sh12
!              sy(ky)=w*sh21+z*sh22
!              kx=kx+incx
!              ky=ky+incy
! 130          continue
! 140     continue
!         return
!         end

!     subroutine srotmg (sd1,sd2,sx1,sy1,sparam)
!     dimension sparam(5)
!     data zero,one,two /0.e0,1.e0,2.e0/
!     data gam,gamsq,rgamsq/4096.e0,1.67772e7,5.96046e-8/
!     if(.not. sd1 .lt. zero) go to 10
!         go to 60
!  10 continue
!     sp2=sd2*sy1
!     if(.not. sp2 .eq. zero) go to 20
!         sflag=-two
!         go to 260
!  20 continue
!     sp1=sd1*sx1
!     sq2=sp2*sy1
!     sq1=sp1*sx1
!     if(.not. abs(sq1) .gt. abs(sq2)) go to 40
!         sh21=-sy1/sx1
!         sh12=sp2/sp1
!         su=one-sh12*sh21
!         if(.not. su .le. zero) go to 30
!              go to 60
!  30     continue
!              sflag=zero
!              sd1=sd1/su
!              sd2=sd2/su
!              sx1=sx1*su
!              go to 100
!  40 continue
!         if(.not. sq2 .lt. zero) go to 50
!              go to 60
!  50     continue
!              sflag=one
!              sh11=sp1/sp2
!              sh22=sx1/sy1
!              su=one+sh11*sh22
!              stemp=sd2/su
!              sd2=sd1/su
!              sd1=stemp
!              sx1=sy1*su
!              go to 100
!  60 continue
!         sflag=-one
!         sh11=zero
!         sh12=zero
!         sh21=zero
!         sh22=zero
!         sd1=zero
!         sd2=zero
!         sx1=zero
!         go to 220
!  70 continue
!     if(.not. sflag .ge. zero) go to 90
!         if(.not. sflag .eq. zero) go to 80
!         sh11=one
!         sh22=one
!         sflag=-one
!         go to 90
!  80     continue
!         sh21=-one
!         sh12=one
!         sflag=-one
!  90 continue
!     go to igo,(120,150,180,210)
! 100 continue
! 110     continue
!         if(.not. sd1 .le. rgamsq) go to 130
!              if(sd1 .eq. zero) go to 160
!              assign 120 to igo
!              go to 70
! 120          continue
!              sd1=sd1*gam**2
!              sx1=sx1/gam
!              sh11=sh11/gam
!              sh12=sh12/gam
!         go to 110
! 130 continue
! 140     continue
!         if(.not. sd1 .ge. gamsq) go to 160
!              assign 150 to igo
!              go to 70
! 150          continue
!              sd1=sd1/gam**2
!              sx1=sx1*gam
!              sh11=sh11*gam
!              sh12=sh12*gam
!         go to 140
! 160 continue
! 170     continue
!         if(.not. abs(sd2) .le. rgamsq) go to 190
!              if(sd2 .eq. zero) go to 220
!              assign 180 to igo
!              go to 70
! 180          continue
!              sd2=sd2*gam**2
!              sh21=sh21/gam
!              sh22=sh22/gam
!         go to 170
! 190 continue
! 200     continue
!         if(.not. abs(sd2) .ge. gamsq) go to 220
!              assign 210 to igo
!              go to 70
! 210          continue
!              sd2=sd2/gam**2
!              sh21=sh21*gam
!              sh22=sh22*gam
!         go to 200
! 220 continue
!         if(sflag)250,230,240
! 230     continue
!              sparam(3)=sh21
!              sparam(4)=sh12
!              go to 260
! 240     continue
!              sparam(2)=sh11
!              sparam(5)=sh22
!              go to 260
! 250     continue
!              sparam(2)=sh11
!              sparam(3)=sh21
!              sparam(4)=sh12
!              sparam(5)=sh22
! 260 continue
!         sparam(1)=sflag
!         return
!     end

!     subroutine sscal(n,sa,sx,incx)
!     real sa,sx(1)
!     if(n.le.0)return
!     if(incx.eq.1)goto 20
!     ns = n*incx
!         do 10 i = 1,ns,incx
!         sx(i) = sa*sx(i)
!  10     continue
!     return
!  20 m = mod(n,5)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!       sx(i) = sa*sx(i)
!  30 continue
!     if( n .lt. 5 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,5
!       sx(i) = sa*sx(i)
!       sx(i + 1) = sa*sx(i + 1)
!       sx(i + 2) = sa*sx(i + 2)
!       sx(i + 3) = sa*sx(i + 3)
!       sx(i + 4) = sa*sx(i + 4)
!  50 continue
!     return
!     end

!     subroutine sswap (n,sx,incx,sy,incy)
!     real sx(1),sy(1),stemp1,stemp2,stemp3
!     if(n.le.0)return
!     if(incx.eq.incy) if(incx-1) 5,20,60
!   5 continue
!     ix = 1
!     iy = 1
!     if(incx.lt.0)ix = (-n+1)*incx + 1
!     if(incy.lt.0)iy = (-n+1)*incy + 1
!     do 10 i = 1,n
!       stemp1 = sx(ix)
!       sx(ix) = sy(iy)
!       sy(iy) = stemp1
!       ix = ix + incx
!       iy = iy + incy
!  10 continue
!     return
!  20 m = mod(n,3)
!     if( m .eq. 0 ) go to 40
!     do 30 i = 1,m
!       stemp1 = sx(i)
!       sx(i) = sy(i)
!       sy(i) = stemp1
!  30 continue
!     if( n .lt. 3 ) return
!  40 mp1 = m + 1
!     do 50 i = mp1,n,3
!       stemp1 = sx(i)
!       stemp2 = sx(i+1)
!       stemp3 = sx(i+2)
!       sx(i) = sy(i)
!       sx(i+1) = sy(i+1)
!       sx(i+2) = sy(i+2)
!       sy(i) = stemp1
!       sy(i+1) = stemp2
!       sy(i+2) = stemp3
!  50 continue
!     return
!  60 continue
!     ns = n*incx
!       do 70 i=1,ns,incx
!       stemp1 = sx(i)
!       sx(i) = sy(i)
!       sy(i) = stemp1
!  70   continue
!     return
!     end

!     subroutine vexopy (nn,v,x,y,icode)
!     real    v(1), x(1), y(1)
!     n = nn
!     if(icode.eq.2) go to 20
!     do 15 i = 1,n
!        v(i) = x(i) + y(i)
!15   continue
!     return
!20   do 25 i = 1,n
!        v(i) = x(i) - y(i)
!25   continue
!     return
!     end

!     subroutine vfill (n,v,val)
!     real    v(n)
!     if (n .le. 0) return
!     nr=mod(n,4)
!     is=1
!     goto(1,2,3,4), nr+1
!   4   is=4
!       v(1)=val
!       v(2)=val
!       v(3)=val
!       goto 1
!   3   is=3
!       v(1)=val
!       v(2)=val
!       goto 1
!   2   is=2
!       v(1)=val
!   1 do 10 i=is,n,4
!       v(i)  =val
!       v(i+1)=val
!       v(i+2)=val
!       v(i+3)=val
!10   continue
!     return
!     end

!     subroutine saxpyx (nn,saa,sx,incxx,sy,incyy)
!     real               sy(1), sx(1), saa
!     n    = nn
!     sa   = saa
!     incx = incxx
!     incy = incyy
!     if (n .le. 0) return
!     if (incx .eq. incy) if (incx - 1) 5,15,35
!   5 continue
!     ix = 1
!     iy = 1
!     if (incx .lt. 0) ix = (-n + 1)*incx + 1
!     if (incy .lt. 0) iy = (-n + 1)*incy + 1
!     do 10 i = 1,n
!        sx(ix) = sy(iy) + sa*sx(ix)
!        ix = ix + incx
!        iy = iy + incy
!  10 continue
!     return
!  15 do 20 i = 1,n
!        sx(i) = sy(i) + sa*sx(i)
!  20 continue
!     return
!  35 ns = n*incx
!     do 40 i = 1,ns,incx
!        sx(i) = sy(i) + sa*sx(i)
!  40 continue
!     return
!     end

*deck dbcg
      subroutine dbcg(n, b, x, nelt, ia, ja, a, isym, matvec, mttvec,
     $     msolve, mtsolv, itol, tol, itmax, iter, err, ierr, iunit, 
     $     r, z, p, rr, zz, pp, dz, rwork, iwork)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax
      integer iter, ierr, iunit, iwork(*)
      double precision b(n), x(n), a(nelt), tol, err, r(n), z(n), p(n)
      double precision rr(n), zz(n), pp(n), dz(n), rwork(*)
      external matvec, mttvec, msolve, mtsolv
      iter = 0
      ierr = 0
      if( n.lt.1 ) then
         ierr = 3
         return
      endif
      fuzz = d1mach(3)
      tolmin = 500.0*fuzz
      fuzz = fuzz*fuzz
      if( tol.lt.tolmin ) then
         tol = tolmin
         ierr = 4
      endif
      call matvec(n, x, r, nelt, ia, ja, a, isym)
      do 10 i = 1, n
         r(i)  = b(i) - r(i)
         rr(i) = r(i)
 10   continue
      call msolve(n, r, z, nelt, ia, ja, a, isym, rwork, iwork)
      call mtsolv(n, rr, zz, nelt, ia, ja, a, isym, rwork, iwork)
      if( isdbcg(n, b, x, nelt, ia, ja, a, isym, msolve, itol, tol,
     $     itmax, iter, err, ierr, iunit, r, z, p, rr, zz, pp,
     $     dz, rwork, iwork, ak, bk, bnrm, solnrm) .ne. 0 )
     $     go to 200
      if( ierr.ne.0 ) return
      do 100 k=1,itmax
         iter = k
         bknum = ddot(n, z, 1, rr, 1)
         if( abs(bknum).le.fuzz ) then
            ierr = 6
            return
         endif
         if(iter .eq. 1) then
            call dcopy(n, z, 1, p, 1)
            call dcopy(n, zz, 1, pp, 1)
         else
            bk = bknum/bkden
            do 20 i = 1, n
               p(i) = z(i) + bk*p(i)
               pp(i) = zz(i) + bk*pp(i)
 20         continue
         endif
         bkden = bknum
         call matvec(n, p, z, nelt, ia, ja, a, isym)
         akden = ddot(n, pp, 1, z, 1)
         ak = bknum/akden
         if( abs(akden).le.fuzz ) then
            ierr = 6
            return
         endif
         call daxpy(n, ak, p, 1, x, 1)
         call daxpy(n, -ak, z, 1, r, 1)
         call mttvec(n, pp, zz, nelt, ia, ja, a, isym)
         call daxpy(n, -ak, zz, 1, rr, 1)
         call msolve(n, r, z, nelt, ia, ja, a, isym, rwork, iwork)
         call mtsolv(n, rr, zz, nelt, ia, ja, a, isym, rwork, iwork)
         if( isdbcg(n, b, x, nelt, ia, ja, a, isym, msolve, itol, tol,
     $        itmax, iter, err, ierr, iunit, r, z, p, rr, zz,
     $        pp, dz, rwork, iwork, ak, bk, bnrm, solnrm) .ne. 0 )
     $        go to 200
 100  continue
      iter = itmax + 1
      ierr = 2
 200  return
      end

*deck dsdbcg
      subroutine dsdbcg(n, b, x, nelt, ia, ja, a, isym, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer ierr, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(n), tol, err, rwork(lenw)
      external dsmv, dsmtv, dsdi
      parameter (locrb=1, locib=11)
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      lociw = locib
      locdin = locrb
      locr = locdin + n
      locz = locr + n
      locp = locz + n
      locrr = locp + n
      loczz = locrr + n
      locpp = loczz + n
      locdz = locpp + n
      locw = locdz + n
      call dchkw( 'dsdbcg', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(4) = locdin
      iwork(9) = lociw
      iwork(10) = locw
      call dsds(n, nelt, ia, ja, a, isym, rwork(locdin))
      call dbcg(n, b, x, nelt, ia, ja, a, isym, dsmv, dsmtv,
     $     dsdi, dsdi, itol, tol, itmax, iter, err, ierr, iunit,
     $     rwork(locr), rwork(locz), rwork(locp),
     $     rwork(locrr), rwork(loczz), rwork(locpp),
     $     rwork(locdz), rwork(1), iwork(1))
      return
      end

*deck dslubc
      subroutine dslubc(n, b, x, nelt, ia, ja, a, isym, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer ierr, iunit, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(nelt), tol, err, rwork(lenw)
      external dsmv, dsmtv, dslui, dsluti
      parameter (locrb=1, locib=11)
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      nl = 0
      nu = 0
      do 20 icol = 1, n
         jbgn = ja(icol)+1
         jend = ja(icol+1)-1
         if( jbgn.le.jend ) then
            do 10 j = jbgn, jend
               if( ia(j).gt.icol ) then
                  nl = nl + 1
                  if( isym.ne.0 ) nu = nu + 1
               else
                  nu = nu + 1
               endif
 10         continue
         endif
 20   continue
      locil = locib
      locjl = locil + n+1
      lociu = locjl + nl
      locju = lociu + nu
      locnr = locju + n+1
      locnc = locnr + n
      lociw = locnc + n
      locl = locrb
      locdin = locl + nl
      locu = locdin + n
      locr = locu + nu
      locz = locr + n
      locp = locz + n
      locrr = locp + n
      loczz = locrr + n
      locpp = loczz + n
      locdz = locpp + n
      locw = locdz + n
      call dchkw( 'dslubc', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(1) = locil
      iwork(2) = locjl
      iwork(3) = lociu
      iwork(4) = locju
      iwork(5) = locl
      iwork(6) = locdin
      iwork(7) = locu
      iwork(9) = lociw
      iwork(10) = locw
      call dsilus( n, nelt, ia, ja, a, isym, nl, iwork(locil),
     $     iwork(locjl), rwork(locl), rwork(locdin), nu, iwork(lociu),
     $     iwork(locju), rwork(locu), iwork(locnr), iwork(locnc) )
      call dbcg(n, b, x, nelt, ia, ja, a, isym, dsmv, dsmtv,
     $     dslui, dsluti, itol, tol, itmax, iter, err, ierr, iunit,
     $     rwork(locr), rwork(locz), rwork(locp),
     $     rwork(locrr), rwork(loczz), rwork(locpp),
     $     rwork(locdz), rwork, iwork )
      return
      end

*deck isdbcg
      function isdbcg(n, b, x, nelt, ia, ja, a, isym, msolve, itol,
     $     tol, itmax, iter, err, ierr, iunit, r, z, p, rr, zz, pp, dz,
     $     rwork, iwork, ak, bk, bnrm, solnrm)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax
      integer iter, ierr, iunit, iwork(1)
      double precision b(n), x(n), a(nelt), tol, err, r(n), z(n), p(n)
      double precision rr(n), zz(n), pp(n), dz(n), rwork(*)
      double precision ak, bk, bnrm, solnrm
      parameter(maxn=441)
      common /solblk/ soln(maxn)
      external msolve
      isdbcg = 0
      if( itol.eq.1 ) then
         if(iter .eq. 0) bnrm = dnrm2(n, b, 1)
         err = dnrm2(n, r, 1)/bnrm
      else if( itol.eq.2 ) then
         if(iter .eq. 0) then
            call msolve(n, b, dz, nelt, ia, ja, a, isym, rwork, iwork)
            bnrm = dnrm2(n, dz, 1)
         endif
         err = dnrm2(n, z, 1)/bnrm
      else if( itol.eq.11 ) then
         if(iter .eq. 0) solnrm = dnrm2(n, soln, 1)
         do 10 i = 1, n
            dz(i) = x(i) - soln(i)
 10      continue
         err = dnrm2(n, dz, 1)/solnrm
      else
         err = 1.0e10
         ierr = 3
      endif
      if(iunit .ne. 0) then
         if( iter.eq.0 ) then
            write(iunit,1000) n, itol
         endif
         write(iunit,1010) iter, err, ak, bk
      endif
      if(err .le. tol) isdbcg = 1
      return
 1000 format(' preconditioned biconjugate gradient for n, itol = ',
     $     i5,i5,/' iter','   error estimate','            alpha',
     $     '             beta')
 1010 format(1x,i4,1x,e16.7,1x,e16.7,1x,e16.7)
      end

*deck dcg
      subroutine dcg(n, b, x, nelt, ia, ja, a, isym, matvec, msolve, 
     $     itol, tol, itmax, iter, err, ierr, iunit, r, z, p, dz,
     $     rwork, iwork )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer iunit, ierr, iwork(*)
      double precision b(n), x(n), a(nelt), tol, err, r(n), z(n), p(n)
      double precision dz(n), rwork(*)
      external matvec, msolve
      iter = 0
      ierr = 0
      if( n.lt.1 ) then
         ierr = 3
         return
      endif
      tolmin = 500.0*d1mach(3)
      if( tol.lt.tolmin ) then
         tol = tolmin
         ierr = 4
      endif
      call matvec(n, x, r, nelt, ia, ja, a, isym)
      do 10 i = 1, n
         r(i) = b(i) - r(i)
 10   continue
      call msolve(n, r, z, nelt, ia, ja, a, isym, rwork, iwork)
      if( isdcg(n, b, x, nelt, ia, ja, a, isym, msolve, itol, tol,
     $     itmax, iter, err, ierr, iunit, r, z, p, dz,
     $     rwork, iwork, ak, bk, bnrm, solnrm) .ne. 0 ) go to 200
      if( ierr.ne.0 ) return
      do 100 k=1,itmax
         iter = k
         bknum = ddot(n, z, 1, r, 1)
         if( bknum.le.0.0d0 ) then
            ierr = 5
            return
         endif
         if(iter .eq. 1) then
            call dcopy(n, z, 1, p, 1)
         else
            bk = bknum/bkden
            do 20 i = 1, n
               p(i) = z(i) + bk*p(i)
 20         continue
         endif
         bkden = bknum
         call matvec(n, p, z, nelt, ia, ja, a, isym)
         akden = ddot(n, p, 1, z, 1)
         if( akden.le.0.0d0 ) then
            ierr = 6
            return
         endif
         ak = bknum/akden
         call daxpy(n, ak, p, 1, x, 1)
         call daxpy(n, -ak, z, 1, r, 1)
         call msolve(n, r, z, nelt, ia, ja, a, isym, rwork, iwork)
         if( isdcg(n, b, x, nelt, ia, ja, a, isym, msolve, itol, tol,
     $        itmax, iter, err, ierr, iunit, r, z, p, dz, rwork,
     $        iwork, ak, bk, bnrm, solnrm) .ne. 0 ) go to 200
 100  continue
      iter = itmax + 1
      ierr = 2
 200  return
      end

*deck dsdcg
      subroutine dsdcg(n, b, x, nelt, ia, ja, a, isym, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol
      integer itmax, iter, ierr, iunit, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(nelt), tol, err, rwork(lenw)
      external dsmv, dsdi
      parameter (locrb=1, locib=11)
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      lociw = locib
      locd = locrb
      locr = locd + n
      locz = locr + n
      locp = locz + n
      locdz = locp + n
      locw  = locdz + n
      call dchkw( 'dsdcg', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(4) = locd
      iwork(9) = lociw
      iwork(10) = locw
      call dsds(n, nelt, ia, ja, a, isym, rwork(locd))
      call dcg(n, b, x, nelt, ia, ja, a, isym, dsmv, dsdi, 
     $     itol, tol, itmax, iter, err, ierr, iunit, rwork(locr), 
     $     rwork(locz), rwork(locp), rwork(locdz), rwork, iwork)
      return
      end

*deck dsiccg
      subroutine dsiccg(n, b, x, nelt, ia, ja, a, isym, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol
      integer itmax, iter, iunit, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(nelt), tol, err, rwork(lenw)
      external dsmv, dsllti
      parameter (locrb=1, locib=11)
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      if( isym.eq.0 ) then
         nel = (nelt + n)/2
      else
         nel = nelt
      endif
      locjel = locib
      lociel = locjel + nel
      lociw = lociel + n + 1
      locel = locrb
      locdin = locel + nel
      locr = locdin + n
      locz = locr + n
      locp = locz + n
      locdz = locp + n
      locw = locdz + n
      call dchkw( 'dsiccg', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(1) = nel
      iwork(2) = locjel
      iwork(3) = lociel
      iwork(4) = locel
      iwork(5) = locdin
      iwork(9) = lociw
      iwork(10) = locw
      call dsics(n, nelt, ia, ja, a, isym, nel, iwork(lociel),
     $     iwork(locjel), rwork(locel), rwork(locdin),
     $     rwork(locr), ierr )
      if( ierr.ne.0 ) then
         call xerrwv('dsiccg: warning...ic factorization broke down '//
     $        'on step i1.  diagonal was set to unity and '//
     $        'factorization proceeded.', 113, 1, 1, 1, ierr, 0,
     $        0, 0.0, 0.0 )
         ierr = 7
      endif
      call dcg(n, b, x, nelt, ia, ja, a, isym, dsmv, dsllti, 
     $     itol, tol, itmax, iter, err, ierr, iunit, rwork(locr),
     $     rwork(locz), rwork(locp), rwork(locdz), rwork(1),
     $     iwork(1))
      return
      end

*deck isdcg
      function isdcg(n, b, x, nelt, ia, ja, a, isym, msolve, itol,
     $     tol, itmax, iter, err, ierr, iunit, r, z, p, dz, 
     $     rwork, iwork, ak, bk, bnrm, solnrm)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax
      integer iter, ierr, iunit, iwork(*)
      double precision b(n), x(n), a(nelt), tol, err, r(n)
      double precision z(n), p(n), dz(n), rwork(*)
      external msolve
      parameter(maxn=441)
      common /solblk/ soln(maxn)
      isdcg = 0
      if( itol.eq.1 ) then
         if(iter .eq. 0) bnrm = dnrm2(n, b, 1)
         err = dnrm2(n, r, 1)/bnrm
      else if( itol.eq.2 ) then
         if(iter .eq. 0) then
            call msolve(n, r, z, nelt, ia, ja, a, isym, rwork, iwork)
            bnrm = dnrm2(n, dz, 1)
         endif
         err = dnrm2(n, z, 1)/bnrm
      else if( itol.eq.11 ) then
         if(iter .eq. 0) solnrm = dnrm2(n, soln, 1)
         do 10 i = 1, n
            dz(i) = x(i) - soln(i)
 10      continue
         err = dnrm2(n, dz, 1)/solnrm
      else
         err = 1.0e10
         ierr = 3
      endif
      if(iunit .ne. 0) then
         if( iter.eq.0 ) then
            write(iunit,1000) n, itol
         endif
         write(iunit,1010) iter, err, ak, bk
      endif     
      if(err .le. tol) isdcg = 1
      return
 1000 format(' preconditioned conjugate gradient for ',
     $     'n, itol = ',i5, i5,
     $     /' iter','   error estimate','            alpha',
     $     '             beta')
 1010 format(1x,i4,1x,e16.7,1x,e16.7,1x,e16.7)
      end

*deck dcgn
      subroutine dcgn(n, b, x, nelt, ia, ja, a, isym, matvec, mttvec, 
     $     msolve, itol, tol, itmax, iter, err, ierr, iunit, r, z, p, 
     $     atp, atz, dz, atdz, rwork, iwork)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer iunit, iwork(*)
      double precision b(n), x(n), a(n), r(n), z(n), p(n)
      double precision atp(n), atz(n), dz(n), atdz(n), rwork(*)
      external matvec, mttvec, msolve
      iter = 0
      ierr = 0
      if( n.lt.1 ) then
         ierr = 3
         return
      endif
      tolmin = 500.0*d1mach(3)
      if( tol.lt.tolmin ) then
         tol = tolmin
         ierr = 4
      endif
      call matvec(n, x, r, nelt, ia, ja, a, isym)
      do 10 i = 1, n
         r(i) = b(i) - r(i)
 10   continue
      call msolve(n, r, z, nelt, ia, ja, a, isym, rwork, iwork)
      call mttvec(n, z, atz, nelt, ia, ja, a, isym)
      if( isdcgn(n, b, x, nelt, ia, ja, a, isym, matvec, mttvec, msolve,
     $     itol, tol, itmax, iter, err, ierr, iunit, r, z, p, atp, atz,
     $     dz, atdz, rwork, iwork, ak, bk, bnrm, solnrm) .ne. 0 )
     $     go to 200
      if( ierr.ne.0 ) return
      do 100 k=1,itmax
         iter = k
         bknum = ddot(n, z, 1, r, 1)
         if( bknum.le.0.0d0 ) then
            ierr = 6
            return
         endif
         if(iter .eq. 1) then
            call dcopy(n, z, 1, p, 1)
         else
            bk = bknum/bkden
            do 20 i = 1, n
               p(i) = z(i) + bk*p(i)
 20         continue
         endif
         bkden = bknum
         if(iter .ne. 1) call daxpy(n, bk, atp, 1, atz, 1)
         call dcopy(n, atz, 1, atp, 1)
         akden = ddot(n, atp, 1, atp, 1)
         if( akden.le.0.0d0 ) then
            ierr = 6
            return
         endif
         ak = bknum/akden
         call daxpy(n, ak, atp, 1, x, 1)
         call matvec(n, atp, z, nelt, ia, ja, a, isym)
         call daxpy(n, -ak, z, 1, r, 1)
         call msolve(n, r, z, nelt, ia, ja, a, isym, rwork, iwork)
         call mttvec(n, z, atz, nelt, ia, ja, a, isym)
         if( isdcgn(n, b, x, nelt, ia, ja, a, isym, matvec, mttvec,
     $        msolve, itol, tol, itmax, iter, err, ierr, iunit, r, 
     $        z, p, atp, atz, dz, atdz, rwork, iwork, ak, bk, bnrm, 
     $        solnrm) .ne. 0) goto 200
 100  continue
      iter = itmax + 1
 200  return
      end

*deck dsdcgn
      subroutine dsdcgn(n, b, x, nelt, ia, ja, a, isym, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol
      integer itmax, iter, ierr, iunit, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(nelt), tol, err, rwork(lenw)
      external dsmv, dsmtv, dsdi
      parameter (locrb=1, locib=11)
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      lociw = locib
      locd = locrb
      locr = locd + n
      locz = locr + n
      locp = locz + n
      locatp = locp + n
      locatz = locatp + n
      locdz = locatz + n
      locatd = locdz + n
      locw = locatd + n
      call dchkw( 'dsdcgn', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(4) = locd
      iwork(9) = lociw
      iwork(10) = locw
      call dsd2s(n, nelt, ia, ja, a, isym, rwork(1))
      call dcgn( n, b, x, nelt, ia, ja, a, isym, dsmv, dsmtv, dsdi, 
     $     itol, tol, itmax, iter, err, ierr, iunit, rwork(locr), 
     $     rwork(locz), rwork(locp), rwork(locatp), rwork(locatz),
     $     rwork(locdz), rwork(locatd), rwork, iwork )
      if( iter.gt.itmax ) ierr = 2
      return
      end

*deck dslucn
      subroutine dslucn(n, b, x, nelt, ia, ja, a, isym, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer ierr, iunit, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(nelt), tol, err, rwork(lenw)
      parameter (locrb=1, locib=11)
      external dsmv, dsmtv, dsmmti
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      nl = 0
      nu = 0
      do 20 icol = 1, n
         jbgn = ja(icol)+1
         jend = ja(icol+1)-1
         if( jbgn.le.jend ) then
            do 10 j = jbgn, jend
               if( ia(j).gt.icol ) then
                  nl = nl + 1
                  if( isym.ne.0 ) nu = nu + 1
               else
                  nu = nu + 1
               endif
 10         continue
         endif
 20   continue
      locil = locib
      locjl = locil + n+1
      lociu = locjl + nl
      locju = lociu + nu
      locnr = locju + n+1
      locnc = locnr + n
      lociw = locnc + n
      locl = locrb
      locdin = locl + nl
      locu = locdin + n
      locr = locu + nu
      locz = locr + n
      locp = locz + n
      locatp = locp + n
      locatz = locatp + n
      locdz = locatz + n
      locatd = locdz + n
      locw = locatd + n
      call dchkw( 'dslucn', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(1) = locil
      iwork(2) = locjl
      iwork(3) = lociu
      iwork(4) = locju
      iwork(5) = locl
      iwork(6) = locdin
      iwork(7) = locu
      iwork(9) = lociw
      iwork(10) = locw
      call dsilus( n, nelt, ia, ja, a, isym, nl, iwork(locil),
     $     iwork(locjl), rwork(locl), rwork(locdin), nu, iwork(lociu),
     $     iwork(locju), rwork(locu), iwork(locnr), iwork(locnc) )
      call dcgn(n, b, x, nelt, ia, ja, a, isym, dsmv, dsmtv, dsmmti, 
     $     itol, tol, itmax, iter, err, ierr, iunit, rwork(locr),
     $     rwork(locz), rwork(locp), rwork(locatp), rwork(locatz),
     $     rwork(locdz), rwork(locatd), rwork, iwork ) 
      if( iter.gt.itmax ) ierr = 2         
      return
      end

*deck isdcgn
      function isdcgn(n, b, x, nelt, ia, ja, a, isym, matvec, mttvec,
     $     msolve, itol, tol, itmax, iter, err, ierr, iunit, r, z, 
     $     p, atp, atz, dz, atdz, rwork, iwork, ak, bk, bnrm, solnrm)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer iunit, iwork(*)
      double precision b(n), x(n), a(n), tol, err, r(n), z(n), p(n)
      double precision atp(n), atz(n), dz(n), atdz(n), rwork(*)
      double precision ak, bk, bnrm, solnrm
      external matvec, mttvec, msolve
      parameter(maxn=441)
      common /solblk/ soln(maxn)
      isdcgn = 0
      if( itol.eq.1 ) then
         if(iter .eq. 0) bnrm = dnrm2(n, b, 1)
         err = dnrm2(n, r, 1)/bnrm
      else if( itol.eq.2 ) then
         if(iter .eq. 0) then
            call msolve(n, b, dz, nelt, ia, ja, a, isym, rwork, iwork)
            call mttvec(n, dz, atdz, nelt, ia, ja, a, isym)
            bnrm = dnrm2(n, atdz, 1)
         endif
         err = dnrm2(n, atz, 1)/bnrm
      else if( itol.eq.11 ) then
         if(iter .eq. 0) solnrm = dnrm2(n, soln, 1)
         do 10 i = 1, n
            dz(i) = x(i) - soln(i)
 10      continue
         err = dnrm2(n, dz, 1)/solnrm
      else
         err = 1.0e10
         ierr = 3
      endif
      if( iunit.ne.0 ) then
         if( iter.eq.0 ) then
            write(iunit,1000) n, itol
         endif
         write(iunit,1010) iter, err, ak, bk
      endif
      if( err.le.tol ) isdcgn = 1
      return
 1000 format(' pcg applied to the normal equations for ',
     $     'n, itol = ',i5, i5,
     $     /' iter','   error estimate','            alpha',
     $     '             beta')
 1010 format(1x,i4,1x,e16.7,1x,e16.7,1x,e16.7)
      end

*deck dcgs
      subroutine dcgs(n, b, x, nelt, ia, ja, a, isym, matvec,
     $     msolve, itol, tol, itmax, iter, err, ierr, iunit, 
     $     r, r0, p, q, u, v1, v2, rwork, iwork)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax
      integer iter, ierr, iunit, iwork(*)
      double precision b(n), x(n), a(nelt), tol, err, r(n), r0(n), p(n)
      double precision q(n), u(n), v1(n), v2(n), rwork(*)
      external matvec, msolve
      iter = 0
      ierr = 0
      if( n.lt.1 ) then
         ierr = 3
         return
      endif
      tolmin = 500.0*d1mach(3)
      if( tol.lt.tolmin ) then
         tol = tolmin
         ierr = 4
      endif
      call matvec(n, x, r, nelt, ia, ja, a, isym)
      do 10 i = 1, n
         v1(i)  = r(i) - b(i)
 10   continue
      call msolve(n, v1, r, nelt, ia, ja, a, isym, rwork, iwork)
      if( isdcgs(n, b, x, nelt, ia, ja, a, isym, matvec, msolve, 
     $     itol, tol, itmax, iter, err, ierr, iunit, r, r0, p, q, 
     $     u, v1, v2, rwork, iwork, ak, bk, bnrm, solnrm) .ne. 0 )
     $     go to 200
      if( ierr.ne.0 ) return
      fuzz = d1mach(3)**2
      do 20 i = 1, n
         r0(i) = r(i)
 20   continue
      rhonm1 = 1.0
      do 100 k=1,itmax
         iter = k
         rhon = ddot(n, r0, 1, r, 1)
         if( abs(rhonm1).lt.fuzz ) goto 998
         bk = rhon/rhonm1
         if( iter.eq.1 ) then
            do 30 i = 1, n
               u(i) = r(i)
               p(i) = r(i)
 30         continue
         else
            do 40 i = 1, n
               u(i) = r(i) + bk*q(i)
               v1(i) = q(i) + bk*p(i)
 40         continue
            do 50 i = 1, n
               p(i) = u(i) + bk*v1(i)
 50         continue
         endif
         call matvec(n, p, v2, nelt, ia, ja, a, isym)
         call msolve(n, v2, v1, nelt, ia, ja, a, isym, rwork, iwork)
         sigma = ddot(n, r0, 1, v1, 1)
         if( abs(sigma).lt.fuzz ) goto 999
         ak = rhon/sigma
         akm = -ak
         do 60 i = 1, n
            q(i) = u(i) + akm*v1(i)
 60      continue
         do 70 i = 1, n
            v1(i) = u(i) + q(i)
 70      continue
         call daxpy( n, akm, v1, 1, x, 1 )
         call matvec(n, v1, v2, nelt, ia, ja, a, isym)
         call msolve(n, v2, v1, nelt, ia, ja, a, isym, rwork, iwork)
         call daxpy( n, akm, v1, 1, r, 1 )
         if( isdcgs(n, b, x, nelt, ia, ja, a, isym, matvec, msolve, 
     $        itol, tol, itmax, iter, err, ierr, iunit, r, r0, p, q, 
     $        u, v1, v2, rwork, iwork, ak, bk, bnrm, solnrm) .ne. 0 )
     $        go to 200
         rhonm1 = rhon
 100  continue
      iter = itmax + 1
      ierr = 2
 200  return
 998  ierr = 5
      return
 999  ierr = 6
      return
      end

*deck dsdcgs
      subroutine dsdcgs(n, b, x, nelt, ia, ja, a, isym, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer ierr, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(n), tol, err, rwork(lenw)
      external dsmv, dsdi
      parameter (locrb=1, locib=11)
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      lociw = locib
      locdin = locrb
      locr  = locdin + n
      locr0 = locr + n
      locp  = locr0 + n
      locq  = locp + n
      locu  = locq + n
      locv1 = locu + n
      locv2 = locv1 + n
      locw  = locv2 + n
      call dchkw( 'dsdcgs', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(4) = locdin
      iwork(9) = lociw
      iwork(10) = locw
      call dsds(n, nelt, ia, ja, a, isym, rwork(locdin))
      call dcgs(n, b, x, nelt, ia, ja, a, isym, dsmv,
     $     dsdi, itol, tol, itmax, iter, err, ierr, iunit,
     $     rwork(locr), rwork(locr0), rwork(locp),
     $     rwork(locq), rwork(locu), rwork(locv1),
     $     rwork(locv2), rwork(1), iwork(1))
      return
      end

*deck dslucs
      subroutine dslucs(n, b, x, nelt, ia, ja, a, isym, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer ierr, iunit, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(nelt), tol, err, rwork(lenw)
      external dsmv, dslui
      parameter (locrb=1, locib=11)
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      nl = 0
      nu = 0
      do 20 icol = 1, n
         jbgn = ja(icol)+1
         jend = ja(icol+1)-1
         if( jbgn.le.jend ) then
            do 10 j = jbgn, jend
               if( ia(j).gt.icol ) then
                  nl = nl + 1
                  if( isym.ne.0 ) nu = nu + 1
               else
                  nu = nu + 1
               endif
 10         continue
         endif
 20   continue
      locil = locib
      locjl = locil + n+1
      lociu = locjl + nl
      locju = lociu + nu
      locnr = locju + n+1
      locnc = locnr + n
      lociw = locnc + n
      locl   = locrb
      locdin = locl + nl
      locuu  = locdin + n
      locr   = locuu + nu
      locr0  = locr + n
      locp   = locr0 + n
      locq   = locp + n
      locu   = locq + n
      locv1  = locu + n
      locv2  = locv1 + n
      locw   = locv2 + n
      call dchkw( 'dslucs', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(1) = locil
      iwork(2) = locjl
      iwork(3) = lociu
      iwork(4) = locju
      iwork(5) = locl
      iwork(6) = locdin
      iwork(7) = locuu
      iwork(9) = lociw
      iwork(10) = locw
      call dsilus( n, nelt, ia, ja, a, isym, nl, iwork(locil),
     $     iwork(locjl), rwork(locl), rwork(locdin), nu, iwork(lociu),
     $     iwork(locju), rwork(locuu), iwork(locnr), iwork(locnc) )
      call dcgs(n, b, x, nelt, ia, ja, a, isym, dsmv,
     $     dslui, itol, tol, itmax, iter, err, ierr, iunit,
     $     rwork(locr), rwork(locr0), rwork(locp),
     $     rwork(locq), rwork(locu), rwork(locv1),
     $     rwork(locv2), rwork, iwork )
      return
      end

*deck isdcgs
      function isdcgs(n, b, x, nelt, ia, ja, a, isym, matvec, msolve, 
     $     itol, tol, itmax, iter, err, ierr, iunit, r, r0, p, q, u, 
     $     v1, v2, rwork, iwork, ak, bk, bnrm, solnrm)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax
      integer iter, ierr, iunit, iwork(1)
      double precision b(n), x(n), a(nelt), tol, err, r(n), r0(n), p(n)
      double precision q(n), u(n), v1(n), v2(n), rwork(1)
      double precision ak, bk, bnrm, solnrm
      parameter(maxn=441)
      common /solblk/ soln(maxn)
      external matvec, msolve
      isdcgs = 0
      if( itol.eq.1 ) then
         if(iter .eq. 0) bnrm = dnrm2(n, b, 1)
         call matvec(n, x, v2, nelt, ia, ja, a, isym )
         do 5 i = 1, n
            v2(i) = v2(i) - b(i)
 5       continue
         err = dnrm2(n, v2, 1)/bnrm
      else if( itol.eq.2 ) then
         if(iter .eq. 0) then
            call msolve(n, b, v2, nelt, ia, ja, a, isym, rwork, iwork)
            bnrm = dnrm2(n, v2, 1)
         endif
         err = dnrm2(n, r, 1)/bnrm
      else if( itol.eq.11 ) then
         if(iter .eq. 0) solnrm = dnrm2(n, soln, 1)
         do 10 i = 1, n
            v2(i) = x(i) - soln(i)
 10      continue
         err = dnrm2(n, v2, 1)/solnrm
      else
         err = 1.0e10
         ierr = 3
      endif
      if(iunit .ne. 0) then
         if( iter.eq.0 ) then
            write(iunit,1000) n, itol
         endif
         write(iunit,1010) iter, err, ak, bk
      endif
      if(err .le. tol) isdcgs = 1
      return
 1000 format(' preconditioned biconjugate gradient squared for ',
     $     'n, itol = ',i5, i5,
     $     /' iter','   error estimate','            alpha',
     $     '             beta')
 1010 format(1x,i4,1x,e16.7,1x,e16.7,1x,e16.7)
      end

*deck dgmres
      subroutine dgmres(n, b, x, nelt, ia, ja, a, isym, matvec, msolve,
     $     itol, tol, itmax, iter, err, ierr, iunit, sb, sx, 
     $     rgwk, lrgw, igwk, ligw, rwork, iwork )
      implicit double precision(a-h,o-z)
      integer  n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer  ierr, iunit, lrgw, ligw, igwk(ligw)
      integer  iwork(*)
      double precision b(n), x(n), a(nelt), tol, err, sb(n), sx(n)
      double precision rgwk(lrgw), rwork(*)
      external matvec, msolve, d1mach
      integer jpre, kmp, maxl, nms, maxlp1, nmsl, nrsts, nrmax
      integer i, iflag, lr, ldl, lhes, lgmr, lq, lv, lw
      double precision bnrm, rhol, sum
      ierr = 0
      maxl = igwk(1)
      if (maxl .eq. 0) maxl = 10
      if (maxl .gt. n) maxl = n
      kmp = igwk(2)
      if (kmp .eq. 0) kmp = maxl
      if (kmp .gt. maxl) kmp = maxl
      jscal = igwk(3)
      jpre = igwk(4)
      if( itol.eq.1 .and. jpre.lt.0 ) goto 650
      if( itol.eq.2 .and. jpre.ge.0 ) goto 650
      nrmax = igwk(5)
      if( nrmax.eq.0 ) nrmax = 10
      if( nrmax.eq.-1 ) nrmax = 0
      if( tol.eq.0.0d0 ) tol = 500.0*d1mach(3)
      iter = 0
      nms = 0
      nrsts = 0
      maxlp1 = maxl + 1
      lv = 1
      lr = lv + n*maxlp1
      lhes = lr + n + 1
      lq = lhes + maxl*maxlp1
      ldl = lq + 2*maxl
      lw = ldl + n
      lxl = lw + n
      lz = lxl + n
      igwk(6) = lz + n - 1
      if( lz+n-1.gt.lrgw ) goto 640
      if (jpre .lt. 0) then
         call msolve(n, b, rgwk(lr), nelt, ia, ja, a, isym,
     $        rwork, iwork)
         nms = nms + 1
      else
         call dcopy(n, b, 1, rgwk(lr), 1)
      endif
      if( jscal.eq.2 .or. jscal.eq.3 ) then
         sum = 0.d0
         do 10 i = 1,n
            sum = sum + (rgwk(lr-1+i)*sb(i))**2
 10      continue
         bnrm = dsqrt(sum)
      else
         bnrm = dnrm2(n,rgwk(lr),1)
      endif
      call matvec(n, x, rgwk(lr), nelt, ia, ja, a, isym)
      do 50 i = 1,n
         rgwk(lr-1+i) = b(i) - rgwk(lr-1+i)
 50   continue
 100  continue
      if( nrsts.gt.nrmax ) goto 610
      if( nrsts.gt.0 ) then
         call dcopy(n, rgwk(ldl), 1, rgwk(lr), 1)
      endif
      call dpigmr(n, rgwk(lr), sb, sx, jscal, maxl, maxlp1, kmp,
     $       nrsts, jpre, matvec, msolve, nmsl, rgwk(lz), rgwk(lv),
     $       rgwk(lhes), rgwk(lq), lgmr, rwork, iwork, rgwk(lw),
     $       rgwk(ldl), rhol, nrmax, b, bnrm, x, rgwk(lxl), itol,
     $       tol, nelt, ia, ja, a, isym, iunit, iflag, err)
      iter = iter + lgmr
      nms = nms + nmsl
      lzm1 = lz - 1
      do 110 i = 1,n
         x(i) = x(i) + rgwk(lzm1+i)
 110  continue
      if( iflag.eq.0 ) goto 600
      if( iflag.eq.1 ) then
         nrsts = nrsts + 1
         goto 100
      endif
      if( iflag.eq.2 ) goto 620
 600  continue
      igwk(7) = nms
      rgwk(1) = rhol
      ierr = 0
      return
 610  continue
      igwk(7) = nms
      rgwk(1) = rhol
      ierr = 1
      return
 620  continue
      igwk(7) = nms
      rgwk(1) = rhol
      ierr = 2
      return
 640  continue
      err = tol
      ierr = -1
      return
 650  continue
      err = tol
      ierr = -2
      return
      end

*deck dsdgmr
      subroutine dsdgmr(n, b, x, nelt, ia, ja, a, isym, nsave,
     $     itol, tol, itmax, iter, err, ierr, iunit, rwork, lenw,
     $     iwork, leniw )
      implicit double precision(a-h,o-z)
      integer  n, nelt, ia(nelt), ja(nelt), isym, nsave, itol
      integer  itmax, iter, ierr, iunit, lenw, leniw, iwork(leniw)
      double precision b(n), x(n), a(nelt), tol, err, rwork(lenw)
      external dsmv, dsdi
      parameter (locrb=1, locib=11)
      ierr = 0
      err  = 0.0
      if( nsave.le.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      locigw = locib
      lociw = locigw + 20
      locdin = locrb
      locrgw = locdin + n
      locw = locrgw + 1+n*(nsave+6)+nsave*(nsave+3)
      iwork(4) = locdin
      iwork(9) = lociw
      iwork(10) = locw
      call dchkw( 'dsdgmr', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      call dsds(n, nelt, ia, ja, a, isym, rwork(locdin))
      iwork(locigw  ) = nsave
      iwork(locigw+1) = nsave
      iwork(locigw+2) = 0
      iwork(locigw+3) = -1
      iwork(locigw+4) = itmax/nsave
      myitol = 0
      call dgmres( n, b, x, nelt, ia, ja, a, isym, dsmv, dsdi,
     $     myitol, tol, itmax, iter, err, ierr, iunit, rwork, rwork,
     $     rwork(locrgw), lenw-locrgw, iwork(locigw), 20,
     $     rwork, iwork )
      if( iter.gt.itmax ) ierr = 2
      return
      end

*deck dslugm
      subroutine dslugm(n, b, x, nelt, ia, ja, a, isym, nsave,
     $     itol, tol, itmax, iter, err, ierr, iunit, rwork, lenw,
     $     iwork, leniw )
      implicit double precision(a-h,o-z)
      integer  n, nelt, ia(nelt), ja(nelt), isym, nsave, itol
      integer  itmax, iter, ierr, iunit, lenw, leniw, iwork(leniw)
      double precision b(n), x(n), a(nelt), tol, err, rwork(lenw)
      external dsmv, dslui
      parameter (locrb=1, locib=11)
      ierr = 0
      err  = 0.0
      if( nsave.le.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      nl = 0
      nu = 0
      do 20 icol = 1, n
         jbgn = ja(icol)+1
         jend = ja(icol+1)-1
         if( jbgn.le.jend ) then
            do 10 j = jbgn, jend
               if( ia(j).gt.icol ) then
                  nl = nl + 1
                  if( isym.ne.0 ) nu = nu + 1
               else
                  nu = nu + 1
               endif
 10         continue
         endif
 20   continue
      locigw = locib
      locil = locigw + 20
      locjl = locil + n+1
      lociu = locjl + nl
      locju = lociu + nu
      locnr = locju + n+1
      locnc = locnr + n
      lociw = locnc + n
      locl = locrb
      locdin = locl + nl
      locu = locdin + n
      locrgw = locu + nu
      locw = locrgw + 1+n*(nsave+6)+nsave*(nsave+3)
      call dchkw( 'dslugm', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(1) = locil
      iwork(2) = locjl
      iwork(3) = lociu
      iwork(4) = locju
      iwork(5) = locl
      iwork(6) = locdin
      iwork(7) = locu
      iwork(9) = lociw
      iwork(10) = locw
      call dsilus( n, nelt, ia, ja, a, isym, nl, iwork(locil),
     $     iwork(locjl), rwork(locl), rwork(locdin), nu, iwork(lociu),
     $     iwork(locju), rwork(locu), iwork(locnr), iwork(locnc) )
      iwork(locigw  ) = nsave
      iwork(locigw+1) = nsave
      iwork(locigw+2) = 0
      iwork(locigw+3) = -1
      iwork(locigw+4) = itmax/nsave
      myitol = 0
      call dgmres( n, b, x, nelt, ia, ja, a, isym, dsmv, dslui,
     $     myitol, tol, itmax, iter, err, ierr, iunit, rwork, rwork,
     $     rwork(locrgw), lenw-locrgw, iwork(locigw), 20,
     $     rwork, iwork )
      if( iter.gt.itmax ) ierr = 2
      return
      end

!     subroutine dhels(a, lda, n, q, b)
!     implicit double precision(a-h,o-z)
!     integer lda, n
!     double precision a(lda,1), b(1), q(1)
!     integer iq, k, kb, kp1
!     double precision c, s, t, t1, t2
!     do 20 k = 1, n
!        kp1 = k + 1
!        iq = 2*(k-1) + 1
!        c = q(iq)
!        s = q(iq+1)
!        t1 = b(k)
!        t2 = b(kp1)
!        b(k) = c*t1 - s*t2
!        b(kp1) = s*t1 + c*t2
!20   continue
!     do 40 kb = 1, n
!        k = n + 1 - kb
!        b(k) = b(k)/a(k,k)
!        t = -b(k)
!        call daxpy(k-1, t, a(1,k), 1, b(1), 1)
!40   continue
!     return
!     end

!     subroutine dheqr(a, lda, n, q, info, ijob)
!     implicit double precision(a-h,o-z)
!     integer lda, n, info, ijob
!     double precision a(lda,*), q(*)
!     integer i, iq, j, k, km1, kp1, nm1
!     double precision c, s, t, t1, t2
!     if (ijob .gt. 1) go to 70
!     info = 0
!     do 60 k = 1, n
!        km1 = k - 1
!        kp1 = k + 1
!        if (km1 .lt. 1) go to 20
!        do 10 j = 1, km1
!           i = 2*(j-1) + 1
!           t1 = a(j,k)
!           t2 = a(j+1,k)
!           c = q(i)
!           s = q(i+1)
!           a(j,k) = c*t1 - s*t2
!           a(j+1,k) = s*t1 + c*t2
!10      continue
!20      continue
!        iq = 2*km1 + 1
!        t1 = a(k,k)
!        t2 = a(kp1,k)
!        if( t2.eq.0.0d0 ) then
!           c = 1.0d0
!           s = 0.0d0
!        elseif( abs(t2).ge.abs(t1) ) then
!           t = t1/t2
!           s = -1.0d0/dsqrt(1.0d0+t*t)
!           c = -s*t
!        else
!           t = t2/t1
!           c = 1.0d0/dsqrt(1.0d0+t*t)
!           s = -c*t
!        endif
!        q(iq) = c
!        q(iq+1) = s
!        a(k,k) = c*t1 - s*t2
!        if( a(k,k).eq.0.0d0 ) info = k
!60   continue
!     return
!70   continue
!     nm1 = n - 1
!     do 100 k = 1,nm1
!        i = 2*(k-1) + 1
!        t1 = a(k,n)
!        t2 = a(k+1,n)
!        c = q(i)
!        s = q(i+1)
!        a(k,n) = c*t1 - s*t2
!        a(k+1,n) = s*t1 + c*t2
!100  continue
!     info = 0
!     t1 = a(n,n)
!     t2 = a(n+1,n)
!     if ( t2.eq.0.0d0 ) then
!        c = 1.0d0
!        s = 0.0d0
!     elseif( abs(t2).ge.abs(t1) ) then
!        t = t1/t2
!        s = -1.0d0/dsqrt(1.0d0+t*t)
!        c = -s*t
!     else
!        t = t2/t1
!        c = 1.0d0/dsqrt(1.0d0+t*t)
!        s = -c*t
!     endif
!     iq = 2*n - 1
!     q(iq) = c
!     q(iq+1) = s
!     a(n,n) = c*t1 - s*t2
!     if (a(n,n) .eq. 0.0d0) info = n
!     return
!     end

*deck dorth
      subroutine dorth(vnew, v, hes, n, ll, ldhes, kmp, snormw)
      implicit double precision(a-h,o-z)
      integer n, ll, ldhes, kmp
      double precision vnew, v, hes, snormw
      dimension vnew(1), v(n,1), hes(ldhes,1)
      integer i, i0
      double precision arg, sumdsq, tem, vnrm
      vnrm = dnrm2(n, vnew, 1)
      i0 = max0(1,ll-kmp+1)
      do 10 i = i0,ll
         hes(i,ll) = ddot(n, v(1,i), 1, vnew, 1)
         tem = -hes(i,ll)
         call daxpy(n, tem, v(1,i), 1, vnew, 1)
 10   continue
      snormw = dnrm2(n, vnew, 1)
      if (vnrm + 0.001d0*snormw .ne. vnrm) return
      sumdsq = 0.0d0
      do 30 i = i0,ll
         tem = -ddot(n, v(1,i), 1, vnew, 1)
         if (hes(i,ll) + 0.001d0*tem .eq. hes(i,ll)) go to 30
         hes(i,ll) = hes(i,ll) - tem
         call daxpy(n, tem, v(1,i), 1, vnew, 1)
         sumdsq = sumdsq + tem**2
 30   continue
      if (sumdsq .eq. 0.0d0) return
      arg = max(0.0d0,snormw**2 - sumdsq)
      snormw = dsqrt(arg)
      return
      end

*deck dpigmr
      subroutine dpigmr(n, r0, sr, sz, jscal, maxl, maxlp1, kmp, 
     $     nrsts, jpre, matvec, msolve, nmsl, z, v, hes, q, lgmr,
     $     rpar, ipar, wk, dl, rhol, nrmax, b, bnrm, x, xl,
     $     itol, tol, nelt, ia, ja, a, isym, iunit, iflag, err)
      implicit double precision(a-h,o-z)
      external matvec, msolve
      integer n,maxl,maxlp1,kmp,jpre,nmsl,lgmr,iflag,jscal,nrsts
      integer nrmax,itol,nelt,isym
      double precision rhol, bnrm, tol
      double precision r0(*), sr(*), sz(*), z(*), v(n,*)
      double precision hes(maxlp1,*), q(*), rpar(*), wk(*), dl(*)
      double precision a(nelt), b(*), x(*), xl(*)
      integer ipar(*), ia(nelt), ja(nelt)
      integer i, info, ip1, i2, j, k, ll, llp1
      double precision r0nrm,c,dlnrm,prod,rho,s,snormw,tem
      do 5 i = 1,n
         z(i) = 0.0d0
 5    continue
      iflag = 0
      lgmr = 0
      nmsl = 0
      itmax =(nrmax+1)*maxl
      if ((jpre .lt. 0) .and.(nrsts .eq. 0)) then
         call dcopy(n, r0, 1, wk, 1)
         call msolve(n, wk, r0, nelt, ia, ja, a, isym, rpar, ipar)
         nmsl = nmsl + 1
      endif
      if (((jscal.eq.2) .or.(jscal.eq.3)) .and.(nrsts.eq.0)) then
         do 10 i = 1,n
            v(i,1) = r0(i)*sr(i)
 10      continue
      else
         do 20 i = 1,n
            v(i,1) = r0(i)
 20      continue
      endif
      r0nrm = dnrm2(n, v, 1)
      iter = nrsts*maxl
      if (isdgmr(n, b, x, xl, nelt, ia, ja, a, isym, msolve,
     $    nmsl, itol, tol, itmax, iter, err, iunit, v(1,1), z, wk,
     $    rpar, ipar, r0nrm, bnrm, sr, sz, jscal,
     $    kmp, lgmr, maxl, maxlp1, v, q, snormw, prod, r0nrm,
     $    hes, jpre) .ne. 0) return
      tem = 1.0d0/r0nrm
      call dscal(n, tem, v(1,1), 1)
      do 50 j = 1,maxl
         do 40 i = 1,maxlp1
            hes(i,j) = 0.0d0
 40      continue
 50   continue
      prod = 1.0d0
      do 90 ll = 1,maxl
         lgmr = ll
        if ((jscal .eq. 1) .or.(jscal .eq. 3)) then
           do 60 i = 1,n
              wk(i) = v(i,ll)/sz(i)
 60        continue
        else
           call dcopy(n, v(1,ll), 1, wk, 1)
        endif
        if (jpre .gt. 0) then
           call msolve(n, wk, z, nelt, ia, ja, a, isym, rpar, ipar)
           nmsl = nmsl + 1
           call matvec(n, z, v(1,ll+1), nelt, ia, ja, a, isym)
        else
           call matvec(n, wk, v(1,ll+1), nelt, ia, ja, a, isym)
        endif
        if (jpre .lt. 0) then
           call dcopy(n, v(1,ll+1), 1, wk, 1)
           call msolve(n,wk,v(1,ll+1),nelt,ia,ja,a,isym,rpar,ipar)
           nmsl = nmsl + 1
        endif
        if ((jscal .eq. 2) .or.(jscal .eq. 3)) then
           do 65 i = 1,n
              v(i,ll+1) = v(i,ll+1)*sr(i)
 65        continue
        endif
        call dorth(v(1,ll+1), v, hes, n, ll, maxlp1, kmp, snormw)
        hes(ll+1,ll) = snormw
        call dheqr(hes, maxlp1, ll, q, info, ll)
        if (info .eq. ll) go to 120
        prod = prod*q(2*ll)
        rho = abs(prod*r0nrm)
        if ((ll.gt.kmp) .and.(kmp.lt.maxl)) then
           if (ll .eq. kmp+1) then
              call dcopy(n, v(1,1), 1, dl, 1)
              do 75 i = 1,kmp
                 ip1 = i + 1
                 i2 = i*2
                 s = q(i2)
                 c = q(i2-1)
                 do 70 k = 1,n
                    dl(k) = s*dl(k) + c*v(k,ip1)
 70              continue
 75           continue
           endif
           s = q(2*ll)
           c = q(2*ll-1)/snormw
           llp1 = ll + 1
           do 80 k = 1,n
              dl(k) = s*dl(k) + c*v(k,llp1)
 80        continue
           dlnrm = dnrm2(n, dl, 1)
           rho = rho*dlnrm
        endif
        rhol = rho
        iter = nrsts*maxl + lgmr
        if (isdgmr(n, b, x, xl, nelt, ia, ja, a, isym, msolve,
     $      nmsl, itol, tol, itmax, iter, err, iunit, dl, z, wk,
     $      rpar, ipar, rhol, bnrm, sr, sz, jscal,
     $      kmp, lgmr, maxl, maxlp1, v, q, snormw, prod, r0nrm,
     $      hes, jpre) .ne. 0) go to 200
        if (ll .eq. maxl) go to 100
        tem = 1.0d0/snormw
        call dscal(n, tem, v(1,ll+1), 1)
 90   continue
 100  continue
      if (rho .lt. r0nrm) go to 150
 120  continue
      iflag = 2
      do 130 i = 1,n
         z(i) = 0.d0
 130  continue
      return
 150  iflag = 1
      if (nrmax .gt. 0) then
         call drlcal(n, kmp, maxl, maxl, v, q, dl, snormw, prod,
     $        r0nrm)
      endif
 200  continue
      ll = lgmr
      llp1 = ll + 1
      do 210 k = 1,llp1
         r0(k) = 0.0d0
 210  continue
      r0(1) = r0nrm
      call dhels(hes, maxlp1, ll, q, r0)
      do 220 k = 1,n
         z(k) = 0.0d0
 220  continue
      do 230 i = 1,ll
         call daxpy(n, r0(i), v(1,i), 1, z, 1)
 230  continue
      if ((jscal .eq. 1) .or.(jscal .eq. 3)) then
         do 240 i = 1,n
            z(i) = z(i)/sz(i)
 240     continue
      endif
      if (jpre .gt. 0) then
         call dcopy(n, z, 1, wk, 1)
         call msolve(n, wk, z, nelt, ia, ja, a, isym, rpar, ipar)
         nmsl = nmsl + 1
      endif
      return
      end

*deck drlcal
      subroutine drlcal(n, kmp, ll, maxl, v, q, rl, snormw, prod,
     $     r0nrm)
      implicit double precision(a-h,o-z)
      integer n, kmp, ll, maxl
      double precision snormw
      double precision v(n,*), q(*), rl(n)
      integer i, ip1, i2, k
      if (kmp .eq. maxl) then
         call dcopy(n, v(1,1), 1, rl, 1)
         llm1 = ll - 1
         do 20 i = 1,llm1
            ip1 = i + 1
            i2 = i*2
            s = q(i2)
            c = q(i2-1)
            do 10 k = 1,n
               rl(k) = s*rl(k) + c*v(k,ip1)
 10         continue
 20      continue
         s = q(2*ll)
         c = q(2*ll-1)/snormw
         llp1 = ll + 1
         do 30 k = 1,n
            rl(k) = s*rl(k) + c*v(k,llp1)
 30      continue
      endif
      tem = r0nrm*prod
      call dscal(n, tem, rl, 1)
      return
      end

*deck dxlcal
      subroutine dxlcal(n, lgmr, x, xl, zl, hes, maxlp1, q, v, r0nrm,
     $     wk, sz, jscal, jpre, msolve, nmsl, rpar, ipar,
     $     nelt, ia, ja, a, isym)
      implicit double precision(a-h,o-z)
      external msolve
      integer n, lgmr, maxlp1, jscal, jpre, ipar(*), nmsl, nelt
      integer ia(nelt), ja(nelt), isym
      double precision r0nrm, x(n), xl(n), zl(n), hes(maxlp1,*)
      double precision q(*), v(n,*), wk(n), sz(*), rpar(*), a(nelt)
      integer i, k, ll, llp1
      ll = lgmr
      llp1 = ll + 1
      do 10 k = 1,llp1
         wk(k) = 0.0d0
 10   continue
      wk(1) = r0nrm
      call dhels(hes, maxlp1, ll, q, wk)
      do 20 k = 1,n
         zl(k) = 0.0d0
 20   continue
      do 30 i = 1,ll
         call daxpy(n, wk(i), v(1,i), 1, zl, 1)
 30   continue
      if ((jscal .eq. 1) .or.(jscal .eq. 3)) then
         do 40 k = 1,n
            zl(k) = zl(k)/sz(k)
 40      continue
      endif
      if (jpre .gt. 0) then
         call dcopy(n, zl, 1, wk, 1)
         call msolve(n, wk, zl, nelt, ia, ja, a, isym, rpar, ipar)
         nmsl = nmsl + 1
      endif
      do 50 k = 1,n
         xl(k) = x(k) + zl(k)
 50   continue
      return
      end

*deck isdgmr
      function isdgmr(n, b, x, xl, nelt, ia, ja, a, isym, msolve,
     $     nmsl, itol, tol, itmax, iter, err, iunit, r, z, dz,
     $     rwork, iwork, rnrm, bnrm, sb, sx, jscal,
     $     kmp, lgmr, maxl, maxlp1, v, q, snormw, prod, r0nrm,
     $     hes, jpre)
      implicit double precision(a-h,o-z)
      integer kmp, lgmr, maxl, maxlp1, jpre, nmsl
      double precision dxnrm, rnrm, r0nrm, snormw, solnrm, prod
      double precision b(*), x(*), ia(*), ja(*), a(*), r(*), z(*), dz(*)
      double precision rwork(*), iwork(*), sb(*), sx(*), q(*), v(n,*)
      double precision hes(maxlp1,maxl), xl(*)
      external msolve
      parameter(maxn=441)
      common /solblk/ soln(maxn)
      save solnrm
      isdgmr = 0
      if ( itol.eq.0 ) then
         err = rnrm/bnrm
      endif
      if ( (itol.gt.0) .and. (itol.le.3) ) then
         if ( lgmr.ne.0 ) call drlcal(n, kmp, lgmr, maxl, v, q, r,
     $                                snormw, prod, r0nrm)
         if ( itol.le.2 ) then
            err = dnrm2(n, r, 1)/bnrm
            if ( (kmp.lt.maxl) .and. (lgmr.ne.0) ) then
               tem = 1.0d0/(r0nrm*prod)
               call dscal(n, tem, r, 1)
            endif
         elseif ( itol.eq.3 ) then
            if ( jpre.gt.0 ) then
               call msolve(n, r, dz, nelt, ia, ja, a, isym, rwork,
     $              iwork)
               nmsl = nmsl + 1
            endif
            if ( (kmp.lt.maxl) .and. (lgmr.ne.0) ) then
               tem = 1.0d0/(r0nrm*prod)
               call dscal(n, tem, r, 1)
            endif
            fuzz = d1mach(1)
            ielmax = 1
            ratmax = abs(dz(1))/max(abs(x(1)),fuzz)
            do 25 i = 2, n
               rat = abs(dz(i))/max(abs(x(i)),fuzz)
               if( rat.gt.ratmax ) then
                  ielmax = i
                  ratmax = rat
               endif
 25         continue
            err = ratmax
            if( ratmax.le.tol ) isdgmr = 1
            if( iunit.gt.0 ) write(iunit,1020) iter, ielmax, ratmax
            return
         endif
      endif
      if ( itol.eq.11 ) then
         if ( (lgmr.ne.0) .and. (iter.gt.0) ) then
            call dxlcal(n, lgmr, x, xl, xl, hes, maxlp1, q, v, r0nrm,
     $           dz, sx, jscal, jpre, msolve, nmsl, rwork, iwork,
     $           nelt, ia, ja, a, isym)
         elseif ( iter.eq.0 ) then
            call dcopy(n, x, 1, xl, 1)
         else
            return
         endif
         if ((jscal .eq. 0) .or.(jscal .eq. 2)) then
            if ( iter.eq.0 ) solnrm = dnrm2(n, soln, 1)
            do 30 i = 1, n
               dz(i) = xl(i) - soln(i)
 30         continue
            err = dnrm2(n, dz, 1)/solnrm
         else
            if (iter .eq. 0) then
               solnrm = 0.d0
               do 40 i = 1,n
                  solnrm = solnrm + (sx(i)*soln(i))**2
 40            continue
               solnrm = dsqrt(solnrm)
            endif
            dxnrm = 0.d0
            do 50 i = 1,n
               dxnrm = dxnrm + (sx(i)*(xl(i)-soln(i)))**2
 50         continue
            dxnrm = dsqrt(dxnrm)
            err = dxnrm/solnrm
         endif
      endif
      if( iunit.ne.0 ) then
         if( iter.eq.0 ) then
            write(iunit,1000) n, itol, maxl, kmp
         endif
         write(iunit,1010) iter, rnrm/bnrm, err
      endif
      if ( err.le.tol ) isdgmr = 1
      return
 1000 format(' generalized minimum residual(',i3,i3,') for ',
     $     'n, itol = ',i5, i5,
     $     /' iter','   natral err est','   error estimate')
 1010 format(1x,i4,1x,e16.7,1x,e16.7)
 1020 format(1x,' iter = ',i5, ' ielmax = ',i5,
     $     ' |r(ielmax)/x(ielmax)| = ',e12.5)
      end

*deck dir
      subroutine dir(n, b, x, nelt, ia, ja, a, isym, matvec, msolve, 
     $     itol, tol, itmax, iter, err, ierr, iunit, r, z, dz,
     $     rwork, iwork)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym
      integer itol, itmax, iter, ierr, iunit, iwork(*)
      double precision b(n), x(n), a(nelt), tol, err, r(n), z(n)
      double precision dz(n), rwork(*)
      external msolve, matvec, isdir
      iter = 0
      ierr = 0
      if( n.lt.1 ) then
         ierr = 3
         return
      endif
      tolmin = 500.0*d1mach(3)
      if( tol.lt.tolmin ) then
         tol = tolmin
         ierr = 4
      endif
      call matvec(n, x, r, nelt, ia, ja, a, isym)
      do 10 i = 1, n
         r(i) = b(i) - r(i)
 10   continue
      call msolve(n, r, z, nelt, ia, ja, a, isym, rwork, iwork)
      if( isdir(n, b, x, nelt, ia, ja, a, isym, msolve, itol, tol,
     $     itmax, iter, err, ierr, iunit, r, z, dz, rwork,
     $     iwork, bnrm, solnrm) .ne. 0 ) go to 200
      if( ierr.ne.0 ) return
      do 100 k=1,itmax
         iter = k
         do 20 i = 1, n
            x(i) = x(i) + z(i)
 20      continue
         call matvec(n, x, r, nelt, ia, ja, a, isym)
         do 30 i = 1, n
            r(i) = b(i) - r(i)
 30      continue
         call msolve(n, r, z, nelt, ia, ja, a, isym, rwork, iwork)
         if( isdir(n, b, x, nelt, ia, ja, a, isym, msolve, itol, tol,
     $        itmax, iter, err, ierr, iunit, r, z, dz, rwork,
     $        iwork, bnrm, solnrm) .ne. 0 ) go to 200
 100  continue
      iter = itmax + 1
      ierr = 2
 200  return
      end

*deck dsjac
      subroutine dsjac(n, b, x, nelt, ia, ja, a, isym, itol, tol, 
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax
      integer iter, iunit, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(nelt), rwork(lenw)
      external dsmv, dsdi
      parameter(locrb=1,locib=11)
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      lociw = locib
      locd = locrb
      locr = locd + n
      locz = locr + n
      locdz = locz + n
      locw = locdz + n
      call dchkw( 'dsjac', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(4) = locd
      iwork(9) = lociw
      iwork(10) = locw
      call ds2y(n, nelt, ia, ja, a, isym )
      call dsds(n, nelt, ia, ja, a, isym, rwork(locd))
      call dir(n, b, x, nelt, ia, ja, a, isym, dsmv, dsdi, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork(locr), rwork(locz), 
     $     rwork(locdz), rwork, iwork )
      return
      end

*deck dsgs
      subroutine dsgs(n, b, x, nelt, ia, ja, a, isym, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax
      integer iter, iunit, iwork(10)
      double precision b(n), x(n), a(n), tol, err, rwork(1)
      external dsmv, dsli
      parameter(locrb=1,locib=11)
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      if( isym.eq.0 ) then
         nel = 0
         do 20 icol = 1, n
            jbgn = ja(icol)
            jend = ja(icol+1)-1
            do 10 j = jbgn, jend
               if( ia(j).ge.icol ) nel = nel + 1
 10         continue
 20      continue
      else
         nel = ja(n+1)-1
      endif
      locjel = locib
      lociel = locjel + n+1
      lociw = lociel + nel
      locel = locrb
      locr = locel + nel
      locz = locr + n
      locdz = locz + n
      locw = locdz + n
      call dchkw( 'dsgs', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(1) = nel
      iwork(2) = lociel
      iwork(3) = locjel
      iwork(4) = locel
      iwork(9) = lociw
      iwork(10) = locw
      call ds2lt( n, nelt, ia, ja, a, isym, nel, iwork(lociel),
     $     iwork(locjel), rwork(locel) )
      call dir(n, b, x, nelt, ia, ja, a, isym, dsmv, dsli, 
     $     itol, tol, itmax, iter, err, ierr, iunit, rwork(locr),
     $     rwork(locz), rwork(locdz), rwork, iwork )
      iwork(9) = lociw+n+nelt
      iwork(10) = locw+nelt
      return
      end

*deck dsilur
      subroutine dsilur(n, b, x, nelt, ia, ja, a, isym, itol, tol,
     $     itmax, iter, err, ierr, iunit, rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer ierr, iunit, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(nelt), tol, err, rwork(lenw)
      parameter (locrb=1, locib=11)
      external dsmv, dslui
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      nl = 0
      nu = 0
      do 20 icol = 1, n
         jbgn = ja(icol)+1
         jend = ja(icol+1)-1
         if( jbgn.le.jend ) then
            do 10 j = jbgn, jend
               if( ia(j).gt.icol ) then
                  nl = nl + 1
                  if( isym.ne.0 ) nu = nu + 1
               else
                  nu = nu + 1
               endif
 10         continue
         endif
 20   continue
      locil = locib
      locjl = locil + n+1
      lociu = locjl + nl
      locju = lociu + nu
      locnr = locju + n+1
      locnc = locnr + n
      lociw = locnc + n
      locl = locrb
      locdin = locl + nl
      locu = locdin + n
      locr = locu + nu
      locz = locr + n
      locdz = locz + n
      locw = locdz + n
      call dchkw( 'dsilur', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(1) = locil
      iwork(2) = locjl
      iwork(3) = lociu
      iwork(4) = locju
      iwork(5) = locl
      iwork(6) = locdin
      iwork(7) = locu
      iwork(9) = lociw
      iwork(10) = locw
      call dsilus( n, nelt, ia, ja, a, isym, nl, iwork(locil),
     $     iwork(locjl), rwork(locl), rwork(locdin), nu, iwork(lociu),
     $     iwork(locju), rwork(locu), iwork(locnr), iwork(locnc) )
      call dir(n, b, x, nelt, ia, ja, a, isym, dsmv, dslui, 
     $     itol, tol, itmax, iter, err, ierr, iunit, rwork(locr),
     $     rwork(locz), rwork(locdz), rwork, iwork)
      return
      end

*deck isdir
      function isdir(n, b, x, nelt, ia, ja, a, isym, msolve, itol, tol,
     $     itmax, iter, err, ierr, iunit, r, z, dz, rwork, iwork,
     $     bnrm, solnrm)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, itol, itmax, iter
      integer iunit, iwork(*)
      double precision b(n), x(n), a(nelt), r(n), z(n), dz(n), rwork(*)
      external msolve
      parameter(maxn=441)
      common /solblk/ soln(maxn)
      isdir = 0
      if( itol.eq.1 ) then
         if(iter .eq. 0) bnrm = dnrm2(n, b, 1)
         err = dnrm2(n, r, 1)/bnrm
      else if( itol.eq.2 ) then
         if(iter .eq. 0) then
            call msolve(n, b, dz, nelt, ia, ja, a, isym, rwork, iwork)
            bnrm = dnrm2(n, dz, 1)
         endif
         err = dnrm2(n, z, 1)/bnrm
      else if( itol.eq.11 ) then
         if( iter.eq.0 ) solnrm = dnrm2(n, soln, 1)
         do 10 i = 1, n
            dz(i) = x(i) - soln(i)
 10      continue
         err = dnrm2(n, dz, 1)/solnrm
      else
         err = 1.0e10
         ierr = 3
      endif
      if( iunit.ne.0 ) then
         write(iunit,1000) iter,err
      endif
      if( err.le.tol ) isdir = 1
      return
 1000 format(5x,'iter = ',i4,' error estimate = ',e16.7)
      end

*deck dlpdoc
      subroutine dlpdoc
      return
      end

      program dlapqc
      parameter(maxn=441, mxnelt=50000, maxiw=50000, maxrw=50000)
      implicit double precision(a-h,o-z)
      character*72     mesg
      double precision a(mxnelt), f(maxn), xiter(maxn), rwork(maxrw)
      integer          ia(mxnelt), ja(mxnelt), iwork(maxiw)
      common /solblk/ soln(maxn)
      istdi = i1mach(1)
      istdo = i1mach(2)
      nfail = 0
      read(istdi,990) kprint
  990 format(i1)
      call xsetun(lun)
      if( kprint.le.1 ) then
         call xsetf(0)
      else
         call xsetf(1)
      endif
      call xermax(1000)
      neltmx = mxnelt
      nmax   = maxn
      leniw  = maxiw
      lenw   = maxrw
      n      = nmax
      itmax  = n
      iout   = kprint
      factor = 1.2
      if( iout.lt.3 ) then
         iunit = 0
      else
         iunit = istdo
      endif
      tol = max(1.0d3*d1mach(3),1.0d-6)
      do 10 kase = 3, 3
         if(kase .eq. 1 .or. kase .eq. 2) itol = kase
         if(kase .eq. 3) itol = 11
         do 20 isym = 0, 1
            call drmgen( neltmx, factor, ierr, n, nelt, 
     $           isym, ia, ja, a, f, soln, rwork, iwork, iwork(n+1) )
            if( ierr.ne.0 ) then
               mesg = 'dlapqc -- fatal error (i1) generating '//
     $              '*random* matrix.'
               call xerrwv( mesg,len(mesg),ierr,2,1,ierr,0,
     $              0,0.0,0.0 )
            endif
            if( isym.eq.0 ) then
               dens = float(nelt)/float(n*n)
            else
               dens = float(2*nelt)/float(n*n)
            endif
            if( iout.ge.2 ) then
              write(istdo,1020) n, nelt, dens
              write(istdo,1030) tol
            endif
            call ds2y( n, nelt, ia, ja, a, isym )
            if( iout.ge.4 ) then
               write(istdo,1040) (k,ia(k),ja(k),a(k),k=1,nelt)
               call dcpplt( n, nelt, ia, ja, a, isym, istdo )
            endif
            if( iout.ge.3 ) then
              write(istdo,1000) 'dsjac ', itol, isym
            endif
            call dfill( n, xiter, 0.0d0 )
            call dsjac(n, f, xiter, nelt, ia, ja, a, isym,
     $           itol, tol, 2*itmax, iter, err, ierr, iunit,
     $           rwork, lenw, iwork, leniw )
            call duterr( 'dsjac ',ierr,iout,nfail,istdo,iter,err )
            if( iout.ge.3 ) then
              write(istdo,1000) 'dsgs  ',itol,isym
            endif
            call dfill( n, xiter, 0.0d0 )
            call dsgs(n, f, xiter, nelt, ia, ja, a, isym,
     $           itol, tol, itmax, iter, err, ierr, iunit,
     $           rwork, lenw, iwork, leniw )
            call duterr( 'dsgs  ',ierr,iout,nfail,istdo,iter,err )
            if( iout.ge.3 ) then
              write(istdo,1000) 'dsilur',itol,isym
            endif
            call dfill( n, xiter, 0.0d0 )
            call dsilur(n, f, xiter, nelt, ia, ja, a, isym,
     $           itol, tol, itmax, iter, err, ierr, iunit,
     $           rwork, lenw, iwork, leniw )
            call duterr( 'dsilur',ierr,iout,nfail,istdo,iter,err )
            if( isym.eq.1 ) then
               if( iout.ge.3 ) then
                  write(istdo,1000) 'dsdcg',itol,isym
               endif
               call dfill( n, xiter, 0.0d0 )
               call dsdcg(n, f, xiter, nelt, ia, ja, a, isym, 
     $              itol, tol, itmax, iter, err, ierr, iunit,
     $              rwork, lenw, iwork, leniw )
               call duterr( 'dsdcg ',ierr,iout,nfail,istdo,iter,err )
            endif
            if( isym.eq.1 ) then
               if( iout.ge.3 ) then
                  write(istdo,1000) 'dsiccg',itol,isym
               endif
               call dfill( n, xiter, 0.0d0 )
               call dsiccg(n, f, xiter, nelt, ia, ja, a, isym, 
     $              itol, tol, itmax, iter, err, ierr, iunit, rwork, 
     $              lenw, iwork, leniw )
               call duterr( 'dsiccg',ierr,iout,nfail,istdo,iter,err )
            endif
            if( iout.ge.3 ) then
               write(istdo,1000) 'dsdcgn',itol,isym
            endif
            call dfill( n, xiter, 0.0d0 )
            call dsdcgn(n, f, xiter, nelt, ia, ja, a, isym, itol,
     $           tol, itmax, iter, err, ierr, iunit, rwork, lenw,
     $           iwork, leniw )
            call duterr( 'dsdcgn',ierr,iout,nfail,istdo,iter,err )
            if( iout.ge.3 ) then 
               write(istdo,1000) 'dslucn',itol,isym
            endif
            call dfill( n, xiter, 0.0d0 )
            call dslucn(n, f, xiter, nelt, ia, ja, a, isym, itol,
     $           tol, itmax, iter, err, ierr, iunit, rwork, lenw,
     $           iwork, leniw )
            call duterr( 'dslucn',ierr,iout,nfail,istdo,iter,err )
            if( iout.ge.3 ) then
               write(istdo,1000) 'dsdbcg',itol,isym
            endif
            call dfill( n, xiter, 0.0d0 )
            call dsdbcg(n, f, xiter, nelt, ia, ja, a, isym, itol,
     $           tol, itmax, iter, err, ierr, iunit, rwork, lenw,
     $           iwork, leniw )
            call duterr( 'dsdbcg',ierr,iout,nfail,istdo,iter,err )
            if( iout.ge.3 ) then
               write(istdo,1000) 'dslubc',itol,isym
            endif
            call dfill( n, xiter, 0.0d0 )
            call dslubc(n, f, xiter, nelt, ia, ja, a, isym, 
     $           itol, tol, itmax, iter, err, ierr, iunit, 
     $           rwork, lenw, iwork, leniw )
            call duterr( 'dslubc',ierr,iout,nfail,istdo,iter,err )
            if( iout.ge.3 ) then
               write(istdo,1000) 'dsdcgs',itol,isym
            endif
            call dfill( n, xiter, 0.0d0 )
            call dsdcgs(n, f, xiter, nelt, ia, ja, a, isym, itol,
     $           tol, itmax, iter, err, ierr, iunit, rwork, lenw,
     $           iwork, leniw )
            call duterr( 'dsdcgs',ierr,iout,nfail,istdo,iter,err )
            if( iout.ge.3 ) then
               write(istdo,1000) 'dslucs',itol,isym
            endif
            call dfill( n, xiter, 0.0d0 )
            call dslucs(n, f, xiter, nelt, ia, ja, a, isym, 
     $           itol, tol, itmax, iter, err, ierr, iunit, 
     $           rwork, lenw, iwork, leniw )
            call duterr( 'dslucs',ierr,iout,nfail,istdo,iter,err )
            do 30 nsave = 0, 3
               if( iout.ge.3 ) then
                  write(istdo,1010) 'dsdomn',itol, isym, nsave
               endif
               call dfill( n, xiter, 0.0d0 )
               call dsdomn(n, f, xiter, nelt, ia, ja, a,
     $              isym, nsave, itol, tol, itmax, iter, err, ierr, 
     $              iunit, rwork, lenw, iwork, leniw )
               call duterr( 'dsdomn',ierr,iout,nfail,istdo,iter,err )
 30         continue
            do 40 nsave=0,3
               if( iout.ge.3 ) then
                  write(istdo,1010) 'dsluom',itol, isym, nsave
               endif
               call dfill( n, xiter, 0.0d0 )
               call dsluom(n, f, xiter, nelt, ia, ja, a,
     $              isym, nsave, itol, tol, itmax, iter, err, ierr, 
     $              iunit, rwork, lenw, iwork, leniw )
               call duterr( 'dsluom',ierr,iout,nfail,istdo,iter,err )
 40         continue
            do 50 nsave = 5, 12
               if( iout.ge.3 ) then
                  write(istdo,1010) 'dsdgmr',itol, isym, nsave
               endif
               call dfill( n, xiter, 0.0d0 )
               itolgm = 0
               call dsdgmr(n, f, xiter, nelt, ia, ja, a,
     $              isym, nsave, itolgm, tol, itmax, iter, err, ierr, 
     $              iunit, rwork, lenw, iwork, leniw )
               call duterr( 'dsdgmr',ierr,iout,nfail,istdo,iter,err )
 50         continue
            do 60 nsave = 5, 12
               if( iout.ge.3 ) then
                  write(istdo,1010) 'dslugm',itol, isym, nsave
               endif
               call dfill( n, xiter, 0.0d0 )
               call dslugm(n, f, xiter, nelt, ia, ja, a,
     $              isym, nsave, itol, tol, itmax, iter, err, ierr, 
     $              iunit, rwork, lenw, iwork, leniw )
               call duterr( 'dslugm',ierr,iout,nfail,istdo,iter,err )
 60         continue
 20      continue
 10   continue
      if( nfail.eq.0 ) then
         write(istdo,1050)
      else
         write(istdo,1060) nfail
      endif
      stop 'all done'
 1000 format(/1x,a6,' : itol = ',i2,'   isym = ',i1)
 1010 format(/1x,a6,' : itol = ',i2,'   isym = ',i1,' nsave = ',i2) 
 1020 format(/'                * random matrix of size',i5,'*'
     $     /'                ',
     $     'number of non-zeros & density = ', i5,e16.7)
 1030 format('                error tolerance = ',e16.7) 
 1040 format(/'  ***** slap column matrix *****'/
     $        ' indx   ia   ja     a'/(1x,i4,1x,i4,1x,i4,1x,e16.7))
 1050 format(//
     $     '*******************************************************'/
     $     '**** all slap double precision quick checks passed ****'/
     $     '****                 no errors                     ****'/
     $     '*******************************************************')
 1060 format(//
     $     '************************************************'/
     $     '**     ===>',i3,' failures detected <===      **'/
     $     '**     slap double precision quick checks     **'/
     $     '** set kprint = 3 for debug information and   **'/
     $     '** rerun the tests to determine the problem.  **'/
     $     '************************************************')
      end

*deck duterr
      subroutine duterr( method, ierr, iout, nfail, istdo, iter, err )
      implicit double precision(a-h,o-z)
      character*6 method
      integer ierr, iout, nfail, istdo, iter
      double precision err
      if( ierr.ne.0 ) nfail = nfail+1    
      if( iout.eq.1 .and. ierr.ne.0 ) then
         write(istdo,1000) method
      endif
      if( iout.eq.2 ) then
         if( ierr.eq.0 ) then
            write(istdo,1010) method
         else
            write(istdo,1020) method,ierr,iter,err
         endif
      endif
      if( iout.ge.3 ) then
         if( ierr.eq.0 ) then
            write(istdo,1030) method,ierr,iter,err
         else
            write(istdo,1020) method,ierr,iter,err
         endif
      endif
      return
 1000 format( 1x,a6,' : **** failure ****')
 1010 format( 1x,a6,' : **** passed  ****')
 1020 format(' **************** warning ***********************'/
     $       ' **** ',a6,' quick test failed: ierr = ',i5,' ****'/
     $       ' **************** warning ***********************'/
     $       ' iteration count = ',i3,' stop test = ',e12.6)
 1030 format(' ***************** passed ***********************'/
     $       ' **** ',a6,' quick test passed: ierr = ',i5,' ****'/
     $       ' ***************** passed ***********************'/
     $       ' iteration count = ',i3,' stop test = ',e12.6)
      end

*deck drmgen
      subroutine drmgen( neltmx, factor, ierr, n, nelt, isym, 
     $     ia, ja, a, f, soln, dsum, itmp, idiag )
      implicit double precision(a-h,o-z)
      integer neltmx, ierr, n, nelt, isym
      integer ia(neltmx), ja(neltmx)
      integer itmp(n), idiag(n)
      double precision factor, a(neltmx)
      double precision f(n), soln(n), dsum(n)
      real rand, dummy
      dummy = 16381.0
      iseed = rand( dummy )
      ierr = 0
      do 10 i = 1, n
         idiag(i) = 0
         dsum(i) = -1.0
 10   continue
      dummy = 0.0
      nelt = 0
      do 30 icol = 1, n
         nl = n+1-icol
         inum = (ifix( rand(dummy)*nl ) + 1)/3
         call dmpl( nl, inum, itmp )
         do 20 irow = 1, inum
            nelt = nelt + 1
            if( nelt.gt.neltmx ) then
               ierr = 1
               return
            endif
            ia(nelt) = n+1-itmp(irow)
            ja(nelt) = icol
            if( ia(nelt).eq.icol ) then
               idiag(icol) = nelt
            else
               a(nelt) = -rand(dummy)
               dsum(icol) = dsum(icol) + a(nelt)
               if( isym.eq.0 ) then
                  nelt = nelt + 1
                  if( nelt.gt.neltmx ) then
                     ierr = 1
                     return
                  endif
                  ia(nelt) = icol
                  ja(nelt) = ia(nelt-1)
                  a(nelt)  = a(nelt-1)*factor
                  dsum(ja(nelt)) = dsum(ja(nelt)) + a(nelt)
               else
                  dsum(ia(nelt)) = dsum(ia(nelt)) + a(nelt)
               endif
            endif
 20      continue
         if( idiag(icol).eq.0 ) then
            nelt = nelt + 1
            if( nelt.gt.neltmx ) then
               ierr = 1
               return
            endif
            idiag(icol) = nelt
            a(nelt) = 0.0d0
            ia(nelt) = icol
            ja(nelt) = icol
         endif
 30   continue
      do 40 i = 1, n
         a(idiag(i)) = -1.0001*dsum(i)
 40   continue
      do 50 i = 1, n
         soln(i) = rand(dummy)
         f(i) = 0.0d0
 50   continue
      do 60 k = 1, nelt
         f(ia(k)) = f(ia(k)) + a(k)*soln(ja(k))
         if( isym.ne.0 .and. ia(k).ne.ja(k) ) then
            f(ja(k)) = f(ja(k)) + a(k)*soln(ia(k))
         endif
 60   continue
      return
      end

*deck dmpl
      subroutine dmpl( n, m, indx )
      implicit double precision(a-h,o-z)
      real rand, dummy
      integer n, m, indx(m)
      dummy = 0.0
      if( n*m.lt.0 .or. m.gt.n ) return
      indx(1) = ifix( rand(dummy)*n ) + 1
      do 30 i = 2, m
 10      id = ifix( rand(dummy)*n ) + 1
         do 20 j = 1, i-1
            if( id.eq.indx(j) ) goto 10
 20      continue
         indx(i) = id
 30   continue
      return
      end

*deck dfill
      subroutine dfill (n,v,val)
      implicit double precision(a-h,o-z)
      integer n
      double precision v(*), val
      if (n .le. 0) return
      nr=mod(n,4)
      is=1
      goto(1,2,3,4), nr+1
    4   is=4
        v(1)=val
        v(2)=val
        v(3)=val
        goto 1
    3   is=3
        v(1)=val
        v(2)=val
        goto 1
    2   is=2
        v(1)=val
    1 do 10 i=is,n,4
        v(i)  =val
        v(i+1)=val
        v(i+2)=val
        v(i+3)=val
 10   continue
      return
      end

*deck dbhin
      subroutine dbhin( n, nelt, ia, ja, a, isym, soln, rhs,
     $     iunit, job )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, job
      double precision a(nelt), rhs(n), soln(n)
      character*80  title
      character*3   code
      character*16  pntfmt, rinfmt
      character*20  nvlfmt, rhsfmt
      integer nline, npls, nrils, nnvls, nrhsls, nrow, ncol, nind, nele
      read(iunit,9000) title
      read(iunit,9010) nline, npls, nrils, nnvls, nrhsls
      read(iunit,9020) code, nrow, ncol, nind, nele
      read(iunit,9030) pntfmt, rinfmt, nvlfmt, rhsfmt
      if( nrow.gt.n ) then
         n = nrow
         jobret = -1
         goto 999
      endif
      if( nind.gt.nelt ) then
         nelt = nind
         jobret = -2
         goto 999
      endif
      n    = nrow
      nelt = nind
      if( code.eq.'rua' ) then
         isym = 0
      else if( code.eq.'rsa' ) then
         isym = 1
      else
         jobret = -3
         goto 999
      endif
      read(iunit,pntfmt) (ja(i), i = 1, n+1)
      read(iunit,rinfmt) (ia(i), i = 1, nelt)
      jobret = 10
      if( nnvls.gt.0 ) then
         read(iunit,nvlfmt) (a(i),  i = 1, nelt)
         jobret = 0
      endif
      if( nrhsls.gt.0 .and. mod(job,2).eq.1 ) then
         read(5,rhsfmt) (rhs(i), i = 1, n)
         jobret = jobret + 1
      endif
      do 70 icol = 1, n
         ibgn = ja(icol)
         iend = ja(icol+1)-1
         do 30 i = ibgn, iend
            if( ia(i).eq.icol ) then
               itemp = ia(i)
               ia(i) = ia(ibgn)
               ia(ibgn) = itemp
               temp = a(i)
               a(i) = a(ibgn)
               a(ibgn) = temp
               goto 40
            endif
 30      continue
 40      ibgn = ibgn + 1
         if( ibgn.lt.iend ) then
            do 60 i = ibgn, iend
               do 50 j = i+1, iend
                  if( ia(i).gt.ia(j) ) then
                     itemp = ia(i)
                     ia(i) = ia(j)
                     ia(j) = itemp
                     temp = a(i)
                     a(i) = a(j)
                     a(j) = temp
                  endif
 50            continue
 60         continue
         endif
 70   continue
 999  job = jobret
      return
 9000 format( a80 )
 9010 format( 5i14 )
 9020 format( a3, 11x, 4i14 )
 9030 format( 2a16, 2a20 )
      end

*deck dchkw
      subroutine dchkw( name, lociw, leniw, locw, lenw,
     $     ierr, iter, err )
      implicit double precision(a-h,o-z)
      character*(*) name
      character*72 mesg
      integer lociw, leniw, locw, lenw, ierr, iter
      double precision err, d1mach
      external d1mach, xerrwv
      ierr = 0
      if( lociw.gt.leniw ) then
         ierr = 1
         iter = 0
         err = d1mach(2)
         mesg = name // ': integer work array too short. '//
     $        ' iwork needs i1: have allocated i2.'
         call xerrwv( mesg, len(mesg), 1, 1, 2, lociw, leniw,
     $        0, 0.0, 0.0 )
      endif
      if( locw.gt.lenw ) then
         ierr = 1
         iter = 0
         err = d1mach(2)
         mesg = name // ': double precision work array too short. '//
     $        ' rwork needs i1: have allocated i2.'
         call xerrwv( mesg, len(mesg), 1, 1, 2, locw, lenw,
     $        0, 0.0, 0.0 )
      endif
      return
      end

*deck qs2i1d
      subroutine qs2i1d( ia, ja, a, n, kflag )
      implicit double precision(a-h,o-z)
      dimension il(21),iu(21)
      integer   ia(n),ja(n),it,iit,jt,jjt
      double precision a(n), ta, tta
      nn = n
      if (nn.lt.1) then
         call xerror ( 'qs2i1d- the number of values to be sorted was no
     $t positive.',59,1,1)
         return
      endif
      if( n.eq.1 ) return
      kk = iabs(kflag)
      if ( kk.ne.1 ) then
         call xerror ( 'qs2i1d- the sort control parameter, k, was not 1
     $ or -1.',55,2,1)
         return
      endif
      if( kflag.lt.1 ) then
         do 20 i=1,nn
            ia(i) = -ia(i)
 20      continue
      endif
      m = 1
      i = 1
      j = nn
      r = .375
 210  if( r.le.0.5898437 ) then
         r = r + 3.90625e-2
      else
         r = r-.21875
      endif
 225  k = i
      ij = i + idint( dble(j-i)*r )
      it = ia(ij)
      jt = ja(ij)
      ta = a(ij)
      if( ia(i).gt.it ) then
         ia(ij) = ia(i)
         ia(i)  = it
         it     = ia(ij)
         ja(ij) = ja(i)
         ja(i)  = jt
         jt     = ja(ij)
         a(ij)  = a(i)
         a(i)   = ta
         ta     = a(ij)
      endif
      l=j
      if( ia(j).lt.it ) then
         ia(ij) = ia(j)
         ia(j)  = it
         it     = ia(ij)
         ja(ij) = ja(j)
         ja(j)  = jt
         jt     = ja(ij)
         a(ij)  = a(j)
         a(j)   = ta
         ta     = a(ij)
         if ( ia(i).gt.it ) then
            ia(ij) = ia(i)
            ia(i)  = it
            it     = ia(ij)
            ja(ij) = ja(i)
            ja(i)  = jt
            jt     = ja(ij)
            a(ij)  = a(i)
            a(i)   = ta
            ta     = a(ij)
         endif
      endif
  240 l=l-1
      if( ia(l).gt.it ) go to 240
  245 k=k+1
      if( ia(k).lt.it ) go to 245
      if( k.le.l ) then
         iit   = ia(l)
         ia(l) = ia(k)
         ia(k) = iit
         jjt   = ja(l)
         ja(l) = ja(k)
         ja(k) = jjt
         tta   = a(l)
         a(l)  = a(k)
         a(k)  = tta
         goto 240
      endif
      if( l-i.gt.j-k ) then
         il(m) = i
         iu(m) = l
         i = k
         m = m+1
      else
         il(m) = k
         iu(m) = j
         j = l
         m = m+1
      endif
      go to 260
  255 m = m-1
      if( m.eq.0 ) go to 300
      i = il(m)
      j = iu(m)
  260 if( j-i.ge.1 ) go to 225
      if( i.eq.j ) go to 255
      if( i.eq.1 ) go to 210
      i = i-1
  265 i = i+1
      if( i.eq.j ) go to 255
      it = ia(i+1)
      jt = ja(i+1)
      ta =  a(i+1)
      if( ia(i).le.it ) go to 265
      k=i
  270 ia(k+1) = ia(k)
      ja(k+1) = ja(k)
      a(k+1)  =  a(k)
      k = k-1
      if( it.lt.ia(k) ) go to 270
      ia(k+1) = it
      ja(k+1) = jt
      a(k+1)  = ta
      go to 265
  300 if( kflag.lt.1 ) then
         do 310 i=1,nn
            ia(i) = -ia(i)
 310     continue
      endif
      return
      end

*deck ds2y
      subroutine ds2y(n, nelt, ia, ja, a, isym )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym
      double precision a(nelt)
      if( ja(n+1).eq.nelt+1 ) return
      call qs2i1d( ja, ia, a, nelt, 1 )
      ja(1) = 1
      do 20 icol = 1, n-1
         do 10 j = ja(icol)+1, nelt
            if( ja(j).ne.icol ) then
               ja(icol+1) = j
               goto 20
            endif
 10      continue
 20   continue
      ja(n+1) = nelt+1
      ja(n+2) = 0
      do 70 icol = 1, n
         ibgn = ja(icol)
         iend = ja(icol+1)-1
         do 30 i = ibgn, iend
            if( ia(i).eq.icol ) then
               itemp = ia(i)
               ia(i) = ia(ibgn)
               ia(ibgn) = itemp
               temp = a(i)
               a(i) = a(ibgn)
               a(ibgn) = temp
               goto 40
            endif
 30      continue
 40      ibgn = ibgn + 1
         if( ibgn.lt.iend ) then
            do 60 i = ibgn, iend
               do 50 j = i+1, iend
                  if( ia(i).gt.ia(j) ) then
                     itemp = ia(i)
                     ia(i) = ia(j)
                     ia(j) = itemp
                     temp = a(i)
                     a(i) = a(j)
                     a(j) = temp
                  endif
 50            continue
 60         continue
         endif
 70   continue
      return
      end

*deck dcpplt
      subroutine dcpplt( n, nelt, ia, ja, a, isym, iunit )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym
      double precision a(nelt)
      character*225 chmat(225)
      nmax = min( 225, n)
      do 10 i = 1, nmax
         chmat(i)(1:nmax) = ' '
 10   continue
      do 30 icol = 1, nmax
         jbgn = ja(icol)
         jend = ja(icol+1)-1
         do 20 j = jbgn, jend
            irow = ia(j)
            if( irow.le.nmax ) then
               if( isym.ne.0 ) then
                  if( a(j).eq.0.0d0 ) then
                     chmat(irow)(icol:icol) = '0'
                  elseif( a(j).gt.0.0d0 ) then
                     chmat(irow)(icol:icol) = '#'
                  else
                     chmat(irow)(icol:icol) = '*'
                  endif
               endif
               if( irow.eq.icol ) then
                  if( a(j).eq.0.0d0 ) then
                     chmat(irow)(icol:icol) = '0'
                  elseif( a(j).gt.0.0d0 ) then
                     chmat(irow)(icol:icol) = 'd'
                  else
                     chmat(irow)(icol:icol) = 'n'
                  endif
               else
                  if( a(j).eq.0.0d0 ) then
                     chmat(irow)(icol:icol) = '0'
                  elseif( a(j).gt.0.0d0 ) then
                     chmat(irow)(icol:icol) = '#'
                  else
                     chmat(irow)(icol:icol) = '*'
                  endif
               endif
            endif
 20      continue
 30   continue
      write(iunit,1000) n, nelt, float(nelt)/float(n*n)
      write(iunit,1010) (mod(i,10),i=1,nmax)
      do 40 irow = 1, nmax
         write(iunit,1020) irow, chmat(irow)(1:nmax)
 40   continue
      return
 1000 format(/'**** picture of column slap matrix follows ****'/
     $     ' n, nelt and density = ',2i10,e16.7)
 1010 format(4x,255(i1))
 1020 format(1x,i3,a)
      end

*deck dtout
      subroutine dtout( n, nelt, ia, ja, a, isym, soln, rhs,
     $     iunit, job )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, job
      double precision a(nelt), rhs(n), soln(n)
      integer irhs, isoln, i
      irhs = 0
      isoln = 0
      if( job.eq.1 .or. job.eq.3 ) irhs = 1
      if( job.gt.1 ) isoln = 1
      write(iunit,1000) n, nelt, isym, irhs, isoln
      do 10 i = 1, nelt
         write(iunit,1010) ia(i), ja(i), a(i)
 10   continue
      if( irhs.eq.1 ) then
         write(iunit,1020) (rhs(i),i=1,n)
      endif
      if( isoln.eq.1 ) then
         write(iunit,1020) (soln(i),i=1,n)
      endif
      return
 1000 format(5i10)
 1010 format(1x,i5,1x,i5,1x,e16.7)
 1020 format(1x,e16.7)
      end

*deck dtin
      subroutine dtin( n, nelt, ia, ja, a, isym, soln, rhs,
     $     iunit, job )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, job
      double precision a(nelt), rhs(n), soln(n)
      integer irhs, isoln, i, neltmax
      neltmax = nelt
      read(iunit,1000) n, nelt, isym, irhs, isoln
      nelt = min( nelt, neltmax )
      do 10 i = 1, nelt
         read(iunit,1010) ia(i), ja(i), a(i)
 10   continue
      jobret = 0
      if( job.eq.1 .or. job.eq.3 ) then
         if( irhs.eq.1 ) then
            jobret = 1
            read(iunit,1020) (rhs(i),i=1,n)
         else
            do 20 i = 1, n
               rhs(i) = 0.0d0
 20         continue
         endif
      endif
      if( job.gt.1 ) then
         if( isoln.eq.1 ) then
            jobret = jobret + 2
            read(iunit,1020) (soln(i),i=1,n)
         else
            do 30 i = 1, n
               soln(i) = 0.0d0
 30         continue
         endif
      endif
      job = jobret
      return
 1000 format(5i10)
 1010 format(1x,i5,1x,i5,1x,e16.7)
 1020 format(1x,e16.7)
      end

*deck dsds
      subroutine dsds(n, nelt, ia, ja, a, isym, dinv)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym
      double precision a(nelt), dinv(n)
 1    continue
      do 10 icol = 1, n
         dinv(icol) = 1.0d0/a(ja(icol))
 10   continue
      return
      end

*deck dsdscl
      subroutine dsdscl( n, nelt, ia, ja, a, isym, x, b, dinv, job,
     $     itol )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, job, itol
      double precision a(nelt), x(n), b(n), dinv(n)
      parameter(maxn=441)
      common /solblk/ soln(maxn)
      if( job.ne.0 ) then
         do 10 icol = 1, n
            dinv(icol) = 1.0d0/sqrt( a(ja(icol)) )
 10      continue
      else
         do 15 icol = 1, n
            dinv(icol) = 1.0d0/dinv(icol)
 15      continue
      endif
      do 30 icol = 1, n
         jbgn = ja(icol)
         jend = ja(icol+1)-1
         di = dinv(icol)
         do 20 j = jbgn, jend
            a(j) = dinv(ia(j))*a(j)*di
 20      continue
 30   continue
      do 40 icol = 1, n
         b(icol) = b(icol)*dinv(icol)
         x(icol) = x(icol)/dinv(icol)
 40   continue
      if( itol.eq.11 ) then
         do 50 icol = 1, n
            soln(icol) = soln(icol)/dinv(icol)
 50      continue
      endif
      return
      end

*deck dsd2s
      subroutine dsd2s(n, nelt, ia, ja, a, isym, dinv)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym
      double precision a(nelt), dinv(n)
      do 10 i = 1, n
         dinv(i) = 0.
 10   continue
      do 40 i = 1, n
         kbgn = ja(i)
         kend = ja(i+1) - 1
         do 20 k = kbgn, kend
            dinv(ia(k)) = dinv(ia(k)) + a(k)**2
 20      continue
         if( isym.eq.1 ) then
            kbgn = kbgn + 1
            if( kbgn.le.kend ) then
               do 30 k = kbgn, kend
                  dinv(i) = dinv(i) + a(k)**2
 30            continue
            endif
         endif
 40   continue
      do 50 i=1,n
         dinv(i) = 1./dinv(i)
 50   continue
      return
      end

*deck ds2lt
      subroutine ds2lt( n, nelt, ia, ja, a, isym, nel, iel, jel, el )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym 
      integer nel, iel(nel), jel(nel)
      double precision a(nelt), el(nelt)
      if( isym.eq.0 ) then
         nel = 0
         do 20 icol = 1, n
            jel(icol) = nel+1
            jbgn = ja(icol)
            jend = ja(icol+1)-1
            do 10 j = jbgn, jend
               if( ia(j).ge.icol ) then
                  nel = nel + 1
                  iel(nel) = ia(j)
                  el(nel)  = a(j)
               endif
 10         continue
 20      continue
         jel(n+1) = nel+1
      else
         nel = nelt
         do 30 i = 1, nelt
            iel(i) = ia(i)
            el(i) = a(i)
 30      continue
         do 40 i = 1, n+1
            jel(i) = ja(i)
 40      continue
      endif
      return
      end

*deck dsics
      subroutine dsics(n, nelt, ia, ja, a, isym, nel, iel, jel,
     $     el, d, r, iwarn )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym
      integer nel, iel(nel), jel(nel)
      double precision a(nelt), el(nel), d(n), r(n)
      iwarn = 0
      nel = 1
      iel(1) = 1
      jel(1) = 1
      el(1) = 1.0d0
      d(1) = a(1)
      do 30 irow = 2, n
         nel = nel + 1
         iel(irow) = nel
         jel(nel) = irow
         el(nel) = 1.0d0
         d(irow) = a(ja(irow))
         if( isym.eq.0 ) then
            icbgn = ja(irow)
            icend = ja(irow+1)-1
         else
            icbgn = 1
            icend = irow-1
         endif
         do 20 ic = icbgn, icend
            if( isym.eq.0 ) then
               icol = ia(ic)
               if( icol.ge.irow ) goto 20
            else
               icol = ic
            endif
            jbgn = ja(icol)+1
            jend = ja(icol+1)-1
            if( jbgn.le.jend .and. ia(jend).ge.irow ) then
               do 10 j = jbgn, jend
                  if( ia(j).eq.irow ) then
                     nel = nel + 1
                     jel(nel) = icol
                     el(nel)  = a(j)
                     goto 20
                  endif
 10            continue
            endif
 20      continue
 30   continue
      iel(n+1) = nel+1
      do 60 irow = 2, n
         ibgn = iel(irow)+1
         iend = iel(irow+1)-1
         if( ibgn.lt.iend ) then
            do 50 i = ibgn, iend-1
               do 40 j = i+1, iend
                  if( jel(i).gt.jel(j) ) then
                     jeltmp = jel(j)
                     jel(j) = jel(i)
                     jel(i) = jeltmp
                     eltmp = el(j)
                     el(j) = el(i)
                     el(i) = eltmp
                  endif
 40            continue
 50         continue
         endif
 60   continue
      irbgn = ja(1)+1
      irend = ja(2)-1
      do 65 irr = irbgn, irend
         ir = ia(irr)
         i = iel(ir)+1
         el(i) = el(i)/d(1)
 65   continue
      do 110 irow = 2, n
         do 66 i = 1, irow-1
            r(i) = 0.0d0
 66      continue
         ibgn = iel(irow)+1
         iend = iel(irow+1)-1
         if( ibgn.le.iend ) then
            do 70 i = ibgn, iend
               r(jel(i)) = el(i)*d(jel(i))
               d(irow) = d(irow) - el(i)*r(jel(i))
 70         continue
            if( d(irow).le.0.0d0 ) then
               if( iwarn.eq.0 ) iwarn = irow
               d(irow) = 1.0d0
            endif
         endif
         irbgn = ja(irow)
         irend = ja(irow+1)-1
         do 100 irr = irbgn, irend
            ir = ia(irr)
            if( ir.le.irow ) goto 100
            ibgn = iel(ir)+1
            iend = iel(ir+1)-1
            if( jel(ibgn).gt.irow ) goto 100
            do 90 i = ibgn, iend
               if( jel(i).eq.irow ) then
                  icend = iend
 91               if( jel(icend).ge.irow ) then
                     icend = icend - 1
                     goto 91
                  endif
                  do 80 ic = ibgn, icend
                     el(i) = el(i) - el(ic)*r(jel(ic))
 80               continue
                  el(i) = el(i)/d(irow)
                  goto 100
               endif
 90         continue
            call xerrwv('dsics -- a and el data structure mismatch'//
     $           ' in row (i1)',53,1,2,1,irow,0,0,0.0,0.0)
 100     continue
 110  continue
      do 120 i =1, n
         d(i) = 1.0d0/d(i)
 120  continue
      return
      end

*deck dsilus
      subroutine dsilus(n, nelt, ia, ja, a, isym, nl, il, jl,
     $     l, dinv, nu, iu, ju, u, nrow, ncol)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, nl, il(nl), jl(nl)
      integer nu, iu(nu), ju(nu), nrow(n), ncol(n)
      double precision a(nelt), l(nl), dinv(n), u(nu)
      do 10 i=1,n
         nrow(i) = 0
         ncol(i) = 0
 10   continue
      do 30 icol = 1, n
         jbgn = ja(icol)+1
         jend = ja(icol+1)-1
         if( jbgn.le.jend ) then
            do 20 j = jbgn, jend
               if( ia(j).lt.icol ) then
                  ncol(icol) = ncol(icol) + 1
               else
                  nrow(ia(j)) = nrow(ia(j)) + 1
                  if( isym.ne.0 ) ncol(ia(j)) = ncol(ia(j)) + 1
               endif
 20         continue
         endif
 30   continue
      ju(1) = 1
      il(1) = 1
      do 40 icol = 1, n
         il(icol+1) = il(icol) + nrow(icol)
         ju(icol+1) = ju(icol) + ncol(icol)
         nrow(icol) = il(icol)
         ncol(icol) = ju(icol)
 40   continue
      do 60 icol = 1, n
         dinv(icol) = a(ja(icol))
         jbgn = ja(icol)+1
         jend = ja(icol+1)-1
         if( jbgn.le.jend ) then
            do 50 j = jbgn, jend
               irow = ia(j)
               if( irow.lt.icol ) then
                  iu(ncol(icol)) = irow
                  u(ncol(icol)) = a(j)
                  ncol(icol) = ncol(icol) + 1
               else
                  jl(nrow(irow)) = icol
                  l(nrow(irow)) = a(j)
                  nrow(irow) = nrow(irow) + 1
                  if( isym.ne.0 ) then
                     iu(ncol(irow)) = icol
                     u(ncol(irow)) = a(j)
                     ncol(irow) = ncol(irow) + 1
                  endif
               endif
 50         continue
         endif
 60   continue
      do 110 k = 2, n
         jbgn = ju(k)
         jend = ju(k+1)-1
         if( jbgn.lt.jend ) then
            do 80 j = jbgn, jend-1
               do 70 i = j+1, jend
                  if( iu(j).gt.iu(i) ) then
                     itemp = iu(j)
                     iu(j) = iu(i)
                     iu(i) = itemp
                     temp = u(j)
                     u(j) = u(i)
                     u(i) = temp
                  endif
 70            continue
 80         continue
         endif
         ibgn = il(k)
         iend = il(k+1)-1
         if( ibgn.lt.iend ) then
            do 100 i = ibgn, iend-1
               do 90 j = i+1, iend
                  if( jl(i).gt.jl(j) ) then
                     jtemp = ju(i)
                     ju(i) = ju(j)
                     ju(j) = jtemp
                     temp = l(i)
                     l(i) = l(j)
                     l(j) = temp
                  endif
 90            continue
 100        continue
         endif
 110  continue
      do 300 i=2,n
         indx1 = il(i)
         indx2 = il(i+1) - 1
         if(indx1 .gt. indx2) go to 200
         do 190 indx=indx1,indx2
            if(indx .eq. indx1) go to 180
            indxr1 = indx1
            indxr2 = indx - 1
            indxc1 = ju(jl(indx))
            indxc2 = ju(jl(indx)+1) - 1
            if(indxc1 .gt. indxc2) go to 180
 160        kr = jl(indxr1)
 170        kc = iu(indxc1)
            if(kr .gt. kc) then
               indxc1 = indxc1 + 1
               if(indxc1 .le. indxc2) go to 170
            elseif(kr .lt. kc) then
               indxr1 = indxr1 + 1
               if(indxr1 .le. indxr2) go to 160
            elseif(kr .eq. kc) then
               l(indx) = l(indx) - l(indxr1)*dinv(kc)*u(indxc1)
               indxr1 = indxr1 + 1
               indxc1 = indxc1 + 1
               if(indxr1 .le. indxr2 .and. indxc1 .le. indxc2) go to 160
            endif
 180        l(indx) = l(indx)/dinv(jl(indx))
 190     continue
 200     indx1 = ju(i)
         indx2 = ju(i+1) - 1
         if(indx1 .gt. indx2) go to 260
         do 250 indx=indx1,indx2
            if(indx .eq. indx1) go to 240
            indxc1 = indx1
            indxc2 = indx - 1
            indxr1 = il(iu(indx))
            indxr2 = il(iu(indx)+1) - 1
            if(indxr1 .gt. indxr2) go to 240
 210        kr = jl(indxr1)
 220        kc = iu(indxc1)
            if(kr .gt. kc) then
               indxc1 = indxc1 + 1
               if(indxc1 .le. indxc2) go to 220
            elseif(kr .lt. kc) then
               indxr1 = indxr1 + 1
               if(indxr1 .le. indxr2) go to 210
            elseif(kr .eq. kc) then
               u(indx) = u(indx) - l(indxr1)*dinv(kc)*u(indxc1)
               indxr1 = indxr1 + 1
               indxc1 = indxc1 + 1
               if(indxr1 .le. indxr2 .and. indxc1 .le. indxc2) go to 210
            endif
 240        u(indx) = u(indx)/dinv(iu(indx))
 250     continue
 260     indxr1 = il(i)
         indxr2 = il(i+1) - 1
         if(indxr1 .gt. indxr2) go to 300
         indxc1 = ju(i)
         indxc2 = ju(i+1) - 1
         if(indxc1 .gt. indxc2) go to 300
 270     kr = jl(indxr1)
 280     kc = iu(indxc1)
         if(kr .gt. kc) then
            indxc1 = indxc1 + 1
            if(indxc1 .le. indxc2) go to 280
         elseif(kr .lt. kc) then
            indxr1 = indxr1 + 1
            if(indxr1 .le. indxr2) go to 270
         elseif(kr .eq. kc) then
            dinv(i) = dinv(i) - l(indxr1)*dinv(kc)*u(indxc1)
            indxr1 = indxr1 + 1
            indxc1 = indxc1 + 1
            if(indxr1 .le. indxr2 .and. indxc1 .le. indxc2) go to 270
         endif
 300  continue
      do 430 i=1,n
         dinv(i) = 1./dinv(i)
 430  continue
      return
      end

*deck dsmv
      subroutine dsmv( n, x, y, nelt, ia, ja, a, isym )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym
      double precision a(nelt), x(n), y(n)
      do 10 i = 1, n
         y(i) = 0.0d0
 10   continue
      do 30 icol = 1, n
         ibgn = ja(icol)
         iend = ja(icol+1)-1
         do 20 i = ibgn, iend
            y(ia(i)) = y(ia(i)) + a(i)*x(icol)
 20      continue
 30   continue
      if( isym.eq.1 ) then
         do 50 irow = 1, n
            jbgn = ja(irow)+1
            jend = ja(irow+1)-1
            if( jbgn.gt.jend ) goto 50
            do 40 j = jbgn, jend
               y(irow) = y(irow) + a(j)*x(ia(j))
 40         continue
 50      continue
      endif
      return
      end

*deck dsmtv
      subroutine dsmtv( n, x, y, nelt, ia, ja, a, isym )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym
      double precision x(n), y(n), a(nelt)
      do 10 i = 1, n
         y(i) = 0.0d0
 10   continue
      do 30 irow = 1, n
         ibgn = ja(irow)
         iend = ja(irow+1)-1
         do 20 i = ibgn, iend
            y(irow) = y(irow) + a(i)*x(ia(i))
 20      continue
 30   continue
      if( isym.eq.1 ) then
         do 50 icol = 1, n
            jbgn = ja(icol)+1
            jend = ja(icol+1)-1
            if( jbgn.gt.jend ) goto 50
            do 40 j = jbgn, jend
               y(ia(j)) = y(ia(j)) + a(j)*x(icol)
 40         continue
 50      continue
      endif
      return
      end

*deck dsdi
      subroutine dsdi(n, b, x, nelt, ia, ja, a, isym, rwork, iwork)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, iwork(10)
      double precision b(n), x(n), a(nelt), rwork(1)
      locd = iwork(4) - 1
      do 10 i = 1, n
         x(i) = rwork(locd+i)*b(i)
 10   continue
      return
      end

*deck dsli
      subroutine dsli(n, b, x, nelt, ia, ja, a, isym, rwork, iwork )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, iwork(10)
      double precision b(n), x(n), a(nelt), rwork(1)
      nel = iwork(1)
      lociel = iwork(2)
      locjel = iwork(3)
      locel = iwork(4)
      call dsli2(n, b, x, nel, iwork(lociel), iwork(locjel),
     $     rwork(locel))
      return
      end

*deck dsli2
      subroutine dsli2(n, b, x, nel, iel, jel, el)
      implicit double precision(a-h,o-z)
      integer n, nel, iel(nel), jel(nel)
      double precision b(n), x(n), el(nel)
      do 10 i=1,n
         x(i) = b(i)
 10   continue
      do 30 icol = 1, n
         x(icol) = x(icol)/el(jel(icol))
         jbgn = jel(icol) + 1
         jend = jel(icol+1) - 1
         if( jbgn.le.jend ) then
            do 20 j = jbgn, jend
               x(iel(j)) = x(iel(j)) - el(j)*x(icol)
 20         continue
         endif
 30   continue
      return
      end

*deck dsllti
      subroutine dsllti(n, b, x, nelt, ia, ja, a, isym, rwork, iwork)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, iwork(1)
      double precision b(1), x(1), a(nelt), rwork(1)
      nel = iwork(1)
      lociel = iwork(3)
      locjel = iwork(2)
      locel  = iwork(4)
      locdin = iwork(5)
      call sllti2(n, b, x, nel, iwork(lociel), iwork(locjel),
     $     rwork(locel), rwork(locdin))
      return
      end

*deck sllti2
      subroutine sllti2(n, b, x, nel, iel, jel, el, dinv)
      implicit double precision(a-h,o-z)
      integer n, nel, iel(nel), jel(1)
      double precision b(n), x(n), el(nel), dinv(n)
      do 10 i=1,n
         x(i) = b(i)
 10   continue
      do 30 irow = 1, n
         ibgn = iel(irow) + 1
         iend = iel(irow+1) - 1
         if( ibgn.le.iend ) then
            do 20 i = ibgn, iend
               x(irow) = x(irow) - el(i)*x(jel(i))
 20         continue
         endif
 30   continue
      do 40 i=1,n
         x(i) = x(i)*dinv(i)
 40   continue
      do 60 irow = n, 2, -1
         ibgn = iel(irow) + 1
         iend = iel(irow+1) - 1
         if( ibgn.le.iend ) then
            do 50 i = ibgn, iend
               x(jel(i)) = x(jel(i)) - el(i)*x(irow)
 50         continue
         endif
 60   continue
      return
      end

*deck dslui
      subroutine dslui(n, b, x, nelt, ia, ja, a, isym, rwork, iwork)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, iwork(10)
      double precision b(n), x(n), a(nelt), rwork(1)
      locil = iwork(1)
      locjl = iwork(2)
      lociu = iwork(3)
      locju = iwork(4)
      locl = iwork(5)
      locdin = iwork(6)
      locu = iwork(7)
      call dslui2(n, b, x, iwork(locil), iwork(locjl), rwork(locl),
     $     rwork(locdin), iwork(lociu), iwork(locju), rwork(locu) )
      return
      end

*deck dslui2
      subroutine dslui2(n, b, x, il, jl, l, dinv, iu, ju, u )
      implicit double precision(a-h,o-z)
      integer n, il(1), jl(1), iu(1), ju(1)
      double precision b(n), x(n), l(1), dinv(n), u(1)
      do 10 i = 1, n
         x(i) = b(i)
 10   continue
      do 30 irow = 2, n
         jbgn = il(irow)
         jend = il(irow+1)-1
         if( jbgn.le.jend ) then
            do 20 j = jbgn, jend
               x(irow) = x(irow) - l(j)*x(jl(j))
 20         continue
         endif
 30   continue
      do 40 i=1,n
         x(i) = x(i)*dinv(i)
 40   continue
      do 60 icol = n, 2, -1
         jbgn = ju(icol)
         jend = ju(icol+1)-1
         if( jbgn.le.jend ) then
            do 50 j = jbgn, jend
               x(iu(j)) = x(iu(j)) - u(j)*x(icol)
 50         continue
         endif
 60   continue
      return
      end

*deck dsluti
      subroutine dsluti(n, b, x, nelt, ia, ja, a, isym, rwork, iwork)
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, iwork(10)
      double precision b(n), x(n), a(n), rwork(1)
      locil = iwork(1)
      locjl = iwork(2)
      lociu = iwork(3)
      locju = iwork(4)
      locl = iwork(5)
      locdin = iwork(6)
      locu = iwork(7)
      call dslui4(n, b, x, iwork(locil), iwork(locjl), rwork(locl),
     $     rwork(locdin), iwork(lociu), iwork(locju), rwork(locu))
      return
      end

*deck dslui4
      subroutine dslui4(n, b, x, il, jl, l, dinv, iu, ju, u )
      implicit double precision(a-h,o-z)
      integer n, il(*), jl(*), iu(*), ju(*)
      double precision b(n), x(n), l(*), dinv(n), u(*)
      do 10 i=1,n
         x(i) = b(i)
 10   continue
      do 80 irow = 2, n
         jbgn = ju(irow)
         jend = ju(irow+1) - 1
         if( jbgn.le.jend ) then
            do 70 j = jbgn, jend
               x(irow) = x(irow) - u(j)*x(iu(j))
 70         continue
         endif
 80   continue
      do 90 i = 1, n
         x(i) = x(i)*dinv(i)
 90   continue
      do 110 icol = n, 2, -1
         jbgn = il(icol)
         jend = il(icol+1) - 1
         if( jbgn.le.jend ) then
            do 100 j = jbgn, jend
               x(jl(j)) = x(jl(j)) - l(j)*x(icol)
 100        continue
         endif
 110  continue
      return
      end

*deck dsmmti
      subroutine dsmmti(n, b, x, nelt, ia, ja, a, isym, rwork, iwork )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, iwork(10)
      double precision b(n), x(n), a(nelt), rwork(1)
      locil = iwork(1)
      locjl = iwork(2)
      lociu = iwork(3)
      locju = iwork(4)
      locl = iwork(5)
      locdin = iwork(6)
      locu = iwork(7)
      call dsmmi2(n, b, x, iwork(locil), iwork(locjl),
     $     rwork(locl), rwork(locdin), iwork(lociu),
     $     iwork(locju), rwork(locu))
      return
      end

*deck dsmmi2
      subroutine dsmmi2( n, b, x, il, jl, l, dinv, iu, ju, u )
      implicit double precision(a-h,o-z)
      integer n, il(1), jl(1), iu(1), ju(1)
      double precision b(n), x(n), l(1), dinv(n), u(n)
      do 10 i = 1, n
         x(i) = b(i)
 10   continue
      do 30 irow = 2, n
         jbgn = il(irow)
         jend = il(irow+1)-1
         if( jbgn.le.jend ) then
            do 20 j = jbgn, jend
               x(irow) = x(irow) - l(j)*x(jl(j))
 20         continue
         endif
 30   continue
      do 40 i=1,n
         x(i) = x(i)*dinv(i)
 40   continue
      do 60 icol = n, 2, -1
         jbgn = ju(icol)
         jend = ju(icol+1)-1
         if( jbgn.le.jend ) then
            do 50 j = jbgn, jend
               x(iu(j)) = x(iu(j)) - u(j)*x(icol)
 50         continue
         endif
 60   continue
      do 80 irow = 2, n
         jbgn = ju(irow)
         jend = ju(irow+1) - 1
         if( jbgn.le.jend ) then
            do 70 j = jbgn, jend
               x(irow) = x(irow) - u(j)*x(iu(j))
 70         continue
         endif
 80   continue
      do 90 i = 1, n
         x(i) = x(i)*dinv(i)
 90   continue
      do 110 icol = n, 2, -1
         jbgn = il(icol)
         jend = il(icol+1) - 1
         if( jbgn.le.jend ) then
            do 100 j = jbgn, jend
               x(jl(j)) = x(jl(j)) - l(j)*x(icol)
 100        continue
         endif
 110  continue
      return
      end

*deck domn
      subroutine domn( n, b, x, nelt, ia, ja, a, isym, matvec, msolve, 
     $     nsave, itol, tol, itmax, iter, err, ierr, iunit, r, z, p, 
     $     ap, emap, dz, csav, rwork, iwork )
      implicit double precision(a-h,o-z)
      integer  n, nelt, ia(nelt), ja(nelt), isym, nsave, itol, itmax
      integer  iter, ierr, iunit, iwork(*)
      double precision b(n), x(n), a(nelt), tol, err, r(n), z(n) 
      double precision p(n,0:nsave), ap(n,0:nsave), emap(n,0:nsave)
      double precision dz(n), csav(nsave), rwork(*)
      external matvec, msolve
      iter = 0
      ierr = 0
      if( n.lt.1 ) then
         ierr = 3
         return
      endif
      eps = d1mach(3)
      if( tol.lt.500.0*eps ) then
         tol = 500.0*eps
         ierr = 4
      endif
      fuzz = eps*eps
      call matvec(n, x, r, nelt, ia, ja, a, isym)
      do 10 i = 1, n
         r(i)  = b(i) - r(i)
 10   continue
      call msolve(n, r, z, nelt, ia, ja, a, isym, rwork, iwork)
      if( isdomn(n, b, x, nelt, ia, ja, a, isym, msolve, nsave,
     $     itol, tol, itmax, iter, err, ierr, iunit,
     $     r, z, p, ap, emap, dz, csav,
     $     rwork, iwork, ak, bnrm, solnrm) .ne. 0 ) go to 200
      if( ierr.ne.0 ) return
      do 100 k = 1, itmax
         iter = k
         ip = mod( iter-1, nsave+1 )
         call dcopy(n, z, 1, p(1,ip), 1)
         call matvec(n, p(1,ip), ap(1,ip), nelt, ia, ja, a, isym)
         call msolve(n, ap(1,ip), emap(1,ip), nelt, ia, ja, a, isym,
     $        rwork, iwork)
         if( nsave.eq.0 ) then
            akden = ddot(n, emap, 1, emap, 1)
         else
            if( iter.gt.1 ) then
               lmax = min( nsave, iter-1 )
               do 20 l = 1, lmax
                  ipo = mod(ip+(nsave+1-l),nsave+1)
                  bkl = ddot(n, emap(1,ip), 1, emap(1,ipo), 1)
                  bkl = bkl*csav(l)
                  call daxpy(n, -bkl,    p(1,ipo), 1,    p(1,ip), 1)
                  call daxpy(n, -bkl,   ap(1,ipo), 1,   ap(1,ip), 1)
                  call daxpy(n, -bkl, emap(1,ipo), 1, emap(1,ip), 1)
 20            continue
               if( nsave.gt.1 ) then
                  do 30 l = nsave-1, 1, -1
                     csav(l+1) = csav(l)
 30               continue
               endif
            endif
            akden = ddot(n, emap(1,ip), 1, emap(1,ip), 1)
            if( abs(akden).lt.eps*eps ) then
               ierr = 6
               return
            endif
            csav(1) = 1./akden
         endif
         aknum = ddot(n, z, 1, emap(1,ip), 1)
         ak = aknum/akden
         call daxpy(n,  ak,    p(1,ip), 1, x, 1)
         call daxpy(n, -ak,   ap(1,ip), 1, r, 1)
         call daxpy(n, -ak, emap(1,ip), 1, z, 1)
         if( isdomn(n, b, x, nelt, ia, ja, a, isym, msolve, nsave,
     $        itol, tol, itmax, iter, err, ierr, iunit,
     $        r, z, p, ap, emap, dz, csav,
     $        rwork, iwork, ak, bnrm, solnrm) .ne. 0 ) go to 200
 100  continue
      iter = itmax + 1
      ierr = 2
 200  return
      end

*deck dsdomn
      subroutine dsdomn(n, b, x, nelt, ia, ja, a, isym, nsave,
     $     itol, tol, itmax, iter, err, ierr, iunit,
     $     rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, nsave, itol, itmax
      integer iter, ierr, iunit, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(n), tol, err, rwork(lenw)
      external dsmv, dsdi
      parameter (locrb=1, locib=11)
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      lociw = locib
      locdin = locrb
      locr = locdin + n
      locz = locr + n
      locp = locz + n
      locap = locp + n*(nsave+1)
      locema = locap + n*(nsave+1)
      locdz = locema + n*(nsave+1)
      loccsa = locdz + n
      locw = loccsa + nsave
      call dchkw( 'dsdomn', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(4) = locdin
      iwork(9) = lociw
      iwork(10) = locw
      call dsds(n, nelt, ia, ja, a, isym, rwork(locdin))
      call domn(n, b, x, nelt, ia, ja, a, isym, dsmv, 
     $     dsdi, nsave, itol, tol, itmax, iter, err, ierr, iunit,
     $     rwork(locr), rwork(locz), rwork(locp), rwork(locap),
     $     rwork(locema), rwork(locdz), rwork(loccsa),
     $     rwork, iwork )
      return
      end

*deck dsluom
      subroutine dsluom(n, b, x, nelt, ia, ja, a, isym, nsave,
     $     itol, tol, itmax, iter, err, ierr, iunit,
     $     rwork, lenw, iwork, leniw )
      implicit double precision(a-h,o-z)
      integer n, nelt, ia(nelt), ja(nelt), isym, nsave, itol, itmax
      integer iter, ierr, iunit, lenw, iwork(leniw), leniw
      double precision b(n), x(n), a(n), rwork(lenw)
      external dsmv, dslui
      parameter (locrb=1, locib=11)
      ierr = 0
      if( n.lt.1 .or. nelt.lt.1 ) then
         ierr = 3
         return
      endif
      call ds2y( n, nelt, ia, ja, a, isym )
      nl = 0
      nu = 0
      do 20 icol = 1, n
         jbgn = ja(icol)+1
         jend = ja(icol+1)-1
         if( jbgn.le.jend ) then
            do 10 j = jbgn, jend
               if( ia(j).gt.icol ) then
                  nl = nl + 1
                  if( isym.ne.0 ) nu = nu + 1
               else
                  nu = nu + 1
               endif
 10         continue
         endif
 20   continue
      locil = locib
      locjl = locil + n+1
      lociu = locjl + nl
      locju = lociu + nu
      locnr = locju + n+1
      locnc = locnr + n
      lociw = locnc + n
      locl   = locrb
      locdin = locl + nl
      locu   = locdin + n
      locr   = locu + nu
      locz   = locr + n
      locp   = locz + n
      locap  = locp + n*(nsave+1)
      locema = locap + n*(nsave+1)
      locdz  = locema + n*(nsave+1)
      loccsa = locdz + n
      locw   = loccsa + nsave
      call dchkw( 'dsluom', lociw, leniw, locw, lenw, ierr, iter, err )
      if( ierr.ne.0 ) return
      iwork(1) = locil
      iwork(2) = locjl
      iwork(3) = lociu
      iwork(4) = locju
      iwork(5) = locl
      iwork(6) = locdin
      iwork(7) = locu
      iwork(9) = lociw
      iwork(10) = locw
      call dsilus( n, nelt, ia, ja, a, isym, nl, iwork(locil),
     $     iwork(locjl), rwork(locl), rwork(locdin), nu, iwork(lociu),
     $     iwork(locju), rwork(locu), iwork(locnr), iwork(locnc) )
      call domn(n, b, x, nelt, ia, ja, a, isym, dsmv,
     $     dslui, nsave, itol, tol, itmax, iter, err, ierr, iunit,
     $     rwork(locr), rwork(locz), rwork(locp), rwork(locap),
     $     rwork(locema), rwork(locdz), rwork(loccsa),
     $     rwork, iwork )
      return
      end

*deck isdomn
      function isdomn(n, b, x, nelt, ia, ja, a, isym, msolve, nsave,
     $     itol, tol, itmax, iter, err, ierr, iunit,
     $     r, z, p, ap, emap, dz, csav,
     $     rwork, iwork, ak, bnrm, solnrm)
      implicit double precision(a-h,o-z)
      integer  n, nelt, ia(nelt), ja(nelt), isym, nsave, itol, itmax
      integer  iter, iunit, iwork(*)
      double precision b(n), x(n), a(nelt), tol, err, r(n), z(n)
      double precision p(n,0:nsave), ap(n,0:nsave), emap(n,0:nsave)
      double precision dz(n), csav(nsave), rwork(*)
      external msolve
      parameter(maxn=441)
      common /solblk/ soln(maxn)
      isdomn = 0
      if( itol.eq.1 ) then
         if(iter .eq. 0) bnrm = dnrm2(n, b, 1)
         err = dnrm2(n, r, 1)/bnrm
      else if( itol.eq.2 ) then
         if(iter .eq. 0) then
            call msolve(n, b, dz, nelt, ia, ja, a, isym, rwork, iwork)
            bnrm = dnrm2(n, dz, 1)
         endif
         err = dnrm2(n, z, 1)/bnrm
      else if( itol.eq.11 ) then
         if(iter .eq. 0) solnrm = dnrm2(n, soln, 1)
         do 10 i = 1, n
            dz(i) = x(i) - soln(i)
 10      continue
         err = dnrm2(n, dz, 1)/solnrm
      else
         err = 1.0e10
         ierr = 3
      endif
      if(iunit .ne. 0) then
         if( iter.eq.0 ) then
            write(iunit,1000) nsave, n, itol
         endif
         write(iunit,1010) iter, err, ak
      endif
      if(err .le. tol) isdomn = 1
      return
 1000 format(' preconditioned orthomin(',i3,') for ',
     $     'n, itol = ',i5, i5,
     $     /' iter','   error estimate','            alpha')
 1010 format(1x,i4,1x,e16.7,1x,e16.7)
      end

! *deck xerabt
!      subroutine xerabt(messg,nmessg)
!      dimension messg(nmessg)
!      call exit(1)
!      end

*deck xerctl
      subroutine xerctl(messg1,nmessg,nerr,level,kontrl)
      character*20 messg1
      return
      end

*deck xerprt
      subroutine xerprt(messg,nmessg)
      integer lun(5)
      character*(*) messg
      call xgetua(lun,nunit)
      lenmes = len(messg)
      do 20 kunit=1,nunit
         iunit = lun(kunit)
         if (iunit.eq.0) iunit = i1mach(4)
         do 10 ichar=1,lenmes,72
            last = min0(ichar+71 , lenmes)
            write (iunit,'(1x,a)') messg(ichar:last)
   10    continue
   20 continue
      return
      end

*deck xerror
      subroutine xerror(messg,nmessg,nerr,level)
      character*(*) messg
      call xerrwv(messg,nmessg,nerr,level,0,0,0,0,0.,0.)
      return
      end

*deck xerrwv
      subroutine xerrwv(messg,nmessg,nerr,level,ni,i1,i2,nr,r1,r2)
      character*(*) messg
      character*20 lfirst
      character*37 morf
      dimension lun(5)
      lkntrl = j4save(2,0,.false.)
      maxmes = j4save(4,0,.false.)
      if ((nmessg.gt.0).and.(nerr.ne.0).and.
     1    (level.ge.(-1)).and.(level.le.2)) go to 10
         if (lkntrl.gt.0) call xerprt('fatal error in...',17)
         call xerprt('xerror -- invalid input',23)
         if (lkntrl.gt.0) call xerprt('job abort due to fatal error.',
     1  29)
         if (lkntrl.gt.0) call xersav(' ',0,0,0,kdummy)
         call xerabt('xerror -- invalid input',23)
         return
   10 continue
      junk = j4save(1,nerr,.true.)
      call xersav(messg,nmessg,nerr,level,kount)
      lfirst = messg
      lmessg = nmessg
      lerr = nerr
      llevel = level
      call xerctl(lfirst,lmessg,lerr,llevel,lkntrl)
      lmessg = nmessg
      lerr = nerr
      llevel = level
      lkntrl = max0(-2,min0(2,lkntrl))
      mkntrl = iabs(lkntrl)
      if ((llevel.lt.2).and.(lkntrl.eq.0)) go to 100
      if (((llevel.eq.(-1)).and.(kount.gt.min0(1,maxmes)))
     1.or.((llevel.eq.0)   .and.(kount.gt.maxmes))
     2.or.((llevel.eq.1)   .and.(kount.gt.maxmes).and.(mkntrl.eq.1))
     3.or.((llevel.eq.2)   .and.(kount.gt.max0(1,maxmes)))) go to 100
         if (lkntrl.le.0) go to 20
            call xerprt(' ',1)
            if (llevel.eq.(-1)) call xerprt
     1('warning message...this message will only be printed once.',57)
            if (llevel.eq.0) call xerprt('warning in...',13)
            if (llevel.eq.1) call xerprt
     1      ('recoverable error in...',23)
            if (llevel.eq.2) call xerprt('fatal error in...',17)
   20    continue
         call xerprt(messg,lmessg)
         call xgetua(lun,nunit)
         isizei = log10(float(i1mach(9))) + 1.0
         isizef = log10(float(i1mach(10))**i1mach(11)) + 1.0
         do 50 kunit=1,nunit
            iunit = lun(kunit)
            if (iunit.eq.0) iunit = i1mach(4)
            do 22 i=1,min(ni,2)
               write (morf,21) i,isizei
   21          format ('(11x,21hin above message, i',i1,'=,i',i2,')   ')
               if (i.eq.1) write (iunit,morf) i1
               if (i.eq.2) write (iunit,morf) i2
   22       continue
            do 24 i=1,min(nr,2)
               write (morf,23) i,isizef+10,isizef
   23          format ('(11x,21hin above message, r',i1,'=,e',
     1         i2,'.',i2,')')
               if (i.eq.1) write (iunit,morf) r1
               if (i.eq.2) write (iunit,morf) r2
   24       continue
            if (lkntrl.le.0) go to 40
               write (iunit,30) lerr
   30          format (15h error number =,i10)
   40       continue
   50    continue
  100 continue
      ifatal = 0
      if ((llevel.eq.2).or.((llevel.eq.1).and.(mkntrl.eq.2)))
     1ifatal = 1
      if (ifatal.le.0) return
      if ((lkntrl.le.0).or.(kount.gt.max0(1,maxmes))) go to 120
         if (llevel.eq.1) call xerprt
     1   ('job abort due to unrecovered error.',35)
         if (llevel.eq.2) call xerprt
     1   ('job abort due to fatal error.',29)
         call xersav(' ',-1,0,0,kdummy)
  120 continue
      if ((llevel.eq.2).and.(kount.gt.max0(1,maxmes))) lmessg = 0
      call xerabt(messg,lmessg)
      return
      end

*deck xersav
      subroutine xersav(messg,nmessg,nerr,level,icount)
      integer lun(5)
      character*(*) messg
      character*20 mestab(10),mes
      dimension nertab(10),levtab(10),kount(10)
      save mestab,nertab,levtab,kount,kountx
      data kount(1),kount(2),kount(3),kount(4),kount(5),
     1     kount(6),kount(7),kount(8),kount(9),kount(10)
     2     /0,0,0,0,0,0,0,0,0,0/
      data kountx/0/
      if (nmessg.gt.0) go to 80
         if (kount(1).eq.0) return
         call xgetua(lun,nunit)
         do 60 kunit=1,nunit
            iunit = lun(kunit)
            if (iunit.eq.0) iunit = i1mach(4)
            write (iunit,10)
   10       format (32h0          error message summary/
     1      51h message start             nerr     level     count)
            do 20 i=1,10
               if (kount(i).eq.0) go to 30
               write (iunit,15) mestab(i),nertab(i),levtab(i),kount(i)
   15          format (1x,a20,3i10)
   20       continue
   30       continue
            if (kountx.ne.0) write (iunit,40) kountx
   40       format (41h0other errors not individually tabulated=,i10)
            write (iunit,50)
   50       format (1x)
   60    continue
         if (nmessg.lt.0) return
         do 70 i=1,10
   70       kount(i) = 0
         kountx = 0
         return
   80 continue
      mes = messg
      do 90 i=1,10
         ii = i
         if (kount(i).eq.0) go to 110
         if (mes.ne.mestab(i)) go to 90
         if (nerr.ne.nertab(i)) go to 90
         if (level.ne.levtab(i)) go to 90
         go to 100
   90 continue
         kountx = kountx+1
         icount = 1
         return
  100    kount(ii) = kount(ii) + 1
         icount = kount(ii)
         return
  110    mestab(ii) = mes
         nertab(ii) = nerr
         levtab(ii) = level
         kount(ii)  = 1
         icount = 1
         return
      end

!     subroutine xgetua(iunita,n)
!     dimension iunita(5)
!     n = j4save(5,0,.false.)
!     do 30 i=1,n
!        index = i+4
!        if (i.eq.1) index = 3
!        iunita(i) = j4save(index,0,.false.)
!  30 continue
!     return
!     end

!     function j4save(iwhich,ivalue,iset)
!     logical iset
!     integer iparam(9)
!     save iparam
!     data iparam(1),iparam(2),iparam(3),iparam(4)/0,2,0,10/
!     data iparam(5)/1/
!     data iparam(6),iparam(7),iparam(8),iparam(9)/0,0,0,0/
!     j4save = iparam(iwhich)
!     if (iset) iparam(iwhich) = ivalue
!     return
!     end

!     subroutine xerdmp
!     call xersav(' ',0,0,0,kount)
!     return
!     end

!     subroutine xgetun(iunit)
!     iunit = j4save(3,0,.false.)
!     return
!     end

!     subroutine xsetua(iunita,n)
!     dimension iunita(5)
!     if ((n.ge.1).and.(n.le.5)) go to 10
!        call xerrwv('xsetua -- invalid value of n (i1).',34,1,2,
!    1  1,n,0,0,0.,0.)
!        return
!  10 continue
!     do 20 i=1,n
!        index = i+4
!        if (i.eq.1) index = 3
!        junk = j4save(index,iunita(i),.true.)
!  20 continue
!     junk = j4save(5,n,.true.)
!     return
!     end

!     subroutine xsetun(iunit)
!     junk = j4save(3,iunit,.true.)
!     junk = j4save(5,1,.true.)
!     return
!     end

      function rand(r)
      save ia1, ia0, ia1ma0, ic, ix1, ix0
      data ia1, ia0, ia1ma0 /1536, 1029, 507/
      data ic /1731/
      data ix1, ix0 /0, 0/
      if (r.lt.0.) go to 10
      if (r.gt.0.) go to 20
      iy0 = ia0*ix0
      iy1 = ia1*ix1 + ia1ma0*(ix0-ix1) + iy0
      iy0 = iy0 + ic
      ix0 = mod (iy0, 2048)
      iy1 = iy1 + (iy0-ix0)/2048
      ix1 = mod (iy1, 2048)
 10   rand = ix1*2048 + ix0
      rand = rand / 4194304.
      return
 20   ix1 = amod(r,1.)*4194304. + 0.5
      ix0 = mod (ix1, 2048)
      ix1 = (ix1-ix0)/2048
      go to 10
      end
//ft05f001 dd *
3
/*
