subroutine nspcg (precon,accel,ndimm,mdimm,nn,maxnzz,coef, a jcoef,p,ip,u,ubar,rhs,wksp,iwksp,nw,inw, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... nspcg is the driver for the nspcg package. c c ... parameters -- c c precon preconditioning module c accel acceleration module c coef floating point matrix data array c jcoef integer matrix data array c n input integer. order of the system (= nn) c u input/output vector. on input, u contains the c initial guess to the solution. on output, it c contains the latest estimate to the solution. c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c wksp floating point workspace vector of length nw c iwksp integer workspace vector of length inw c nw length of wksp upon input, amount used upon c output c inw length of iwksp upon input, amount used upon c output c iparm integer vector of length 30. allows user to c specify some integer parameters which affect c the method. c rparm floating point vector of length 30. allows user to c specify some floating point parameters which affect c the method. c ier output integer. error flag. c c ... specifications for parameters c external accel, precon integer iparm(30), jcoef(2), p(1), ip(1), iwksp(1) dimension coef(1), rhs(1), u(1), ubar(1), rparm(30), wksp(1) c c *** begin -- package common c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c c *** end -- package common c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c ier = 0 ndim = ndimm mdim = mdimm n = nn maxnz = maxnzz lenr = nw leni = inw irmax = 0 iimax = 0 t1 = timer (dummy) call echall (n,iparm,rparm,1,1,ier) if (ier .lt. 0) return timfac = 0.0d0 call pointr (1,wksp,iwksp,ier) c c ... call preparatory routines. c c ... remove zeros from jcoef for purdue data structure. c if (nstore .eq. 1) call adjust (n,ndim,maxnz,jcoef,1) call prep (coef,jcoef,wksp(irpnt),iwksp(iipnt),n,nstore,ier) if (ier .lt. 0) then call ershow (ier,'nspcg') go to 20 endif c c ... eliminate penalty-method dirichlet points, if requested. c ielim = iparm(24) tol = rparm(15) if (ielim .eq. 1) call elim (n,jcoef,coef,rhs,wksp,iwksp, a tol) c c ... determine symmetry of matrix. c if (nstore .eq. 1 .and. isymm .eq. 2) call detsym a (ndim,maxnz,coef,jcoef,n,isymm) c c ... scale matrix. c call scale (coef,jcoef,wksp,1,n,u,ubar,rhs,ier) if (ier .lt. 0) go to 20 c c ... permute matrix. c call permut (coef,jcoef,p,ip,wksp,iwksp,1,n,u,ubar,rhs,ier) if (ier .lt. 0) go to 15 c c ... call iterative routine. c call precon (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) c c ... unpermute matrix. c call permut (coef,jcoef,p,ip,wksp,iwksp,2,n,u,ubar,rhs,ier) c c ... unscale matrix. c 15 call scale (coef,jcoef,wksp,2,n,u,ubar,rhs,ier) c c ... restore zeros to jcoef for purdue data structure. c 20 if (nstore .eq. 1) call adjust (n,ndim,maxnz,jcoef,2) t2 = timer (dummy) timtot = t2 - t1 iparm(18) = ipropa iparm(23) = isymm rparm(13) = timfac rparm(14) = timtot call echall (n,iparm,rparm,2,1,ier) c call pointr (2,wksp,iwksp,ier) nw = irmax inw = iimax maxnzz = maxnz return end subroutine rsnsp (precon,accel,ndimm,mdimm,nn,maxnzz,coef, a jcoef,p,ip,u,ubar,rhs,wksp,iwksp,nw,inw, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... rsnsp is the driver for the nspcg package for methods c applied to the explicitly computed reduced system. c c ... parameters -- c c precon preconditioning module c accel acceleration module c coef floating point matrix data array c jcoef integer matrix data array c n input integer. order of the system (= nn) c u input/output vector. on input, u contains the c initial guess to the solution. on output, it c contains the latest estimate to the solution. c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c wksp floating point workspace of length nw c iwksp integer workspace of length inw c nw length of wksp upon input, amount used upon c output c inw length of iwksp upon input, amount used upon c output c iparm integer vector of length 30. allows user to c specify some integer parameters which affect c the method. c rparm floating point vector of length 30. allows user to c specify some floating point parameters which affect c the method. c ier output integer. error flag. c c ... specifications for parameters c external accel, precon integer iparm(30), jcoef(2), p(1), ip(1), iwksp(1) dimension coef(1), rhs(1), u(1), ubar(1), rparm(30), wksp(1) c c *** begin -- package common c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c c *** end -- package common c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c ier = 0 ndim = ndimm mdim = mdimm n = nn maxnz = maxnzz lenr = nw leni = inw irmax = 0 iimax = 0 t1 = timer (dummy) call echall (n,iparm,rparm,1,1,ier) timfac = 0.0d0 call pointr (1,wksp,iwksp,ier) c c ... call preparatory routines. c c ... remove zeros from jcoef for purdue data structure. c if (nstore .eq. 1) call adjust (n,ndim,maxnz,jcoef,1) call prep (coef,jcoef,wksp(irpnt),iwksp(iipnt),n,nstore,ier) if (ier .lt. 0) then call ershow (ier,'rsnsp') go to 20 endif c c ... eliminate penalty-method dirichlet points, if requested. c ielim = iparm(24) tol = rparm(15) if (ielim .eq. 1) call elim (n,jcoef,coef,rhs,wksp,iwksp, a tol) c c ... determine symmetry of matrix. c if (nstore .eq. 1 .and. isymm .eq. 2) call detsym a (ndim,maxnz,coef,jcoef,n,isymm) c c ... form reduced system matrix. c call rsprep (coef,jcoef,wksp,iwksp,n,rhs,u,ubar, a p,ip,nr,irs,ijcrs,irsrhs,ier) c c ... scale matrix. c call scale (wksp(irs),iwksp(ijcrs),wksp,1,nr,u,ubar, a wksp(irsrhs),ier) if (ier .lt. 0) go to 20 c c ... call iterative routine. c call precon (accel,wksp(irs),iwksp(ijcrs),nr,u,ubar, a wksp(irsrhs),wksp,iwksp,iparm,rparm,ier) c c ... unscale matrix. c call scale (wksp(irs),iwksp(ijcrs),wksp,2,nr,u,ubar, a wksp(irsrhs),ier) c c ... restore to original system. c call rspost (coef,jcoef,wksp,iwksp,n,rhs,u,ubar, a p,ip,nr,irs,ijcrs,ier) c c ... restore zeros to jcoef for purdue data structure. c 20 if (nstore .eq. 1) call adjust (n,ndim,maxnz,jcoef,2) t2 = timer (dummy) timtot = t2 - t1 iparm(18) = ipropa iparm(23) = isymm rparm(13) = timfac rparm(14) = timtot call echall (n,iparm,rparm,2,1,ier) c call pointr (2,wksp,iwksp,ier) nw = irmax inw = iimax maxnzz = maxnz return end subroutine prep (coef,jcoef,wksp,iwksp,nn,nstore,ier) implicit double precision (a-h, o-z) c c ... prep puts the diagonal entries of the matrix into column c one of coef. c c ... parameters -- c c n dimension of matrix c jcoef integer matrix representation array c coef matrix representation array c wksp workspace array of size n c iwksp integer workspace c ier error flag -- on return, values mean c 0 -- no errors detected c -5 -- nonexistent diagonal element c c ... specifications for parameters c integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cmpart / mpstrt, mpart c n = nn go to (5,10,10,15,15), nstore 5 call prep1 (n,ndim,maxnz,jcoef,coef,ier) return 10 call prep2 (n,ndim,maxnz,jcoef,coef,wksp,ier) return 15 call needw ('prep',1,iipnt,2*n+1,ier) if (ier .lt. 0) return call prep3 (n,maxnz,jcoef,jcoef(ndim+1),coef,mpart, a iwksp,iwksp(n+2)) mpstrt = iipnt iipnt = iipnt + mpart + 1 return end subroutine pointr (icall,wksp,iwksp,ier) implicit double precision (a-h, o-z) c c ... pointr adjusts pointers according to ifact. c c ... parameters -- c c icall indicates beginning or ending call c = 1 for beginning c = 2 for ending c wksp floating point workspace vector c iwksp integer workspace vector c c ... specifications for parameters c integer iwksp(1) dimension wksp(1) c c *** begin -- package common c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c c *** end -- package common c c ... data common blocks c common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c if (icall .eq. 2) go to 15 c c ... initialize pointers. c if (ifact .eq. 0) return iipnt = 1 irpnt = 1 nfactr = 0 nfacti = 0 ifactr = 1 ifacti = 1 return c c ... reset pointers for return c 15 if (ier .lt. 0) return if (nfacti .eq. 0) go to 20 call vicopy (nfacti,iwksp(ifacti),iwksp) iipnt = nfacti + 1 ifacti = 1 20 if (nfactr .eq. 0) return call vcopy (nfactr,wksp(ifactr),wksp) iwkpt2 = iwkpt2 - ifactr + 1 irpnt = nfactr + 1 ifactr = 1 return end subroutine needw (subnam,isw,istart,length,ier) implicit double precision (a-h, o-z) c c ... needw determines if enough integer or floating point c workspace is available. c c ... parameters -- c c subnam name of calling routine c isw switch for floating point or integer workspace check c = 0 floating point c = 1 integer c istart starting address c length length desired c ier error indicator (output) c = -2 insufficient floating point workspace c = -3 insufficient integer workspace c c ... specifications for parameters c character*10 subnam common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c newlen = istart + length - 1 if (isw .eq. 1) go to 10 if (lenr .ge. newlen) go to 5 ier = -2 call ershow (ier,subnam) 5 irmax = max (irmax,newlen) return 10 if (leni .ge. newlen) go to 15 ier = -3 call ershow (ier,subnam) 15 iimax = max (iimax,newlen) return end subroutine scale (coef,jcoef,wksp,icall,n,u,ubar,rhs,ier) implicit double precision (a-h, o-z) c c ... scale scales the matrix, u, ubar, and rhs. c c ... parameters -- c c icall key to indicate whether scaling (icall=1) or c unscaling (icall=2) is to be done c n order of system c u current solution estimate c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c ier error flag c = 0 no errors detected c = -4 nonpositive diagonal element c c ... specifications for parameters c integer jcoef(2) dimension rhs(1), u(1), ubar(1), coef(1), wksp(1) c c ... data common blocks c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c if (iscale .ne. 1) return go to (5,10,10,15,15), nstore 5 call scalep (coef,jcoef,wksp,icall,n,u,ubar,rhs,ier) return 10 call scaled (coef,jcoef,wksp,icall,n,u,ubar,rhs,ier) return 15 call scales (coef,jcoef,wksp,icall,n,u,ubar,rhs,ier) return end subroutine permut (coef,jcoef,p,ip,wksp,iwksp,icall,n,u, a ubar,rhs,ier) implicit double precision (a-h, o-z) c c ... permut permutes the matrix, u, ubar, and rhs. c c ... parameters -- c c icall key to indicate whether permuting (icall=1) or c unpermuting (icall=2) is to be done c n order of system c u current solution estimate c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c ier error flag c = 0 no errors detected c = -2 insufficient floating point space to permute system c = -3 insufficient integer space to permute c system c c ... specifications for parameters c integer jcoef(2), p(1), ip(1), iwksp(1) dimension rhs(1), u(1), ubar(1), coef(1), wksp(1) c c ... data common blocks c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c if (iperm .ne. 1) return go to (5,10,10,15,15), nstore 5 call permp (coef,jcoef,p,ip,wksp,iwksp, a icall,n,u,ubar,rhs,ier) return 10 call permd (coef,jcoef,p,ip,wksp,iwksp, a icall,n,u,ubar,rhs,ier) return 15 call perms (coef,jcoef,p,ip,wksp,iwksp, a icall,n,u,ubar,rhs,ier) return end subroutine elim (n,jcoef,coef,rhs,wksp,iwksp,toll) implicit double precision (a-h, o-z) c c ... elim removes rows of the matrix for which the ratio of the c sum of off-diagonal elements to the diagonal element is c small (less than tol) in absolute value. c this is to take care of matrices arising from finite c element discretizations of partial differential equations c with dirichlet boundary conditions implemented by penalty c methods. any such rows and corresponding columns are then c eliminated (set to the identity after correcting the rhs). c c ... parameter list -- c c n dimension of matrix c jcoef integer array of matrix representation c coef array of sparse matrix representation c rhs right hand side of matrix problem c wksp wksp array of length n c tol tolerance factor (= toll) c c ... specifications for arguments c common / cmpart / mpstrt, mpart common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension coef(1), rhs(1), wksp(1) c tol = toll go to (5,10,15,20,25), nstore 5 call elim1 (n,ndim,maxnz,jcoef,coef,rhs,wksp(irpnt),tol) return 10 call elim2 (n,ndim,maxnz,jcoef,coef,rhs,wksp(irpnt),tol) return 15 call elim3 (n,ndim,maxnz,jcoef,coef,rhs,wksp(irpnt),tol) return 20 call elim4 (mpart,iwksp(mpstrt),jcoef,jcoef(ndim+1), a coef,rhs,wksp(irpnt),tol) return 25 call elim5 (mpart,iwksp(mpstrt),jcoef,jcoef(ndim+1), a coef,rhs,wksp(irpnt),tol) return end subroutine scaled (coef,jcoef,wksp,icall,nn,u,ubar,rhs,ier) implicit double precision (a-h, o-z) c c ... scaled scales the matrix, u, ubar, and rhs. c (symmetric or nonsymmetric diagonal format) c c ... parameters -- c c icall key to indicate whether scaling (icall=1) or c unscaling (icall=2) is to be done c n order of system c u current solution estimate c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c ier error flag c = 0 no errors detected c = -4 nonpositive diagonal element c c ... specifications for parameters c integer jcoef(2) dimension rhs(1), u(1), ubar(1), coef(1), wksp(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d c c *** end -- package common c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c n = nn iflag = 0 if (ntest .eq. 6) iflag = 1 if (icall .eq. 2) go to 20 c c ... scale system. c c ... check for sufficient room. c call needw ('scaled',0,irpnt,n,ier) if (ier .lt. 0) return iptscl = irpnt irpnt = irpnt + n call scal2 (n,ndim,maxnz,jcoef,coef,rhs,u,ubar, a wksp(iptscl),iflag,ier) if (ier .lt. 0) call ershow (ier,'scaled') return c c ... unscale system. c 20 call uscal2 (n,ndim,maxnz,jcoef,coef,rhs,u,ubar, a wksp(iptscl),iflag) return end subroutine scalep (coef,jcoef,wksp,icall,nn,u,ubar,rhs,ier) implicit double precision (a-h, o-z) c c ... scalep scales the matrix, u, ubar, and rhs. c (purdue format) c c ... parameters -- c c icall key to indicate whether scaling (icall=1) or c unscaling (icall=2) is to be done c n order of system c u current solution estimate c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c ier error flag c = 0 no errors detected c = -4 nonpositive diagonal element c c ... specifications for parameters c integer jcoef(2) dimension rhs(1), u(1), ubar(1), coef(1), wksp(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d c c *** end -- package common c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c n = nn iflag = 0 if (ntest .eq. 6) iflag = 1 if (icall .eq. 2) go to 20 c c ... scale system. c c ... check for sufficient room. c call needw ('scalep',0,irpnt,2*n,ier) if (ier .lt. 0) return iptscl = irpnt irpnt = irpnt + n call scal1 (n,ndim,maxnz,jcoef,coef,rhs,u,ubar, a wksp(iptscl),wksp(irpnt),iflag,ier) if (ier .lt. 0) call ershow (ier,'scalep') return c c ... unscale system. c 20 call uscal1 (n,ndim,maxnz,jcoef,coef,rhs,u,ubar, a wksp(iptscl),wksp(irpnt),iflag) return end subroutine scales (coef,jcoef,wksp,icall,nn,u,ubar,rhs,ier) implicit double precision (a-h, o-z) c c ... scales scales the matrix, u, ubar, and rhs. c (sparse format) c c ... parameters -- c c icall key to indicate whether scaling (icall=1) or c unscaling (icall=2) is to be done c n order of system c u current solution estimate c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c ier error flag c = 0 no errors detected c = -4 nonpositive diagonal element c c ... specifications for parameters c integer jcoef(2) dimension rhs(1), u(1), ubar(1), coef(1), wksp(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d c c *** end -- package common c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c n = nn iflag = 0 if (ntest .eq. 6) iflag = 1 if (icall .eq. 2) go to 10 c c ... scale system. c c ... check for sufficient room. c call needw ('scales',0,irpnt,2*n,ier) if (ier .lt. 0) return iptscl = irpnt irpnt = irpnt + n call scal3 (n,maxnz,jcoef,jcoef(ndim+1),coef,rhs,u,ubar, a wksp(iptscl),wksp(irpnt),iflag,ier) if (ier .lt. 0) call ershow (ier,'scales') return c c ... unscale system. c 10 call uscal3 (n,maxnz,jcoef,jcoef(ndim+1),coef,rhs,u,ubar, a wksp(iptscl),wksp(irpnt),iflag) return end subroutine permd (coef,jcoef,p,ip,wksp,iwksp,icall,nn,u, a ubar,rhs,ier) implicit double precision (a-h, o-z) c c ... permd permutes the matrix, u, ubar, and rhs. c (diagonal format) c c ... parameters -- c c icall key to indicate whether permuting (icall=1) or c unpermuting (icall=2) is to be done c n order of system c u current solution estimate c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c ier error flag c = 0 no errors detected c = -2 insufficient floating point space to permute system c = -3 insufficient integer space to permute c system c c ... specifications for parameters c integer jcoef(2), p(1), ip(1), iwksp(1) dimension rhs(1), u(1), ubar(1), coef(1), wksp(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c c *** end -- package common c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax c n = nn if (icall .eq. 2) go to 65 c c ... permute system. c c ... check for sufficient storage to permute matrix c call needw ('permd',0,irpnt,n,ier) if (ier .lt. 0) return nc = iipnt call needw ('permd',1,nc,n,ier) if (ier .lt. 0) return call pgen (n,p,ip,iwksp(nc),ncolor) ipt = nc + ncolor ncmax = 0 do 16 i = nc,ipt-1 if (ncmax .lt. iwksp(i)) ncmax = iwksp(i) 16 continue call needw ('permd',1,ipt,ncolor+1,ier) if (ier .lt. 0) return call iptgen (ncolor,iwksp(ipt),iwksp(nc)) maxnew = ipt + ncolor + 1 jcnew = maxnew + ncolor lbhb = jcnew + ncolor*mdim call needw ('permd',1,maxnew,ncolor+ncolor*mdim+n,ier) if (ier .lt. 0) return isym = nstore - 2 call pmdg (ndim,mdim,n,maxnz,jcoef,coef,ncolor,iwksp(nc), a p,ip,maxd,iwksp(maxnew), a iwksp(jcnew),wksp(irpnt),iwksp(lbhb),isym,ier) if (ier .lt. 0) then call ershow (ier,'permd') return endif lbhb = jcnew + ncolor*maxd iblock = lbhb + ncolor call move4 (ndim,n,iwksp(maxnew),iwksp(jcnew),coef,ncolor, a iwksp(nc),wksp(irpnt),iwksp(lbhb)) call needw ('permd',1,lbhb,ncolor+3*ncolor*(maxd+1),ier) if (ier .lt. 0) return call define (ndim,iwksp(maxnew),iwksp(jcnew),coef,ncolor, a iwksp(nc),iwksp(iblock),iwksp(lbhb)) lbhbm = iwksp(lbhb) do 45 j = 1,ncolor-1 if (lbhbm .lt. iwksp(lbhb+j)) lbhbm = iwksp(lbhb+j) 45 continue is1 = iblock + 3*ncolor*lbhbm is2 = is1 + ncolor call needw ('permd',1,is1,2*ncolor,ier) if (ier .lt. 0) return call prbblk (ncolor,ncolor,iwksp(iblock),iwksp(lbhb), a iwksp(is1),iwksp(is2),propa) if (propa) ipropa = 1 if (.not. propa) ipropa = 0 iipnt = is1 call pervec (n,p,rhs,wksp(irpnt)) call pervec (n,p,u,wksp(irpnt)) if (ntest .eq. 6) call pervec (n,p,ubar,wksp(irpnt)) return c c ... unpermute system. c 65 call needw ('permd',1,iipnt,2*n,ier) if (ier .lt. 0) return isym = nstore - 2 call unpmdg (ndim,n,maxnz,jcoef,coef,ncolor,iwksp(nc), a p,ip,maxd,iwksp(maxnew), a iwksp(jcnew),wksp(irpnt),iwksp(iipnt),isym) call pervec (n,ip,rhs,wksp(irpnt)) call pervec (n,ip,u,wksp(irpnt)) if (ntest .eq. 6) call pervec (n,ip,ubar,wksp(irpnt)) return end subroutine permp (coef,jcoef,p,ip,wksp,iwksp,icall,nn,u, a ubar,rhs,ier) implicit double precision (a-h, o-z) c c ... permp permutes the matrix, u, ubar, and rhs. c (purdue format) c c ... parameters -- c c icall key to indicate whether permuting (icall=1) or c unpermuting (icall=2) is to be done c n order of system c u current solution estimate c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c ier error flag c = 0 no errors detected c = -2 insufficient floating point space to permute c system c = -3 insufficient integer space to permute c system c c ... specifications for parameters c integer jcoef(2), p(1), ip(1), iwksp(1) dimension rhs(1), u(1), ubar(1), coef(1), wksp(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d c c *** end -- package common c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise c n = nn if (icall .eq. 2) go to 40 c c ... permute system. c c ... check for sufficient storage to permute matrix c call needw ('permp',0,irpnt,n,ier) if (ier .lt. 0) return nc = iipnt call needw ('permp',1,nc,n,ier) if (ier .lt. 0) return call pgen (n,p,ip,iwksp(nc),ncolor) ipt = nc + ncolor ncmax = 0 do 20 i = nc,ipt-1 if (ncmax .lt. iwksp(i)) ncmax = iwksp(i) 20 continue call needw ('permp',1,ipt,ncolor+1,ier) if (ier .lt. 0) return call iptgen (ncolor,iwksp(ipt),iwksp(nc)) iipnt = iipnt + 2*ncolor + 1 call needw ('permp',1,iipnt,n,ier) if (ier .lt. 0) return call permat (ndim,maxnz,coef,jcoef, a wksp(irpnt),iwksp(iipnt),n,p) call needw ('permp',1,iipnt,2*ncolor,ier) if (ier .lt. 0) return ndt = iipnt ndb = iipnt + ncolor call move3 (ndim,mdim,n,maxnz,jcoef,coef,iwksp(ndt), a iwksp(ndb),ncolor,iwksp(nc),ier) iipnt = iipnt + 2*ncolor if (ier .lt. 0) then call ershow (ier,'permp') return endif call pervec (n,p,rhs,wksp(irpnt)) call pervec (n,p,u,wksp(irpnt)) if (ntest .eq. 6) call pervec (n,p,ubar,wksp(irpnt)) return c c ... unpermute system. c 40 call needw ('permp',0,irpnt,n,ier) if (ier .lt. 0) return call needw ('permp',1,iipnt,n,ier) if (ier .lt. 0) return call permat (ndim,maxnz,coef,jcoef, a wksp(irpnt),iwksp(iipnt),n,ip) call pervec (n,ip,rhs,wksp(irpnt)) call pervec (n,ip,u,wksp(irpnt)) if (ntest .eq. 6) call pervec (n,ip,ubar,wksp(irpnt)) return end subroutine perms (coef,jcoef,p,ip,wksp,iwksp,icall,nn,u, a ubar,rhs,ier) implicit double precision (a-h, o-z) c c ... perms permutes the matrix, u, ubar, and rhs. c (sparse format) c c ... parameters -- c c icall key to indicate whether permuting (icall=1) or c unpermuting (icall=2) is to be done c n order of system c u current solution estimate c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c ier error flag c = 0 no errors detected c = -2 insufficient floating point space to permute c system c = -3 insufficient integer space to permute c system c c ... specifications for parameters c integer jcoef(2), p(1), ip(1), iwksp(1) dimension rhs(1), u(1), ubar(1), coef(1), wksp(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d c c *** end -- package common c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c n = nn isym = 0 if (nstore .eq. 5) isym = 1 if (icall .eq. 2) go to 10 c c ... permute system. c c ... check for sufficient storage to permute matrix c call needw ('perms',0,irpnt,n,ier) if (ier .lt. 0) return call needw ('perms',1,iipnt,n,ier) if (ier .lt. 0) return call pgen (n,p,ip,iwksp(iipnt),ncolor) call permas (isym,n,maxnz,jcoef,jcoef(ndim+1), a coef,wksp(irpnt),p) call pervec (n,p,rhs,wksp(irpnt)) call pervec (n,p,u,wksp(irpnt)) if (ntest .eq. 6) call pervec (n,p,ubar,wksp(irpnt)) return c c ... unpermute system. c 10 call needw ('perms',0,irpnt,n,ier) if (ier .lt. 0) return call needw ('perms',1,iipnt,n,ier) if (ier .lt. 0) return call permas (isym,n,maxnz,jcoef,jcoef(ndim+1), a coef,wksp(irpnt),ip) call pervec (n,ip,rhs,wksp(irpnt)) call pervec (n,ip,u,wksp(irpnt)) if (ntest .eq. 6) call pervec (n,ip,ubar,wksp(irpnt)) return end subroutine rsprep (coef,jcoef,wksp,iwksp,nn,rhs,u,ubar, a p,ip,nrr,irs,ijcrs,irsrhs,ier) implicit double precision (a-h, o-z) c c ... rsprep is the preprocessor for methods using the c explicitly-computed reduced system. c c ... parameters -- c c coef floating point matrix data array c jcoef integer matrix data array c n input integer. order of the system (= nn) c rhs input vector. contains the right hand side c of the matrix problem. c u current solution estimate c ubar exact solution vector (if known) c nr order of the reduced system upon output c irs pointer into wksp for reduced system matrix c ijcrs pointer into wksp for reduced system integer c array c irsrhs pointer into wksp for reduced system rhs c ier output integer. error flag. c c ... specifications for parameters c integer jcoef(2), iwksp(1), p(1), ip(1) dimension coef(1), rhs(1), u(1), ubar(1), wksp(1) c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / rscons / ndimrs, mdimrs, maxzrs c n = nn c c ... permute matrix. c call permut (coef,jcoef,p,ip,wksp,iwksp,1, a n,u,ubar,rhs,ier) if (ier .lt. 0) return c c ... form reduced system matrix. c nr = iwksp(nc) nb = iwksp(nc+1) irs = irpnt ijcrs = iipnt length = lenr - irpnt + 1 call vfill (length,wksp(irpnt),0.0d0) if (nstore .ge. 2) go to 30 c c ... purdue storage. c call needw ('rsprep',0,irpnt,3*nr,ier) if (ier .lt. 0) return call needw ('rsprep',1,iipnt,2*nr,ier) if (ier .lt. 0) return lim1 = (lenr - 2*nr - irpnt + 1)/nr lim2 = (leni - nr - iipnt + 1)/nr maxlim = min(lim1,lim2) ip1 = irpnt + nr*maxlim ip2 = iipnt + nr*maxlim call rsmatp (ndim,nr,maxnz,jcoef,coef,maxrs,iwksp(ijcrs), a wksp(irs),maxlim,wksp(ip1),iwksp(ip2),ier) if (ier .lt. 0) then call ershow (ier,'rsprep') return endif irpnt = irpnt + nr*maxrs iipnt = iipnt + nr*maxrs go to 45 c c ... diagonal storage. c 30 call needw ('rsprep',0,irpnt,nr,ier) if (ier .lt. 0) return call needw ('rsprep',1,iipnt,nr,ier) if (ier .lt. 0) return maxlim = length/nr isym = 0 if (nstore .eq. 3) isym = 1 call rsmatd (ndim,nr,nb,iwksp(maxnew),iwksp(jcnew),coef, a coef(ndim+1),coef(nr+ndim+1),coef(nr+1),maxrs, a iwksp(ijcrs),wksp(irs),maxlim,isym,ier) if (ier .lt. 0) then call ershow (ier,'rsprep') return endif irpnt = irpnt + nr*maxrs iipnt = iipnt + maxrs c c ... form reduced system rhs. c 45 irsrhs = irpnt ip1 = irpnt + nr call needw ('rsprep',0,irpnt,n+nr,ier) if (ier .lt. 0) return if (nstore .eq. 1) call rsbegp (n,nr,ndim,maxnz,jcoef, a coef,wksp(irsrhs),rhs,wksp(ip1)) if (nstore .ge. 2) call rsrhsd (n,nr,ndim,iwksp(maxnew), a iwksp(jcnew),coef,wksp(irsrhs),rhs, a wksp(ip1)) irpnt = irpnt + nr c c ... update constants. c ndimrs = ndim mdimrs = mdim maxzrs = maxnz ndim = nr mdim = maxrs maxnz = maxrs nrr = nr return end subroutine rspost (coef,jcoef,wksp,iwksp,nn,rhs,u,ubar, a p,ip,nrr,irs,ijcrs,ier) implicit double precision (a-h, o-z) c c ... rspost is the postprocessor for methods using the c explicitly-computed reduced system. c c ... parameters -- c c coef floating point matrix data array c jcoef integer matrix data array c n input integer. order of the system (= nn) c rhs input vector. contains the right hand side c of the matrix problem. c u current solution estimate c ubar exact solution vector (if known) c nr order of the reduced system upon input c irs pointer into wksp for reduced system matrix c ijcrs pointer into wksp for reduced system integer c array c ier output integer. error flag. c c ... specifications for parameters c integer jcoef(2), iwksp(1), p(1), ip(1) dimension coef(1), rhs(1), u(1), ubar(1), wksp(1) c c ... data common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / rscons / ndimrs, mdimrs, maxzrs c n = nn nr = nrr nb = n - nr c c ... update constants. c ndim = ndimrs mdim = mdimrs maxnz = maxzrs irpnt = irs iipnt = ijcrs c c ... compute xb. c call needw ('rspost',0,irpnt,nb,ier) if (ier .lt. 0) return if (nstore .eq. 1) call rsendp (n,nr,ndim,maxnz,jcoef, a coef,u,rhs,wksp(irpnt)) if (nstore .ge. 2) call rsxbd (n,nr,ndim,iwksp(maxnew), a iwksp(jcnew),coef,u,rhs) c c ... unpermute matrix. c call permut (coef,jcoef,p,ip,wksp,iwksp,2, a n,u,ubar,rhs,ier) if (ier .lt. 0) return return end subroutine redblk (ndim,n,maxnz,coef,jcoef,p,ip,nstore, a iwksp,ier) implicit double precision (a-h, o-z) c c ... redblk determines if the matrix has property a. c c ... parameters -- c c n problem size c nstore storage mode c = 1 purdue format c = 2 symmetric diagonal format c = 3 nonsymmetric diagonal format c = 4 symmetric sparse format c = 5 nonsymmetric sparse format c iwksp integer workspace vector of length n c ier error code c = 0 no errors detected c = -8 matrix does not have property a c c ... common blocks c integer jcoef(2), p(1), ip(1), iwksp(1) dimension coef(1) logical propal c go to (5,5,5,10,10), nstore 5 call prbndx (n,ndim,maxnz,jcoef,coef,p,ip,propal,nstore) go to 15 10 call bicol (n,maxnz,jcoef,jcoef(ndim+1),p,ip,iwksp,propal) 15 if (propal) ier = 0 if (.not. propal) ier = -8 if (propal) return call ershow (ier,'redblk') return end subroutine noadp (coef,jcoef,wksp,iwksp,n,p,r,pdp,pldup) implicit double precision (a-h, o-z) c c ... noadp is a dummy routine to do no adaption. c c ... specifications for parameters c c integer jcoef(2), iwksp(1) dimension p(1), r(1), coef(1), wksp(1) c return end subroutine copy (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... copy does a vector copy (null preconditioner) c integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c do 10 i = 1,n 10 z(i) = r(i) return end subroutine split (accel,suba,subat,subq,subqt,subql,subqlt, a subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... split determines how to apply the splitting based on c iqlr. c external accel, suba, subat, subq, subqt, subql, subqlt, a subqr, subqrt, subadp, copy integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d c c *** end -- package common c if (iqlr .eq. 0) then call accel (suba,subat,copy,copy,copy,copy,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,jer) endif if (iqlr .eq. 1) then call accel (suba,subat,subq,subqt,copy,copy,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,jer) endif if (iqlr .eq. 2) then call accel (suba,subat,copy,copy,subq,subqt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,jer) endif if (iqlr .eq. 3) then call accel (suba,subat,subql,subqlt,subqr,subqrt, a subadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,jer) endif if (jer .ne. 0) ier = jer return end subroutine rich1 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... rich1 drives the richardson preconditioner. c external accel, suba8, suba9, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom4 / srelpr, keyzer, keygs c iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + n call split (accel,suba8,suba9,copy,copy,copy,copy, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm, a ier) if (keygs .eq. 1) irpnt = irpnt - n return end subroutine jac1 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... jac1 drives the jacobi preconditioner. c external accel, suba8, suba9, subq1, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom4 / srelpr, keyzer, keygs c iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + n call split (accel,suba8,suba9,subq1,subq1,subq1,subq1, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) if (keygs .eq. 1) irpnt = irpnt - n return end subroutine sor1 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... sor1 drives the point sor method. c external accel, suba8, suba9, subq78, noadp, copy integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c iwkpt1 = irpnt irpnt = irpnt + n call move1 (ndim,mdim,n,maxnz,jcoef,coef,maxt,maxb,ier) if (ier .lt. 0) then call ershow (ier,'sor1') return endif call split (accel,suba8,suba9,subq78,subq78,subq78,subq78, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine ssor1 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ssor1 drives the point ssor method. c external accel, suba8, suba9, subq79, subq80, subq81, subq82, a subq83, subq84, subq85 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c n = nn iwkpt1 = irpnt irpnt = irpnt + n if (isymm .ne. 0) irpnt = irpnt + n call move1 (ndim,mdim,n,maxnz,jcoef,coef,maxt,maxb,ier) if (ier .lt. 0) then call ershow (ier,'ssor1') return endif call split (accel,suba8,suba9,subq79,subq80,subq81,subq82, a subq83,subq84,subq85, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) if (isymm .ne. 0) irpnt = irpnt - n irpnt = irpnt - n return end subroutine ic1 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ic1 drives the ic preconditioner. c external accel, suba8, suba9, subq86, subq87, subq88, a subq89, subq90, subq91, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c c n = nn if (ifact .eq. 0 .and. lvfill .gt. 0) go to 20 call move1 (ndim,mdim,n,maxnz,jcoef,coef,maxt,maxb,ier) if (ier .lt. 0) then call ershow (ier,'ic1') return endif 20 t1 = timer (dummy) if (ifact .eq. 1) call pfact1 (coef,jcoef,wksp,iwksp,n,1,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba8,suba9,subq86,subq87,subq88,subq89, a subq90,subq91,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine mic1 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... mic1 drives the mic preconditioner. c external accel, suba8, suba9, subq86, subq87, subq88, a subq89, subq90, subq91, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c c n = nn if (ifact .eq. 0 .and. lvfill .gt. 0) go to 20 call move1 (ndim,mdim,n,maxnz,jcoef,coef,maxt,maxb,ier) if (ier .lt. 0) then call ershow (ier,'mic1') return endif 20 t1 = timer (dummy) if (ifact .eq. 1) call pfact1 (coef,jcoef,wksp,iwksp,n,2,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba8,suba9,subq86,subq87,subq88,subq89, a subq90,subq91,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine lsp1 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lsp1 drives the least squares polynomial preconditioner. c external accel, suba8, suba9, subq92, subq93, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / itcom8 / ainf common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom4 / srelpr, keyzer, keygs c n = nn call needw ('lsp1',0,irpnt,2*n,ier) if (ier .lt. 0) return call ainfn (n,ndim,maxnz,jcoef,coef,1,ainf,wksp(irpnt)) iwkpt2 = irpnt irpnt = irpnt + 2*n iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + n call split (accel,suba8,suba9,subq92,subq93,subq92,subq93, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n if (keygs .eq. 1) irpnt = irpnt - n return end subroutine neu1 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... neu1 drives the neumann polynomial preconditioner. c external accel, suba8, suba9, subq94, subq95, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom4 / srelpr, keyzer, keygs c n = nn call needw ('neu1',0,irpnt,n,ier) if (ier .lt. 0) return iwkpt2 = irpnt irpnt = irpnt + n iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + n call split (accel,suba8,suba9,subq94,subq95,subq94,subq95, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n if (keygs .eq. 1) irpnt = irpnt - n return end subroutine rich2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... rich2 drives the richardson preconditioner. c external accel, suba1, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c call split (accel,suba1,suba1,copy,copy,copy,copy, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine jac2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... jac2 drives the jacobi preconditioner. c external accel, suba1, subq1, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c call split (accel,suba1,suba1,subq1,subq1,subq1,subq1, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine ljac2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ljac2 drives the line jacobi preconditioner. c external accel, suba1, subq2, noadp, copy integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c t1 = timer (dummy) if (ifact .eq. 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call split (accel,suba1,suba1,subq2,subq2,subq2,subq2, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine ljacx2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ljacx2 drives the line jacobi preconditioner. c external accel, suba1, subq4, noadp, copy integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c t1 = timer (dummy) if (ifact .eq. 1) call linv (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call split (accel,suba1,suba1,subq4,subq4,subq4,subq4, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine sor2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... sor2 drives the point sor method. c external accel, suba1, subq6, noadp, copy integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c call rowise (maxnz,jcoef,irwise) call needw ('sor2',1,iipnt,maxnz,ier) if (ier .lt. 0) return iwkpt1 = iipnt iipnt = iipnt + maxnz call split (accel,suba1,suba1,subq6,subq6,subq6,subq6, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) iipnt = iipnt - maxnz return end subroutine ssor2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ssor2 drives the point ssor method. c external accel, suba1, subq7, subq8, subq9, subq10, a subq11, subq12 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c call rowise (maxnz,jcoef,irwise) call needw ('ssor2',1,iipnt,maxnz,ier) if (ier .lt. 0) return iwkpt1 = iipnt iipnt = iipnt + maxnz call split (accel,suba1,suba1,subq7,subq7,subq8,subq9, a subq10,subq11,subq12, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) iipnt = iipnt - maxnz return end subroutine ic2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ic2 drives the symmetric ic preconditioner. c external accel, suba1, subq13, subq14, subq15, subq16, a subq17, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c c t1 = timer (dummy) if (ifact .eq. 1) call pfact2 (coef,jcoef,wksp,iwksp,n,1,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return leniw = max (maxnz,nfacti) iwkpt1 = iipnt iipnt = iipnt + leniw call split (accel,suba1,suba1,subq13,subq13,subq14,subq15, a subq16,subq17,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) iipnt = iipnt - leniw return end subroutine mic2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... mic2 drives the symmetric mic preconditioner. c external accel, suba1, subq13, subq14, subq15, subq16, a subq17, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c c t1 = timer (dummy) if (ifact .eq. 1) call pfact2 (coef,jcoef,wksp,iwksp,n,2,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return leniw = max (maxnz,nfacti) iwkpt1 = iipnt iipnt = iipnt + leniw call split (accel,suba1,suba1,subq13,subq13,subq14,subq15, a subq16,subq17,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) iipnt = iipnt - leniw return end subroutine lsp2 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lsp2 drives the least squares polynomial preconditioner. c external accel, suba1, subq18, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / itcom8 / ainf common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c n = nn call needw ('lsp2',0,irpnt,2*n,ier) if (ier .lt. 0) return call ainfn (n,ndim,maxnz,jcoef,coef,2,ainf,wksp(irpnt)) iwkpt1 = irpnt irpnt = irpnt + 2*n call split (accel,suba1,suba1,subq18,subq18,subq18,subq18, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine neu2 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... neu2 drives the neumann polynomial preconditioner. c external accel, suba1, subq19, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c n = nn call needw ('neu2',0,irpnt,n,ier) if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba1,suba1,subq19,subq19,subq19,subq19, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine lsor2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lsor2 drives the line sor method. c external accel, suba1, subq20, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call split (accel,suba1,suba1,subq20,subq20,subq20,subq20, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine lssor2 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lssor2 drives the line ssor method. c external accel, suba1, subq21, subq22, copy integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c n = nn call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + n if (ier .lt. 0) return call split (accel,suba1,suba1,subq21,subq21,subq21,subq21, a copy,copy,subq22, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine bic2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... bic2 drives the block factorization (version 1) method. c external accel, suba1, subq25, copy, noadp external ibfcs1 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call bfacs (1,ibfcs1,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + kblsz if (ier .lt. 0) return call split (accel,suba1,suba1,subq25,subq25,subq25,subq25, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - kblsz return end subroutine mbic2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... mbic2 drives the block factorization (version 1, modified) c method. c external accel, suba1, subq25, copy, noadp external ibfcs3 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call bfacs (2,ibfcs3,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + kblsz if (ier .lt. 0) return call split (accel,suba1,suba1,subq25,subq25,subq25,subq25, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - kblsz return end subroutine bicx2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... bicx2 drives the block factorization (version 2) method. c external accel, suba1, subq25, copy, noadp external ibfcs2 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call bfacs (3,ibfcs2,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + kblsz if (ier .lt. 0) return call split (accel,suba1,suba1,subq25,subq25,subq25,subq25, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - kblsz return end subroutine mbicx2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... mbicx2 drives the block factorization (version 2, modified) c method. c external accel, suba1, subq25, copy, noadp external ibfcs4 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call bfacs (4,ibfcs4,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + kblsz if (ier .lt. 0) return call split (accel,suba1,suba1,subq25,subq25,subq25,subq25, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - kblsz return end subroutine llsp2 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... llsp2 drives the line least squares polynomial preconditioner. c external accel, suba1, subq23, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / itcom8 / ainf common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c n = nn call needw ('llsp2',0,irpnt,n,ier) if (ier .lt. 0) return call adinfn (n,ndim,maxnz,jcoef,coef,2,ainf,wksp(irpnt)) t1 = timer (dummy) if (ifact .eq. 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call needw ('llsp2',0,irpnt,2*n,ier) if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*n call split (accel,suba1,suba1,subq23,subq23,subq23,subq23, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine lneu2 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lneu2 drives the line neumann polynomial preconditioner. c external accel, suba1, subq24, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c n = nn t1 = timer (dummy) if (ifact .eq. 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call needw ('lneu2',0,irpnt,2*n,ier) if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*n call split (accel,suba1,suba1,subq24,subq24,subq24,subq24, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine rich3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... rich3 drives the richardson preconditioner. c external accel, suba4, suba5, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c call split (accel,suba4,suba5,copy,copy,copy,copy, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine jac3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... jac3 drives the jacobi preconditioner. c external accel, suba4, suba5, subq1, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c call split (accel,suba4,suba5,subq1,subq1,subq1,subq1, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine ljac3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ljac3 drives the line jacobi preconditioner. c external accel, suba4, suba5, subq2, subq3, noadp, copy integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c t1 = timer (dummy) if (ifact .eq. 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call split (accel,suba4,suba5,subq2,subq3,subq2,subq3, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine ljacx3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ljacx3 drives the line jacobi preconditioner. c external accel, suba4, suba5, subq4, subq5, noadp, copy integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c t1 = timer (dummy) if (ifact .eq. 1) call linv (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call split (accel,suba4,suba5,subq4,subq5,subq4,subq5, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine sor3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... sor3 drives the point sor method. c external accel, suba4, suba5, subq40, noadp, copy integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c call rowise (maxnz,jcoef,irwise) call needw ('sor3',1,iipnt,maxnz,ier) if (ier .lt. 0) return call needw ('sor3',0,irpnt,n,ier) if (ier .lt. 0) return call move2 (ndim,n,maxnz,jcoef,coef,wksp(irpnt), a iwksp(iipnt),maxt,maxb) iwkpt1 = iipnt iipnt = iipnt + maxnz call split (accel,suba4,suba5,subq40,subq40,subq40,subq40, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) iipnt = iipnt - maxnz return end subroutine ssor3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ssor3 drives the point ssor method. c external accel, suba4, suba5, subq41, subq42, subq43, subq44, a subq45, subq46, subq47 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c n = nn call rowise (maxnz,jcoef,irwise) call needw ('ssor3',1,iipnt,maxnz,ier) if (ier .lt. 0) return call needw ('ssor3',0,irpnt,n,ier) if (ier .lt. 0) return call move2 (ndim,n,maxnz,jcoef,coef,wksp(irpnt), a iwksp(iipnt),maxt,maxb) iwkpt1 = irpnt irpnt = irpnt + n iwkpt2 = iipnt iipnt = iipnt + maxnz call split (accel,suba4,suba5,subq41,subq42,subq43,subq44, a subq45,subq46,subq47, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n iipnt = iipnt - maxnz return end subroutine ic3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ic3 drives the nonsymmetric ic preconditioner. c external accel, suba4, suba5, subq48, subq49, subq50, a subq51, subq52, subq53, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c c n = nn call needw ('ic3',1,iipnt,maxnz,ier) if (ier .lt. 0) return call needw ('ic3',0,irpnt,n,ier) if (ier .lt. 0) return if (ifact .eq. 0 .and. lvfill .gt. 0) go to 20 call move2 (ndim,n,maxnz,jcoef,coef,wksp(irpnt), a iwksp(iipnt),maxt,maxb) 20 t1 = timer (dummy) if (ifact .eq. 1) call pfact3 (coef,jcoef,wksp,iwksp,n,1,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return leniw = max (maxnz,nfacti) iwkpt1 = iipnt iipnt = iipnt + leniw call split (accel,suba4,suba5,subq48,subq49,subq50,subq51, a subq52,subq53,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) iipnt = iipnt - leniw return end subroutine mic3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... mic3 drives the nonsymmetric mic preconditioner. c external accel, suba4, suba5, subq48, subq49, subq50, a subq51, subq52, subq53, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c c n = nn call needw ('mic3',1,iipnt,maxnz,ier) if (ier .lt. 0) return call needw ('mic3',0,irpnt,n,ier) if (ier .lt. 0) return if (ifact .eq. 0 .and. lvfill .gt. 0) go to 20 call move2 (ndim,n,maxnz,jcoef,coef,wksp(irpnt), a iwksp(iipnt),maxt,maxb) 20 t1 = timer (dummy) if (ifact .eq. 1) call pfact3 (coef,jcoef,wksp,iwksp,n,2,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return leniw = max (maxnz,nfacti) iwkpt1 = iipnt iipnt = iipnt + leniw call split (accel,suba4,suba5,subq48,subq49,subq50,subq51, a subq52,subq53,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) iipnt = iipnt - leniw return end subroutine lsp3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lsp3 drives the least squares polynomial preconditioner. c external accel, suba4, suba5, subq54, subq55, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / itcom8 / ainf common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c n = nn call needw ('lsp3',0,irpnt,2*n,ier) if (ier .lt. 0) return call ainfn (n,ndim,maxnz,jcoef,coef,3,ainf,wksp(irpnt)) iwkpt1 = irpnt irpnt = irpnt + 2*n call split (accel,suba4,suba5,subq54,subq55,subq54,subq55, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine neu3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... neu3 drives the neumann polynomial preconditioner. c external accel, suba4, suba5, subq56, subq57, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c n = nn call needw ('neu3',0,irpnt,n,ier) if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba4,suba5,subq56,subq57,subq56,subq57, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine lsor3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lsor3 drives the line sor method. c external accel, suba4, suba5, subq58, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call split (accel,suba4,suba5,subq58,subq58,subq58,subq58, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine lssor3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lssor3 drives the line ssor method. c external accel, suba4, suba5, subq59, subq60, subq61, a subq62, subq63, subq64, subq65 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c n = nn call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + n if (ier .lt. 0) return call split (accel,suba4,suba5,subq59,subq60,subq61,subq62, a subq63,subq64,subq65, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine bic3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... bic3 drives the block factorization (version 1) method. c external accel, suba4, suba5, subq70, subq71, subq72, a subq73, subq74, subq75, noadp external ibfcn1 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call bfacmz (1,ibfcn1,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*kblsz call split (accel,suba4,suba5,subq70,subq71,subq72,subq73, a subq74,subq75,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*kblsz return end subroutine mbic3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... mbic3 drives the block factorization (version 1, modified) c method. c external accel, suba4, suba5, subq70, subq71, subq72, a subq73, subq74, subq75, noadp external ibfcn3 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call bfacmz (2,ibfcn3,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*kblsz call split (accel,suba4,suba5,subq70,subq71,subq72,subq73, a subq74,subq75,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*kblsz return end subroutine bicx3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... bicx3 drives the block factorization (version 2) c method. c external accel, suba4, suba5, subq70, subq71, subq72, a subq73, subq74, subq75, noadp external ibfcn2 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call bfacmz (3,ibfcn2,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*kblsz call split (accel,suba4,suba5,subq70,subq71,subq72,subq73, a subq74,subq75,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*kblsz return end subroutine mbicx3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... mbicx3 drives the block factorization (version 2, modified) c method. c external accel, suba4, suba5, subq70, subq71, subq72, a subq73, subq74, subq75, noadp external ibfcn4 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier .lt. 0) return t1 = timer (dummy) if (ifact .eq. 1) call bfacmz (4,ibfcn4,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*kblsz call split (accel,suba4,suba5,subq70,subq71,subq72,subq73, a subq74,subq75,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*kblsz return end subroutine llsp3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... llsp3 drives the line least squares polynomial preconditioner. c external accel, suba4, suba5, subq66, subq67, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / itcom8 / ainf common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c n = nn call needw ('llsp3',0,irpnt,n,ier) if (ier .lt. 0) return call adinfn (n,ndim,maxnz,jcoef,coef,3,ainf,wksp(irpnt)) t1 = timer (dummy) if (ifact .eq. 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call needw ('llsp3',0,irpnt,2*n,ier) if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*n call split (accel,suba4,suba5,subq66,subq67,subq66,subq67, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine lneu3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lneu3 drives the line neumann polynomial preconditioner. c external accel, suba4, suba5, subq68, subq69, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c n = nn t1 = timer (dummy) if (ifact .eq. 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call needw ('lneu3',0,irpnt,2*n,ier) if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*n call split (accel,suba4,suba5,subq68,subq69,subq68,subq69, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine rich4 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... rich4 drives the richardson preconditioner. c external accel, suba12, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom4 / srelpr, keyzer, keygs c iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + 2*n call split (accel,suba12,suba12,copy,copy,copy,copy, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) if (keygs .eq. 1) irpnt = irpnt - 2*n return end subroutine jac4 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... jac4 drives the jacobi preconditioner. c external accel, suba12, subq1, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom4 / srelpr, keyzer, keygs c iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + 2*n call split (accel,suba12,suba12,subq1,subq1,subq1,subq1, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) if (keygs .eq. 1) irpnt = irpnt - 2*n return end subroutine lsp4 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lsp4 drives the least squares polynomial preconditioner. c external accel, suba12, sub110, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / itcom8 / ainf common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom4 / srelpr, keyzer, keygs c n = nn call needw ('lsp4',0,irpnt,2*n,ier) if (ier .lt. 0) return call ainfn (n,ndim,maxnz,jcoef,coef,4,ainf,wksp(irpnt)) iwkpt2 = irpnt irpnt = irpnt + 2*n iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + 2*n call split (accel,suba12,suba12,sub110,sub110,sub110,sub110, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n if (keygs .eq. 1) irpnt = irpnt - 2*n return end subroutine neu4 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... neu4 drives the neumann polynomial preconditioner. c external accel, suba12, sub111, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom4 / srelpr, keyzer, keygs c n = nn call needw ('neu4',0,irpnt,n,ier) if (ier .lt. 0) return iwkpt2 = irpnt irpnt = irpnt + n iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + 2*n call split (accel,suba12,suba12,sub111,sub111,sub111,sub111, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n if (keygs .eq. 1) irpnt = irpnt - 2*n return end subroutine rich5 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... rich5 drives the richardson preconditioner. c external accel, suba13, suba14, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom4 / srelpr, keyzer, keygs c iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + 2*n call split (accel,suba13,suba14,copy,copy,copy,copy, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) if (keygs .eq. 1) irpnt = irpnt - 2*n return end subroutine jac5 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... jac5 drives the jacobi preconditioner. c external accel, suba13, suba14, subq1, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom4 / srelpr, keyzer, keygs c iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + 2*n call split (accel,suba13,suba14,subq1,subq1,subq1,subq1, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) if (keygs .eq. 1) irpnt = irpnt - 2*n return end subroutine lsp5 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... lsp5 drives the least squares polynomial preconditioner. c external accel, suba13, suba14, sub112, sub113, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / itcom8 / ainf common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom4 / srelpr, keyzer, keygs c n = nn call needw ('lsp5',0,irpnt,2*n,ier) if (ier .lt. 0) return call ainfn (n,ndim,maxnz,jcoef,coef,5,ainf,wksp(irpnt)) iwkpt2 = irpnt irpnt = irpnt + 2*n iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + 2*n call split (accel,suba13,suba14,sub112,sub113,sub112,sub113, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n if (keygs .eq. 1) irpnt = irpnt - 2*n return end subroutine neu5 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... neu5 drives the neumann polynomial preconditioner. c external accel, suba13, suba14, sub114, sub115, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom4 / srelpr, keyzer, keygs c n = nn call needw ('neu5',0,irpnt,n,ier) if (ier .lt. 0) return iwkpt2 = irpnt irpnt = irpnt + n iwkpt1 = irpnt if (keygs .eq. 1) irpnt = irpnt + 2*n call split (accel,suba13,suba14,sub114,sub115,sub114,sub115, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n if (keygs .eq. 1) irpnt = irpnt - 2*n return end subroutine sor6 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... sor6 drives the multi-color sor method. c external accel, suba8, subq96, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba8,suba8,subq96,subq96,subq96,subq96, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine ssor6 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ssor6 drives the multi-color ssor method. c external accel, suba8, suba9, subq97, subq98, subq99, sub100, a sub101, sub102, sub103 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax c iwkpt1 = irpnt irpnt = irpnt + n + ncmax call split (accel,suba8,suba9,subq97,subq98,subq99,sub100, a sub101,sub102,sub103, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n - ncmax return end subroutine ic6 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ic6 drives the ic preconditioner. c (multi-color ordering) c external accel, suba8, suba9, sub104, sub105, sub106, a sub107, sub108, sub109, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c c n = nn t1 = timer (dummy) if (ifact .eq. 1) call pfactc (coef,jcoef,wksp,iwksp,n,1,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba8,suba9,sub104,sub105,sub106,sub107, a sub108,sub109,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine mic6 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... mic6 drives the mic preconditioner. c (multi-color ordering) c external accel, suba8, suba9, sub104, sub105, sub106, a sub107, sub108, sub109, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c c n = nn t1 = timer (dummy) if (ifact .eq. 1) call pfactc (coef,jcoef,wksp,iwksp,n,2,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba8,suba9,sub104,sub105,sub106,sub107, a sub108,sub109,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine rs6 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... rs6 drives the reduced system method (purdue storage c with red-black coloring). c external accel, suba10, suba11, subq1, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c n = nn c c ... compute red-black rhs. c nr = iwksp(nc) nb = n - nr call needw ('rs6',0,irpnt,2*n,ier) if (ier .lt. 0) return irhs = irpnt irpnt = irpnt + nr call vfill (2*n,wksp(irhs),0.0d0) call rsbegp (n,nr,ndim,maxnz,jcoef,coef,wksp(irhs),rhs, a wksp(irpnt)) iwkpt1 = irpnt irpnt = irpnt + n + nb call split (accel,suba10,suba11,subq1,subq1,subq1,subq1, a copy,copy,noadp, a coef,jcoef,nr,u,ubar,wksp(irhs),wksp,iwksp, a iparm,rparm,ier) call rsendp (n,nr,ndim,maxnz,jcoef,coef,u,rhs,wksp(iwkpt1)) irpnt = irpnt - 2*n return end subroutine sor7 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... sor7 drives the multi-color sor method. c external accel, suba2, subq26, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac c t1 = timer (dummy) if (ifact .eq. 1) call mfact (coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return call split (accel,suba2,suba2,subq26,subq26,subq26,subq26, a copy,copy,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine ssor7 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... ssor7 drives the multi-color ssor method. c external accel, suba2, suba3, subq27, subq28, subq29, a subq30, subq31, subq32, subq33 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c n = nn t1 = timer (dummy) if (ifact .eq. 1) call mfact (coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba2,suba3,subq27,subq28,subq29,subq30, a subq31,subq32,subq33, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine bic7 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... bic7 drives the block factorization (version 1) method. c (multi-color ordering) c external accel, suba2, suba3, subq34, subq35, subq36, a subq37, subq38, subq39, noadp external ibfcn1 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c t1 = timer (dummy) if (ifact .eq. 1) call bfacmy (1,ibfcn1,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*ncmax call split (accel,suba2,suba3,subq34,subq35,subq36,subq37, a subq38,subq39,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*ncmax return end subroutine mbic7 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... mbic7 drives the block factorization (version 1, modified) c method (multi-color ordering) c external accel, suba2, suba3, subq34, subq35, subq36, a subq37, subq38, subq39, noadp external ibfcn3 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c t1 = timer (dummy) if (ifact .eq. 1) call bfacmy (2,ibfcn3,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*ncmax call split (accel,suba2,suba3,subq34,subq35,subq36,subq37, a subq38,subq39,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*ncmax return end subroutine bicx7 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... bicx7 drives the block factorization (version 2) c method (multi-color ordering) c external accel, suba2, suba3, subq34, subq35, subq36, a subq37, subq38, subq39, noadp external ibfcn2 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c t1 = timer (dummy) if (ifact .eq. 1) call bfacmy (3,ibfcn2,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*ncmax call split (accel,suba2,suba3,subq34,subq35,subq36,subq37, a subq38,subq39,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*ncmax return end subroutine mbicx7 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... mbicx7 drives the block factorization (version 2, modified) c method (multi-color ordering) c external accel, suba2, suba3, subq34, subq35, subq36, a subq37, subq38, subq39, noadp external ibfcn4 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 c t1 = timer (dummy) if (ifact .eq. 1) call bfacmy (4,ibfcn4,coef,jcoef,wksp,iwksp, a n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return iwkpt1 = irpnt irpnt = irpnt + 2*ncmax call split (accel,suba2,suba3,subq34,subq35,subq36,subq37, a subq38,subq39,noadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*ncmax return end subroutine rs7 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c ... rs7 drives the reduced system method (diagonal storage c with red-black coloring). c external accel, suba6, suba7, subq76, subq77, copy, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / intern / ndt, ndb, maxt, maxb, ivers, irwise c n = nn t1 = timer (dummy) if (ifact .eq. 1) call mfact (coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier .lt. 0) return c c ... compute red-black rhs. c nr = iwksp(nc) nb = n - nr call needw ('rs7',0,irpnt,n,ier) if (ier .lt. 0) return irhs = irpnt irpnt = irpnt + nr call rsbegd (n,n,nr,ndim,iwksp(maxnew),ndt,ndb,iwksp(jcnew), a coef,wksp(irhs),rhs,wksp(ifactr),wksp(irpnt)) iwkpt1 = irpnt irpnt = irpnt + nb call split (accel,suba6,suba7,subq76,subq77,subq76,subq77, a copy,copy,noadp, a coef,jcoef,nr,u,ubar,wksp(irhs),wksp,iwksp, a iparm,rparm,ier) call rsendd (n,n,nr,ndim,iwksp(maxnew),ndt,ndb,iwksp(jcnew), a coef,u,rhs,wksp(ifactr)) irpnt = irpnt - n return end subroutine suba1 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba1 calls mult2s. c common / dscons / ndim, mdim, maxnz integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c call mult2s (ndim,maxnz,coef,jcoef,n,x,y) return end subroutine suba2 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba2 calls muldc. c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c call muldc (ndim,n,coef,ncolor,iwksp(nc),iwksp(maxnew), a iwksp(jcnew),x,y) return end subroutine suba3 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba3 calls muldct. c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c call muldct (ndim,n,coef,ncolor,iwksp(nc),iwksp(maxnew), a iwksp(jcnew),x,y) return end subroutine suba4 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba4 calls mult2n. c common / dscons / ndim, mdim, maxnz integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c call mult2n (ndim,maxnz,coef,jcoef,n,x,y) return end subroutine suba5 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba5 calls mul2nt. c common / dscons / ndim, mdim, maxnz integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c call mul2nt (ndim,maxnz,coef,jcoef,n,x,y) return end subroutine suba6 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba6 calls rsad. c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c nr = iwksp(nc) nb = iwksp(nc+1) nbig = nr + nb call rsad (nbig,n,n,ndim,iwksp(maxnew),ndt,ndb, a iwksp(jcnew),coef,y,x,wksp(ifactr),wksp(iwkpt1)) return end subroutine suba7 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba7 calls rsatd. c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c nr = iwksp(nc) nb = iwksp(nc+1) nbig = nr + nb call rsatd (nbig,n,n,ndim,iwksp(maxnew),ndt,ndb, a iwksp(jcnew),coef,y,x,wksp(ifactr),wksp(iwkpt1)) return end subroutine suba8 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba8 calls mult1. c common / dscons / ndim, mdim, maxnz common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c call mult1 (ndim,maxnz,coef,jcoef,wksp(iwkpt1),n,x,y) return end subroutine suba9 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba9 calls mul1t. c common / dscons / ndim, mdim, maxnz common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c call mul1t (ndim,maxnz,coef,jcoef,wksp(iwkpt1),n,x,y) return end subroutine suba10 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba10 calls rsap. c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c nr = iwksp(nc) nb = iwksp(nc+1) nbig = nr + nb call rsap (ndim,nbig,n,maxnz,jcoef,coef,x,y,wksp(iwkpt1)) return end subroutine suba11 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba11 calls rsatp. c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c nr = iwksp(nc) nb = iwksp(nc+1) nbig = nr + nb if (isymm .eq. 0) call rsap (ndim,nbig,n,maxnz,jcoef,coef, a x,y,wksp(iwkpt1)) if (isymm .eq. 1) call rsatp (ndim,nbig,n,maxnz,jcoef,coef, a x,y,wksp(iwkpt1)) return end subroutine suba12 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba12 calls mult3. c common / dscons / ndim, mdim, maxnz common / cmpart / mpstrt, mpart common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c call mult3 (mpart,iwksp(mpstrt),coef,jcoef,jcoef(ndim+1), a wksp(iwkpt1),x,y) return end subroutine suba13 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba13 calls mult3n. c common / dscons / ndim, mdim, maxnz common / cmpart / mpstrt, mpart common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c call mult3n (mpart,iwksp(mpstrt),coef,jcoef,jcoef(ndim+1), a wksp(iwkpt1),x,y) return end subroutine suba14 (coef,jcoef,wksp,iwksp,n,x,y) implicit double precision (a-h, o-z) c c ... suba14 calls mul3nt. c common / dscons / ndim, mdim, maxnz common / cmpart / mpstrt, mpart common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension x(1), y(1), coef(1), wksp(1) c call mul3nt (mpart,iwksp(mpstrt),coef,jcoef,jcoef(ndim+1), a wksp(iwkpt1),x,y) return end subroutine subq1 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq1 calls pjac, for jacobi preconditioning. c integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c call pjac (coef,n,r,z) return end subroutine subq2 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq2 calls bdsol, for line jacobi preconditioning. c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c if (nstore .eq. 2) isym = 0 if (nstore .eq. 3) isym = 1 call bdsol (n,n,kblsz,ndt,ndb,wksp(ifactr),r,z,isym) return end subroutine subq3 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq3 calls bdsolt, for line jacobi preconditioning. c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c call bdsolt (n,n,kblsz,ndt,ndb,wksp(ifactr),r,z) return end subroutine subq4 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq4 call bmul or bmuln, for line jacobi preconditioning c (approximate inverse) c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c if (nstore .eq. 2) isym = 0 if (nstore .eq. 3) isym = 1 ift = ifactr + n ifb = ifactr + n*(ndt + 1) if (isym .eq. 0) call bmul (n,n,ndt,wksp(ifactr),wksp(ift),r,z) if (isym .eq. 1) call bmuln (n,n,ndt,ndb,wksp(ifactr), a wksp(ift),wksp(ifb),r,z) return end subroutine subq5 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq5 call bmul or bmulnt, for line jacobi preconditioning c (approximate inverse) c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c if (nstore .eq. 2) isym = 0 if (nstore .eq. 3) isym = 1 ift = ifactr + n ifb = ifactr + n*(ndt + 1) if (isym .eq. 0) call bmul (n,n,ndt,wksp(ifactr),wksp(ift),r,z) if (isym .eq. 1) call bmulnt (n,n,ndt,ndb,wksp(ifactr), a wksp(ift),wksp(ifb),r,z) return end subroutine subq6 (coef,jcoef,wksp,iwksp,n,u,rhs,unew) implicit double precision (a-h, o-z) c c ... subq6 calls the basic sor iterative step c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension u(1), rhs(1), unew(1), coef(1), wksp(1) c maxt = maxnz - 1 call sords (ndim,n,maxt,jcoef(2),coef,coef(ndim+1),omega, a irwise,u,rhs,unew,iwksp(iwkpt1)) return end subroutine subq7 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq7 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c maxt = maxnz - 1 call srs (ndim,n,maxt,jcoef(2),coef,coef(ndim+1),omega, a irwise,iwksp(iwkpt1),r,z) return end subroutine subq8 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq8 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c maxt = maxnz - 1 call srs1 (ndim,n,maxt,jcoef(2),coef,coef(ndim+1),omega, a irwise,iwksp(iwkpt1),r,z) return end subroutine subq9 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq9 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c maxt = maxnz - 1 call srs3 (ndim,n,maxt,jcoef(2),coef,coef(ndim+1),omega, a irwise,iwksp(iwkpt1),r,z) return end subroutine subq10 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq10 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c maxt = maxnz - 1 call srs2 (ndim,n,maxt,jcoef(2),coef,coef(ndim+1),omega, a irwise,iwksp(iwkpt1),r,z) return end subroutine subq11 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq11 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c maxt = maxnz - 1 call srs4 (ndim,n,maxt,jcoef(2),coef,coef(ndim+1),omega, a irwise,iwksp(iwkpt1),r,z) return end subroutine subq12 (coef,jcoef,wksp,iwksp,n,p,r,pdp,pldup) implicit double precision (a-h, o-z) c c ... subq12 calls the ssor adaption routine. c c common / dscons / ndim, mdim, maxnz integer jcoef(2), iwksp(1) dimension p(1), r(1), coef(1), wksp(1) c maxt = maxnz - 1 call ssord (ndim,maxt,jcoef(2),coef,coef(ndim+1),n,p,r, a pdp,pldup) return end subroutine subq13 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq13 calls ics, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c if (propa) call ics (ndim,n,maxt,jcoef(2),wksp(ifactr), a coef(ndim+1),1,irwise,iwksp(iwkpt1),r,z) if (.not. propa) call ics (n,n,maxt,iwksp(ifacti+1), a wksp(ifactr),wksp(ifactr+n), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq14 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq14 calls ics1, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c if (propa) call ics1 (ndim,n,maxt,jcoef(2),wksp(ifactr), a coef(ndim+1),1,irwise,iwksp(iwkpt1),r,z) if (.not. propa) call ics1 (n,n,maxt,iwksp(ifacti+1), a wksp(ifactr),wksp(ifactr+n), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq15 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq15 calls ics3, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c if (propa) call ics3 (ndim,n,maxt,jcoef(2),wksp(ifactr), a coef(ndim+1),1,irwise,iwksp(iwkpt1),r,z) if (.not. propa) call ics3 (n,n,maxt,iwksp(ifacti+1), a wksp(ifactr),wksp(ifactr+n), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq16 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq16 calls ics2, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c if (propa) call ics2 (ndim,n,maxt,jcoef(2),wksp(ifactr), a coef(ndim+1),1,irwise,iwksp(iwkpt1),r,z) if (.not. propa) call ics2 (n,n,maxt,iwksp(ifacti+1), a wksp(ifactr),wksp(ifactr+n), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq17 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq17 calls ics4, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c if (propa) call ics4 (ndim,n,maxt,jcoef(2),wksp(ifactr), a coef(ndim+1),1,irwise,iwksp(iwkpt1),r,z) if (.not. propa) call ics4 (n,n,maxt,iwksp(ifacti+1), a wksp(ifactr),wksp(ifactr+n), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq18 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq18 calls ppii, for lspoly preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba1 c call ppii (suba1,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt1),n,r,z) return end subroutine subq19 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq19 calls pneu, for neumann polynomial preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba1 c call pneu (suba1,coef,jcoef,wksp,iwksp,coef,ndeg, a wksp(iwkpt1),n,r,z) return end subroutine subq20 (coef,jcoef,wksp,iwksp,n,u,rhs,unew) implicit double precision (a-h, o-z) c c ... subq20 calls the basic lsor iterative step c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension u(1), rhs(1), unew(1), coef(1), wksp(1) c call sordb (n,ndim,kblsz,kblsz,iwksp(ifacti),lbhb, a wksp(ifactr),coef,jcoef,n,omega,u,rhs,unew) return end subroutine subq21 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq21 calls the lssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim*iwksp(ifacti+2) + 1 ipt2 = iwksp(ifacti+2) + 1 call sbsl (n,ndim,n,kblsz,kblsz,lbhb,iwksp(ifacti), a wksp(ifactr),coef(ipt1),jcoef(ipt2),r,z, a omega,wksp(iwkpt1)) return end subroutine subq22 (coef,jcoef,wksp,iwksp,n,p,r,pdp,pldup) implicit double precision (a-h, o-z) c c ... subq22 calls the lssor adaption routine. c c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension p(1), r(1), coef(1), wksp(1) c call ssrcd (n,ndim,maxnz,kblsz,iwksp(ifacti),wksp(ifactr), a coef,jcoef,n,p,r,wksp(iwkpt1),pdp,pldup) return end subroutine subq23 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq23 calls pbpii, for line lspoly preconditioning. c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba1, subq2 c call pbpii (suba1,subq2,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt1),n,r,z) return end subroutine subq24 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq24 calls pbneu, for line neumann polynomial c preconditioning. c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba1, subq2 c call pbneu (suba1,subq2,coef,jcoef,wksp,iwksp,ndeg, a wksp(iwkpt1),n,r,z) return end subroutine subq25 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq25 calls ibsl, for bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn ipt2 = ifactr + n*iwksp(ifacti+2) if (lvfill .gt. 0) go to 10 nwdiag = iwksp(ifacti+2) - ltrunc if (propa) call ibsl a (n,ndim,n,kblsz,kblsz,lbhb,iwksp(ifacti), a wksp(ifactr),coef(ndim*nwdiag+1), a jcoef(nwdiag+1),r,z,ivers,wksp(iwkpt1)) if (.not. propa) call ibsl a (n,n,n,kblsz,kblsz,lbhb,iwksp(ifacti), a wksp(ifactr),wksp(ipt2), a jcoef(nwdiag+1),r,z,ivers,wksp(iwkpt1)) return 10 ipt1 = ifacti + 3*lbhb + iwksp(ifacti+2) call ibsl (n,n,n,kblsz,kblsz,lbhb,iwksp(ifacti), a wksp(ifactr),wksp(ipt2),iwksp(ipt1),r,z, a ivers,wksp(iwkpt1)) return end subroutine subq26 (coef,jcoef,wksp,iwksp,n,u,rhs,unew) implicit double precision (a-h, o-z) c c ... subq26 calls the basic multi-color sor iterative step c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp integer jcoef(2), iwksp(1) dimension u(1), rhs(1), unew(1), coef(1), wksp(1) c call sordmb (n,ndim,n,iwksp(iblock),iwksp(lbhb),ncolor, a iwksp(nc),iwksp(ipt),wksp(ifactr),coef, a iwksp(jcnew),n,omega,u,rhs,unew) return end subroutine subq27 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq27 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) ipt1 = ndim*nwdiag + 1 ipt2 = ncolor*nwdiag + jcnew call sbsln (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ipt1),iwksp(ipt2),r,z,omega,0,wksp(iwkpt1)) return end subroutine subq28 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq28 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) ipt1 = ndim*nwdiag + 1 ipt2 = ncolor*nwdiag + jcnew call sbslnt (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ipt1),iwksp(ipt2),r,z,omega,0,wksp(iwkpt1)) return end subroutine subq29 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq29 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) ipt1 = ndim*nwdiag + 1 ipt2 = ncolor*nwdiag + jcnew call sbsln1 (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ipt1),iwksp(ipt2),r,z,omega,0) return end subroutine subq30 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq30 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) ipt1 = ndim*nwdiag + 1 ipt2 = ncolor*nwdiag + jcnew call sbsln3 (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ipt1),iwksp(ipt2),r,z,omega,0) return end subroutine subq31 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq31 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) ipt1 = ndim*nwdiag + 1 ipt2 = ncolor*nwdiag + jcnew call sbsln2 (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ipt1),iwksp(ipt2),r,z,omega,0,wksp(iwkpt1)) return end subroutine subq32 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq32 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) ipt1 = ndim*nwdiag + 1 ipt2 = ncolor*nwdiag + jcnew call sbsln4 (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ipt1),iwksp(ipt2),r,z,omega,0,wksp(iwkpt1)) return end subroutine subq33 (coef,jcoef,wksp,iwksp,n,p,r,pdp,pldup) implicit double precision (a-h, o-z) c c ... subq33 calls the mssor adaption routine. c c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension p(1), r(1), coef(1), wksp(1) c call ssrcdm (n,ndim,iwksp(lbhb),n,ncolor,iwksp(nc), a iwksp(ipt),iwksp(iblock),wksp(ifactr), a coef,iwksp(jcnew),n,p,r,wksp(iwkpt1), a pdp,pldup) return end subroutine subq34 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq34 calls ibsln, for multi-color bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) a - 2*ltrunc if (propa) call ibsln a (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ndim*nwdiag+1),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) if (.not. propa) call ibsln a (n,n,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a wksp(iwkpt2),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) return end subroutine subq35 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq35 calls ibslnt, for multi-color bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) a - 2*ltrunc if (propa) call ibslnt a (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ndim*nwdiag+1),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) if (.not. propa) call ibslnt a (n,n,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a wksp(iwkpt2),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) return end subroutine subq36 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq36 calls ibsln1, for multi-color bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) a - 2*ltrunc if (propa) call ibsln1 a (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ndim*nwdiag+1),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) if (.not. propa) call ibsln1 a (n,n,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a wksp(iwkpt2),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) return end subroutine subq37 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq37 calls ibsln3, for multi-color bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) a - 2*ltrunc if (propa) call ibsln3 a (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ndim*nwdiag+1),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) if (.not. propa) call ibsln3 a (n,n,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a wksp(iwkpt2),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) return end subroutine subq38 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq38 calls ibsln2, for multi-color bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) a - 2*ltrunc if (propa) call ibsln2 a (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ndim*nwdiag+1),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) if (.not. propa) call ibsln2 a (n,n,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a wksp(iwkpt2),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) return end subroutine subq39 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq39 calls ibsln4, for multi-color bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn nwdiag = iwksp(iblock+2) + iwksp(iblock+3*ncolor+2) a - 2*ltrunc if (propa) call ibsln4 a (n,ndim,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a coef(ndim*nwdiag+1),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) if (.not. propa) call ibsln4 a (n,n,n,n,ncolor,iwksp(nc),iwksp(ipt), a iwksp(lbhb),iwksp(iblock),wksp(ifactr), a wksp(iwkpt2),iwksp(jcnew+nwdiag*ncolor), a r,z,ivers,0,wksp(iwkpt1)) return end subroutine subq40 (coef,jcoef,wksp,iwksp,n,u,rhs,unew) implicit double precision (a-h, o-z) c c ... subq40 calls the basic sor iterative step c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp integer jcoef(2), iwksp(1) dimension u(1), rhs(1), unew(1), coef(1), wksp(1) c maxtp1 = maxt + 1 call sordn (ndim,n,maxt,maxb,jcoef(2),jcoef(maxt+2),coef, a coef(ndim+1),coef(maxtp1*ndim+1),omega, a irwise,u,rhs,unew,iwksp(iwkpt1)) return end subroutine subq41 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq41 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c maxtp1 = maxt + 1 call srsn (ndim,n,maxt,maxb,jcoef(2),jcoef(maxt+2),coef, a coef(ndim+1),coef(ndim*maxtp1+1),omega,irwise, a iwksp(iwkpt2),r,z) return end subroutine subq42 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq42 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c maxtp1 = maxt + 1 call srsnt (ndim,n,maxt,maxb,jcoef(2),jcoef(maxt+2),coef, a coef(ndim+1),coef(ndim*maxtp1+1),omega,irwise, a iwksp(iwkpt2),r,z) return end subroutine subq43 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq43 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c maxtp1 = maxt + 1 call srsn1 (ndim,n,maxb,jcoef(maxt+2),coef, a coef(ndim*maxtp1+1),omega,irwise, a iwksp(iwkpt2),r,z) return end subroutine subq44 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq44 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c maxtp1 = maxt + 1 call srsn3 (ndim,n,maxb,jcoef(maxt+2),coef, a coef(ndim*maxtp1+1),omega,irwise, a iwksp(iwkpt2),r,z) return end subroutine subq45 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq45 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c call srsn2 (ndim,n,maxt,jcoef(2),coef, a coef(ndim+1),omega,irwise, a iwksp(iwkpt2),r,z) return end subroutine subq46 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq46 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c call srsn4 (ndim,n,maxt,jcoef(2),coef, a coef(ndim+1),omega,irwise, a iwksp(iwkpt2),r,z) return end subroutine subq47 (coef,jcoef,wksp,iwksp,n,p,r,pdp,pldup) implicit double precision (a-h, o-z) c c ... subq47 calls the ssor adaption routine. c c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension p(1), r(1), coef(1), wksp(1) c maxtp1 = maxt + 1 call ssordn (ndim,maxt,maxb,jcoef(2),jcoef(maxt+2),coef, a coef(ndim+1),coef(ndim*maxtp1+1),n,p,r, a wksp(iwkpt1),pdp,pldup) return end subroutine subq48 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq48 calls icsn, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn maxtp1 = maxt + 1 if (propa) call icsn (ndim,n,maxt,maxb,jcoef(2),jcoef(maxt+2), a wksp(ifactr),coef(ndim+1), a coef(ndim*maxtp1+1),1,irwise, a iwksp(iwkpt1),r,z) if (.not. propa) call icsn (n,n,maxt,maxb,iwksp(ifacti+1), a iwksp(ifacti+maxt+1),wksp(ifactr), a wksp(ifactr+n),wksp(ifactr+n*maxtp1), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq49 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq49 calls icsnt, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn maxtp1 = maxt + 1 if (propa) call icsnt (ndim,n,maxt,maxb,jcoef(2),jcoef(maxt+2), a wksp(ifactr),coef(ndim+1), a coef(ndim*maxtp1+1),1,irwise, a iwksp(iwkpt1),r,z) if (.not. propa) call icsnt (n,n,maxt,maxb,iwksp(ifacti+1), a iwksp(ifacti+maxt+1),wksp(ifactr), a wksp(ifactr+n),wksp(ifactr+n*maxtp1), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq50 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq50 calls icsn1, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn maxtp1 = maxt + 1 if (propa) call icsn1 (ndim,n,maxb,jcoef(maxt+2), a wksp(ifactr), a coef(ndim*maxtp1+1),1,irwise, a iwksp(iwkpt1),r,z) if (.not. propa) call icsn1 (n,n,maxb, a iwksp(ifacti+maxt+1),wksp(ifactr), a wksp(ifactr+n*maxtp1), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq51 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq51 calls icsn3, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn maxtp1 = maxt + 1 if (propa) call icsn3 (ndim,n,maxb,jcoef(maxt+2), a wksp(ifactr), a coef(ndim*maxtp1+1),1,irwise, a iwksp(iwkpt1),r,z) if (.not. propa) call icsn3 (n,n,maxb, a iwksp(ifacti+maxt+1),wksp(ifactr), a wksp(ifactr+n*maxtp1), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq52 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq52 calls icsn2, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c if (propa) call icsn2 (ndim,n,maxt,jcoef(2), a wksp(ifactr),coef(ndim+1), a 1,irwise, a iwksp(iwkpt1),r,z) if (.not. propa) call icsn2 (n,n,maxt,iwksp(ifacti+1), a wksp(ifactr), a wksp(ifactr+n), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq53 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq53 calls icsn4, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c if (propa) call icsn4 (ndim,n,maxt,jcoef(2), a wksp(ifactr),coef(ndim+1), a 1,irwise, a iwksp(iwkpt1),r,z) if (.not. propa) call icsn4 (n,n,maxt,iwksp(ifacti+1), a wksp(ifactr), a wksp(ifactr+n), a 0,irwise,iwksp(iwkpt1),r,z) return end subroutine subq54 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq54 calls ppii, for lspoly preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba4 c call ppii (suba4,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt1),n,r,z) return end subroutine subq55 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq55 calls ppii, for lspoly preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba5 c call ppii (suba5,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt1),n,r,z) return end subroutine subq56 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq56 calls pneu, for neumann polynomial preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba4 c call pneu (suba4,coef,jcoef,wksp,iwksp,coef,ndeg, a wksp(iwkpt1),n,r,z) return end subroutine subq57 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq57 calls pneu, for neumann polynomial preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba5 c call pneu (suba5,coef,jcoef,wksp,iwksp,coef,ndeg, a wksp(iwkpt1),n,r,z) return end subroutine subq58 (coef,jcoef,wksp,iwksp,n,u,rhs,unew) implicit double precision (a-h, o-z) c c ... subq58 calls the basic lsor iterative step c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension u(1), rhs(1), unew(1), coef(1), wksp(1) c call sordnb (n,ndim,kblsz,kblsz,iwksp(ifacti),lbhb, a wksp(ifactr),coef,jcoef,n,omega,u,rhs,unew) return end subroutine subq59 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq59 calls the lssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) c idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb nwdiag = iwksp(ifacti+2) + iwksp(ifacti+5) ipt1 = ndim*nwdiag + 1 ipt2 = nwdiag + 1 call sbsln (n,ndim,n,kblsz,1,idumb(1),idumb(2),idumb(3), a iwksp(ifacti),wksp(ifactr),coef(ipt1), a jcoef(ipt2),r,z,omega,1,wksp(iwkpt1)) return end subroutine subq60 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq60 calls the lssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) c idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb nwdiag = iwksp(ifacti+2) + iwksp(ifacti+5) ipt1 = ndim*nwdiag + 1 ipt2 = nwdiag + 1 call sbslnt (n,ndim,n,kblsz,1,idumb(1),idumb(2),idumb(3), a iwksp(ifacti),wksp(ifactr),coef(ipt1), a jcoef(ipt2),r,z,omega,1,wksp(iwkpt1)) return end subroutine subq61 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq61 calls the lssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) c idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb nwdiag = iwksp(ifacti+2) + iwksp(ifacti+5) ipt1 = ndim*nwdiag + 1 ipt2 = nwdiag + 1 call sbsln1 (n,ndim,n,kblsz,1,idumb(1),idumb(2),idumb(3), a iwksp(ifacti),wksp(ifactr),coef(ipt1), a jcoef(ipt2),r,z,omega,1) return end subroutine subq62 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq62 calls the lssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) c idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb nwdiag = iwksp(ifacti+2) + iwksp(ifacti+5) ipt1 = ndim*nwdiag + 1 ipt2 = nwdiag + 1 call sbsln3 (n,ndim,n,kblsz,1,idumb(1),idumb(2),idumb(3), a iwksp(ifacti),wksp(ifactr),coef(ipt1), a jcoef(ipt2),r,z,omega,1) return end subroutine subq63 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq63 calls the lssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) c idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb nwdiag = iwksp(ifacti+2) + iwksp(ifacti+5) ipt1 = ndim*nwdiag + 1 ipt2 = nwdiag + 1 call sbsln2 (n,ndim,n,kblsz,1,idumb(1),idumb(2),idumb(3), a iwksp(ifacti),wksp(ifactr),coef(ipt1), a jcoef(ipt2),r,z,omega,1,wksp(iwkpt1)) return end subroutine subq64 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq64 calls the lssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) c idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb nwdiag = iwksp(ifacti+2) + iwksp(ifacti+5) ipt1 = ndim*nwdiag + 1 ipt2 = nwdiag + 1 call sbsln4 (n,ndim,n,kblsz,1,idumb(1),idumb(2),idumb(3), a iwksp(ifacti),wksp(ifactr),coef(ipt1), a jcoef(ipt2),r,z,omega,1,wksp(iwkpt1)) return end subroutine subq65 (coef,jcoef,wksp,iwksp,n,p,r,pdp,pldup) implicit double precision (a-h, o-z) c c ... subq65 calls the lssor adaption routine. c c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension p(1), r(1), coef(1), wksp(1) c call ssrcdn (n,ndim,lbhb,kblsz,iwksp(ifacti),wksp(ifactr), a coef,jcoef,n,p,r,wksp(iwkpt1),pdp,pldup) return end subroutine subq66 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq66 calls pbpii, for line lspoly preconditioning. c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba4, subq2 c call pbpii (suba4,subq2,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt1),n,r,z) return end subroutine subq67 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq67 calls pbpii, for line lspoly preconditioning. c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba5, subq3 c call pbpii (suba5,subq3,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt1),n,r,z) return end subroutine subq68 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq68 calls pbneu, for line neumann polynomial c preconditioning. c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba4, subq2 c call pbneu (suba4,subq2,coef,jcoef,wksp,iwksp,ndeg, a wksp(iwkpt1),n,r,z) return end subroutine subq69 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq69 calls pbneu, for line neumann polynomial c preconditioning. c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba5, subq3 c call pbneu (suba5,subq3,coef,jcoef,wksp,iwksp,ndeg, a wksp(iwkpt1),n,r,z) return end subroutine subq70 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq70 calls ibsln, for bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb c n = nn nwnew = iwksp(ifacti+2) + iwksp(ifacti+5) ipt2 = ifactr + n*nwnew if (lvfill .gt. 0) go to 10 nwdiag = nwnew - 2*ltrunc if (propa) call ibsln a (n,ndim,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a coef(ndim*nwdiag+1),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) if (.not. propa) call ibsln a (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(ipt2),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) return 10 ipt1 = ifacti + 3*lbhb + nwnew call ibsln (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(ipt2),iwksp(ipt1), a r,z,ivers,1,wksp(iwkpt1)) return end subroutine subq71 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq71 calls ibslnt, for bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb c n = nn nwnew = iwksp(ifacti+2) + iwksp(ifacti+5) ipt2 = ifactr + n*nwnew if (lvfill .gt. 0) go to 10 nwdiag = nwnew - 2*ltrunc if (propa) call ibslnt a (n,ndim,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a coef(ndim*nwdiag+1),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) if (.not. propa) call ibslnt a (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(iwkpt2),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) return 10 ipt1 = ifacti + 3*lbhb + nwnew call ibslnt (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(ipt2),iwksp(ipt1), a r,z,ivers,1,wksp(iwkpt1)) return end subroutine subq72 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq72 calls ibsln1, for bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb c n = nn nwnew = iwksp(ifacti+2) + iwksp(ifacti+5) ipt2 = ifactr + n*nwnew if (lvfill .gt. 0) go to 10 nwdiag = nwnew - 2*ltrunc if (propa) call ibsln1 a (n,ndim,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a coef(ndim*nwdiag+1),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) if (.not. propa) call ibsln1 a (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(iwkpt2),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) return 10 ipt1 = ifacti + 3*lbhb + nwnew call ibsln1 (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(ipt2),iwksp(ipt1), a r,z,ivers,1,wksp(iwkpt1)) return end subroutine subq73 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq73 calls ibsln3, for bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb c n = nn nwnew = iwksp(ifacti+2) + iwksp(ifacti+5) ipt2 = ifactr + n*nwnew if (lvfill .gt. 0) go to 10 nwdiag = nwnew - 2*ltrunc if (propa) call ibsln3 a (n,ndim,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a coef(ndim*nwdiag+1),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) if (.not. propa) call ibsln3 a (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(iwkpt2),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) return 10 ipt1 = ifacti + 3*lbhb + nwnew call ibsln3 (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(ipt2),iwksp(ipt1), a r,z,ivers,1,wksp(iwkpt1)) return end subroutine subq74 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq74 calls ibsln2, for bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb c n = nn nwnew = iwksp(ifacti+2) + iwksp(ifacti+5) ipt2 = ifactr + n*nwnew if (lvfill .gt. 0) go to 10 nwdiag = nwnew - 2*ltrunc if (propa) call ibsln2 a (n,ndim,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a coef(ndim*nwdiag+1),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) if (.not. propa) call ibsln2 a (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(iwkpt2),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) return 10 ipt1 = ifacti + 3*lbhb + nwnew call ibsln2 (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(ipt2),iwksp(ipt1), a r,z,ivers,1,wksp(iwkpt1)) return end subroutine subq75 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq75 calls ibsln4, for bic preconditioning. c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 dimension r(1), z(1), coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb c n = nn nwnew = iwksp(ifacti+2) + iwksp(ifacti+5) ipt2 = ifactr + n*nwnew if (lvfill .gt. 0) go to 10 nwdiag = nwnew - 2*ltrunc if (propa) call ibsln4 a (n,ndim,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a coef(ndim*nwdiag+1),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) if (.not. propa) call ibsln4 a (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(iwkpt2),jcoef(nwdiag+1), a r,z,ivers,1,wksp(iwkpt1)) return 10 ipt1 = ifacti + 3*lbhb + nwnew call ibsln4 (n,n,n,kblsz,1,idumb(1),idumb(2), a idumb(3),iwksp(ifacti),wksp(ifactr), a wksp(ipt2),iwksp(ipt1), a r,z,ivers,1,wksp(iwkpt1)) return end subroutine subq76 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq76 calls bdsol, for rs preconditioning. c c logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn nr = iwksp(nc) nb = iwksp(nc+1) nbig = nr + nb call bdsol (nbig,n,n,ndt,ndb,wksp(ifactr),r,z,1) return end subroutine subq77 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq77 calls bdsolt, for rs preconditioning. c c logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c n = nn nr = iwksp(nc) nb = iwksp(nc+1) nbig = nr + nb call bdsolt (nbig,n,n,ndt,ndb,wksp(ifactr),r,z) return end subroutine subq78 (coef,jcoef,wksp,iwksp,n,u,rhs,unew) implicit double precision (a-h, o-z) c c ... subq78 calls the basic sor iterative step c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp integer jcoef(2), iwksp(1) dimension u(1), rhs(1), unew(1), coef(1), wksp(1) c ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 call sorp (ndim,n,maxt,maxb,jcoef(ip1),jcoef(ip2),coef, a coef(ip1),coef(ip2),omega,u,rhs,unew) return end subroutine subq79 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq79 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 call srsp (ndim,n,maxt,maxb,jcoef(ip1),jcoef(ip2),coef, a coef(ip1),coef(ip2),omega,r,z) return end subroutine subq80 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq80 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 call srsntp (ndim,n,maxt,maxb,jcoef(ip1),jcoef(ip2),coef, a coef(ip1),coef(ip2),omega,r,z) return end subroutine subq81 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq81 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ip2 = ndim*(maxt + 1) + 1 call srsp1 (ndim,n,maxb,jcoef(ip2),coef,coef(ip2),omega,r,z) return end subroutine subq82 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq82 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ip2 = ndim*(maxt + 1) + 1 call srsp3 (ndim,n,maxb,jcoef(ip2),coef,coef(ip2),omega,r,z) return end subroutine subq83 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq83 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ip1 = ndim + 1 call srsp2 (ndim,n,maxt,jcoef(ip1),coef,coef(ip1),omega,r,z) return end subroutine subq84 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq84 calls the ssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ip1 = ndim + 1 call srsp4 (ndim,n,maxt,jcoef(ip1),coef,coef(ip1),omega,r,z) return end subroutine subq85 (coef,jcoef,wksp,iwksp,n,p,r,pdp,pldup) implicit double precision (a-h, o-z) c c ... subq85 calls the ssor adaption routine. c c common / dscons / ndim, mdim, maxnz common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension p(1), r(1), coef(1), wksp(1) c ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 if (isymm .eq. 0) call ssorp (ndim,maxt,jcoef(ip1),coef, a coef(ip1),n,p,r,wksp(iwkpt1), a pdp,pldup) if (isymm .ne. 0) call ssorpn (ndim,maxt,maxb,jcoef(ip1), a jcoef(ip2),coef,coef(ip1), a coef(ip2),n,p,r,wksp(iwkpt1), a pdp,pldup) return end subroutine subq86 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq86 calls ics, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) logical symm c n = nn symm = isymm .eq. 0 if (.not. propa) go to 10 ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 if (symm) call icsp (ndim,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),coef(ip1),1,r,z) if (.not. symm) call icsnp (ndim,ndim,n,maxt,maxb, a jcoef(ip1),jcoef(ip2),wksp(ifactr), a coef(ip1),coef(ip2),1,r,z) return 10 if (lvfill .gt. 0) go to 15 ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 ip3 = ifactr + n ip4 = n*(maxt + 1)+ ifactr if (symm) call icsp (n,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsnp (n,ndim,n,maxt,maxb, a jcoef(ip1),jcoef(ip2),wksp(ifactr), a wksp(ip3),wksp(ip4),0,r,z) return 15 continue ip1 = ifacti + n ip2 = ifacti + n*(maxt + 1) ip3 = ifactr + n ip4 = n*(maxt + 1)+ ifactr if (symm) call icsp (n,n,n,maxt,iwksp(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsnp (n,n,n,maxt,maxb, a iwksp(ip1),iwksp(ip2),wksp(ifactr), a wksp(ip3),wksp(ip4),0,r,z) return end subroutine subq87 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq87 calls ics, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) logical symm c n = nn symm = isymm .eq. 0 if (.not. propa) go to 10 ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 if (symm) call icsp (ndim,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),coef(ip1),1,r,z) if (.not. symm) call icsntp (ndim,ndim,n,maxt,maxb, a jcoef(ip1),jcoef(ip2),wksp(ifactr), a coef(ip1),coef(ip2),1,r,z) return 10 if (lvfill .gt. 0) go to 15 ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 ip3 = ifactr + n ip4 = n*(maxt + 1)+ ifactr if (symm) call icsp (n,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsntp (n,ndim,n,maxt,maxb, a jcoef(ip1),jcoef(ip2),wksp(ifactr), a wksp(ip3),wksp(ip4),0,r,z) return 15 continue ip1 = ifacti + n ip2 = ifacti + n*(maxt + 1) ip3 = ifactr + n ip4 = n*(maxt + 1)+ ifactr if (symm) call icsp (n,n,n,maxt,iwksp(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsntp (n,n,n,maxt,maxb, a iwksp(ip1),iwksp(ip2),wksp(ifactr), a wksp(ip3),wksp(ip4),0,r,z) return end subroutine subq88 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq88 calls ics, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) logical symm c n = nn symm = isymm .eq. 0 if (.not. propa) go to 10 ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 if (symm) call icsp1 (ndim,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),coef(ip1),1,r,z) if (.not. symm) call icsnp1 (ndim,ndim,n,maxb, a jcoef(ip2),wksp(ifactr), a coef(ip2),1,r,z) return 10 if (lvfill .gt. 0) go to 15 ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 ip3 = ifactr + n ip4 = n*(maxt + 1)+ ifactr if (symm) call icsp1 (n,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsnp1 (n,ndim,n,maxb, a jcoef(ip2),wksp(ifactr), a wksp(ip4),0,r,z) return 15 continue ip1 = ifacti + n ip2 = ifacti + n*(maxt + 1) ip3 = ifactr + n ip4 = n*(maxt + 1)+ ifactr if (symm) call icsp1 (n,n,n,maxt,iwksp(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsnp1 (n,n,n,maxb, a iwksp(ip2),wksp(ifactr), a wksp(ip4),0,r,z) return end subroutine subq89 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq89 calls ics, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) logical symm c n = nn symm = isymm .eq. 0 if (.not. propa) go to 10 ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 if (symm) call icsp3 (ndim,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),coef(ip1),1,r,z) if (.not. symm) call icsnp3 (ndim,ndim,n,maxb, a jcoef(ip2),wksp(ifactr), a coef(ip2),1,r,z) return 10 if (lvfill .gt. 0) go to 15 ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 ip3 = ifactr + n ip4 = n*(maxt + 1)+ ifactr if (symm) call icsp3 (n,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsnp3 (n,ndim,n,maxb, a jcoef(ip2),wksp(ifactr), a wksp(ip4),0,r,z) return 15 continue ip1 = ifacti + n ip2 = ifacti + n*(maxt + 1) ip3 = ifactr + n ip4 = n*(maxt + 1)+ ifactr if (symm) call icsp3 (n,n,n,maxt,iwksp(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsnp3 (n,n,n,maxb, a iwksp(ip2),wksp(ifactr), a wksp(ip4),0,r,z) return end subroutine subq90 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq90 calls ics, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) logical symm c n = nn symm = isymm .eq. 0 if (.not. propa) go to 10 ip1 = ndim + 1 if (symm) call icsp2 (ndim,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),coef(ip1),1,r,z) if (.not. symm) call icsnp2 (ndim,ndim,n,maxt, a jcoef(ip1),wksp(ifactr), a coef(ip1),1,r,z) return 10 if (lvfill .gt. 0) go to 15 ip1 = ndim + 1 ip3 = ifactr + n if (symm) call icsp2 (n,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsnp2 (n,ndim,n,maxt, a jcoef(ip1),wksp(ifactr), a wksp(ip3),0,r,z) return 15 continue ip1 = ifacti + n ip3 = ifactr + n if (symm) call icsp2 (n,n,n,maxt,iwksp(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsnp2 (n,n,n,maxt, a iwksp(ip1),wksp(ifactr), a wksp(ip3),0,r,z) return end subroutine subq91 (coef,jcoef,wksp,iwksp,nn,r,z) implicit double precision (a-h, o-z) c c ... subq91 calls ics, for ic(s) preconditioning. c c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) logical symm c n = nn symm = isymm .eq. 0 if (.not. propa) go to 10 ip1 = ndim + 1 if (symm) call icsp4 (ndim,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),coef(ip1),1,r,z) if (.not. symm) call icsnp4 (ndim,ndim,n,maxt, a jcoef(ip1),wksp(ifactr), a coef(ip1),1,r,z) return 10 if (lvfill .gt. 0) go to 15 ip1 = ndim + 1 ip3 = ifactr + n if (symm) call icsp4 (n,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsnp4 (n,ndim,n,maxt, a jcoef(ip1),wksp(ifactr), a wksp(ip3),0,r,z) return 15 continue ip1 = ifacti + n ip3 = ifactr + n if (symm) call icsp4 (n,n,n,maxt,iwksp(ip1), a wksp(ifactr),wksp(ip3),0,r,z) if (.not. symm) call icsnp4 (n,n,n,maxt, a iwksp(ip1),wksp(ifactr), a wksp(ip3),0,r,z) return end subroutine subq92 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq92 calls ppii, for lspoly preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba8 c call ppii (suba8,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt2),n,r,z) return end subroutine subq93 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq93 calls ppii, for lspoly preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba9 c call ppii (suba9,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt2),n,r,z) return end subroutine subq94 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq94 calls pneu, for neumann polynomial preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba8 c call pneu (suba8,coef,jcoef,wksp,iwksp,coef,ndeg, a wksp(iwkpt2),n,r,z) return end subroutine subq95 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq95 calls pneu, for neumann polynomial preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba9 c call pneu (suba9,coef,jcoef,wksp,iwksp,coef,ndeg, a wksp(iwkpt2),n,r,z) return end subroutine subq96 (coef,jcoef,wksp,iwksp,n,u,rhs,unew) implicit double precision (a-h, o-z) c c ... subq96 calls the basic multi-color sor iterative step c common / dscons / ndim, mdim, maxnz logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp integer jcoef(2), iwksp(1) dimension u(1), rhs(1), unew(1), coef(1), wksp(1) c call sorcp (ndim,n,jcoef(ndim+1),coef,coef(ndim+1),ncolor, a iwksp(nc),iwksp(ndt),iwksp(ndb),omega,u,rhs, a unew) return end subroutine subq97 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq97 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 call srscp (ndim,n,jcoef(ipt1),coef,coef(ipt1),ncolor, a iwksp(nc),iwksp(ndt),iwksp(ndb),omega, a wksp(iwkpt1),r,z) return end subroutine subq98 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq98 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 call srscpt (ndim,n,jcoef(ipt1),coef,coef(ipt1),ncolor, a iwksp(nc),iwksp(ndt),iwksp(ndb),omega, a wksp(iwkpt1),r,z) return end subroutine subq99 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... subq99 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 call srscp1 (ndim,n,jcoef(ipt1),coef,coef(ipt1),ncolor, a iwksp(nc),iwksp(ndt),iwksp(ndb),omega, a wksp(iwkpt1),r,z) return end subroutine sub100 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub100 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 call srscp3 (ndim,n,jcoef(ipt1),coef,coef(ipt1),ncolor, a iwksp(nc),iwksp(ndt),iwksp(ndb),omega, a wksp(iwkpt1),r,z) return end subroutine sub101 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub101 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 call srscp2 (ndim,n,jcoef(ipt1),coef,coef(ipt1),ncolor, a iwksp(nc),iwksp(ndt),omega, a wksp(iwkpt1),r,z) return end subroutine sub102 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub102 calls the mssor preconditioner. c c c *** begin -- itpack common c logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c common / dscons / ndim, mdim, maxnz common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 call srscp4 (ndim,n,jcoef(ipt1),coef,coef(ipt1),ncolor, a iwksp(nc),iwksp(ndt),omega, a wksp(iwkpt1),r,z) return end subroutine sub103 (coef,jcoef,wksp,iwksp,n,p,r,pdp,pldup) implicit double precision (a-h, o-z) c c ... sub103 calls the mssor adaption routine. c c common / dscons / ndim, mdim, maxnz common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c integer jcoef(2), iwksp(1) dimension p(1), r(1), coef(1), wksp(1) c ipt1 = ndim + 1 if (isymm .eq. 0) call ssrcp (ndim,jcoef(ipt1),coef,coef(ipt1), a n,ncolor,iwksp(nc),iwksp(ndt),p, a r,wksp(iwkpt1),pdp,pldup) if (isymm .eq. 1) call ssrcpn (ndim,jcoef(ipt1),coef,coef(ipt1), a n,ncolor,iwksp(nc),iwksp(ndt), a iwksp(ndb),p,r,wksp(iwkpt1), a pdp,pldup) return end subroutine sub104 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub104 calls the ic preconditioner. c (multicolor purdue) c c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 ipt2 = ifactr + n if (propa) call icscp (ndim,ndim,n,jcoef(ipt1),wksp(ifactr), a coef(ipt1),ncolor,iwksp(nc),iwksp(ndt), a iwksp(ndb),1,wksp(iwkpt1),r,z) if (.not. propa) call icscp (n,ndim,n,jcoef(ipt1),wksp(ifactr), a wksp(ipt2),ncolor,iwksp(nc),iwksp(ndt), a iwksp(ndb),0,wksp(iwkpt1),r,z) return end subroutine sub105 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub105 calls the ic preconditioner. c (multicolor purdue) c c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 ipt2 = ifactr + n if (propa) call icscpt (ndim,ndim,n,jcoef(ipt1),wksp(ifactr), a coef(ipt1),ncolor,iwksp(nc),iwksp(ndt), a iwksp(ndb),1,wksp(iwkpt1),r,z) if (.not. propa) call icscpt (n,ndim,n,jcoef(ipt1),wksp(ifactr), a wksp(ipt2),ncolor,iwksp(nc),iwksp(ndt), a iwksp(ndb),0,wksp(iwkpt1),r,z) return end subroutine sub106 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub106 calls the ic preconditioner. c (multicolor purdue) c c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 ipt2 = ifactr + n if (propa) call icscp1 (ndim,ndim,n,jcoef(ipt1),wksp(ifactr), a coef(ipt1),ncolor,iwksp(nc),iwksp(ndt), a iwksp(ndb),1,wksp(iwkpt1),r,z) if (.not. propa) call icscp1 (n,ndim,n,jcoef(ipt1),wksp(ifactr), a wksp(ipt2),ncolor,iwksp(nc),iwksp(ndt), a iwksp(ndb),0,wksp(iwkpt1),r,z) return end subroutine sub107 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub107 calls the ic preconditioner. c (multicolor purdue) c c common / dscons / ndim, mdim, maxnz logical propa common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 ipt2 = ifactr + n if (propa) call icscp3 (ndim,ndim,n,jcoef(ipt1),wksp(ifactr), a coef(ipt1),ncolor,iwksp(nc),iwksp(ndt), a iwksp(ndb),1,wksp(iwkpt1),r,z) if (.not. propa) call icscp3 (n,ndim,n,jcoef(ipt1),wksp(ifactr), a wksp(ipt2),ncolor,iwksp(nc),iwksp(ndt), a iwksp(ndb),0,wksp(iwkpt1),r,z) return end subroutine sub108 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub104 calls the ic preconditioner. c (multicolor purdue) c c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 ipt2 = ifactr + n if (propa) call icscp2 (ndim,ndim,n,jcoef(ipt1),wksp(ifactr), a coef(ipt1),ncolor,iwksp(nc),iwksp(ndt), a 1,wksp(iwkpt1),r,z) if (.not. propa) call icscp2 (n,ndim,n,jcoef(ipt1),wksp(ifactr), a wksp(ipt2),ncolor,iwksp(nc),iwksp(ndt), a 0,wksp(iwkpt1),r,z) return end subroutine sub109 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub104 calls the ic preconditioner. c (multicolor purdue) c c common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) c ipt1 = ndim + 1 ipt2 = ifactr + n if (propa) call icscp4 (ndim,ndim,n,jcoef(ipt1),wksp(ifactr), a coef(ipt1),ncolor,iwksp(nc),iwksp(ndt), a 1,wksp(iwkpt1),r,z) if (.not. propa) call icscp4 (n,ndim,n,jcoef(ipt1),wksp(ifactr), a wksp(ipt2),ncolor,iwksp(nc),iwksp(ndt), a 0,wksp(iwkpt1),r,z) return end subroutine sub110 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub110 calls ppii, for lspoly preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba12 c call ppii (suba12,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt2),n,r,z) return end subroutine sub111 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub111 calls pneu, for neumann polynomial preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba12 c call pneu (suba12,coef,jcoef,wksp,iwksp,coef,ndeg, a wksp(iwkpt2),n,r,z) return end subroutine sub112 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub112 calls ppii, for lspoly preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba13 c call ppii (suba13,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt2),n,r,z) return end subroutine sub113 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub113 calls ppii, for lspoly preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom8 / ainf integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba14 c call ppii (suba14,coef,jcoef,wksp,iwksp,ainf, a 0.0d0,0.0d0,ndeg,wksp(iwkpt2),n,r,z) return end subroutine sub114 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub114 calls pneu, for neumann polynomial preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba13 c call pneu (suba13,coef,jcoef,wksp,iwksp,coef,ndeg, a wksp(iwkpt2),n,r,z) return end subroutine sub115 (coef,jcoef,wksp,iwksp,n,r,z) implicit double precision (a-h, o-z) c c ... sub115 calls pneu, for neumann polynomial preconditioning. c c common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) external suba14 c call pneu (suba14,coef,jcoef,wksp,iwksp,coef,ndeg, a wksp(iwkpt2),n,r,z) return end subroutine lfact (coef,jcoef,wksp,nn,ier) implicit double precision (a-h, o-z) c c ... lfact computes a line factorization. c c ... parameters -- c c n problem size c nfactr factorization size c c ... common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2) dimension coef(1), wksp(1) c c ... check for sufficient workspace to store factor. c n = nn if (nstore .eq. 2) isym = 0 if (nstore .eq. 3) isym = 1 ndt = 0 ndb = 0 do 20 jd = 1,maxnz do 15 j = 1,maxnz if (jcoef(j) .ne. jd) go to 15 ndt = ndt + 1 go to 20 15 continue go to 25 20 continue 25 if (isym .eq. 0) go to 40 do 35 jd = 1,maxnz do 30 j = 1,maxnz if (jcoef(j) .ne. -jd) go to 30 ndb = ndb + 1 go to 35 30 continue go to 40 35 continue 40 nfactr = (ndt + ndb + 1)*n call needw ('lfact',0,irpnt,nfactr,ier) if (ier .lt. 0) return c ifactr = irpnt call vcopy (n,coef,wksp(ifactr)) ndt = 0 do 55 jd = 1,maxnz do 50 j = 1,maxnz if (jcoef(j) .ne. jd) go to 50 ndt = ndt + 1 ipt1 = (j - 1)*ndim + 1 ipt2 = ndt*n + ifactr call vcopy (n,coef(ipt1),wksp(ipt2)) go to 55 50 continue go to 60 55 continue 60 ndb = 0 if (isym .eq. 0) go to 75 do 70 jd = 1,maxnz do 65 j = 1,maxnz if (jcoef(j) .ne. -jd) go to 65 ndb = ndb + 1 ipt1 = (j - 1)*ndim + 1 ipt2 = (ndt + ndb)*n + ifactr call vcopy (n,coef(ipt1),wksp(ipt2)) go to 70 65 continue go to 75 70 continue c c ... factor. c 75 call bdfac (n,n,kblsz,ndt,ndb,wksp(ifactr),isym) irpnt = irpnt + nfactr return end subroutine linv (coef,jcoef,wksp,nn,ier) implicit double precision (a-h, o-z) c c ... linv computes a line approximate inverse. c c ... parameters -- c c n problem size c nfactr factorization size c c ... common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / intern / ndt, ndb, maxt, maxb, ivers, irwise integer jcoef(2) dimension coef(1), wksp(1) c c ... check for sufficient workspace to store factor. c n = nn if (nstore .eq. 2) isym = 0 if (nstore .eq. 3) isym = 1 ndt = 0 ndb = 0 do 20 jd = 1,maxnz do 15 j = 1,maxnz if (jcoef(j) .ne. jd) go to 15 ndt = ndt + 1 go to 20 15 continue go to 25 20 continue 25 if (isym .eq. 0) go to 40 do 35 jd = 1,maxnz do 30 j = 1,maxnz if (jcoef(j) .ne. -jd) go to 30 ndb = ndb + 1 go to 35 30 continue go to 40 35 continue c 40 ndt = ndt + ltrunc if (isym .eq. 1) ndb = ndb + ltrunc nfactr = (ndt + ndb + 1)*n call needw ('linv',0,irpnt,nfactr,ier) if (ier .lt. 0) return c ifactr = irpnt call vfill (nfactr,wksp(ifactr),0.0d0) call vcopy (n,coef,wksp(ifactr)) it = 0 do 55 jd = 1,maxnz do 50 j = 1,maxnz if (jcoef(j) .ne. jd) go to 50 it = it + 1 ipt1 = (j - 1)*ndim + 1 ipt2 = it*n + ifactr call vcopy (n,coef(ipt1),wksp(ipt2)) go to 55 50 continue go to 60 55 continue 60 if (isym .eq. 0) go to 75 it = ndt do 70 jd = 1,maxnz do 65 j = 1,maxnz if (jcoef(j) .ne. -jd) go to 65 it = it + 1 ipt1 = (j - 1)*ndim + 1 ipt2 = it*n + ifactr call vcopy (n,coef(ipt1),wksp(ipt2)) go to 70 65 continue go to 75 70 continue c c ... factor and invert. c 75 call bdfac (n,n,kblsz,ndt,ndb,wksp(ifactr),isym) call bdinv (n,n,kblsz,ndt,ndb,wksp(ifactr),isym) irpnt = irpnt + nfactr return end subroutine mfact (coef,jcoef,wksp,iwksp,nn,ier) implicit double precision (a-h, o-z) c c ... mfact computes a line factorization of a multi-color matrix. c c ... parameters -- c c n problem size c nfactr factorization size c c ... common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / intern / ndt, ndb, maxt, maxb, ivers, irwise logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) c c ... check for sufficient workspace to store factor. c n = nn ndt = iwksp(iblock+2) - 1 ndb = iwksp(iblock+ncolor*3+2) nwdiag = ndt + ndb + 1 nfactr = n*nwdiag call needw ('mfact',0,irpnt,nfactr,ier) if (ier .lt. 0) return c ifactr = irpnt do 15 j = 1,nwdiag ipt1 = (j - 1)*ndim + 1 ipt2 = (j - 1)*n + ifactr call vcopy (n,coef(ipt1),wksp(ipt2)) 15 continue c c ... factor. c call bdfac (n,n,n,ndt,ndb,wksp(ifactr),1) irpnt = irpnt + nfactr return end subroutine pfact1 (coef,jcoef,wksp,iwksp,nn,methh,ier) implicit double precision (a-h, o-z) c c ... pfact1 computes a point incomplete factorization. c c ... parameters c c n order of system c meth method of factorization c = 1 ic (unmodified) c = 2 mic (modified) c nfactr amount of floating point workspace needed for factorization c nfacti amount of integer workspace needed for factorization c ier error flag c c ... specifications for parameters c c integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c n = nn meth = methh c c ... if requested, find out if matrix has property a. c if (ipropa .eq. 0) propa = .false. if (ipropa .eq. 1) propa = .true. if (lvfill .gt. 0) propa = .false. if (lvfill .gt. 0) go to 55 if (ipropa .ne. 2) go to 15 call needw ('pfact1',1,iipnt,2*n,ier) if (ier .lt. 0) return call prbndx (n,ndim,maxnz,jcoef,coef,iwksp(iipnt), a iwksp(iipnt+n),propa,1) if (propa) ipropa = 1 if (.not. propa) ipropa = 0 c 15 if (.not. propa) go to 35 c c ... propa = .true. c ifactr = irpnt nfactr = n nfacti = 0 call needw ('pfact1',0,irpnt,nfactr+n,ier) if (ier .lt. 0) return call vcopy (n,coef,wksp(ifactr)) irpnt = irpnt + nfactr ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 if (isymm .eq. 0) call icfp (ndim,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),coef(ip1),meth,1,omega, a wksp(irpnt),iflag) if (isymm .ne. 0) call icfnp (ndim,ndim,n,maxt,maxb,jcoef(ip1), a jcoef(ip2),wksp(ifactr),coef(ip1), a coef(ip2),meth,1,omega,iflag) if (iflag .eq. 1) ier = -12 if (iflag .eq. 2) ier = 5 if (iflag .eq. 0) return call ershow (ier,'pfact1') return c c ... propa = .false., lvfill = 0. c 35 ifactr = irpnt jmax = maxt + 1 if (isymm .ne. 0) jmax = 1 + maxt + maxb nfactr = n*jmax nfacti = 0 call needw ('pfact1',0,irpnt,nfactr+n,ier) if (ier .lt. 0) return call vfill (nfactr,wksp(ifactr),0.0d0) do 45 j = 1,jmax ip1 = ndim*(j - 1) + 1 ip2 = n*(j - 1) + ifactr call vcopy (n,coef(ip1),wksp(ip2)) 45 continue irpnt = irpnt + nfactr ip1 = ndim + 1 ip2 = ndim*(maxt + 1) + 1 ip3 = ifactr + n ip4 = n*(maxt + 1) + ifactr if (isymm .eq. 0) call icfp (n,ndim,n,maxt,jcoef(ip1), a wksp(ifactr),wksp(ip3),meth,0,omega, a wksp(irpnt),iflag) if (isymm .ne. 0) call icfnp (n,ndim,n,maxt,maxb,jcoef(ip1), a jcoef(ip2),wksp(ifactr),wksp(ip3), a wksp(ip4),meth,0,omega,iflag) if (iflag .eq. 1) ier = -12 if (iflag .eq. 2) ier = 5 if (iflag .eq. 0) return call ershow (ier,'pfact1') return c c ... propa = .false., lvfill .gt. 0 c 55 len = n*(maxt + 1) if (isymm .ne. 0) len = n*(1 + maxt + maxb) call needw ('pfact1',1,iipnt,len,ier) if (ier .lt. 0) return call needw ('pfact1',0,irpnt,len,ier) if (ier .lt. 0) return jmax = maxt + 1 if (isymm .ne. 0) jmax = 1 + maxt + maxb do 70 j = 1,jmax ipt1 = (j - 1)*ndim + 1 ipt2 = (j - 1)*n + iipnt call vicopy (n,jcoef(ipt1),iwksp(ipt2)) ipt2 = (j - 1)*n + irpnt call vcopy (n,coef(ipt1),wksp(ipt2)) 70 continue mw1 = (leni - (iipnt + n) + 1)/n mw2 = (lenr - (irpnt + n) + 1)/n mwidth = min (mw1,mw2) maxc = maxt + maxb do 75 i = 1,lvfill if (isymm .eq. 0) call fillsp (n,n,maxt,iwksp(iipnt+n), a wksp(irpnt+n),mwidth,ier) if (isymm .ne. 0) call fillnp (n,n,maxc,iwksp(iipnt+n), a wksp(irpnt+n),mwidth,ier) if (ier .lt. 0) then call ershow (ier,'pfact1') return endif 75 continue maxcp1 = maxc + 1 if (isymm .ne. 0) call move1 (n,mwidth+1,n,maxcp1, a iwksp(iipnt),wksp(irpnt),maxt,maxb,ier) if (ier .lt. 0) then call ershow (ier,'pfact1') return endif if (isymm .eq. 0) nfactr = n*(maxt + 1) if (isymm .ne. 0) nfactr = n*(maxt + maxb + 1) nfacti = nfactr call needw ('pfact1',0,irpnt,nfactr+n,ier) if (ier .lt. 0) return call needw ('pfact1',1,iipnt,nfacti,ier) if (ier .lt. 0) return c ifactr = irpnt ifacti = iipnt irpnt = irpnt + nfactr iipnt = iipnt + nfacti ip1 = ifacti + n ip2 = ifacti + n*(maxt + 1) ip3 = ifactr + n ip4 = ifactr + n*(maxt + 1) if (isymm .eq. 0) call icfp (n,n,n,maxt,iwksp(ip1), a wksp(ifactr),wksp(ip3), a meth,0,omega,wksp(irpnt),iflag) if (isymm .ne. 0) call icfnp (n,n,n,maxt,maxb,iwksp(ip1), a iwksp(ip2),wksp(ifactr),wksp(ip3), a wksp(ip4),meth,0,omega,iflag) if (iflag .eq. 1) ier = -12 if (iflag .eq. 2) ier = 5 if (iflag .eq. 0) return call ershow (ier,'pfact1') return end subroutine pfact2 (coef,jcoef,wksp,iwksp,nn,methh,ier) implicit double precision (a-h, o-z) c c ... pfact2 computes a point incomplete factorization. c c ... parameters c c n order of system c meth method of factorization c = 1 ic (unmodified) c = 2 mic (modified) c nfactr amount of floating point workspace needed for factorization c ier error flag c c ... specifications for parameters c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) c n = nn meth = methh c c ... if requested, find out if matrix has property a. c if (ipropa .eq. 0) propa = .false. if (ipropa .eq. 1) propa = .true. if (lvfill .gt. 0) propa = .false. if (lvfill .gt. 0) go to 20 if (ipropa .ne. 2) go to 15 call needw ('pfact2',1,iipnt,2*n,ier) if (ier .lt. 0) return call prbndx (n,ndim,maxnz,jcoef,coef,iwksp(iipnt), a iwksp(iipnt+n),propa,2) if (propa) ipropa = 1 if (.not. propa) ipropa = 0 c 15 if (.not. propa) go to 20 c c ... propa = .true. c maxt = maxnz - 1 maxb = 0 ifactr = irpnt nfactr = n nfacti = 0 call needw ('pfact2',0,irpnt,nfactr+n,ier) if (ier .lt. 0) return call rowise (maxnz,jcoef,irwise) call needw ('pfact2',1,iipnt,maxnz+maxt**2,ier) if (ier .lt. 0) return call vfill (n,wksp(ifactr),0.0d0) call vcopy (n,coef,wksp(ifactr)) irpnt = irpnt + nfactr if (ifctv .eq. 0) call icf a (ndim,n,maxt,jcoef(2),wksp(ifactr),coef(ndim+1), a meth,1,omega,wksp(irpnt),iwksp(iipnt),iflag) if (ifctv .eq. 1) call icfv a (ndim,n,maxt,jcoef(2),wksp(ifactr),coef(ndim+1), a meth,1,omega,wksp(irpnt),iwksp(iipnt),iflag) if (iflag .eq. 1) ier = -12 if (iflag .eq. 2) ier = 5 if (iflag .eq. 0) return call ershow (ier,'pfact2') return c c ... propa = .false. c 20 call vicopy (maxnz,jcoef,iwksp(iipnt)) maxt = maxnz - 1 maxb = 0 if (lvfill .eq. 0) go to 26 do 25 i = 1,lvfill 25 call fills (maxt,iwksp(iipnt+1)) 26 nfactr = n*(maxt + 1) nfacti = maxt + 1 call needw ('pfact2',1,iipnt,maxt**2,ier) if (ier .lt. 0) return call needw ('pfact2',0,irpnt,nfactr+n,ier) if (ier .lt. 0) return c ifactr = irpnt ifacti = iipnt call vfill (nfactr,wksp(ifactr),0.0d0) do 40 j = 1,maxnz ip1 = ndim*(j - 1) + 1 ip2 = n*(j - 1) + ifactr call vcopy (n,coef(ip1),wksp(ip2)) 40 continue irpnt = irpnt + nfactr iipnt = iipnt + maxt + 1 call rowise (maxt+1,iwksp(ifacti),irwise) call needw ('pfact2',1,iipnt,maxt,ier) if (ier .lt. 0) return if (ifctv .eq. 0) call icf a (n,n,maxt,iwksp(ifacti+1),wksp(ifactr),wksp(ifactr+n), a meth,0,omega,wksp(irpnt),iwksp(iipnt),iflag) if (ifctv .eq. 1) call icfv a (n,n,maxt,iwksp(ifacti+1),wksp(ifactr),wksp(ifactr+n), a meth,0,omega,wksp(irpnt),iwksp(iipnt),iflag) if (iflag .eq. 1) ier = -12 if (iflag .eq. 2) ier = 5 if (iflag .eq. 0) return call ershow (ier,'pfact2') return end subroutine pfact3 (coef,jcoef,wksp,iwksp,nn,meth,ier) implicit double precision (a-h, o-z) c c ... pfact3 computes a point incomplete factorization. c c ... parameters c c n order of system c meth method of factorization c = 1 ic (unmodified) c = 2 mic (modified) c nfactr amount of floating point workspace needed for factorization c ier error flag c c ... specifications for parameters c c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) c n = nn c c ... if requested, find out if matrix has property a. c if (ipropa .eq. 0) propa = .false. if (ipropa .eq. 1) propa = .true. if (lvfill .gt. 0) propa = .false. if (lvfill .gt. 0) go to 20 if (ipropa .ne. 2) go to 15 call needw ('pfact3',1,iipnt,2*n,ier) if (ier .lt. 0) return call prbndx (n,ndim,maxnz,jcoef,coef,iwksp(iipnt), a iwksp(iipnt+n),propa,3) if (propa) ipropa = 1 if (.not. propa) ipropa = 0 c 15 if (.not. propa) go to 20 c c ... propa = .true. c ifactr = irpnt nfactr = n nfacti = 0 call needw ('pfact3',0,irpnt,nfactr+n,ier) if (ier .lt. 0) return call rowise (maxnz,jcoef,irwise) call needw ('pfact3',1,iipnt,maxt*maxb,ier) if (ier .lt. 0) return call vfill (n,wksp(ifactr),0.0d0) call vcopy (n,coef,wksp(ifactr)) irpnt = irpnt + nfactr maxtp1 = maxt + 1 call icfn (ndim,n,maxt,maxb,jcoef(2),jcoef(maxt+2), a wksp(ifactr),coef(ndim+1),coef(ndim*maxtp1+1), a meth,1,omega,wksp(irpnt),iwksp(iipnt),iflag) if (iflag .eq. 1) ier = -12 if (iflag .eq. 2) ier = 5 if (iflag .eq. 0) return call ershow (ier,'pfact3') return c c ... propa = .false. c 20 call vicopy (maxnz,jcoef,iwksp(iipnt)) maxz = maxnz if (lvfill .eq. 0) go to 26 do 25 i = 1,lvfill 25 call filln (maxz,iwksp(iipnt)) 26 nfactr = n*maxz nfacti = maxz call needw ('pfact3',1,iipnt,maxz,ier) if (ier .lt. 0) return call needw ('pfact3',0,irpnt,nfactr,ier) if (ier .lt. 0) return c ifactr = irpnt ifacti = iipnt call vfill (nfactr,wksp(ifactr),0.0d0) do 40 j = 1,maxnz ip1 = ndim*(j - 1) + 1 ip2 = n*(j - 1) + ifactr call vcopy (n,coef(ip1),wksp(ip2)) 40 continue irpnt = irpnt + nfactr iipnt = iipnt + maxz call rowise (maxz,iwksp(ifacti),irwise) call needw ('pfact3',0,irpnt,n,ier) if (ier .lt. 0) return call move2 (n,n,maxz,iwksp(ifacti),wksp(ifactr), a wksp(irpnt),iwksp(iipnt),maxt,maxb) call needw ('pfact3',1,iipnt,maxt*maxb,ier) if (ier .lt. 0) return ipt1 = ifacti + maxt + 1 ipt2 = ifactr + n*(maxt + 1) call icfn (n,n,maxt,maxb,iwksp(ifacti+1),iwksp(ipt1), a wksp(ifactr),wksp(ifactr+n),wksp(ipt2), a meth,0,omega,wksp(irpnt),iwksp(iipnt),iflag) if (iflag .eq. 1) ier = -12 if (iflag .eq. 2) ier = 5 if (iflag .eq. 0) return call ershow (ier,'pfact3') return end subroutine pfactc (coef,jcoef,wksp,iwksp,nn,methh,ier) implicit double precision (a-h, o-z) c c ... pfactc computes a point incomplete factorization. c (multicolor ordering) c c ... parameters c c n order of system c meth method of factorization c = 1 ic (unmodified) c = 2 mic (modified) c ier error flag c c ... specifications for parameters c c integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c n = nn meth = methh c c ... if requested, find out if matrix has property a. c if (ipropa .eq. 0) propa = .false. if (ipropa .eq. 1) propa = .true. if (ipropa .ne. 2) go to 15 call needw ('pfactc',1,iipnt,2*n,ier) if (ier .lt. 0) return call prbndx (n,ndim,maxnz,jcoef,coef,iwksp(iipnt), a iwksp(iipnt+n),propa,1) if (propa) ipropa = 1 if (.not. propa) ipropa = 0 c 15 if (.not. propa) go to 30 c c ... propa = .true. c ifactr = irpnt nfactr = n nfacti = 0 call needw ('pfactc',0,irpnt,nfactr,ier) if (ier .lt. 0) return call vcopy (n,coef,wksp(ifactr)) irpnt = irpnt + nfactr ip1 = ndim + 1 maxc = maxnz - 1 call icfcp (ndim,ndim,n,maxc,jcoef(ip1),wksp(ifactr), a coef(ip1),ncolor,iwksp(ndt),iwksp(ndb), a meth,1,iwksp(ipt),omega,iflag) if (iflag .eq. 1) ier = -12 if (iflag .eq. 2) ier = 5 if (iflag .eq. 0) return call ershow (ier,'pfactc') return c c ... propa = .false. c 30 ifactr = irpnt nfactr = n*maxnz nfacti = 0 call needw ('pfactc',0,irpnt,nfactr,ier) if (ier .lt. 0) return call vfill (nfactr,wksp(ifactr),0.0d0) do 45 j = 1,maxnz ip1 = ndim*(j - 1) + 1 ip2 = n*(j - 1) + ifactr call vcopy (n,coef(ip1),wksp(ip2)) 45 continue irpnt = irpnt + nfactr ip1 = ndim + 1 ip3 = ifactr + n maxc = maxnz - 1 call icfcp (n,ndim,n,maxc,jcoef(ip1),wksp(ifactr),wksp(ip3), a ncolor,iwksp(ndt),iwksp(ndb),meth, a 0,iwksp(ipt),omega,iflag) if (iflag .eq. 1) ier = -12 if (iflag .eq. 2) ier = 5 if (iflag .eq. 0) return call ershow (ier,'pfactc') return end subroutine bfacmz (methf,factor,coef,jcoef,wksp,iwksp,nn,ier) implicit double precision (a-h, o-z) c c ... bfacmz computes a block factorization. c (nonsymmetric diagonal) c c ... parameters c c n order of system c nfactr amount of floating point workspace needed for factorization c ier error flag c c ... specifications for parameters c c external factor common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp dimension coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) c n = nn if (methf .le. 2) ivers = 1 if (methf .gt. 2) ivers = 2 c c ... if requested, find out if matrix has block property a. c ncol = n/kblsz if (ipropa .eq. 0) propa = .false. if (ipropa .eq. 1) propa = .true. if (lvfill .gt. 0) propa = .false. if (lvfill .gt. 0) go to 15 if (ipropa .ne. 2) go to 15 call needw ('bfacmz',1,iipnt,2*ncol,ier) if (ier .lt. 0) return iwksp(iipnt) = lbhb call prbblk (ncol,1,iwksp(iblock),iwksp(iipnt), a iwksp(iipnt+1),iwksp(iipnt+ncol+1),propa) if (propa) ipropa = 1 if (.not. propa) ipropa = 0 c c ... calculate fill-in and factor. c 15 call fillbn (n,coef,jcoef,iwksp(iblock),wksp,iwksp,ier) if (ier .lt. 0) return nwnew = iwksp(iblock+2) + iwksp(iblock+5) nwdiag = nwnew - 2*ltrunc if (methf .eq. 1) nwkp = kblsz*nwnew if (methf .eq. 2) nwkp = kblsz*(nwnew + 1) if (methf .eq. 3) nwkp = 0 if (methf .eq. 4) nwkp = n + 2*kblsz call needw ('fillbn',0,irpnt,nwkp,ier) if (ier .lt. 0) return ipt1 = iblock + 3*lbhb ipt2 = ipt1 + nwnew idumb(1) = kblsz idumb(2) = 1 idumb(3) = lbhb if (propa) then call factor (n,ndim,n,iwksp(iipnt),jcoef(nwdiag+1), a wksp(ifactr),coef(ndim*nwdiag+1),1, a idumb(1),iwksp(iblock),idumb(3),1,1, a idumb(2),omega,wksp(irpnt),ier) endif if (.not. propa .and. lvfill .eq. 0) then call factor (n,n,n,iwksp(iipnt),jcoef(nwdiag+1), a wksp(ifactr),wksp(iwkpt2),1, a idumb(1),iwksp(iblock),idumb(3),1,0, a idumb(2),omega,wksp(irpnt),ier) endif if (lvfill .gt. 0) then call factor (n,n,n,iwksp(ipt1),iwksp(ipt2), a wksp(ifactr),wksp(iwkpt2),1, a idumb(1),iwksp(iblock),idumb(3),1,0, a idumb(2),omega,wksp(irpnt),ier) endif return end subroutine bfacs (methf,factor,coef,jcoef,wksp,iwksp,nn,ier) implicit double precision (a-h, o-z) c c ... bfacs computes a block factorization. c (symmetric diagonal) c c ... parameters c c n order of system c nfactr amount of floating point workspace needed for factorization c ier error flag c c ... specifications for parameters c c external factor common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) c n = nn if (methf .le. 2) ivers = 1 if (methf .gt. 2) ivers = 2 c c ... if requested, find out if matrix has block property a. c ncol = n/kblsz if (ipropa .eq. 0) propa = .false. if (ipropa .eq. 1) propa = .true. if (lvfill .gt. 0) propa = .false. if (lvfill .gt. 0) go to 15 if (ipropa .ne. 2) go to 15 call needw ('bfacs',1,iipnt,2*ncol,ier) if (ier .lt. 0) return iwksp(iipnt) = lbhb call prbblk (ncol,1,iwksp(iblock),iwksp(iipnt), a iwksp(iipnt+1),iwksp(iipnt+ncol+1),propa) if (propa) ipropa = 1 if (.not. propa) ipropa = 0 c c ... calculate fill-in and factor. c 15 call fillb (n,coef,jcoef,iwksp(iblock),wksp,iwksp,ier) if (ier .lt. 0) return nwnew = iwksp(iblock+2) nwdiag = nwnew - ltrunc if (methf .eq. 1) nwkp = kblsz*nwnew if (methf .eq. 2) nwkp = kblsz*(nwnew + 1) if (methf .eq. 3) nwkp = 0 if (methf .eq. 4) nwkp = n + 2*kblsz call needw ('fillb',0,irpnt,nwkp,ier) if (ier .lt. 0) return ipt1 = iblock + 3*lbhb ipt2 = ipt1 + nwnew if (propa) then call factor (n,ndim,n,iwksp(iipnt),jcoef(nwdiag+1), a wksp(ifactr),coef(ndim*nwdiag+1),kblsz, a iwksp(iblock),lbhb,1,omega,wksp(irpnt),ier) endif if (.not. propa .and. lvfill .eq. 0) then call factor (n,n,n,iwksp(iipnt),jcoef(nwdiag+1), a wksp(ifactr),wksp(iwkpt2),kblsz, a iwksp(iblock),lbhb,0,omega,wksp(irpnt),ier) endif if (lvfill .gt. 0) then call factor (n,n,n,iwksp(ipt1),iwksp(ipt2),wksp(ifactr), a wksp(iwkpt2),kblsz,iwksp(iblock),lbhb,0, a omega,wksp(irpnt),ier) endif return end subroutine fillb (nn,coef,jcoef,iblock,wksp,iwksp,ier) implicit double precision (a-h, o-z) c c ... fillb calculates block fill-in for block factorization methods. c (symmetric diagonal storage) c c ... parameters -- c c n order of system c coef floating point matrix coefficient array c jcoef integer matrix coefficient array c iblock array for block information c wksp floating point workspace array c iwksp integer workspace array c ier error flag c c ... specifications for parameters c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblk, ncmax dimension coef(1), wksp(1) integer jcoef(1), iblock(3,3), iwksp(1) c n = nn c c ... determine block fill-in pattern. c if (lvfill .gt. 0) then lbhbsa = lbhb do 25 lv = 1,lvfill lbhbl = lbhb do 20 j1 = 3,lbhb do 15 j2 = 3,lbhb jd = iblock(1,j1) - iblock(1,j2) if (jd .le. 0) go to 15 do 10 j3 = 3,lbhbl if (iblock(1,j3) .eq. jd) go to 15 10 continue lbhbl = lbhbl + 1 iblock(1,lbhbl) = jd iblock(3,lbhbl) = 0 15 continue 20 continue lbhb = lbhbl 25 continue endif c c ... compute constants and check for sufficient workspace. c call needw ('fillb',1,iblk,3*lbhb,ier) if (ier .lt. 0) return nwdiag = iblock(3,1) nwnew = nwdiag + ltrunc iipnt = iblk + 3*lbhb ifactr = irpnt nwk = 3*lbhb + maxnz + ltrunc + (lbhb-2)*(2*nwnew-1) call needw ('fillb',1,iblk,nwk,ier) if (ier .lt. 0) return do 30 j = 1,nwnew 30 iwksp(iipnt+j-1) = j - 1 iblock(3,1) = nwnew c c ... determine diagonal numbers in filled-in block matrix. c if (lvfill .gt. 0) then jmax = 3 do 32 j = 3,lbhbsa if (iblock(1,j) .gt. iblock(1,jmax)) jmax = j 32 continue jnext = iipnt + nwnew do 50 jjc = 3,lbhb if (jjc .le. lbhbsa) then jstc = iblock(2,jjc) mc = iblock(3,jjc) j1 = jnext do 35 j = 1,mc iwksp(jnext) = jcoef(nwdiag+jstc+j-1) jnext = jnext + 1 35 continue j2 = jnext - 1 endif if (jjc .eq. jmax) go to 50 jblkc = iblock(1,jjc) inc = jblkc*kblsz lim1 = inc - (nwnew - 1) lim2 = inc + (nwnew - 1) do 45 j = lim1,lim2 if (jjc .le. lbhbsa) then do 40 jj = j1,j2 if (iwksp(jj) .eq. j) go to 45 40 continue endif iwksp(jnext) = j jnext = jnext + 1 iblock(3,jjc) = iblock(3,jjc) + 1 45 continue 50 continue if (lbhb .ge. 4) then do 52 jjc = 4,lbhb 52 iblock(2,jjc) = iblock(2,jjc-1) + iblock(3,jjc-1) endif endif c c ... copy matrix into wksp. c if (propa) then nfactr = n*nwnew nfacti = 3*lbhb endif if (.not. propa .and. lvfill .eq. 0) then nfactr = n*(maxnz + ltrunc) nfacti = 3*lbhb endif if (lvfill .gt. 0) then ndg = 0 do 55 j = 1,lbhb 55 ndg = ndg + iblock(3,j) nfactr = n*ndg nfacti = ndg + 3*lbhb endif call needw ('fillb',0,ifactr,nfactr,ier) if (ier .lt. 0) return call needw ('fillb',1,ifacti,nfacti,ier) if (ier .lt. 0) return call vfill (nfactr,wksp(ifactr),0.0d0) ipt1 = 1 ipt2 = ifactr do 60 j = 1,nwdiag call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n 60 continue iwkpt2 = ifactr + n*nwnew ipt2 = iwkpt2 if (.not. propa .and. lvfill .eq. 0) then do 62 j = nwdiag+1,maxnz call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n 62 continue endif if (lvfill .gt. 0) then j1 = iipnt + nwnew j2 = iipnt + ndg - 1 do 70 j = nwdiag+1,maxnz jcol = jcoef(j) ipt1 = (j - 1)*ndim + 1 do 65 jj = j1,j2 if (iwksp(jj) .ne. jcol) go to 65 ipt2 = iwkpt2 + (jj-j1)*n call vcopy (n,coef(ipt1),wksp(ipt2)) go to 70 65 continue 70 continue endif irpnt = ifactr + nfactr iipnt = ifacti + nfacti return end subroutine fillbn (nn,coef,jcoef,iblock,wksp,iwksp,ier) implicit double precision (a-h, o-z) c c ... fillbn calculates block fill-in for block factorization methods. c (nonsymmetric diagonal storage) c c ... parameters -- c c n order of system c coef floating point matrix coefficient array c jcoef integer matrix coefficient array c iblock array for block information c wksp floating point workspace array c iwksp integer workspace array c ier error flag c c ... specifications for parameters c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblk, ncmax dimension coef(1), wksp(1) integer jcoef(1), iblock(3,3), iwksp(1) c n = nn c c ... determine block fill-in pattern. c if (lvfill .gt. 0) then lbhbsa = lbhb do 25 lv = 1,lvfill lbhbl = lbhb do 20 j1 = 3,lbhb do 15 j2 = 3,lbhb jd = iblock(1,j1) + iblock(1,j2) if (iblock(1,j1)*iblock(1,j2) .ge. 0) go to 15 do 10 j3 = 1,lbhbl if (iblock(1,j3) .eq. jd) go to 15 10 continue lbhbl = lbhbl + 1 iblock(1,lbhbl) = jd iblock(3,lbhbl) = 0 15 continue 20 continue lbhb = lbhbl 25 continue endif c c ... compute constants and check for sufficient workspace. c call needw ('fillbn',1,iblk,3*lbhb,ier) if (ier .lt. 0) return ndt = iblock(3,1) - 1 ndb = iblock(3,2) nwdiag = ndt + ndb + 1 nwnew = nwdiag + 2*ltrunc iipnt = iblk + 3*lbhb ifactr = irpnt nwk = 3*lbhb + maxnz + 2*ltrunc + (lbhb-2)*nwnew call needw ('fillbn',1,iblk,nwk,ier) if (ier .lt. 0) return do 30 j = 1,ndt+ltrunc+1 30 iwksp(iipnt+j-1) = j - 1 do 31 j = ndt+ltrunc+2,nwnew 31 iwksp(iipnt+j-1) = -(j - ndt - ltrunc - 1) iblock(3,1) = ndt + ltrunc + 1 iblock(3,2) = ndb + ltrunc iblock(2,2) = iblock(2,1) + iblock(3,1) c c ... determine diagonal numbers in filled-in block matrix. c if (lvfill .gt. 0) then jmax = 3 jmin = 3 do 32 j = 3,lbhbsa if (iblock(1,j) .gt. iblock(1,jmax)) jmax = j if (iblock(1,j) .lt. iblock(1,jmin)) jmin = j 32 continue jnext = iipnt + nwnew do 50 jjc = 3,lbhb if (jjc .le. lbhbsa) then jstc = iblock(2,jjc) mc = iblock(3,jjc) j1 = jnext do 35 j = 1,mc iwksp(jnext) = jcoef(nwdiag+jstc+j-1) jnext = jnext + 1 35 continue j2 = jnext - 1 endif if (jjc .eq. jmax .or. jjc .eq. jmin) go to 50 jblkc = iblock(1,jjc) inc = jblkc*kblsz lim1 = inc - (ndb + ltrunc) lim2 = inc + (ndt + ltrunc) do 45 j = lim1,lim2 if (jjc .le. lbhbsa) then do 40 jj = j1,j2 if (iwksp(jj) .eq. j) go to 45 40 continue endif iwksp(jnext) = j jnext = jnext + 1 iblock(3,jjc) = iblock(3,jjc) + 1 45 continue 50 continue if (lbhb .ge. 4) then do 52 jjc = 4,lbhb 52 iblock(2,jjc) = iblock(2,jjc-1) + iblock(3,jjc-1) endif endif c c ... copy matrix into wksp. c if (propa) then nfactr = n*nwnew nfacti = 3*lbhb endif if (.not. propa .and. lvfill .eq. 0) then nfactr = n*(maxnz + 2*ltrunc) nfacti = 3*lbhb endif if (lvfill .gt. 0) then ndg = 0 do 55 j = 1,lbhb 55 ndg = ndg + iblock(3,j) nfactr = n*ndg nfacti = ndg + 3*lbhb endif call needw ('fillbn',0,ifactr,nfactr,ier) if (ier .lt. 0) return call needw ('fillbn',1,ifacti,nfacti,ier) if (ier .lt. 0) return call vfill (nfactr,wksp(ifactr),0.0d0) ipt1 = 1 ipt2 = ifactr do 60 j = 1,ndt+1 call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n 60 continue ipt2 = ipt2 + n*ltrunc do 61 j = ndt+2,nwdiag call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n 61 continue iwkpt2 = ifactr + n*nwnew ipt2 = iwkpt2 if (.not. propa .and. lvfill .eq. 0) then do 62 j = nwdiag+1,maxnz call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n 62 continue endif if (lvfill .gt. 0) then j1 = iipnt + nwnew j2 = iipnt + ndg - 1 do 70 j = nwdiag+1,maxnz jcol = jcoef(j) ipt1 = (j - 1)*ndim + 1 do 65 jj = j1,j2 if (iwksp(jj) .ne. jcol) go to 65 ipt2 = iwkpt2 + (jj-j1)*n call vcopy (n,coef(ipt1),wksp(ipt2)) go to 70 65 continue 70 continue endif irpnt = ifactr + nfactr iipnt = ifacti + nfacti return end subroutine bfacmy (methf,factor,coef,jcoef,wksp,iwksp,nn,ier) implicit double precision (a-h, o-z) c c ... bfacmy computes a block factorization. c (multicolor nonsymmetric diagonal) c c ... parameters c c n order of system c nfactr amount of floating point workspace needed for factorization c ier error flag c c ... specifications for parameters c c external factor common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp dimension coef(1), wksp(1) integer jcoef(2), iwksp(1) c n = nn if (methf .le. 2) ivers = 1 if (methf .gt. 2) ivers = 2 c c ... calculate constants. c if (ipropa .eq. 0) propa = .false. if (ipropa .eq. 1) propa = .true. c c ... calculate fill-in and factor. c call fillbc (n,ncolor,coef,jcoef,iwksp(iblock),wksp,iwksp,ier) if (ier .lt. 0) return nwdiag = ndt + ndb + 1 nwnew = nwdiag + 2*ltrunc if (methf .eq. 1) nwkp = ncmax*nwnew if (methf .eq. 2) nwkp = ncmax*(nwnew + 1) if (methf .eq. 3) nwkp = 0 if (methf .eq. 4) nwkp = n + 2*ncmax call needw ('bfacmy',0,irpnt,nwkp,ier) if (ier .lt. 0) return if (propa) then call factor (n,ndim,n,iwksp(iipnt), a iwksp(jcnew+ncolor*nwdiag), a wksp(ifactr),coef(ndim*nwdiag+1),ncolor, a iwksp(nc),iwksp(iblock),iwksp(lbhb),0,1, a iwksp(ipt),omega,wksp(irpnt),ier) endif if (.not. propa) then call factor (n,n,n,iwksp(iipnt), a iwksp(jcnew+ncolor*nwdiag), a wksp(ifactr),wksp(iwkpt2),ncolor, a iwksp(nc),iwksp(iblock),iwksp(lbhb),0,0, a iwksp(ipt),omega,wksp(irpnt),ier) endif return end subroutine fillbc (nn,ncolor,coef,jcoef,iblock,wksp,iwksp,ier) implicit double precision (a-h, o-z) c c ... fillbc sets ups wksp for block factorization methods. c (multicolor nonsymmetric diagonal) c c ... parameters -- c c n order of system c coef floating point matrix coefficient array c jcoef integer matrix coefficient array c iblock array for block information c wksp floating point workspace array c iwksp integer workspace array c ier error flag c c ... specifications for parameters c common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / intern / ndt, ndb, maxt, maxb, ivers, irwise common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 logical propa common / cblock / propa, ncol, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblk, ncmax dimension coef(1), wksp(1) integer jcoef(1), iblock(3,ncolor,3), iwksp(1) c n = nn c c ... compute constants and check for sufficient workspace. c ndt = 0 ndb = 0 do 10 j = 1,ncolor ndt = max (ndt,iblock(3,j,1)-1) ndb = max (ndb,iblock(3,j,2)) 10 continue nwdiag = ndt + ndb + 1 nwnew = nwdiag + 2*ltrunc ifactr = irpnt c c ... copy matrix into wksp. c if (propa) nfactr = n*nwnew if (.not. propa) nfactr = n*nwnew + n*(maxd-nwdiag) call needw ('fillbc',0,ifactr,nfactr,ier) if (ier .lt. 0) return call needw ('fillbc',1,iipnt,nwnew*ncolor,ier) if (ier .lt. 0) return call vfill (nfactr,wksp(ifactr),0.0d0) ipt1 = 1 ipt2 = ifactr do 15 j = 1,ndt+1 call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n 15 continue ipt2 = ipt2 + n*ltrunc do 20 j = ndt+2,nwdiag call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n 20 continue iwkpt2 = ifactr + n*nwnew ipt2 = iwkpt2 if (.not. propa) then do 25 j = nwdiag+1,maxd call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n 25 continue endif irpnt = ifactr + nfactr do 40 ico = 1,ncolor do 30 j = 1,ndt+ltrunc+1 30 iwksp(iipnt+(j-1)*ncolor+ico-1) = j - 1 do 35 j = ndt+ltrunc+2,nwnew 35 iwksp(iipnt+(j-1)*ncolor+ico-1) = -(j - ndt - ltrunc - 1) 40 continue do 45 ico = 1,ncolor iblock(3,ico,1) = ndt + ltrunc + 1 iblock(3,ico,2) = ndb + ltrunc iblock(2,ico,2) = iblock(2,ico,1) + iblock(3,ico,1) 45 continue return end subroutine blkdef (coef,jcoef,wksp,iwksp,nn,ier) implicit double precision (a-h, o-z) c c ... blkdef defines various block constants for a constant c block size matrix. c c ... parameters -- c c n problem size c c ... common blocks c common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, a jcnew, lbhb, iblock, ncmax integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) c n = nn c call needw ('blkdef',1,iipnt,3*(maxnz+1),ier) if (ier .lt. 0) return call move5 (ndim,n,maxnz,jcoef,coef) if (ifact .eq. 0) return ifacti = iipnt iblock = ifacti call defcon (ndim,n,maxnz,jcoef,coef,kblsz,iwksp(ifacti), a lbhb) nfacti = 3*lbhb iipnt = ifacti + 3*lbhb return end subroutine cg (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) external suba, subat, subql, subqlt, subqr, subqrt, subadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c ier = 0 call needw ('cg',0,irpnt,3*n+2*itmax,ier) if (ier .lt. 0) return nw = lenr - irpnt + 1 call cgw (suba,subql,coef,jcoef,wksp,iwksp, a n,u,ubar,rhs,wksp(irpnt),nw,iparm,rparm,ier) irmax = irpnt + nw - 1 return end subroutine si (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) external suba, subat, subql, subqlt, subqr, subqrt, subadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c ier = 0 call needw ('si',0,irpnt,4*n,ier) if (ier .lt. 0) return nw = lenr - irpnt + 1 call siw (suba,subql,coef,jcoef,wksp,iwksp, a n,u,ubar,rhs,wksp(irpnt),nw,iparm,rparm,ier) irmax = irpnt + nw - 1 return end subroutine srcg (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) external suba, subat, subql, subqlt, subqr, subqrt, subadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c ier = 0 call needw ('srcg',0,irpnt,3*n+2*itmax,ier) if (ier .lt. 0) return nw = lenr - irpnt + 1 call srcgw (suba,subql,subadp,coef,jcoef,wksp,iwksp, a n,u,ubar,rhs,wksp(irpnt),nw,iparm,rparm,ier) irmax = irpnt + nw - 1 return end subroutine srsi (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) external suba, subat, subql, subqlt, subqr, subqrt, subadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c ier = 0 call needw ('srsi',0,irpnt,4*n,ier) if (ier .lt. 0) return nw = lenr - irpnt + 1 call srsiw (suba,subql,subadp,coef,jcoef,wksp,iwksp, a n,u,ubar,rhs,wksp(irpnt),nw,iparm,rparm,ier) irmax = irpnt + nw - 1 return end subroutine sor (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp, a iparm,rparm,ier) implicit double precision (a-h, o-z) external suba, subat, subql, subqlt, subqr, subqrt, subadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c ier = 0 call needw ('sor',0,irpnt,2*n,ier) if (ier .lt. 0) return nw = lenr - irpnt + 1 call sorw (suba,subql,coef,jcoef,wksp,iwksp, a n,u,ubar,rhs,wksp(irpnt),nw,iparm,rparm,ier) irmax = irpnt + nw - 1 return end subroutine basic (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call basicw (suba,subql,subqr,coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine me (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call mew (suba,subql,subqr,coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine odir (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call odirw (suba,subql,subqr,coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine omin (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call ominw (suba,subql,subqr,coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine ores (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call oresw (suba,subql,subqr,coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine iom (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call iomw (suba,subql,subqr,coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine gmres (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call gmresw (suba,subql,subqr,coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine cgnr (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call cgnrw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine lsqr (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call lsqrw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine usymlq (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call uslqw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine usymqr (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call usqrw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine landir (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call ldirw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine lanmin (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call lminw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine lanres (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call lresw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine cgcr (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wk,iwk,iparm,rparm,ier) implicit double precision (a-h, o-z) c c this routine implements the constrained residual method of c j. r. wallis, coupled with truncated/restarted orthomin. for c further information about the algorithm, see "constrained residual c acceleration of conjugate residual methods", by j. r. wallis, c r. p. kendall and t. e. little of j. s. nolen and assocs. inc.; c report spe 13536, society of petroleum engineers, 1985. c c right preconditioning only is allowed in this algorithm. c c unfortunately, this routine is limited -- all blocks must be the c same size. but the idea can be easily generalized. c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wk(1), iwk(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp external nullpl, cgcrpr logical ipl, ipr, iql, iqr c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c c ... data common blocks common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / ccgcr / nblk, nband, ictac, ieta, ivcgcr c c time to proceed ... c if (nstore .ne. 2 .and. nstore .ne. 3) go to 998 c irpsav = irpnt iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 if (iql) go to 998 c ipl = .false. ipr = .true. iplr = 0 if (ipl) iplr = iplr + 1 if (ipr) iplr = iplr + 2 c c form the c**(t)*a*c matrix c 1 if (nbl1d .le. 0 .or. nbl2d .le. 0) go to 998 nbl0d = 1 if (mod(nbl2d,nbl1d) .ne. 0 .or. mod(nbl1d,nbl0d) .ne. 0) a go to 998 nblk = n / nbl2d if (nblk .eq. 1) nblk = n / nbl1d ictac = irpnt nwgb = lenr - ictac + 1 ierpp = 0 call getblk (coef,jcoef,n,nblk,nband,wk(ictac),nwgb,ierpp) irmax = max (irmax,ictac-1+nwgb) if (ierpp .lt. 0) go to 999 irpnt = ictac + nblk*nband c c perform first-iterate calculations c ieta = irpnt ivcgcr = ieta + nblk iv2 = ivcgcr + n irmax = max(irmax,iv2-1+n) if (irmax .gt. lenr) go to 997 c call suba (coef,jcoef,wk,iwk,n,u,wk(ivcgcr)) call vexopy (n,wk(ivcgcr),rhs,wk(ivcgcr),2) call tmult (n,nblk,nband,wk(ictac),wk(ieta),wk(ivcgcr), a wk(ivcgcr)) call vexopy (n,u,u,wk(ivcgcr),1) c c pass it on to orthomin ... c irpnt = iv2 nw = lenr - irpnt + 1 call omingw (suba,subql,subqr,nullpl,cgcrpr,coef,jcoef, a wk,iwk,n,u,ubar,rhs,wk(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) c irpnt = irpsav return c c error returns ... c c insuff. floating point workspace ... 997 ier = -2 call ershow (ier,'cgcr') return c c unimplemented option ... 998 ier = -16 call ershow (ier,'cgcr') return c c generic handler ... 999 ier = ierpp return end subroutine bcgs (suba,subat,subql,subqlt,subqr,subqrt,subadp, a coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) implicit double precision (a-h, o-z) c dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), a wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp c c ... data common blocks c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax c nw = lenr - irpnt + 1 call bcgsw (suba,subql,subqr,coef,jcoef, a wksp,iwksp,n,u,ubar,rhs,wksp(irpnt),nw, a iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine cgw (suba,subq,coef,jcoef,wfac,jwfac,nn,u,ubar,rhs, a wksp,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c cgw drives the conjugate gradient algorithm. c c ... parameters -- c c suba matrix-vector multiplication routine c subq preconditioning routine c n input integer. order of the system (= nn) c u input/output vector. on input, u contains the c initial guess to the solution. on output, it c contains the latest estimate to the solution. c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c wksp vector used for working space. c nw length of wksp array. if this length is less than c the amount needed, nw will give the needed amount c upon output. c iparm integer vector of length 30. allows user to c specify some integer parameters which affect c the method. c rparm floating point vector of length 30. allows user to c specify some floating point parameters which affect c the method. c ier output integer. error flag. c c ... specifications for parameters c external suba, subq integer iparm(30), jcoef(2), jwfac(1) dimension rhs(1), u(1), ubar(1), wksp(1), rparm(30), coef(1), a wfac(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- package common c c ... initialize common blocks c ier = 0 n = nn t1 = timer (dummy) iacel = 1 timit = 0.0d0 digit1 = 0.0d0 digit2 = 0.0d0 call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 35 if (level .ge. 2) write (nout,10) 10 format (1x,'cg') c c ... compute workspace base addresses and check for sufficient c ... workspace. c iw1 = 1 iw2 = iw1 + n iw3 = iw2 + n iw4 = iw3 + n nwksp = 3*n + 2*itmax if (nw .ge. nwksp) go to 15 ier = -2 call ershow (ier,'cgw') go to 30 15 continue call nmcalc (coef,jcoef,wfac,jwfac,1,subq,n,rhs,ubar,wksp,ier) if (ier .lt. 0) go to 30 c c ... zero out workspace c call vfill (nwksp,wksp,0.0d0) c c ... iteration sequence c call itcg (suba,subq,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, a wksp(iw1),wksp(iw2),wksp(iw3),wksp(iw4),ier) c if (ier .lt. 0 .or. ier .eq. 1) go to 25 c c ... method has converged c if (level .ge. 1) write (nout,20) in 20 format (/1x,'cg has converged in ',i5,' iterations' ) c c ... optional error analysis c 25 if (idgts .lt. 0) go to 30 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wksp,digit1, a digit2,idgts) c c ... set return parameters in iparm and rparm c 30 t2 = timer (dummy) nw = 3*n + 2*in timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 rparm(9) = omega rparm(10) = alphab rparm(11) = betab rparm(12) = specr c 35 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) c return end subroutine siw (suba,subq,coef,jcoef,wfac,jwfac,nn,u,ubar,rhs, a wksp,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c siw drives the chebyshev acceleration algorithm. c c ... parameters -- c c suba matrix-vector multiplication routine c subq preconditioning routine c n input integer. order of the system (= nn) c u input/output vector. on input, u contains the c initial guess to the solution. on output, it c contains the latest estimate to the solution. c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c wksp vector used for working space. c nw length of wksp array. if this length is less than c the amount needed, nw will give the needed amount c upon output. c iparm integer vector of length 30. allows user to c specify some integer parameters which affect c the method. c rparm floating point vector of length 30. allows user to c specify some floating point parameters which affect c the method. c ier output integer. error flag. c c ... specifications for parameters c external suba, subq integer iparm(30), jcoef(2), jwfac(1) dimension rhs(1), u(1), ubar(1), wksp(1), rparm(30), coef(1), a wfac(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- package common c c ... initialize common blocks c ier = 0 n = nn t1 = timer (dummy) iacel = 2 timit = 0.0d0 digit1 = 0.0d0 digit2 = 0.0d0 call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 35 if (level .ge. 2) write (nout,10) 10 format (1x,'si') c c ... compute workspace base addresses and check for sufficient c ... workspace. c iw1 = 1 iw2 = iw1 + n iw3 = iw2 + n iw4 = iw3 + n nwksp = 4*n if (nw .ge. nwksp) go to 15 ier = -2 call ershow (ier,'siw') go to 30 15 continue call nmcalc (coef,jcoef,wfac,jwfac,1,subq,n,rhs,ubar,wksp,ier) if (ier .lt. 0) go to 30 c c ... compute an initial rayleigh quotient and adjust emax, emin. c call vfill (n,wksp,1.0d0) call subq (coef,jcoef,wfac,jwfac,n,wksp,wksp(iw2)) call suba (coef,jcoef,wfac,jwfac,n,wksp(iw2),wksp(iw3)) rq = vdot (n,wksp(iw2),wksp(iw3)) / a vdot (n,wksp(iw2),wksp) rqmax = rq rqmin = rq if (maxadd) emax = max (emax,rqmax) if (minadd) emin = min (emin,rqmin) if (minadd) emin = max (emin,0.0d0) c c ... zero out workspace c call vfill (nwksp,wksp,0.0d0) c c ... iteration sequence c call itsi (suba,subq,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, a wksp(iw1),wksp(iw2),wksp(iw3),wksp(iw4),ier) c if (ier .lt. 0 .or. ier .eq. 1) go to 25 c c ... method has converged c if (level .ge. 1) write (nout,20) in 20 format (/1x,'si has converged in ',i5,' iterations ') c c ... optional error analysis c 25 if (idgts .lt. 0) go to 30 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wksp,digit1, a digit2,idgts) c c ... set return parameters in iparm and rparm c 30 t2 = timer (dummy) nw = 4*n timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 rparm(9) = omega rparm(10) = alphab rparm(11) = betab rparm(12) = specr c 35 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) c return end subroutine srcgw (suba,subq,subadp,coef,jcoef,wfac,jwfac, a nn,u,ubar,rhs,wksp,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c srcgw drives the ssor conjugate gradient algorithm. c c ... parameters -- c c suba matrix-vector multiplication routine c subq preconditioning routine c subadp adpation routine c n input integer. order of the system (= nn) c u input/output vector. on input, u contains the c initial guess to the solution. on output, it c contains the latest estimate to the solution. c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c wksp vector used for working space. c nw length of wksp array. if this length is less than c the amount needed, nw will give the needed amount c upon output. c iparm integer vector of length 30. allows user to c specify some integer parameters which affect c the method. c rparm floating point vector of length 30. allows user to c specify some floating point parameters which affect c the method. c ier output integer. error flag. c c ... specifications for parameters c external suba, subq, subadp integer iparm(30), jcoef(2), jwfac(1) dimension rhs(1), u(1), ubar(1), wksp(1), rparm(30), coef(1), a wfac(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- package common c c ... initialize common blocks c ier = 0 n = nn t1 = timer (dummy) iacel = 1 timit = 0.0d0 digit1 = 0.0d0 digit2 = 0.0d0 call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 35 if (level .ge. 2) write (nout,10) 10 format (1x,'srcg') c c ... compute workspace base addresses and check for sufficient c ... workspace. c iw1 = 1 iw2 = iw1 + n iw3 = iw2 + n iw4 = iw3 + n nwksp = 3*n + 2*itmax if (nw .ge. nwksp) go to 15 ier = -2 call ershow (ier,'srcgw') go to 30 15 continue c c ... zero out workspace c call vfill (nwksp,wksp,0.0d0) c c ... iteration sequence c call itsrcg (suba,subq,subadp,coef,jcoef,wfac,jwfac,n,u,ubar, a rhs,wksp(iw1),wksp(iw2),wksp(iw3),wksp(iw4),ier) c if (ier .lt. 0 .or. ier .eq. 1) go to 25 c c ... method has converged c if (level .ge. 1) write (nout,20) in 20 format (/1x,'srcg has converged in ',i5,' iterations' ) c c ... optional error analysis c 25 if (idgts .lt. 0) go to 30 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wksp,digit1, a digit2,idgts) c c ... set return parameters in iparm and rparm c 30 t2 = timer (dummy) timit = t2 - t1 nw = 3*n + 2*in iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 rparm(9) = omega rparm(10) = alphab rparm(11) = betab rparm(12) = specr c 35 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) c return end subroutine srsiw (suba,subq,subadp,coef,jcoef,wfac,jwfac, a nn,u,ubar,rhs,wksp,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c srsiw drives the ssor chebyshev acceleration algorithm. c c ... parameters -- c c suba matrix-vector multiplication routine c subq preconditioning routine c subadp adpation routine c n input integer. order of the system (= nn) c u input/output vector. on input, u contains the c initial guess to the solution. on output, it c contains the latest estimate to the solution. c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c wksp vector used for working space. c nw length of wksp array. if this length is less than c the amount needed, nw will give the needed amount c upon output. c iparm integer vector of length 30. allows user to c specify some integer parameters which affect c the method. c rparm floating point vector of length 30. allows user to c specify some floating point parameters which affect c the method. c ier output integer. error flag. c c ... specifications for parameters c external suba, subq, subadp integer iparm(30), jcoef(2), jwfac(1) dimension rhs(1), u(1), ubar(1), wksp(1), rparm(30), coef(1), a wfac(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- package common c c ... initialize common blocks c ier = 0 n = nn t1 = timer (dummy) iacel = 2 timit = 0.0d0 digit1 = 0.0d0 digit2 = 0.0d0 call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 35 if (level .ge. 2) write (nout,10) 10 format (1x,'srsi') c c ... compute workspace base addresses and check for sufficient c ... workspace. c iw1 = 1 iw2 = iw1 + n iw3 = iw2 + n iw4 = iw3 + n nwksp = 4*n if (nw .ge. nwksp) go to 15 ier = -2 call ershow (ier,'srsiw') go to 30 15 continue c c ... compute an initial rayleigh quotient and adjust emax, emin. c call vfill (n,wksp,1.0d0) call subq (coef,jcoef,wfac,jwfac,n,wksp,wksp(iw2)) call suba (coef,jcoef,wfac,jwfac,n,wksp(iw2),wksp(iw3)) rq = vdot (n,wksp(iw2),wksp(iw3)) / a vdot (n,wksp(iw2),wksp) rqmax = 1.0d0 rqmin = rq c c ... adjust emax, emin. c emax = 1.0d0 maxadd = .false. if (minadd) emin = min (emin,rqmin) if (minadd) emin = max (emin,0.0d0) c c ... zero out workspace c call vfill (nwksp,wksp,0.0d0) c c ... iteration sequence c call itsrsi (suba,subq,subadp,coef,jcoef,wfac,jwfac,n,u,ubar, a rhs,wksp(iw1),wksp(iw2),wksp(iw3),wksp(iw4),ier) c if (ier .lt. 0 .or. ier .eq. 1) go to 25 c c ... method has converged c if (level .ge. 1) write (nout,20) in 20 format (/1x,'srsi has converged in ',i5,' iterations ') c c ... optional error analysis c 25 if (idgts .lt. 0) go to 30 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wksp,digit1, a digit2,idgts) c c ... set return parameters in iparm and rparm c 30 t2 = timer (dummy) timit = t2 - t1 nw = 4*n iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 rparm(9) = omega rparm(10) = alphab rparm(11) = betab rparm(12) = specr c 35 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) c return end subroutine sorw (suba,subq,coef,jcoef,wfac,jwfac,nn, a u,ubar,rhs,wksp,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c sorw drives the successive over-relaxation algorithm. c c ... parameters -- c c suba matrix-vector multiplication routine c subq routine to do an sor pass c n input integer. order of the system (= nn) c u input/output vector. on input, u contains the c initial guess to the solution. on output, it c contains the latest estimate to the solution. c ubar input vector containing the true solution c (optional) c rhs input vector. contains the right hand side c of the matrix problem. c wksp vector used for working space. c nw length of wksp array. if this length is less than c the amount needed, nw will give the needed amount c upon output. c iparm integer vector of length 30. allows user to c specify some integer parameters which affect c the method. c rparm floating point vector of length 30. allows user to c specify some floating point parameters which affect c the method. c ier output integer. error flag. c c ... specifications for parameters c external suba, subq integer iparm(30), jcoef(2), jwfac(1) dimension rhs(1), u(1), ubar(1), wksp(1), rparm(30), coef(1), a wfac(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- package common c c ... initialize common blocks c ier = 0 n = nn t1 = timer (dummy) iacel = 3 timit = 0.0d0 digit1 = 0.0d0 digit2 = 0.0d0 call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 35 if (level .ge. 2) write (nout,10) 10 format (1x,'sor') c c ... compute workspace base addresses and check for sufficient c ... workspace. c nwksp = 2*n if (nw .ge. nwksp) go to 15 ier = -2 call ershow (ier,'sorw') go to 30 c c ... zero out workspace c 15 call vfill (nwksp,wksp,0.0d0) c c ... iteration sequence c call itsor (subq,coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wksp,ier) c if (ier .lt. 0 .or. ier .eq. 1) go to 25 c c ... method has converged c if (level .ge. 1) write (nout,20) in 20 format (/1x,'sor has converged in ',i5,' iterations' ) c c ... optional error analysis c 25 if (idgts .lt. 0) go to 30 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wksp,digit1, a digit2,idgts) c c ... set return parameters in iparm and rparm c 30 t2 = timer (dummy) timit = t2 - t1 nw = 2*n iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 rparm(9) = omega rparm(10) = alphab rparm(11) = betab rparm(12) = specr c 35 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) c return end subroutine itcg (suba,subq,coef,jcoef,wfac,jwfac,nn,u,ubar, a rhs,r,p,z,tri,ier) implicit double precision (a-h, o-z) c c itcg does the conjugate gradient iterations. c c ... parameters -- c c suba matrix-vector multiplication routine c subq preconditioning routine c n order of system (= nn) c u current solution c ubar known solution (optional) c rhs right hand side vector c r,p,z workspace vectors of length n each c tri tridiagonal matrix associated with the c eigenvalues of the tridiagonal matrix. c ier error code c c ... specifications for parameters c external suba, subq integer jcoef(2), jwfac(1) dimension coef(1), wfac(1) dimension u(1), ubar(1), rhs(1), r(1), p(1), z(1), tri(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c n = nn in = 0 is = 0 rzdot = 0.0d0 alpha = 0.0d0 beta = 0.0d0 alphao = 0.0d0 maxadp = maxadd minadp = minadd c c compute r = residual c call suba (coef,jcoef,wfac,jwfac,n,u,r) do 10 i = 1,n 10 r(i) = rhs(i) - r(i) go to 25 c c***** begin iteration loop ***** c 15 do 20 i = 1,n 20 r(i) = r(i) - alpha*z(i) c c ... do preconditioning step -- solve q*z = r for z. c 25 call subq (coef,jcoef,wfac,jwfac,n,r,z) c c ... compute rzdot = (r,z) c dkm1 = rzdot rzdot = 0.0d0 do 30 i = 1,n 30 rzdot = rzdot + r(i)*z(i) if (rzdot .gt. 0.0d0) go to 35 ier = -7 call ershow (ier,'itcg') return c c ... determine whether or not to stop. c 35 call pstops (n,r,z,u,ubar,ier) if (level .ge. 2) call iterm (n,u) if (halt .or. ier .lt. 0) return if (in .lt. itmax) go to 40 ier = 1 call ershow (ier,'itcg') zeta = stptst return c c ... compute beta = rzdot/dkm1 c 40 if (in .eq. 0) go to 45 beta = rzdot/dkm1 c c ... compute p = z + beta*p c 45 do 50 i = 1,n 50 p(i) = z(i) + beta*p(i) c c ... compute alpha = rzdot / (p,a*p) c call suba (coef,jcoef,wfac,jwfac,n,p,z) alphao = alpha pap = 0.0d0 do 55 i = 1,n 55 pap = pap + p(i)*z(i) alpha = rzdot / pap if (pap .gt. 0.0d0) go to 60 ier = -6 call ershow (ier,'itcg') return c c ... compute latest eigenvalue estimates. c 60 if (maxadp .or. minadp) call chgcon (tri,ier) c c ... compute new solution u = u + alpha*p c do 65 i = 1,n 65 u(i) = u(i) + alpha*p(i) in = in + 1 is = is + 1 go to 15 end subroutine itsi (suba,subq,coef,jcoef,wfac,jwfac,nn,u,ubar, a rhs,r,p,z,wksp,ier) implicit double precision (a-h, o-z) c c itsi does the semi-iterative iterations. c c ... parameters -- c c suba matrix-vector multiplication routine c subq preconditioning routine c n order of system (= nn) c u current solution c ubar known solution (optional) c rhs right hand side vector c r,p,z, workspace vectors of length n each c wksp volatile workspace c ier error code c c ... specifications for parameters c external suba, subq integer jcoef(2), jwfac(1) dimension coef(1), wfac(1) dimension u(1), ubar(1), rhs(1), r(1), p(1), z(1), wksp(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c n = nn in = 0 c c ... new chebychev sequence. c 10 is = 0 alpha = 0.0d0 beta = 0.0d0 rho = 1.0d0 rzdot = 0.0d0 gamma = 2.0d0/(emax + emin) sigma = (emax - emin)/(emax + emin) term = sqrt (1.0d0 - sigma*sigma) rr = (1.0d0 - term)/(1.0d0 + term) maxadp = maxadd minadp = minadd c c compute r = residual c call suba (coef,jcoef,wfac,jwfac,n,u,r) do 15 i = 1,n 15 r(i) = rhs(i) - r(i) go to 30 c c***** begin iteration loop ***** c 20 do 25 i = 1,n 25 r(i) = r(i) - alpha*z(i) c c ... do preconditioning step -- solve q*z = r for z. c 30 call subq (coef,jcoef,wfac,jwfac,n,r,z) c c ... compute rzdot = (r,z) c dkm1 = rzdot rzdot = 0.0d0 do 35 i = 1,n 35 rzdot = rzdot + r(i)*z(i) if (is .eq. 0) dkq = rzdot if (rzdot .ge. 0.0d0) go to 40 ier = -7 call ershow (ier,'itsi') return c c ... determine whether or not to stop. c 40 call pstops (n,r,z,u,ubar,ier) if (level .ge. 2) call iterm (n,u) if (halt .or. ier .lt. 0) return if (in .lt. itmax) go to 45 ier = 1 call ershow (ier,'itsi') zeta = stptst return c c ... compute iteration parameters. c 45 call parsi c c ... compute p = z + beta*p c ... u = u + alpha*p c do 50 i = 1,n p(i) = z(i) + beta*p(i) u(i) = u(i) + alpha*p(i) 50 continue c c ... adapt on emin and emax c in = in + 1 if (.not. maxadp .and. .not. minadp) go to 55 call chgsi (suba,coef,jcoef,wfac,jwfac,n,z,wksp,icode,ier) if (ier .lt. 0) return c c ... check if new estimates of emax, emin are to be used. c if (icode .eq. 1) go to 10 c c ... estimates of emax, emin are still good. c 55 is = is + 1 call suba (coef,jcoef,wfac,jwfac,n,p,z) go to 20 end subroutine itsrcg (suba,subq,subadp,coef,jcoef,wfac,jwfac, a nn,u,ubar,rhs,r,p,z,tri,ier) implicit double precision (a-h, o-z) c c itsrcg does the ssor conjugate gradient iterations. c c ... parameters -- c c suba matrix-vector multiplication routine c subq preconditioning routine c subadp adpation routine c n order of system (= nn) c u current solution c ubar known solution (optional) c rhs right hand side vector c r,p,z workspace vectors of length n each c tri tridiagonal matrix associated with the c eigenvalues of the tridiagonal matrix. c ier error code c c ... specifications for parameters c external suba, subq, subadp integer jcoef(2), jwfac(1) dimension coef(1), wfac(1) dimension u(1), ubar(1), rhs(1), r(1), p(1), z(1), tri(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c n = nn in = 0 isw = 1 5 is = 0 rzdot = 0.0d0 alpha = 0.0d0 beta = 0.0d0 alphao = 0.0d0 maxadp = maxadd minadp = minadd c c recompute bnorm c call nmcalc (coef,jcoef,wfac,jwfac,isw,subq,n,rhs,ubar,r,ier) if (ier .lt. 0) return isw = 2 c c compute r = residual c call suba (coef,jcoef,wfac,jwfac,n,u,r) do 10 i = 1,n 10 r(i) = rhs(i) - r(i) go to 25 c c***** begin iteration loop ***** c 15 do 20 i = 1,n 20 r(i) = r(i) - alpha*z(i) c c ... do preconditioning step -- solve q*z = r for z. c 25 call subq (coef,jcoef,wfac,jwfac,n,r,z) c c ... compute rzdot = (r,z) c dkm1 = rzdot rzdot = 0.0d0 do 30 i = 1,n 30 rzdot = rzdot + r(i)*z(i) if (rzdot .ge. 0.0d0) go to 35 ier = -7 call ershow (ier,'itsrcg') return c c ... determine whether or not to stop. c 35 call pstops (n,r,z,u,ubar,ier) if (level .ge. 2) call iterm (n,u) if (halt .or. ier .lt. 0) return if (in .lt. itmax) go to 40 ier = 1 call ershow (ier,'itsrcg') zeta = stptst return c c ... compute beta = rzdot/dkm1 c 40 if (is .eq. 0) go to 45 beta = rzdot/dkm1 c c ... compute p = z + beta*p c 45 do 50 i = 1,n 50 p(i) = z(i) + beta*p(i) c c ... compute alpha = rzdot / (p,a*p) c call suba (coef,jcoef,wfac,jwfac,n,p,z) alphao = alpha pap = 0.0d0 do 55 i = 1,n 55 pap = pap + p(i)*z(i) alpha = rzdot / pap if (pap .ge. 0.0d0) go to 60 ier = -6 call ershow (ier,'itsrcg') return c c ... compute latest eigenvalue estimates. c 60 if (minadp) call chgcon (tri,ier) c c ... compute new solution u = u + alpha*p c do 65 i = 1,n 65 u(i) = u(i) + alpha*p(i) is = is + 1 in = in + 1 call ssorad (subadp,coef,jcoef,wfac,jwfac,n,p,z,r,icode) if (icode .eq. 0) go to 15 go to 5 end subroutine itsrsi (suba,subq,subadp,coef,jcoef,wfac,jwfac, a nn,u,ubar,rhs,r,p,z,wksp,ier) implicit double precision (a-h, o-z) c c itsrsi does the ssor semi-iterative iterations. c c ... parameters -- c c suba matrix-vector multiplication routine c subq preconditioning routine c subadp adpation routine c n order of system (= nn) c u current solution c ubar known solution (optional) c rhs right hand side vector c r,p,z, workspace vectors of length n each c wksp volatile workspace c ier error code c c ... specifications for parameters c external suba, subq, subadp integer jcoef(2), jwfac(1) dimension coef(1), wfac(1) dimension u(1), ubar(1), rhs(1), r(1), p(1), z(1), wksp(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c n = nn c in = 0 isw = 1 c c recompute bnorm c 5 call nmcalc (coef,jcoef,wfac,jwfac,isw,subq,n,rhs,ubar,r,ier) if (ier .lt. 0) return isw = 2 c c ... update rayleigh quotient . c if (in .eq. 0) go to 10 call subq (coef,jcoef,wfac,jwfac,n,p,z) call suba (coef,jcoef,wfac,jwfac,n,z,r) rq = vdot (n,z,r) / vdot (n,z,p) rqmin = rq if (minadd) emin = rqmin c c ... new chebychev sequence. c 10 is = 0 alpha = 0.0d0 beta = 0.0d0 rho = 1.0d0 rzdot = 0.0d0 gamma = 2.0d0/(emax + emin) sigma = (emax - emin)/(emax + emin) term = sqrt (1.0d0 - sigma*sigma) rr = (1.0d0 - term)/(1.0d0 + term) minadp = minadd c c compute r = residual c call suba (coef,jcoef,wfac,jwfac,n,u,r) do 15 i = 1,n 15 r(i) = rhs(i) - r(i) go to 30 c c***** begin iteration loop ***** c 20 do 25 i = 1,n 25 r(i) = r(i) - alpha*z(i) c c ... do preconditioning step -- solve q*z = r for z. c 30 call subq (coef,jcoef,wfac,jwfac,n,r,z) c c ... compute rzdot = (r,z) c dkm1 = rzdot rzdot = 0.0d0 do 35 i = 1,n 35 rzdot = rzdot + r(i)*z(i) if (is .eq. 0) dkq = rzdot if (rzdot .ge. 0.0d0) go to 40 ier = -7 call ershow (ier,'itsrsi') return c c ... determine whether or not to stop. c 40 call pstops (n,r,z,u,ubar,ier) if (level .ge. 2) call iterm (n,u) if (halt .or. ier .lt. 0) return if (in .lt. itmax) go to 45 ier = 1 call ershow (ier,'itsrsi') zeta = stptst return c c ... compute iteration parameters. c 45 call parsi c c ... compute p = z + beta*p c ... u = u + alpha*p c do 50 i = 1,n p(i) = z(i) + beta*p(i) u(i) = u(i) + alpha*p(i) 50 continue c c ... adapt on emin and emax c in = in + 1 if (.not. minadp) go to 55 call chgsi (suba,coef,jcoef,wfac,jwfac,n,z,wksp,icode,ier) if (ier .lt. 0) return c c ... check if new estimates of emax, emin are to be used. c if (icode .eq. 1) go to 10 c c ... estimates of emax, emin are still good. c 55 is = is + 1 call suba (coef,jcoef,wfac,jwfac,n,p,z) call ssorad (subadp,coef,jcoef,wfac,jwfac,n,p,z,r,icode) if (icode .eq. 0) go to 20 go to 5 end subroutine itsor (subq,coef,jcoef,wfac,jwfac,nn,u,ubar, a rhs,wksp,ier) implicit double precision (a-h, o-z) c c ... itsor does the sor iterations c c ... parameters -- c c subq routine to do an sor pass c n size of system c rhs right hand side c u solution vector c ubar known solution (optional) c wksp workspace vector of length 2*n c c ... specifications for parameters c integer jcoef(2), jwfac(1) dimension coef(1), wfac(1) dimension rhs(1), u(1), ubar(1), wksp(1) external subq logical change c c *** begin -- itpack common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- itpack common c c c ... set initial parameters not already set c n = nn in = 0 is = 0 ip = 0 iss = 0 iphat = 2 delnnm = 0.0d0 delsnm = 0.0d0 call sorstp (n,u,ubar,0.0d0,0.0d0) change = omgadp ib2 = n + 1 if (.not. omgadp) go to 10 omegap = omega omega = 1.0d0 ipstar = 4 if (omegap .le. 1.0d0) change = .false. c c ... start iterating. c 10 do 55 iter = 1,itmax+1 c c ... output intermediate information c if (level .ge. 2) call iterm (n,u) if (halt) return if (.not. change) go to 15 change = .false. is = is + 1 ip = 0 iss = 0 omega = min (omegap,tau(is)) iphat = max ( 3 , int ( (omega-1.0d0)/(2.0d0-omega) ) ) ipstar = ipstr (omega) c c ... compute u (in + 1) and norm of del(s,p) c 15 delsnm = delnnm spcrm1 = specr do 20 i = 1,n 20 wksp(i) = rhs(i) call subq (coef,jcoef,wfac,jwfac,n,u,wksp,wksp(ib2)) do 25 i = 1,n 25 wksp(i) = u(i) - wksp(n+i) sum = 0.0d0 do 28 i = 1,n 28 sum = sum + wksp(i)*wksp(i) delnnm = sqrt (sum) do 30 i = 1,n 30 u(i) = wksp(i+n) if (delnnm .eq. 0.0d0) go to 35 if (in .ne. 0) specr = delnnm / delsnm if (ip .lt. iphat) go to 50 c c ... stopping test, set h c if (specr .ge. 1.0d0) go to 50 if (.not. (specr .gt. (omega - 1.0d0))) go to 35 h = specr go to 40 35 iss = iss + 1 h = omega - 1.0d0 c c ... perform stopping test. c 40 continue dnrm = delnnm**2 call sorstp (n,u,ubar,dnrm,h) if (halt) go to 50 c c ... method has not converged yet, test for changing omega c if (.not. omgadp) go to 50 if (ip .lt. ipstar) go to 50 if (omega .gt. 1.0d0) go to 45 emax = sqrt (abs (specr)) omegap = 2.0d0 / (1.0d0 + sqrt (abs (1.0d0 - specr))) change = .true. go to 50 45 if (iss .ne. 0) go to 50 if (specr .le. (omega - 1.0d0)**fff) go to 50 if ((specr + 0.00005d0) .le. spcrm1) go to 50 c c ... change parameters c emax = (specr + omega - 1.0d0) / (sqrt (abs (specr))*omega) omegap = 2.0d0 / (1.0d0 + sqrt (abs (1.0d0 - emax*emax))) change = .true. c 50 ip = ip + 1 in = in + 1 55 continue ier = 1 in = in - 1 call ershow (ier,'itsor') zeta = stptst return end subroutine basicw (suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the basic (unaccelerated) iterative method, c with preconditioning. that is, it applies the fixed point method c to the preconditioned system. c two-sided preconditioning is efficiently implemented. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) logical iql, iqr external suba, subql, subqr dimension iparm(30), rparm(30) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c preliminary calculations c iacel = 0 ier = 0 nwusd = 0 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 996 if (level .ge. 2) write (nout,496) 496 format (' basic') c use knowledge about spectrum to optimally extrapolate ... extrap = (emax+emin)/2.0d0 iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 c c initialize the stopping test ... c call inithv (0) zthave = .true. nwpstp = nw call pstop (0,suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 735 c c bust up workspace ... c izt = 1 iv1 = izt + n iwfree = iv1 + n if (iqlr .eq. 0) iwfree = iv1 nwusd = max (nwusd,iwfree-1) c c check the memory usage ... c if (nwusd .gt. nw) go to 999 c c do preliminary calculations ... c in = 0 is = 0 go to (151,152,153,154),iqlr + 1 c 151 call suba (coef,jcoef,wfac,jwfac,n,u,wk(izt)) call vexopy (n,wk(izt),rhs,wk(izt),2) go to 10 c 152 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(izt)) go to 10 c 153 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subqr (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(izt)) go to 10 c 154 call suba (coef,jcoef,wfac,jwfac,n,u,wk(izt)) call vexopy (n,wk(izt),rhs,wk(izt),2) call subql (coef,jcoef,wfac,jwfac,n,wk(izt),wk(iv1)) call subqr (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(izt)) go to 10 c c-----------------------begin iteration loop---------------------- c c determine whether or not to stop -- c 10 call inithv (1) nwpstp = nw - (iwfree-1) call pstop (1,suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,xxx,xxx,wk(izt), a wk(iwfree),nwpstp,ier) nwusd = max (nwusd,nwpstp+iwfree-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c c form iterate ... c call vtriad (n,u,u,1.0d0/extrap,wk(izt),1) c c form residuals, as necessary ... c go to (161,162,163,164),iqlr + 1 c 161 call suba (coef,jcoef,wfac,jwfac,n,u,wk(izt)) call vexopy (n,wk(izt),rhs,wk(izt),2) go to 110 c 162 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(izt)) go to 110 c 163 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subqr (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(izt)) go to 110 c 164 call suba (coef,jcoef,wfac,jwfac,n,u,wk(izt)) call vexopy (n,wk(izt),rhs,wk(izt),2) call subql (coef,jcoef,wfac,jwfac,n,wk(izt),wk(iv1)) call subqr (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(izt)) go to 110 c c proceed to next iteration c 110 in = in + 1 is = is + 1 go to 10 c c--------------------------------finish up------------------------- c 900 if (halt) go to 715 ier = 1 call ershow (ier,'basicw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' basic method converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk, a digit1,digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 996 call ershow (ier,'basicw') go to 735 c c insuff. floating point wksp ... 999 ier = -2 call ershow (ier,'basicw') go to 735 c end subroutine mew (suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw, a iparm,rparm,ier) implicit double precision (a-h, o-z) c c this routine runs the minimal error algorithm of fridman. c the reference is: v. m. fridman, "the method of minimum iterations c ...", ussr computational math. and math. phys., vol. 2, 1962, c pp. 362-3. c c two-sided preconditioning is implemented. the iteration matrix c should be symmetric for this algorithm to work. c c we have introduced periodic scaling of the direction vectors, to c prevent overflow. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) external suba, subql, subqr dimension iparm(30), rparm(30) logical iql, iqr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c the following indexing functions are used to access the old c direction vectors -- c indp(i) = ip + mod(i,2)*n indpt(i) = ipt + mod(i,2)*n c c various preliminary calculations. c dot = 0.0d0 nwusd = 0 ier = 0 iacel = 4 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 997 if (level .ge. 2) write (nout,496) 496 format (' me') iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 c c initialize the stopping test ... c call inithv (0) zhave = .true. nwpstp = nw call pstop (0,suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c c memory allocation, etc. c c nomenclature -- r -- residual of the original system. c z -- inv(ql)*r c zt -- inv(qr)*z c ip = 1 ipt = ip + 2*n iz = ipt + 2*n ir = iz + n iv1 = ir + n if (.not. rcalp) iv1 = ir izt = iv1 + n iv2 = izt + n if (.not. ztcalp) iv2 = izt iqlap = iv1 iqrlap = iv2 iwfree = iv2 + n c c note that memory usage has been overlapped whenever possible, c in order to save space. c nwusd = max (nwusd,iwfree-1) c c check the memory usage -- c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 rhave = rcalp zthave = ztcalp c c perform first-iterate calculations c call suba (coef,jcoef,wfac,jwfac,n,u,wk(ir)) call vexopy (n,wk(ir),rhs,wk(ir),2) call subql (coef,jcoef,wfac,jwfac,n,wk(ir),wk(iz)) call subqr (coef,jcoef,wfac,jwfac,n,wk(iz),wk(izt)) c c---------------------------- begin iteration loop ---------------------------- c c determine whether or not to stop -- c note that we have already done the calculations necessary so that suba c and subql are not actually used by pstop. c 10 call inithv (1) nwpstp = nw - (iwfree-1) call pstop (1,suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk(ir),wk(iz),wk(izt), a wk(iwfree),nwpstp,ier) nwusd = max (nwusd,nwpstp+iwfree-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c c compute p(n), the direction vector, and inv(qr)*p(n) (=pt(n)). c scal = 1.0d0 c c first, case of in .eq. 0 c if (in .ne. 0) go to 100 toplam = vdot (n,wk(iz),wk(iz)) call suba (coef,jcoef,wfac,jwfac,n,wk(izt),wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(indp(in))) call subqr (coef,jcoef,wfac,jwfac,n,wk(indp(in)),wk(indpt(in))) go to 120 c c case in .gt. 0 c 100 toplam = vdot (n,wk(indp(in-1)),wk(iz)) bet1 = - vdot (n,wk(indp(in-1)),wk(iqlap)) / dot if (in .ne. 1) go to 110 c c case in .eq. 1 c call vtriad (n,wk(indp(in)),wk(iqlap),bet1,wk(indp(in-1)),1) call vtriad (n,wk(indpt(in)),wk(iqrlap),bet1,wk(indpt(in-1)),1) go to 120 c c case in .gt. 1 c 110 bet2 = - vdot (n,wk(indp(in-2)),wk(iqlap)) / dotold call vtriad (n,wk(indp(in)), wk(iqlap), bet2,wk(indp(in-2)), 1) call vtriad (n,wk(indpt(in)),wk(iqrlap),bet2,wk(indpt(in-2)),1) call vtriad (n,wk(indp(in)), wk(indp(in)), bet1,wk(indp(in-1)), 1) call vtriad (n,wk(indpt(in)),wk(indpt(in)),bet1,wk(indpt(in-1)),1) c c at this point, we are finished forming the latest direction vector. c we proceed to calculate lambda and update the solution and the c residual. c 120 dotold = dot dot = vdot (n,wk(indp(in)),wk(indp(in))) c if (dot .lt. srelpr) go to 998 c c scale direction vector if necessary ... if (dot.lt.srelpr**2 .or. dot.gt.(1.0d0/srelpr**2)) then scal = sqrt(dot) call vtriad (n,wk(indp(in)), xxx,1.0d0/scal,wk(indp(in)), 2) call vtriad (n,wk(indpt(in)),xxx,1.0d0/scal,wk(indpt(in)),2) dot = 1.0d0 end if c 124 vlamda = toplam / dot / scal c c u -- c call vtriad (n,u,u,vlamda,wk(indpt(in)),1) c c r -- c call suba (coef,jcoef,wfac,jwfac,n,wk(indpt(in)),wk(iv2)) if (rhave) call vtriad (n,wk(ir),wk(ir),-vlamda,wk(iv2),1) c c z -- c call subql (coef,jcoef,wfac,jwfac,n,wk(iv2),wk(iqlap)) call vtriad (n,wk(iz),wk(iz),-vlamda,wk(iqlap),1) c c zt -- c call subqr (coef,jcoef,wfac,jwfac,n,wk(iqlap),wk(iqrlap)) if (zthave) call vtriad (n,wk(izt),wk(izt),-vlamda,wk(iqrlap),1) c c proceed to next iteration c in = in + 1 is = is + 1 go to 10 c c-------------------------------finish up----------------------------- c 900 if (halt) go to 715 ier = 1 call ershow (ier,'mew') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' me converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 997 call ershow (ier,'mew') go to 735 c 998 ier = -15 call ershow (ier,'mew') go to 725 c 999 ier = -2 call ershow (ier,'mew') go to 735 c end subroutine cgnrw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the conjugate gradient algorithm on the normal equations. c in this variant, the residual of the original system is minimized c per iteration. currently, only left preconditioning is implemented. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c preliminary calculations. c nwusd = 0 ier = 0 iacel = 5 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 997 iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 if (iqr) go to 995 if (level .ge. 2) write (nout,496) 496 format (' cgnr') maxadp = maxadd minadp = minadd alphao = 0.0d0 alpha = 0.0d0 beta = 0.0d0 c c initialize the stopping test ... c call inithv (0) zthave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c itri = 1 ip = itri if ( .not. (maxadd .or. minadd) ) go to 850 ip = itri + 2*itmax call vfill (2*itmax,wk(itri),0.0d0) 850 ir = ip + n iv1 = ir + n iv2 = iv1 + n nwusd = max (nwusd,iv2-1+n) c c check the memory usage -- c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(ir)) c c--------------------------begin iteration loop------------------------ c c determine whether or not to stop -- c 10 call inithv (1) nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,wk(ir), a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c if (in .ne. 0) go to 110 c c perform first-iterate calculations c call subqlt (coef,jcoef,wfac,jwfac,n,wk(ir),wk(iv1)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(ip)) ard = vdot (n,wk(ip),wk(ip)) go to 111 c c perform subsequent-iterate calculations c 110 ardold = ard c if (abs(ardold) .lt. srelpr) go to 996 call subqlt (coef,jcoef,wfac,jwfac,n,wk(ir),wk(iv1)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) ard = vdot (n,wk(iv2),wk(iv2)) an = ard/ardold call vtriad (n,wk(ip),wk(iv2),an,wk(ip),1) beta = an c c proceed to form the iterate. c 111 call suba (coef,jcoef,wfac,jwfac,n,wk(ip),wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) pap = vdot (n,wk(iv2),wk(iv2)) if (abs(pap) .lt. srelpr**2) go to 998 vlamda = ard/pap c call vtriad (n,u,u,vlamda,wk(ip),1) call vtriad (n,wk(ir),wk(ir),-vlamda,wk(iv2),1) c c update eigenvalue estimates c alphao = alpha alpha = vlamda if (maxadp .or. minadp) call chgcon (wk(itri),ier) if (ier .lt. 0) go to 725 c c proceed to next iteration c in = in + 1 is = is + 1 go to 10 c c-------------------------------finish up--------------------------- c 900 if (halt) go to 715 ier = 1 call ershow (ier,'cgnrw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' cgnr converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 995 ier = -16 call ershow (ier,'cgnrw') return c 996 ier = -13 call ershow (ier,'cgnrw') go to 725 c 997 call ershow (ier,'cgnrw') go to 735 c 998 ier = -15 call ershow (ier,'cgnrw') go to 725 c 999 ier = -2 call ershow (ier,'cgnrw') go to 735 c end subroutine lsqrw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the lsqr algorithm. the algorithm is taken from c the article 'lsqr -- an algorithm for sparse linear equations c and sparse least squares.' c by c. c. paige amd m. a. saunders, in acm transactions on c mathematical software, vol. 8, no. 1, march 1982, pp. 43-71. c the iterates produced are the same as those of cgnr, in exact c arithmetic, but this should be more stable. only left c preconditioning is currently implemented. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) integer vect1, vect2, os external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c preliminary calculations. c nwusd = 0 ier = 0 iacel = 6 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 996 iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 if (iqr) go to 995 if (level .ge. 2) write (nout,496) 496 format (' lsqr') c c initialize the stopping test ... c call inithv (0) zdhav = .true. nwpstp = nw call pstop (0,suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 735 c c ... associated integer variables. c iu = 1 iv = iu + n iw = iv + n iv1 = iw + n iv2 = iv1 + n nwusd = max (nwusd,iv2-1+n) c c check the memory usage -- c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 c c now, perform first-iterate calculations c call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) beta = sqrt(vdot (n,wk(iv2),wk(iv2))) if (abs(beta) .lt. srelpr) go to 997 call vtriad (n,wk(iu),xxx,1.0d0/beta,wk(iv2),2) c call subqlt (coef,jcoef,wfac,jwfac,n,wk(iu),wk(iv1)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) alpha = sqrt(vdot (n,wk(iv2),wk(iv2))) if (abs(alpha) .lt. srelpr) go to 997 call vtriad (n,wk(iv),xxx,1.0d0/alpha,wk(iv2),2) c call vcopy (n,wk(iv),wk(iw)) phibar = beta rhobar = alpha zdot = phibar**2 c if u(0) is zero, then the norm of u(n) can be calculated for free. c otherwise, i don't know. c c---------------------------begin iteration loop--------------------- c c determine whether or not to stop -- c 10 call inithv (1) zdhav = .true. nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c c ... compute the lanczos vectors. c call suba (coef,jcoef,wfac,jwfac,n,wk(iv),wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) call vtriad (n,wk(iu),wk(iv2),-alpha,wk(iu),1) beta = sqrt(vdot (n,wk(iu),wk(iu))) if (abs(beta) .lt. srelpr) go to 997 call vtriad (n,wk(iu),xxx,1.0d0/beta,wk(iu),2) c call subqlt (coef,jcoef,wfac,jwfac,n,wk(iu),wk(iv1)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) call vtriad (n,wk(iv),wk(iv2),-beta,wk(iv),1) alpha = sqrt(vdot (n,wk(iv),wk(iv))) if (abs(alpha) .lt. srelpr) go to 997 call vtriad (n,wk(iv),xxx,1.0d0/alpha,wk(iv),2) c c continue by calculating various scalars. c rho = sqrt(rhobar**2+beta**2) if (rho .lt. srelpr) go to 998 c = rhobar/rho s = beta/rho theta = s*alpha rhobar = -c*alpha phi = c*phibar phibar = s*phibar c c now generate the new u and w vectors. c call vtriad (n,u,u,phi/rho,wk(iw),1) call vtriad (n,wk(iw),wk(iv),-theta/rho,wk(iw),1) c c proceed to next iteration c zdot = phibar**2 in = in + 1 is = is + 1 go to 10 c c-----------------------------finish up------------------------- c 900 if (halt) go to 715 ier = 1 call ershow (ier,'lsqrw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' lsqr converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 995 ier = -16 call ershow (ier,'lsqrw') return c 996 call ershow (ier,'lsqrw') go to 735 c 997 ier = -13 call ershow (ier,'lsqrw') go to 725 c 998 ier = -14 call ershow (ier,'lsqrw') go to 725 c 999 ier = -2 call ershow (ier,'lsqrw') go to 735 c end subroutine odirw (suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c this routine implements orthodir with truncation and c restarting and with 2-sided preconditioning. the effective value c of the z matrix is (inv(ql)*a*inv(qr))**t. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) logical iql, iqr external suba, subql, subqr dimension iparm(30), rparm(30) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c the following indexing functions are used to access the old c direction vectors and dot products -- c indpt(i) = ipt + mod(i,nv)*n indqap(i) = iqapt + mod(i,nv)*n inddot(i) = idot + mod(i,nv) c c various preliminary calculations. c c nwusd = 0 ier = 0 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 997 write (nout,496) 496 format (' orthodir') iacel = 7 iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 c c initialize the stopping test ... c call inithv (0) zhave = .true. zthave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 997 c c memory allocation, etc. c nv = max (1,min(ns1,ns2-1)) ipt = 1 iqapt = ipt + nv*n idot = iqapt + nv*n iz = idot + nv izt = iz + n if (.not. iqr) izt = iz isv = izt + n iv1 = isv + n iv2 = iv1 + n c if (iql) nwusd = max (nwusd,iv2-1+n) if (.not. iql) nwusd = max (nwusd,iv1-1+n) c c check the memory usage -- c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 c c perform first-iterate calculations c if (iql) go to 122 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iz)) call vexopy (n,wk(iz),rhs,wk(iz),2) go to 121 122 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iz)) 121 if (iqr) call subqr (coef,jcoef,wfac,jwfac,n,wk(iz),wk(izt)) c if (.not. iqr) zdot = vdot (n,wk(iz),wk(iz)) c c ========================= begin iteration loop ==================== c c c determine whether or not to stop ... c 10 call inithv (1) nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,wk(iz),wk(izt), a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c c proceed to calculate the direction vectors. c c first, case of no old p vectors. c np = min(mod(in,ns2),ns1) if (np .ne. 0) go to 100 c if (is .eq. 0) call vcopy (n,wk(izt),wk(indpt(in))) if (is .ne. 0) call vcopy (n,wk(isv),wk(indpt(in))) if (iql) go to 123 call suba (coef,jcoef,wfac,jwfac,n,wk(indpt(in)),wk(indqap(in))) go to 120 123 call suba (coef,jcoef,wfac,jwfac,n,wk(indpt(in)),wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(indqap(in))) go to 120 c c case of at least one old p vector. c this case is handled in a tricky way, to optimize the workspace. c 100 if (iql) go to 124 call suba (coef,jcoef,wfac,jwfac,n,wk(isv),wk(iv1)) go to 125 124 call suba (coef,jcoef,wfac,jwfac,n,wk(isv),wk(iv2)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv2),wk(iv1)) c 125 top = vdot (n,wk(indqap(in-np)),wk(iv1)) bet = - top / wk(inddot(in-np)) call vtriad (n,wk(indpt(in)),wk(isv),bet,wk(indpt(in-np)),1) call vtriad (n,wk(indqap(in)),wk(iv1),bet,wk(indqap(in-np)),1) ibegin = in - np + 1 iend = in - 1 if (ibegin .gt. iend) go to 613 do 612 i = ibegin,iend top = vdot (n,wk(indqap(i)),wk(iv1)) bet = - top / wk(inddot(i)) call vtriad (n,wk(indpt(in)),wk(indpt(in)),bet,wk(indpt(i)),1) 612 call vtriad (n,wk(indqap(in)),wk(indqap(in)),bet,wk(indqap(i)),1) 613 continue c c periodically scale the direction vector, to prevent overflow ... c 120 continue dot = vdot (n,wk(indqap(in)),wk(indqap(in))) if (dot.lt.srelpr**2 .or. dot.gt.(1.0d0/srelpr**2)) then call vtriad (n,wk(indpt(in)), xxx,1.0d0/dot,wk(indpt(in)), 2) call vtriad (n,wk(indqap(in)),xxx,1.0d0/dot,wk(indqap(in)),2) dot = 1.0d0 end if c c at this point, we are finished forming the latest direction vector. c we proceed to calculate lambda and update the solution and c the residuals. c 129 continue c if (abs(dot) .lt. srelpr) go to 998 wk(inddot(in)) = dot top = vdot (n,wk(indqap(in)),wk(iz)) vlamda = top / dot c the following commented-out line is unstable. but it can be fixed. c if (.not. iqr) zdot = zdot - 2*vlamda*top + vlamda**2*dot c c u -- c call vtriad (n,u,u,vlamda,wk(indpt(in)),1) c c z -- c call vtriad (n,wk(iz),wk(iz),-vlamda,wk(indqap(in)),1) c c zt -- c call subqr (coef,jcoef,wfac,jwfac,n,wk(indqap(in)),wk(isv)) if (iqr) call vtriad (n,wk(izt),wk(izt),-vlamda,wk(isv),1) c c proceed to next iteration c in = in + 1 is = is + 1 if (is .eq. ns2) is = 0 go to 10 c c-------------------------------finish up---------------------------- c 900 if (.not. halt) go to 996 if (level .ge. 1) write (nout,720) in 720 format (/' orthodir converged in ',i5,' iterations.') c 725 if (idgts .ge. 0) a call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk, a digit1,digit2,idgts) c pack revised parms into iparm, rparm ... t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c c error returns c c no convergence ... 996 ier = 1 call ershow (ier,'odirw') zeta = stptst go to 725 c c generic error handler ... 997 call ershow (ier,'odirw') go to 735 c c breakdown ... 998 ier = -15 call ershow (ier,'odirw') go to 725 c c insufficient floating point wksp ... 999 ier = -2 call ershow (ier,'odirw') go to 735 end subroutine ominw (suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c this routine implements the truncated/restarted orthomin algorithm. c eigenvalue estimation is implemented. c note that this also implements the gcr algorithm. c c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) external suba, subql, subqr external nullpl, nullpr dimension iparm(30), rparm(30) c ier = 0 call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) return c c pass on to workhorse routine ... c call omingw (suba,subql,subqr,nullpl,nullpr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) return end subroutine omingw (suba,subql,subqr,precl,precr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c this is a generalized version of the omingw routine which allows a c more general computational form for the preconditioning. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) logical ipl, ipr external suba, subql, subqr, precl, precr dimension iparm(30), rparm(30) logical ztget, havest, hadest, evest c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c the following indexing functions are used to access the old c direction vectors and dot products -- c indpt(i) = ipt + mod(i,nv)*n indqap(i) = iqapt + mod(i,nv)*n inddot(i) = idot + mod(i,nv+1) indhes(i,j) = ihess + (i-1) + (j-1)*nhess inapar(i) = iapar + mod(i,nv) indlam(i) = ilam + mod(i,nv+1) c c various preliminary calculations. c t1 = timer (dummy) c ipl = iplr .eq. 1 .or. iplr .eq. 3 ipr = iplr .eq. 2 .or. iplr .eq. 3 c iacel = 8 nwusd = 0 if (level .ge. 1) write (nout,497) 497 format (' omin') c c initialize the stopping test ... c call inithv (0) zhave = .true. zthave = .true. nwpstp = nw call pstopg (0,suba,subql,subqr,precl,precr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 997 ztget = ztcalp zthave = ztget c c memory allocation, etc. c numbig = 1000 methev = 1 if (iabs(ns3) .ge. numbig) then if (ns3 .gt. 0) ns3 = ns3 - numbig if (ns3 .lt. 0) ns3 = ns3 + numbig methev = 2 end if c evest = ns3 .ne. 0 .and. (maxadd.or.minadd) nhess = 2 + min(itmax,ns2) nv = max (1,min(ns1,ns2-1)) ipt = 1 iqapt = ipt + nv*n idot = iqapt + nv*n iapar = idot + (nv+1) ihess = iapar + nv ilam = ihess + nhess*(nv+2) if (.not. evest) ilam = ihess iz = ilam + (nv+1) izt = iz + n if (.not. ipr) izt = iz iv1 = izt + n iv2 = iv1 + n ir = iz if (ipl) ir = iv1 c nwtmp = iv1 - 1 + n if (ipl) nwtmp = iv2 - 1 + n nwusd = max (nwusd,nwtmp) c c check the memory usage -- c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 c c perform first-iterate calculations c call suba (coef,jcoef,wfac,jwfac,n,u,wk(ir)) call vexopy (n,wk(ir),rhs,wk(ir),2) if (ipl) call precl (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a wk(ir),wk(iz)) hadest = .false. c c ------------------------- begin iteration loop ---------------------- c c determine whether or not to stop ... c 10 if (.not. ztget) go to 710 if (ipr) call precr (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a wk(iz),wk(izt)) c 710 call inithv (1) nwpstp = nw - (iv1-1) call pstopg (1,suba,subql,subqr,precl,precr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,wk(iz),wk(izt), a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c if (zthave) go to 711 if (ipr) call precr (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a wk(iz),wk(izt)) c c------------------proceed to calculate the direction vectors---------------- c c first, case of no old p vectors. c 711 np = min(mod(in,ns2),ns1) if (np .ne. 0) go to 100 c call vcopy (n,wk(izt),wk(indpt(in))) if (.not. ipl) then call suba (coef,jcoef,wfac,jwfac,n,wk(indpt(in)),wk(indqap(in))) else call suba (coef,jcoef,wfac,jwfac,n,wk(indpt(in)),wk(iv1)) call precl (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a wk(iv1),wk(indqap(in))) end if go to 120 c c case of at least one old p vector. c this case is handled in a tricky way, to optimize the workspace. c 100 if (.not. ipl) then call suba (coef,jcoef,wfac,jwfac,n,wk(izt),wk(iv1)) else call suba (coef,jcoef,wfac,jwfac,n,wk(izt),wk(iv2)) call precl (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a wk(iv2),wk(iv1)) end if c top = vdot (n,wk(indqap(in-np)),wk(iv1)) wk(inapar(in-np)) = top bet = - top / wk(inddot(in-np)) call vtriad (n,wk(indpt(in)),wk(izt),bet,wk(indpt(in-np)),1) call vtriad (n,wk(indqap(in)),wk(iv1),bet,wk(indqap(in-np)),1) c do 612 i = in-np+1, in-1 top = vdot (n,wk(indqap(i)),wk(iv1)) wk(inapar(i)) = top bet = - top / wk(inddot(i)) call vtriad (n,wk(indpt(in)), wk(indpt(in)), bet,wk(indpt(i)), 1) 612 call vtriad (n,wk(indqap(in)),wk(indqap(in)),bet,wk(indqap(i)),1) c c at this point, we are finished forming the latest direction vector. c we proceed to calculate lambda and update the solution and c the residuals. c 120 continue apap = vdot (n,wk(indqap(in)),wk(indqap(in))) c if (abs(apap) .lt. srelpr**2) go to 998 if (abs(apap) .eq. 0.0d0) go to 998 wk(inddot(in)) = apap top = vdot (n,wk(indqap(in)),wk(iz)) vlamda = top / apap c if (.not. ipr) zzdot = zzdot - 2*vlamda*top + vlamda**2*apap c c u -- call vtriad (n,u,u,vlamda,wk(indpt(in)),1) c c z -- call vtriad (n,wk(iz),wk(iz),-vlamda,wk(indqap(in)),1) c c----------------------------hess matrix update--------------------------- c c there are two schemes here, based on two different ways of projecting c the iteration matrix. c c update hessenberg matrix: scheme 1 c if (.not. evest) go to 955 wk(indlam(in)) = vlamda if (is .eq. 0) call vfill (nhess*(nv+2),wk(ihess),0.0d0) if (methev .ne. 1) go to 746 c do 954 i=in-np,in if (i .eq. in) apar = apap if (i .ne. in) apar = wk(inapar(i)) wk(indhes(i+1+(is-in),in-i+2)) = wk(indhes(i+1+(is-in),in-i+2)) a + apar/wk(indlam(in)) / sqrt(wk(inddot(in))*wk(inddot(i))) if (is .ne. 0) a wk(indhes(i+1+(is-in),in-i+1)) = wk(indhes(i+1+(is-in),in-i+1)) a - apar/wk(indlam(in-1)) / sqrt(wk(inddot(in-1))*wk(inddot(i))) 954 continue iesize = is go to 747 c c update hessenberg matrix: scheme 2 c 746 iesize = is + 1 wk(indhes(is+2,1)) = -1.0d0 / vlamda wk(indhes(is+1,2)) = 1.0d0 / vlamda if (np .eq. 0) go to 749 do 748 i=in-np,in-1 id = in - i + 1 wk(indhes(is+3-id,id )) = wk(indhes(is+3-id,id )) a - wk(inapar(i))/wk(inddot(i))/wk(indlam(i)) 748 wk(indhes(is+2-id,id+1)) = wk(indhes(is+2-id,id+1)) a + wk(inapar(i))/wk(inddot(i))/wk(indlam(i)) 749 continue c c estimate eigenvalues ... c 747 nwhe = nw - (iv1-1) call hesest (wk(ihess),nhess,nv+2,iesize,ns3,havest, a emaxnw,eminnw,wk(iv1),nwhe,ier) nwusd = max (nwusd,iv1-1+nwhe) if (ier .ne. 0) go to 995 if (.not. havest) go to 955 if (hadest) go to 956 if (maxadd) emax = emaxnw if (minadd) emin = eminnw hadest = .true. go to 955 956 if (maxadd) emax = max (emax,emaxnw) if (minadd) emin = min (emin,eminnw) c c---------------------------proceed to next iteration------------------------ c 955 in = in + 1 is = is + 1 if (is .eq. ns2) is = 0 go to 10 c c-------------------------------finish up------------------------------------ c 900 if (.not. halt) go to 996 if (level .ge. 1) write (nout,720) in 720 format (/' orthomin converged in ',i5,' iterations.') c 725 if (idgts .ge. 0) a call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) c pack revised parms into iparm, rparm ... t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c c--------------------------------error returns----------------------------- c c unimplemented option ... 995 ier = -16 call ershow (ier,'omingw') go to 725 c c no convergence ... 996 ier = 1 call ershow (ier,'omingw') zeta = stptst go to 725 c c generic error handler ... 997 call ershow (ier,'omingw') go to 735 c c breakdown ... 998 ier = -15 call ershow (ier,'omingw') go to 725 c c insufficient floating point wksp ... 999 ier = -2 call ershow (ier,'omingw') go to 735 end subroutine oresw (suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c this routine implements orthores with truncation and c restarting and with 2-sided preconditioning. the value of z is c the identity. the code is optimal in speed and workspace c requirements, for general a, ql and qr. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) external suba, subql, subqr dimension iparm(30), rparm(30) logical iql, iqr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c the following indexing functions are used to access the old c direction vectors and dot products -- c indu(i) = iu + mod(i,nv)*n indz(i) = iz + mod(i,nv)*n inddot(i) = idot + mod(i,nv) c c various preliminary calculations. c nwusd = 0 ier = 0 iacel = 9 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 997 if (level .ge. 2) write (nout,496) 496 format (' orthores') iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 c c initialize the stopping test ... c call inithv (0) zhave = .true. zthave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c c memory allocation, etc. c c nomenclature -- r -- residual of the original system. c z -- inv(ql)*r c zt -- inv(qr)*z c nv = max (1,min(ns1+1,ns2)) iu = 1 iz = iu + nv*n idot = iz + nv*n iv1 = idot + nv iv2 = iv1 + n nwusd = max (nwusd,iv2-1+n) c c check the memory usage -- c if (nwusd .gt. nw) go to 999 c in = 0 c c perform first-iterate calculations. c note -- we will use the vector 'u' to store ztilde. the u vectors c will be stored in the table. wk(iv1) will hold r. c call vcopy (n,u,wk(indu(0))) call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(indz(0))) call subqr (coef,jcoef,wfac,jwfac,n,wk(indz(0)),u) wk(inddot(0)) = vdot (n,wk(indz(0)),wk(indz(0))) c c-------------------------begin iteration loop----------------------- c c determine whether or not to stop -- c 10 call inithv (1) nwpstp = nw - (iv2-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,wk(indu(in)),ubar,rhs,xxx,wk(indz(in)),u, a wk(iv2),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv2-1) if (level .ge. 2) call iterm (n,wk(indu(in))) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c c proceed to calculate the iterates. c np = min(mod(in,ns2)+1,ns1+1) call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) top = vdot (n,wk(indz(in+1-np)),wk(iv2)) sig = top / wk(inddot(in+1-np)) call vtriad (n,wk(indz(in+1)),wk(iv2),-sig,wk(indz(in+1-np)),1) call vtriad (n,wk(indu(in+1)),u,sig,wk(indu(in+1-np)),1) sigsum = sig ibegin = in - np + 2 iend = in if (ibegin .gt. iend) go to 613 do 612 i = ibegin,iend top = vdot (n,wk(indz(i)),wk(iv2)) den = wk(inddot(i)) if (abs(den) .lt. srelpr) go to 998 sig = top / den call vtriad (n,wk(indz(in+1)),wk(indz(in+1)),-sig,wk(indz(i)),1) call vtriad (n,wk(indu(in+1)),wk(indu(in+1)),sig,wk(indu(i)),1) 612 sigsum = sigsum + sig 613 continue if (abs(sigsum) .lt. srelpr) go to 998 vlamda = 1.0d0/sigsum call vtriad (n,wk(indz(in+1)),xxx,-vlamda,wk(indz(in+1)),2) call vtriad (n,wk(indu(in+1)),xxx,vlamda,wk(indu(in+1)),2) wk(inddot(in+1)) = vdot (n,wk(indz(in+1)),wk(indz(in+1))) c call subqr (coef,jcoef,wfac,jwfac,n,wk(indz(in+1)),u) c c proceed to next iteration c in = in + 1 go to 10 c c-----------------------------finish up---------------------------- c 900 call vcopy (n,wk(indu(in)),u) if (halt) go to 715 ier = 1 call ershow (ier,'oresw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' orthores converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 997 call ershow (ier,'oresw') go to 735 c 998 ier = -15 call ershow (ier,'oresw') go to 725 c 999 ier = -2 call ershow (ier,'oresw') go to 735 c end subroutine iomw (suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the (truncated) iom algorithm. the reference is c youcef saad, "krylov subspace methods ...", mathematics of c computation, vol. 37, july 1981, pp. 105f. c c in the symmetric case this algorithm reduces to the symmlq c algorithm of paige and saunders, except paige and saunders have c implemented a trick to avoid breakdown before convergence. this c trick is not implemented here. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) integer idotw, vect1, vect2, dots1, dots2, os logical uneed external suba, subql, subqr dimension iparm(30), rparm(30) dimension gdum(1), wkxxx(1) logical iql, iqr logical exact, gamize c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c next, the indexing functions. c indv1(i) = vect1 + mod(i,nv)*n indbe2(i) = ibeta2 + mod(i,os) indc(i) = icos + mod(i,os) inds(i) = isin + mod(i,os) indu(i) = iu + mod(i,os+1) indw(i) = iw + n*mod(i,os) c c preliminary calculations. c nwusd = 0 ier = 0 iacel = 10 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 996 iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 gamize = .true. if (iqr) go to 995 if (level .ge. 2) write (nout,496) 496 format (' iom') c the following flag tells us whether the truncating actually c throws out important information. it should actually be set to c true if the matrix is symmetric. exact = .false. c c initialize the stopping test ... c call inithv (0) zdhav = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c c ... associated integer variables. c os = iabs(ns1) iv = 1 nv = os idotw = 1 iw = 1 vect1 = iw + iv*n*os vect2 = vect1 dots1 = vect2 + iv*n*nv dots2 = dots1 ibeta1 = dots2 + idotw*os ibeta2 = ibeta1 icos = ibeta2 + os isin = icos + os iu = isin + os iv1 = iu + os+1 iv2 = iv1 + n nwusd = max (nwusd,iv2-1+n) c c check the memory usage -- c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 uneed = rcalp .or. zcalp .or. ztcalp .or. udhav a .or. ntest .eq. 6 .or. level .ge. 3 c c--------------------------begin iteration loop--------------------- c c perform first-iterate calculations ... c 10 if (is .ne. 0) go to 100 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) call pvec (n,nv,iv,1,os,idotw,is,1,1,wk(vect1),wk(dots1),0, a wk(ibeta1),gdum,gamize,wk(iv2),wkxxx,ier) gamma1 = gdum(1) if (ier .lt. 0) go to 997 gamma2 = gamma1 vnorm1 = 1.0d0/gamma1 vnorm2 = 1.0d0/gamma2 zdot = vnorm1**2 ucnp1= 0.0d0 c 100 call inithv (1) zdhav = .true. nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c c c ... compute q(n+1), etc -- the direction vectors c call suba (coef,jcoef,wfac,jwfac,n,wk(indv1(is)),wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) call pvec (n,nv,iv,1,os,idotw,is+1,1,1,wk(vect1),wk(dots1),0, a wk(ibeta1),gdum,gamize,wk(iv2),wkxxx,ier) gamma1 = gdum(1) if (ier .lt. 0) go to 997 gamma2 = gamma1 c c ... now record norms. c vn1old = vnorm1 vnorm1 = 1.0d0/gamma1 vn2old = vnorm2 vnorm2 = 1.0d0/gamma2 c c ... now update the factorization c ucnbar = ucnp1 ibgn = max (0,is+1-os) do 1 i = ibgn,is 1 wk(indu(i+1)) = -wk(indbe2(i)) if (ibgn .gt. 0) wk(indu(ibgn))= 0.0d0 call qrupd (is+1,os+1,os,wk(icos),wk(isin),ucnbar,ucn,wk(iu), a vn2old,ier) if (ier .lt. 0) go to 998 ucnp1 = wk(indu(is+1)) c c ... update the old w vector. c if (is .ne. 0) a call vtriad (n,wk(indw(is-1)),xxx,ucnbar/ucn,wk(indw(is-1)),2) c c ... now generate the new w vector. c if (abs(ucnp1) .lt. srelpr) go to 998 call vcopy (n,wk(indv1(is)),wk(iv1)) ibgn = max (1,is-os+1) iend = is if (iend .lt. ibgn) go to 200 do 201 i = ibgn,iend 201 call vtriad (n,wk(iv1),wk(iv1),-wk(indu(i)),wk(indw(i-1)),1) 200 continue call vtriad (n,wk(indw(is)),xxx,1.0d0/ucnp1,wk(iv1),2) if (is .ne. 0) go to 205 c c ... update iterate u(0). c zold= 0.0d0 zbar = vn1old if (uneed) call vtriad (n,u,u,zbar,wk(indw(0)),1) go to 210 c c ... update subsequent iterates u(n). c 205 zold = wk(indc(is))*zbar zbold = zbar zbar =-wk(inds(is))*zbar factor = zold if (uneed) factor = factor - zbold*ucn/ucnbar call vtriad (n,u,u,factor,wk(indw(is-1)),1) if (uneed) call vtriad (n,u,u,zbar,wk(indw(is)),1) c to avoid breakdown for the symmetric indefinite case, we'd only add c in w(is-1) here, i believe. 210 continue zdot = (zbar/ucnp1*vnorm1)**2 c c proceed to next iteration c in = in + 1 is = is + 1 go to 10 c c-----------------------------finish up------------------------------ c 900 if (.not. uneed) call vtriad (n,u,u,zbar,wk(indw(is-1)),1) if (halt) go to 715 ier = 1 call ershow (ier,'iomw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' iom converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 995 ier = -16 call ershow (ier,'iomw') return c 996 call ershow (ier,'iomw') go to 735 c 997 ier = -13 call ershow (ier,'iomw') go to 725 c 998 ier = -14 call ershow (ier,'iomw') go to 725 c 999 ier = -2 call ershow (ier,'iomw') go to 735 c end subroutine gmresw (suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the truncated/restarted gmres algorithm. a detailed c description of this useful algorithm may be found in the paper, c "gmres: a generalized minimal residual algorithm for solving c nonsymmetric linear systems", youcef saad and martin h. schultz, c siam j. sci. stat. comput., v. 7, no. 3, july 1986. c c further scoop on how to set up qr factorizations can be obtained in c "practical use of some krylov subspace methods for solving c indefinite and unsymmetric linear systems", youcef saad, siam j. sci. c stat. comput., v. 5, no. 1, march 1984. c c the advantage of this algorithm over its competitors orthomin and gcr c is that work and storage are saved by avoiding the computation of c certain vectors. c c this routine now handles right and 2-sided preconditioning. the main c thing to note about this is that a new table of basis vecttors is now c necessary, to use to update the solution. c c this routine also avoids explicit scaling of the p and w vectors. c c for the pure restarted case, we actually compute the final arnoldi c vector, rather than just estimating its norm. this is a diversion c from the saad/schultz paper. this was done because in some cases it c was found that the norm estimation was subject to significant c numerical error. c c modified feb. 1990 to make the restarted method more efficient. c specifically, new formulas were installed for the scalar part of c the computation to give an optimal asymptotic dependence on ns2. c c---------------------------------------------------------------------- c dimension coef(*), jcoef(*), wfac(*), jwfac(*) dimension u(*), ubar(*), rhs(*), wk(*) logical uneed, zneed external suba, subql, subqr dimension iparm(30), rparm(30) logical iql, iqr logical trunc, exact, rstrt, rstrtd, zhvold logical havest, hadest, evadpt c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c-------------------------- indexing functions -------------------------- c c the following function accesses the arnoldi vectors. indp(i) = ip + mod(i,nv)*n c c the following accesses q-r times the arnoldi vectors indpt(i) = ipt + mod(i,nvt)*n c c fudge factor for the arnoldi vectors. p(actual) = p(stored)*pfudge. c (we do the same trick with a*p.) indpf(i) = ipf + mod(i,nv) c c the following accesses the w-vectors. indw(i) = iw + n*mod(i,nv) c c fudge factors for the w vectors ... c (similarly, the vector "xi" is fudged.) indwf(i) = iwf + mod(i,nv) c c the following accesses the hessenberg matrix -- stored by diagonals ... indhes(i,j) = ihess + (i-1) + (j-i+1)*nhess c c the following are the cosines and sines of the rotations. indc(i) = icos + mod(i,nrot) inds(i) = isin + mod(i,nrot) c c the following accesses the u matrix -- stored by columns ... indu(i,j) = iu + j-i+1 + mod(j-1,nuc)*nbwuh c c the following accesses the z-vector ... indzc(i) = izc + mod(i-1,nzc) c c----------------------- preliminary calculations ---------------------- c nwusd = 0 ier = 0 iacel = 11 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 996 iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 iadpt = ns3 evadpt = (maxadd .or. minadd) .and. iadpt .ne. 0 trunc = ns1 .lt. (ns2-1) exact = .not. trunc if (ns1 .lt. 2) go to 995 if (level .ge. 2) write (nout,496) 496 format (' gmres') c c--------------------------initialize the stopping test------------------ c call inithv (0) zdhav = .not. (trunc .and. .not.exact) nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c c uneed tells us whether u must be computed explicitly per iteration. c similarly for zneed. uneed = rcalp .or. udhav a .or. ntest .eq. 6 .or. level .ge. 3 zneed = zcalp hadest = .false. c c------------------------associated integer variables--------------------- c c---effective ns2--- ns2e = min(ns2,itmax) c---length of diags of hess matrix--- nhess = ns2e + 2 c---bandwidth of the hess matrix--- nbwh = min(ns1+1,ns2e+1) c---bandwidth of u-or-h--- nbwuh = min(ns1+2, ns2e+1) c---number columns stored of the u matrix--- if ( trunc) nuc = 1 if (.not.trunc) nuc = ns2e c---size of arnoldi-vector tables--- nv = min(ns1,ns2e+1) nvt = nv if (iqr .and. .not.trunc) nvt = nv - 1 if (iqr .and. trunc) nvt = 1 c---number of givens rotations to store--- nrot = min(ns1,ns2e) c---number of elts of z-vector to store--- if ( trunc) nzc = 2 if (.not.trunc) nzc = ns2e + 1 c c------------------------------memory layout--------------------------- c ihess = 1 ipt = ihess + nhess*nbwh if (.not.evadpt) ipt = ihess ip = ipt + n*nvt if (.not.iqr) ip = ipt izc = ip + n*nv icos = izc + nzc isin = icos + nrot iy = isin + nrot iu = iy + ns2e if (trunc .or. .not.uneed) iu = iy ipz = iu + nbwuh*nuc ipf = ipz + ns2e+1 if (trunc) ipf = ipz iz = ipf + nv iw = iz + n iwf = iw + n*nv ixi = iwf + nv iv1 = ixi + n if (.not. trunc) iv1 = iw iv2 = iv1 + n nwusd = max (nwusd,iv2+n-1) c c --- check the memory usage --- c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 rstrtd = .true. c c-------------------------------------------------------------------- c---------------------------begin iteration loop--------------------- c-------------------------------------------------------------------- c c handle first iteration after restart ... c 10 call inithv (1) zdhav = .not.(trunc.and..not.exact) .and. in .ne. 0 if (.not. rstrtd) go to 100 c ---get resid--- if (.not. zhave) then if (iql) then call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iz)) else call suba (coef,jcoef,wfac,jwfac,n,u,wk(iz)) call vexopy (n,wk(iz),rhs,wk(iz),2) end if zhave = .true. end if c ---get resid norm--- if (.not. zdhav) then zdot = vdot (n,wk(iz),wk(iz)) zdhav = .true. end if if (zdot .lt. 0.0d0) go to 994 vnorm = sqrt(zdot) if (vnorm .lt. srelpr**2) go to 997 call vcopy (n,wk(iz),wk(indp(is))) wk(indpf(is)) = 1.0d0/vnorm wk(indzc(is+1)) = vnorm c c --- perform stopping test --- c 100 nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,wk(iz),xxx, a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c c rstrt tells us whether this is the last step before restarting ... rstrt = (is+1 .eq. ns2) if (evadpt .and. is .eq. 0) & call vfill (nhess*nbwh,wk(ihess),0.0d0) c c-----------------------compute the new arnoldi vector---------------- c c pn(is+1)*p(is+1) = a*p(is) + sum (i=0 to is) (beta(is+1,i)*p(i)), c c---get a times old vec--- if (iqr) call subqr (coef,jcoef,wfac,jwfac,n,wk(indp (is)), a wk(indpt(is))) if (iql) then call suba (coef,jcoef,wfac,jwfac,n,wk(indpt(is)),wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) else call suba (coef,jcoef,wfac,jwfac,n,wk(indpt(is)),wk(iv2)) end if apf = wk(indpf(is)) c---compute arnoldi vector--- ibeg = max (is+1-ns1,0) iend = is if (ibeg .gt. 0) wk(indu(ibeg,is+1)) = 0.0d0 pfnew = apf do 199 i = ibeg,iend h = vdot (n,wk(indp(i)),wk(iv2)) * wk(indpf(i))*apf wk(indu(i+1,is+1)) = h if (evadpt) wk(indhes(i+1,is+1)) = h if (i .eq. ibeg) call vtriad (n,wk(indp(is+1)),wk(iv2), a -h*wk(indpf(i))/pfnew,wk(indp(i)),1) if (i .ne. ibeg) call vtriad (n,wk(indp(is+1)),wk(indp(is+1)), a -h*wk(indpf(i))/pfnew,wk(indp(i)),1) 199 continue wk(indpf(is+1)) = pfnew c---get norm--- dot = vdot (n,wk(indp(is+1)),wk(indp(is+1))) * pfnew**2 vnorm = sqrt(dot) if (vnorm .lt. srelpr**2) go to 192 wk(indu(is+2,is+1)) = vnorm if (evadpt) wk(indhes(is+2,is+1)) = vnorm c---scale--- wk(indpf(is+1)) = wk(indpf(is+1))/vnorm if (abs(wk(indpf(is+1))) .lt. srelpr .or. a abs(wk(indpf(is+1))) .gt. 1.0d0/srelpr) then call vtriad (n,wk(indp(is+1)),xxx,wk(indpf(is+1)), a wk(indp(is+1)),2) wk(indpf(is+1)) = 1.0d0 end if c c-----------------------update the qr factorization------------------- c 192 continue c---apply old rotations--- ibgn = max(0,is-ns1) iuold = indu(ibgn+1,is+1) do 7977 i = ibgn, is-1 iunew = indu(i+2,is+1) ut = wk(iuold) h = wk(iunew) ctmp = wk(indc(i+1)) stmp = wk(inds(i+1)) wk(iuold) = ctmp*ut + stmp*h wk(iunew) = -stmp*ut + ctmp*h 7977 iuold = iunew iunew = indu(is+2,is+1) c---calc new rotation--- v1 = wk(iuold) v2 = wk(iunew) denom = sqrt (v1**2 + v2**2) if (denom .lt. srelpr) go to 998 wk(indc(is+1)) = v1/denom wk(inds(is+1)) = v2/denom c---apply new rotation--- wk(iuold) = denom wk(iunew) = 0.0d0 c c--------------------------compute w, if needed------------------------ c uc = wk(indu(is+1,is+1)) if (abs(uc) .lt. srelpr**2) go to 998 if (.not.trunc) go to 572 c c ... case of explicit w calc ... c if (is .eq. 0) then call vcopy (n,wk(indpt(is)),wk(indw(1))) wk(indwf(is+1)) = wk(indpf(is))/uc c call vtriad (n,wk(indw(is+1)),xxx,1.0d0/uc,wk(indpt(is)),2) go to 572 end if wfnew = wk(indpf(is)) ibeg = max (1,is+1-ns1) iend = is do 574 i = ibeg, iend if (i .eq. ibeg) call vtriad (n,wk(indw(is+1)),wk(indpt(is)), a -wk(indu(i,is+1))*wk(indwf(i))/wfnew,wk(indw(i)),1) if (i .ne. ibeg) call vtriad (n,wk(indw(is+1)),wk(indw(is+1)), a -wk(indu(i,is+1))*wk(indwf(i))/wfnew,wk(indw(i)),1) 574 continue wk(indwf(is+1)) = wfnew/uc if (abs(wk(indwf(is+1))) .lt. srelpr .or. a abs(wk(indwf(is+1))) .gt. 1.0d0/srelpr) then call vtriad (n,wk(indw(is+1)),xxx,wk(indwf(is+1)), a wk(indw(is+1)),2) wk(indwf(is+1)) = 1.0d0 end if 572 continue c c---get new zc entries--- wk(indzc(is+2)) = -wk(inds(is+1))*wk(indzc(is+1)) wk(indzc(is+1)) = wk(indc(is+1))*wk(indzc(is+1)) c c------------------- u-vector computation section --------------------- c if (trunc) then c c---truncated case--- call vtriad (n,u,u,wk(indzc(is+1))*wk(indwf(is+1)), a wk(indw(is+1)),1) else c c---non-truncated case--- if (.not.(uneed .or. rstrt)) go to 410 iynew = iv1 nwusd = max (nwusd,iynew+ns2e-1) if (nwusd .gt. nw) go to 999 c ---do back solve on u-matrix--- nm = is + 1 do 623 i = nm, 1, -1 sum = wk(indzc(i)) do 624 j = i+1, nm 624 sum = sum - wk(iynew-1+j)*wk(indu(i,j)) 623 wk(iynew-1+i) = sum/wk(indu(i,i)) c ---form iterate--- do 625 i = 0, nm-1 val = wk(iynew+i) if (uneed .and. i.ne.nm-1) val = val - wk(iy+i) 625 call vtriad (n,u,u,val*wk(indpf(i)),wk(indpt(i)),1) if (uneed) call vcopy (nm,wk(iynew),wk(iy)) endif 410 continue c c--------------------- residual computation section ------------------- c zhvold = zhave zhave = .false. if (trunc) go to 671 c c---non-truncated case--- c c do it if resid needed by pstop or if restarting. if (zneed .or. rstrt) then ipznew = iv1 nwusd = max (nwusd,ipznew+ns2e) if (nwusd .gt. nw) go to 999 call vcopy (is+1,wk(izc),wk(ipznew)) wk(ipznew+is+1) = 0.0d0 c ---apply rotations--- do 644 i = is+1, 1, -1 v1 = wk(indc(i))*wk(ipznew+i-1) - wk(inds(i))*wk(ipznew+i) v2 = wk(inds(i))*wk(ipznew+i-1) + wk(indc(i))*wk(ipznew+i) wk(ipznew+i-1) = v1 644 wk(ipznew+i) = v2 c ---form resid--- do 645 i = 0, is+1 val = wk(ipznew+i) if (zhvold .and. i.ne.is+1) val = val - wk(ipz) 645 call vtriad (n,wk(iz),wk(iz),-val*wk(indpf(i)), a wk(indp(i)),1) call vcopy (is+2,wk(ipznew),wk(ipz)) zhave = .true. end if go to 425 c c---truncated case--- c c do it if pstop needs it or if we may restart later. 671 if ( zneed .or. (itmax.gt.ns2) ) then c ---update xi--- if (is .eq. 0) then call vcopy (n,wk(indp(is)),wk(ixi)) xif = wk(indpf(is)) else xif = xif*(-wk(inds(is))) call vtriad (n,wk(ixi),wk(ixi), a wk(indc(is))*wk(indpf(is))/xif,wk(indp(is)),1) end if if (abs(xif).lt.srelpr .or. a abs(xif) .gt. 1.0d0/srelpr) then call vtriad (n,wk(ixi),xxx,xif,wk(ixi),2) xif = 1.0d0 end if c ---form resid--- call vtriad (n,wk(iz),wk(iz), a -wk(indzc(is+1))*wk(indc(is+1))*xif,wk(ixi),1) call vtriad (n,wk(iz),wk(iz), a -wk(indzc(is+1))*wk(inds(is+1))*wk(indpf(is+1)), a wk(indp(is+1)),1) zhave = .true. endif 425 continue c c---get resid norm--- c if (exact) then zdot = wk(indzc(is+2))**2 end if c c--------------------------------ev est------------------------------- c if (evadpt) then nwhe = nw - (iv1-1) call hesest (wk(ihess),nhess,nv+2,is+1,iadpt,havest, a emaxnw,eminnw,wk(iv1),nwhe,ier) nwusd = max (nwusd,iv1-1+nwhe) if (ier .ne. 0) go to 996 if (.not. havest) go to 874 if (hadest) go to 876 if (maxadd) emax = emaxnw if (minadd) emin = eminnw hadest = .true. go to 874 876 if (maxadd) emax = max (emax,emaxnw) if (minadd) emin = min (emin,eminnw) end if c c-------------------------finish up the iteration---------------------- c 874 in = in + 1 is = is + 1 if (rstrt) is = 0 rstrtd = rstrt go to 10 c c---------------------------------------------------------------------- c------------------------------wrap it up------------------------------ c---------------------------------------------------------------------- c c---form u, if not up-to-date--- c 900 if (uneed .or. rstrtd .or. trunc) go to 901 iynew = iv1 nwusd = max (nwusd,iynew+ns2e-1) if (nwusd .gt. nw) go to 999 c ---do back solve on u-matrix--- nm = is do 663 i = nm, 1, -1 sum = wk(indzc(i)) do 664 j = i+1, nm 664 sum = sum - wk(iynew-1+j)*wk(indu(i,j)) 663 wk(iynew-1+i) = sum/wk(indu(i,i)) c ---form iterate--- do 665 i = 0, nm-1 val = wk(iynew+i) 665 call vtriad (n,u,u,val*wk(indpf(i)),wk(indpt(i)),1) c c---------------------------------------------------------------------- c-----------------------------head out of here------------------------- c---------------------------------------------------------------------- c 901 continue if (halt) go to 715 ier = 1 call ershow (ier,'gmresw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' gmres converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c----------------------------error returns----------------------------- c 994 ier = -15 call ershow (ier,'gmresw') return c 995 ier = -16 call ershow (ier,'gmresw') return c 996 call ershow (ier,'gmresw') go to 735 c 997 ier = -13 call ershow (ier,'gmresw') go to 725 c 998 ier = -14 call ershow (ier,'gmresw') go to 725 c 999 ier = -2 call ershow (ier,'gmresw') go to 735 c end subroutine uslqw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the usymlq algorithm. see: m. a. saunders, h. d. simon c and e. l. yip, "two conjugate-gradient-type methods for sparse c unsymmetric linear equations, report eta-tr-18, boeing computer c services, seattle, washington, 1984, to appear in siam journal on c numerical analysis. c c note -- this routine is still not quite optimal. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) integer vect1, vect2, os logical uneed external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c next, the indexing functions. c indv1(i) = vect1 + mod(i,nv)*n indv2(i) = vect2 + mod(i,nv)*n indbe1(i) = ibeta1 + mod(i,os) indbe2(i) = ibeta2 + mod(i,os) indc(i) = icos + mod(i,os) inds(i) = isin + mod(i,os) indu(i) = iu + mod(i,os+1) indw(i) = iw + n*mod(i,os) c c preliminary calculations. c nwusd = 0 ier = 0 iacel = 12 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 996 iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 if (iqr) go to 995 if (level .ge. 2) write (nout,496) 496 format (' usymlq') c c initialize the stopping test ... c call inithv (0) zdhav = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c c ... associated integer variables. c os = 2 iv = 1 nv = os iw = 1 vect1 = iw + iv*n*os vect2 = vect1 + iv*n*nv ibeta1 = vect2 + iv*n*nv ibeta2 = ibeta1 + os icos = ibeta2 + os isin = icos + os iu = isin + os iv1 = iu + os + 1 iv2 = iv1 + n nwusd = max (nwusd,iv2-1+n) c c check the memory usage -- c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 uneed = rcalp .or. zcalp .or. ztcalp .or. udhav a .or. ntest .eq. 6 .or. level .ge. 3 c c------------------------begin iteration loop----------------------- c c perform first-iterate calculations ... c 10 if (in .ne. 0) go to 100 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) vnorm1 = sqrt(vdot(n,wk(iv2),wk(iv2))) vnorm2 = vnorm1 if (abs(vnorm1) .lt. srelpr) go to 997 gamma1 = 1.0d0/vnorm1 gamma2 = 1.0d0/vnorm2 call vtriad (n,wk(indv1(0)),xxx,gamma1,wk(iv2),2) call vcopy (n,wk(indv1(0)),wk(indv2(0))) zdot = vnorm1**2 ucnp1= 0.0d0 c c determine whether or not to stop -- c 100 call inithv (1) zdhav = .true. nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c c ... compute q(n+1), etc -- the direction vectors c call suba (coef,jcoef,wfac,jwfac,n,wk(indv1(in)),wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) an = vdot (n,wk(indv2(in)),wk(iv2)) if (in .ne. 0) go to 110 call vtriad (n,wk(indv2(in+1)),wk(iv2),-an,wk(indv2(in)), 1) wk(indbe2(in)) = -an go to 111 110 call vtriad (n,wk(indv2(in+1)),xxx,-vnorm1,wk(indv2(in-1)),2) call vtriad (n,wk(indv2(in+1)),wk(indv2(in+1)),1.0d0,wk(iv2),1) call vtriad (n,wk(indv2(in+1)),wk(indv2(in+1)),-an, a wk(indv2(in)),1) wk(indbe2(in)) = -an wk(indbe2(in-1)) = -vnorm1 111 vn2old = vnorm2 vnorm2 = sqrt(vdot (n,wk(indv2(in+1)),wk(indv2(in+1)))) if (abs(vnorm2) .lt. srelpr) go to 997 gamma2 = 1.0d0/vnorm2 call vtriad (n,wk(indv2(in+1)),xxx,gamma2,wk(indv2(in+1)),2) c call subqlt (coef,jcoef,wfac,jwfac,n,wk(indv2(in)),wk(iv1)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) if (in .ne. 0) go to 810 call vtriad (n,wk(indv1(in+1)),wk(iv2),-an,wk(indv1(in)),1) wk(indbe1(in)) = -an go to 811 810 call vtriad (n,wk(indv1(in+1)),xxx,-vn2old,wk(indv1(in-1)),2) call vtriad (n,wk(indv1(in+1)),wk(indv1(in+1)),1.0d0,wk(iv2),1) call vtriad (n,wk(indv1(in+1)),wk(indv1(in+1)),-an,wk(indv1(in)), a 1) wk(indbe1(in)) = -an wk(indbe1(in-1)) = -vn2old 811 vn1old= vnorm1 vnorm1 = sqrt(vdot (n,wk(indv1(in+1)),wk(indv1(in+1)))) if (abs(vnorm1) .lt. srelpr) go to 997 gamma1 = 1.0d0/vnorm1 call vtriad (n,wk(indv1(in+1)),xxx,gamma1,wk(indv1(in+1)),2) c c ... now update the factorization ucnbar = ucnp1 ibgn = max (0,in+1-os) do 1 i = ibgn,in 1 wk(indu(i+1)) = -wk(indbe2(i)) if (ibgn .gt. 0) wk(indu(ibgn))= 0.0d0 call qrupd (in+1,os+1,os,wk(icos),wk(isin),ucnbar,ucn,wk(iu), a vn2old,ier) if (ier .ne. 0) go to 998 ucnp1 = wk(indu(in+1)) c c ... update the old w vector. c if (in .ne. 0) a call vtriad (n,wk(indw(in-1)),xxx,ucnbar/ucn,wk(indw(in-1)),2) c c ... now generate the new w vector. c if (abs(ucnp1) .lt. srelpr) go to 998 call vcopy (n,wk(indv1(in)),wk(iv1)) ibgn = max (1,in-os+1) iend = in if (iend .lt. ibgn) go to 200 do 201 i = ibgn,iend 201 call vtriad (n,wk(iv1),wk(iv1),-wk(indu(i)),wk(indw(i-1)),1) 200 continue call vtriad (n,wk(indw(in)),xxx,1.0d0/ucnp1,wk(iv1),2) if (in .ne. 0) go to 205 c c ... update iterate u(0). zold= 0.0d0 zbar = vn1old if (uneed) call vtriad (n,u,u,zbar,wk(indw(0)), 1) go to 210 c c ... update subsequent iterates u(n). c 205 zold = wk(indc(in))*zbar zbold = zbar zbar =-wk(inds(in))*zbar factor = zold if (uneed) factor = factor - zbold*ucn/ucnbar call vtriad (n,u,u,factor,wk(indw(in-1)), 1) if (uneed) call vtriad (n,u,u,zbar,wk(indw(in)), 1) 210 continue zdot = (zbar/ucnp1*vnorm1)**2 c c proceed to next iteration c in = in + 1 is = is + 1 go to 10 c c------------------------------finish up------------------------------- c 900 if (.not. uneed) call vtriad (n,u,u,zbar,wk(indw(in-1)),1) if (halt) go to 715 ier = 1 call ershow (ier,'uslqw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' usymlq converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c c unimplemented option 995 ier = -16 call ershow (ier,'uslqw') return 996 call ershow (ier,'uslqw') go to 735 c 997 ier = -13 call ershow (ier,'uslqw') go to 725 c 998 ier = -14 call ershow (ier,'uslqw') go to 725 c 999 ier = -2 call ershow (ier,'uslqw') go to 735 c end subroutine usqrw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the usymqr algorithm. same reference as usymlq c algorithm. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) integer vect1, vect2, os external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c next, the indexing functions. c indv 1(i)= vect1 + mod(i,nv)*n indv2(i) = vect2 + mod(i,nv)*n indbe 1(i)= ibeta1 + mod(i,os) indbe2(i) = ibeta2 + mod(i,os) indc(i) = icos + mod(i,os+ 1) inds(i) = isin + mod(i,os+ 1) indu(i) = iu + mod(i,os+2) indw(i) = iw + n*mod(i,os) c c preliminary calculations. c nwusd = 0 ier = 0 iacel = 13 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 996 iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 if (iqr) go to 995 if (level .ge. 2) write (nout,496) 496 format (' usymqr') c c initialize the stopping test ... c call inithv (0) zdhav = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c c ... associated integer variables. c os = 2 iv = 1 nv = os iw = 1 vect1 = iw + iv*n*os vect2 = vect1 + iv*n*nv ibeta1 = vect2 + iv*n*nv ibeta2 = ibeta1 + os icos = ibeta2 + os isin = icos + os+ 1 iu = isin + os+ 1 iv1 = iu + os+2 iv2 = iv1 + n nwusd = max (nwusd,iv2- 1+n) c c check the memory usage -- c if (nwusd .gt. nw) go to 999 c c c now, perform first-iterate calculations in = 0 is = 0 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) vnorm1 = sqrt(vdot (n,wk(iv2),wk(iv2))) vnorm2 = vnorm1 if (abs(vnorm1) .lt. srelpr) go to 997 gamma1 = 1.0d0/vnorm1 gamma2 = 1.0d0/vnorm2 call vtriad (n,wk(indv1(0)),xxx,gamma1,wk(iv2),2) call vcopy (n,wk(indv1(0)),wk(indv2(0))) zdot = vnorm1**2 znext = vnorm1 c c------------------------begin iteration loop------------------------ c c determine whether or not to stop -- c 10 call inithv (1) zdhav = .true. nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c c c ... compute q(n+1), etc -- the direction vectors call suba (coef,jcoef,wfac,jwfac,n,wk(indv1(in)),wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) an = vdot (n,wk(indv2(in)),wk(iv2)) if (in .ne. 0) go to 110 call vtriad (n,wk(indv2(in+1)),wk(iv2),-an,wk(indv2(in)),1) wk(indbe2(in)) = -an go to 111 110 call vtriad (n,wk(indv2(in+1)),xxx,-vnorm1,wk(indv2(in-1)),2) call vtriad (n,wk(indv2(in+1)),wk(indv2(in+1)),1.0d0,wk(iv2),1) call vtriad (n,wk(indv2(in+1)),wk(indv2(in+1)),-an,wk(indv2(in)), a 1) wk(indbe2(in)) = -an wk(indbe2(in-1)) = -vnorm1 111 vn2old = vnorm2 vnorm2 = sqrt(vdot (n,wk(indv2(in+1)),wk(indv2(in+1)))) if (abs(vnorm2) .lt. srelpr) go to 997 gamma2 = 1.0d0/vnorm2 call vtriad (n,wk(indv2(in+1)),xxx,gamma2,wk(indv2(in+1)),2) c call subqlt (coef,jcoef,wfac,jwfac,n,wk(indv2(in)),wk(iv1)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) if (in .ne. 0) go to 810 call vtriad (n,wk(indv1(in+1)),wk(iv2),-an,wk(indv1(in)),1) wk(indbe1(in)) = -an go to 811 810 call vtriad (n,wk(indv1(in+1)),xxx,-vn2old,wk(indv1(in-1)),2) call vtriad (n,wk(indv1(in+1)),wk(indv1(in+1)),1.0d0,wk(iv2),1) call vtriad (n,wk(indv1(in+1)),wk(indv1(in+1)),-an,wk(indv1(in)), a 1) wk(indbe1(in)) = -an wk(indbe1(in-1)) = -vn2old 811 vnorm1 = sqrt(vdot (n,wk(indv1(in+1)),wk(indv1(in+1)))) if (abs(vnorm1) .lt. srelpr) go to 997 gamma1 = 1.0d0/vnorm1 call vtriad (n,wk(indv1(in+1)),xxx,gamma1,wk(indv1(in+1)),2) c c ... now update the factorization ibgn = max (0,in+1-os) do 1 i = ibgn,in 1 wk(indu(i+1)) = -wk(indbe2(i)) if (ibgn .gt. 0) wk(indu(ibgn))= 0.0d0 wk(indu(in+2)) = vnorm2 call qrupd (in+2,os+2,os+1,wk(icos),wk(isin),wk(indu(in+1)),x, a wk(iu),vnorm2,ier) if (ier .lt. 0) go to 998 c c ... now generate the new w vector. uc = wk(indu(in+1)) if (abs(uc) .lt. srelpr) go to 998 call vcopy (n,wk(indv1(in)),wk(iv1)) ibgn = max (1,in-os+1) iend = in if (iend .lt. ibgn) go to 200 do 201 i = ibgn,iend 201 call vtriad (n,wk(iv1),wk(iv1),-wk(indu(i)),wk(indw(i-1)),1) 200 continue call vtriad (n,wk(indw(in)),xxx,1.0d0/uc,wk(iv1),2) c c ... update iterates u(n). z = wk(indc(in+1))*znext znext = -wk(inds(in+1))*znext call vtriad (n,u,u,z,wk(indw(in)),1) zdot = znext**2 c c proceed to next iteration c in = in + 1 is = is + 1 go to 10 c c-----------------------------finish up---------------------------- c 900 if (halt) go to 715 ier = 1 call ershow (ier,'usqrw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' usymqr converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 995 ier = -16 call ershow (ier,'usqrw') return c 996 call ershow (ier,'usqrw') go to 735 c 997 ier = -13 call ershow (ier,'usqrw') go to 725 c 998 ier = -14 call ershow (ier,'usqrw') go to 725 c 999 ier = -2 call ershow (ier,'usqrw') go to 735 c end subroutine ldirw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the lanczos/orthodir algorithm. see jea and young, in c linear algebra and its applications, vol 52/3, 1983, pp399f. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c indexing functions. c indq(i) = iq + n*mod(i,2) indqt(i) = iqt + n*mod(i,2) c c preliminary calculations. c nwusd = 0 ier = 0 iacel = 14 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 997 iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 if (iqr) go to 995 if (level .ge. 2) write (nout,496) 496 format (' landir') c c initialize the stopping test ... c call inithv (0) zhave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c iq = 1 iqt = iq + 2*n ir = iqt + 2*n iv1 = ir + n iv2 = iv1 + n iv3 = iv2 + n nwusd = max (nwusd,iv3-1+n) c c check the memory usage. c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(ir)) c c begin iteration loop c c determine whether or not to stop. c 10 call inithv (1) nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,wk(ir),xxx, a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c if (in .ne. 0) go to 110 c c perform first-iterate calculations c call vcopy (n,wk(ir),wk(indq(in))) call vcopy (n,wk(indq(in)),wk(indqt(in))) qaq= 0.0d0 go to 115 c c proceed to calculate the direction vectors, for in .gt. 0. c 110 call subqlt (coef,jcoef,wfac,jwfac,n,wk(indqt(in-1)),wk(iv1)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv3)) aqaq = vdot(n,wk(iv2),wk(iv3)) an = aqaq / qaq if (in .ne. 1) go to 150 call vtriad (n,wk(indq(in)),wk(iv2),-an,wk(indq(in-1)),1) call vtriad (n,wk(indqt(in)),wk(iv3),-an,wk(indqt(in-1)),1) go to 115 150 bn = qaq / qaqold call vtriad (n,wk(indq(in)),wk(iv2),-bn,wk(indq(in-2)),1) call vtriad (n,wk(indq(in)),wk(indq(in)),-an,wk(indq(in-1)),1) call vtriad (n,wk(indqt(in)),wk(iv3),-bn,wk(indqt(in-2)),1) call vtriad (n,wk(indqt(in)),wk(indqt(in)),-an,wk(indqt(in-1)),1) c c proceed to form the iterate. c 115 call suba (coef,jcoef,wfac,jwfac,n,wk(indq(in)),wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) qaqold = qaq qaq = vdot(n,wk(indqt(in)),wk(iv2)) if (abs(qaq) .lt. srelpr) go to 998 qr = vdot(n,wk(indqt(in)),wk(ir)) vlamda = qr / qaq call vtriad (n,u,u,vlamda,wk(indq(in)),1) call vtriad (n,wk(ir),wk(ir),-vlamda,wk(iv2),1) c c proceed to next iteration c in = in + 1 is = is + 1 go to 10 c c-----------------------------finish up----------------------------- c 900 if (halt) go to 715 ier = 1 call ershow (ier,'ldirw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' lanczos/orthodir converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 995 ier = -16 call ershow (ier,'ldirw') return c 997 call ershow (ier,'ldirw') go to 735 c 998 ier = -15 call ershow (ier,'ldirw') go to 725 c 999 ier = -2 call ershow (ier,'ldirw') go to 735 c end subroutine lminw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the lanczos/orthomin algorithm. c here, zhat and phat will refer to the "dummy" system of the c lanczos method. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) integer vect1, vect2, os external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c nwusd = 0 ier = 0 iacel = 15 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 997 if (level .ge. 2) write (nout,496) 496 format (' lanmin') c c initialize the stopping test ... c iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 call inithv (0) zhave = .true. zthave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c c allocate memory -- overlap wherever possible ... ip = 1 ipt = ip + n if (.not. iqr) ipt = ip iphat = ipt + n iz = iphat + n izt = iz + n if (.not. iqr) izt = iz izhat = izt + n iv1 = izhat + n iv2 = iv1 + n if (iqlr .eq. 0) nwusd = max (nwusd,iv1-1+n) if (iqlr .ne. 0) nwusd = max (nwusd,iv2-1+n) c c check the memory usage. c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 if (.not. iql) go to 121 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iz)) go to 122 121 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iz)) call vexopy (n,wk(iz),rhs,wk(iz),2) 122 if (iqr) call subqr (coef,jcoef,wfac,jwfac,n,wk(iz),wk(izt)) c c============================begin iteration loop====================== c c determine whether or not to stop. c 10 call inithv (1) nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,wk(iz),wk(izt), a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c if (in .ne. 0) go to 110 c c perform first-iterate calculations c call vcopy (n,wk(iz),wk(izhat)) rd = vdot (n,wk(iz),wk(izhat)) call vcopy (n,wk(iz),wk(ip)) call vcopy (n,wk(izhat),wk(iphat)) if (iqr) call vcopy (n,wk(izt),wk(ipt)) go to 111 c c perform subsequent-iterate calculations c 110 rdold = rd c if (abs(rdold) .lt. srelpr) go to 996 if (abs(rdold) .eq. 0.0d0) go to 996 c c form the old zhat ... go to (131,132,133,134), iqlr + 1 131 call subat (coef,jcoef,wfac,jwfac,n,wk(iphat),wk(iv1)) go to 135 132 call subqlt (coef,jcoef,wfac,jwfac,n,wk(iphat),wk(iv2)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv2),wk(iv1)) go to 135 133 call subat (coef,jcoef,wfac,jwfac,n,wk(iphat),wk(iv2)) call subqrt (coef,jcoef,wfac,jwfac,n,wk(iv2),wk(iv1)) go to 135 134 call subqlt (coef,jcoef,wfac,jwfac,n,wk(iphat),wk(iv1)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) call subqrt (coef,jcoef,wfac,jwfac,n,wk(iv2),wk(iv1)) 135 call vtriad (n,wk(izhat),wk(izhat),-vlamda,wk(iv1),1) c c form the direction vectors ... rd = vdot (n,wk(iz),wk(izhat)) an = rd/rdold call vtriad (n,wk(ip),wk(iz),an,wk(ip),1) call vtriad (n,wk(iphat),wk(izhat),an,wk(iphat),1) if (iqr) call vtriad (n,wk(ipt),wk(izt),an,wk(ipt),1) c c============================form the iterate======================== c 111 if (iql) go to 141 call suba (coef,jcoef,wfac,jwfac,n,wk(ipt),wk(iv1)) go to 142 141 call suba (coef,jcoef,wfac,jwfac,n,wk(ipt),wk(iv2)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv2),wk(iv1)) 142 pap = vdot (n,wk(iphat),wk(iv1)) c if (abs(pap) .lt. srelpr**2) go to 998 if (abs(pap) .eq. 0.0d0) go to 998 vlamda = rd/pap c c call vtriad (n,u,u,vlamda,wk(ipt),1) call vtriad (n,wk(iz),wk(iz),-vlamda,wk(iv1),1) if (.not. iqr) go to 151 call subqr (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iv2)) call vtriad (n,wk(izt),wk(izt),-vlamda,wk(iv2),1) c c proceed to next iteration c 151 in = in + 1 is = is + 1 go to 10 c c------------------------------finish up----------------------------- c 900 if (halt) go to 715 ier = 1 call ershow (ier,'lminw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' lanczos/orthomin converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 996 ier = -13 call ershow (ier,'lminw') go to 725 c 997 call ershow (ier,'lminw') go to 735 c 998 ier = -15 call ershow (ier,'lminw') go to 725 c 999 ier = -2 call ershow (ier,'lminw') go to 735 c end subroutine lresw (suba,subat,subql,subqlt,subqr,subqrt, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the lanczos/orthores algorithm. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c c indexing functions. c indu(i) = iu + n*mod(i,nv) indr(i) = ir + n*mod(i,nv) indrt(i) = irt + n*mod(i,nv) c c preliminary calculations. c nwusd = 0 ier = 0 iacel = 16 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 997 iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 if (iqr) go to 995 if (level .ge. 2) write (nout,496) 496 format (' lanres') c c initialize the stopping test ... c call inithv (0) zhave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c nv = 2 iu = 1 ir = iu + nv*n irt = ir + nv*n iv1 = irt + nv*n nwusd = max (nwusd,iv1-1+n) c c check the memory usage. c if (nwusd .gt. nw) go to 999 c c note -- we will use the vector 'u' for scratch storage, to save space. c call vcopy (n,u,wk(indu(0))) in = 0 is = 0 call suba (coef,jcoef,wfac,jwfac,n,wk(indu(in)),wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(indr(in))) call vcopy (n,wk(indr(in)),wk(indrt(in))) c c--------------------------begin iteration loop----------------------- c c determine whether or not to stop. c 10 call inithv (1) nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,wk(indu(in)),ubar,rhs,xxx,wk(indr(in)),xxx, a wk(iv1),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv1-1) if (level .ge. 2) call iterm (n,wk(indu(in))) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c c proceed to calculate the parameters. c first, gamma. c rd = vdot (n,wk(indr(in)),wk(indrt(in))) call suba (coef,jcoef,wfac,jwfac,n,wk(indr(in)),wk(iv1)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),u) rar = vdot (n,u,wk(indrt(in))) if (abs(rar) .lt. srelpr) go to 998 gam = rd / rar c c now, rho. c if (in .ne. 0) go to 118 rho = 1.0d0 go to 119 118 if (abs(gamold) .lt. srelpr) go to 998 if (abs(rdold) .lt. srelpr) go to 998 if (abs(rho) .lt. srelpr) go to 998 rhoinv = 1.0d0 - (gam/gamold)*(rd/rdold)/rho if (abs(rhoinv) .lt. srelpr) go to 998 rho = 1.0d0 / rhoinv c c now work on updating u, r, rt. c first, the first iteration. c 119 if (in .ne. 0) go to 150 call vtriad (n,wk(indu(in+1)),wk(indu(in)),gam,wk(indr(in)),1) call vtriad (n,wk(indu(in+1)),xxx,rho,wk(indu(in+1)),2) call vtriad (n,wk(indr(in+1)),wk(indr(in)),-gam,u,1) call vtriad (n,wk(indr(in+1)),xxx,rho,wk(indr(in+1)),2) call subqlt (coef,jcoef,wfac,jwfac,n,wk(indrt(in)),wk(iv1)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv1),u) call vtriad (n,wk(indrt(in+1)),wk(indrt(in)),-gam,u,1) call vtriad (n,wk(indrt(in+1)),xxx,rho,wk(indrt(in+1)),2) go to 151 c c now work on subsequent iterations. c 150 call vtriad (n,wk(indu(in+1)),xxx,1.0d0-rho,wk(indu(in-1)),2) call vtriad (n,wk(indu(in+1)),wk(indu(in+1)),rho,wk(indu(in)),1) call vtriad (n,wk(indu(in+1)),wk(indu(in+1)),rho*gam, a wk(indr(in)),1) call vtriad (n,wk(indr(in+1)),xxx,1.0d0-rho,wk(indr(in-1)),2) call vtriad (n,wk(indr(in+1)),wk(indr(in+1)),rho,wk(indr(in)),1) call vtriad (n,wk(indr(in+1)),wk(indr(in+1)),-rho*gam,u,1) call subqlt (coef,jcoef,wfac,jwfac,n,wk(indrt(in)),wk(iv1)) call subat (coef,jcoef,wfac,jwfac,n,wk(iv1),u) call vtriad (n,wk(indrt(in+1)),xxx,1.0d0-rho,wk(indrt(in-1)), a 2) call vtriad (n,wk(indrt(in+1)),wk(indrt(in+1)),rho,wk(indrt(in)), a 1) call vtriad (n,wk(indrt(in+1)),wk(indrt(in+1)),-rho*gam,u,1) c c proceed to next iteration c 151 gamold = gam rdold = rd in = in + 1 is = is + 1 go to 10 c c-------------------------------finish up---------------------------- c 900 call vcopy (n,wk(indu(in)),u) if (halt) go to 715 ier = 1 call ershow (ier,'lresw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' lanczos/orthores converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 995 ier = -16 call ershow (ier,'lresw') return c 997 call ershow (ier,'lresw') go to 735 c 998 ier = -15 call ershow (ier,'lresw') go to 725 c 999 ier = -2 call ershow (ier,'lresw') go to 735 c end subroutine bcgsw (suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) implicit double precision (a-h, o-z) c c code to run the biconjugate-gradient-squared algorithm. c the algorithm is taken from "preconditioned biconjugate gradient c methods for numerical reservoir simulation", by p. joly and r. c eymard, to appear in journal of computational physics. the original c reference is p. sonneveld, "cgs, a fast lanczos-type solver for c unsymmetric linear systems," report 84-16, delft university of c technology, dept. of mathematics and informatics. c dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), a wfac(1), jwfac(1) external suba, subql, subqr dimension iparm(30), rparm(30) logical iql, iqr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c nwusd = 0 ier = 0 iacel = 15 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier .lt. 0) go to 997 if (level .ge. 2) write (nout,496) 496 format (' bcgs') iql = iqlr .eq. 1 .or. iqlr .eq. 3 iqr = iqlr .eq. 2 .or. iqlr .eq. 3 if (iqr) go to 995 c c initialize the stopping test ... c call inithv (0) zhave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,xxx,xxx, a wk,nwpstp,ier) nwusd = max (nwusd,nwpstp) if (ier .lt. 0) go to 730 c c allocate memory -- overlap wherever possible ... ir0 = 1 ip = ir0 + n ipt = ip + n if (.not. iqr) ipt = ip iq = ipt + n iz = iq + n izt = iz + n if (.not. iqr) izt = iz iv1 = izt + n iv2 = iv1 + n iv3 = iv2 + n nwusd = max (nwusd,iv3-1+n) ipaaq = iv1 ippaaq = iv2 c c check the memory usage. c if (nwusd .gt. nw) go to 999 c in = 0 is = 0 if (.not. iql) go to 121 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iv1)) call vexopy (n,wk(iv1),rhs,wk(iv1),2) call subql (coef,jcoef,wfac,jwfac,n,wk(iv1),wk(iz)) go to 122 121 call suba (coef,jcoef,wfac,jwfac,n,u,wk(iz)) call vexopy (n,wk(iz),rhs,wk(iz),2) 122 if (iqr) call subqr (coef,jcoef,wfac,jwfac,n,wk(iz),wk(izt)) c c=======================begin iteration loop======================= c c determine whether or not to stop. c 10 call inithv (1) nwpstp = nw - (iv2-1) call pstop (1,suba,subql,subqr,coef,jcoef, a wfac,jwfac,n,u,ubar,rhs,xxx,wk(iz),wk(izt), a wk(iv2),nwpstp,ier) nwusd = max (nwusd,nwpstp+iv2-1) if (level .ge. 2) call iterm (n,u) if (halt .or. in .ge. itmax .or. ier .lt. 0) go to 900 c if (in .ne. 0) go to 110 c c perform first-iterate calculations c call vcopy (n,wk(iz),wk(ir0)) call vcopy (n,wk(iz),wk(ip)) call vcopy (n,wk(iz),wk(iq)) r0r = vdot (n,wk(iz),wk(ir0)) go to 111 c c perform subsequent-iterate calculations c 110 r0rold = r0r r0r = vdot (n,wk(ir0),wk(iz)) if (abs(r0rold) .lt. srelpr**2) go to 996 beta = r0r/r0rold c c form direction vectors ... c call vtriad (n,wk(ip),wk(iz),beta,wk(ipaaq),1) call vtriad (n,wk(iv2),wk(ipaaq),beta,wk(iq),1) call vtriad (n,wk(iq),wk(ip),beta,wk(iv2),1) c c==========================form the iterate========================== c c at this point we have the vectors p and q and the new dot(r,r0) ... c now form aq ... c 111 iaq = iv1 if (.not.iql) then call suba (coef,jcoef,wfac,jwfac,n,wk(iq),wk(iaq)) else call suba (coef,jcoef,wfac,jwfac,n,wk(iq),wk(iv2)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv2),wk(iaq)) end if c dot(r0,aq) ... r0aq = vdot (n,wk(ir0),wk(iaq)) if (abs(r0aq) .lt. srelpr**2) go to 998 alpha = r0r / r0aq c p-alpha*aq, p+p-alpha*aq ... call vtriad (n,wk(ipaaq), wk(ip),-alpha,wk(iaq),1) call vexopy (n,wk(ippaaq),wk(ip),wk(ipaaq),1) c c---get u--- call vtriad (n,u,u,alpha,wk(ippaaq),1) c c---get resid--- if (.not.iql) then call suba (coef,jcoef,wfac,jwfac,n,wk(ippaaq),wk(iv3)) call vtriad (n,wk(iz),wk(iz),-alpha,wk(iv3),1) else call suba (coef,jcoef,wfac,jwfac,n,wk(ippaaq),wk(iv3)) call subql (coef,jcoef,wfac,jwfac,n,wk(iv3),wk(iv2)) call vtriad (n,wk(iz),wk(iz),-alpha,wk(iv2),1) end if c c proceed to next iteration c in = in + 1 is = is + 1 go to 10 c c----------------------------------finish up---------------------------------- c 900 if (halt) go to 715 ier = 1 call ershow (ier,'bcgsw') zeta = stptst go to 725 715 continue if (level .ge. 1) write (nout,720) in 720 format (/' bcgs converged in ',i5,' iterations.') c 725 continue if (idgts .lt. 0) go to 730 call perror1 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1, a digit2,idgts) 730 t2 = timer (dummy) timit = t2 - t1 iparm(2) = in rparm(1) = zeta rparm(2) = emax rparm(3) = emin rparm(6) = timit rparm(7) = digit1 rparm(8) = digit2 735 continue if (level .ge. 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return c c error returns c 995 ier = -16 call ershow (ier,'bcgsw') go to 725 c 996 ier = -13 call ershow (ier,'bcgsw') go to 725 c 997 call ershow (ier,'bcgsw') go to 735 c 998 ier = -15 call ershow (ier,'bcgsw') go to 725 c 999 ier = -2 call ershow (ier,'bcgsw') go to 735 c end subroutine nullpl (coef,jcoef,wk,iwk,n,subql,suba,subqr,u,v) implicit double precision (a-h, o-z) c c routine to just apply the left preconditioner ... c dimension u(1), v(1), coef(1), jcoef(2), wk(1), iwk(1) external subql, suba, subqr c call subql (coef,jcoef,wk,iwk,n,u,v) return end subroutine nullpr (coef,jcoef,wk,iwk,n,subql,suba,subqr,u,v) implicit double precision (a-h, o-z) c c routine to just apply the right preconditioner ... c dimension u(1), v(1), coef(1), jcoef(2), wk(1), iwk(1) external subql, suba, subqr c call subqr (coef,jcoef,wk,iwk,n,u,v) return end subroutine cgcrpr (coef,jcoef,wk,iwk,n,subql,suba,subqr,u,v) implicit double precision (a-h, o-z) c c right preconditioner routine to use with cgcr method. c dimension u(1), v(1), coef(1), jcoef(2), wk(1), iwk(1) c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d c common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / ccgcr / nblk, nband, ictac, ieta, ivcgcr c external subql, suba, subqr c c could bypass next line if subqr is just a copy ... call subqr (coef,jcoef,wk,iwk,n,u,v) call suba (coef,jcoef,wk,iwk,n,v,wk(ivcgcr)) call tmult (n,nblk,nband,wk(ictac),wk(ieta),wk(ivcgcr), a wk(ivcgcr)) call vexopy (n,v,v,wk(ivcgcr),2) c return end subroutine getblk (coef,jcoef,n,nblk,nband,ctac,nw,ier) implicit double precision (a-h, o-z) c c this utility routine for the cgcr algorithm computes the matrix c (c**t)*a*c and factors it. here, each column of c is zero c everywhere except it is all 1's on one of its blocks. c dimension ctac(nblk,1), coef(1), jcoef(2) logical symm c common / itcom4 / srelpr, keyzer, keygs common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz ,lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv c c ... data common blocks c common / dscons / ndim, mdim, maxnz c c nband = 0 c c*************************** find the bandwidth ********************** c c idmin = 0 idmax = 0 do 10 i=1,maxnz idiag = jcoef(i) idmin = min (idmin,idiag) 10 idmax = max (idmax,idiag) if (nstore .eq. 2) idmin = - idmax ihalf = max (-idmin,idmax) nbsiz = n / nblk nhband = (ihalf+nbsiz-1)/nbsiz nband = 1 + 2*nhband c c******************************************************************* c c now form the matrix. basically what we need to do here is to c add up all the elements in each block of the a-matrix. c if (nblk*nband .gt. nw) go to 999 nw = nblk*nband c call vfill (nblk*nband,ctac,0.0d0) c c loop over the diagonals ... do 1 i=1,maxnz idiag = jcoef(i) ibeg = max (1,1-idiag) iend = min (n,n-idiag) ibbeg = 1 + (ibeg-1)/nbsiz ibend = 1 + (iend-1)/nbsiz ibase = (i-1)*ndim c symm = nstore .eq. 2 .and. idiag .ne. 0 idm1 = idiag - 1 iomid = -idm1 nmid = n - idiag nhbp1 = nhband + 1 c loop over the rows of ctac ... do 2 j=ibbeg,ibend ibeg = max (1+(j-1)*nbsiz,iomid) iend = min(j*nbsiz,nmid) c ic1 = (ibeg+idiag-1)/nbsiz + 1 c ic2 = (iend+idiag-1)/nbsiz + 1 c id1 = ic1 - j + nhband + 1 c id2 = ic2 - j + nhband + 1 itemp1 = (ibeg+idm1)/nbsiz itemp2 = (iend+idm1)/nbsiz id1 = itemp1 + 2 - j + nhband id2 = itemp2 + 2 - j + nhband j1s = j + id1 - nhbp1 j2s = j + id2 - nhbp1 id1s = nband - id1 + 1 id2s = nband - id2 + 1 if (id1 .ne. id2) go to 3 c ctac(j,id1) = ctac(j,id1) c a + vadd(iend-ibeg+1,coef(ibase+ibeg)) do 41 ii=ibeg,iend if (symm) ctac(j1s,id1s) = ctac(j1s,id1s) + coef(ibase+ii) 41 ctac(j,id1) = ctac(j,id1) + coef(ibase+ii) go to 2 c3 imid = 1 + (ic2-1)*nbsiz - idiag 3 imid = iomid + itemp2*nbsiz c ctac(j,id1) = ctac(j,id1) c a + vadd(imid-ibeg ,coef(ibase+ibeg)) do 42 ii=ibeg,imid-1 if (symm) ctac(j1s,id1s) = ctac(j1s,id1s) + coef(ibase+ii) 42 ctac(j,id1) = ctac(j,id1) + coef(ibase+ii) c ctac(j,id2) = ctac(j,id2) c a + vadd(iend-imid+1,coef(ibase+imid)) do 43 ii=imid,iend if (symm) ctac(j2s,id2s) = ctac(j2s,id2s) + coef(ibase+ii) 43 ctac(j,id2) = ctac(j,id2) + coef(ibase+ii) c 2 continue c 1 continue c c**************************** do lu factorization ******************** c do 31 i=1,nblk-1 denom = ctac(i,nhbp1) if (abs(denom) .lt. srelpr) go to 998 xpivot = 1.0d0 / denom nsubmt = min(nhband,nblk-i) do 30 j=1,nsubmt ipj = i + j ind2 = nhbp1 - j do 30 k=1,nsubmt c30 ctac(i+j,nhband-j+1+k) = ctac(i+j,nhband-j+1+k) c a - xpivot*ctac(i+j,nhband-j+1)*ctac(i,nhband+1+k) ind = nhbp1 - j + k 30 ctac(ipj,ind) = ctac(ipj,ind) a - xpivot*ctac(ipj,ind2)*ctac(i,nhbp1+k) do 32 j=1,nsubmt ipj = i + j ind1 = nhbp1 - j ind2 = nhbp1 + j c ctac(i+j,nhband+1-j) = ctac(i+j,nhband+1-j)*xpivot c32 ctac(i ,nhband+1+j) = ctac(i ,nhband+1+j)*xpivot ctac(ipj,ind1) = ctac(ipj,ind1)*xpivot 32 ctac(i ,ind2) = ctac(i ,ind2)*xpivot 31 continue return c c c error returns c c breakdown ... 998 ier = -6 call ershow (ier,'getblk') return c c insuff. memory ... 999 ier = -2 call ershow (ier,'getblk') nw = nblk*nband return end subroutine tmult (n,nblk,nband,ctac,eta,u,v) implicit double precision (a-h, o-z) c c this utility routine for the cgcr algorithm computes the product of c the t-matrix with a vector. here, t = c*((c**t)*a*c)**(-1) * c**t, c a projection. c dimension ctac(nblk,nband), eta(1), u(1), v(1) c nbsiz = n / nblk nhband = (nband-1)/2 nhbp1 = nhband + 1 c c form the eta vector - aggregation step. c do 1 i=0,nblk-1 c1 eta(i) = vadd (nbsiz,u(1+i*nbsiz)) ip1 = i + 1 eta(ip1) = 0.0d0 do 1 j=1,nbsiz 1 eta(ip1) = eta(ip1) + u(i*nbsiz+j) c c perform the forward solve. c if (nhband .eq. 0) go to 40 do 2 irow=2,nblk ibeg = max (1,irow-nhband) iend = irow - 1 ind = nhbp1 - irow do 3 icol = ibeg,iend 3 eta(irow) = eta(irow) - eta(icol)*ctac(irow,ind+icol) 2 continue c c perform the diagonal solve. c 40 do 4 i=1,nblk 4 eta(i) = eta(i) / ctac(i,nhbp1) c c perform the back solve. c if (nhband .eq. 0) go to 41 do 5 i=1,nblk-1 irow = nblk - i ibeg = irow + 1 iend = min (irow+nhband,nblk) ind = nhbp1 - irow do 6 icol = ibeg,iend 6 eta(irow) = eta(irow) - eta(icol)*ctac(irow,ind+icol) 5 continue c c form the vector t*u - disaggregation step. c 41 do 7 i=0,nblk-1 val = eta(i+1) c7 call vfill (nbsiz,v(1+i*nbsiz),eta(i+1)) do 7 j=1,nbsiz 7 v(i*nbsiz+j) = val c return end double precision function vadd (n,v) implicit double precision (a-h, o-z) c c adds up all elements of a vector c dimension v(1) c sum = 0.0d0 do i=1,n sum = sum + v(i) enddo vadd = sum return end subroutine hesest (hess,nhess,nd,esize,imode,havest, a emax,emin,wk,nw,ier) implicit double precision (a-h, o-z) c c routine to calculate the moduli of the extremal eigenvalues of a c banded hessenberg matrix. c c hess - the hessenberg matrix, stored by diagonals c nhess, nd - dimensions of array hess c esize - indicator of how many rows/cols of hess have been c filled out so far c imode - style of eigenvalue estimation: c abs(imode) - use this size of principal submatrix to do estimate c sign(imode) - use either leading or trailing principal submatrix c c dimension hess(nhess,nd), wk(1) logical havest integer esize c havest = .false. if (imode .gt. 0 .and. esize .gt. imode) return c c memory allocation c ndim = min(esize,iabs(imode)) if (ndim .le. 0) return imat = 1 ireal = imat + ndim*ndim iimag = ireal + ndim c nwusd = iimag - 1 + ndim if (nwusd .gt. nw) go to 999 nw = nwusd c c make the hess matrix into a full matrix c if (imode .lt. 0) go to 1 ibeg = 1 iend = esize go to 2 1 ibeg = max (1,esize-iabs(imode)+1) iend = esize 2 call vfill (ndim*ndim,wk(imat),0.0d0) do 3 i=ibeg,iend jbeg = max (ibeg,i-1) jend = min (ibeg-1+ndim,i+nd-2) do 3 j=jbeg,jend 3 wk(imat+(i-ibeg)+(j-ibeg)*ndim) = hess(i,j-i+2) c c call to eispack to calculate eigenvalues c ierr = 0 call hqr (ndim,ndim,1,ndim,wk(imat),wk(ireal),wk(iimag),ierr) if (ierr .ne. 0) go to 998 c c find eigenvalues with largest and smallest modulus c emax = wk(ireal)**2 + wk(iimag)**2 emin = emax if (ndim .eq. 1) go to 5 do 6 i=2,ndim vmod = wk(ireal-1+i)**2 + wk(iimag-1+i)**2 emax = max (emax,vmod) 6 emin = min (emin,vmod) c 5 emax = sqrt (emax) emin = sqrt (emin) havest = .true. return c c c error returns ... c c error in call to eispack 998 ier = -18 call ershow (ier,'hesest') return c c insuff. floating point workspace 999 ier = -2 nw = nwusd call ershow (ier,'hesest') return end subroutine pvec (n,nv,iv,s,s1,idotw,it,il,ir,vect, a dots,ndc,betas,gamma,gamize,svec,wk,ier) implicit double precision (a-h, o-z) c c this routine performs generalized gram-schmidt on a collection c of vectors. c it is used to update the table of direction vectors for c generalized conjugate gradient methods per-iteration. c note that this routine was intended to be rather general, c including block conjugate gradient methods. c c params -- c n - size of the vectors c nv - the size of the p-vector table. c ie., the table contains p(it-1), p(it-2),...,p(it-nv). c iv - number of p-vector-like objects we are dragging along. c eg., if iv=3, then we may be computing p, ap and q(inv)ap. c s - the block size for block conjugate gradient methods. c s1 - indicates how many of the old p-vectors are to be used to c orthogonalize the new p-vector. c idotw - indicates the bandwidth of the matrix used to calculate c the betas. c generally equals s1, but if the h-matrix is symmetric c then = 1. c it - iteration number. this routine calculates p(it). c il,ir - integers between 1 and iv. indicate whether p, ap or c q(inv)ap c is to be used to calculate the inner product for c orthogonality. c vect - the p-vector table. c dots - workspace for the dot products. c ndc - the number of dot products that have already been c computed by formit. c betas - workspace for the betas. c gamma - an s by s matrix containing the coefficients from applying c gram schmidt to p(it). c gamize - flag to indicate whether gram schmidt is to be applied c after p(it) is calculated. c svec - input packet of vectors to the p-vector calculation c process. c wk - workspace. must be of size s. c ier - error code c c array structure and indexing functions -- c c vect(n,s,nv,iv) jv c svec(n,s,iv) isv c dots(s,s,idotw,s1) id c betas(s,s,s1) ib c gamma(s,s) - c integer s1, s, idotw dimension vect(1), svec(1) dimension dots(1), betas(1) dimension gamma(s,s) dimension wk(1) logical gamize common / itcom4 / srelpr, keyzer, keygs c c define the necessary indexing functions. c jv(i,j,k,l) = 1 + (i-1) + n*((j-1) + s*(mod(k,nv) + nv*(l-1))) isv(i,j,k) = 1 + (i-1) + n*((j-1) + s*(k-1)) id(i,j,k,l) = 1 + (i-1) + s*((j-1) + s*((k-l) + idotw*mod(k,s1))) ib(i,j,k) = 1 + (i-1) + s*((j-1) + s*mod(k,s1)) c ier = 0 c c ... handle first iteration. c if (it .eq. 0 .or. s1 .le. 0) go to 1000 c c ... now handle general iteration. c c ... first, calculate dot products (p(it-1),p(i)). c ibgn = max (it-idotw,0) iend = it - 1 - ndc if (ibgn .gt. iend) go to 10 do 2 i = ibgn,iend do 2 j = 1,s do 2 k = 1,s 2 dots(id(j,k,it-1,i)) = vdot (n,vect(jv(1,j,it-1,il)), a vect(jv(1,k,i,ir))) c c ... next, form all the new betas. c 10 ibgn = max (it-s1,0) iend = it - 1 do 3 i = ibgn,iend do 34 l = 1,s do 35 k = 1,s wk(k) = -vdot (n,vect(jv(1,k,i,il)),svec(isv(1,l,ir))) jbgn = max (i-idotw+1,it-s1,0) jend = i - 1 if (jend .lt. jbgn) go to 35 do 4 j = jbgn,jend do 4 m = 1,s 4 wk(k) = wk(k) - dots(id(k,m,i,j))*betas(ib(m,l,j)) 35 continue call vcopy (s*s,dots(id(1,1,i,i)),gamma) call gauss (s,s,gamma,wk(1),betas(ib(1,l,i)),ier) if (ier .ne. 0) go to 999 34 continue 3 continue c c ... now, get new p vectors. c do 37 m = 1,iv do 37 i = ibgn,iend do 37 l = 1,s do 6 k = 1,s 6 call vtriad (n,svec(isv(1,l,m)),svec(isv(1,l,m)), a betas(ib(k,l,i)),vect(jv(1,k,i,m)),1) 37 continue c c ... copy new vectors into the table. c 1000 do 168 m = 1,iv 168 call vcopy (n*s,svec(isv(1,1,m)),vect(jv(1,1,it,m))) c c ... now calculate gamma and orthogonalize the new block of p-vectors c call vfill (s*s,gamma,0.0d0) do 881 i = 1,s 881 gamma(i,i) = 1.0d0 if (.not. gamize) return do 879 i = 1,s if (i .eq. 1) go to 882 do 883 j = 1,i-1 883 wk(j) = vdot (n,vect(jv(1,1,j,it)),vect(jv(1,1,i,it))) do 884 j = 1,i-1 do 885 m = 1,iv 885 call vtriad (n,vect(jv(1,i,it,m)),vect(jv(1,i,it,m)), a -wk(j),vect(jv(1,j,it,m)),1) do 886 k = j,i-1 886 gamma(j,i) = gamma(j,i) - gamma(j,k)*wk(k) 884 continue 882 vnorm = sqrt(vdot(n,vect(jv(1,i,it,1)),vect(jv(1,i,it,1)))) if (abs(vnorm) .lt. srelpr**2) go to 999 do 888 m = 1,iv 888 call vtriad (n,vect(jv(1,i,it,m)),xxx,1.0d0/vnorm, a vect(jv(1,i,it,m)),2) do 887 j = 1,i 887 gamma(j,i) = gamma(j,i)/vnorm 879 continue return c c ... error return. c 999 ier = -100 return end subroutine gauss (ndim,n,a,rhs,u,ier) implicit double precision (a-h, o-z) c c gaussian elimination routine. c dimension a(ndim,ndim), rhs(ndim), u(ndim) common / itcom4 / srelpr, keyzer, keygs ier = 0 if (n .eq. 1) go to 190 do 1 i = 1,n-1 if (abs(a(i,i)) .lt. srelpr**2) go to 999 do 10 j = i+1,n fact = a(j,i)/a(i,i) a(j,i) = 0.0d0 do 2 k = i+1,n 2 a(j,k) = a(j,k) - fact*a(i,k) rhs(j) = rhs(j) - fact*rhs(i) 10 continue 1 continue c 190 do 3 i = 1,n k = n - i + 1 if (abs(a(k,k)) .lt. srelpr**2) go to 999 u(k) = rhs(k) if (i .eq. 1) go to 44 do 4 j = k+1,n u(k) = u(k) - u(j)*a(k,j) 4 continue 44 u(k) = u(k)/a(k,k) 3 continue return 999 ier = -100 return end subroutine qrupd (ndim,nnz,nind,c,s,ucnbar,ucn,u,b,ier) implicit double precision (a-h, o-z) c c this routine updates the qr factorization of the banded upper c hessenberg matrix used by various conjugate gradient variants. c c parameters -- c ndim - the current size of the hessenberg matrix c nnz - the actual number of nonzeros in the band of the c hessenberg matrix. obviously, must be .le. than nind. c nind - the bandwidth of the hessenberg matrix, as stored c c,s - arrays which hold the cosines and sines of all the c rotations that have been performed so far c u - the new rightmost column of the hessenberg matrix, c which is to be rotated c b - the element of the hessenberg matrix to be zapped c by the new rotation c ucnbar - the element of the hessenberg matrix that b is to be c ucn - rotated into the new value of ucnbar, after the rotation c dimension c(1), s(1), u(1) c c note -- due to the fortran implementation on the cyber 205, it is c necessary to make ucnbar an array rather than a scalar. c dimension ucnbar(1) c c ... define the usual indexing functions. c indv(i) = 1 + mod(i,nind) indu(i) = 1 + mod(i,nind+1) c c ... indu is used to index u. c if (ndim .le. 1) return c c ... apply all the old rotations to the column. c jbgn = max(1,ndim-nnz+1) jend = ndim - 2 if (jend .lt. jbgn) go to 3 do 2 j = jbgn,jend u1 = c(indv(j))*u(indu(j)) + s(indv(j))*u(indu(j+1)) u2 =-s(indv(j))*u(indu(j)) + c(indv(j))*u(indu(j+1)) u(indu(j)) = u1 u(indu(j+1)) = u2 2 continue 3 continue c c ... now proceed to form the new 2-by-2 rotation matrix. c ucnb = ucnbar(1) denom = sqrt(ucnb*ucnb+b*b) if (abs(ucnb) .ge. 1.0d-40) denom = sign(denom,ucnb) if (abs(denom) .lt. 1.0d-40) go to 999 c(indv(ndim-1)) = ucnb/denom s(indv(ndim-1)) = b/denom c c ... now apply the new rotation. c u1 = c(indv(ndim-1))*u(indu(ndim-1))+s(indv(ndim-1))*u(indu(ndim)) u2 =-s(indv(ndim-1))*u(indu(ndim-1))+c(indv(ndim-1))*u(indu(ndim)) u(indu(ndim-1)) = u1 u(indu(ndim)) = u2 ucn = c(indv(ndim-1))*ucnb + s(indv(ndim-1))*b return 999 ier = -14 return end subroutine pstop (ncall,suba,subql,subqr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,r, a z,zt,wk,nw,ier) implicit double precision (a-h, o-z) c dimension zt(1), z(1), r(1), u(1), ubar(1), rhs(1), wk(1) dimension coef(1), jcoef(2), wfac(1), jwfac(1) external suba, subql, subqr, nullpl, nullpr c call pstopg (ncall,suba,subql,subqr,nullpl,nullpr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,r,z,zt,wk,nw,ier) return end subroutine pstopg (ncall,suba,subql,subqr,precl,precr, a coef,jcoef,wfac,jwfac,n,u,ubar,rhs,r, a z,zt,wk,nw,ier) implicit double precision (a-h, o-z) c c ... pstop computes one of stopping tests to determine if the c iterative method has converged to a solution within the c error tolerance, zeta. the stopping tests are -- c c (1) (emax/emin) * sqrt ( (r ,zt)/(rhs,inv(q)*rhs) ) c (2) ( 1.0/emin) * sqrt ( (zt,zt)/(u,u) ) c (3) (emax/emin) * sqrt ( (zt,zt)/(inv(q)*rhs,inv(q)*rhs) ) c (4) sqrt ( (zt,zt)/(inv(q)*rhs,inv(q)*rhs) ) c (5) sqrt ( (r ,r )/(rhs,rhs) ) c (6) sqrt ( (u-ubar,u-ubar)/(ubar,ubar) ) c (7) (emax/emin) * sqrt ( (r,z)/(rhs,inv(ql)*rhs) ) c (8) ( 1.0/emin) * sqrt ( (z,z)/(u,u) ) c (9) (emax/emin) * sqrt ( (z,z)/(inv(ql)*rhs,inv(ql)*rhs) ) c (10) sqrt ( (z,z)/(inv(ql)*rhs,inv(ql)*rhs) ) c c ... here, emax and emin are estimates of the 2-norm of the iteration c matrix and its inverse. c c key parameters -- c c ncall: = 0 for first call to pstop by accelerator c < 0 for recalc of bnorms, in the case that a new prec has c been calc'ed c > 0 for a routine call to check the stopping test c c iplr : = 0 the left and right preconditioning matrices are the c identity c = 1 the right prec is the identity c = 2 the left prec is the identity c = 3 neither the left nor the right prec matrix is the c identity c c r: the residual of the original system, if rhave = .true. c z : ql**(-1) r, if zhave = .true. c zt : qr**(-1) z, if zthave = .true. c c c this routine is admittedly quite overdesigned. the idea was to have c a general routine which would calculate the needed inner products c with the absolute least amount of work, by determining which inner c products already exist. c dimension zt(1), z(1), r(1), u(1), ubar(1), rhs(1), wk(1) dimension coef(1), jcoef(2), wfac(1), jwfac(1) external suba, subql, subqr, precl, precr c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c logical init, nufact logical ipl, ipr logical risz, riszt, ziszt logical rhav, zhav, zthav, rcalc, zcalc, ztcalc logical udhv, rdhv, rzhv, rzthv, zdhv, zzthv, ztdhv logical udcal, rdcal, rzcal, rztcal, zdcal, zztcal, ztdcal c dimension idlarr(10), idrarr(10), needbn(10) data idlarr /1,3,3,3,1,0,1,2,2,2/ data idrarr /3,3,3,3,1,0,2,2,2,2/ data needbn /1,0,1,1,1,0,1,0,1,1/ c c nwusd = 0 halt = .false. tiny = 500.0d0*srelpr c c get flags to tell us if there is any prec on the left or right ... ipl = iplr .eq. 1 .or. iplr .eq. 3 ipr = iplr .eq. 2 .or. iplr .eq. 3 c find equivalences between r, z, zt ... risz = .not. ipl ziszt = .not. ipr riszt = risz .and. ziszt c decode ntest ... idl = idlarr(ntest) idr = idrarr(ntest) idot = 1 + (idl-1) + (idr-1)*3 c init = ncall .eq. 0 nufact = ncall .lt. 0 if (.not. (init .or. nufact)) go to 900 c c====================================================================== c========================== initialization section ==================== iv1 = 1 iv2 = iv1 + n c c ... compute bnorms, as necessary. c if (needbn(ntest) .eq. 0) go to 750 idle = idl if (idle .eq. 3 .and. ziszt) idle = 2 if (idle .eq. 2 .and. risz) idle = 1 idre = idr if (idre .eq. 3 .and. ziszt) idre = 2 if (idre .eq. 2 .and. risz) idre = 1 idp = 0 idlp = 0 idrp = 0 nwusd = 0 if (nwusd .gt. nw) go to 999 c calc ql(inv)*rhs, if necess ... if (max(idle,idre) .gt. 1 .and. ipl) then nwusd = nwusd + n if (nwusd .gt. nw) go to 999 idp = idp + 1 call precl (coef,jcoef,wfac,jwfac,n,subql,suba,subqr,rhs, a wk(1+n*(idp-1))) if (idle .gt. 1) idlp = idlp + 1 if (idre .gt. 1) idrp = idrp + 1 end if c calc qr(inv)*ql(inv)*rhs, if necess ... if (max(idle,idre) .gt. 2) then nwusd = nwusd + n if (nwusd .gt. nw) go to 999 idp = idp + 1 if (idp .eq. 1) a call precr (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a rhs,wk(1+n*(idp-1))) if (idp .eq. 2) a call precr (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a wk(1+n*(idp-2)),wk(1+n*(idp-1))) if (idle .gt. 2) idlp = idlp + 1 if (idre .gt. 2) idrp = idrp + 1 end if c get needed dot ... if (init .or. (idlp .ne. 0 .or. idrp .ne. 0)) then bnorm1 = seldot(n,1+idlp,rhs,wk(1),wk(1+n),wk(1+2*n), a 1+idrp,rhs,wk(1),wk(1+n),wk(1+2*n)) if (bnorm1 .lt. 0.0d0) go to 998 bnorm1 = max (srelpr,sqrt(bnorm1)) end if if (idlp .eq. 0 .or. idrp .eq. 0) bnorm = bnorm1 c c ... get ubar norm, as necessary ... c 750 if (nufact) go to 900 ubarnm = srelpr if (ntest .eq. 6) ubarnm = sqrt(vdot (n,ubar,ubar)) c c ... end of initialization phase ... c=============================================================================== c=============================================================================== c c ... now begin the actual stopping test section ... c c notes on the strategy of this routine: c basically, what we're after in order to perform the stopping c tests is certain dot products. the needed dot products may already c be available from the accelerator (in variables rrot, etc., as c indicated in flags rdhav, etc.) otherwise, it will be necessary to c compute these from the appropriate vectors. these vectors in turn c may already exist (in variables r, z, zt, as indicated b c rhave, zhave, zthave), or it may be necessary to compute them. c if they are computed by pstop, then the workspace is used to store c them. furthermore, there are dependencies between the vectors: zt c requires z, z requires r. add to this the further complication that c it may be possible to c optimize: if there is no left preconditioner, c then r equals z, and so forth. c this routine attempts to get the necessary data to do the c stopping test in the most optimal way. c a few notes on the semantics of variables. the flag rhave tells c whether the variable named r actually contains the residual; the flag c rhav tells whether the residual exists somewhere - whether in r, z, c zt or workspace. if c nonzero, the variable ir tells where in the c workspace the residual is (if it is in the workspace). now, the c variable rdhav tells whether rdot actually contains the dot product c of r with itself. unlike r and rhave, rdot and rdhav will actually c be updated by pstop if they are calculated herein, or if rdot can be c found from some other dot. c the variable rcalp indicates whether r was somewhere in workspace c after pstop did its work. the accelerator would like to know this, c since it may want to circumvent letting pstop do a vector calculation c if it can do it more efficiently. c for the initialization call (ncall=0), there is a dry run of c the stopping test. that is, the flags rhave, rcalp, rrhave, etc. c are set to what they would be set in an actual call, but no actual c vector calculations are done. this is necessary so that the c accelerator can plan ahead and take action to circumvent pstop doing c lengthly calculations - e.g., calculating the residual using an a c mult when the accelerator could do it simply by doing a saxpy. c c 900 continue c c make temporaries for dot haves (modify the actual dot haves only c if ncall>0) udhv = udhav rdhv = rdhav rzhv = rzhav rzthv = rzthav zdhv = zdhav zzthv = zzthav ztdhv = ztdhav c c evaluate vector haves ... rhav = rhave .or. (zhave.and.risz) .or. (zthave.and.riszt) zhav = zhave .or. (rhave.and.risz) .or. (zthave.and.ziszt) zthav = zthave .or. (rhave.and.riszt) .or. (zhave .and.ziszt) c c take note that there are no vectors in the workspace ... ir = 0 iz = 0 izt = 0 c iwfree = 1 c c ********** calculate r ********** c c find dot needs ... 102 assign 105 to lbldn go to 1100 c calculate whatever dots we can ... 105 assign 110 to lbldc go to 1300 c find vector needs ... 110 assign 115 to lblvn go to 1200 c get r ... 115 if (.not. rcalc) go to 120 ir = iwfree iwfree = iwfree + n nwusd = iwfree-1 if (init .or. nufact) go to 116 if (nwusd .gt. nw) go to 999 call suba (coef,jcoef,wfac,jwfac,n,u,wk(ir)) call vexopy (n,wk(ir),rhs,wk(ir),2) 116 rhav = .true. c revise vector haves ... if (.not. risz) go to 111 iz = ir zhav = .true. 111 if (.not. riszt) go to 120 izt = ir zthav = .true. c c ********** calculate z ********** c c calculate dots ... 120 assign 125 to lbldc go to 1300 c revise vector needs ... 125 assign 126 to lblvn go to 1200 c get z ... 126 if (.not. zcalc) go to 130 iz = iwfree iwfree = iwfree + n nwusd = iwfree-1 if (init .or. nufact) go to 127 if (nwusd .gt. nw) go to 999 if (rhave) call precl (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a r,wk(iz)) if (ir .ne. 0) call precl (coef,jcoef,wfac,jwfac,n,subql,suba, a subqr,wk(ir),wk(iz)) 127 zhav = .true. c revise vector haves ... if (.not. risz) go to 121 ir = iz rhav = .true. 121 if (.not. ziszt) go to 130 izt = iz zthav = .true. c c ********** calculate zt ********** c c calculate dots ... 130 assign 135 to lbldc go to 1300 c revise vector needs .. 135 assign 136 to lblvn go to 1200 c get zt ... 136 if (.not. ztcalc) go to 150 izt = iwfree iwfree = iwfree + n nwusd = iwfree-1 if (init .or. nufact) go to 137 if (nwusd .gt. nw) go to 999 if (zhave) call precr (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a z,wk(izt)) if ((.not. zhave) .and. (rhave .and. risz)) a call precr (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a r,wk(izt)) if (iz .ne. 0) a call precr (coef,jcoef,wfac,jwfac,n,subql,suba,subqr, a wk(iz),wk(izt)) 137 zthav = .true. c revise vector haves ... if (.not. riszt) go to 131 ir = izt rhav = .true. 131 if (.not. ziszt) go to 150 iz = izt zhav = .true. c c***** take care of details before going on to perform the stopping c test c c calculate whatever dots we can ... 150 assign 151 to lbldc go to 1300 c save vector calculation needs ... 151 rcalp = ir .ne. 0 zcalp = iz .ne. 0 ztcalp = izt .ne. 0 c head home, if ncall .le. 0 ... if (init .or. nufact) go to 950 c c save dot have temporaries, if ncall>0 ... udhav = udhv rdhav = rdhv rzhav = rzhv rzthav = rzthv zdhav = zdhv zzthav = zzthv ztdhav = ztdhv c c get (u-ubar,u-ubar) if (ntest .ne. 6) go to 45 uedot= 0.0d0 do 40 i = 1,n 40 uedot = uedot + (u(i) - ubar(i))**2 c c=============================================================================== c====================== stopping test computation section ====================== c c at this point, all the needed dot products have been computed, and c we are to actually perform the stopping test. c 45 go to (51,52,53,54,55,56,57,58,59,60), ntest c c ... test 1 c 51 if (rztdot .lt. -srelpr) go to 998 top = emax * sqrt (abs(rztdot)) bottom = emin * bnorm1 go to 80 c c ... test 2 c 52 top = sqrt (abs(ztdot)) bottom = emin * udnm go to 80 c c ... test 3 c 53 top = emax * sqrt (abs(ztdot)) bottom = emin * bnorm1 go to 80 c c ... test 4 c 54 top = sqrt (abs(ztdot)) bottom = bnorm1 go to 80 c c ... test 5 c 55 top = sqrt (abs(rdot)) bottom = bnorm1 go to 80 c c ... test 6 c 56 top = sqrt (abs(uedot)) bottom = ubarnm go to 80 c c ... test 7 c 57 if (rzdot .lt. -srelpr) go to 998 top = emax * sqrt (abs(rzdot)) bottom = emin * bnorm1 go to 80 c c ... test 8 c 58 top = sqrt (abs(zdot)) bottom = emin * udnm go to 80 c c ... test 9 c 59 top = emax * sqrt (abs(zdot)) bottom = emin * bnorm1 go to 80 c c ... test 10 c 60 top = sqrt (abs(zdot)) bottom = bnorm1 go to 80 c 80 if (bottom .lt. tiny) bottom = tiny stptst = top/bottom call ckconv (ier) if (ier .lt. 0) go to 950 halt = .false. if (top .lt. bottom*zeta) halt = .true. c c done with the stopping test, head home. go to 950 c c=============================================================================== c*********************** section to calculate dot-needs ************************ c c here, we consider which dot products the stopping test needs, and c see whether the needed dot products are currently nonexistent and c thus must be calculated. c 1100 continue c c spread any dot information to other dots, as possible ... if (risz) then if (rdhv) then rzdot = rdot rzhv = .true. zdot = rdot zdhv = .true. end if if (rzhv) then rdot = rzdot rdhv = .true. zdot = rzdot zdhv = .true. end if if (zdhv) then rzdot = zdot rzhv = .true. rdot = zdot rdhv = .true. end if end if c if (ziszt) then if (zdhv) then zztdot = zdot zzthv = .true. ztdot = zdot ztdhv = .true. end if if (zzthv) then zdot = zztdot zdhv = .true. ztdot = zztdot ztdhv = .true. end if if (ztdhv) then zdot = ztdot zdhv = .true. zztdot = ztdot zzthv = .true. end if end if c if (riszt) then if (rdhv) then rztdot = rdot rzthv = .true. ztdot = rdot ztdhv = .true. end if if (rzthv) then rdot = rztdot rdhv = .true. ztdot = rztdot ztdhv = .true. end if if (ztdhv) then rztdot = ztdot rzthv = .true. rdot = ztdot rdhv = .true. end if end if c c figure out which dots actually need to be calculated ... 1103 udcal = (needbn(ntest) .eq. 0 .and. ntest .ne. 6) .and. .not.udhv rdcal = idot .eq. 1 .and. .not.rdhv rzcal = (idot .eq. 2 .or. idot .eq. 4) .and. .not.rzhv rztcal = (idot .eq. 3 .or. idot .eq. 7) .and. .not.rzthv zdcal = idot .eq. 5 .and. .not.zdhv zztcal = (idot .eq. 6 .or. idot .eq. 8) .and. .not.zzthv ztdcal = idot .eq. 9 .and. .not.ztdhv go to lbldn c c=============================================================================== c********************* section to calculate vector-needs *********************** c c here, we see which vectors have to be calculated in order to c satisfy the dot calculation needs. c 1200 continue ztcalc = (rztcal.or.zztcal.or.ztdcal) a .and. .not.zthav zcalc = (rzcal .or.zdcal .or.zztcal .or. ztcalc) a .and. .not.zhav rcalc = (rdcal .or.rzcal .or.rztcal .or. zcalc) a .and. .not.rhav go to lblvn c c=============================================================================== c********************* dot product calculation section ************************* c c here, we calculate whatever dot products can be calculated from the c currently existing vectors. c c first locate where the needed vectors are ... 1300 if (rhave) locr = 1 if (zhave .and. risz) locr = 2 if (zthave .and. riszt) locr = 3 if (ir .ne. 0) locr = 4 c if (rhave .and. risz) locz = 1 if (zhave) locz = 2 if (zthave .and. ziszt) locz = 3 if (iz .ne. 0) locz = 4 c if (rhave .and. riszt) loczt = 1 if (zhave .and. ziszt) loczt = 2 if (zthave) loczt = 3 if (izt .ne. 0) loczt = 4 c c now calculate whatever dot products we can ... c c** get udnm ... if (.not. udcal) go to 1350 if ((in .gt. 5) .and. (mod(in,5) .ne. 0)) go to 1350 uold = udnm if (init .or. nufact) go to 1349 udnm = sqrt ( abs ( vdot (n,u,u) ) ) c if ((in .gt. 5) .and. (abs (udnm-uold) .lt. udnm*zeta)) c a is3 = 1 if (udnm .lt. srelpr) udnm = 1.0d0 1349 udhv = .true. assign 1350 to lbldn go to 1100 c c** get rdot ... 1350 if (.not. (rdcal .and. rhav)) go to 1360 if (init .or. nufact) go to 1359 rdot = seldot (n,locr,r,z,zt,wk(ir),locr,r,z,zt,wk(ir)) 1359 rdhv = .true. assign 1360 to lbldn go to 1100 c c** get rzdot ... 1360 if (.not. (rzcal .and. rhav .and. zhav)) go to 1370 if (init .or. nufact) go to 1369 rzdot = seldot (n,locr,r,z,zt,wk(ir),locz,r,z,zt,wk(iz)) 1369 rzhv = .true. assign 1370 to lbldn go to 1100 c c** get rztdot ... 1370 if (.not. (rztcal .and. rhav .and. zthav)) go to 1380 if (init .or. nufact) go to 1379 rztdot = seldot (n,locr,r,z,zt,wk(ir),loczt,r,z,zt,wk(izt)) 1379 rzthv = .true. assign 1380 to lbldn go to 1100 c c** get zdot ... 1380 if (.not. (zdcal .and. zhav)) go to 1390 if (init .or. nufact) go to 1389 zdot = seldot (n,locz,r,z,zt,wk(iz),locz,r,z,zt,wk(iz)) 1389 zdhv = .true. assign 1390 to lbldn go to 1100 c c** get zztdot ... 1390 if (.not. (zztcal .and. zhav .and. zthav)) go to 1400 if (init .or. nufact) go to 1399 zztdot = seldot (n,locz,r,z,zt,wk(iz),loczt,r,z,zt,wk(izt)) 1399 zzthv = .true. assign 1400 to lbldn go to 1100 c c** get ztdot ... 1400 if (.not. (ztdcal .and. zthav)) go to 1410 if (init .or. nufact) go to 1409 ztdot = seldot (n,loczt,r,z,zt,wk(izt),loczt,r,z,zt,wk(izt)) 1409 ztdhv = .true. assign 1410 to lbldn go to 1100 c 1410 continue go to lbldc c c=============================================================================== 950 nw = nwusd return c================================= error returns =============================== c c splitting matrix is not positive definite c 998 ier = -7 call ershow (ier,'pstop') go to 950 c c insuff. floating point wksp c 999 ier = -2 call ershow (ier,'pstop') go to 950 end double precision function seldot (n,iu,u1,u2,u3,u4,iv,v1,v2,v3,v4) implicit double precision (a-h, o-z) c c this routine computes a dot product from a selected pair of vectors c dimension u1(1), u2(1), u3(1), v1(1), v2(1), v3(1) dimension u4(1), v4(1) c ind = 1 + (iv-1) + 4*(iu-1) if (ind .eq. 1) seldot = vdot (n,u1,v1) if (ind .eq. 2) seldot = vdot (n,u1,v2) if (ind .eq. 3) seldot = vdot (n,u1,v3) if (ind .eq. 4) seldot = vdot (n,u1,v4) if (ind .eq. 5) seldot = vdot (n,u2,v1) if (ind .eq. 6) seldot = vdot (n,u2,v2) if (ind .eq. 7) seldot = vdot (n,u2,v3) if (ind .eq. 8) seldot = vdot (n,u2,v4) if (ind .eq. 9) seldot = vdot (n,u3,v1) if (ind .eq. 10) seldot = vdot (n,u3,v2) if (ind .eq. 11) seldot = vdot (n,u3,v3) if (ind .eq. 12) seldot = vdot (n,u3,v4) if (ind .eq. 13) seldot = vdot (n,u4,v1) if (ind .eq. 14) seldot = vdot (n,u4,v2) if (ind .eq. 15) seldot = vdot (n,u4,v3) if (ind .eq. 16) seldot = vdot (n,u4,v4) return end subroutine ckconv (ier) implicit double precision (a-h, o-z) c c routine to determine whether iterative method has stagnated, c or other unfortunate situation. c parameter (nst=20) parameter (eps=1.0d-7) common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / itcom3 / alpha, beta, zeta, emax, emin, pap, a alphao, gamma, sigma, rr, rho, dkq, dkm1, a ff, rqmin, rqmax, stptst, udnm, ubarnm, a bnorm, bnorm1 c dimension stold(nst) save stold, ist ind(i) = 1 + mod(i,nst) c if (in .le. 0) ist = 0 c ist = ist + 1 stold(ind(ist)) = stptst if (ist .lt. nst) go to 900 c do 2 i = 1, nst-1 do 2 i = nst-1, 1, -1 c val = abs(stold(ind(ist-i))-stptst)/stptst val = abs(stold(ind(ist-i))-stptst) if (val .gt. eps*stptst) go to 900 2 continue ier = -19 call ershow (ier,'ckconv') return c 900 return end subroutine inithv (icall) implicit double precision (a-h, o-z) c c routine to initialize dot and vector haves to false. c common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c udhav = .false. rdhav = .false. rzhav = .false. rzthav = .false. zdhav = .false. zzthav = .false. ztdhav = .false. if (icall .eq. 1) return rhave = .false. zhave = .false. zthave = .false. c return end subroutine hqr(nm,n,low,igh,h,wr,wi,ierr) implicit double precision (a-h, o-z) c integer en,enm2 dimension h(nm,n),wr(n),wi(n) double precision norm logical notlas c c this routine is a translation of the algol procedure hqr, c num. math. 14, 219-231(1970) by martin, peters, and wilkinson. c handbook for auto. comp., vol.ii-linear algebra, 359-371(1971). c c this routine finds the eigenvalues of a floating point c upper hessenberg matrix by the qr method. c c on input c c nm must be set to the row dimension of two-dimensional c array parameters as declared in the calling program c dimension statement. c c n is the order of the matrix. c c low and igh are integers determined by the balancing c routine balanc. if balanc has not been used, c set low=1, igh=n. c c h contains the upper hessenberg matrix. information about c the transformations used in the reduction to hessenberg c form by elmhes or orthes, if performed, is stored c in the remaining triangle under the hessenberg matrix. c c on output c c h has been destroyed. therefore, it must be saved c before calling hqr if subsequent calculation and c back transformation of eigenvectors is to be performed. c c wr and wi contain the real and imaginary parts, c respectively, of the eigenvalues. the eigenvalues c are unordered except that complex conjugate pairs c of values appear consecutively with the eigenvalue c having the positive imaginary part first. if an c error exit is made, the eigenvalues should be correct c for indices ierr+1,...,n. c c ierr is set to c zero for normal return, c j if the limit of 30*n iterations is exhausted c while the j-th eigenvalue is being sought. c c questions and comments should be directed to burton s. garbow, c mathematics and computer science div, argonne national laboratory c c this version dated august 1983. c c ------------------------------------------------------------------ c ierr = 0 norm = 0.0d0 k = 1 c .......... store roots isolated by balanc c and compute matrix norm .......... do 50 i = 1, n c do 40 j = k, n 40 norm = norm + abs(h(i,j)) c k = i if (i .ge. low .and. i .le. igh) go to 50 wr(i) = h(i,i) wi(i) = 0.0d0 50 continue c en = igh t = 0.0d0 itn = 30*n c .......... search for next eigenvalues .......... 60 if (en .lt. low) go to 1001 its = 0 na = en - 1 enm2 = na - 1 c .......... look for single small sub-diagonal element c for l=en step -1 until low do -- .......... 70 do 80 ll = low, en l = en + low - ll if (l .eq. low) go to 100 s = abs(h(l-1,l-1)) + abs(h(l,l)) if (s .eq. 0.0d0) s = norm tst1 = s tst2 = tst1 + abs(h(l,l-1)) if (tst2 .eq. tst1) go to 100 80 continue c .......... form shift .......... 100 x = h(en,en) if (l .eq. en) go to 270 y = h(na,na) w = h(en,na) * h(na,en) if (l .eq. na) go to 280 if (itn .eq. 0) go to 1000 if (its .ne. 10 .and. its .ne. 20) go to 130 c .......... form exceptional shift .......... t = t + x c do 120 i = low, en 120 h(i,i) = h(i,i) - x c s = abs(h(en,na)) + abs(h(na,enm2)) x = 0.75d0 * s y = x w = -0.4375d0 * s * s 130 its = its + 1 itn = itn - 1 c .......... look for two consecutive small c sub-diagonal elements. c for m=en-2 step -1 until l do -- .......... do 140 mm = l, enm2 m = enm2 + l - mm zz = h(m,m) r = x - zz s = y - zz p = (r * s - w) / h(m+1,m) + h(m,m+1) q = h(m+1,m+1) - zz - r - s r = h(m+2,m+1) s = abs(p) + abs(q) + abs(r) p = p / s q = q / s r = r / s if (m .eq. l) go to 150 tst1 = abs(p)*(abs(h(m-1,m-1)) + abs(zz) + abs(h(m+1,m+1))) tst2 = tst1 + abs(h(m,m-1))*(abs(q) + abs(r)) if (tst2 .eq. tst1) go to 150 140 continue c 150 mp2 = m + 2 c do 160 i = mp2, en h(i,i-2) = 0.0d0 if (i .eq. mp2) go to 160 h(i,i-3) = 0.0d0 160 continue c .......... double qr step involving rows l to en and c columns m to en .......... do 260 k = m, na notlas = k .ne. na if (k .eq. m) go to 170 p = h(k,k-1) q = h(k+1,k-1) r = 0.0d0 if (notlas) r = h(k+2,k-1) x = abs(p) + abs(q) + abs(r) if (x .eq. 0.0d0) go to 260 p = p / x q = q / x r = r / x 170 s = sign(sqrt(p*p+q*q+r*r),p) if (k .eq. m) go to 180 h(k,k-1) = -s * x go to 190 180 if (l .ne. m) h(k,k-1) = -h(k,k-1) 190 p = p + s x = p / s y = q / s zz = r / s q = q / p r = r / p if (notlas) go to 225 c .......... row modification .......... do 200 j = k, n p = h(k,j) + q * h(k+1,j) h(k,j) = h(k,j) - p * x h(k+1,j) = h(k+1,j) - p * y 200 continue c j = min(en,k+3) c .......... column modification .......... do 210 i = 1, j p = x * h(i,k) + y * h(i,k+1) h(i,k) = h(i,k) - p h(i,k+1) = h(i,k+1) - p * q 210 continue go to 255 225 continue c .......... row modification .......... do 230 j = k, n p = h(k,j) + q * h(k+1,j) + r * h(k+2,j) h(k,j) = h(k,j) - p * x h(k+1,j) = h(k+1,j) - p * y h(k+2,j) = h(k+2,j) - p * zz 230 continue c j = min(en,k+3) c .......... column modification .......... do 240 i = 1, j p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2) h(i,k) = h(i,k) - p h(i,k+1) = h(i,k+1) - p * q h(i,k+2) = h(i,k+2) - p * r 240 continue 255 continue c 260 continue c go to 70 c .......... one root found .......... 270 wr(en) = x + t wi(en) = 0.0d0 en = na go to 60 c .......... two roots found .......... 280 p = (y - x) / 2.0d0 q = p * p + w zz = sqrt(abs(q)) x = x + t if (q .lt. 0.0d0) go to 320 c .......... real pair .......... zz = p + sign(zz,p) wr(na) = x + zz wr(en) = wr(na) if (zz .ne. 0.0d0) wr(en) = x - w / zz wi(na) = 0.0d0 wi(en) = 0.0d0 go to 330 c .......... complex pair .......... 320 wr(na) = x + p wr(en) = x + p wi(na) = zz wi(en) = -zz 330 en = enm2 go to 60 c .......... set error -- all eigenvalues have not c converged after 30*n iterations .......... 1000 ierr = en 1001 return end subroutine adjust (n,ndim,maxnzz,jcoef,key) implicit double precision (a-h, o-z) c c ... adjust makes adjustments to the jcoef array. c c ... parameters -- c c n dimension of the matrix. c ndim row dimension of jcoef array in defining routine c maxnz number of columns in jcoef array c jcoef integer matrix representation array c key indicator flag c = 1 remove zeros from jcoef array c = 2 restore zeros to jcoef array c c ... specifications for parameters c integer jcoef(ndim,1) c maxnz = maxnzz if (maxnz .lt. 2) return if (key .eq. 2) go to 20 c c ... change zero elements of jcoef array. c do 15 j = 2,maxnz do 10 i = 1,n 10 if (jcoef(i,j) .le. 0) jcoef(i,j) = i 15 continue return c c ... put original zeros back in jcoef array. c 20 do 30 j = 2,maxnz do 25 i = 1,n 25 if (jcoef(i,j) .eq. i) jcoef(i,j) = 0 30 continue return end subroutine adinfn (nn,ndim,maxnzz,jcoef,coef,nstore,ainf,wksp) implicit double precision (a-h, o-z) c c ... adinfn computes an upper bound on the spectral radius of c inv(d)*a. c c ... parameters -- c c n order of system (= nn) c ndim row dimension of coef array in defining routine c maxnz number of columns in coef array (= maxnzz) c jcoef integer matrix representation array c coef matrix representation array c nstore matrix storage mode c = 2 symmetric diagonal format c = 3 nonsymmetric diagonal format c ainf upper bound estimate upon output c wksp workspace vector of length n c c ... specifications for parameters c integer jcoef(2) dimension coef(ndim,1), wksp(1) c n = nn maxnz = maxnzz if (ainf .gt. 0.0d0) return do 10 i = 1,n 10 wksp(i) = coef(i,1) do 25 jd = 1,maxnz do 20 j = 1,maxnz if (jcoef(j) .ne. jd) go to 20 do 15 i = 1,n 15 wksp(i) = wksp(i) - abs (coef(i,j)) if (nstore .eq. 3) go to 25 len = n - jd do 18 i = 1,len 18 wksp(i+jd) = wksp(i+jd) - abs (coef(i,j)) go to 25 20 continue go to 30 25 continue 30 if (nstore .eq. 2) go to 50 do 45 jd = 1,maxnz do 40 j = 1,maxnz if (jcoef(j) .ne. -jd) go to 40 do 35 i = 1,n 35 wksp(i) = wksp(i) - abs (coef(i,j)) go to 45 40 continue go to 50 45 continue c c ... factor. c 50 t1 = vmin (n,wksp) if (t1 .le. 0.0d0) t1 = 1.0d0 call ainfn (n,ndim,maxnz,jcoef,coef,nstore,ainf,wksp) ainf = ainf/t1 return end subroutine ainfn (nn,ndim,maxnzz,jcoef,coef,nstore,ainf, a wksp) implicit double precision (a-h, o-z) c c ... ainfn calculates the infinity norm of the matrix a. c c ... parameters -- c c n order of system (= nn) c ndim row dimension of coef array in defining routine c maxnz number of columns in coef array (= maxnzz) c jcoef integer matrix representation array c coef matrix representation array c nstore matrix storage mode c = 1 purdue format c = 2 symmetric diagonal format c = 3 nonsymmetric diagonal format c = 4 symmetric sparse format c = 5 nonsymmetric sparse format c ainf the infinity norm of the matrix, //a//, upon c output c wksp workspace vector of length n c c ... specifications for parameters c integer jcoef(ndim,2) dimension coef(ndim,1), wksp(1) c n = nn maxnz = maxnzz if (ainf .gt. 0.0d0) return go to (10,30,55,75,75), nstore c c ... ellpack data structure. c 10 do 15 i = 1,n 15 wksp(i) = abs (coef(i,1)) if (maxnz .le. 1) go to 995 do 25 j = 2,maxnz do 20 i = 1,n 20 wksp(i) = wksp(i) + abs (coef(i,j)) 25 continue go to 995 c c ... symmetric diagonal data structure. c 30 do 35 i = 1,n 35 wksp(i) = abs (coef(i,1)) if (maxnz .le. 1) go to 995 do 50 j = 2,maxnz ind = jcoef(j,1) len = n - ind do 40 i = 1,len 40 wksp(i) = wksp(i) + abs (coef(i,j)) do 45 i = 1,len 45 wksp(i+ind) = wksp(i+ind) + abs (coef(i,j)) 50 continue go to 995 c c ... nonsymmetric diagonal data structure. c 55 do 60 i = 1,n 60 wksp(i) = abs (coef(i,1)) if (maxnz .le. 1) go to 995 do 70 j = 2,maxnz ind = jcoef(j,1) len = n - iabs(ind) ist1 = max (1,1 - ind) ist2 = min (n,n - ind) do 65 i = ist1,ist2 65 wksp(i) = wksp(i) + abs (coef(i,j)) 70 continue go to 995 c c ... sparse structure. c 75 do 80 i = 1,n 80 wksp(i) = abs (coef(i,1)) if (maxnz .le. n) go to 995 np1 = n + 1 do 85 k = np1,maxnz 85 wksp(jcoef(k,1)) = wksp(jcoef(k,1)) + abs (coef(k,1)) if (nstore .eq. 5) go to 995 do 90 k = np1,maxnz 90 wksp(jcoef(k,2)) = wksp(jcoef(k,2)) + abs (coef(k,1)) c c ... determine ainf = max (wksp(i)). c 995 ainf = vmax (n,wksp) return end subroutine bdfac (lda,nn,nsizee,nt,nb,a,isym) implicit double precision (a-h, o-z) c c ... bdfac computes the factorization of a dense banded matrix. c c ... parameters -- c c lda leading dimension of array a c n active size of array a c nsize size of an individual subsystem (if multiple systems) c nsize = n upon input if not a multiple system c nt number of diagonals needed to store the super- c diagonals c nb number of diagonals needed to store the sub- c diagonals c a array c isym symmetry switch c = 0 matrix is symmetric c = 1 matrix is nonsymmetric c c ... specifications for parameters c dimension a(lda,5) data lenv / 10 / c n = nn maxt = nt nsize = nsizee nsys = n/nsize c c ... branch on symmetry. c if (isym .eq. 1) go to 30 c c ... symmetric case. c c ... diagonal case (maxt = 0). c if (maxt .ne. 0) go to 15 do 10 i = 1,n 10 a(i,1) = 1.0d0/a(i,1) return c c ... tridiagonal case (maxt = 1). c 15 if (maxt .ne. 1) go to 20 if (nsys .le. lenv) call tfac (n,a,a(1,2)) if (nsys .gt. lenv) call tfacm (n,nsize,a,a(1,2)) return c c ... pentadiagonal case (maxt = 2). c 20 if (maxt .ne. 2) go to 25 if (nsys .le. lenv) call pfac (n,a,a(1,2),a(1,3)) if (nsys .gt. lenv) call pfacm (n,nsize,a,a(1,2),a(1,3)) return c c ... banded case (maxt .gt. 2). c 25 if (nsys .le. lenv) call bfac (lda,n,maxt,a,a(1,2)) if (nsys .gt. lenv) call bfacm (n,nsize,nsys,maxt,a,a(1,2)) return c c ... nonsymmetric case. c 30 maxb = nb c c ... diagonal case (maxt = maxb = 0). c if (maxt .ne. 0 .or. maxb .ne. 0) go to 40 do 35 i = 1,n 35 a(i,1) = 1.0d0/a(i,1) return c c ... tridiagonal case (maxt = maxb = 1). c 40 if (maxt .ne. 1 .or. maxb .ne. 1) go to 45 if (nsys .le. lenv) call tfacn (n,a,a(1,2),a(2,3)) if (nsys .gt. lenv) call tfacnm (n,nsize,a,a(1,2),a(2,3)) return c c ... pentadiagonal case (maxt = maxb = 2). c 45 if (maxt .ne. 2 .or. maxb .ne. 2) go to 50 if (nsys .le. lenv) call pfacn (n,a,a(1,2),a(1,3),a(2,4), a a(3,5)) if (nsys .gt. lenv) call pfacnm (n,nsize,a,a(1,2),a(1,3), a a(2,4),a(3,5)) return c c ... all other cases. c 50 if (nsys .le. lenv) call bfacn (lda,n,maxt,maxb,a,a(1,2), a a(1,maxt+2)) if (nsys .gt. lenv) call bfacnm (n,nsize,nsys,maxt,maxb,a,a(1,2), a a(1,maxt+2)) return end subroutine bdinv (lda,nn,nsizee,nt,nb,fac,isym) implicit double precision (a-h, o-z) c c ... bdinv computes the inverse of a dense banded matrix. c c ... parameters -- c c lda leading dimension of factorization matrix fac c n active size of factorization matrix fac c nsize size of an individual subsystem (if multiple systems) c nsize = n upon input if not a multiple system c nt number of diagonals needed to store the super- c diagonals c nb number of diagonals needed to store the sub- c diagonals c fac array containing factorization upon input c isym symmetry switch c = 0 matrix is symmetric c = 1 matrix is nonsymmetric c c ... specifications for parameters c dimension fac(lda,3) data lenv / 10 / c n = nn maxt = nt nsize = nsizee nsys = n/nsize c c ... branch on symmetry. c if (isym .eq. 1) go to 30 c c ... symmetric case. c if (maxt - 1) 10,20,25 c c ... diagonal case (maxt = 0). c 10 return c c ... tridiagonal case (maxt = 1). c 20 if (nsys .le. lenv) call tinv (n,fac,fac(1,2)) if (nsys .gt. lenv) call tinvm (n,nsize,fac,fac(1,2)) return c c ... banded case (maxt .ge. 2). c 25 call binv (lda,n,maxt+1,fac) return c c ... nonsymmetric case. c 30 maxb = nb c c ... diagonal case (maxt = maxb = 0). c if (maxt .ne. 0 .or. maxb .ne. 0) go to 40 return c c ... tridiagonal case (maxt = maxb = 1). c 40 if (maxt .ne. 1 .or. maxb .ne. 1) go to 45 if (nsys .le. lenv) call tinvn (n,fac,fac(1,2),fac(2,3)) if (nsys .gt. lenv) call tinvnm (n,nsize,fac,fac(1,2),fac(2,3)) return c c ... all other cases. c 45 call binvn (lda,n,maxt,maxb,fac,fac(1,2),fac(1,maxt+2)) return end subroutine bdsol (lda,nn,nsizee,nt,nb,fac,y,x,isym) implicit double precision (a-h, o-z) c c ... bdsol computes the solution to a dense banded matrix. c thus, bdsol finds the solution to a*x = y, where fac c contains the factorization of the a matrix. c c ... parameters -- c c lda leading dimension of array fac c n active size of array fac c nsize size of an individual subsystem (if multiple systems) c nsize = n upon input if not a multiple system c nt number of diagonals needed to store the super- c diagonals of the factorization c nb number of diagonals needed to store the sub- c diagonals of the factorization c fac array containing the factorization of the matrix c y upon input, y conains the right hand side c x upon output, x contains the solution to a*x = y c isym symmetry switch c = 0 matrix is symmetric c = 1 matrix is nonsymmetric c c ... specifications for parameters c dimension fac(lda,5), x(1), y(1) data lenv / 10 / c n = nn maxt = nt nsize = nsizee nsys = n/nsize c c ... branch on symmetry. c if (isym .eq. 1) go to 30 c c ... symmetric case. c c ... diagonal case (maxt = 0). c if (maxt .ne. 0) go to 15 do 10 i = 1,n 10 x(i) = fac(i,1)*y(i) return c c ... tridiagonal case (maxt = 1). c 15 if (maxt .ne. 1) go to 20 if (nsys .le. lenv) call tsoln (n,fac,fac(1,2),fac(1,2),y,x) if (nsys .gt. lenv) call tsolnm (n,nsize,fac,fac(1,2), a fac(1,2),y,x) return c c ... pentadiagonal case (maxt = 2). c 20 if (maxt .ne. 2) go to 25 if (nsys .le. lenv) call psoln (n,fac,fac(1,2),fac(1,3), a fac(1,2),fac(1,3),y,x) if (nsys .gt. lenv) call psolnm (n,nsize,fac,fac(1,2),fac(1,3), a fac(1,2),fac(1,3),y,x) return c c ... banded case (maxt .ge. 3). c 25 if (nsys .le. lenv) call bsol (lda,n,maxt,fac,fac(1,2),y,x) if (nsys .gt. lenv) call bsolm (n,nsize,maxt,fac,fac(1,2),y,x) return c c ... nonsymmetric case. c 30 maxb = nb c c ... diagonal case (maxt = maxb = 0). c if (maxt .ne. 0 .or. maxb .ne. 0) go to 40 do 35 i = 1,n 35 x(i) = fac(i,1)*y(i) return c c ... tridiagonal case (maxt = maxb = 1). c 40 if (maxt .ne. 1 .or. maxb .ne. 1) go to 45 if (nsys .le. lenv) call tsoln (n,fac,fac(1,2),fac(2,3),y,x) if (nsys .gt. lenv) call tsolnm (n,nsize,fac,fac(1,2),fac(2,3), a y,x) return c c ... pentadiagonal case (maxt = maxb = 2). c 45 if (maxt .ne. 2 .or. maxb .ne. 2) go to 50 if (nsys .le. lenv) call psoln (n,fac,fac(1,2),fac(1,3), a fac(2,4),fac(3,5),y,x) if (nsys .gt. lenv) call psolnm (n,nsize,fac,fac(1,2),fac(1,3), a fac(2,4),fac(3,5),y,x) return c c ... all other cases. c 50 if (nsys .le. lenv) call bsoln (lda,n,maxt,maxb,fac,fac(1,2), a fac(1,maxt+2),y,x) if (nsys .gt. lenv) call bsolnm (n,nsize,maxt,maxb,fac, a fac(1,2),fac(1,maxt+2),y,x) return end subroutine bdsolt (lda,nn,nsizee,nt,nb,fac,y,x) implicit double precision (a-h, o-z) c c ... bdsolt computes the transpose solution to a nonsymmetric c dense banded matrix. c thus, bdsolt finds the solution to (a**t)*x = y, where fac c contains the factorization of the a matrix. c c ... parameters -- c c lda leading dimension of array fac c n active size of array fac c nsize size of an individual subsystem (if multiple systems) c nsize = n upon input if not a multiple system c nt number of diagonals needed to store the super- c diagonals of the factorization c nb number of diagonals needed to store the sub- c diagonals of the factorization c fac array containing the factorization of the matrix c y upon input, y conains the right hand side c x upon output, x contains the solution to a*x = y c c ... specifications for parameters c dimension fac(lda,5), x(1), y(1) data lenv / 10 / c n = nn maxt = nt maxb = nb nsize = nsizee nsys = n/nsize c c ... nonsymmetric case. c c ... diagonal case (maxt = maxb = 0). c if (maxt .ne. 0 .or. maxb .ne. 0) go to 15 do 10 i = 1,n 10 x(i) = fac(i,1)*y(i) return c c ... tridiagonal case (maxt = maxb = 1). c 15 if (maxt .ne. 1 .or. maxb .ne. 1) go to 20 if (nsys .le. lenv) call tsoln (n,fac,fac(2,3),fac(1,2),y,x) if (nsys .gt. lenv) call tsolnm (n,nsize,fac,fac(2,3),fac(1,2), a y,x) return c c ... pentadiagonal case (maxt = maxb = 2). c 20 if (maxt .ne. 2 .or. maxb .ne. 2) go to 25 if (nsys .le. lenv) call psoln (n,fac,fac(2,4),fac(3,5), a fac(1,2),fac(1,3),y,x) if (nsys .gt. lenv) call psolnm (n,nsize,fac,fac(2,4),fac(3,5), a fac(1,2),fac(1,3),y,x) return c c ... all other cases. c 25 if (nsys .le. lenv) call bsolnt (lda,n,maxt,maxb,fac,fac(1,2), a fac(1,maxt+2),y,x) if (nsys .gt. lenv) call bsontm (n,nsize,maxt,maxb,fac, a fac(1,2),fac(1,maxt+2),y,x) return end subroutine bbs (ndim,nn,maxt,t,x) implicit double precision (a-h, o-z) c c ... bbs does a banded back substitution (i + t)*x = y. c t is a rectangular matrix of adjacent super-diagonals. c c ... parameters -- c c ndim row dimension of t array in defining routine c n order of system c maxt number of columns in t array c t array of active size n by maxt giving the super- c diagonals in the order 1,2,3,... c x on input, x contains y c vector containing solution upon output c c ... specifications for parameters c dimension t(ndim,1), x(1) c n = nn do 20 i = n-1,1,-1 sum = x(i) lim = min (maxt,n-i) do 15 j = 1,lim sum = sum - t(i,j)*x(i+j) 15 continue x(i) = sum 20 continue return end subroutine bbsm (nsize,nsys,maxt,t,x) implicit double precision (a-h, o-z) c c ... bbsm does a back solve (i + t)*x = y where t is an array c containing superdiagonals in order 1,2,... . c c ... parameters -- c c n order of system c nsize size of a single subsystem c nsys number of independent subsystems c maxt number of columns in t array c t array of active size n by maxt containing c the super-diagonal elements of the factorization c x on input, x contains y c vector containing solution upon output c c ... specifications for parameters c dimension t(nsize,nsys,1), x(nsize,1) c do 25 i = nsize-1,1,-1 lim = min (nsize-i, maxt) do 20 j = 1,lim ij = i + j do 15 l = 1,nsys 15 x(i,l) = x(i,l) - t(i,l,j)*x(ij,l) 20 continue 25 continue return end subroutine bbst (ndim,nn,maxb,b,x) implicit double precision (a-h, o-z) c c ... bbst does a backward substitution (i + (b**t))*x = y c where the array b represents sub-diagonals. b corresponds c to a banded system. c c ... parameters -- c c ndim row dimension of b in defining routine c n order of system (= nn) c maxb number of diagonals stored in b c b array of active size n x maxb giving the c sub-diagonals in the order -1,-2,... . c x on input, x contains y c vector containing solution upon output c c ... specifications for parameters c dimension b(ndim,1), x(1) c n = nn do 25 i = n,2,-1 term = x(i) lim = min (i-1,maxb) do 20 j = 1,lim x(i-j) = x(i-j) - b(i,j)*term 20 continue 25 continue return end subroutine bbstm (nsize,nsys,maxb,b,x) implicit double precision (a-h, o-z) c c ... bbstm does the backward solve (i + (b**t))*x = y where b c contains subdiagonals for multiple banded systems. c c ... parameters -- c c n order of system c nsize the size of an individual subsystem c nsys the number of subsystems c maxb number of columns in b array c b array of active size n by maxb containing c sub-diagonals in the order -1,-2,-3,... c x on input, x contains y c vector containing solution upon output c c ... specifications for parameters c dimension b(nsize,nsys,1), x(nsize,1) c do 25 i = nsize,2,-1 lim = min (i-1,maxb) do 20 j = 1,lim do 15 l = 1,nsys 15 x(i-j,l) = x(i-j,l) - b(i,l,j)*x(i,l) 20 continue 25 continue return end subroutine bfac (ndim,nn,maxt,d,t) implicit double precision (a-h, o-z) c c ... bfac computes a factorization to a single banded c symmetric matrix represented by d and t and replaces it. c c ... parameters -- c c ndim row dimension of t array in defining routine c n order of system (= nn) c maxt number of columns in t array c d vector containing the diagonal elements of a c t array of active size n by maxt containing the c super-diagonals in the order 1,2,3,... c c ... specifications for parameters c dimension d(1), t(ndim,1) c n = nn nm1 = n - 1 do 20 k = 1,nm1 pivot = d(k) lim = min (n-k,maxt) do 15 j1 = 1,lim term = t(k,j1)/pivot jcol1 = k + j1 d(jcol1) = d(jcol1) - term*t(k,j1) if (j1 .eq. lim) go to 15 j1p1 = j1 + 1 do 10 j2 = j1p1,lim jcol2 = j2 - j1 t(jcol1,jcol2) = t(jcol1,jcol2) - term*t(k,j2) 10 continue 15 continue 20 continue do 25 i = 1,n 25 d(i) = 1.0d0/d(i) do 35 j = 1,maxt len = n - j do 30 i = 1,len 30 t(i,j) = d(i)*t(i,j) 35 continue return end subroutine bfacm (n,nsize,nsys,maxt,d,t) implicit double precision (a-h, o-z) c c ... bfacm computes factorizations to multiple banded c symmetric matrices represented by d and t and replaces it. c c ... parameters -- c c n order of global system (= nn) c nsize order of a single system c nsys number of independent subsystems c maxt number of columns in t array c d vector of length n containing the diagonal c elements of a c t array of active size n by maxt containing the c super-diagonals in the order 1,2,3,... c c ... specifications for parameters c dimension d(nsize,1), t(nsize,nsys,1) c nsm1 = nsize - 1 do 30 k = 1,nsm1 lim = min (nsize-k,maxt) do 25 j1 = 1,lim jcol1 = k + j1 do 10 l = 1,nsys 10 d(jcol1,l) = d(jcol1,l) - (t(k,l,j1)**2)/d(k,l) if (j1 .eq. lim) go to 25 j1p1 = j1 + 1 do 20 j2 = j1p1,lim jcol2 = j2 - j1 do 15 l = 1,nsys t(jcol1,l,jcol2) = t(jcol1,l,jcol2) a - t(k,l,j1)*t(k,l,j2)/d(k,l) 15 continue 20 continue 25 continue 30 continue call vinv (n,d) do 35 jj = 1,maxt len = n - jj call vexopy (len,t(1,1,jj),d,t(1,1,jj),3) 35 continue return end subroutine bfacn (ndim,nn,maxt,maxb,d,t,b) implicit double precision (a-h, o-z) c c ... bfacn computes a factorization to a single banded c nonsymmetric matrix represented by d, t, and b and c replaces it. c c ... parameters -- c c ndim row dimension of t and b in defining routine c n order of system (= nn) c maxt number of diagonals stored in t c maxb number of diagonals stored in b c d vector of length n containing the diagonal c elements of a c t array of active size n x maxt giving the c super-diagonals in the order 1,2,3,... c b array of active size n x maxb giving the c sub-diagonals in the order -1,-2,-3,... c c ... specifications for parameters c dimension d(1), t(ndim,1), b(ndim,1) c n = nn nm1 = n - 1 do 35 k = 1,nm1 pivot = d(k) liml = min (maxb,n-k) limu = min (maxt,n-k) do 30 ip = 1,liml i = k + ip term = b(i,ip)/pivot do 25 jp = 1,limu term1 = term*t(k,jp) l = jp - ip if (l) 10,15,20 10 b(i,-l) = b(i,-l) - term1 go to 25 15 d(i) = d(i) - term1 go to 25 20 t(i,l) = t(i,l) - term1 25 continue 30 continue 35 continue c do 40 i = 1,n 40 d(i) = 1.0d0/d(i) do 50 j = 1,maxt len = n - j do 45 i = 1,len 45 t(i,j) = d(i)*t(i,j) 50 continue do 60 j = 1,maxb len = n - j do 55 i = 1,len 55 b(i+j,j) = d(i)*b(i+j,j) 60 continue return end subroutine bfacnm (nn,nsize,nsys,maxt,maxb,d,t,b) implicit double precision (a-h, o-z) c c ... bfacnm computes a factorization to multiple banded c nonsymmetric matrices represented by d, t, and b and c replaces it. c c ... parameters -- c c nsize size of a subsystem c nsys number of independent subsystems c maxt number of diagonals stored in t c maxb number of diagonals stored in b c n order of system (= nn) c d vector of length n containing the diagonal c elements of a c t array of active size n x maxt giving the c super-diagonals in the order 1,2,3,... c b array of active size n x maxb giving the c sub-diagonals in the order -1,-2,-3,... c c ... specifications for parameters c dimension d(nsize,1), t(nsize,nsys,1), b(nsize,nsys,1) c n = nn nsm1 = nsize - 1 do 50 k = 1,nsm1 liml = min (maxb,nsize-k) limu = min (maxt,nsize-k) do 45 ip = 1,liml i = k + ip do 40 jp = 1,limu l = jp - ip if (l) 10,20,30 10 do 15 m = 1,nsys 15 b(i,m,-l) = b(i,m,-l) - b(i,m,ip)*t(k,m,jp)/d(k,m) go to 40 20 do 25 m = 1,nsys 25 d(i,m) = d(i,m) - b(i,m,ip)*t(k,m,jp)/d(k,m) go to 40 30 do 35 m = 1,nsys 35 t(i,m,l) = t(i,m,l) - b(i,m,ip)*t(k,m,jp)/d(k,m) 40 continue 45 continue 50 continue c call vinv (n,d) do 55 j = 1,maxt len = n - j call vexopy (len,t(1,1,j),d,t(1,1,j),3) 55 continue do 60 j = 1,maxb len = n - j call vexopy (len,b(j+1,1,j),d,b(j+1,1,j),3) 60 continue return end subroutine bfs (ndim,nn,maxb,b,x) implicit double precision (a-h, o-z) c c ... bfs does a forward substitution (i + b)*x = y where the c array b represents sub-diagonals. b corresponds to a c banded system. c c ... parameters -- c c ndim row dimension of b in defining routine c n order of system (= nn) c maxb number of diagonals stored in b c b array of active size n x maxb giving the c sub-diagonals in the order -1,-2,-3,... . c x on input, x contains y c vector containing solution upon output c c ... specifications for parameters c dimension b(ndim,1), x(1) c n = nn do 15 i = 2,n lim = min (i-1,maxb) sum = x(i) do 10 j = 1,lim sum = sum - b(i,j)*x(i-j) 10 continue x(i) = sum 15 continue return end subroutine bfsm (nsize,nsys,maxb,b,x) implicit double precision (a-h, o-z) c c ... bfsm does the forward solve (i + b)*x = y where b contains c subdiagonals for multiple banded systems. c c ... parameters -- c c n order of system c nsize the size of an individual subsystem c nsys the number of subsystems c maxb number of columns in b array c b array of active size n by maxb containing c sub-diagonals in the order -1,-2,-3,... . c x on input, x contains y c vector containing solution upon output c c ... specifications for parameters c dimension b(nsize,nsys,1), x(nsize,1) c do 20 i = 2,nsize lim = min (i-1,maxb) do 15 j = 1,lim do 10 l = 1,nsys 10 x(i,l) = x(i,l) - b(i,l,j)*x(i-j,l) 15 continue 20 continue return end subroutine bfst (ndim,nn,maxt,t,x) implicit double precision (a-h, o-z) c c ... bfst does a banded forward substitution (i + (t**t))*x = y. c t is a rectangular matrix of adjacent super-diagonals. c c ... parameters -- c c ndim row dimension of t array in defining routine c n order of system c maxt number of columns in t array c t array of active size n by maxt giving the super- c diagonals in the order 1,2,3,... c x on input, x contains y c vector containing solution upon output c c ... specifications for parameters c dimension t(ndim,1), x(1) c n = nn nm1 = n - 1 do 20 i = 1,nm1 term = x(i) lim = min (maxt,n-i) do 15 j = 1,lim x(i+j) = x(i+j) - t(i,j)*term 15 continue 20 continue return end subroutine bfstm (nsize,nsys,maxt,t,x) implicit double precision (a-h, o-z) c c ... bfstm does a forward solve (i + (t**t))*x = y where t is c an array containing superdiagonals in order 1,2,... . c (multiple systems) c c ... parameters -- c c n order of system c nsize size of a single subsystem c nsys number of independent subsystems c maxt number of columns in t array c t array of active size n by maxt containing c the super-diagonal elements of the factorization c x on input, x contains y c vector containing solution upon output c c ... specifications for parameters c dimension t(nsize,nsys,1), x(nsize,1) c nsm1 = nsize - 1 do 20 i = 1,nsm1 lim = min (maxt,nsize-i) do 15 j = 1,lim ij = i + j do 10 l = 1,nsys 10 x(ij,l) = x(ij,l) - t(i,l,j)*x(i,l) 15 continue 20 continue return end subroutine binv (ndim,nn,maxnz,fact) implicit double precision (a-h, o-z) c c ... binv computes an approximate inverse to a single banded c symmetric matrix. fact must contain upon input the output c from a factorization routine. c c ... parameters -- c c ndim row dimension of fact in the defining routine c n order of system (= nn) c maxnz bandwidth of the factorization and inverse c fact array containing factorization diagonals c in the order 0,1,2,3,... c c ... specifications for parameters c dimension fact(ndim,2) c n = nn nm1 = n - 1 c c ... general banded matrix. c do 25 ik = 1,nm1 k = n - ik lim = min (ik+1,maxnz) sum1= 0.0d0 do 15 i = 2,lim t1 = fact(k,i) sum2= 0.0d0 do 10 j = 2,lim m1 = min (i,j) m2 = max (i,j) l1 = k + m1 - 1 l2 = m2 - m1 + 1 sum2 = sum2 - fact(k,j)*fact(l1,l2) 10 continue fact(n,i) = sum2 sum1 = sum1 - t1*sum2 15 continue fact(k,1) = fact(k,1) + sum1 do 20 i = 2,lim 20 fact(k,i) = fact(n,i) 25 continue do 30 i = 2,maxnz 30 fact(n,i)= 0.0d0 return end subroutine binvn (ndim,nn,maxt,maxb,d,t,b) implicit double precision (a-h, o-z) c c ... binvn computes an approximate inverse to a single banded c nonsymmetric matrix. d, t, and b must contain upon input c the output from a factorization routine. c c ... parameters -- c c ndim row dimension of t and b in the defining routine c n order of system (= nn) c maxt number of columns in t c maxb number of columns in b c d vector of length n containing the diagonal c elements of the factorization c t array of active size n by maxt containing c the superdiagonals of the factorization c in the order 1,2,3,... c b array of active size n by maxb containing c the subdiagonals of the factorization c in the order -1,-2,-3,.... c c ... specifications for parameters c dimension d(1), t(ndim,1), b(ndim,1) c n = nn nm1 = n - 1 c c ... general banded matrix. c do 75 ik = 1,nm1 k = n - ik c c ... copy kth row and column into wksp. c limr = min (maxt,ik) limc = min (maxb,ik) do 10 j = 1,limr 10 t(n,j) = t(k,j) do 15 j = 1,limc 15 b(1,j) = b(k+j,j) c c ... do computations for kth row. c do 40 j = 1,limr sum= 0.0d0 lim = min (limr,limc+j) do 35 i = 1,lim kpi = k + i l = i - j if (l) 20,25,30 20 sum = sum - t(n,i)*t(kpi,-l) go to 35 25 sum = sum - t(n,i)*d(kpi) go to 35 30 sum = sum - t(n,i)*b(kpi,l) 35 continue t(k,j) = sum 40 continue c c ... do computations for kth column. c do 65 j = 1,limc sum= 0.0d0 lim = min (limc,limr+j) kpj = k + j do 60 i = 1,lim kpi = k + i l = i - j if (l) 45,50,55 45 sum = sum - b(1,i)*b(kpj,-l) go to 60 50 sum = sum - b(1,i)*d(kpi) go to 60 55 sum = sum - b(1,i)*t(kpj,l) 60 continue b(kpj,j) = sum 65 continue c c ... compute kth diagonal element. c sum = d(k) lim = min (limr,limc) do 70 j = 1,lim 70 sum = sum - t(n,j)*b(k+j,j) d(k) = sum 75 continue c c ... zero out workspace rows. c do 80 j = 1,maxt 80 t(n,j)= 0.0d0 do 85 j = 1,maxb 85 b(1,j)= 0.0d0 return end subroutine bmul (ndim,n,maxt,d,t,x,y) implicit double precision (a-h, o-z) c c ... bmul computes y = a*x, where x and y are vectors and c ... a is a banded symmetric matrix. c c ... parameters -- c c ndim row dimension of array t c n order of matrix c maxt number of columns in t c d vector of length n giving the c diagonal elements of a c t array of size n by maxt giving the c superdiagonals of a in the order c 1,2,.... c x,y vectors of order n c c ... specifications for parameters c dimension d(1), t(ndim,1), x(1), y(1) c do 10 i = 1,n 10 y(i) = d(i)*x(i) if (maxt .le. 0) return do 25 la = 1,maxt len = n - la do 15 i = 1,len 15 y(i) = y(i) + t(i,la)*x(i+la) do 20 i = 1,len 20 y(i+la) = y(i+la) + t(i,la)*x(i) 25 continue return end subroutine bmuln (ndim,n,maxt,maxb,d,t,b,x,y) implicit double precision (a-h, o-z) c c ... bmuln computes y = a*x, where x and y are vectors and c ... d, t, and b represent a stored in nonsymmetric band c ... storage format. c c ... parameters -- c c ndim row dimension of arrays t and b c n order of array a c maxt number of columns in t array c maxb number of columns in b array c d vector of length n giving the diagonal c elements of a c t array of active size n by maxt giving c the super-diagonals of a in the order c 1,2,3,... c b array of active size n by maxb giving c the sub-diagonals of a in the order c -1,-2,-3,.... c x,y vectors of order n c c ... specifications for parameters c dimension d(1), t(ndim,1), b(ndim,1), x(1), y(1) c do 10 i = 1,n 10 y(i) = d(i)*x(i) if (maxt .lt. 1) go to 25 do 20 j = 1,maxt len = n - j do 15 i = 1,len 15 y(i) = y(i) + t(i,j)*x(i+j) 20 continue 25 if (maxb .lt. 1) return do 35 j = 1,maxb len = n - j do 30 i = 1,len 30 y(i+j) = y(i+j) + b(i+j,j)*x(i) 35 continue return end subroutine bmulnt (ndim,n,maxt,maxb,d,t,b,x,y) implicit double precision (a-h, o-z) c c ... bmulnt computes y = (a**t)*x, where x and y are vectors and c ... d, t, and b represent a stored in nonsymmetric band c ... storage format. c c ... parameters -- c c ndim row dimension of arrays t and b c n order of array a c maxt number of columns in t array c maxb number of columns in b array c d vector of length n giving the diagonal c elements of a c t array of active size n by maxt giving c the super-diagonals of a in the order c 1,2,3,... c b array of active size n by maxb giving c the sub-diagonals of a in the order c -1,-2,-3,... c x,y vectors of order n c c ... specifications for parameters c dimension d(1), t(ndim,1), b(ndim,1), x(1), y(1) c do 10 i = 1,n 10 y(i) = d(i)*x(i) if (maxt .lt. 1) go to 25 do 20 j = 1,maxt len = n - j do 15 i = 1,len 15 y(i+j) = y(i+j) + t(i,j)*x(i) 20 continue 25 if (maxb .lt. 1) return do 35 j = 1,maxb len = n - j do 30 i = 1,len 30 y(i) = y(i) + b(i+j,j)*x(i+j) 35 continue return end subroutine bsol (ndim,nn,maxt,d,t,y,x) implicit double precision (a-h, o-z) c c ... bsol solves a*x = y for a banded and symmetric matrix a. d and c t must contain upon input the factorization arrays from bfac. c c ... parameters -- c c ndim row dimension of t array in defining routine c n order of system c maxt number of columns in t array c d vector of length n containing the diagonal c pivots of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization in the order c 1,2,3,... c y right-hand-side vector c x vector containing solution upon output c c ... specifications for parameters c dimension t(ndim,1), x(1), y(1), d(1) c n = nn do 10 i = 1,n 10 x(i) = y(i) call bfst (ndim,n,maxt,t,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call bbs (ndim,n,maxt,t,x) return end subroutine bsolm (nn,nsize,maxt,d,t,y,x) implicit double precision (a-h, o-z) c c ... bsolm solves the system ax = y for x, where a is multiple c symmetric banded matrices whose factorizations are contained in c d and t. c c ... parameters -- c c n order of system c nsize size of a single subsystem c maxt number of columns in t array c d vector of length n containing the diagonal c elements of the factorization c t array of active size n by maxt containing c the super-diagonal elements of the factorization c in the order 1,2,3,... c y right-hand-side vector c x vector containing solution upon output c c ... specifications for parameters c dimension d(1), t(1), y(1), x(1) c n = nn do 10 i = 1,n 10 x(i) = y(i) nsys = n/nsize call bfstm (nsize,nsys,maxt,t,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call bbsm (nsize,nsys,maxt,t,x) return end subroutine bsoln (ndim,nn,maxt,maxb,d,t,b,y,x) implicit double precision (a-h, o-z) c c ... bsoln solves a*x = y for a banded and nonsymmetric matrix a. c d, t, and b must contain upon input the factorization arrays c from bfacn. c c ... parameters -- c c ndim row dimension of t array in defining routine c n order of system c maxt number of columns in t array c maxb number of columns in b array c d vector of length n containing the diagonal c pivots of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization in the order c 1,2,3,... c b array of active size n by maxb giving the sub- c diagonals of the factorization in the order c -1,-2,-3,... c y right-hand-side vector c x vector containing solution upon output c c ... specifications for parameters c dimension t(ndim,1), x(1), y(1), d(1), b(ndim,1) c n = nn do 10 i = 1,n 10 x(i) = y(i) call bfs (ndim,n,maxb,b,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call bbs (ndim,n,maxt,t,x) return end subroutine bsolnm (nn,nsize,maxt,maxb,d,t,b,y,x) implicit double precision (a-h, o-z) c c ... bsolnm solves a*x = y for a banded and nonsymmetric matrix a. c d, t, and b must contain upon input the factorization arrays c from bfacnm. (multiple systems) c c ... parameters -- c c n order of system c nsize size of an individual subsystem c maxt number of columns in t array c maxb number of columns in b array c d vector of length n containing the diagonal c pivots of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization in the order c 1,2,3,... c b array of active size n by maxb giving the sub- c diagonals of the factorization in the order c -1,-2,-3,... c y right-hand-side vector c x vector containing solution upon output c c ... specifications for parameters c dimension t(1), x(1), y(1), d(1), b(1) c n = nn do 10 i = 1,n 10 x(i) = y(i) nsys = n/nsize call bfsm (nsize,nsys,maxb,b,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call bbsm (nsize,nsys,maxt,t,x) return end subroutine bsolnt (ndim,nn,maxt,maxb,d,t,b,y,x) implicit double precision (a-h, o-z) c c ... bsolnt solves (a**t)*x = y for a banded and nonsymmetric c matrix a. d, t, and b must contain upon input the c factorization arrays from bfacn. c c ... parameters -- c c ndim row dimension of t array in defining routine c n order of system c maxt number of columns in t array c maxb number of columns in b array c d vector of length n containing the diagonal c pivots of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization in the order c 1,2,3,... c b array of active size n by maxb giving the sub- c diagonals of the factorization in the order c -1,-2,-3,... c y right-hand-side vector c x vector containing solution upon output c c ... specifications for parameters c dimension t(ndim,1), x(1), y(1), d(1), b(ndim,1) c n = nn do 10 i = 1,n 10 x(i) = y(i) call bfst (ndim,n,maxt,t,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call bbst (ndim,n,maxb,b,x) return end subroutine bsontm (nn,nsize,maxt,maxb,d,t,b,y,x) implicit double precision (a-h, o-z) c c ... bsontm solves (a**t)*x = y for a banded and nonsymmetric c matrix a. d, t, and b must contain upon input the c factorization arrays from bfacnm. (multiple systems) c c ... parameters -- c c n order of system c nsize size of an individual subsystem c maxt number of columns in t array c maxb number of columns in b array c d vector of length n containing the diagonal c pivots of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization in the order c 1,2,3,... c b array of active size n by maxb giving the sub- c diagonals of the factorization in the order c -1,-2,-3,... c y right-hand-side vector c x vector containing solution upon output c c ... specifications for parameters c dimension t(1), x(1), y(1), d(1), b(1) c n = nn do 10 i = 1,n 10 x(i) = y(i) nsys = n/nsize call bfstm (nsize,nsys,maxt,t,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call bbstm (nsize,nsys,maxb,b,x) return end subroutine bicol (n,nz,ia,ja,count,father,oppos,propa) implicit double precision (a-h, o-z) c c ... bicolor determines whether or not the matrix represented c in the sparse (ia,ja) format is bi-colorable. c the algorithm used is the union-find algorithm. c c ... parameters -- c c n number of vertices c nz number of edges (length of ia and ja vectors) c ia integer vector of i values c ja integer vector of j values c count integer workspace vectors of length n each c father upon output, count gives the color of each node c oppos c propa logical variable indicating on output whether c matrix has property a c c ... specification of parameters c logical propa integer ia(1), ja(1), count(1), father(1), oppos(1) integer v, w, w0, a, b, c, d c do 10 i = 1,n count(i) = 1 father(i) = 0 oppos(i) = 0 10 continue do 60 k = 1,nz if (ia(k) .eq. ja(k)) go to 60 c c ... a = find (ia(k)). c v = ia(k) 15 if (father(v) .eq. 0) go to 20 v = father(v) go to 15 20 w = ia(k) 25 if (father(w) .eq. 0) go to 30 w0 = w w = father(w) father(w0) = v go to 25 30 a = v c c ... b = find (ja(k)). c v = ja(k) 35 if (father(v) .eq. 0) go to 40 v = father(v) go to 35 40 w = ja(k) 45 if (father(w) .eq. 0) go to 50 w0 = w w = father(w) father(w0) = v go to 45 50 b = v c c ... test for a = b. c if (a .ne. b) go to 55 propa = .false. return c c ... do unioning. c 55 if (oppos(a) .eq. b) go to 60 if (oppos(b) .eq. 0) then c = a else c c ... c = merge (a,oppos(b)). c i = a j = oppos(b) if (count(i) .ge. count(j)) then father(j) = i count(i) = count(i) + count(j) c = i else father(i) = j count(j) = count(i) + count(j) c = j endif endif if (oppos(a) .eq. 0) then d = b else c c ... d = merge (b,oppos(a)). c i = b j = oppos(a) if (count(i) .ge. count(j)) then father(j) = i count(i) = count(i) + count(j) d = i else father(i) = j count(j) = count(i) + count(j) d = j endif endif oppos(c) = d oppos(d) = c 60 continue c c ... do coloring. c do 65 i = 1,n 65 count(i) = 0 do 90 i = 1,n c c ... a = find(i). c v = i 70 if (father(v) .eq. 0) go to 75 v = father(v) go to 70 75 w = i 80 if (father(w) .eq. 0) go to 85 w0 = w w = father(w) father(w0) = v go to 80 85 a = v if (count(a) .eq. 0) then count(a) = 1 count(i) = 1 j = oppos(a) if (j .ne. 0) count(j) = 2 else count(i) = count(a) endif 90 continue propa = .true. return end subroutine chgcon (tri,ier) implicit double precision (a-h, o-z) c c ... chgcon computes the new estimates for the largest and c smallest eigenvalues (emax and emin) for conjugate gradient c acceleration. c c ... parameters -- c c tri tridiagonal matrix associated with the eigenvalues c of the conjugate gradient polynomial c ier error code c c ... specifications for parameters c dimension tri(2,2) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c c description of variables in common blocks in main routine c save tl1,tl2,bl1,bl2 ip = is if (ip - 1) 10,20,30 c c ... ip = 0 c 10 end = 1.0d0/alpha tri(1,1) = end tri(2,1)= 0.0d0 if (maxadp) emax = end if (minadp) emin = end return c c ... ip = 1 c 20 t1 = 1.0d0/alpha + beta/alphao t2 = beta/(alphao**2) tri(1,2) = t1 tri(2,2) = t2 tsqr = sqrt (t2) tl1 = tri(1,1) + tsqr tl2 = t1 + tsqr bl1 = tri(1,1) - tsqr bl2 = t1 - tsqr t3 = tri(1,1) + t1 t4 = sqrt ( (t1-tri(1,1))**2 + 4.0d0*t2 ) if (maxadp) emax = (t3 + t4)/2.0d0 if (minadp) emin = (t3 - t4)/2.0d0 return c c ... ip .ge. 2 c 30 t1 = 1.0d0/alpha + beta/alphao t2 = beta/(alphao**2) tsqr = sqrt (t2) tri(1,ip+1) = t1 tri(2,ip+1) = t2 if (.not. maxadp) go to 40 c c ... compute new estimate of emax. c tl1 = max (tl1,tl2+tsqr) tl2 = t1 + tsqr emaxo = emax end = max (tl1,tl2) e1 = eigvss (ip+1,tri,emaxo,end,2,ier) if (ier .ne. 3 .and. ier .ne. 4) go to 35 c c ... poor estimate for emax. therefore need to stop adaptive c procedure and keep old value of emax. c maxadp = .false. if (level .ge. 2) write (nout,31) ier,in,emaxo 31 format (/5x,'estimation of maximum eigenvalue emax halted' a /5x,'routine zbrent returned ier = ',i5 b /5x,'adaptive procedure turned off at iteration ',i5 c /5x,'final estimate of maximum eigenvalue =',d15.7/) go to 40 c c ... valid emax estimate. check for small relative change in emax. c 35 emax = e1 if (abs (emax - emaxo) .lt. emax*zeta) maxadp = .false. c c ... compute new estimate of emin. c 40 if (.not. minadp) return bl1 = min (bl1,bl2-tsqr) bl2 = t1 - tsqr start = max ( 0.0d0, min (bl1,bl2) ) emino = emin e1 = eigvss (ip+1,tri,start,emino,1,ier) if (ier .ne. 3 .and. ier .ne. 4) go to 45 c c ... poor estimate for emin. therefore need to stop adaptive c procedure and keep old value of emin. c minadp = .false. if (level .ge. 2) write (nout,41) ier,in,emino 41 format (/5x,'estimation of minimum eigenvalue emin halted' a /5x,'routine zbrent returned ier = ',i5 b /5x,'adaptive procedure turned off at iteration ',i5 c /5x,'final estimate of minimum eigenvalue =',d15.7/) return c c ... valid emin estimate. check for small relative change in emin. c 45 emin = e1 if (abs (emin - emino) .lt. emin*zeta) minadp = .false. return end subroutine chgsi (suba,coef,jcoef,wfac,jwfac,nn,z,wksp, a icode,ier) implicit double precision (a-h, o-z) c c ... chgsi adapts on the iteration parameters. c c ... parameters -- c c n order of system (= nn) c z current pseudo-residual vector c wksp workspace vector of length n c icode output indicator of parameter changes c = 0 estimates of emax, emin not changed c = 1 estimates of emax, emin changed c ier error code c c ... specifications for parameters c external suba integer jcoef(2), jwfac(1) dimension z(1), wksp(1), coef(1), wfac(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c n = nn c istar = 3 icode = 0 if (is .eq. 0) return rnrm = sqrt (rzdot) rnrmq = sqrt (dkq) rnrm1 = sqrt (dkm1) qa = rnrm/rnrmq t1 = rr**is qt = 2.0d0*sqrt (t1)/(1.0d0 + t1) if (qa .le. qt**ff) return if (qa .le. 1.0d0 .and. is .le. istar) return icode = 1 c c ... compute rayleigh quotient. c ... rq = (z,a*z)/(r,z) c call suba (coef,jcoef,wfac,jwfac,n,z,wksp) top= 0.0d0 do 10 i = 1,n 10 top = top + z(i)*wksp(i) if (top .ge. 0.0d0) go to 15 ier = -6 call ershow (ier,'chgsi') return 15 rq = top/rzdot kode = 0 if (rq .gt. rqmax) kode = 1 rqmin = min (rq,rqmin) rqmax = max (rq,rqmax) yy = (1.0d0+t1)*(qa+sqrt (qa*qa-qt*qt))/2.0d0 xx = yy**(1.0d0/dble (is)) if (qa .gt. 1.0d0) go to 25 if (kode .eq. 1) go to 25 c c ... emin adjustment. c eminp = (emax+emin)*(1.0d0-xx)*(xx-rr)/(2.0d0*xx*(rr+1.0d0)) if (minadp) emin = min (emin,eminp,rqmin) if (maxadp) emax = max (emax,rqmax) if (level .ge. 2) write (nout,20) in,rq,eminp,emin,emax 20 format (/1x,15x,'parameters were changed at iteration',i7/ a 1x,20x,'rayleigh quotient ',f15.9/ a 1x,20x,'young estimate ',f15.9/ a 1x,20x,'emin ',f15.9/ a 1x,20x,'emax ',f15.9/) return c c ... emax adjustment. c 25 emaxp = (emax+emin)*(1.0d0+xx)*(xx+rr)/(2.0d0*xx*(rr+1.0d0)) uu = ((1.0d0+t1)/(1.0d0+rr**(is-1))) * (rnrm/rnrm1) emaxpp = (emax+emin)*(1.0d0+uu)*(uu+rr)/(2.0d0*uu*(rr+1.0d0)) if (maxadp) emax = max (emax,1.1d0*emaxp,1.1d0*emaxpp,1.1d0*rqmax) if (minadp) emin = rqmin if (level .ge. 2) write (nout,30) in,rq,emaxp,emaxpp,emin,emax 30 format (/1x,15x,'parameters were changed at iteration',i7/ a 1x,20x,'rayleigh quotient ',f15.9/ a 1x,20x,'young estimate ',f15.9/ a 1x,20x,'hageman estimate ',f15.9/ a 1x,20x,'emin ',f15.9/ a 1x,20x,'emax ',f15.9/) return end subroutine color (nxp,nyp,nzp,nx,ny,nz,pp,p) implicit double precision (a-h, o-z) c c ... routine color reproduces a color pattern given by array c pp of dimensions nxp x nyp x nzp into the grid color c array p of dimensions nx x ny x nz. c c ... parameters -- c c nxp, integer variables giving the x, y, and z dimensions c nyp, of the pattern array, respectively. c nzp c nx,ny, integer variables giving the x, y, and z dimensions c nz of the grid, respectively. c pp integer vector of length nxp*nyp*nzp c giving the color pattern to be repeated c p integer vector of length nxg*nyg*nzg c which contains upon output the grid coloring c c ... specifications for parameters c integer pp (nxp,nyp,nzp), p (nx,ny,nz) c do 30 k = 1,nz kp = mod (k - 1, nzp) + 1 do 20 j = 1,ny jp = mod (j - 1, nyp) + 1 do 10 i = 1,nx ip = mod (i - 1, nxp) + 1 p (i,j,k) = pp (ip,jp,kp) 10 continue 20 continue 30 continue return end subroutine defcon (ndim,nn,maxnz,jcoef,coef,kblsz,iblock,lbhb) implicit double precision (a-h, o-z) c c ... define defines block constants for block-structured matrices. c (diagonal data structure, constant block size) c c ... parameters -- c c ndim row dimension of coef array in defining routine c nn size of system c maxnz number of diagonals in coef c jcoef integer vector of size maxnz giving the diagonal c numbers c coef matrix representation array c kblsz constant block size c iblock integer array of size 3 by lbhb c giving block constants upon output c lbhb integer giving the number of diagonal blocks c upon output. c c ... specifications for parameters c integer jcoef(2), iblock(3,3) dimension coef(ndim,1) c n = nn ipt = 2 iblock(1,1) = 0 iblock(1,2) = 0 iblock(2,1) = 1 iblock(3,1) = 0 iblock(3,2) = 0 do 25 j = 1,maxnz jd = jcoef(j) do 10 i = 1,n if (coef(i,j) .ne. 0.0d0) go to 15 10 continue go to 25 15 jcol = i + jd c c ... find block for jcol. c ib = (i-1)/kblsz + 1 jb = (jcol-1)/kblsz + 1 id = jb - ib if (id .eq. iblock(1,ipt)) go to 20 ipt = ipt + 1 iblock(1,ipt) = id iblock(3,ipt) = 0 20 iblock(3,ipt) = iblock(3,ipt) + 1 25 continue lbhb = ipt c c ... split zero diagonal block into super and sub diagonals. c jlim = iblock(3,2) do 30 j = 1,jlim jd = jcoef(j) if (jd .lt. 0) go to 35 iblock(3,1) = iblock(3,1) + 1 iblock(3,2) = iblock(3,2) - 1 30 continue j = jlim + 1 35 iblock(2,2) = j c c ... form starting positions. c if (lbhb .le. 2) return iblock(2,3) = 1 if (lbhb .le. 3) return do 40 j = 4,lbhb 40 iblock(2,j) = iblock(2,j-1) + iblock(3,j-1) return end subroutine define (ndim,maxnew,jcnew,coef,ncol,nc, a iblock,lbhb) implicit double precision (a-h, o-z) c c ... define defines block constants for block-structured matrices. c (diagonal data structure, nonconstant block size) c c ... parameters -- c c ndim row dimension of coef array in defining routine c maxnew integer vector giving the number of diagonals c for each distinct block size. c jcnew integer array of size ncolor*max(maxnew(i)) c giving the diagonal numbers for each distinct c block size. c coef matrix representation array c ncolor number of distinct block sizes c nc integer vector of length ncolor, giving the number c of nodes for each distinct block size. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants upon output c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size c upon output. c c ... specifications for parameters c integer maxnew(ncol), jcnew(ncol,1), nc(ncol), lbhb(ncol), a iblock(3,ncol,3) dimension coef(ndim,1) c ncolor = ncol ist = 1 do 60 k = 1,ncolor ncc = nc(k) maxnz = maxnew(k) ied = ist + ncc - 1 ipt = 2 iblock(1,k,1) = 0 iblock(1,k,2) = 0 iblock(2,k,1) = 1 iblock(3,k,1) = 0 iblock(3,k,2) = 0 do 35 j = 1,maxnz jd = jcnew(k,j) do 10 i = ist,ied if (coef(i,j) .ne. 0.0d0) go to 15 10 continue go to 35 15 jcol = i + jd c c ... find block for jcol. c ib = k js = 0 do 20 ij = 1,ncolor js = js + nc(ij) if (js .ge. jcol) go to 25 20 continue 25 jb = ij id = jb - ib if (id .eq. iblock(1,k,ipt)) go to 30 ipt = ipt + 1 iblock(1,k,ipt) = id iblock(3,k,ipt) = 0 30 iblock(3,k,ipt) = iblock(3,k,ipt) + 1 35 continue lbhb(k) = ipt c c ... split zero diagonal block into super and sub diagonals. c jlim = iblock(3,k,2) do 40 j = 1,jlim jd = jcnew(k,j) if (jd .lt. 0) go to 45 iblock(3,k,1) = iblock(3,k,1) + 1 iblock(3,k,2) = iblock(3,k,2) - 1 40 continue j = jlim + 1 45 iblock(2,k,2) = j c c ... form starting positions. c jlim = lbhb(k) if (jlim .le. 2) go to 55 iblock(2,k,3) = 1 if (jlim .le. 3) go to 55 do 50 j = 4,jlim 50 iblock(2,k,j) = iblock(2,k,j-1) + iblock(3,k,j-1) 55 ist = ied + 1 60 continue return end double precision function determ (n,tri,xlmda) implicit double precision (a-h, o-z) c c determ computes the determinant of a symmetric c tridiagonal matrix given by tri. det(tri - xlmda*i) = 0 c c ... parameters -- c c n order of tridiagonal system c tri symmetric tridiagonal matrix of order n c xlmda argument for characteristic equation c c ... specifications for parameters c dimension tri(2,1) c nm1 = n - 1 d2 = tri(1,n) - xlmda d1 = d2 * (tri(1,nm1) - xlmda) - tri(2,n) if (n .eq. 2) go to 20 c c ... beginning of loop c do 10 l = nm1,2,-1 d3 = d2 d2 = d1 d1 = (tri(1,l-1) - xlmda) * d2 - d3 * tri(2,l) 10 continue c c ... determinant computed c 20 determ = d1 c return end subroutine detsym (ndim,maxnzz,coef,jcoef,nn,isymm) implicit double precision (a-h, o-z) c c ... detsym determines if the matrix is symmetric. c (purdue storage format) c c ... parameters -- c c ndim row dimension of coef in defining routine c maxnz number of columns in coef c coef array of matrix nonzeros c jcoef array of matrix column numbers c n order of matrix (= nn) c isymm symmetry switch. upon output, c isymm = 0 if matrix is symmetric c = 1 if matrix is nonsymmetric c c ... specifications for parameters c dimension coef(ndim,2) integer jcoef(ndim,2) c n = nn maxnz = maxnzz isymm = 0 if (maxnz .le. 1) return do 20 i = 1,n do 15 j = 2,maxnz jcol = jcoef(i,j) if (jcol .eq. i) go to 15 val = coef(i,j) do 10 jj = 2,maxnz jcol1 = jcoef(jcol,jj) if (jcol1 .ne. i) go to 10 val1 = coef(jcol,jj) if (val1 .eq. val) go to 15 isymm = 1 return 10 continue isymm = 1 return 15 continue 20 continue return end subroutine echall (n,iparm,rparm,icall,icallr,ier) implicit double precision (a-h, o-z) c c ... echall initializes the package common blocks from the c ... information contained in iparm and rparm. echall also c ... prints the values of all parameters in iparm and rparm. c c ... parameters -- c c iparm c and c rparm arrays of parameters specifying options and c tolerances c icall indicator of which parameters are being printed c icall = 1, initial parameters c = 2, final parameters c icallr indicator of calling routine c = 1, called from nspcg c = 2, called from accelerator c c ... specifications for parameters c c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp common / itcom6 / method, iscale, iperm, nstore, a ifact, kblsz, lvfill, ltrunc, ndeg, a ipropa, isymm, ifctv common / itcom8 / ainf c c *** end -- package common c logical erflag integer iparm(25) dimension rparm(16) character*6 inames(25), rnames(16) data naiprm, narprm / 11,12 / data inames / 'ntest', 'itmax', 'level', 'nout', 'idgts', a 'maxadp', 'minadp', 'iomgad', 'ns1', 'ns2', 'ns3', a 'nstore', 'iscale', 'iperm', 'ifact', 'lvfill', a 'ltrunc', 'ipropa', 'kblsz', 'nbl2d', 'ifctv', a 'iqlr', 'isymm', 'ielim', 'ndeg' / data rnames / 'zeta', 'emax', 'emin', 'ff', 'fff', 'timit', a 'digit1', 'digit2', 'omega', 'alphab', 'betab', a 'specr', 'timfac', 'timtot', 'tol', 'ainf' / c if (icall .ne. 1) go to 20 c c handle accelerator parameters ... c ntest = iparm(1) itmax = iparm(2) level = iparm(3) nout = iparm(4) idgts = iparm(5) maxad = iparm(6) maxadd = (maxad .eq. 1) minad = iparm(7) minadd = (minad .eq. 1) maxadp = maxadd minadp = minadd iomgad = iparm(8) omgadp = (iomgad .eq. 1) ns1 = iparm(9) ns2 = iparm(10) ns3 = iparm(11) iqlr = iparm(22) iplr = iqlr c zeta = rparm(1) emax = rparm(2) emin = rparm(3) ff = rparm(4) fff = rparm(5) timit = rparm(6) digit1 = rparm(7) digit2 = rparm(8) omega = rparm(9) alphab = rparm(10) betab = rparm(11) specr = rparm(12) c erflag = .false. erflag = erflag .or. ntest .lt. 1 .or. ntest .gt. 10 erflag = erflag .or. itmax .le. 0 erflag = erflag .or. maxad .lt. 0 .or. maxad .gt. 1 erflag = erflag .or. minad .lt. 0 .or. minad .gt. 1 erflag = erflag .or. ns1 .lt. 0 erflag = erflag .or. ns2 .lt. 0 erflag = erflag .or. emax .lt. 0.0d0 erflag = erflag .or. emin .lt. 0.0d0 erflag = erflag .or. ff .le. 0.0d0 .or. ff .gt. 1.0d0 if (erflag) go to 999 c c ... test if eps is too small c temp = 500.0d0*srelpr if (zeta .ge. temp) go to 150 ier = 2 call ershow (ier,'echall') zeta = temp rparm(1) = temp c c ... verify n c 150 if (n .gt. 0 ) go to 200 ier = -1 call ershow (ier,'echall') return c c now handle preconditioner parameters ... c 200 if (icallr .eq. 2) go to 50 nstore = iparm(12) iscale = iparm(13) iperm = iparm(14) ifact = iparm(15) lvfill = iparm(16) ltrunc = iparm(17) ipropa = iparm(18) nbl1d = iparm(19) nbl2d = iparm(20) ifctv = iparm(21) iqlr = iparm(22) isymm = iparm(23) ndeg = iparm(25) ainf = rparm(16) c if (nbl1d .eq. -1) nbl1d = n if (nbl2d .eq. -1) nbl2d = n kblsz = nbl1d erflag = .false. erflag = erflag .or. iqlr .lt. 0 .or. iqlr .gt. 3 erflag = erflag .or. ipropa .lt. 0 .or. ipropa .gt. 3 if (erflag) go to 999 c c c ... initialize rest of common variables c 50 halt = .false. stptst= 0.0d0 udnm = 1.0d0 in = 0 c c prepare to do output ... c if (level .le. 2) return write (nout,15) 15 format (/5x,'initial iterative parameters') go to 30 c 20 if (level .le. 2) return write (nout,25) 25 format (/5x,'final iterative parameters') c 30 if (icallr .eq. 2) go to 305 write (nout,301) 301 format (5x,'preprocessor and preconditioner parameters') ibip = naiprm + 1 ieip = 25 ibrp = narprm + 1 ierp = 16 go to 300 305 write (nout,302) 302 format (5x,'general and acceleration parameters') ibip = 1 ieip = naiprm ibrp = 1 ierp = narprm c 300 write (nout,35) (i,iparm(i),inames(i),i=ibip,ieip) 35 format (10x,'iparm(',i2,') =',i15,4x,'(',a6,')' ) write (nout,40) (i,rparm(i),rnames(i),i=ibrp,ierp) 40 format (10x,'rparm(',i2,') =',d15.8,4x,'(',a6,')' ) return c c error returns ... c c inadmissible option ... 999 ier = -10 call ershow (ier,'echall') return end double precision function eigvss (n,tri,start,end,icode,ier) implicit double precision (a-h, o-z) c c ... eigvss computes a selected eigenvalue of a symmetric c tridiagonal matrix for conjugate gradient acceleration. c modified imsl routine zbrent used. c c ... parameters -- c c n order of tridiagonal system c tri symmetric tridiagonal matrix of order n c start initial lower bound of interval containing root c end initial upper bound of interval containing root c icode operation key c = 1 minimum eigenvalue sought c = 2 maximum eigenvalue sought c ier error flag c c ... specifications for parameters c dimension tri(2,1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c eigvss= 0.0d0 itmp = int (-dlog10 (abs (zeta))) nsig = max (itmp,4) maxfn = max (itmax,50) eps= 0.0d0 a = start b = end call zbrent (n,tri,eps,nsig,a,b,maxfn,ier) if (icode .eq. 1) eigvss = max (a,b) if (icode .eq. 2) eigvss = min (a,b) c return end subroutine elim1 (nn,ndim,maxnzz,jcoef,coef,rhs,wksp,toll) implicit double precision (a-h, o-z) c c ... elim1 removes rows of the matrix for which the ratio of the c sum of off-diagonal elements to the diagonal element is c small (less than tol) in absolute value. c this is to take care of matrices arising from finite c element discretizations of partial differential equations c with dirichlet boundary conditions implemented by penalty c methods. any such rows and corresponding columns are then c eliminated (set to the identity after correcting the rhs). c purdue format. c c ... parameter list -- c c n dimension of matrix ( = nn) c ndim row dimension of arrays jcoef and coef in the c calling program c maxnz maximum number of nonzero entries per row (=maxnzz) c jcoef integer array of matrix representation c coef array of sparse matrix representation c rhs right hand side of matrix problem c wksp wksp array of length n c tol tolerance factor (= toll) c c ... specifications for arguments c integer jcoef(ndim,1) dimension coef(ndim,1), rhs(1), wksp(1) c n = nn maxnz = maxnzz tol = toll if (n .le. 0 .or. maxnz .lt. 2) return c c ... find maximum off-diagonal elements in absolute value. c do 10 i = 1,n 10 wksp(i)= 0.0d0 do 20 j = 2,maxnz do 15 i = 1,n 15 wksp(i) = wksp(i) + abs (coef(i,j)) 20 continue do 25 i = 1,n 25 wksp(i) = wksp(i) / abs(coef(i,1)) c c ... eliminate desired rows and columns. c do 35 i = 1,n if (wksp(i) .gt. tol) go to 35 rhs(i) = rhs(i)/coef(i,1) coef(i,1) = 1.0d0 do 30 j = 2,maxnz coef(i,j)= 0.0d0 jcoef(i,j) = i 30 continue 35 continue do 45 j = 2,maxnz do 40 i = 1,n jcol = jcoef(i,j) if (wksp(jcol) .gt. tol) go to 40 rhs(i) = rhs(i) - coef(i,j)*rhs(jcol) coef(i,j)= 0.0d0 jcoef(i,j) = i 40 continue 45 continue return end subroutine elim2 (nn,ndim,maxnzz,jcoef,coef,rhs,wksp,toll) implicit double precision (a-h, o-z) c c ... elim2 removes rows of the matrix for which the ratio of the c sum of off-diagonal elements to the diagonal element is c small (less than tol) in absolute value. c this is to take care of matrices arising from finite c element discretizations of partial differential equations c with dirichlet boundary conditions implemented by penalty c methods. any such rows and corresponding columns are then c eliminated (set to the identity after correcting the rhs). c symmetric diagonal format. c c ... parameter list -- c c n dimension of matrix ( = nn) c ndim row dimension of array coef in the c calling program c maxnz number of diagonals stored c jcoef integer vector of diagonal numbers c coef array of sparse matrix representation c rhs right hand side of matrix problem c wksp wksp array of length n c tol tolerance factor (= toll) c c ... specifications for arguments c integer jcoef(1) dimension coef(ndim,1), rhs(1), wksp(1) c n = nn maxnz = maxnzz tol = toll if (n .le. 0 .or. maxnz .lt. 2) return c c ... find maximum off-diagonal elements in absolute value. c do 10 i = 1,n 10 wksp(i)= 0.0d0 do 25 j = 2,maxnz ind = jcoef(j) len = n - ind do 15 i = 1,len 15 wksp(i) = wksp(i) + abs (coef(i,j)) do 20 i = 1,len 20 wksp(i+ind) = wksp(i+ind) + abs (coef(i,j)) 25 continue do 30 i = 1,n 30 wksp(i) = wksp(i) / abs(coef(i,1)) c c ... eliminate desired rows and columns. c do 50 i = 1,n if (wksp(i) .gt. tol) go to 50 rhs(i) = rhs(i)/coef(i,1) coef(i,1) = 1.0d0 do 40 j = 2,maxnz jcol = jcoef(j) iback = i - jcol iforw = i + jcol if (iforw .gt. n) go to 35 if (wksp(iforw) .le. tol) go to 35 rhs(iforw) = rhs(iforw) - coef(i,j)*rhs(i) 35 if (iback .lt. 1) go to 40 rhs(iback) = rhs(iback) - coef(iback,j)*rhs(i) coef(iback,j)= 0.0d0 40 continue do 45 j = 2,maxnz 45 coef(i,j)= 0.0d0 50 continue return end subroutine elim3 (nn,ndim,maxnzz,jcoef,coef,rhs,wksp,toll) implicit double precision (a-h, o-z) c c ... elim3 removes rows of the matrix for which the ratio of the c sum of off-diagonal elements to the diagonal element is c small (less than tol) in absolute value. c this is to take care of matrices arising from finite c element discretizations of partial differential equations c with dirichlet boundary conditions implemented by penalty c methods. any such rows and corresponding columns are then c eliminated (set to the identity after correcting the rhs). c nonsymmetric diagonal format. c c ... parameter list -- c c n dimension of matrix ( = nn) c ndim row dimension of array coef in the c calling program c maxnz number of diagonals stored c jcoef integer vector of diagonal numbers c coef array of sparse matrix representation c rhs right hand side of matrix problem c wksp wksp array of length n c tol tolerance factor (= toll) c c ... specifications for arguments c integer jcoef(1) dimension coef(ndim,1), rhs(1), wksp(1) c n = nn maxnz = maxnzz tol = toll if (n .le. 0 .or. maxnz .lt. 2) return c c ... find maximum off-diagonal elements in absolute value. c do 10 i = 1,n 10 wksp(i)= 0.0d0 do 20 j = 2,maxnz ind = jcoef(j) ist1 = max (1,1 - ind) ist2 = min (n,n - ind) do 15 i = ist1,ist2 15 wksp(i) = wksp(i) + abs (coef(i,j)) 20 continue do 25 i = 1,n 25 wksp(i) = wksp(i) / abs(coef(i,1)) c c ... eliminate desired rows and columns. c do 35 i = 1,n if (wksp(i) .gt. tol) go to 35 rhs(i) = rhs(i)/coef(i,1) coef(i,1) = 1.0d0 do 30 j = 2,maxnz 30 coef(i,j)= 0.0d0 35 continue do 45 i = 1,n if (wksp(i) .gt. tol) go to 45 do 40 j = 2,maxnz inew = i - jcoef(j) if (inew .lt. 1 .or. inew .gt. n) go to 40 rhs(inew) = rhs(inew) - coef(inew,j)*rhs(i) coef(inew,j)= 0.0d0 40 continue 45 continue return end subroutine elim4 (mm,np,ia,ja,a,rhs,wksp,toll) implicit double precision (a-h, o-z) c c ... elim4 removes rows of the matrix for which the ratio of the c sum of off-diagonal elements to the diagonal element is c small (less than tol) in absolute value. c this is to take care of matrices arising from finite c element discretizations of partial differential equations c with dirichlet boundary conditions implemented by penalty c methods. any such rows and corresponding columns are then c eliminated (set to the identity after correcting the rhs). c symmetric sparse format. c c ... parameter list -- c c m number of partitions c np pointer vector to partitions c ia vector of i values c ja vector of j values c a vector of coefficients c rhs right hand side of matrix problem c wksp wksp vector of length n (2n if keygs = 1) c tol tolerance factor (= toll) c c ... specifications for arguments c integer ia(1), ja(1), np(2) dimension a(1), rhs(1), wksp(1) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c m = mm n = np(2) - 1 nz = np(m+1) - 1 tol = toll np1 = n + 1 c c ... find sum of absolute values of off-diagonal coefficients. c do 10 i = 1,n 10 wksp(i)= 0.0d0 if (keygs .eq. 1) go to 30 do 25 k = 2,m ist = np(k) ied = np(k+1) - 1 cdir$ ivdep do 15 i = ist,ied 15 wksp(ia(i)) = wksp(ia(i)) + abs(a(i)) cdir$ ivdep do 20 i = ist,ied 20 wksp(ja(i)) = wksp(ja(i)) + abs(a(i)) 25 continue go to 50 30 do 45 k = 2,m ist = np(k) ied = np(k+1) - 1 len = ied - ist + 1 call vgathr (len,wksp,ia(ist),wksp(n+1)) do 35 i = ist,ied 35 wksp(i-ist+1+n) = wksp(i-ist+1+n) + abs(a(i)) call vscatr (len,wksp(n+1),ia(ist),wksp) call vgathr (len,wksp,ja(ist),wksp(n+1)) do 40 i = ist,ied 40 wksp(i-ist+1+n) = wksp(i-ist+1+n) + abs(a(i)) call vscatr (len,wksp(n+1),ja(ist),wksp) 45 continue 50 do 55 i = 1,n 55 wksp(i) = wksp(i) / abs(a(i)) c c ... eliminate desired rows and columns. c do 70 l = 1,n if (wksp(l) .gt. tol) go to 70 rhs(l) = rhs(l)/a(l) a(l) = 1.0d0 do 60 k = np1,nz i = ia(k) j = ja(k) if (i .eq. l .and. wksp(j) .gt. tol) a rhs(j) = rhs(j) - a(k)*rhs(i) if (j .ne. l) go to 60 rhs(i) = rhs(i) - a(k)*rhs(j) a(k) = 0.0d0 60 continue do 65 k = np1,nz if (ia(k) .eq. l) a(k) = 0.0d0 65 continue 70 continue return end subroutine elim5 (mm,np,ia,ja,a,rhs,wksp,toll) implicit double precision (a-h, o-z) c c ... elim5 removes rows of the matrix for which the ratio of the c sum of off-diagonal elements to the diagonal element is c small (less than tol) in absolute value. c this is to take care of matrices arising from finite c element discretizations of partial differential equations c with dirichlet boundary conditions implemented by penalty c methods. any such rows and corresponding columns are then c eliminated (set to the identity after correcting the rhs). c nonsymmetric sparse format. c c ... parameter list -- c c m number of partitions c np pointer vector to partitions c ia vector of i values c ja vector of j values c a vector of coefficients c rhs right hand side of matrix problem c wksp wksp vector of length n (2n if keygs = 1) c tol tolerance factor (= toll) c c ... specifications for arguments c integer ia(1), ja(1), np(2) dimension a(1), rhs(1), wksp(1) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c m = mm n = np(2) - 1 nz = np(m+1) - 1 tol = toll c c ... find sum of absolute values of off-diagonal coefficients. c do 10 i = 1,n 10 wksp(i)= 0.0d0 if (keygs .eq. 1) go to 25 do 20 k = 2,m ist = np(k) ied = np(k+1) - 1 cdir$ ivdep do 15 i = ist,ied 15 wksp(ia(i)) = wksp(ia(i)) + abs(a(i)) 20 continue go to 40 25 do 35 k = 2,m ist = np(k) ied = np(k+1) - 1 len = ied - ist + 1 call vgathr (len,wksp,ia(ist),wksp(n+1)) do 30 i = ist,ied 30 wksp(i-ist+1+n) = wksp(i-ist+1+n) + abs(a(i)) call vscatr (len,wksp(n+1),ia(ist),wksp) 35 continue 40 do 45 i = 1,n 45 wksp(i) = wksp(i) / abs(a(i)) c c ... eliminate desired rows and columns. c do 50 i = 1,n if (wksp(i) .gt. tol) go to 50 rhs(i) = rhs(i)/a(i) a(i) = 1.0d0 50 continue np1 = n + 1 do 55 k = np1,nz if (wksp(ia(k)) .le. tol) a(k) = 0.0d0 55 continue do 60 k = np1,nz j = ja(k) if (wksp(j) .gt. tol) go to 60 i = ia(k) rhs(i) = rhs(i) - a(k)*rhs(j) a(k) = 0.0d0 60 continue return end subroutine ershow (ierr,iname) implicit double precision (a-h, o-z) c c ... ershow prints an appropriate error message for the error c numbered ier. c c ... parameters -- c c ier error number (input) c .gt. 0 for warning errors c .lt. 0 for fatal errors c iname routine name in which error occurred c c ... specifications for parameters c character*10 iname c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c character*80 fmess(20), wmess(6) data fmess(1) / 'nonpositive matrix size n' / data fmess(2) / 'insufficient floating point workspace' / data fmess(3) / 'insufficient integer workspace' / data fmess(4) / 'nonpositive diagonal element' / data fmess(5) / 'nonexistent diagonal element' / data fmess(6) / 'a is not positive definite' / data fmess(7) / 'q is not positive definite' / data fmess(8) / 'unable to permute matrix as requested' / data fmess(9) / 'mdim not large enough to expand matrix' / data fmess(10) / 'inadmissible parameter encountered' / data fmess(11) / 'incorrect storage mode for block method' / data fmess(12) / 'zero pivot encountered during factorization' / data fmess(13) / 'breakdown in direction vector calculation' / data fmess(14) / 'breakdown in attempt to perform rotation' / data fmess(15) / 'breakdown in iterate calculation' / data fmess(16) / 'unimplemented combination of parameters' / data fmess(17) / 'error in computing preconditioning polynomial' / data fmess(18) / 'unable to perform eigenvalue estimation' / data fmess(19) / 'iterative method has gone to sleep' / data fmess(20) / 'unknown error' / data wmess(1) / 'failure to converge in itmax iterations' / data wmess(2) / 'zeta too small' / data wmess(3) / 'no convergence in maxfn iterations in zbrent' / data wmess(4) / 'f(a) and f(b) have the same sign in zbrent' / data wmess(5) / 'negative pivot encountered in factorization' / data wmess(6) / 'unknown warning' / c ier = ierr if (ier .eq. 0) return if (ier .lt. 0 .and. level .lt. 0) return if (ier .gt. 0 .and. level .lt. 1) return if (ier .lt. -19) ier = -20 if (ier .gt. 5) ier = 6 if (ier .lt. 0) write (nout,10) 10 format (//1x,60('*') / a 1x,18('*'),' f a t a l e r r o r ',18('*') / a 1x,60('*') /) if (ier .gt. 0) write (nout,20) 20 format (//1x,60('*') / a 1x,16('*'),' w a r n i n g e r r o r ',16('*') / a 1x,60('*') /) write (nout,23) iname 23 format (1x,'routine ',a10) inum = iabs(ier) if (ier .gt. 0) go to 30 c c ... print out fatal errors. c write (nout,25) fmess(inum) 25 format (1x,a80) go to 999 c c ... print out warning errors. c 30 write (nout,25) wmess(inum) if (inum .ne. 2) go to 999 temp = 500.0d0*srelpr write (nout,35) zeta, srelpr, temp 35 format (1x,'rparm(1) =',d10.3,' (zeta)' a / 1x, 'a value this small may hinder convergence' a / 1x, 'since machine precision srelpr = ',d10.3 a / 1x, 'zeta reset to ',d10.3) c c ... print ending line. c 999 write (nout,1000) 1000 format (/1x,60('*')/) return end subroutine filln (maxnz,jcoef) implicit double precision (a-h, o-z) c c ... filln determines the fill-in diagonals for nonsymmetric c diagonal storage. c c ... parameters -- c c maxnz upon input, the number of diagonals c upon output, the number of diagonals with fill-in c jcoef upon input, the diagonal numbers c upon output, the diagonal numbers with fill-in c c ... specifications for parameters c integer jcoef(2) c maxn = maxnz do 20 j1 = 1,maxnz do 15 j2 = 1,maxnz jd = jcoef(j1) + jcoef(j2) if (jcoef(j1)*jcoef(j2) .ge. 0) go to 15 do 10 j3 = 1,maxn if (jcoef(j3) .eq. jd) go to 15 10 continue maxn = maxn + 1 jcoef(maxn) = jd 15 continue 20 continue maxnz = maxn return end subroutine fills (maxt,jt) implicit double precision (a-h, o-z) c c ... fills determines the fill-in diagonals for symmetric c diagonal storage. c c ... parameters -- c c maxt upon input, the number of diagonals in the c upper triangle c upon output, the number of diagonals in the c upper triangle with fill-in c jt upon input, the diagonal numbers in the upper c triangle c upon output, the diagonal numbers in the upper c triangle with fill-in c c ... specifications for parameters c integer jt(1) c maxn = maxt do 20 j1 = 1,maxt do 15 j2 = 1,maxt jd = jt(j1) - jt(j2) if (jd .le. 0) go to 15 do 10 j3 = 1,maxn if (jt(j3) .eq. jd) go to 15 10 continue maxn = maxn + 1 jt(maxn) = jd 15 continue 20 continue maxt = maxn return end subroutine fillnp (ndim,nn,maxcc,jc,c,mwidth,ier) implicit double precision (a-h, o-z) c c ... fillnp determines the fill-in structure. c (purdue storage, nonsymmetric matrix) c c ... parameters -- c c ndim row dimension of jc and c arrays c n order of system (= nn) c maxc upon input, maxc is the number of columns in c the c array c upon output, maxc is the number of columns in c the c array with fill-in c jc integer array of active size n by maxc giving the c column numbers of the corresponding elements in c c c array of active size n by maxc giving the c coefficients of the off-diagonal elements c mwidth maximum column width to be allowed for fill-in c ier error code c = 0 no errors detected c = -2 mwidth too small to accomodate fill-in c c ... specifications for parameters c integer jc(ndim,1) dimension c(ndim,1) c c n = nn maxc = maxcc maxu = maxc c if (maxc .lt. 1) return nm1 = n - 1 do 45 k = 1,nm1 kp1 = k + 1 do 40 j1 = 1,maxc do 35 i = kp1,n if (jc(i,j1) .ne. k) go to 35 do 30 j2 = 1,maxc j = jc(k,j2) if (j .le. k .or. j .eq. i) go to 30 do 10 j3 = 1,maxu if (j .eq. iabs(jc(i,j3))) go to 30 10 continue do 15 j3 = 1,maxu if (jc(i,j3) .ne. i) go to 15 jc(i,j3) = -j go to 30 15 continue maxu = maxu + 1 if (maxu .le. mwidth) go to 20 ier = -2 return 20 do 25 ii = 1,n jc(ii,maxu) = ii c(ii,maxu)= 0.0d0 25 continue jc(i,maxu) = -j 30 continue 35 continue 40 continue 45 continue c c ... decode new elements of jt, jb. c do 55 j = 1,maxu do 50 i = 1,n 50 jc(i,j) = iabs(jc(i,j)) 55 continue maxcc = maxu return end subroutine fillsp (ndim,nn,maxtt,jt,t,mwidth,ier) implicit double precision (a-h, o-z) c c ... fillsp determines the fill-in structure. c (purdue storage, symmetric matrix) c c ... parameters -- c c ndim row dimension of t and jt arrays c n order of system (= nn) c maxt upon input, maxt is the number of columns in c the t array c upon output, maxt is the number of columns in c the t array with fill-in c jt integer array of active size n by maxt giving the c column numbers of the corresponding elements in t c t array of active size n by maxt giving the c coefficients of the upper triangle of the matrix c mwidth maximum column width of jt and t to be allowed c ier error code c = 0 no error detected c = -2 mwidth too small to store factor c c ... specifications for parameters c dimension t(ndim,1) integer jt(ndim,1) c c n = nn maxt = maxtt maxu = maxt ier = 0 c if (maxt .lt. 1) return nm1 = n - 1 do 40 k = 1,nm1 do 35 j1 = 1,maxt jcol1 = jt(k,j1) if (jcol1 .le. 0 .or. jcol1 .eq. k) go to 35 do 30 j2 = 1,maxt jcol2 = jt(k,j2) if (jcol2 .le. 0 .or. jcol2 .eq. k) go to 30 if (jcol2 .le. jcol1) go to 30 do 10 j3 = 1,maxu if (jcol2 .eq. iabs(jt(jcol1,j3))) go to 30 10 continue do 15 j3 = 1,maxu if (jt(jcol1,j3) .ne. jcol1) go to 15 jt(jcol1,j3) = -jcol2 go to 30 15 continue maxu = maxu + 1 if (maxu .le. mwidth) go to 20 ier = -2 return 20 do 25 i = 1,n jt(i,maxu) = i t(i,maxu) = 0.0d0 25 continue jt(jcol1,maxu) = -jcol2 30 continue 35 continue 40 continue c c ... decode new elements of jt. c do 50 j = 1,maxu do 45 i = 1,n 45 jt(i,j) = iabs(jt(i,j)) 50 continue maxtt = maxu return end subroutine ibfcn1 (lddd,ldtt,n,jd,jt,d,t,ncol,nci, a iblock,lbhb,iunif,ipropa,ipt, a omega,wksp,ier) implicit double precision (a-h, o-z) c c ... ibfcn1 does an incomplete block factorization of the matrix c contained in d and t (version 1, unmodified). c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic (version 1) preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c jd integer array of size ncolor by whatever c giving the diagonal block diagonal numbers for c each distinct block size. jd is 1 by whatever c if iunif = 1. c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c d array for diagonal block c t array for off-diagonal blocks c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c ipropa property a switch c = 0 matrix does not have block property a c = 1 matrix has block property a c ipt integer pointer vector of length ncolor+1 if c iunif = 0 c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jd(ncol,1), jt(ncol,1), nci(1), lbhb(1), a iblock(3,ncol,2) dimension d(lddd,1), t(ldtt,1), wksp(1) logical unif, propa c ldd = lddd ldt = ldtt ncolor = ncol unif = iunif .eq. 1 propa = ipropa .eq. 1 c c ... define various constants. c if (unif) go to 15 klim = ncolor go to 20 15 kblsz = nci(1) na = kblsz nb = kblsz nc = kblsz ii = 1 kk = 1 jlim = lbhb(1) llim = jlim klim = n/kblsz ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) ma = ndt + ndb + 1 c c ... start factorization. c 20 do 95 k = 1,klim if (unif) go to 25 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) ma = ndt + ndb + 1 go to 30 25 ist = (k - 1)*kblsz + 1 30 call bdfac (ldd,na,na,ndt,ndb,d(ist,1),1) call mcopy (ldd,na,na,ma,d(ist,1),wksp) call bdinv (na,na,na,ndt,ndb,wksp,1) if (k .eq. klim .or. jlim .le. 2) go to 95 do 90 i = k+1,klim if (unif) go to 35 ii = i llim = lbhb(i) 35 if (llim .le. 2) go to 90 do 40 l = 3,llim jcol = i + iblock(1,ii,l) if (jcol .eq. k) go to 45 40 continue go to 90 45 mc = iblock(3,ii,l) if (unif) go to 50 nc = ipt(i+1) - ipt(i) incc = ipt(k) - ipt(i) go to 55 50 incc = (k - i)*kblsz 55 istc = ist - incc jstc = iblock(2,ii,l) do 85 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .le. k) go to 85 jdiff = jcol - i if (jdiff .ne. 0 .and. propa) go to 85 do 60 m = 1,llim if (iblock(1,ii,m) .eq. jdiff) go to 65 60 continue go to 85 65 mb = iblock(3,kk,j) istb = ist jstb = iblock(2,kk,j) if (unif) go to 70 nb = ipt(jcol+1) - ipt(jcol) incb = ipt(jcol) - ipt(k) go to 75 70 incb = (jcol - k)*kblsz 75 incd = incc + incb istd = istc jstd = iblock(2,ii,m) md = iblock(3,ii,m) if (m .eq. 1) go to 80 call t1prod (na,ldt,ldt,ldt,ncolor,na,nc,nb, a ma,mb,mc,md,incb,incc,incd,jd(kk,1), a jt(kk,jstb),jt(ii,jstc), a jt(ii,jstd),wksp,t(istb,jstb), a t(istc,jstc),t(istd,jstd)) go to 85 80 md = md + iblock(3,ii,2) call t1prod (na,ldt,ldt,ldd,ncolor,na,nc,nb, a ma,mb,mc,md,incb,incc,incd,jd(kk,1), a jt(kk,jstb),jt(ii,jstc), a jd(ii,jstd),wksp,t(istb,jstb), a t(istc,jstc),d(istd,jstd)) 85 continue 90 continue 95 continue return end subroutine ibfcn2 (lddd,ldtt,n,jd,jt,d,t,ncol,nci, a iblock,lbhb,iunif,ipropa,ipt, a omega,wksp,ier) implicit double precision (a-h, o-z) c c ... ibfcn2 does an incomplete block factorization of the matrix c contained in d and t (version 2, unmodified). c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic (version 2) preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c jd integer array of size ncolor by whatever c giving the diagonal block diagonal numbers for c each distinct block size. jd is 1 by whatever c if iunif = 1. c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c d array for diagonal block c t array for off-diagonal blocks c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c ipropa property a switch c = 0 matrix does not have block property a c = 1 matrix has block property a c ipt integer pointer vector of length ncolor+1 if c iunif = 0 c c ... specifications for parameters c integer ipt(1), jd(ncol,1), jt(ncol,1), nci(1), lbhb(1), a iblock(3,ncol,2) dimension d(lddd,1), t(ldtt,1), wksp(1) logical unif, propa c ldd = lddd ldt = ldtt ncolor = ncol unif = iunif .eq. 1 propa = ipropa .eq. 1 c c ... define various constants. c if (unif) go to 15 klim = ncolor go to 20 15 kblsz = nci(1) na = kblsz nb = kblsz nc = kblsz ii = 1 kk = 1 jlim = lbhb(1) llim = jlim klim = n/kblsz ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) ma = ndt + ndb + 1 c c ... start factorization. c 20 do 95 k = 1,klim if (unif) go to 25 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) ma = ndt + ndb + 1 go to 30 25 ist = (k - 1)*kblsz + 1 30 call bdfac (ldd,na,na,ndt,ndb,d(ist,1),1) call bdinv (ldd,na,na,ndt,ndb,d(ist,1),1) if (k .eq. klim .or. jlim .le. 2) go to 95 do 90 i = k+1,klim if (unif) go to 35 ii = i llim = lbhb(i) 35 if (llim .le. 2) go to 90 do 40 l = 3,llim jcol = i + iblock(1,ii,l) if (jcol .eq. k) go to 45 40 continue go to 90 45 mc = iblock(3,ii,l) if (unif) go to 50 nc = ipt(i+1) - ipt(i) incc = ipt(k) - ipt(i) go to 55 50 incc = (k - i)*kblsz 55 istc = ist - incc jstc = iblock(2,ii,l) do 85 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .le. k) go to 85 jdiff = jcol - i if (jdiff .ne. 0 .and. propa) go to 85 do 60 m = 1,llim if (iblock(1,ii,m) .eq. jdiff) go to 65 60 continue go to 85 65 mb = iblock(3,kk,j) istb = ist jstb = iblock(2,kk,j) if (unif) go to 70 nb = ipt(jcol+1) - ipt(jcol) incb = ipt(jcol) - ipt(k) go to 75 70 incb = (jcol - k)*kblsz 75 incd = incc + incb istd = istc jstd = iblock(2,ii,m) md = iblock(3,ii,m) if (m .eq. 1) go to 80 call t1prod (ldd,ldt,ldt,ldt,ncolor,na,nc,nb, a ma,mb,mc,md,incb,incc,incd,jd(kk,1), a jt(kk,jstb),jt(ii,jstc), a jt(ii,jstd),d(ist,1),t(istb,jstb), a t(istc,jstc),t(istd,jstd)) go to 85 80 md = md + iblock(3,ii,2) call t1prod (ldd,ldt,ldt,ldd,ncolor,na,nc,nb, a ma,mb,mc,md,incb,incc,incd,jd(kk,1), a jt(kk,jstb),jt(ii,jstc), a jd(ii,jstd),d(ist,1),t(istb,jstb), a t(istc,jstc),d(istd,jstd)) 85 continue 90 continue 95 continue return end subroutine ibfcn3 (lddd,ldtt,n,jd,jt,d,t,ncol,nci, a iblock,lbhb,iunif,ipropa,ipt,omega,wksp, a ier) implicit double precision (a-h, o-z) c c ... ibfcn3 does an incomplete block factorization of the matrix c contained in d and t (version 1, modified). c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic (version 1) preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c jd integer array of size ncolor by whatever c giving the diagonal block diagonal numbers for c each distinct block size. jd is 1 by whatever c if iunif = 1. c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c d array for diagonal block c t array for off-diagonal blocks c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c ipropa property a switch c = 0 matrix does not have block property a c = 1 matrix has block property a c ipt integer pointer vector of length ncolor+1 if c iunif = 0 c omega relaxation factor between 0 and 1. c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jd(ncol,1), jt(ncol,1), nci(1), lbhb(1), a iblock(3,ncol,2) dimension d(lddd,1), t(ldtt,1), wksp(1) logical unif, propa c ldd = lddd ldt = ldtt ncolor = ncol unif = iunif .eq. 1 propa = ipropa .eq. 1 c c ... define various constants. c if (unif) go to 15 klim = ncolor go to 20 15 kblsz = nci(1) na = kblsz nb = kblsz nc = kblsz ii = 1 kk = 1 jlim = lbhb(1) llim = jlim klim = n/kblsz ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) ma = ndt + ndb + 1 c c ... start factorization. c 20 do 100 k = 1,klim if (unif) go to 25 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) ma = ndt + ndb + 1 go to 30 25 ist = (k - 1)*kblsz + 1 30 call bdfac (ldd,na,na,ndt,ndb,d(ist,1),1) call mcopy (ldd,na,na,ma,d(ist,1),wksp) call bdinv (na,na,na,ndt,ndb,wksp,1) ip1 = na*ma + 1 ip2 = ip1 + na - 1 if (k .eq. klim .or. jlim .le. 2) go to 100 do 95 i = k+1,klim if (unif) go to 35 ii = i llim = lbhb(i) 35 if (llim .le. 2) go to 95 do 40 l = 3,llim jcol = i + iblock(1,ii,l) if (jcol .eq. k) go to 45 40 continue go to 95 45 mc = iblock(3,ii,l) if (unif) go to 50 nc = ipt(i+1) - ipt(i) incc = ipt(k) - ipt(i) go to 55 50 incc = (k - i)*kblsz 55 istc = ist - incc jstc = iblock(2,ii,l) do 90 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .le. k) go to 90 mb = iblock(3,kk,j) istb = ist jstb = iblock(2,kk,j) if (unif) go to 60 nb = ipt(jcol+1) - ipt(jcol) incb = ipt(jcol) - ipt(k) go to 65 60 incb = (jcol - k)*kblsz 65 incd = incc + incb istd = istc jdiff = jcol - i if (jdiff .ne. 0 .and. propa) go to 85 do 70 m = 1,llim if (iblock(1,ii,m) .eq. jdiff) go to 75 70 continue go to 85 75 jstd = iblock(2,ii,m) md = iblock(3,ii,m) if (m .eq. 1) go to 80 call t1prod (na,ldt,ldt,ldt,ncolor,na,nc,nb, a ma,mb,mc,md,incb,incc,incd,jd(kk,1), a jt(kk,jstb),jt(ii,jstc), a jt(ii,jstd),wksp,t(istb,jstb), a t(istc,jstc),t(istd,jstd)) call tsumn a (na,nc,nb,na,ldt,ldt,ncolor,ma,mb,mc,md,incb, a incc,incd,jd(kk,1),jt(kk,jstb),jt(ii,jstc), a jt(ii,jstd),wksp,t(istb,jstb),t(istc,jstc), a d(istd,1),omega) go to 85 80 md = md + iblock(3,ii,2) call t1prod (na,ldt,ldt,ldd,ncolor,na,nc,nb, a ma,mb,mc,md,incb,incc,incd,jd(kk,1), a jt(kk,jstb),jt(ii,jstc), a jd(ii,jstd),wksp,t(istb,jstb), a t(istc,jstc),d(istd,jstd)) call tsumn a (na,nc,nb,na,ldt,ldt,ncolor,ma,mb,mc,md,incb, a incc,incd,jd(kk,1),jt(kk,jstb),jt(ii,jstc), a jd(ii,jstd),wksp,t(istb,jstb),t(istc,jstc), a d(istd,1),omega) 85 call rowsum (ldt,na,mb,t(istb,jstb),wksp(ip1),1) do 87 iii = ip1,ip2 87 wksp(iii) = omega*wksp(iii) call bdsol (ldd,na,na,ndt,ndb,d(ist,1),wksp(ip1), a wksp(ip1),1) call vsubd (ldt,ncolor,nc,na,mc,t(istc,jstc), a jt(ii,jstc),d(istd,1),wksp(ip1),incc) 90 continue 95 continue 100 continue return end subroutine ibfcn4 (lddd,ldtt,n,jd,jt,d,t,ncol,nci, a iblock,lbhb,iunif,ipropa,ipt,omega,wksp, a ier) implicit double precision (a-h, o-z) c c ... ibfcn4 does an incomplete block factorization of the matrix c contained in d and t (version 2, modified). c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic (version 2) preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c jd integer array of size ncolor by whatever c giving the diagonal block diagonal numbers for c each distinct block size. jd is 1 by whatever c if iunif = 1. c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c d array for diagonal block c t array for off-diagonal blocks c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c ipropa property a switch c = 0 matrix does not have block property a c = 1 matrix has block property a c ipt integer pointer vector of length ncolor+1 if c iunif = 0 c omega relaxation factor between 0 and 1. c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jd(ncol,1), jt(ncol,1), nci(1), lbhb(1), a iblock(3,ncol,2) dimension d(lddd,2), t(ldtt,1), wksp(1) logical unif, propa c ldd = lddd ldt = ldtt ncolor = ncol unif = iunif .eq. 1 propa = ipropa .eq. 1 c c ... define various constants. c ip1 = n + 1 if (unif) go to 15 klim = ncolor do 13 k = 1,ncolor ist = ipt(k) + 1 na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) ma = ndt + ndb + 1 call rowsum (ldd,na,ma,d(ist,1),wksp(ist),1) 13 continue go to 20 15 kblsz = nci(1) na = kblsz nb = kblsz nc = kblsz ii = 1 kk = 1 jlim = lbhb(1) llim = jlim klim = n/kblsz ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) ma = ndt + ndb + 1 call rowsum (ldd,n,ma,d,wksp,1) c c ... start factorization. c 20 do 100 k = 1,klim if (unif) go to 25 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) ma = ndt + ndb + 1 go to 30 25 ist = (k - 1)*kblsz + 1 30 isu = ist + na - 1 call bdfac (ldd,na,na,ndt,ndb,d(ist,1),1) call bdinv (ldd,na,na,ndt,ndb,d(ist,1),1) call bmuln (ldd,na,ndt,ndb,d(ist,1),d(ist,2),d(ist,ndt+2), a wksp(ist),wksp(ip1)) do 31 iii = ist,isu if (wksp(iii) .ne. 0.0d0) go to 31 ier = -12 call ershow (ier,'ibfcn4') return 31 continue do 33 iii = ist,isu 33 d(iii,1) = d(iii,1) + omega*(1.0d0 - wksp(iii-ist+ip1))/ a wksp(iii) ip2 = ip1 + na if (k .eq. klim .or. jlim .le. 2) go to 100 do 95 i = k+1,klim if (unif) go to 35 ii = i llim = lbhb(i) 35 if (llim .le. 2) go to 95 do 40 l = 3,llim jcol = i + iblock(1,ii,l) if (jcol .eq. k) go to 45 40 continue go to 95 45 mc = iblock(3,ii,l) if (unif) go to 50 nc = ipt(i+1) - ipt(i) incc = ipt(k) - ipt(i) go to 55 50 incc = (k - i)*kblsz 55 istc = ist - incc jstc = iblock(2,ii,l) do 90 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .le. k) go to 90 mb = iblock(3,kk,j) istb = ist jstb = iblock(2,kk,j) if (unif) go to 60 nb = ipt(jcol+1) - ipt(jcol) incb = ipt(jcol) - ipt(k) go to 65 60 incb = (jcol - k)*kblsz 65 incd = incc + incb istd = istc jdiff = jcol - i if (jdiff .ne. 0 .and. propa) go to 85 do 70 m = 1,llim if (iblock(1,ii,m) .eq. jdiff) go to 75 70 continue go to 85 75 jstd = iblock(2,ii,m) md = iblock(3,ii,m) if (m .eq. 1) go to 80 call t1prod (ldd,ldt,ldt,ldt,ncolor,na,nc,nb, a ma,mb,mc,md,incb,incc,incd,jd(kk,1), a jt(kk,jstb),jt(ii,jstc), a jt(ii,jstd),d(ist,1),t(istb,jstb), a t(istc,jstc),t(istd,jstd)) call tsumn a (na,nc,nb,ldd,ldt,ldt,ncolor,ma,mb,mc,md,incb, a incc,incd,jd(kk,1),jt(kk,jstb),jt(ii,jstc), a jt(ii,jstd),d(ist,1),t(istb,jstb),t(istc,jstc), a wksp(istd),1.0d0) go to 85 80 md = md + iblock(3,ii,2) call t1prod (ldd,ldt,ldt,ldd,ncolor,na,nc,nb, a ma,mb,mc,md,incb,incc,incd,jd(kk,1), a jt(kk,jstb),jt(ii,jstc), a jd(ii,jstd),d(ist,1),t(istb,jstb), a t(istc,jstc),d(istd,jstd)) 85 call rowsum (ldt,na,mb,t(istb,jstb),wksp(ip1),1) call bmuln (ldd,na,ndt,ndb,d(ist,1),d(ist,2), a d(ist,ndt+2),wksp(ip1),wksp(ip2)) call vsubd (ldt,ncolor,nc,na,mc,t(istc,jstc), a jt(ii,jstc),wksp(istd),wksp(ip2),incc) 90 continue 95 continue 100 continue return end subroutine ibfcs1 (lddd,ldtt,nn,jd,jt,d,t,kblszz, a iblock,lbhb,ipropa,omega,wksp,ier) implicit double precision (a-h, o-z) c c ... ibfcs1 does an incomplete block factorization of the matrix c contained in d and t (version 1, unmodified). c symmetric diagonal data structure, natural ordering. c block ic (version 1) preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c jd integer vector giving the diagonal numbers c for the diagonal block c jt integer vector giving the diagonal numbers c for the off-diagonal blocks c d array for diagonal block c t array for off-diagonal blocks c kblsz block size c iblock integer array of size 3 by lbhb c giving block constants c lbhb number of blocks per block row c ipropa property a switch c = 0 matrix does not have block property a c = 1 matrix has block property a c wksp floating point workspace vector c c ... specifications for parameters c integer jd(1), jt(1), iblock(3,3) dimension d(lddd,1), t(ldtt,1), wksp(1) logical propa c n = nn ldd = lddd ldt = ldtt na = kblszz propa = ipropa .eq. 1 klim = n/na ma = iblock(3,1) ndt = ma - 1 c c ... block tridiagonal case. c if (lbhb .gt. 3) go to 25 jblkb = iblock(1,3) mb = iblock(3,3) incb = jblkb*na do 20 k = 1,klim ist = (k - 1)*na + 1 istd = ist + incb call bdfac (ldd,na,na,ndt,0,d(ist,1),0) if (istd .gt. n) go to 20 call mcopy (ldd,na,na,ma,d(ist,1),wksp) call bdinv (na,na,na,ndt,0,wksp,0) call t2prod (na,na,ldt,ldt,ldd,ma,mb,mb,ma, a incb,incb,0,jd,jt,jt,jd,wksp,t(ist,1),t(ist,1), a d(istd,1)) 20 continue return c c ... general block structure. c 25 do 50 k = 1,klim ist = (k - 1)*na + 1 call bdfac (ldd,na,na,ndt,0,d(ist,1),0) if (k .eq. klim) go to 50 call mcopy (ldd,na,na,ma,d(ist,1),wksp) call bdinv (na,na,na,ndt,0,wksp,0) jjlim = min (lbhb,klim-k+2) do 45 jjc = 3,jjlim jblkc = iblock(1,jjc) jstc = iblock(2,jjc) mc = iblock(3,jjc) incc = jblkc*na istd = ist + incc if (istd .gt. n) go to 45 do 40 jjb = 3,jjlim jblkb = iblock(1,jjb) jstb = iblock(2,jjb) mb = iblock(3,jjb) incb = jblkb*na jdiff = jblkb - jblkc if (jdiff .lt. 0) go to 40 if (jdiff .ne. 0 .and. propa) go to 40 do 30 jjd = 1,jjlim if (jdiff .eq. iblock(1,jjd)) go to 35 30 continue go to 40 35 jblkd = iblock(1,jjd) jstd = iblock(2,jjd) md = iblock(3,jjd) incd = jblkd*na if (jjd .ne. 1) call t2prod a (na,na,ldt,ldt,ldt,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jt(jstd),wksp,t(ist,jstb),t(ist,jstc), a t(istd,jstd)) if (jjd .eq. 1) call t2prod a (na,na,ldt,ldt,ldd,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jd,wksp,t(ist,jstb),t(ist,jstc), a d(istd,1)) 40 continue 45 continue 50 continue return end subroutine ibfcs2 (lddd,ldtt,nn,jd,jt,d,t,kblszz, a iblock,lbhb,ipropa,omega,wksp,ier) implicit double precision (a-h, o-z) c c ... ibfcs2 does an incomplete block factorization of the matrix c contained in d and t (version 2, unmodified). c symmetric diagonal data structure, natural ordering. c block ic (version 2) preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c jd integer vector giving the diagonal numbers c for the diagonal block c jt integer vector giving the diagonal numbers c for the off-diagonal blocks c d array for diagonal block c t array for off-diagonal blocks c kblsz block size c iblock integer array of size 3 by lbhb c giving block constants c lbhb number of blocks per block row c ipropa property a switch c = 0 matrix does not have block property a c = 1 matrix has block property a c c ... specifications for parameters c integer jd(1), jt(1), iblock(3,3) dimension d(lddd,1), t(ldtt,1), wksp(1) logical propa c n = nn ldd = lddd ldt = ldtt na = kblszz propa = ipropa .eq. 1 klim = n/na ma = iblock(3,1) ndt = ma - 1 c c ... block tridiagonal case. c if (lbhb .gt. 3) go to 25 jblkb = iblock(1,3) mb = iblock(3,3) incb = jblkb*na do 20 k = 1,klim ist = (k - 1)*na + 1 istd = ist + incb call bdfac (ldd,na,na,ndt,0,d(ist,1),0) call bdinv (ldd,na,na,ndt,0,d(ist,1),0) if (istd .gt. n) go to 20 call t2prod (na,ldd,ldt,ldt,ldd,ma,mb,mb,ma, a incb,incb,0,jd,jt,jt,jd,d(ist,1),t(ist,1), a t(ist,1),d(istd,1)) 20 continue return c c ... general block structure. c 25 do 50 k = 1,klim ist = (k - 1)*na + 1 call bdfac (ldd,na,na,ndt,0,d(ist,1),0) call bdinv (ldd,na,na,ndt,0,d(ist,1),0) if (k .eq. klim) go to 50 jjlim = min (lbhb,klim-k+2) do 45 jjc = 3,jjlim jblkc = iblock(1,jjc) jstc = iblock(2,jjc) mc = iblock(3,jjc) incc = jblkc*na istd = ist + incc if (istd .gt. n) go to 45 do 40 jjb = 3,jjlim jblkb = iblock(1,jjb) jstb = iblock(2,jjb) mb = iblock(3,jjb) incb = jblkb*na jdiff = jblkb - jblkc if (jdiff .lt. 0) go to 40 if (jdiff .ne. 0 .and. propa) go to 40 do 30 jjd = 1,jjlim if (jdiff .eq. iblock(1,jjd)) go to 35 30 continue go to 40 35 jblkd = iblock(1,jjd) jstd = iblock(2,jjd) md = iblock(3,jjd) incd = jblkd*na if (jjd .ne. 1) call t2prod a (na,ldd,ldt,ldt,ldt,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jt(jstd),d(ist,1),t(ist,jstb),t(ist,jstc), a t(istd,jstd)) if (jjd .eq. 1) call t2prod a (na,ldd,ldt,ldt,ldd,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jd,d(ist,1),t(ist,jstb),t(ist,jstc), a d(istd,1)) 40 continue 45 continue 50 continue return end subroutine ibfcs3 (lddd,ldtt,nn,jd,jt,d,t,kblszz, a iblock,lbhb,ipropa,omegaa,wksp,ier) implicit double precision (a-h, o-z) c c ... ibfcs3 does an incomplete block factorization of the matrix c contained in d and t (version 1, modified). c symmetric diagonal data structure, natural ordering. c block ic (version 1) preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c jd integer vector giving the diagonal numbers c for the diagonal block c jt integer vector giving the diagonal numbers c for the off-diagonal blocks c d array for diagonal block c t array for off-diagonal blocks c kblsz block size c iblock integer array of size 3 by lbhb c giving block constants c lbhb number of blocks per block row c ipropa property a switch c = 0 matrix does not have block property a c = 1 matrix has block property a c omega relaxation factor between 0. and 1. c = 0 no modification c = 1 full modification c wksp floating point workspace vector c c ... specifications for parameters c integer jd(1), jt(1), iblock(3,3) dimension d(lddd,1), t(ldtt,1), wksp(1) logical propa c n = nn ldd = lddd ldt = ldtt na = kblszz omega = omegaa propa = ipropa .eq. 1 klim = n/na ma = iblock(3,1) ndt = ma - 1 c c ... block tridiagonal case. c if (lbhb .gt. 3) go to 25 ip1 = na*ma + 1 ip2 = ip1 + na - 1 jblkb = iblock(1,3) mb = iblock(3,3) incb = jblkb*na do 20 k = 1,klim ist = (k - 1)*na + 1 istd = ist + incb call bdfac (ldd,na,na,ndt,0,d(ist,1),0) if (istd .gt. n) go to 20 call mcopy (ldd,na,na,ma,d(ist,1),wksp) call bdinv (na,na,na,ndt,0,wksp,0) call t2prod (na,na,ldt,ldt,ldd,ma,mb,mb,ma, a incb,incb,0,jd,jt,jt,jd,wksp,t(ist,1), a t(ist,1),d(istd,1)) call tsum (na,na,ldt,ldt,ma,mb,mb,ma,incb,incb, a 0,jd,jt,jt,jd,wksp,t(ist,1),t(ist,1), a d(istd,1),d(istd,1),wksp(ip1),1,omega) call rowsum (ldt,na,mb,t(ist,1),wksp(ip1),1) do 15 iii = ip1,ip2 15 wksp(iii) = omega*wksp(iii) call bdsol (ldd,na,na,ndt,0,d(ist,1),wksp(ip1), a wksp(ip1),0) call vsubdt (ldt,1,na,na,mb,t(ist,1),jt,d(istd,1), a wksp(ip1),incb) 20 continue return c c ... general block structure. c 25 ip1 = na*ma + 1 ip2 = ip1 + na - 1 do 60 k = 1,klim ist = (k - 1)*na + 1 call bdfac (ldd,na,na,ndt,0,d(ist,1),0) if (k .eq. klim) go to 60 call mcopy (ldd,na,na,ma,d(ist,1),wksp) call bdinv (na,na,na,ndt,0,wksp,0) jjlim = min (lbhb,klim-k+2) do 55 jjc = 3,jjlim jblkc = iblock(1,jjc) jstc = iblock(2,jjc) mc = iblock(3,jjc) incc = jblkc*na istd = ist + incc if (istd .gt. n) go to 55 do 50 jjb = 3,jjlim jblkb = iblock(1,jjb) jstb = iblock(2,jjb) mb = iblock(3,jjb) incb = jblkb*na istdd = ist + incb if (istdd .gt. n) go to 50 jdiff = jblkb - jblkc if (jdiff .lt. 0) go to 50 if (jdiff .ne. 0 .and. propa) go to 40 do 30 jjd = 1,jjlim if (jdiff .eq. iblock(1,jjd)) go to 35 30 continue go to 40 35 jblkd = iblock(1,jjd) jstd = iblock(2,jjd) md = iblock(3,jjd) incd = jblkd*na if (jjd .ne. 1) call t2prod a (na,na,ldt,ldt,ldt,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jt(jstd),wksp,t(ist,jstb),t(ist,jstc), a t(istd,jstd)) if (jjd .eq. 1) call t2prod a (na,na,ldt,ldt,ldd,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jd,wksp,t(ist,jstb),t(ist,jstc), a d(istd,1)) if (jjd .ne. 1) call tsum a (na,na,ldt,ldt,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jt(jstd),wksp,t(ist,jstb),t(ist,jstc), a d(istd,1),d(istdd,1),wksp(ip1),0,omega) if (jjd .eq. 1) call tsum a (na,na,ldt,ldt,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jd,wksp,t(ist,jstb),t(ist,jstc), a d(istd,1),d(istdd,1),wksp(ip1),1,omega) c 40 call rowsum (ldt,na,mb,t(ist,jstb),wksp(ip1),1) do 42 iii = ip1,ip2 42 wksp(iii) = omega*wksp(iii) call bdsol (ldd,na,na,ndt,0,d(ist,1),wksp(ip1), a wksp(ip1),0) call vsubdt (ldt,1,na,na,mc,t(ist,jstc),jt(jstc), a d(istd,1),wksp(ip1),incc) if (jdiff .eq. 0) go to 50 call rowsum (ldt,na,mc,t(ist,jstc),wksp(ip1),1) do 45 iii = ip1,ip2 45 wksp(iii) = omega*wksp(iii) call bdsol (ldd,na,na,ndt,0,d(ist,1),wksp(ip1), a wksp(ip1),0) call vsubdt (ldt,1,na,na,mb,t(ist,jstb),jt(jstb), a d(istdd,1),wksp(ip1),incb) 50 continue 55 continue 60 continue return end subroutine ibfcs4 (lddd,ldtt,nn,jd,jt,d,t,kblszz, a iblock,lbhb,ipropa,omegaa,wksp,ier) implicit double precision (a-h, o-z) c c ... ibfcs4 does an incomplete block factorization of the matrix c contained in d and t (version 2, modified). c symmetric diagonal data structure, natural ordering. c block ic (version 2) preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c jd integer vector giving the diagonal numbers c for the diagonal block c jt integer vector giving the diagonal numbers c for the off-diagonal blocks c d array for diagonal block c t array for off-diagonal blocks c kblsz block size c iblock integer array of size 3 by lbhb c giving block constants c lbhb number of blocks per block row c ipropa property a switch c = 0 matrix does not have block property a c = 1 matrix has block property a c omega relaxation factor between 0. and 1. c = 0 no modification c = 1 full modification c wksp floating point workspace vector c c ... specifications for parameters c integer jd(1), jt(1), iblock(3,3) dimension d(lddd,2), t(ldtt,1), wksp(1) logical propa c n = nn ldd = lddd ldt = ldtt na = kblszz omega = omegaa propa = ipropa .eq. 1 klim = n/na ma = iblock(3,1) ndt = ma - 1 c c ... block tridiagonal case. c if (lbhb .gt. 3) go to 25 ip1 = n + 1 ip2 = ip1 + na jblkb = iblock(1,3) mb = iblock(3,3) incb = jblkb*na call rowsum (ldd,n,ma,d,wksp,0) do 20 k = 1,klim ist = (k - 1)*na + 1 isu = k*na istd = ist + incb call bdfac (ldd,na,na,ndt,0,d(ist,1),0) call bdinv (ldd,na,na,ndt,0,d(ist,1),0) call bmul (ldd,na,ndt,d(ist,1),d(ist,2),wksp(ist),wksp(ip1)) do 10 ii = ist,isu if (wksp(ii) .ne. 0.0d0) go to 10 ier = -12 call ershow (ier,'ibfcs4') return 10 continue do 15 ii = ist,isu 15 d(ii,1) = d(ii,1) + omega*(1.0d0 - wksp(ii-ist+ip1))/ a wksp(ii) if (istd .gt. n) go to 20 call t2prod (na,ldd,ldt,ldt,ldd,ma,mb,mb,ma, a incb,incb,0,jd,jt,jt,jd,d(ist,1),t(ist,1), a t(ist,1),d(istd,1)) call rowsum (ldt,na,mb,t(ist,1),wksp(ip1),1) call bmul (ldd,na,ndt,d(ist,1),d(ist,2),wksp(ip1), a wksp(ip2)) call vsubdt (ldt,1,na,na,mb,t(ist,1),jt,wksp(istd), a wksp(ip2),incb) 20 continue return c c ... general block structure. c 25 ip1 = n + 1 ip2 = ip1 + na call rowsum (ldd,n,ma,d,wksp,0) do 60 k = 1,klim ist = (k - 1)*na + 1 isu = k*na call bdfac (ldd,na,na,ndt,0,d(ist,1),0) call bdinv (ldd,na,na,ndt,0,d(ist,1),0) call bmul (ldd,na,ndt,d(ist,1),d(ist,2),wksp(ist),wksp(ip1)) do 26 ii = ist,isu if (wksp(ii) .ne. 0.0d0) go to 26 ier = -12 call ershow (ier,'ibfcs4') return 26 continue do 27 ii = ist,isu 27 d(ii,1) = d(ii,1) + omega*(1.0d0 - wksp(ii-ist+ip1))/ a wksp(ii) if (k .eq. klim) go to 60 jjlim = min (lbhb,klim-k+2) do 55 jjc = 3,jjlim jblkc = iblock(1,jjc) jstc = iblock(2,jjc) mc = iblock(3,jjc) incc = jblkc*na istd = ist + incc if (istd .gt. n) go to 55 do 50 jjb = 3,jjlim jblkb = iblock(1,jjb) jstb = iblock(2,jjb) mb = iblock(3,jjb) incb = jblkb*na istdd = ist + incb if (istdd .gt. n) go to 50 jdiff = jblkb - jblkc if (jdiff .lt. 0) go to 50 if (jdiff .ne. 0 .and. propa) go to 40 do 30 jjd = 1,jjlim if (jdiff .eq. iblock(1,jjd)) go to 35 30 continue go to 40 35 jblkd = iblock(1,jjd) jstd = iblock(2,jjd) md = iblock(3,jjd) incd = jblkd*na if (jjd .ne. 1) call t2prod a (na,ldd,ldt,ldt,ldt,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jt(jstd),d(ist,1),t(ist,jstb),t(ist,jstc), a t(istd,jstd)) if (jjd .eq. 1) call t2prod a (na,ldd,ldt,ldt,ldd,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jd,d(ist,1),t(ist,jstb),t(ist,jstc), a d(istd,1)) if (jjd .ne. 1) call tsum a (na,ldd,ldt,ldt,ma,mb,mc,md,incb, a incc,incd,jd,jt(jstb),jt(jstc), a jt(jstd),d(ist,1),t(ist,jstb),t(ist,jstc), a wksp(istd),wksp(istdd),wksp(ip1),0,1.0d0) c 40 call rowsum (ldt,na,mb,t(ist,jstb),wksp(ip1),1) call bmul (ldd,na,ndt,d(ist,1),d(ist,2),wksp(ip1), a wksp(ip2)) call vsubdt (ldt,1,na,na,mc,t(ist,jstc),jt(jstc), a wksp(istd),wksp(ip2),incc) if (jdiff .eq. 0) go to 50 call rowsum (ldt,na,mc,t(ist,jstc),wksp(ip1),1) call bmul (ldd,na,ndt,d(ist,1),d(ist,2),wksp(ip1), a wksp(ip2)) call vsubdt (ldt,1,na,na,mb,t(ist,jstb),jt(jstb), a wksp(istdd),wksp(ip2),incb) 50 continue 55 continue 60 continue return end subroutine ibbs (ldd,ldt,n,kblszz,nsize,lbhb,iblock,d,t, a jt,x,ivers,wksp) implicit double precision (a-h, o-z) c c ... ibbs does an incomplete block backward pass. c symmetric diagonal data structure, natural ordering. c block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c kblsz block size c nsize size of an individual subsystem within a c diagonal block c lbhb number of blocks per block row c iblock integer array of size 3 by lbhb c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer vector giving the diagonal numbers c for the off-diagonal blocks c x input/output vector of length n c ivers key for version of factorization c = 1 version 1 c = 2 version 2 c wksp floating point workspace vector c c ... specifications for parameters c integer jt(1), iblock(3,1) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical vers2 c kblsz = kblszz l = n/kblsz nt = iblock(3,1) - 1 vers2 = ivers .eq. 2 do 40 k = l,1,-1 ist = (k - 1)*kblsz + 1 ied = k*kblsz if (k .eq. l) go to 15 jjlim = min (lbhb,l-k+2) do 10 jj = 3,jjlim jblk = iblock(1,jj) jst = iblock(2,jj) mjj = iblock(3,jj) inc = jblk*kblsz istf = ist + inc if (istf .gt. n) go to 10 call vsubd (ldt,1,kblsz,kblsz,mjj,t(ist,jst),jt(jst), a x(ist),x(istf),inc) 10 continue 15 if (nt .ge. 1) go to 25 do 20 i = ist,ied 20 x(i) = d(i,1)*x(i) go to 40 25 if (vers2) go to 30 call bdsol (ldd,kblsz,nsize,nt,0,d(ist,1),x(ist),x(ist), a 0) go to 40 30 call bmul (ldd,kblsz,nt,d(ist,1),d(ist,2),x(ist),wksp) do 35 i = ist,ied 35 x(i) = wksp(i-ist+1) 40 continue return end subroutine ibbsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) implicit double precision (a-h, o-z) c c ... ibbsn does an incomplete block backward solve. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c x input/output vector of length n c ivers key for version number c = 1 version 1 c = 2 version 2 c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical unif, vers2 c vers2 = ivers .eq. 2 unif = iunif .eq. 1 c l = ncolor if (.not. unif) go to 10 na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) kk = 1 c c ... do backward solution. c 10 lm1 = l - 1 do 50 k = lm1,1,-1 if (unif) go to 15 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) go to 20 15 ist = (k - 1)*na + 1 20 ied = ist + na - 1 do 22 i = 1,na 22 wksp(i) = 0.0d0 do 25 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .le. k) go to 25 jstb = iblock(2,kk,j) mb = iblock(3,kk,j) if (unif) inc = (jcol - k)*na if (.not. unif) inc = ipt(jcol) - ipt(k) if (.not. unif) nb = nci(jcol) istb = ist + inc if (istb .gt. n) go to 25 call vaddd (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb), a wksp,x(istb),inc) 25 continue if (ndt + ndb .ge. 1) go to 35 do 30 i = ist,ied 30 x(i) = x(i) - d(i,1)*wksp(i-ist+1) go to 50 35 if (vers2) go to 40 call bdsol (ldd,na,nsize,ndt,ndb,d(ist,1),wksp,wksp,1) do 37 i = ist,ied 37 x(i) = x(i) - wksp(i-ist+1) go to 50 40 nap1 = na + 1 call bmuln (ldd,na,ndt,ndb,d(ist,1),d(ist,2),d(ist,ndt+2), a wksp,wksp(nap1)) do 45 i = ist,ied 45 x(i) = x(i) - wksp(i-ist+nap1) 50 continue return end subroutine ibbsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) implicit double precision (a-h, o-z) c c ... ibbsnt does an incomplete block transpose backward solve. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c x input/output vector of length n c ivers key for version number c = 1 version 1 c = 2 version 2 c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical unif, vers1 c vers1 = ivers .eq. 1 unif = iunif .eq. 1 c l = ncolor if (.not. unif) go to 10 na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) kk = 1 c c ... do backward solution. c 10 do 45 k = l,1,-1 if (unif) go to 15 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) go to 20 15 ist = (k - 1)*na + 1 20 ied = ist + na - 1 if (ndt + ndb .ge. 1) go to 30 do 25 i = ist,ied 25 x(i) = d(i,1)*x(i) go to 35 30 if (vers1) call bdsolt a (ldd,na,nsize,ndt,ndb,d(ist,1),x(ist),x(ist)) if (vers1) go to 35 call bmulnt a (ldd,na,ndt,ndb,d(ist,1),d(ist,2),d(ist,ndt+2), a x(ist),wksp) do 32 i = ist,ied 32 x(i) = wksp(i-ist+1) 35 do 40 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .ge. k) go to 40 jstb = iblock(2,kk,j) mb = iblock(3,kk,j) if (unif) inc = (jcol - k)*na if (.not. unif) inc = ipt(jcol) - ipt(k) if (.not. unif) nb = nci(jcol) istb = ist + inc if (istb .lt. 1) go to 40 call vsubdt (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb), a x(istb),x(ist),inc) 40 continue 45 continue return end subroutine ibfs (ldd,ldt,n,kblszz,nsize,lbhb,iblock,d,t, a jt,x,ivers,wksp) implicit double precision (a-h, o-z) c c ... ibfs does an incomplete block forward pass. c symmetric diagonal data structure, natural ordering. c block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c kblsz block size c nsize size of an individual subsystem within a c diagonal block c lbhb number of blocks per block row c iblock integer array of size 3 by lbhb c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer vector giving the diagonal numbers c for the off-diagonal blocks c x input/output vector of length n c ivers key for version of factorization c = 1 version 1 c = 2 version 2 c wksp floating point workspace vector c c ... specifications for parameters c integer jt(1), iblock(3,1) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical vers1, vers2 c kblsz = kblszz l = n/kblsz lm1 = l - 1 nt = iblock(3,1) - 1 vers1 = ivers .eq. 1 vers2 = ivers .eq. 2 do 30 k = 1,lm1 ist = (k - 1)*kblsz + 1 ied = k*kblsz if (nt .ge. 1) go to 15 do 10 i = ist,ied 10 wksp(i-ist+1) = d(i,1)*x(i) go to 20 15 if (vers1) call bdsol (ldd,kblsz,nsize,nt,0,d(ist,1), a x(ist),wksp,0) if (vers2) call bmul (ldd,kblsz,nt,d(ist,1),d(ist,2), a x(ist),wksp) 20 jjlim = min (lbhb,l-k+2) do 25 jj = 3,jjlim jblk = iblock(1,jj) jst = iblock(2,jj) mjj = iblock(3,jj) inc = jblk*kblsz istf = ist + inc if (istf .gt. n) go to 25 call vsubdt (ldt,1,kblsz,kblsz,mjj,t(ist,jst),jt(jst), a x(istf),wksp,inc) 25 continue 30 continue return end subroutine ibfsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) implicit double precision (a-h, o-z) c c ... ibfsn does an incomplete block forward solve. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c x input/output vector of length n c ivers key for version number c = 1 version 1 c = 2 version 2 c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical unif, vers2 c vers2 = ivers .eq. 2 unif = iunif .eq. 1 c l = ncolor if (.not. unif) go to 10 na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) kk = 1 c c ... do forward solution. c 10 do 50 k = 1,l if (unif) go to 15 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) go to 20 15 ist = (k - 1)*na + 1 20 ied = ist + na - 1 do 25 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .ge. k) go to 25 jstb = iblock(2,kk,j) mb = iblock(3,kk,j) if (unif) inc = (jcol - k)*na if (.not. unif) inc = ipt(jcol) - ipt(k) if (.not. unif) nb = nci(jcol) istb = ist + inc if (istb .lt. 1) go to 25 call vsubd (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb), a x(ist),x(istb),inc) 25 continue if (ndt + ndb .ge. 1) go to 35 do 30 i = ist,ied 30 x(i) = d(i,1)*x(i) go to 50 35 if (vers2) go to 40 call bdsol (ldd,na,nsize,ndt,ndb,d(ist,1),x(ist),x(ist),1) go to 50 40 call bmuln (ldd,na,ndt,ndb,d(ist,1),d(ist,2),d(ist,ndt+2), a x(ist),wksp) do 45 i = ist,ied 45 x(i) = wksp(i-ist+1) 50 continue return end subroutine ibfsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) implicit double precision (a-h, o-z) c c ... ibfsnt does an incomplete block transpose forward solve. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c x input/output vector of length n c ivers key for version number c = 1 version 1 c = 2 version 2 c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical unif, vers1, vers2 c vers1 = ivers .eq. 1 vers2 = ivers .eq. 2 unif = iunif .eq. 1 c l = ncolor if (.not. unif) go to 10 na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) kk = 1 c c ... do forward solution. c 10 lm1 = l - 1 do 45 k = 1,lm1 if (unif) go to 15 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) go to 20 15 ist = (k - 1)*na + 1 20 ied = ist + na - 1 if (ndt + ndb .ge. 1) go to 30 do 25 i = ist,ied 25 wksp(i-ist+1) = d(i,1)*x(i) go to 35 30 if (vers1) call bdsolt a (ldd,na,nsize,ndt,ndb,d(ist,1),x(ist),wksp) if (vers2) call bmulnt a (ldd,na,ndt,ndb,d(ist,1),d(ist,2),d(ist,ndt+2), a x(ist),wksp) 35 do 40 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .le. k) go to 40 jstb = iblock(2,kk,j) mb = iblock(3,kk,j) if (unif) inc = (jcol - k)*na if (.not. unif) inc = ipt(jcol) - ipt(k) if (.not. unif) nb = nci(jcol) istb = ist + inc if (istb .gt. n) go to 40 call vsubdt (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb), a x(istb),wksp,inc) 40 continue 45 continue return end subroutine ibsl (ldd,ldt,n,kblsz,nsize,lbhb,iblock,d,t, a jt,y,x,ivers,wksp) implicit double precision (a-h, o-z) c c ... ibsl does an incomplete block solution. c symmetric diagonal data structure, natural ordering. c block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c kblsz block size c nsize size of an individual subsystem within a c diagonal block c lbhb number of blocks per block row c iblock integer array of size 3 by lbhb c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer vector giving the diagonal numbers c for the off-diagonal blocks c y input vector for the right-hand-side c x output vector for the solution to q*x = y c ivers key for version of factorization c = 1 version 1 c = 2 version 2 c wksp floating point workspace vector c c ... specifications for parameters c integer jt(1), iblock(3,1) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c do 10 i = 1,n 10 x(i) = y(i) call ibfs (ldd,ldt,n,kblsz,nsize,lbhb,iblock,d,t, a jt,x,ivers,wksp) call ibbs (ldd,ldt,n,kblsz,nsize,lbhb,iblock,d,t, a jt,x,ivers,wksp) return end subroutine ibsln (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,ivers,iunif,wksp) implicit double precision (a-h, o-z) c c ... ibsln does an incomplete block solution. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c ivers key for version number c = 1 version 1 c = 2 version 2 c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c do 10 i = 1,n 10 x(i) = y(i) call ibfsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) call ibbsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) return end subroutine ibslnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,ivers,iunif,wksp) implicit double precision (a-h, o-z) c c ... ibslnt does an incomplete block transpose solution. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c ivers key for version number c = 1 version 1 c = 2 version 2 c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c do 10 i = 1,n 10 x(i) = y(i) call ibfsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) call ibbsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) return end subroutine ibsln1 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,ivers,iunif,wksp) implicit double precision (a-h, o-z) c c ... ibsln1 does an incomplete block forward pass. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c ivers key for version number c = 1 version 1 c = 2 version 2 c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c do 10 i = 1,n 10 x(i) = y(i) call ibfsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) return end subroutine ibsln2 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,ivers,iunif,wksp) implicit double precision (a-h, o-z) c c ... ibsln2 does an incomplete block backward pass. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c ivers key for version number c = 1 version 1 c = 2 version 2 c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c do 10 i = 1,n 10 x(i) = y(i) call ibbsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) return end subroutine ibsln3 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,ivers,iunif,wksp) implicit double precision (a-h, o-z) c c ... ibsln3 does an incomplete block transpose back solve. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c ivers key for version number c = 1 version 1 c = 2 version 2 c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c do 10 i = 1,n 10 x(i) = y(i) call ibbsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) return end subroutine ibsln4 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,ivers,iunif,wksp) implicit double precision (a-h, o-z) c c ... ibsln4 does an incomplete block transpose forward pass. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ic preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c ivers key for version number c = 1 version 1 c = 2 version 2 c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c do 10 i = 1,n 10 x(i) = y(i) call ibfsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,ivers,iunif,wksp) return end subroutine icf (ndim,nn,maxtt,jt,d,t,meth, a ipropa,omega,wksp,iwksp,iflag) implicit double precision (a-h, o-z) c c ... icf computes an incomplete factorization of the matrix c stored in d and t and replaces it. c (symmetric diagonal storage) c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector giving the diagonal indices of c the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the c super-diagonals of the matrix c meth point factorization wanted c = 1 ic c = 2 mic c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c omega modification factor between 0.0 and 1.0 c = 0 no modification c = 1 full modification c wksp workspace vector of length n c iwksp integer workspace of length maxt**2 c iflag indicator of factorization stability c iflag = 0 no errors detected c = 1 zero pivot encountered c (unsuccessful factorization) c = 2 negative pivot encountered c (successful factorization) c c ... specifications for parameters c integer jt(1), iwksp(1) dimension d(1), t(ndim,1), wksp(1) logical propa c c n = nn maxt = maxtt iflag = 0 propa = ipropa .eq. 1 if (maxt .lt. 1) go to 500 nm1 = n - 1 if (meth .ne. 1 .or. .not. propa) go to 20 c c ... ic, propa = t. c do 15 k = 1,nm1 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 do 10 j = 1,maxt kf = k + jt(j) if (kf .le. n) d(kf) = d(kf) - t(k,j)**2/pivot 10 continue 15 continue if (d(n) .eq. 0.0d0) go to 995 go to 500 20 if (meth .ne. 2 .or. .not. propa) go to 50 c c ... mic, propa = t. c do 25 i = 1,n 25 wksp(i) = 0.0d0 do 35 j = 1,maxt do 30 i = 1,n 30 wksp(i) = wksp(i) + t(i,j) 35 continue do 45 k = 1,nm1 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 do 40 i = 1,maxt kf = k + jt(i) if (kf .gt. n) go to 40 term = t(k,i)/pivot d(kf) = d(kf) - term*(omega*wksp(k)-(omega-1.0d0)*t(k,i)) 40 continue 45 continue if (d(n) .eq. 0.0d0) go to 995 go to 500 c c ... ic, mic for propa = f. c 50 nbig = maxt + 1 do 70 i = 1,maxt do 65 j = i,maxt if (j .eq. i) go to 65 iloc = (j - 1)*maxt + i id = iabs (jt(j) - jt(i)) do 60 k = 1,maxt if (jt(k) .ne. id) go to 60 iwksp(iloc) = k go to 65 60 continue iwksp(iloc) = nbig 65 continue 70 continue do 100 k = 1,nm1 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 do 95 i = 1,maxt kf = k + jt(i) if (kf .gt. n) go to 95 do 75 j = i,maxt 75 wksp(j) = t(k,i)*t(k,j)/pivot d(kf) = d(kf) - wksp(i) do 90 j = i,maxt if (j .eq. i) go to 90 kg = k + jt(j) if (kg .gt. n) go to 90 iloc = (j-1)*maxt+i id = iwksp(iloc) if (id .eq. nbig) go to 85 kff = min (kf,kg) t(kff,id) = t(kff,id) - wksp(j) go to 90 85 if (meth .eq. 1) go to 90 d(kf) = d(kf) - omega*wksp(j) d(kg) = d(kg) - omega*wksp(j) 90 continue 95 continue 100 continue if (d(n) .eq. 0.0d0) go to 995 c c ... store reciprocals of pivots. c 500 do 505 i = 1,n 505 d(i) = 1.0d0/d(i) if (maxt .lt. 1 .or. propa) go to 990 do 515 j = 1,maxt len = n - jt(j) do 510 i = 1,len 510 t(i,j) = d(i)*t(i,j) 515 continue c c ... check for negative pivots. c 990 if (vmin(n,d) .lt. 0.0d0) iflag = 2 return c c ... error - matrix cannot be factored since a pivot is zero c 995 iflag = 1 return end subroutine icfn (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,meth, a ipropa,omega,wksp,iwksp,iflag) implicit double precision (a-h, o-z) c c ... icfn computes an incomplete factorization of the matrix c stored in d, t, and b and replaces it. c (nonsymmetric diagonal storage) c c ... parameters -- c c ndim row dimension of t,b arrays c n order of system (= nn) c maxt number of columns in t array c maxb number of columns in b array c jt integer vector giving the diagonal indices of c the corresponding columns in t c jb integer vector giving the diagonal indices of c the corresponding columns in b c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the c super-diagonals of the matrix c b array of active size n by maxb giving the c sub-diagonals of the matrix c meth point factorization wanted c = 1 ic c = 2 mic c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c omega modification factor between 0.0 and 1.0 c = 0 no modification c = 1 full modification c wksp workspace vector of length n c iwksp integer workspace of length maxb*maxt c iflag indicator of factorization stability c iflag = 0 no errors detected c = 1 zero pivot encountered c (unsuccessful factorization) c = 2 negative pivot encountered c (successful factorization) c c ... specifications for parameters c integer jt(1), jb(1), iwksp(1) dimension d(1), t(ndim,1), b(ndim,1), wksp(1) logical propa c c n = nn maxt = maxtt maxb = maxbb iflag = 0 propa = ipropa .eq. 1 if (maxt .lt. 1 .or. maxb .lt. 1) go to 500 nm1 = n - 1 if (meth .ne. 1 .or. .not. propa) go to 30 c c ... ic, propa = t. c nval = 0 do 15 j = 1,maxb i1 = -jb(j) do 10 i = 1,maxt i2 = jt(i) if (i1 .ne. i2) go to 10 nval = nval + 1 iwksp(3*nval-2) = j iwksp(3*nval-1) = i iwksp(3*nval) = i2 go to 15 10 continue 15 continue if (nval .eq. 0) go to 500 do 25 k = 1,nm1 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 do 20 j = 1,nval kf = k + iwksp(3*j) if (kf .gt. n) go to 20 i1 = iwksp(3*j-2) i2 = iwksp(3*j-1) d(kf) = d(kf) - b(kf,i1)*t(k,i2)/pivot 20 continue 25 continue if (d(n) .eq. 0.0d0) go to 995 go to 500 30 if (meth .ne. 2 .or. .not. propa) go to 70 c c ... mic, propa = t. c do 35 i = 1,n 35 wksp(i) = 0.0d0 do 45 j = 1,maxt do 40 i = 1,n 40 wksp(i) = wksp(i) + t(i,j) 45 continue do 55 i = 1,maxb i1 = -jb(i) do 50 j = 1,maxt i2 = jt(j) if (i1 .ne. i2) go to 50 iwksp(i) = j go to 55 50 continue iwksp(i) = 0 55 continue do 65 k = 1,nm1 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 do 60 i = 1,maxb kf = k - jb(i) if (kf .gt. n) go to 60 term = b(kf,i)/pivot t1 = 0.0d0 i1 = iwksp(i) if (i1 .ne. 0) t1 = t(k,i1) d(kf) = d(kf) - term*(omega*wksp(k)-(omega-1.0d0)*t1) 60 continue 65 continue if (d(n) .eq. 0.0d0) go to 995 go to 500 c c ... ic, mic for propa = f. c 70 nbig = maxt + maxb do 105 i = 1,maxb do 100 j = 1,maxt iloc = (j - 1)*maxb + i id = jt(j) + jb(i) if (id) 75,85,90 75 do 80 k = 1,maxb if (jb(k) .ne. id) go to 80 iwksp(iloc) = -k go to 100 80 continue iwksp(iloc) = nbig go to 100 85 iwksp(iloc) = 0 go to 100 90 do 95 k = 1,maxt if (jt(k) .ne. id) go to 95 iwksp(iloc) = k go to 100 95 continue iwksp(iloc) = nbig 100 continue 105 continue do 140 k = 1,nm1 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 do 135 i = 1,maxb kf = k - jb(i) if (kf .gt. n) go to 135 do 110 j = 1,maxt 110 wksp(j) = b(kf,i)*t(k,j)/pivot do 130 j = 1,maxt iloc = (j-1)*maxb+i id = iwksp(iloc) if (id) 115,120,125 115 mid = -id b(kf,mid) = b(kf,mid) - wksp(j) go to 130 120 d(kf) = d(kf) - wksp(j) go to 130 125 if (id .ne. nbig) t(kf,id) = t(kf,id) - wksp(j) if (id .eq. nbig .and. meth .eq. 2) a d(kf) = d(kf) - omega*wksp(j) 130 continue 135 continue 140 continue if (d(n) .eq. 0.0d0) go to 995 c c ... store reciprocals of pivots. c 500 do 505 i = 1,n 505 d(i) = 1.0d0/d(i) if (maxt .lt. 1 .or. propa) go to 520 do 515 j = 1,maxt len = n - jt(j) do 510 i = 1,len 510 t(i,j) = d(i)*t(i,j) 515 continue 520 if (maxb .lt. 1 .or. propa) go to 990 do 530 j = 1,maxb ind = jb(j) len = n + ind do 525 i = 1,len 525 b(i-ind,j) = d(i)*b(i-ind,j) 530 continue c c ... check for negative pivots. c 990 if (vmin(n,d) .lt. 0.0d0) iflag = 2 return c c ... error - matrix cannot be factored since a pivot is zero c 995 iflag = 1 return end subroutine icfv (ndim,nn,maxtt,jt,d,t,meth, a ipropa,omega,wksp,iwksp,iflag) implicit double precision (a-h, o-z) c c ... icfv computes an incomplete factorization of the matrix c stored in d and t and replaces it. c (symmetric diagonal storage, vectorized version) c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector giving the diagonal indices of c the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the c super-diagonals of the matrix c meth point factorization wanted c = 1 ic c = 2 mic c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c omega modification factor between 0.0 and 1.0 c = 0 no modification c = 1 full modification c wksp workspace vector of length n c iwksp integer workspace of length maxt**2 c iflag indicator of factorization stability c iflag = 0 no errors detected c = 1 zero pivot encountered c (unsuccessful factorization) c = 2 negative pivot encountered c (successful factorization) c c ... specifications for parameters c integer jt(1), iwksp(1) dimension d(1), t(ndim,1), wksp(1) logical propa c c n = nn maxt = maxtt iflag = 0 propa = ipropa .eq. 1 if (maxt .lt. 1) go to 500 if (meth .ne. 1 .or. .not. propa) go to 45 c c ... ic, propa = t. c do 10 i = 1,maxt 10 iwksp(i) = jt(i) + 1 c c ... determine nc, imin. c 15 nc = n do 20 i = 1,maxt nterm = iwksp(i) - 1 if (nterm .ge. nc) go to 20 nc = nterm imin = i 20 continue if (nc .ge. n) go to 500 ndel = jt(imin) ibeg = nc + 1 if (ndel .gt. 1) go to 35 c c ... special case for first super-diagonal. c nc1 = n do 25 i = 1,maxt if (i .eq. imin) go to 25 if (iwksp(i) .lt. nc1) nc1 = iwksp(i) 25 continue iwksp(imin) = nc1 + 1 do 30 j = ibeg,nc1 30 d(j) = d(j) - (t(j-1,imin)**2)/d(j-1) go to 15 c c ... far diagonals. c 35 iwksp(imin) = iwksp(imin) + ndel ied = min (ibeg+ndel-1,n) cdir$ ivdep do 40 i = ibeg,ied 40 d(i) = d(i) - (t(i-ndel,imin)**2)/d(i-ndel) go to 15 45 if (meth .ne. 2 .or. .not. propa) go to 100 c c ... mic, propa = t. c do 50 i = 1,n 50 wksp(i) = 0.0d0 do 60 j = 1,maxt do 55 i = 1,n 55 wksp(i) = wksp(i) + t(i,j) 60 continue do 65 i = 1,maxt 65 iwksp(i) = jt(i) + 1 c c ... determine nc, imin. c 70 nc = n do 75 i = 1,maxt nterm = iwksp(i) - 1 if (nterm .ge. nc) go to 75 nc = nterm imin = i 75 continue if (nc .ge. n) go to 500 ndel = jt(imin) ibeg = nc + 1 if (ndel .gt. 1) go to 90 c c ... special case for first super-diagonal. c nc1 = n do 80 i = 1,maxt if (i .eq. imin) go to 80 if (iwksp(i) .lt. nc1) nc1 = iwksp(i) 80 continue iwksp(imin) = nc1 + 1 do 85 j = ibeg,nc1 85 d(j) = d(j) - t(j-1,imin)*(omega*wksp(j-1)- a (omega-1.0d0)*t(j-1,imin))/d(j-1) go to 70 c c ... far diagonals. c 90 iwksp(imin) = iwksp(imin) + ndel ied = min (ibeg+ndel-1,n) cdir$ ivdep do 95 i = ibeg,ied 95 d(i) = d(i) - t(i-ndel,imin)*(omega*wksp(i-ndel)- a (omega-1.0d0)*t(i-ndel,imin))/d(i-ndel) go to 70 c c ... set up pointers for propa = f case. c 100 nbig = maxt + 1 do 115 i = 1,maxt do 110 j = 1,maxt iloc = j*maxt + i id = iabs (jt(j) - jt(i)) do 105 k = 1,maxt if (jt(k) .ne. id) go to 105 iwksp(iloc) = k go to 110 105 continue iwksp(iloc) = nbig 110 continue 115 continue c c ... ic, mic for propa = f. c do 120 i = 1,maxt 120 iwksp(i) = jt(i) + 1 c c ... determine nc, imin. c 125 nc = n do 130 i = 1,maxt nterm = iwksp(i) - 1 if (nterm .ge. nc) go to 130 nc = nterm imin = i 130 continue if (nc .ge. n) go to 500 ndel = jt(imin) iwksp(imin) = iwksp(imin) + ndel ibeg = nc + 1 ied = min (ibeg+ndel-1,n) cdir$ ivdep do 135 i = ibeg,ied 135 d(i) = d(i) - (t(i-ndel,imin)**2)/d(i-ndel) do 160 j = 1,maxt jcol = jt(j) if (jcol .le. ndel) go to 160 iloc = j*maxt + imin id = iwksp(iloc) ied1 = min (ied,n-jcol+ndel) if (id .eq. nbig) go to 145 cdir$ ivdep do 140 i = ibeg,ied1 140 t(i,id) = t(i,id) - t(i-ndel,imin)*t(i-ndel,j)/d(i-ndel) go to 160 145 if (meth .eq. 1) go to 160 do 150 i = ibeg,ied1 150 wksp(i) = omega*t(i-ndel,imin)*t(i-ndel,j)/d(i-ndel) ish = jcol - ndel do 155 i = ibeg,ied1 d(i) = d(i) - wksp(i) d(i+ish) = d(i+ish) - wksp(i) 155 continue 160 continue go to 125 c c ... store reciprocals of pivots. c 500 do 505 i = 1,n if (d(i) .eq. 0.0d0) go to 995 505 continue do 510 i = 1,n 510 d(i) = 1.0d0/d(i) if (maxt .lt. 1 .or. propa) go to 990 do 520 j = 1,maxt len = n - jt(j) do 515 i = 1,len 515 t(i,j) = d(i)*t(i,j) 520 continue c c ... check for negative pivots. c 990 if (vmin(n,d) .lt. 0.0d0) iflag = 2 return c c ... error - matrix cannot be factored since a pivot is zero c 995 iflag = 1 return end subroutine icfnp (ndimr,ndimi,nn,maxtt,maxbb,jt,jb,d,t,b,meth, a ipropa,omega,iflag) implicit double precision (a-h, o-z) c c ... icfnp computes an incomplete factorization of the matrix c stored in d, t, and b and replaces it. c (purdue storage, nonsymmetric matrix) c c ... parameters -- c c ndimr row dimension of t and b arrays c ndimi row dimension of jt and jb arrays c n order of system (= nn) c maxt number of columns in t,jt arrays c maxb number of columns in b,jb arrays c jt integer array giving the column indices of the c corresponding elements in t c jb integer array giving the column indices of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the c upper triangle of the matrix c b array of active size n by maxb giving the c lower triangle of the matrix c meth point factorization wanted c = 1 ic c = 2 mic c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c omega modification factor between 0.0 and 1.0 c = 0 no modification c = 1 full modification c iflag indicator of factorization stability c iflag = 0 no errors detected c = 1 zero pivot encountered c (unsuccessful factorization) c = 2 negative pivot encountered c (successful factorization) c c ... specifications for parameters c integer jt(ndimi,1), jb(ndimi,1) dimension d(1), t(ndimr,1), b(ndimr,1) logical propa c c n = nn maxt = maxtt maxb = maxbb iflag = 0 propa = ipropa .eq. 1 c if (maxt .lt. 1 .or. maxb .lt. 1) go to 50 nm1 = n - 1 do 45 k = 1,nm1 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 kp1 = k + 1 do 40 j1 = 1,maxb do 35 i = kp1,n jcol1 = jb(i,j1) if (jcol1 .ne. k) go to 35 term1 = b(i,j1)/pivot do 30 j2 = 1,maxt j = jt(k,j2) if (j .le. k) go to 30 term2 = term1*t(k,j2) jdiff = j - i if (jdiff .eq. 0) go to 27 if (propa) go to 25 if (jdiff .gt. 0) go to 15 do 10 j3 = 1,maxb if (jb(i,j3) .ne. j) go to 10 b(i,j3) = b(i,j3) - term2 go to 30 10 continue go to 25 15 do 20 j3 = 1,maxt if (jt(i,j3) .ne. j) go to 20 t(i,j3) = t(i,j3) - term2 go to 30 20 continue 25 if (meth .eq. 1) go to 30 27 d(i) = d(i) - omega*term2 30 continue 35 continue 40 continue 45 continue if (d(n) .eq. 0.0d0) go to 995 c c ... store reciprocals of pivots. c 50 do 55 i = 1,n 55 d(i) = 1.0d0/d(i) if (maxt .lt. 1 .or. propa) go to 70 do 65 j = 1,maxt do 60 i = 1,n 60 t(i,j) = d(i)*t(i,j) 65 continue 70 if (maxb .lt. 1 .or. propa) go to 990 do 80 j = 1,maxb do 75 i = 1,n 75 b(i,j) = b(i,j)*d(jb(i,j)) 80 continue c c ... check for negative pivots. c 990 if (vmin(n,d) .lt. 0.0d0) iflag = 2 return c c ... error - matrix cannot be factored since a pivot is zero c 995 iflag = 1 return end subroutine icfp (ndimr,ndimi,nn,maxtt,jt,d,t,meth,ipropa,omega, a wksp,iflag) implicit double precision (a-h, o-z) c c ... icfp computes an incomplete factorization of the matrix c stored in d and t and replaces it. c (purdue storage, symmetric matrix) c c ... parameters -- c c ndimr row dimension of t array c ndimi row dimension of jt array c n order of system (= nn) c maxt number of columns in t array c jt integer array of active size n by maxt giving the c column numbers of the corresponding elements in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the c coefficients of the upper triangle of the matrix c meth point factorization wanted c = 1 ic c = 2 mic c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c omega modification factor between 0.0 and 1.0 c = 0 no modification c = 1 full modification c wksp workspace array of length n c iflag indicator of factorization stability c iflag = 0 no errors detected c = 1 zero pivot encountered c (unsuccessful factorization) c = 2 negative pivot encountered c (successful factorization) c c ... specifications for parameters c dimension d(1), t(ndimr,1), wksp(1) integer jt(ndimi,1) logical propa c c n = nn maxt = maxtt iflag = 0 propa = ipropa .eq. 1 if (maxt .lt. 1) go to 500 nm1 = n - 1 if (meth .ne. 1 .or. .not. propa) go to 20 c c ... ic, propa = t. c do 15 k = 1,nm1 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 do 10 j = 1,maxt jcol = jt(k,j) d(jcol) = d(jcol) - t(k,j)**2/pivot 10 continue 15 continue if (d(n) .eq. 0.0d0) go to 995 go to 500 20 if (meth .ne. 2 .or. .not. propa) go to 50 c c ... mic, propa = t. c do 25 i = 1,n 25 wksp(i) = 0.0d0 do 35 j = 1,maxt do 30 i = 1,n 30 wksp(i) = wksp(i) + t(i,j) 35 continue do 45 k = 1,nm1 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 do 40 i = 1,maxt jcol = jt(k,i) if (jcol .eq. k) go to 40 term = t(k,i)/pivot d(jcol) = d(jcol) - term*(omega*wksp(k) a -(omega-1.0d0)*t(k,i)) 40 continue 45 continue if (d(n) .eq. 0.0d0) go to 995 go to 500 c c ... ic, mic for propa = f. c 50 do 70 k = 1,nm1 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 do 65 j1 = 1,maxt jcol1 = jt(k,j1) if (jcol1 .eq. k) go to 65 d(jcol1) = d(jcol1) - (t(k,j1)**2)/pivot term1 = t(k,j1)/pivot do 60 j2 = 1,maxt jcol2 = jt(k,j2) if (jcol2 .le. jcol1) go to 60 if (jcol2 .eq. k) go to 60 term2 = term1*t(k,j2) do 55 j3 = 1,maxt if (jcol2 .ne. jt(jcol1,j3)) go to 55 t(jcol1,j3) = t(jcol1,j3) - term2 go to 60 55 continue if (meth .eq. 1) go to 60 d(jcol1) = d(jcol1) - omega*term2 d(jcol2) = d(jcol2) - omega*term2 60 continue 65 continue 70 continue if (d(n) .eq. 0.0d0) go to 995 c c ... store reciprocals of pivots and scale t. c 500 do 510 i = 1,n 510 d(i) = 1.0d0/d(i) if (maxt .lt. 1 .or. propa) go to 990 do 520 j = 1,maxt do 515 i = 1,n 515 t(i,j) = d(i)*t(i,j) 520 continue c c ... check for negative pivots. c 990 if (vmin(n,d) .lt. 0.0d0) iflag = 2 return c c ... error - matrix cannot be factored since a pivot is zero c 995 iflag = 1 return end subroutine icfcp (ndimr,ndimi,nn,maxcc,jc,d,c,ncolor,nt,nb, a meth,ipropa,ipt,omega,iflag) implicit double precision (a-h, o-z) c c ... icfcp computes an incomplete factorization of the matrix c stored in d and c and replaces it. c (purdue storage, multicolor) c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c n order of system (= nn) c maxc number of columns in c array c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c meth point factorization wanted c = 1 ic c = 2 mic c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c ipt integer pointer vector of length ncolor + 1 c omega modification factor between 0.0 and 1.0 c = 0 no modification c = 1 full modification c iflag indicator of factorization stability c iflag = 0 no errors detected c = 1 zero pivot encountered c (unsuccessful factorization) c = 2 negative pivot encountered c (successful factorization) c c ... specifications for parameters c integer jc(ndimi,1), nt(1), nb(1), ipt(1) dimension d(1), c(ndimr,1) logical propa c c n = nn maxc = maxcc ncol = ncolor iflag = 0 propa = ipropa .eq. 1 if (maxc .lt. 1) go to 75 c c ... do factorization. c do 65 icol = 1,ncol-1 k1 = ipt(icol) + 1 k2 = ipt(icol+1) j22 = nt(icol) if (j22 .le. 0) go to 65 do 60 k = k1,k2 pivot = d(k) if (pivot .eq. 0.0d0) go to 995 do 55 l1 = icol+1,ncol i1 = ipt(l1) + 1 i2 = ipt(l1+1) j11 = nt(l1) + 1 j12 = nt(l1) + nb(l1) j32 = nt(l1) if (j11 .gt. j12) go to 55 do 50 j1 = j11,j12 do 45 i = i1,i2 jcol1 = jc(i,j1) if (jcol1 .ne. k) go to 45 term1 = c(i,j1)/pivot do 40 j2 = 1,j22 j = jc(k,j2) if (j .le. k) go to 40 term2 = term1*c(k,j2) if (j .eq. i) go to 35 if (propa) go to 30 if (j .gt. i) go to 20 do 15 j3 = j11,j12 if (jc(i,j3) .ne. j) go to 15 c(i,j3) = c(i,j3) - term2 go to 40 15 continue go to 30 20 if (j32 .le. 0) go to 30 do 25 j3 = 1,j32 if (jc(i,j3) .ne. j) go to 25 c(i,j3) = c(i,j3) - term2 go to 40 25 continue 30 if (meth .eq. 1) go to 40 35 d(i) = d(i) - omega*term2 40 continue 45 continue 50 continue 55 continue 60 continue 65 continue k1 = ipt(ncol) + 1 k2 = ipt(ncol+1) do 70 k = k1,k2 if (d(k) .eq. 0.0d0) go to 995 70 continue c c ... store reciprocals of pivots. c 75 do 80 i = 1,n 80 d(i) = 1.0d0/d(i) if (maxc .lt. 1 .or. propa) go to 990 do 105 icol = 1,ncol nt2 = nt(icol) i1 = ipt(icol) + 1 i2 = ipt(icol+1) do 100 j = 1,maxc if (j .gt. nt2) go to 90 do 85 i = i1,i2 85 c(i,j) = d(i)*c(i,j) go to 100 90 do 95 i = i1,i2 95 c(i,j) = c(i,j)*d(jc(i,j)) 100 continue 105 continue c c ... check for negative pivots. c 990 if (vmin(n,d) .lt. 0.0d0) iflag = 2 return c c ... error - matrix cannot be factored since a pivot is zero c 995 iflag = 1 return end subroutine ics (ndim,nn,maxtt,jt,d,t,ipropa,irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... ics does an ic solution (natural ordering, c symmetric diagonal storage). c c (i + (t**t))*inv(d)*(i + t)*x = y propa = .false. c (i + (t**t)*d)*inv(d)*(i + d*t)*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c n = nn maxt = maxtt do 10 i = 1,n 10 x(i) = y(i) call icfst (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call icbs (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) return end subroutine ics1 (ndim,nn,maxtt,jt,d,t,ipropa,irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... ics1 does an ic forward solution (natural ordering, c symmetric diagonal storage). c c (i + (t**t))*inv(d)*x = y propa = .false. c (i + (t**t)*d)*inv(d)*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c n = nn maxt = maxtt do 10 i = 1,n 10 x(i) = y(i) call icfst (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = sqrt(abs(d(i)))*x(i) return end subroutine ics2 (ndim,nn,maxtt,jt,d,t,ipropa,irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... ics2 does an ic back solution (natural ordering, c symmetric diagonal storage). c c (i + t)*x = y propa = .false. c (i + d*t)*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c n = nn maxt = maxtt do 10 i = 1,n 10 x(i) = y(i)*sign(1.0d0,d(i))*sqrt(abs(d(i))) call icbs (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) return end subroutine ics3 (ndim,nn,maxtt,jt,d,t,ipropa,irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... ics3 does an ic transpose backward solution (natural ordering, c symmetric diagonal storage). c c inv(d)*(i + t)*x = y propa = .false. c inv(d)*(i + d*t)*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c n = nn maxt = maxtt do 15 i = 1,n 15 x(i) = sqrt(abs(d(i)))*y(i) call icbs (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) return end subroutine ics4 (ndim,nn,maxtt,jt,d,t,ipropa,irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... ics4 does an ic transpose forward solution (natural ordering, c symmetric diagonal storage). c c (i + (t**t))*x = y propa = .false. c (i + (t**t)*d)*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c n = nn maxt = maxtt do 10 i = 1,n 10 x(i) = y(i) call icfst (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = x(i)*sign(1.0d0,d(i))*sqrt(abs(d(i))) return end subroutine icsn (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,ipropa, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... icsn does an ic solution (natural ordering, c nonsymmetric diagonal storage). c c (i + b)*inv(d)*(i + t)*x = y propa = .false. c (i + b*d)*inv(d)*(i + d*t)*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxt number of columns in t array c maxb number of columns in b array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c b array of active size n by maxb giving the sub- c diagonals of the factorization if not property a c or the sub-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1), b(ndim,1) integer jt(1), jb(1), iwksp(1) c n = nn maxt = maxtt maxb = maxbb do 10 i = 1,n 10 x(i) = y(i) call icfs (ndim,n,maxb,jb,d,b,ipropa,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call icbs (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) return end subroutine icsnt (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,ipropa, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... icsnt does an transpose ic solution (natural ordering, c nonsymmetric diagonal storage). c c (i + (t**t))*inv(d)*(i + (b**t))*x = y propa = .false. c (i + (t**t)*d)*inv(d)*(i + d*(b**t))*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxt number of columns in t array c maxb number of columns in b array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c b array of active size n by maxb giving the sub- c diagonals of the factorization if not property a c or the sub-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1), b(ndim,1) integer jt(1), jb(1), iwksp(1) c n = nn maxt = maxtt maxb = maxbb do 10 i = 1,n 10 x(i) = y(i) call icfst (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call icbst (ndim,n,maxb,jb,d,b,ipropa,irwise,iwksp,x) return end subroutine icsn1 (ndim,n,maxb,jb,d,b,ipropa, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... icsn1 does an ic forward pass (natural ordering, c nonsymmetric diagonal storage). c c (i + b)*inv(d)*(i + t)*x = y propa = .false. c (i + b*d)*inv(d)*(i + d*t)*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxb number of columns in b array c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the factorization c b array of active size n by maxb giving the sub- c diagonals of the factorization if not property a c or the sub-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) c do 10 i = 1,n 10 x(i) = y(i) call icfs (ndim,n,maxb,jb,d,b,ipropa,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = sqrt(abs(d(i)))*x(i) return end subroutine icsn2 (ndim,n,maxt,jt,d,t,ipropa, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... icsn2 does an ic back pass (natural ordering, c nonsymmetric diagonal storage). c c (i + b)*inv(d)*(i + t)*x = y propa = .false. c (i + b*d)*inv(d)*(i + d*t)*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c do 10 i = 1,n 10 x(i) = y(i)*sign(1.0d0,d(i))*sqrt(abs(d(i))) call icbs (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) return end subroutine icsn3 (ndim,n,maxb,jb,d,b,ipropa, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... icsn3 does an ic transpose back pass (natural ordering, c nonsymmetric diagonal storage). c c (i + b)*inv(d)*(i + t)*x = y propa = .false. c (i + b*d)*inv(d)*(i + d*t)*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxb number of columns in b array c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the factorization c b array of active size n by maxb giving the sub- c diagonals of the factorization if not property a c or the sub-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) c do 15 i = 1,n 15 x(i) = sqrt(abs(d(i)))*y(i) call icbst (ndim,n,maxb,jb,d,b,ipropa,irwise,iwksp,x) return end subroutine icsn4 (ndim,n,maxt,jt,d,t,ipropa, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... icsn4 does an ic transpose forward pass (natural ordering, c nonsymmetric diagonal storage). c c (i + b)*inv(d)*(i + t)*x = y propa = .false. c (i + b*d)*inv(d)*(i + d*t)*x = y propa = .true. c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c do 10 i = 1,n 10 x(i) = y(i) call icfst (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = x(i)*sign(1.0d0,d(i))*sqrt(abs(d(i))) return end subroutine icsnp (ndimr,ndimi,nn,maxtt,maxbb,jt,jb,d,t,b, a ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsnp does an ic solution (natural ordering, c purdue storage, nonsymmetric matrix). c c (i + b)*d*(i + t)*x = y if ipropa = 0 c (d + b)*inv(d)*(d + t)*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c maxb number of columns in b array c jt integer array giving the column numbers of the c corresponding elements in t c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c b array of active size n by maxb giving the lower c triangle of the factorization if ipropa = 0 c or the lower triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndimr,1), b(ndimr,1) integer jt(ndimi,1), jb(ndimi,1) c n = nn maxt = maxtt maxb = maxbb do 10 i = 1,n 10 x(i) = y(i) call icfsp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*d(i) go to 30 20 do 25 i = 1,n 25 x(i) = x(i)/d(i) 30 continue call icbsp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) return end subroutine icsntp (ndimr,ndimi,nn,maxtt,maxbb,jt,jb,d,t,b, a ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsntp does an transpose ic solution (natural ordering, c purdue storage, nonsymmetric matrix). c c (i + (t**t))*d*(i + (b**t))*x = y if ipropa = 0 c (d + (t**t))*inv(d)*(d + (b**t))*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c maxb number of columns in b array c jt integer array giving the column numbers of the c corresponding elements in t c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c b array of active size n by maxb giving the lower c triangle of the factorization if ipropa = 0 c or the lower triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndimr,1), b(ndimr,1) integer jt(ndimi,1), jb(ndimi,1) c n = nn maxt = maxtt maxb = maxbb do 10 i = 1,n 10 x(i) = y(i) call icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*d(i) go to 30 20 do 25 i = 1,n 25 x(i) = x(i)/d(i) 30 continue call icbstp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) return end subroutine icsnp1 (ndimr,ndimi,nn,maxb,jb,d,b,ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsnp1 does an ic forward solution (natural ordering, c purdue storage, nonsymmetric matrix). c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxb number of columns in b array c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the factorization c b array of active size n by maxb giving the lower c triangle of the factorization if ipropa = 0 c or the lower triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), b(ndimr,1) integer jb(ndimi,1) c n = nn do 10 i = 1,n 10 x(i) = y(i) call icfsp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*sqrt(abs(d(i))) return 20 do 25 i = 1,n 25 x(i) = x(i)/sqrt(abs(d(i))) return end subroutine icsnp2 (ndimr,ndimi,n,maxt,jt,d,t,ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsnp2 does an ic back solution (natural ordering, c purdue storage, nonsymmetric matrix). c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) c if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = y(i)*sign(1.0d0,d(i))*sqrt(abs(d(i))) go to 30 20 do 25 i = 1,n 25 x(i) = y(i)/(sign(1.0d0,d(i))*sqrt(abs(d(i)))) 30 continue call icbsp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) return end subroutine icsnp3 (ndimr,ndimi,n,maxb,jb,d,b,ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsnp3 does an transpose ic forward solution (natural ordering, c purdue storage, nonsymmetric matrix). c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxb number of columns in b array c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the factorization c b array of active size n by maxb giving the lower c triangle of the factorization if ipropa = 0 c or the lower triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), b(ndimr,1) integer jb(ndimi,1) c if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = y(i)*sqrt(abs(d(i))) go to 30 20 do 25 i = 1,n 25 x(i) = y(i)/sqrt(abs(d(i))) 30 continue call icbstp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) return end subroutine icsnp4 (ndimr,ndimi,n,maxt,jt,d,t,ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsnp4 does an transpose ic back solution (natural ordering, c purdue storage, nonsymmetric matrix). c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) c do 10 i = 1,n 10 x(i) = y(i) call icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*sign(1.0d0,d(i))*sqrt(abs(d(i))) return 20 do 25 i = 1,n 25 x(i) = x(i)/(sign(1.0d0,d(i))*sqrt(abs(d(i)))) return end subroutine icsp (ndimr,ndimi,nn,maxtt,jt,d,t,ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsp does an ic solution (natural ordering, c purdue storage, symmetric matrix). c c (i + (t**t))*d*(i + t)*x = y if ipropa = 0 c (d + (t**t))*inv(d)*(d + t)*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) c n = nn maxt = maxtt do 10 i = 1,n 10 x(i) = y(i) call icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*d(i) go to 30 20 do 25 i = 1,n 25 x(i) = x(i)/d(i) 30 continue call icbsp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) return end subroutine icsp1 (ndimr,ndimi,nn,maxt,jt,d,t,ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsp1 does an ic forward solution (natural ordering, c purdue storage, symmetric matrix). c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) c n = nn do 10 i = 1,n 10 x(i) = y(i) call icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*sqrt(abs(d(i))) return 20 do 25 i = 1,n 25 x(i) = x(i)/sqrt(abs(d(i))) return end subroutine icsp2 (ndimr,ndimi,n,maxt,jt,d,t,ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsp2 does an ic back solution (natural ordering, c purdue storage, symmetric matrix). c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) c if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = y(i)*sign(1.0d0,d(i))*sqrt(abs(d(i))) go to 30 20 do 25 i = 1,n 25 x(i) = y(i)/(sign(1.0d0,d(i))*sqrt(abs(d(i)))) 30 continue call icbsp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) return end subroutine icsp3 (ndimr,ndimi,n,maxt,jt,d,t,ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsp3 does an ic transpose forward solution (natural ordering, c purdue storage, symmetric matrix). c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) c if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = y(i)*sqrt(abs(d(i))) go to 30 20 do 25 i = 1,n 25 x(i) = y(i)/sqrt(abs(d(i))) 30 continue call icbsp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) return end subroutine icsp4 (ndimr,ndimi,n,maxt,jt,d,t,ipropa,y,x) implicit double precision (a-h, o-z) c c ... icsp4 does an ic transpose back solution (natural ordering, c purdue storage, symmetric matrix). c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) c do 10 i = 1,n 10 x(i) = y(i) call icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*sign(1.0d0,d(i))*sqrt(abs(d(i))) return 20 do 25 i = 1,n 25 x(i) = x(i)/(sign(1.0d0,d(i))*sqrt(abs(d(i)))) return end subroutine icscp (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,nb,ipropa, a wksp,y,x) implicit double precision (a-h, o-z) c c ... icscp does an ic solve. c (purdue storage, multicolor) c c (i + b)*d*(i + t)*x = y if ipropa = 0 c (d + b)*inv(d)*(d + t)*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c y on input, y is the right-hand-side vector c x on output, x is the solution to the forward solve c c ... specifications for parameters c integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) c n = nn c do 10 i = 1,n 10 x(i) = y(i) call icfscp (ndimr,ndimi,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp, a x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*d(i) go to 30 20 do 25 i = 1,n 25 x(i) = x(i)/d(i) 30 continue call icbscp (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,ipropa,wksp, a x) return end subroutine icscpt (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,nb,ipropa, a wksp,y,x) implicit double precision (a-h, o-z) c c ... icscpt does an transpose ic solve. c (purdue storage, multicolor) c c (i + (t**t))*d*(i + (b**t))*x = y if ipropa = 0 c (d + (t**t))*inv(d)*(d + (b**t))*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c wksp workspace vector of length max(nc(i)) c y on input, y is the right-hand-side vector c x on output, x is the solution vector c c ... specifications for parameters c integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) c n = nn c do 10 i = 1,n 10 x(i) = y(i) call icfsct (ndimr,ndimi,jc,d,c,ncolor,nc,nt,ipropa,wksp, a x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*d(i) go to 30 20 do 25 i = 1,n 25 x(i) = x(i)/d(i) 30 continue call icbsct (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp, a x) return end subroutine icscp1 (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,nb,ipropa, a wksp,y,x) implicit double precision (a-h, o-z) c c ... icscp1 does an ic forward solve. c (purdue storage, multicolor) c c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c y on input, y is the right-hand-side vector c x on output, x is the solution to the forward solve c c ... specifications for parameters c integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) c n = nn c do 10 i = 1,n 10 x(i) = y(i) call icfscp (ndimr,ndimi,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp, a x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*sqrt(abs(d(i))) return 20 do 25 i = 1,n 25 x(i) = x(i)/sqrt(abs(d(i))) return end subroutine icscp2 (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,ipropa, a wksp,y,x) implicit double precision (a-h, o-z) c c ... icscp2 does an ic back solve. c (purdue storage, multicolor) c c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c y on input, y is the right-hand-side vector c x on output, x is the solution to the forward solve c c ... specifications for parameters c integer jc(ndimi,1), nc(1), nt(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) c n = nn c if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = y(i)*sign(1.0d0,d(i))*sqrt(abs(d(i))) go to 30 20 do 25 i = 1,n 25 x(i) = y(i)/(sign(1.0d0,d(i))*sqrt(abs(d(i)))) 30 continue call icbscp (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,ipropa,wksp, a x) return end subroutine icscp3 (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,nb,ipropa, a wksp,y,x) implicit double precision (a-h, o-z) c c ... icscp3 does an transpose ic forward solve. c (purdue storage, multicolor) c c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c wksp workspace vector of length max(nc(i)) c y on input, y is the right-hand-side vector c x on output, x is the solution vector c c ... specifications for parameters c integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) c n = nn c if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = y(i)*sqrt(abs(d(i))) go to 30 20 do 25 i = 1,n 25 x(i) = y(i)/sqrt(abs(d(i))) 30 continue call icbsct (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp, a x) return end subroutine icscp4 (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,ipropa, a wksp,y,x) implicit double precision (a-h, o-z) c c ... icscp4 does an transpose ic back solve. c (purdue storage, multicolor) c c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c wksp workspace vector of length max(nc(i)) c y on input, y is the right-hand-side vector c x on output, x is the solution vector c c ... specifications for parameters c integer jc(ndimi,1), nc(1), nt(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) c n = nn c do 10 i = 1,n 10 x(i) = y(i) call icfsct (ndimr,ndimi,jc,d,c,ncolor,nc,nt,ipropa,wksp, a x) if (ipropa .eq. 1) go to 20 do 15 i = 1,n 15 x(i) = x(i)*sign(1.0d0,d(i))*sqrt(abs(d(i))) return 20 do 25 i = 1,n 25 x(i) = x(i)/(sign(1.0d0,d(i))*sqrt(abs(d(i)))) return end subroutine icbs (ndim,nn,maxtt,jt,d,t,ipropa,irwise,iwksp,x) implicit double precision (a-h, o-z) c c ... icbs does an ic back solve (natural ordering, c diagonal storage). c (i + t)*x = y if not property a c (i + d*t)*x = y if property a c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c x on input, x contains y c on output, x is the solution to back-solve c c ... specifications for parameters c dimension x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c c logical propa c n = nn maxt = maxtt nm1 = n - 1 propa = ipropa .eq. 1 if (maxt .lt. 1) return c c ... select rowwise or diagonal-wise algorithm. c if (irwise .eq. 1) go to 70 c c ... diagonal-wise algorithm. c do 15 i = 1,maxt 15 iwksp(i) = n - jt(i) c c ... determine nc, imax. c 20 nc = 1 do 25 i = 1,maxt nterm = iwksp(i) + 1 if (nterm .le. nc) go to 25 nc = nterm imax = i 25 continue if (nc .le. 1) return ndel = jt(imax) iend = nc - 1 if (ndel .gt. 1) go to 50 c c ... special case for first super diagonal. c nc1 = 1 do 30 i = 1,maxt if (i .eq. imax) go to 30 if (iwksp(i) .gt. nc1) nc1 = iwksp(i) 30 continue iwksp(imax) = nc1 - 1 if (propa) go to 40 do 35 k = iend,nc1,-1 35 x(k) = x(k) - t(k,imax)*x(k+1) go to 20 40 do 45 k = iend,nc1,-1 45 x(k) = x(k) - d(k)*t(k,imax)*x(k+1) go to 20 c c ... far diagonals (do vector computations). c 50 iwksp(imax) = iwksp(imax) - ndel ibeg = max (iend - ndel,0) + 1 if (propa) go to 60 cdir$ ivdep do 55 i = ibeg,iend 55 x(i) = x(i) - t(i,imax)*x(i+ndel) go to 20 cdir$ ivdep 60 do 65 i = ibeg,iend 65 x(i) = x(i) - d(i)*t(i,imax)*x(i+ndel) go to 20 c c ... rowwise algorithm. c 70 do 85 i = nm1,1,-1 do 75 j = 1,maxt 75 iwksp(j) = min (n,i+jt(j)) sum = 0.0d0 do 80 j = 1,maxt 80 sum = sum + t(i,j)*x(iwksp(j)) if (propa) sum = d(i)*sum x(i) = x(i) - sum 85 continue return end subroutine icbst (ndim,nn,maxbb,jb,d,b,ipropa,irwise,iwksp,x) implicit double precision (a-h, o-z) c c ... icbst does an ic back solve (natural ordering, c diagonal storage). c (i + (b**t))*x = y if not property a c (i + d*(b**t))*x = y if property a c c ... parameters -- c c ndim row dimension of b array c n order of system (= nn) c maxb number of columns in b array c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the factorization c b array of active size n by maxb giving the sub- c diagonals of the factorization if not property a c or the sub-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxb c x on input, x contains y c on output, x is the solution to back-solve c c ... specifications for parameters c dimension x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) logical propa c n = nn maxb = maxbb propa = ipropa .eq. 1 if (maxb .lt. 1) return c c ... select rowwise or diagonal-wise algorithm. c if (irwise .eq. 1) go to 70 c c ... diagonal-wise algorithm. c do 15 i = 1,maxb 15 iwksp(i) = n + jb(i) c c ... determine nc, imax. c 20 nc = 1 do 25 i = 1,maxb nterm = iwksp(i) + 1 if (nterm .le. nc) go to 25 nc = nterm imax = i 25 continue if (nc .le. 1) return ndel = -jb(imax) iend = nc - 1 if (ndel .gt. 1) go to 50 c c ... special case for first sub diagonal. c nc1 = 1 do 30 i = 1,maxb if (i .eq. imax) go to 30 if (iwksp(i) .gt. nc1) nc1 = iwksp(i) 30 continue iwksp(imax) = nc1 - 1 if (propa) go to 40 do 35 k = iend,nc1,-1 35 x(k) = x(k) - b(k+1,imax)*x(k+1) go to 20 40 do 45 k = iend,nc1,-1 45 x(k) = x(k) - d(k)*b(k+1,imax)*x(k+1) go to 20 c c ... far diagonals (do vector computations). c 50 iwksp(imax) = iwksp(imax) - ndel ibeg = max (iend - ndel,0) + 1 if (propa) go to 60 cdir$ ivdep do 55 i = ibeg,iend 55 x(i) = x(i) - b(i+ndel,imax)*x(i+ndel) go to 20 cdir$ ivdep 60 do 65 i = ibeg,iend 65 x(i) = x(i) - d(i)*b(i+ndel,imax)*x(i+ndel) go to 20 c c ... rowwise algorithm. c 70 if (propa) go to 90 do 85 i = n,2,-1 do 75 j = 1,maxb 75 iwksp(j) = max (1,i+jb(j)) term = x(i) do 80 j = 1,maxb 80 x(iwksp(j)) = x(iwksp(j)) - b(i,j)*term 85 continue return 90 do 105 i = n,2,-1 do 95 j = 1,maxb 95 iwksp(j) = max (1,i+jb(j)) term = x(i) do 100 j = 1,maxb 100 x(iwksp(j)) = x(iwksp(j)) - d(iwksp(j))*b(i,j)*term 105 continue return end subroutine icfs (ndim,nn,maxbb,jb,d,b,ipropa,irwise,iwksp,x) implicit double precision (a-h, o-z) c c ... icfs does an ic forward solve (natural ordering, c diagonal storage). c (i + b)*x = y if not property a c (i + b*d)*x = y if property a c c ... parameters -- c c ndim row dimension of b array c n order of system (= nn) c maxb number of columns in b array c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the factorization c b array of active size n by maxb giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxb c x on input, x contains y c on output, x is the solution to forward-solve c c ... specifications for parameters c dimension x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) logical propa c n = nn maxb = maxbb propa = ipropa .eq. 1 if (maxb .lt. 1) return c c ... select rowwise or diagonal-wise algorithm. c if (irwise .eq. 1) go to 70 c c ... diagonal-wise algorithm. c do 15 i = 1,maxb 15 iwksp(i) = 1 - jb(i) c c ... determine nc, imin. c 20 nc = n do 25 i = 1,maxb nterm = iwksp(i) - 1 if (nterm .ge. nc) go to 25 nc = nterm imin = i 25 continue if (nc .ge. n) return ndel = -jb(imin) ibeg = nc + 1 if (ndel .gt. 1) go to 50 c c ... special case for first minor subdiagonal. c nc1 = n do 30 i = 1,maxb if (i .eq. imin) go to 30 if (iwksp(i) .lt. nc1) nc1 = iwksp(i) 30 continue iwksp(imin) = nc1 + 1 if (propa) go to 40 do 35 j = ibeg,nc1 35 x(j) = x(j) - b(j,imin)*x(j-1) go to 20 40 do 45 j = ibeg,nc1 45 x(j) = x(j) - d(j-1)*b(j,imin)*x(j-1) go to 20 c c ... far diagonals (do vector computations). c 50 iwksp(imin) = iwksp(imin) + ndel iend = min (ibeg+ndel-1,n) if (propa) go to 60 cdir$ ivdep do 55 i = ibeg,iend 55 x(i) = x(i) - b(i,imin)*x(i-ndel) go to 20 cdir$ ivdep 60 do 65 i = ibeg,iend 65 x(i) = x(i) - d(i-ndel)*b(i,imin)*x(i-ndel) go to 20 c c ... rowwise algorithm. c 70 if (propa) go to 90 do 85 i = 2,n do 75 j = 1,maxb 75 iwksp(j) = max (1,i+jb(j)) sum = x(i) do 80 j = 1,maxb 80 sum = sum - b(i,j)*x(iwksp(j)) x(i) = sum 85 continue return 90 do 105 i = 2,n do 95 j = 1,maxb 95 iwksp(j) = max (1,i+jb(j)) sum = x(i) do 100 j = 1,maxb 100 sum = sum - d(iwksp(j))*b(i,j)*x(iwksp(j)) x(i) = sum 105 continue return end subroutine icfst (ndim,nn,maxtt,jt,d,t,ipropa,irwise,iwksp,x) implicit double precision (a-h, o-z) c c ... icfst does an ic forward solve (natural ordering, c diagonal storage). c (i + (t**t))*x = y if not property a c (i + (t**t)*d)*x = y if property a c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the super- c diagonals of the factorization if not property a c or the super-diagonals of the matrix if property a c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c x on input, x contains y c on output, x is the solution to forward-solve c c ... specifications for parameters c dimension x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) logical propa c n = nn maxt = maxtt nm1 = n - 1 propa = ipropa .eq. 1 if (maxt .lt. 1) return c c ... select rowwise or diagonal-wise algorithm. c if (irwise .eq. 1) go to 70 c c ... diagonal-wise algorithm. c do 15 i = 1,maxt 15 iwksp(i) = jt(i) + 1 c c ... determine nc, imin. c 20 nc = n do 25 i = 1,maxt nterm = iwksp(i) - 1 if (nterm .ge. nc) go to 25 nc = nterm imin = i 25 continue if (nc .ge. n) return ndel = jt(imin) ibeg = nc + 1 if (ndel .gt. 1) go to 50 c c ... special case for first minor subdiagonal. c nc1 = n do 30 i = 1,maxt if (i .eq. imin) go to 30 if (iwksp(i) .lt. nc1) nc1 = iwksp(i) 30 continue iwksp(imin) = nc1 + 1 if (propa) go to 40 do 35 j = ibeg,nc1 35 x(j) = x(j) - t(j-1,imin)*x(j-1) go to 20 40 do 45 j = ibeg,nc1 45 x(j) = x(j) - d(j-1)*t(j-1,imin)*x(j-1) go to 20 c c ... far diagonals (do vector computations). c 50 iwksp(imin) = iwksp(imin) + ndel iend = min (ibeg+ndel-1,n) if (propa) go to 60 cdir$ ivdep do 55 i = ibeg,iend 55 x(i) = x(i) - t(i-ndel,imin)*x(i-ndel) go to 20 cdir$ ivdep 60 do 65 i = ibeg,iend 65 x(i) = x(i) - d(i-ndel)*t(i-ndel,imin)*x(i-ndel) go to 20 c c ... rowwise algorithm. c 70 do 85 i = 1,nm1 do 75 j = 1,maxt 75 iwksp(j) = min (n,i+jt(j)) term = x(i) if (propa) term = term*d(i) do 80 j = 1,maxt 80 x(iwksp(j)) = x(iwksp(j)) - t(i,j)*term 85 continue return end subroutine icbsp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) implicit double precision (a-h, o-z) c c ... icbsp does an ic back solve (natural ordering, c purdue storage). c c (i + t)*x = y if ipropa = 0 c (d + t)*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c x on input, x contains y c on output, x is the solution to back-solve c c ... specifications for parameters c dimension x(1), d(1), t(ndimr,1) integer jt(ndimi,1) logical propa c propa = ipropa .eq. 1 if (maxt .ge. 1) go to 15 if (.not. propa) return do 10 i = 1,n 10 x(i) = x(i)*d(i) return 15 do 25 i = n,1,-1 sum = x(i) do 20 j = 1,maxt sum = sum - t(i,j)*x(jt(i,j)) 20 continue if (propa) sum = sum*d(i) x(i) = sum 25 continue return end subroutine icbstp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) implicit double precision (a-h, o-z) c c ... icbstp does an transpose ic back solve (natural ordering, c purdue storage). c c (i + (b**t))*x = y if ipropa = 0 c (d + (b**t))*x = y if ipropa = 1 c c ... parameters -- c c n order of system c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c maxb number of columns in b array c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the factorization c b array of active size n by maxb giving the lower c triangle of the factorization if ipropa = 0 c or the lower triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c x on input, x contains y c on output, x is the solution to back-solve c c ... specifications for parameters c dimension x(1), d(1), b(ndimr,1) integer jb(ndimi,1) logical propa c propa = ipropa .eq. 1 if (maxb .ge. 1) go to 15 if (.not. propa) return do 10 i = 1,n 10 x(i) = x(i)*d(i) return 15 do 25 i = n,1,-1 if (propa) x(i) = x(i)*d(i) term = x(i) do 20 j = 1,maxb x(jb(i,j)) = x(jb(i,j)) - b(i,j)*term 20 continue 25 continue return end subroutine icfsp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) implicit double precision (a-h, o-z) c c ... icfsp does an ic forward solve (natural ordering, c purdue storage). c c (i + b)*x = y if ipropa = 0 c (d + b)*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxb number of columns in b array c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the factorization c b array of active size n by maxb giving the lower c triangle of the factorization if ipropa = 0 c or the lower triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c x on input, x contains y c on output, x is the solution to forward-solve c c ... specifications for parameters c dimension x(1), d(1), b(ndimr,1) integer jb(ndimi,1) logical propa c propa = ipropa .eq. 1 if (maxb .ge. 1) go to 15 if (.not. propa) return do 10 i = 1,n 10 x(i) = x(i)*d(i) return 15 do 25 i = 1,n sum = x(i) do 20 j = 1,maxb sum = sum - b(i,j)*x(jb(i,j)) 20 continue if (propa) sum = sum*d(i) x(i) = sum 25 continue return end subroutine icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) implicit double precision (a-h, o-z) c c ... icfstp does an transpose ic forward solve (natural ordering, c purdue storage). c c (i + (t**t))*x = y if ipropa = 0 c (d + (t**t))*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of floating point arrays c ndimi row dimension of integer arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the factorization c t array of active size n by maxt giving the upper c triangle of the factorization if ipropa = 0 c or the upper triangle of the matrix if ipropa = 1 c ipropa property a switch c = 0 matrix does not have property a c = 1 matrix does have property a c x on input, x contains y c on output, x is the solution to forward-solve c c ... specifications for parameters c dimension x(1), d(1), t(ndimr,1) integer jt(ndimi,1) logical propa c propa = ipropa .eq. 1 if (maxt .ge. 1) go to 15 if (.not. propa) return do 10 i = 1,n 10 x(i) = x(i)*d(i) return 15 do 25 i = 1,n if (propa) x(i) = x(i)*d(i) term = x(i) do 20 j = 1,maxt x(jt(i,j)) = x(jt(i,j)) - t(i,j)*term 20 continue 25 continue return end subroutine icbscp (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,ipropa, a wksp,x) implicit double precision (a-h, o-z) c c ... icbscp does a back ic solve. c (purdue storage, multicolor) c c (i + t)*x = y if ipropa = 0 c (d + t)*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c x on input, x contains y c on output, x is the solution to the back solve c c ... specifications for parameters c integer jc(ndimi,1), nc(1), nt(1) dimension d(1), c(ndimr,1), x(1), wksp(1) logical propa c propa = ipropa .eq. 1 c ied = n do 25 icol = ncolor,1,-1 npt = nc(icol) ist = ied - npt + 1 j2 = nt(icol) call vsubp (ndimr,ndimi,npt,j2,c(ist,1),jc(ist,1),x(ist),x, a wksp) if (.not. propa) go to 20 do 15 i = ist,ied 15 x(i) = x(i)*d(i) 20 ied = ied - npt 25 continue return end subroutine icbsct (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,nb,ipropa, a wksp,x) implicit double precision (a-h, o-z) c c ... icbsct does a transpose back ic solve. c (purdue storage, multicolor) c c (i + (b**t))*x = y if ipropa = 0 c (d + (b**t))*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c wksp workspace vector of length max(nc(i)) c x on input, x contains y c on output, x is the solution to the back solve c c ... specifications for parameters c integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), wksp(1) logical propa c propa = ipropa .eq. 1 c ied = n do 25 icol = ncolor,1,-1 npt = nc(icol) ist = ied - npt + 1 if (.not. propa) go to 20 do 15 i = ist,ied 15 x(i) = x(i)*d(i) 20 j1 = nt(icol) + 1 mj = nb(icol) call vsubpt (ndimr,ndimi,npt,mj,c(ist,j1),jc(ist,j1),x,x(ist), a wksp) ied = ied - npt 25 continue return end subroutine icfscp (ndimr,ndimi,jc,d,c,ncolor,nc,nt,nb,ipropa, a wksp,x) implicit double precision (a-h, o-z) c c ... icfscp does a forward ic solve. c (purdue storage, multicolor) c c (i + b)*x = y if ipropa = 0 c (d + b)*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c x on input, x contains y c on output, x is the solution to the back solve c c ... specifications for parameters c integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), wksp(1) logical propa c propa = ipropa .eq. 1 c ist = 1 do 25 icol = 1,ncolor npt = nc(icol) ied = ist + npt - 1 j1 = nt(icol) + 1 mj = nb(icol) call vsubp (ndimr,ndimi,npt,mj,c(ist,j1),jc(ist,j1),x(ist),x, a wksp) if (.not. propa) go to 20 do 15 i = ist,ied 15 x(i) = x(i)*d(i) 20 ist = ist + npt 25 continue return end subroutine icfsct (ndimr,ndimi,jc,d,c,ncolor,nc,nt,ipropa, a wksp,x) implicit double precision (a-h, o-z) c c ... icfsct does a transpose forward ic solve. c (purdue storage, multicolor) c c (i + (t**t))*x = y if ipropa = 0 c (d + (t**t))*x = y if ipropa = 1 c c ... parameters -- c c ndimr row dimension of c array c ndimi row dimension of jc array c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c ipropa property a flag c = 0 matrix does not have property a c = 1 matrix has property a c wksp workspace vector of length max(nc(i)) c x on input, x contains y c on output, x is the solution to the forward solve c c ... specifications for parameters c integer jc(ndimi,1), nc(1), nt(1) dimension d(1), c(ndimr,1), x(1), wksp(1) logical propa c propa = ipropa .eq. 1 c ist = 1 do 25 icol = 1,ncolor npt = nc(icol) ied = ist + npt - 1 if (.not. propa) go to 20 do 15 i = ist,ied 15 x(i) = x(i)*d(i) 20 j2 = nt(icol) call vsubpt (ndimr,ndimi,npt,j2,c(ist,1),jc(ist,1),x,x(ist), a wksp) ist = ist + npt 25 continue return end integer function ipstr (omega) implicit double precision (a-h, o-z) c c ipstr finds the smallest integer, ipstr, greater than 5 such c that ipstr * (omega-1)**(ipstr-1) .le. 0.50. ipstr will be c set in loop. c c ... parameters -- c c omega relaxation factor for sor method c c ... specifications for parameters c c wm1 = omega - 1.0d0 factor = wm1**5 c do ip = 6,940 if ( dble (ip)*factor .le. 0.5d0 ) go to 15 factor = factor*wm1 enddo ip = 940 15 continue ipstr = ip return end subroutine iptgen (ncolor,ipt,nc) implicit double precision (a-h, o-z) c c ... iptgen generates ipt, the pointer vector to block rows, c for block structured matrices with nonconstant block size. c c ... parameters -- c c ncolor the number of colors (block rows) c ipt upon input, an integer vector of length ncolor+1 c upon output, the pointer vector c nc integer vector of length ncolor giving the c number of nodes for each color c c ... specifications for parameters c integer ipt(1), nc(1) c ipt(1) = 0 do 10 k = 1,ncolor ipt(k+1) = ipt(k) + nc(k) 10 continue return end subroutine iterm (nn,u) implicit double precision (a-h, o-z) c c iterm produces the iteration summary line at the end c of each iteration. if level .ge. 4, the latest approximation c to the solution will be printed. c c ... parameters -- c c n order of system (= nn) c u solution estimate c c ... specifications for parameters c dimension u(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- package common c n = nn c c ... print various parameters after each iteration c if (in .gt. 0) go to 15 c c ... print header c if (iacel .ne. 3) write (nout,10) 10 format (/5x,'intermediate output after each iteration' a /' iteration',11x,'convergence ', b 5x,'emax',9x,'emin' /7x,'n',7x,'s',8x,'test' /) if (iacel .eq. 3) write (nout,12) 12 format (////5x,'intermediate output after each iteration' a //' number of',11x,'convergence',5x, b 'emax',8x,'omega',7x,'spectral' /' iterations', c 13x,'test',34x,'radius' //) c c ... print summary line c 15 if (iacel .ne. 3) write (nout,20) in,is,stptst,emax,emin 20 format (3x,i5,3x,i5,3x,3d13.5) if (iacel .eq. 3) write (nout,22) in,is,stptst,emax,omega,specr 22 format (3x,i5,3x,i5,3x,5d13.5) if (level .ge. 4) go to 25 return c 25 write (nout,30) in 30 format (/1x,2x,'estimate of solution at iteration ',i5) write (nout,35) (u(i),i=1,n) 35 format (1x,5g16.7) write (nout,40) 40 format (//) c return end subroutine mcopy (lda,ldb,n,m,a,b) implicit double precision (a-h, o-z) c c ... mcopy copies an array a into array b. c c ... parameters -- c c lda leading dimension of array a c ldb leading dimension of array b c n number of rows in a to be copied c m number of columns in a to be copied c a,b arrays c c ... specifications for parameters c dimension a(lda,1), b(ldb,1) c do 15 j = 1,m do 10 i = 1,n 10 b(i,j) = a(i,j) 15 continue return end subroutine move1 (ndim,mdim,nn,maxnzz,jcoef,coef,nt,nb,ier) implicit double precision (a-h, o-z) c c ... move1 moves the data structure to the form d/t/b, where c d is the main diagonal, the t columns contain only upper c triangular elements and the b columns contain only lower c triangular elements. thus the upper and lower triangle c elements are segregated into separate columns of coef, c with the upper elements coming first. c (purdue data structure, natural ordering, with point c ic or point ssor preconditionings) c c ... parameters -- c c ndim row dimension of coef array in defining routine c mdim column dimension of coef array in defining routine c n order of system (= nn) c maxnz number of columns in coef array (= maxnzz) c jcoef integer matrix representation array c coef matrix representation array c nt number of columns needed to store t, the upper c triangular part of coef c nb number of columns needed to store b, the lower c triangular part of coef c ier error code c = 0 no errors detected c = -9 mdim .lt. 1+nt+nb. hence insufficient room c to store adjusted matrix c c ... specifications for parameters c integer jcoef(ndim,1) dimension coef(ndim,1) c c *** begin -- package common c c c *** end -- package common c n = nn maxnz = maxnzz c c ... determine maximum number of nonzeros per row in t and b. c ntt = 0 nbb = 0 if (maxnz .le. 1) go to 999 do 25 i = 1,n ntrow = 0 nbrow = 0 do 20 j = 2,maxnz if (jcoef(i,j) - i) 10,20,15 10 nbrow = nbrow + 1 go to 20 15 ntrow = ntrow + 1 20 continue if (ntrow .gt. ntt) ntt = ntrow if (nbrow .gt. nbb) nbb = nbrow 25 continue c c ... shuffle matrix so that t is first. c ndtb = ntt + nbb + 1 if (ndtb .le. mdim) go to 30 c c ... error -- mdim is too small. c ier = -9 go to 999 c c ... permute elements of each row. c 30 if (ntt*nbb .eq. 0) go to 999 if (ndtb .le. maxnz) go to 40 maxz = maxnz + 1 do 35 j = maxz,ndtb do 35 i = 1,n coef(i,j) = 0.0d0 jcoef(i,j) = i 35 continue maxnz = ndtb 40 nt2 = ntt + 1 nb1 = nt2 + 1 do 65 i = 1,n jbc = nt2 do 50 jtc = 2,nt2 if (jcoef(i,jtc) .ge. i) go to 50 45 jbc = jbc + 1 if (jcoef(i,jbc) .lt. i) go to 45 jtemp = jcoef(i,jtc) jcoef(i,jtc) = jcoef(i,jbc) jcoef(i,jbc) = jtemp temp = coef(i,jtc) coef(i,jtc) = coef(i,jbc) coef(i,jbc) = temp 50 continue jtc = 1 do 60 jbc = nb1,maxnz if (jcoef(i,jbc) .le. i) go to 60 55 jtc = jtc + 1 if (jcoef(i,jtc) .gt. i) go to 55 jtemp = jcoef(i,jtc) jcoef(i,jtc) = jcoef(i,jbc) jcoef(i,jbc) = jtemp temp = coef(i,jtc) coef(i,jtc) = coef(i,jbc) coef(i,jbc) = temp 60 continue 65 continue c c ... exit. c 999 nt = ntt nb = nbb maxnzz = maxnz return end subroutine move2 (ndim,nn,maxnzz,jcoef,coef,work,iwork, a nt,nb) implicit double precision (a-h, o-z) c c ... move2 moves the data structure to the form d/t/b, where c d is the main diagonal, the t columns contain only upper c triangular elements and the b columns contain only lower c triangular elements. thus the upper and lower triangle c elements are segregated into separate columns of coef, c with the upper elements coming first. c (diagonal data structure, natural ordering, with point c ic or point ssor preconditionings) c c ... parameters -- c c ndim row dimension of coef array in defining routine c n order of system (= nn) c maxnz number of columns in coef array (= maxnzz) c jcoef integer matrix representation array c coef matrix representation array c work floating point workspace array of length n c iwork integer work array of length maxnz c nt number of columns needed to store t, the upper c triangular part of coef c nb number of columns needed to store b, the lower c triangular part of coef c c ... specifications for parameters c integer jcoef(2), iwork(1) dimension coef(ndim,1), work(1) c n = nn maxnz = maxnzz ntt = 0 nbb = 0 if (maxnz .le. 1) go to 999 c c ... compute nbb and ntt. c do 10 j = 1,maxnz ndiag = jcoef(j) if (ndiag .gt. 0) ntt = ntt + 1 if (ndiag .lt. 0) nbb = nbb + 1 10 continue c c ... compute pointers into sorted jcoef. c c ... code jcoef. c do 15 j = 1,maxnz if (jcoef(j) .lt. 0) jcoef(j) = n - jcoef(j) 15 continue iwork(1) = 1 do 30 j = 2,maxnz iaux = jcoef(j) do 20 k = 1,j-1 i = j - k ktemp = iwork(i) if (iaux .gt. jcoef(ktemp)) go to 25 iwork(i+1) = iwork(i) 20 continue i = 0 25 iwork(i+1) = j 30 continue c c ... decode jcoef. c do 35 j = 1,maxnz if (jcoef(j) .gt. n) jcoef(j) = n - jcoef(j) 35 continue c c ... sort coef and jcoef. c do 40 i = 1,maxnz if (iwork(i) .eq. i) iwork(i) = 0 40 continue do 65 ii = 1,maxnz k = iwork(ii) if (k .eq. 0) go to 65 i = ii 45 jtemp = jcoef(i) jcoef(i) = jcoef(k) jcoef(k) = jtemp do 50 l = 1,n work(l) = coef(l,i) coef(l,i) = coef(l,k) coef(l,k) = work(l) 50 continue iwork(i) = 0 do 55 j = ii,maxnz if (iwork(j) .eq. i) go to 60 55 continue go to 65 60 i = j if (i .ne. k) go to 45 iwork(k) = 0 65 continue c c ... exit. c 999 nt = ntt nb = nbb return end subroutine move3 (ndim,mdim,nn,maxnzz,jcoef,coef,nt,nb, a ncolor,nc,ier) implicit double precision (a-h, o-z) c c ... move3 moves the data structure to the form d/t/b, where c d is the main diagonal, the t columns contain only upper c triangular elements and the b columns contain only lower c triangular elements. thus the upper and lower triangle c elements are segregated into separate columns of coef, c with the upper elements coming first. c the above segregation is done for each color. c (purdue data structure, multi-color ordering, with point c ic or point ssor preconditionings) c c ... parameters -- c c ndim row dimension of coef array in defining routine c mdim column dimension of coef array in defining routine c n order of system (= nn) c maxnz number of columns in coef array (= maxnzz) c jcoef integer matrix representation array c coef matrix representation array c nt integer vector of length ncolor. for each color, c the number of columns needed to store t, the upper c triangular part of the matrix for those rows. c nb integer vector of length ncolor. for each color, c the number of columns needed to store b, the lower c triangular part of the matrix for those rows. c ncolor number of colors c nc integer vector of length ncolor, giving the number c of nodes for each color. c ier error code c = 0 no errors detected c = -9 mdim .lt. 1+nt+nb. hence insufficient room c to store adjusted matrix c c ... specifications for parameters c integer jcoef(ndim,1), nt(1), nb(1), nc(1) dimension coef(ndim,1) c c n = nn maxnz = maxnzz c ist = 1 do 85 icol = 1,ncolor ncol = nc(icol) ied = ist + ncol - 1 c c ... determine maximum number of nonzeros per row in t and b. c ntt = 0 nbb = 0 if (maxnz .le. 1) go to 80 do 25 i = ist,ied ntrow = 0 nbrow = 0 do 20 j = 2,maxnz if (jcoef(i,j) - i) 10,20,15 10 nbrow = nbrow + 1 go to 20 15 ntrow = ntrow + 1 20 continue if (ntrow .gt. ntt) ntt = ntrow if (nbrow .gt. nbb) nbb = nbrow 25 continue c c ... shuffle matrix so that t is first. c ndtb = ntt + nbb + 1 if (ndtb .le. mdim) go to 30 c c ... error -- mdim is too small. c ier = -9 go to 999 c c ... permute elements of each row. c 30 if (ndtb .le. maxnz) go to 40 maxz = maxnz + 1 do 35 j = maxz,ndtb do 35 i = 1,n coef(i,j) = 0.0d0 jcoef(i,j) = i 35 continue maxnz = ndtb 40 nt2 = ntt + 1 nb1 = ntt + 2 nz1 = 2 + ntt + nbb do 75 i = ist,ied jbc = nt2 do 50 jtc = 2,nt2 if (jtc .gt. nt2) go to 50 if (jcoef(i,jtc) .ge. i) go to 50 45 jbc = jbc + 1 if (jcoef(i,jbc) .lt. i) go to 45 jtemp = jcoef(i,jtc) jcoef(i,jtc) = jcoef(i,jbc) jcoef(i,jbc) = jtemp temp = coef(i,jtc) coef(i,jtc) = coef(i,jbc) coef(i,jbc) = temp 50 continue jtc = 1 do 60 jbc = nb1,maxnz if (jbc .gt. maxnz) go to 60 if (jcoef(i,jbc) .le. i) go to 60 55 jtc = jtc + 1 if (jcoef(i,jtc) .gt. i) go to 55 jtemp = jcoef(i,jtc) jcoef(i,jtc) = jcoef(i,jbc) jcoef(i,jbc) = jtemp temp = coef(i,jtc) coef(i,jtc) = coef(i,jbc) coef(i,jbc) = temp 60 continue jbc = nt2 do 70 jzc = nz1,maxnz if (jzc .gt. maxnz) go to 70 if (jcoef(i,jzc) .ge. i) go to 70 65 jbc = jbc + 1 if (jcoef(i,jbc) .lt. i) go to 65 jtemp = jcoef(i,jzc) jcoef(i,jzc) = jcoef(i,jbc) jcoef(i,jbc) = jtemp temp = coef(i,jzc) coef(i,jzc) = coef(i,jbc) coef(i,jbc) = temp 70 continue 75 continue c 80 nt(icol) = ntt nb(icol) = nbb ist = ist + ncol 85 continue c c ... exit. c 999 maxnzz = maxnz return end subroutine move4 (ndim,nn,maxnew,jcnew,coef,ncol,nc, a work,iwork) implicit double precision (a-h, o-z) c c ... move4 moves the data structure to the form dc/tc/bc, where c dc is the main diagonal block, tc is the upper triangular c block matrices, and db is the lower triangular block c matrices. c the above segregation is done for each color. c (diagonal data structure, multi-color ordering, with c ic or ssor preconditionings (point or block)) c c ... parameters -- c c ndim row dimension of coef array in defining routine c n order of system (= nn) c maxnew integer vector giving the number of diagonals c created for each color c jcnew integer array of size ncolor*max(maxnew(i)) c giving the diagonal numbers for each color c coef matrix representation array c ncolor number of colors c nc integer vector of length ncolor, giving the number c of nodes for each color. c work floating point workspace array of length max (nc(i)) c iwork integer work array of length max (maxnew(i)) c c ... specifications for parameters c integer maxnew(1), jcnew(ncol,1), nc(1), iwork(1) dimension coef(ndim,1), work(1) c n = nn ncolor = ncol ist = 1 do 70 icol = 1,ncolor ncc = nc(icol) ied = ist + ncc - 1 c c ... compute pointers into sorted jcnew. c c ... code jcnew. c maxnz = maxnew(icol) do 15 j = 1,maxnz do 5 i = ist,ied if (coef(i,j) .ne. 0.0d0) go to 10 5 continue go to 15 10 jd = jcnew(icol,j) jcol = i + jd if (jcol .lt. i .and. jcol .ge. ist) a jcnew(icol,j) = n - jd if (jcol .gt. ied) jcnew(icol,j) = 2*n + jd if (jcol .lt. ist) jcnew(icol,j) = 3*n - jd 15 continue iwork(1) = 1 do 30 j = 2,maxnz iaux = jcnew(icol,j) do 20 k = 1,j-1 i = j - k ktemp = iwork(i) if (iaux .gt. jcnew(icol,ktemp)) go to 25 iwork(i+1) = iwork(i) 20 continue i = 0 25 iwork(i+1) = j 30 continue c c ... decode jcnew. c do 35 j = 1,maxnz jd = jcnew(icol,j) if (jd .gt. n .and. jd .lt. 2*n) jcnew(icol,j) = n - jd if (jd .gt. 2*n .and. jd .lt. 3*n) a jcnew(icol,j) = jd - 2*n if (jd .gt. 3*n) jcnew(icol,j) = 3*n - jd 35 continue c c ... sort coef and jcnew. c do 40 i = 1,maxnz if (iwork(i) .eq. i) iwork(i) = 0 40 continue do 65 ii = 1,maxnz k = iwork(ii) if (k .eq. 0) go to 65 i = ii 45 jtemp = jcnew(icol,i) jcnew(icol,i) = jcnew(icol,k) jcnew(icol,k) = jtemp do 50 l = ist,ied work(l-ist+1) = coef(l,i) coef(l,i) = coef(l,k) coef(l,k) = work(l-ist+1) 50 continue iwork(i) = 0 do 55 j = ii,maxnz if (iwork(j) .eq. i) go to 60 55 continue go to 65 60 i = j if (i .ne. k) go to 45 iwork(k) = 0 65 continue ist = ist + ncc 70 continue c c ... exit. c return end subroutine move5 (ndim,n,maxnz,jcoef,coef) implicit double precision (a-h, o-z) c c ... move5 moves the data structure to the form dc/tc/bc, where c dc is the main diagonal block, tc is the upper triangular c block matrices, and db is the lower triangular block c matrices. c (diagonal data structure, with constant block size) c c ... parameters -- c c ndim row dimension of coef array in defining routine c n order of system c maxnz number of diagonals stored c jcoef integer vector of length maxnz giving the c diagonal numbers c coef matrix representation array c c ... specifications for parameters c dimension coef(ndim,maxnz), jcoef(maxnz) c c ... move dc to the first columns. c jsh = 1 jcol = 1 jget = 0 5 do 10 j = 1,maxnz jd = jcoef(j) if (jd .eq. jget) go to 15 10 continue if (jsh .lt. 0) go to 30 jsh = -1 jget = -1 go to 5 15 if (j .eq. jcol) go to 25 do 20 i = 1,n temp = coef(i,j) coef(i,j) = coef(i,jcol) coef(i,jcol) = temp 20 continue jcoef(j) = jcoef(jcol) jcoef(jcol) = jd 25 jcol = jcol + 1 jget = jget + jsh go to 5 c c ... move tc, bc to the next columns. c 30 if (jcol .gt. maxnz) return do 35 j = jcol,maxnz jd = jcoef(j) if (jd .lt. 0) jcoef(j) = n - jd 35 continue jcolsv = jcol 40 jsml = jcol do 45 j = jcol,maxnz jd = jcoef(j) if (jd .lt. jcoef(jsml)) jsml = j 45 continue if (jsml .eq. jcol) go to 55 do 50 i = 1,n temp = coef(i,jsml) coef(i,jsml) = coef(i,jcol) coef(i,jcol) = temp 50 continue jtemp = jcoef(jsml) jcoef(jsml) = jcoef(jcol) jcoef(jcol) = jtemp 55 jcol = jcol + 1 if (jcol .le. maxnz) go to 40 c c ... uncode jcoef. c do 60 j = jcolsv,maxnz jd = jcoef(j) if (jd .gt. n) jcoef(j) = n - jd 60 continue return end subroutine muldc (ndim,nn,coef,ncolor,nc,maxnew,jcnew,x,y) implicit double precision (a-h, o-z) c c ... muldc computes y = a*x for a matrix permuted to an c ncolor x ncolor block matrix stored in diagonal format. c c ... parameters -- c c ndim row dimension of coef array c n order of system c coef floating point array of coefficients c ncolor number of colors in the permutation (= ncol) c nc integer vector of length ncolor giving the c number of nodes for each color c maxnew integer vector giving the number of diagonals c created for each color c jcnew integer array of size ncolor*max(maxnew(i)) c giving the diagonal numbers for each color c x vector of length n to be multiplied by c y vector of length n to contain result vector c c ... specifications for parameters c integer nc(1), maxnew(1), jcnew(ncolor,2) dimension coef(ndim,2), x(1), y(1) c n = nn do 10 i =1,n 10 y(i) = coef(i,1)*x(i) i1 = 1 joff = 0 do 15 k = 1,ncolor ncc = nc(k) jlim = maxnew(k) - 1 call vaddd (ndim,ncolor,ncc,n,jlim,coef(i1,2),jcnew(k,2), a y(i1),x,joff) i1 = i1 + ncc joff = joff - ncc 15 continue return end subroutine muldct (ndim,nn,coef,ncolor,nc,maxnew,jcnew,x,y) implicit double precision (a-h, o-z) c c ... muldct computes y = (a**t)*x for a matrix permuted to an c ncolor x ncolor block matrix stored in diagonal format. c c ... parameters -- c c ndim row dimension of coef array c n order of system c coef floating point array of coefficients c ncolor number of colors in the permutation (= ncol) c nc integer vector of length ncolor giving the c number of nodes for each color c maxnew integer vector giving the number of diagonals c created for each color c jcnew integer array of size ncolor*max(maxnew(i)) c giving the diagonal numbers for each color c x vector of length n to be multiplied by c y vector of length n to contain result vector c c ... specifications for parameters c integer nc(1), maxnew(1), jcnew(ncolor,2) dimension coef(ndim,2), x(1), y(1) c n = nn do 10 i =1,n 10 y(i) = coef(i,1)*x(i) i1 = 1 joff = 0 do 15 k = 1,ncolor ncc = nc(k) jlim = maxnew(k) - 1 call vadddt (ndim,ncolor,ncc,n,jlim,coef(i1,2),jcnew(k,2), a y,x(i1),joff) i1 = i1 + ncc joff = joff - ncc 15 continue return end subroutine mult1 (ndim,maxnz,coef,jcoef,wksp,nn,x,y) implicit double precision (a-h, o-z) c c ... mult1 computes y = a*x, a matrix-vector product. c the diagonal is assumed to be in column one. c (purdue storage format) c c ... parameters -- c c ndim row dimension of coef in defining routine c maxnz number of columns in coef c coef array of matrix nonzeros c jcoef array of matrix column numbers c wksp workspace array of length n c n order of matrix (= nn) c x multiplying vector of length n c y product vector of length n c c ... specifications for parameters c dimension coef(ndim,2), x(1), y(1), wksp(1) integer jcoef(ndim,2) c n = nn maxm1 = maxnz - 1 do 10 i = 1,n 10 y(i) = coef(i,1)*x(i) call vaddp (ndim,ndim,n,maxm1,coef(1,2),jcoef(1,2),y,x,wksp) return end subroutine mult2n (ndim,maxnz,coef,jcoef,nn,x,y) implicit double precision (a-h, o-z) c c ... mult2n computes y = a*x, a matrix-vector product. c the diagonal is assumed to be in column one. all diagonals of c the matrix must be stored. c (nonsymmetric diagonal storage format) c c ... parameters -- c c ndim row dimension of coef in defining routine c maxnz number of columns in coef c coef array of matrix diagonals c jcoef array of matrix diagonal numbers c n dimension of matrix (= nn) c x multiplying vector of length n c y product vector of length n c c ... specifications for parameters c dimension coef(ndim,2), x(1), y(1) integer jcoef(2) c n = nn do 10 i = 1,n 10 y(i) = coef(i,1)*x(i) if (maxnz .le. 1) return maxm1 = maxnz - 1 call vaddd (ndim,1,n,n,maxm1,coef(1,2),jcoef(2),y,x,0) return end subroutine mult2s (ndim,maxnz,coef,jcoef,nn,x,y) implicit double precision (a-h, o-z) c c ... mult2s computes y = a*x, a matrix-vector product. c the diagonal is assumed to be in column 1. only the upper c diagonals and the main diagonal are assumed stored. c (symmetric diagonal storage format) c c ... parameters -- c c ndim row dimension of coef in defining routine c maxnz number of columns in coef c coef array of matrix diagonals c jcoef array of matrix diagonal numbers c n dimension of matrix (= nn) c x multiplying vector of length n c y product vector of length n c c ... specifications for parameters c dimension coef(ndim,1), x(1), y(1) integer jcoef(2) c n = nn do 10 i = 1,n 10 y(i) = coef(i,1)*x(i) if (maxnz .le. 1) return c do 25 j = 2,maxnz ind = jcoef(j) len = n - ind do 15 i = 1,len 15 y(i) = y(i) + coef(i,j)*x(i+ind) do 20 i = 1,len 20 y(i+ind) = y(i+ind) + coef(i,j)*x(i) 25 continue return end subroutine mul1t (ndim,maxnz,coef,jcoef,wksp,nn,x,y) implicit double precision (a-h, o-z) c c ... mul1t computes y = (a**t)*x, a matrix-vector product. c the diagonal is assumed to be in column one. c (purdue storage format) c c ... parameters -- c c ndim row dimension of coef in defining routine c maxnz number of columns in coef c coef array of matrix nonzeros c jcoef array of matrix column numbers c wksp workspace array of length n c n dimension of matrix (= nn) c x multiplying vector of length n c y product vector of length n c c ... specifications for parameters c dimension coef(ndim,2), x(1), y(1), wksp(1) integer jcoef(ndim,2) c n = nn do 10 i = 1,n 10 y(i) = coef(i,1)*x(i) if (maxnz .le. 1) return maxm1 = maxnz - 1 call vaddpt (ndim,ndim,n,maxm1,coef(1,2),jcoef(1,2),y,x,wksp) return end subroutine mul2nt (ndim,maxnz,coef,jcoef,nn,x,y) implicit double precision (a-h, o-z) c c ... mul2nt computes y = (a**t)*x, a matrix-vector product. c the diagonal is assumed to be in column one. all diagonals of c the matrix must be stored. c (nonsymmetric diagonal storage format) c c ... parameters -- c c ndim row dimension of coef in defining routine c maxnz number of columns in coef c coef array of matrix diagonals c jcoef array of matrix diagonal numbers c n dimension of matrix (= nn) c x multiplying vector of length n c y product vector of length n c c ... specifications for parameters c dimension coef(ndim,2), x(1), y(1) integer jcoef(2) c n = nn do 10 i = 1,n 10 y(i) = coef(i,1)*x(i) if (maxnz .le. 1) return maxm1 = maxnz - 1 call vadddt (ndim,1,n,n,maxm1,coef(1,2),jcoef(2),y,x,0) return end subroutine mult3 (mm,np,a,ia,ja,wksp,x,y) implicit double precision (a-h, o-z) c c ... mult3 computes y = a*x, a matrix-vector product. c the diagonal is assumed to be in the first partition. c (symmetric sparse storage format) c c ... parameters -- c c m number of partitions c np integer vector of length m+1 giving partition c pointers c a floating point vector giving matrix coefficients c ia integer vector giving i values c ja integer vector giving j values c wksp workspace vector of length 2*n (keygs = 1 only) c x multiplying vector of length n c y product vector of length n c c ... specifications for parameters c dimension a(1), x(1), y(1), wksp(1) integer np(2), ia(1), ja(1) c m = mm ied = np(2) - 1 do 10 i = 1,ied 10 y(i) = a(i)*x(i) mm1 = m - 1 call vadds (mm1,np(2),ia,ja,a,y,x,wksp) call vadds (mm1,np(2),ja,ia,a,y,x,wksp) return end subroutine mult3n (mm,np,a,ia,ja,wksp,x,y) implicit double precision (a-h, o-z) c c ... mult3n computes y = a*x, a matrix-vector product. c the diagonal is assumed to be in the first partition. c (nonsymmetric sparse storage format) c c ... parameters -- c c m number of partitions c np integer vector of length m+1 giving partition c pointers c a floating point vector giving matrix coefficients c ia integer vector giving i values c ja integer vector giving j values c wksp workspace vector of length 2*n (keygs = 1 only) c x multiplying vector of length n c y product vector of length n c c ... specifications for parameters c dimension a(1), x(1), y(1), wksp(1) integer np(2), ia(1), ja(1) c m = mm ied = np(2) - 1 do 10 i = 1,ied 10 y(i) = a(i)*x(i) mm1 = m - 1 call vadds (mm1,np(2),ia,ja,a,y,x,wksp) return end subroutine mul3nt (mm,np,a,ia,ja,wksp,x,y) implicit double precision (a-h, o-z) c c ... mul3nt computes y = (a**t)*x, a matrix-vector product. c the diagonal is assumed to be in the first partition. c (nonsymmetric sparse storage format) c c ... parameters -- c c m number of partitions c np integer vector of length m+1 giving partition c pointers c a floating point vector giving matrix coefficients c ia integer vector giving i values c ja integer vector giving j values c wksp workspace vector of length 2*n (keygs = 1 only) c x multiplying vector of length n c y product vector of length n c c ... specifications for parameters c dimension a(1), x(1), y(1), wksp(1) integer np(2), ia(1), ja(1) c m = mm ied = np(2) - 1 do 10 i = 1,ied 10 y(i) = a(i)*x(i) mm1 = m - 1 call vadds (mm1,np(2),ja,ia,a,y,x,wksp) return end subroutine nmcalc (coef,jcoef,wfac,jwfac,icall,subq,nn, a rhs,ubar,wksp,ier) implicit double precision (a-h, o-z) c c ... nmcalc calculates the quantities c c bnorm = sqrt (rhs,rhs) c bnorm1 = any other norm of rhs needed for the stopping test c ubarnm = sqrt (ubar,ubar) c c which are needed in the stopping tests. c c the stopping tests are -- c c (1) (emax/emin) * sqrt ( (r ,zt)/(rhs,inv(q)*rhs) ) c (2) ( 1.0/emin) * sqrt ( (zt,zt)/(u,u) ) c (3) (emax/emin) * sqrt ( (zt,zt)/(inv(q)*rhs,inv(q)*rhs) ) c (4) sqrt ( (zt,zt)/(inv(q)*rhs,inv(q)*rhs) ) c (5) sqrt ( (r ,r )/(rhs,rhs) ) c (6) sqrt ( (u-ubar,u-ubar)/(ubar,ubar) ) c (7) (emax/emin) * sqrt ( (r,z)/(rhs,inv(ql)*rhs) ) c (8) ( 1.0/emin) * sqrt ( (z,z)/(u,u) ) c (9) (emax/emin) * sqrt ( (z,z)/(inv(ql)*rhs,inv(ql)*rhs) ) c (10) sqrt ( (z,z)/(inv(ql)*rhs,inv(ql)*rhs) ) c c ... parameters -- c c icall key for initial or secondary call c = 1 initial call c = 2 later call (needed if q is changed) c subq preconditioning routine c n order of system c rhs right hand side c ubar known solution c wksp workspace vector of length n c ier error code c = 0 no error detected c = -7 q is not positive definite c c ... specifications for parameters c dimension rhs(1), ubar(1), wksp(1), coef(1), jcoef(2), a wfac(1), jwfac(1) external subq c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c c n = nn nteste = ntest if (ntest .gt. 6) nteste = ntest - 6 go to (10,50,20,20,30,40), nteste c c ... bnorm1: sqrt(b,q(inv)b). c 10 call subq (coef,jcoef,wfac,jwfac,n,rhs,wksp) sum = vdot (n,rhs,wksp) if (sum .ge. 0.0d0) go to 15 ier = -7 call ershow (ier,'nmcalc') return 15 bnorm1 = max ( sqrt(sum),srelpr ) return c c ... bnorm1: sqrt(q(inv)b,q(inv)b). c 20 call subq (coef,jcoef,wfac,jwfac,n,rhs,wksp) sum = vdot (n,wksp,wksp) bnorm1 = max ( sqrt(sum),srelpr ) return c c ... bnorm. c 30 if (icall .eq. 2) return sum = vdot (n,rhs,rhs) bnorm = max ( sqrt(sum),srelpr ) bnorm1 = bnorm return c c ... ubarnm. c 40 if (icall .eq. 2) return sum = vdot (n,ubar,ubar) ubarnm = max ( sqrt(sum),srelpr ) return c c ... exit. c 50 return end subroutine omgchg (ssorcp,coef,jcoef,wfac,jwfac,n,p,r) implicit double precision (a-h, o-z) c c ... omgchg changes alphab and betab for a new estimate of omega. c c ... parameters -- c c n order of system (= nn) c p vector from acceleration algorithm c r workspace vector from acceleration algorithm c c ... specifications for parameters c dimension p(1), r(1), coef(1), jcoef(2), wfac(1), jwfac(1) external ssorcp c c *** begin -- package common c common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- package common c c c ... update alphab and betab. c call ssorcp (coef,jcoef,wfac,jwfac,n,p,r,pdp,pldup) alphab = min (alphab, (pap/pdp) - 1.0d0) betab = max (betab , pldup/pdp) return end subroutine out (nn,v,iswt,noutt) implicit double precision (a-h, o-z) c c out effects printing of residual and solution c vectors - called from perror1 c c ... parameters -- c c v vector of length n c iswt labelling information c nout output device number (= noutt) c c ... specifications for parameters c dimension v(nn) c n = nn nout = noutt if (n .le. 0) return c kupper = min (n, 4) if (iswt .eq. 1) write (nout,10) 10 format (//5x,'residual vector') if (iswt .eq. 2) write (nout,15) 15 format (//5x,'solution vector') write (nout,20) (i,i=1,kupper) 20 format (10x,4i15) write (nout,25) 25 format (10x,65('-') /) c do 35 j = 1,n,4 kupper = min (j+3,n) jm1 = j - 1 write (nout,30) jm1,(v(k),k=j,kupper) 30 format (4x,i5,'+ ',4d15.5) 35 continue c return end subroutine pbneu (suba,dsolve,coef,jcoef,wfac,jwfac, a nd,wksp,nn,r,z) implicit double precision (a-h, o-z) c c ... pbneu computes the nd-degree block neumann polynomial c ... approximation to the matrix inv(a). c if a = d - b, where d is a dense banded matrix c then the output vector is -- c c z = (i + p + p**2 + ... + p**nd)*inv(d) * r c c where p = inv(d)*b . c c ... parameters -- c c suba matrix-vector multiplication routine c dsolve routine for computing inv(d)*vector c nd the degree of the polynomial desired c wksp workspace of length 2*n c n order of system (= nn) c r residual c z output vector c c ... specifications for parameters c external suba, dsolve dimension r(1), z(1), wksp(1), coef(1), jcoef(2), a wfac(1), jwfac(1) c n = nn np1 = n + 1 call dsolve (coef,jcoef,wfac,jwfac,n,r,z) if (nd .le. 0) return c do 20 k = 1,nd call suba (coef,jcoef,wfac,jwfac,n,z,wksp) do 10 i = 1,n 10 wksp(i) = r(i) - wksp(i) call dsolve (coef,jcoef,wfac,jwfac,n,wksp,wksp(np1)) do 15 i = 1,n 15 z(i) = z(i) + wksp(i+n) 20 continue return end subroutine pbpii (suba,dsolve,coef,jcoef,wfac,jwfac, a ainf,alpha,beta,nd,wksp,nn,r,z) implicit double precision (a-h, o-z) c c ... pbpii computes the block nd-degree least squares polynomial c ... approximation to the matrix inv(a). the output vector is -- c c ... z = inv(d)*p (a*inv(d)) * r c ... np c c ... parameters -- c c suba matrix-vector multiplication routine c dsolve routine to compute inv(d)*vector c ainf the infinity norm of matrix inv(d)*a c alpha, the least squares weighting factors c beta c nd the degree of the polynomial desired c wksp workspace of length 2*n c n order of system (= nn) c r residual c z output vector c c ... specifications for parameters c external suba, dsolve dimension r(1), z(1), wksp(1), coef(1), jcoef(2), a wfac(1), jwfac(1) c c n = nn np1 = n + 1 al = alpha be = beta c c1 = ((al+be+2.0d0)*(al+be+3.0d0))/(ainf*(al+2.0d0)*(al+be+2.0d0)) call dsolve (coef,jcoef,wfac,jwfac,n,r,z) do 10 i = 1,n 10 z(i) = c1*z(i) if (nd .le. 0) return c do 15 i = 1,n 15 wksp(i) = r(i) do 35 k = 1,nd fk = dble (k) c1 = ((2.0d0*fk+al+be+2.0d0)*(2.0d0*fk+al+be+3.0d0))/ a (ainf*(fk+al+2.0d0)*(fk+al+be+2.0d0)) c2 = (fk*(fk+be)*(2.0d0*fk+al+be))/ a ((fk+al+1.0d0)*(fk+al+be+1.0d0)*(2.0d0*fk+al+be+2.0d0)) call suba (coef,jcoef,wfac,jwfac,n,z,wksp(np1)) do 20 i = 1,n 20 wksp(n+i) = r(i) - wksp(n+i) do 25 i = 1,n 25 wksp(i) = wksp(i+n) + c2*wksp(i) call dsolve (coef,jcoef,wfac,jwfac,n,wksp,wksp(np1)) do 30 i = 1,n 30 z(i) = z(i) + c1*wksp(n+i) 35 continue return end subroutine pneu (suba,coef,jcoef,wfac,jwfac,d,nd,wksp,nn,r,z) implicit double precision (a-h, o-z) c c ... pneu computes the nd-degree point neumann polynomial c ... approximation to the matrix inv(a). the output vector is -- c ... z = p (a)*r c ... np c c ... parameters -- c c suba matrix-vector multiplication routine c d vector of length n giving the diagonal elements c of the matrix c nd the degree of the polynomial desired c wksp workspace of length n c n order of system (= nn) c r residual c z output vector c c ... specifications for parameters c external suba dimension r(1), d(1), z(1), wksp(1), coef(1), jcoef(2), a wfac(1), jwfac(1) c n = nn do 10 i = 1,n 10 z(i) = r(i)/d(i) if (nd .le. 0) return c do 20 k = 1,nd call suba (coef,jcoef,wfac,jwfac,n,z,wksp) do 15 i = 1,n 15 z(i) = z(i) + (r(i) - wksp(i))/d(i) 20 continue return end subroutine ppii (suba,coef,jcoef,wfac,jwfac,ainf, a alpha,beta,nd,wksp,nn,r,z) implicit double precision (a-h, o-z) c c ... ppii computes the nd-degree least squares polynomial c ... approximation to the matrix inv(a). the output vector is -- c ... z = p (a)*r c ... np c c ... parameters -- c c suba matrix-vector multiplication routine c ainf the infinity norm of matrix a c alpha, the least squares weighting factors c beta c nd the degree of the polynomial desired c wksp workspace of length 2*n c n order of system (= nn) c r residual c z output vector c c ... specifications for parameters c external suba dimension r(1), z(1), wksp(1), coef(1), jcoef(2), a wfac(1), jwfac(1) c c n = nn np1 = n + 1 al = alpha be = beta c c1 = ((al+be+2.0d0)*(al+be+3.0d0))/(ainf*(al+2.0d0)*(al+be+2.0d0)) do 10 i = 1,n 10 z(i) = c1*r(i) if (nd .le. 0) return c do 15 i = 1,n 15 wksp(i) = r(i) do 35 k = 1,nd fk = dble (k) c1 = ((2.0d0*fk+al+be+2.0d0)*(2.0d0*fk+al+be+3.0d0))/ a (ainf*(fk+al+2.0d0)*(fk+al+be+2.0d0)) c2 = (fk*(fk+be)*(2.0d0*fk+al+be))/ a ((fk+al+1.0d0)*(fk+al+be+1.0d0)*(2.0d0*fk+al+be+2.0d0)) call suba (coef,jcoef,wfac,jwfac,n,z,wksp(np1)) do 20 i = 1,n 20 wksp(n+i) = r(i) - wksp(n+i) do 25 i = 1,n 25 wksp(i) = wksp(i+n) + c2*wksp(i) do 30 i = 1,n 30 z(i) = z(i) + c1*wksp(i) 35 continue return end subroutine pbs (n,t1,t2,x) implicit double precision (a-h, o-z) c c ... pbs does a penta-diagonal back substitution (i+t1+t2)*x = y c where t1 and t2 are the first and second super diagonals. c c ... parameters -- c c n order of the system c t1 vector of length n-1 containing the first super- c diagonal elements c t2 vector of length n-2 containing the second super- c diagonal elements c x on input, x contains y c on output, x contains the solution to c (i + t1 + t2)*x = y c c ... specifications for parameters c dimension t1(1), t2(1), x(1) c x(n-1) = x(n-1) - t1(n-1)*x(n) do 10 i = n-2,1,-1 10 x(i) = x(i) - t1(i)*x(i+1) - t2(i)*x(i+2) return end subroutine pbsm (nn,nsize,t1,t2,x) implicit double precision (a-h, o-z) c c ... pbsm does a penta-diagonal back substitution (i+t1+t2)*x = y c where t1 and t2 are superdiagonals of a system composed of c independent subsystems of size nsize. c c ... parameters -- c c n order of system c nsize order of the individual subsystems c t1 linear array of length n-1 containing the first c super-diagonal elements of the factorizations c t2 linear array of length n-2 containing the second c super-diagonal elements of the factorizations c x on input, x contains y c the solution to (i + t1 + t2)*x = y c c ... specifications for parameters c dimension t1(nsize,1), t2(nsize,1), x(nsize,1) c n = nn nsys = n/nsize do 10 j = 1,nsys 10 x(nsize-1,j) = x(nsize-1,j) - t1(nsize-1,j)*x(nsize,j) do 20 i = nsize-2,1,-1 do 15 j = 1,nsys 15 x(i,j) = x(i,j) - t1(i,j)*x(i+1,j) - t2(i,j)*x(i+2,j) 20 continue return end subroutine pfac (nn,d,t1,t2) implicit double precision (a-h, o-z) c c ... pfac computes a factorization of a single symmetric c pentadiagonal matrix contained in d, t1, and t2 and c replaces it. c c ... parameters -- c c n order of system (= nn) c d vector of length n containing the diagonal c elements of the matrix c t1 vector of length n-1 containing the first c super-diagonal elements of the matrix c t2 vector of length n-2 containing the second c super-diagonal elements of the matrix c c ... specifications for parameters c dimension d(1), t1(1), t2(1) c n = nn do 10 i = 1,n-2 dii = 1.0d0/d(i) d(i+1) = d(i+1) - t1(i)*t1(i)*dii d(i+2) = d(i+2) - t2(i)*t2(i)*dii t1(i+1) = t1(i+1) - t1(i)*t2(i)*dii 10 continue d(n) = d(n) - t1(n-1)*t1(n-1)/d(n-1) do 15 i = 1,n 15 d(i) = 1.0d0/d(i) do 20 i = 1,n-1 20 t1(i) = d(i)*t1(i) do 25 i = 1,n-2 25 t2(i) = d(i)*t2(i) return end subroutine pfacm (nn,nsize,d,t1,t2) implicit double precision (a-h, o-z) c c ... pfacm computes factorizations of multiple independent c symmetric pentadiagonal matrices contained in d, t1, and t2. c c ... parameters -- c c n order of global system (= nn) c nsize size of the individual subsystems c d linear array of length n containing the c diagonal elements of the systems c t1 linear array of length n-1 containing the c first super-diagonal elements of the systems c t2 linear array of length n-2 containing the c second super-diagonal elements of the systems c c ... specifications for parameters c dimension d(nsize,1), t1(nsize,1), t2(nsize,1) c n = nn nsys = n/nsize do 15 i = 1,nsize-2 do 10 j = 1,nsys d(i+1,j) = d(i+1,j) - (t1(i,j)**2)/d(i,j) d(i+2,j) = d(i+2,j) - (t2(i,j)**2)/d(i,j) t1(i+1,j) = t1(i+1,j) - t1(i,j)*t2(i,j)/d(i,j) 10 continue 15 continue do 20 j = 1,nsys 20 d(nsize,j) = d(nsize,j) - (t1(nsize-1,j)**2)/d(nsize-1,j) call vinv (n,d) call vexopy (n-1,t1,d,t1,3) call vexopy (n-2,t2,d,t2,3) return end subroutine pfacn (nn,d,t1,t2,b1,b2) implicit double precision (a-h, o-z) c c ... pfacn computes a factorization of a single nonsymmetric c pentadiagonal matrix contained in d,t1,t2,b1, and b2 c and replaces it. c c ... parameters -- c c n order of system (= nn) c d vector of length n containing the diagonal c elements of the matrix c t1 vector of length n-1 containing the first c super-diagonal elements of the matrix c t2 vector of length n-2 containing the second c super-diagonal elements of the matrix c b1 vector of length n-1 containing the first c sub-diagonal elements of the matrix c b2 vector of length n-2 containing the second c sub-diagonal elements of the matrix c c ... specifications for parameters c dimension d(1), t1(1), t2(1), b1(1), b2(1) c n = nn do 10 i = 1,n-2 dii = 1.0d0/d(i) d(i+1) = d(i+1) - b1(i)*t1(i)*dii d(i+2) = d(i+2) - b2(i)*t2(i)*dii t1(i+1) = t1(i+1) - b1(i)*t2(i)*dii b1(i+1) = b1(i+1) - b2(i)*t1(i)*dii 10 continue d(n) = d(n) - b1(n-1)*t1(n-1)/d(n-1) do 15 i = 1,n 15 d(i) = 1.0d0/d(i) do 20 i = 1,n-1 t1(i) = d(i)*t1(i) b1(i) = d(i)*b1(i) 20 continue do 25 i = 1,n-2 t2(i) = d(i)*t2(i) b2(i) = d(i)*b2(i) 25 continue return end subroutine pfacnm (nn,nsize,d,t1,t2,b1,b2) implicit double precision (a-h, o-z) c c ... pfacnm computes factorizations of multiple independent c nonsymmetric pentadiagonal matrices contained in c d,t1,t2,b1, and b2. c c ... parameters -- c c n order of global system (= nn) c nsize order of single subsystem c d linear array of length n containing the c diagonal elements of the systems c t1 linear array of length n-1 containing the first c super-diagonal elements of the systems c t2 linear array of length n-2 containing the second c super-diagonal elements of the systems c b1 linear array of length n-1 containing the first c sub-diagonal elements of the systems c b2 linear array of length n-2 containing the second c sub-diagonal elements of the systems c c ... specifications for parameters c dimension d(nsize,1), t1(nsize,1), b1(nsize,1), t2(nsize,1), a b2(nsize,1) c n = nn nsys = n/nsize do 15 i = 1,nsize-2 do 10 j = 1,nsys d(i+1,j) = d(i+1,j) - b1(i,j)*t1(i,j)/d(i,j) d(i+2,j) = d(i+2,j) - b2(i,j)*t2(i,j)/d(i,j) t1(i+1,j) = t1(i+1,j) - b1(i,j)*t2(i,j)/d(i,j) b1(i+1,j) = b1(i+1,j) - b2(i,j)*t1(i,j)/d(i,j) 10 continue 15 continue do 20 j = 1,nsys 20 d(nsize,j) = d(nsize,j) - b1(nsize-1,j)*t1(nsize-1,j)/ a d(nsize-1,j) call vinv (n,d) call vexopy (n-1,t1,d,t1,3) call vexopy (n-2,t2,d,t2,3) call vexopy (n-1,b1,d,b1,3) call vexopy (n-2,b2,d,b2,3) return end subroutine pfs (n,b1,b2,x) implicit double precision (a-h, o-z) c c ... pfs does a penta-diagonal forward substitution (i+b1+b2)*x = y c where b1 and b2 are the first and second sub-diagonals. c c ... parameters -- c c n order of system c b1 vector of length n-1 containing the first c sub-diagonal elements c b2 vector of length n-2 containing the second c sub-diagonal elements c x on input, x contains y c on output, x contains the solution to c (i + b1 + b2)*x = y c c ... specifications for parameters c dimension b1(1), b2(1), x(2) c x(2) = x(2) - b1(1)*x(1) do 10 i = 3,n 10 x(i) = x(i) - b1(i-1)*x(i-1) - b2(i-2)*x(i-2) return end subroutine pfsm (nn,nsize,b1,b2,x) implicit double precision (a-h, o-z) c c ... pfsm does a penta-diagonal forward substitution (i+b1+b2)*x = y c where b1 and b2 are subdiagonals of a system composed of c independent subsystems of size nsize. c c ... parameters -- c c n order of system c nsize order of the individual subsystems c b1 linear array of length n-1 containing the first c sub-diagonal elements of the factorizations c b2 linear array of length n-2 containing the second c sub-diagonal elements of the factorizations c x on input, x contains y c on output, x contains c the solution to (i + b1 + b2)*x = y c c ... specifications for parameters c dimension b1(nsize,1), b2(nsize,1), x(nsize,1) c n = nn nsys = n/nsize do 10 j = 1,nsys 10 x(2,j) = x(2,j) - b1(1,j)*x(1,j) do 20 i = 3,nsize do 15 j = 1,nsys 15 x(i,j) = x(i,j) - b1(i-1,j)*x(i-1,j) - b2(i-2,j)*x(i-2,j) 20 continue return end subroutine psoln (nn,d,t1,t2,b1,b2,y,x) implicit double precision (a-h, o-z) c c ... psoln solves the system ax = y for x, where a is a single c pentadiagonal system. d, t1, t2, b1, and b2 contain c the main, first and second super, and first and second sub c diagonals, respectively, of the factorization. c c ... parameters -- c c n order of system c d vector of length n containing the diagonal c elements of the factorization matrix c t1 vector of length n-1 containing the first c super-diagonal elements of the factorization c t2 vector of length n-2 containing the second c super-diagonal elements of the factorization c b1 vector of length n-1 containing the first c sub-diagonal elements of the factorization c b2 vector of length n-2 containing the second c sub-diagonal elements of the factorization c y the right-hand side c x the solution to ax = y c c ... specifications for parameters c dimension d(1), t1(1), t2(1), b1(1), b2(1), x(1), y(1) c n = nn do 10 i = 1,n 10 x(i) = y(i) call pfs (n,b1,b2,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call pbs (n,t1,t2,x) return end subroutine psolnm (nn,nsize,d,t1,t2,b1,b2,y,x) implicit double precision (a-h, o-z) c c ... psolnm solves the system ax = y for x, where a contains c multiple pentadiagonal systems. d, t1, t2, b1, and b2 are c the main, first and second super, and the first and second c sub diagonals, respectively, of the factorization. c c ... parameters -- c c n order of system c nsize size of an individual subsystem c d vector of length n containing the diagonal c elements of the factorization matrix c t1 vector of length n-1 containing the first c super-diagonal elements of the factorization c t2 vector of length n-2 containing the second c super-diagonal elements of the factorization c b1 vector of length n-1 containing the first c sub-diagonal elements of the factorization c b2 vector of length n-2 containing the second c sub-diagonal elements of the factorization c y the right-hand side c x the solution to ax = y c c ... specifications for parameters c dimension d(1), t1(1), t2(1), b1(1), b2(1), x(1), y(1) c n = nn do 10 i = 1,n 10 x(i) = y(i) call pfsm (n,nsize,b1,b2,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call pbsm (n,nsize,t1,t2,x) return end subroutine parsi implicit double precision (a-h, o-z) c c ... parsi computes the iteration parameters. c c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c rhol = rho if (is - 1) 10,15,20 10 rho = 1.0d0 go to 25 15 rho = 1.0d0/(1.0d0 - sigma*sigma/2.0d0) go to 25 20 rho = 1.0d0/(1.0d0 - sigma*sigma*rhol/4.0d0) c c ... compute alpha, beta. c 25 alpha = rho*gamma beta = rhol*(rho - 1.0d0)/rho return end subroutine permas (isym,nn,nzz,ia,ja,a,wksp,p) implicit double precision (a-h, o-z) c c ... permas takes the sparse matrix representation of the c matrix and permutes both rows and columns, overwriting c the previous structure. (sparse data structure) c c ... parameters -- c c isym switch for symmetric storage c = 0 matrix is symmetric c = 1 matrix is nonsymmetric c n size of system c nz length of ia, ja, and a vectors c ia vector of i values c ja vector of j values c a vector of matrix coefficients c wksp workspace vector of length n c p permutation vector c c ... it is assumed that the i-th entry of the permutation vector c p indicates the row the i-th row gets mapped into. (i.e. c if ( p(i) = j ) row i gets mapped into row j) c c ... specifications for parameters c dimension a(1), wksp(1) integer ia(1), ja(1), p(1) c n = nn nz = nzz c c ... explicit gathers. c call vgathi (nz,p,ia,ia) call vgathi (nz,p,ja,ja) do 5 i = 1,n 5 wksp(i) = a(i) call vscatr (n,wksp,p,a) do 10 i = 1,n ia(i) = i ja(i) = i 10 continue c c ... convert to upper triangular elements for symmetric storage c if (isym .eq. 1) return np1 = n + 1 do 15 i = np1,nz if (ia(i) .le. ja(i)) go to 15 idum = ia(i) ia(i) = ja(i) ja(i) = idum 15 continue return end subroutine permat (ndim,maxnz,coef,jcoef,wksp,iwksp,nn,p) implicit double precision (a-h, o-z) c c ... permat takes the sparse matrix representation of the c matrix and permutes both rows and columns, overwriting c the previous structure. (purdue data structure) c c ... parameters -- c c ndim row dimension of coef array in defining routine c maxnz number of columns in coef and jcoef arrays c coef array of matrix coefficients c jcoef array of matrix columns numbers c wksp workspace array of length n c iwksp integer workspace array of length n c n order of system (= nn) c p permutation vector c c ... it is assumed that the i-th entry of the permutation vector c p indicates the row the i-th row gets mapped into. (i.e. c if ( p(i) = j ) row i gets mapped into row j) c c ... specifications for parameters c dimension coef(ndim,1), wksp(1) integer jcoef(ndim,1), iwksp(1), p(1) c n = nn if (n .le. 0) return do 20 j = 1,maxnz do 10 i = 1,n wksp(i) = coef(i,j) iwksp(i) = jcoef(i,j) 10 continue call vscatr (n,wksp,p,coef(1,j)) call vscati (n,iwksp,p,jcoef(1,j)) call vgathi (n,p,jcoef(1,j),jcoef(1,j)) 20 continue return end subroutine perror1 (suba,coef,jcoef,wfac,jwfac,nn,u,rhs, a wksp,digtt1,digtt2,idgtts) implicit double precision (a-h, o-z) c c perror1 computes the residual, r = rhs - a*u. the user c also has the option of printing the residual and/or the c unknown vector depending on idgts. c c ... parameters -- c c suba matrix-vector multiplication routine c n dimension of matrix (= nn) c u latest estimate of solution c rhs right hand side of matrix problem c wksp workspace vector of length n c digit1 output - measure of accuracy of stopping test (= digtt1 c digit2 output - measure of accuracy of solution (= digtt2) c idgts parameter controlling level of output (= idgtts) c if idgts < 1 or idgts > 4, then no output. c = 1, then number of digits is printed, pro- c vided level .ge. 1 c = 2, then solution vector is printed, pro- c vided level .ge. 1 c = 3, then residual vector is printed, pro- c vided level .ge. 1 c = 4, then both vectors are printed, pro- c vided level .ge. 1 c c ... specifications for parameters c external suba dimension rhs(1), u(1), wksp(1), coef(1), jcoef(2), a wfac(1), jwfac(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c n = nn idgts = idgtts digit1 = 0.0d0 digit2 = 0.0d0 c digit1 = -dlog10 (abs (srelpr)) if (stptst .gt. 0.0d0) digit1 = -dlog10 (abs (stptst)) call suba (coef,jcoef,wfac,jwfac,n,u,wksp) call vexopy (n,wksp,rhs,wksp,2) rnrm = sqrt ( vdot (n,wksp,wksp) ) sum = vdot (n,rhs,rhs) bnorm = max ( sqrt(sum),srelpr ) temp = rnrm/bnorm if (temp .eq. 0.0d0) go to 10 digit2 = -dlog10 (abs (temp)) go to 15 c 10 digit2 = -dlog10 (abs (srelpr)) c 15 if ((idgts .lt. 1) .or. (level .le. 0)) go to 25 write (nout,20) digit1,digit2 20 format (/10x,'approx. no. of digits in stopping test =', a f5.1,2x,'(digit1)' b /10x,'approx. no. of digits in ratio test =', c f5.1,2x,'(digit2)') c if (idgts .le. 1 .or. idgts .gt. 4) go to 25 if (idgts .ge. 3) call out (n,wksp,1,nout) if (idgts .ne. 3) call out (n,u,2,nout) c 25 continue digtt1 = digit1 digtt2 = digit2 return end subroutine pervec (nn,p,v,wksp) implicit double precision (a-h, o-z) c c ... pervec permutes a vector as dictated by the permutation c ... vector p. if p(i) = j, then v(j) gets v(i). c c ... parameters -- c c n length of vectors p, v, and wksp (= nn) c p integer permutation vector c v vector to be permuted c wksp workspace vector of length n c c ... specifications for parameters c integer p(1) dimension v(1), wksp(1) c n = nn if (n .le. 0) return do 10 i = 1,n wksp(i) = v(i) 10 continue call vscatr (n,wksp,p,v) return end subroutine pgen (nn,p,ip,nc,ncolor) implicit double precision (a-h, o-z) c c ... pgen constructs the permutation vector p and its inverse c ... ip for a coloring given by p. c c ... parameters -- c c n order of system (= nn) c p vector from prbndx upon input c permutation vector upon output c ip integer workspace vector upon input c inverse permutation vector upon output c nc number of points for each color (output) c ncolor number of colors c c ... specifications for parameters c integer p(1), ip(1), nc(1) c n = nn c c ... determine number of colors and number of elements for each c color. c ncolor = 0 do 5 i = 1,n 5 nc(i) = 0 do 10 i = 1,n ic = p(i) if (ncolor .lt. ic) ncolor = ic nc(ic) = nc(ic) + 1 10 continue c c ... construct permutation vector. c ip(1) = 1 do 15 i = 2,ncolor ip(i) = ip(i-1) + nc(i-1) 15 continue do 20 i = 1,n ic = p(i) p(i) = ip(ic) ip(ic) = ip(ic) + 1 20 continue c c ... construct inverse permutation vector. c do 25 i = 1,n j = p(i) ip(j) = i 25 continue return end subroutine pjac (diag,nn,r,z) implicit double precision (a-h, o-z) c c ... pjac does the point jacobi preconditioning. c c ... parameters -- c c diag vector of length n containing the diagonal c elements of the coefficient matrix c n order of system (= nn) c r residual c z output vector c c ... specifications for parameters c dimension r(1), z(1), diag(1) c n = nn do 10 i = 1,n 10 z(i) = r(i)/diag(i) return end subroutine pmdg (ndim,mdim,nn,maxnz,jcoef,coef,ncol,nc,p,ip, a maxd,maxnew,jcnew,wksp,iwksp,isym,ier) implicit double precision (a-h, o-z) c c ... pmdg permutes the matrix according to index vector p, c and, if room allows, stores the permuted matrix in c diagonal format. there will be enough room if the number c of diagonals needed does not exceed mdim. c c ... parameters -- c c ndim row dimension of coef and jcoef arrays c in defining routine c mdim column dimension of coef and jcoef arrays in c defining routine c n order of system (active row size of coef and jcoef) c maxnz active column size of coef and jcoef c jcoef integer array of column numbers c coef floating point array of coefficients c ncolor number of colors in the permutation (= ncol) c nc integer vector of length ncolor giving the c number of nodes for each color c p permutation vector c ip inverse permuation vector c maxd active columns in permuted matrix c maxnew integer vector giving the number of diagonals c created for each color c jcnew integer array of size ncolor*max(maxnew(i)) c giving the diagonal numbers for each color c wksp floating point workspace of length n c iwksp integer workspace of length 2*n c isym symmetric storage switch c = 0 symmetric storage c = 1 nonsymmetric storage c ier error flag c = 0 no errors detected c = -9 mdim is less than the number of columns c needed in coef to store the permuted c matrix in diagonal format c c ... specifications for parameters c integer jcoef(2), nc(1), p(1), maxnew(1), jcnew(ncol,1), a iwksp(1), ip(1) dimension coef(ndim,1), wksp(1) c c n = nn ncolor = ncol c c ... fill out rest of matrix if symmetric storage is used. c if (isym .ne. 0) go to 2 maxd = 2*maxnz - 1 if (mdim .lt. maxd) ier = -9 if (ier .lt. 0) return c do 1 j = 2,maxnz ind = jcoef(j) len = n - ind jcol = maxnz + j - 1 jcoef(jcol) = -ind call vfill (ind,coef(1,jcol),0.0d0) call vcopy (len,coef(1,j),coef(ind+1,jcol)) 1 continue maxnz = maxd c c ... determine the number of created diagonals. c 2 do 5 i = 1,ncolor maxnew(i) = 1 jcnew(i,1) = 0 5 continue do 35 j = 2,maxnz ind = jcoef(j) do 10 i = 1,n iwksp(n+i) = i + ind if (coef(i,j) .eq. 0.0d0) iwksp(n+i) = i 10 continue call vscati (n,iwksp(n+1),p,iwksp) call vgathi (n,p,iwksp,iwksp) do 15 i = 1,n 15 iwksp(i) = iwksp(i) - i ist = 1 do 30 k = 1,ncolor ncc = nc(k) ied = ist + ncc - 1 lim = maxnew(k) do 25 i = ist,ied id = iwksp(i) do 20 jj = 1,lim if (jcnew(k,jj) .eq. id) go to 25 20 continue lim = lim + 1 maxnew(k) = lim if (lim .gt. mdim) go to 40 jcnew(k,lim) = id 25 continue ist = ist + ncc 30 continue 35 continue c c ... determine maxd. c 40 maxd = -1 do 45 k = 1,ncolor 45 maxd = max (maxd,maxnew(k)) if (mdim .lt. maxd) ier = -9 if (ier .lt. 0) return c c ... permute matrix. c do 55 j = 1,maxnz do 50 i = 1,n 50 wksp(i) = coef(i,j) call vscatr (n,wksp,p,coef(1,j)) 55 continue c c ... rearrange rows. c ist = 1 do 85 k = 1,ncolor ncc = nc(k) ied = ist + ncc - 1 lim = maxnew(k) do 62 l = 1,lim jcol = jcnew(k,l) iwksp(n+jcol) = l 62 continue do 80 i = ist,ied iip = ip(i) do 60 j = 2,maxnz 60 wksp(j) = coef(i,j) do 63 j = 2,maxd 63 coef(i,j) = 0.0d0 do 75 j = 2,maxnz if (wksp(j) .eq. 0.0d0) go to 75 icol = p(iip + jcoef(j)) - i l = iwksp(n+icol) coef(i,l) = wksp(j) 75 continue 80 continue ist = ist + ncc 85 continue return end subroutine prbndx (nn,ndim,maxnzz,jcoef,coef,p,ip,propa,nstore) implicit double precision (a-h, o-z) c c************************************************************** c c (purdue, diagonal data structures) c prbndx determines if the matrix has property a. c this algorithm assumes all neighbors of a particular node c are known. c c the algorithm is to mark the first node as red (arbitrary). c all of its adjacent nodes are marked black and placed in c a stack. the remainder of the code pulls the first node c off the top of the stack and tries to type its adjacent nodes. c the typing of the adjacent point is a five way case statement c which is well commented below (see do loop 50). c c the array p is used both to keep track of the color of a node c (red node is positive, black is negative) but also the father c node that caused the color marking of that point. since c complete information on the adjacency structure is hard to come c by, this forms a link to enable the color change of a partial c tree when a recoverable color conflict occurs. c c the array ip is used as a stack to point to the set of nodes c left to be typed that are known to be adjacent to the current c father node. c c c********************************************************************* c c ... input parameters -- c c n number of nodes. (integer, scalar) (= nn) c ndim row dimension of coef array c maxnz maximum number of nonzeros per row c jcoef integer data array c coef floating point data array c p,ip integer workspace vectors of length n c nstore data structure switch c = 1 purdue c = 2 diagonal (symmetric or nonsymmetric) c c ... output parameters -- c c p contains information for constructing the permutation c array upon output c propa a logical variable which is set to .true. if the c matrix has property a and .false. otherwise c c c******************************************************************** c c ... specifications for parameters c integer p(1), ip(1), jcoef(ndim,1) dimension coef(ndim,1) logical propa c c c ... specifications for local variables c integer first, old, young, curtyp, type c c----------------------------------------------------------------------- c n = nn maxnz = maxnzz do 5 i = 1,n p(i) = 0 ip(i) = 0 5 continue c c ... handle the first set of points until some adjacent points c ... are found c first = 1 c 10 p(first) = first if (maxnz .gt. 1) go to 20 c c ... search for next entry that has not been marked c if (first .eq. n) go to 65 ibgn = first + 1 do 15 i = ibgn,n if (p(i) .ne. 0) go to 15 first = i go to 10 15 continue go to 65 c c ... first set of adjacent points found c 20 next = 1 last = 1 ip(1) = first c c ... loop over labeled points indicated in the stack stored in c ... the array ip c 25 k = ip(next) curtyp = p(k) nxttyp = -curtyp if (maxnz .le. 0) go to 55 do 50 j = 1,maxnz if (nstore .eq. 1) jcol = jcoef(k,j) if (nstore .ge. 2) jcol = k + jcoef(j,1) c c ... determine if element (k,j) is a diagonal element or zero. c if (jcol .lt. 1 .or. jcol .gt. n .or. jcol .eq. k) a go to 50 if (coef(k,j) .eq. 0.0d0) go to 50 c type = p(jcol) c c================================================================== c c the following is a five way case statement dealing with the c labeling of the adjacent node. c c ... case i. if the adjacent node has already been labeled with c label equal to nxttyp, then skip to the next adjacent c node. c if (type .eq. nxttyp) go to 50 c c ... case ii. if the adjacent node has not been labeled yet label c it with nxttyp and enter it in the stack c if (type .ne. 0) go to 30 last = last + 1 ip(last) = jcol p(jcol) = nxttyp go to 50 c c ... case iii. if the adjacent node has already been labeled with c opposite color and the same father seed, then there c is an irrecoverable color conflict. c 30 if (type .eq. curtyp) go to 999 c c ... case iv. if the adjacent node has the right color and a different c father node, then change all nodes of the youngest fathe c node to point to the oldest father seed and retain the c same colors. c if (type * nxttyp .lt. 1) go to 40 old = min ( iabs(type), iabs(nxttyp) ) young = max ( iabs(type), iabs(nxttyp) ) do 35 l = young,n if (iabs(p(l)) .eq. young) p(l) = isign(old, p(l)) 35 continue curtyp = p(k) nxttyp = -curtyp go to 50 c c ... case v. if the adjacent node has the wrong color and a different c father node, then change all nodes of the youngest father c node to point to the oldest father node along with c changing their colors. since until this time the c youngest father node tree has been independent no other c color conflicts will arise from this change. c 40 old = min ( iabs(type), iabs(nxttyp) ) young = max ( iabs(type), iabs(nxttyp) ) do 45 l = young,n if (iabs(p(l)) .eq. young) p(l) = isign(old, -p(l)) 45 continue curtyp = p(k) nxttyp = -curtyp c c c ... end of case statement c c================================================================== 50 continue c c ... advance to next node in the stack c 55 next = next + 1 if (next .le. last) go to 25 c c ... all nodes in the stack have been removed c c ... check for nodes not labeled. if any are found c ... start the labeling process again at the first c ... node found that is not labeled. c ibgn = first + 1 do 60 i = ibgn,n if (p(i) .ne. 0) go to 60 first = i go to 10 60 continue c c c=================================================================== c c c ... all nodes are now typed either red or black. c ... red-black ordering possible. c 65 propa = .true. do 70 i = 1,n if (p(i) .ge. 0) p(i) = 1 if (p(i) .le. 0) p(i) = 2 70 continue return c c ...... type conflict c 999 propa = .false. return end subroutine prbblk (ncol,ndis,iblock,lbhb,p,ip,propa) implicit double precision (a-h, o-z) c c************************************************************** c c (block structure) c prbblk determines if the matrix has block property a. c see routine prbndx for an explanation of the algorithm c c************************************************************** c c ... input parameters -- c c ncolor number of diagonal blocks c ndis number of distinct diagonal blocks c iblock integer array of size 3 by ndis by max(lbhb(i)) c giving block constants c lbhb integer vector of size ndis giving the number c of diagonal blocks for each distinct block size. c p,ip integer workspace vectors of length ncolor c c ... output parameters -- c c p contains information for constructing the permutation c array upon output c propa a logical variable which is set to .true. if the c matrix has block property a and .false. otherwise c c c******************************************************************** c c ... specifications for parameters c integer p(1), ip(1), iblock(3,ndis,1), lbhb(1) logical propa c c ... specifications for local variables c integer first, old, young, curtyp, type c c ncolor = ncol ndist = ndis index = 1 do 5 i = 1,ncolor p(i) = 0 ip(i) = 0 5 continue c c ... handle the first set of points until some adjacent points c ... are found c first = 1 c 10 p(first) = first if (ndist .gt. 1) index = first maxnz = lbhb(index) if (maxnz .gt. 1) go to 20 c c ... search for next entry that has not been marked c if (first .eq. ncolor) go to 65 do 15 i = first+1,ncolor if (p(i) .ne. 0) go to 15 first = i go to 10 15 continue go to 65 c c ... first set of adjacent points found c 20 next = 1 last = 1 ip(1) = first c c ... loop over labeled points indicated in the stack stored in c ... the array ip c 25 k = ip(next) curtyp = p(k) nxttyp = -curtyp if (ndist .gt. 1) index = k maxnz = lbhb(index) if (maxnz .le. 0) go to 55 do 50 j = 1,maxnz jcol = k + iblock(1,index,j) c c ... determine if element (k,j) is a diagonal element or zero. c if (jcol .lt. 1 .or. jcol .gt. ncolor .or. a jcol .eq. k) go to 50 if (iblock(3,index,j) .eq. 0) go to 50 c type = p(jcol) c c================================================================== c c the following is a five way case statement dealing with the c labeling of the adjacent node. c c ... case i. if the adjacent node has already been labeled with c label equal to nxttyp, then skip to the next adjacent c node. c if (type .eq. nxttyp) go to 50 c c ... case ii. if the adjacent node has not been labeled yet label c it with nxttyp and enter it in the stack c if (type .ne. 0) go to 30 last = last + 1 ip(last) = jcol p(jcol) = nxttyp go to 50 c c ... case iii. if the adjacent node has already been labeled with c opposite color and the same father seed, then there c is an irrecoverable color conflict. c 30 if (type .eq. curtyp) go to 999 c c ... case iv. if the adjacent node has the right color and a different c father node, then change all nodes of the youngest fathe c node to point to the oldest father seed and retain the c same colors. c if (type * nxttyp .lt. 1) go to 40 old = min ( iabs(type), iabs(nxttyp) ) young = max ( iabs(type), iabs(nxttyp) ) do 35 l = young,ncolor if (iabs(p(l)) .eq. young) p(l) = isign(old, p(l)) 35 continue curtyp = p(k) nxttyp = -curtyp go to 50 c c ... case v. if the adjacent node has the wrong color and a different c father node, then change all nodes of the youngest father c node to point to the oldest father node along with c changing their colors. since until this time the c youngest father node tree has been independent no other c color conflicts will arise from this change. c 40 old = min ( iabs(type), iabs(nxttyp) ) young = max ( iabs(type), iabs(nxttyp) ) do 45 l = young,ncolor if (iabs(p(l)) .eq. young) p(l) = isign(old, -p(l)) 45 continue curtyp = p(k) nxttyp = -curtyp c c c ... end of case statement c c================================================================== 50 continue c c ... advance to next node in the stack c 55 next = next + 1 if (next .le. last) go to 25 c c ... all nodes in the stack have been removed c c ... check for nodes not labeled. if any are found c ... start the labeling process again at the first c ... node found that is not labeled. c do 60 i = first+1,ncolor if (p(i) .ne. 0) go to 60 first = i go to 10 60 continue c c c=================================================================== c c c ... all nodes are now typed either red or black. c ... red-black ordering possible. c 65 propa = .true. do 70 i = 1,ncolor if (p(i) .ge. 0) p(i) = 1 if (p(i) .le. 0) p(i) = 2 70 continue return c c ...... type conflict c 999 propa = .false. return end subroutine prep1 (nn,ndim,maxnzz,jcoef,coef,ier) implicit double precision (a-h, o-z) c c ... prep1 puts the diagonal elements of the matrix in column one c of coef (purdue data structure) c c ... parameters -- c c n dimension of matrix ( = nn) c ndim row dimension of coef array in defining routine c maxnz number of columns in coef array (= maxnzz) c jcoef integer matrix representation array c coef matrix representation array c ier error flag -- on return, values mean c 0 -- no errors detected c -5 -- nonexistent diagonal element c c ... specifications for parameters c integer jcoef(ndim,1) dimension coef(ndim,1) c n = nn maxnz = maxnzz c do 20 i = 1,n do 10 j = 1,maxnz if (jcoef(i,j) .eq. i) go to 15 10 continue c c ... no diagonal entry for row i. c ier = -5 return c c ... switch entries so that diagonal element is in column 1. c 15 if (j .eq. 1) go to 20 save = coef(i,j) coef(i,j) = coef(i,1) jcoef(i,j) = jcoef(i,1) coef(i,1) = save jcoef(i,1) = i 20 continue return end subroutine prep2 (nn,ndim,maxnzz,jcoef,coef,wksp,ier) implicit double precision (a-h, o-z) c c ... prep2 puts the diagonal entries of the matrix into column c one of coef. (diagonal data structure) c c ... parameters -- c c n dimension of matrix ( = nn) c ndim row dimension of coef array in defining routine c maxnz number of columns in coef array (= maxnzz) c jcoef integer matrix representation array c coef matrix representation array c wksp workspace array of size n c ier error flag -- on return, values mean c 0 -- no errors detected c -5 -- nonexistent diagonal element c c ... specifications for parameters c integer jcoef(2) dimension coef(ndim,1), wksp(1) c n = nn maxnz = maxnzz c do 10 j = 1,maxnz if (jcoef(j) .eq. 0) go to 15 10 continue c c ... no main diagonal. c ier = -5 return c c ... switch diagonals so that main diagonal is in column 1. c 15 if (j .eq. 1) return do 20 i = 1,n wksp(i) = coef(i,1) coef(i,1) = coef(i,j) coef(i,j) = wksp(i) 20 continue jcoef(j) = jcoef(1) jcoef(1) = 0 return end subroutine prep3 (n,nz,ia,ja,a,m,np,iwksp) implicit double precision (a-h, o-z) c c ... prep3 puts the diagonal elements of the matrix in the c first n locations of the data structure, adds duplicate c triples, and defines the partition for matrix-vector c products. c c ... parameters -- c c n number of equations c nz length of ia, ja, and a vectors c ia vector of i values c ja vector of j values c a vector of matrix coefficients c m number of partitions (output) c np on output, np contains the partition pointers. c it must be at least m+1 in length. c iwksp integer workspace vector of length n c c ... specifications for parameters c integer ia(1), ja(1), iwksp(1), np(1) dimension a(1) c c ... eliminate duplicates from the vectors by adding their c values in the a vector. first, sort the vectors by c rows first and then by columns within each row. c call vsrta1 (nz,ia,ja,a) c c ... add duplicates. c l = 1 do 10 k = 2,nz i = ia(k) j = ja(k) aval = a(k) if (i .eq. ia(l) .and. j .eq. ja(l)) go to 5 l = l + 1 ia(l) = i ja(l) = j a(l) = aval go to 10 5 a(l) = a(l) + aval 10 continue nz = l c c ... put main diagonal elements first. c do 20 k = 1,nz 15 i = ia(k) j = ja(k) if (i .ne. j) go to 20 if (i .eq. k) go to 20 val = a(k) ia(k) = ia(i) ja(k) = ja(i) a(k) = a(i) ia(i) = i ja(i) = i a(i) = val go to 15 20 continue c c ... define partitions. c kbgn = n + 1 krep = kbgn mm = 1 np(1) = 1 25 mm = mm + 1 np(mm) = kbgn do 30 i = 1,n 30 iwksp(i) = 0 nval = 0 if (kbgn .gt. nz) go to 50 do 40 k = kbgn,nz i = ia(k) j = ja(k) if (iwksp(i) .eq. 1 .or. iwksp(i) .eq. 3 .or. a iwksp(j) .ge. 2) go to 40 nval = nval + 1 iwksp(i) = iwksp(i) + 1 iwksp(j) = iwksp(j) + 2 if (k .eq. krep) go to 35 at = a(krep) it = ia(krep) jt = ja(krep) a(krep) = a(k) ia(krep) = i ja(krep) = j a(k) = at ia(k) = it ja(k) = jt 35 krep = krep + 1 if (nval .ge. n) go to 45 40 continue 45 kbgn = krep go to 25 50 m = mm - 1 return end subroutine prich (nn,r,z) implicit double precision (a-h, o-z) c c ... prich does the richardson preconditioning. c c ... parameters -- c c n order of system (= nn) c r residual c z output vector c c ... specifications for parameters c dimension r(1), z(1) c n = nn do 10 i = 1,n 10 z(i) = r(i) return end subroutine pstops (nn,r,z,u,ubar,ier) implicit double precision (a-h, o-z) c c ... pstops performs a test to see if the iterative method has c converged to a solution inside the error tolerance, zeta. c (cg and si routines) c c the stopping tests are -- c c (1) (emax/emin) * sqrt ( (r ,zt)/(rhs,inv(q)*rhs) ) c (2) ( 1.0/emin) * sqrt ( (zt,zt)/(u,u) ) c (3) (emax/emin) * sqrt ( (zt,zt)/(inv(q)*rhs,inv(q)*rhs) ) c (4) sqrt ( (zt,zt)/(inv(q)*rhs,inv(q)*rhs) ) c (5) sqrt ( (r ,r )/(rhs,rhs) ) c (6) sqrt ( (u-ubar,u-ubar)/(ubar,ubar) ) c (7) (emax/emin) * sqrt ( (r,z)/(rhs,inv(ql)*rhs) ) c (8) ( 1.0/emin) * sqrt ( (z,z)/(u,u) ) c (9) (emax/emin) * sqrt ( (z,z)/(inv(ql)*rhs,inv(ql)*rhs) ) c (10) sqrt ( (z,z)/(inv(ql)*rhs,inv(ql)*rhs) ) c c c ... parameters -- c c n order of system c r residual vector c z pseudo-residual vector c u solution estimate c ier error flag c = 0 no errors detected c = -7 splitting matrix is not positive definite c c ... specifications for parameters c dimension r(1), z(1), u(1), ubar(1) c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 common / itcom4 / srelpr, keyzer, keygs common / itcom9 / rdot, rzdot, rztdot, zdot, zztdot, ztdot, a rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp, a udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav c c *** end -- package common c logical q1 save q1 n = nn halt = .false. tiny = 500.0d0*srelpr nteste = ntest if (ntest .gt. 6) nteste = nteste - 6 c go to (10,20,30,40,50,60), nteste c c ... test 1 c 10 if (rzdot .ge. 0.0d0) go to 15 ier = -7 call ershow (ier,'pstops') return 15 emaxl = emax eminl = emin if (eminl .lt. tiny) eminl = tiny tl = emaxl*sqrt (rzdot) tr = eminl*bnorm1 stptst = tl/tr if (tl .lt. tr*zeta) halt = .true. return c c ... test 2 c c ... special procedure for zeroth iteration c 20 if (in .ge. 1) go to 25 q1 = .false. udnm = 1.0d0 stptst = sqrt (rzdot) if (stptst .lt. tiny) halt = .true. return c c ... in .ge. 1 c c ... test if udnm needs to be recomputed. c 25 if (q1) go to 28 if ((in .gt. 5) .and. (mod(in,5) .ne. 0)) go to 28 uold = udnm udnm = sqrt ( vdot (n,u,u) ) if (udnm .lt. tiny) udnm = 1.0d0 if ((in .gt. 5) .and. a (abs (udnm-uold) .lt. udnm*zeta)) q1 = .true. c c ... compute stopping test. c 28 eminl = emin if (eminl .lt. tiny) eminl = tiny tl = sqrt ( vdot (n,z,z) ) tr = udnm*eminl stptst = tl/tr if (tl .lt. tr*zeta) halt = .true. return c c ... test 3. c 30 emaxl = emax eminl = emin if (eminl .lt. tiny) eminl = tiny tl = emaxl*sqrt ( vdot (n,z,z) ) tr = eminl*bnorm1 stptst = tl/tr if (tl .lt. tr*zeta) halt = .true. return c c ... test 4. c 40 tl = sqrt ( vdot (n,z,z) ) tr = bnorm1 stptst = tl/tr if (tl .lt. tr*zeta) halt = .true. return c c ... test 5. c 50 tl = sqrt ( vdot (n,r,r) ) tr = bnorm stptst = tl/tr if (tl .lt. tr*zeta) halt = .true. return c c ... test 6. c 60 sum = 0.0d0 do 65 i = 1,n 65 sum = sum + (u(i) - ubar(i))**2 tl = sqrt (sum) tr = ubarnm stptst = tl/tr if (tl .lt. tr*zeta) halt = .true. return end subroutine rowise (maxnz,jcoef,irwise) implicit double precision (a-h, o-z) c c ... rowise determines whether a row-wise or diagonal-wise c algorithm should be used for ic and ssor splittings with c diagonal storage. this routine should be called after c final factorization is computed. c c ... parameters -- c c maxnz number of number of diagonals stored c jcoef vector of diagonal numbers for factorization c array or matrix c irwise has a value upon output of c 0 if diagonal-wise algorithm should be used c 1 if row-wise algorithm should be used c c ... specifications for parameters c integer jcoef(2) c c ... use a rowwise algorithm if 2 .le. /jcoef(j)/ .le. maxd c some j. c maxd = 10 c irwise = 0 do 15 j = 1,maxnz jcol = iabs(jcoef(j)) if (jcol .le. 1 .or. jcol .gt. maxd) go to 15 irwise = 1 return 15 continue return end subroutine rowsum (lda,n,maxnzz,a,x,isym) implicit double precision (a-h, o-z) c c ... rowsum computes the row sum of the matrix a. c c ... parameters -- c c lda leading dimension of array a c n active size of array a c maxnz number of columns in array a c a array of size n by maxnz c x vector of length n containing the row c sum of a upon output c isym symmetry switch c = 0 matrix is a banded symmetric matrix c with the diagonal in column one c = 1 matrix is nonsymmetric c c ... specifications for parameters c dimension a(lda,1), x(1) c maxnz = maxnzz do 10 i = 1,n 10 x(i) = 0.0d0 do 20 j = 1,maxnz do 15 i = 1,n 15 x(i) = x(i) + a(i,j) 20 continue if (isym .eq. 1 .or. maxnz .le. 1) return do 30 j = 2,maxnz do 25 i = j,n 25 x(i) = x(i) + a(i-j+1,j) 30 continue return end subroutine rsad (nn,nsize,nrr,ndim,maxnew,ndtt,ndbb,jcnew, a coef,c,b,dfac,wksp) implicit double precision (a-h, o-z) c c ... rsad computes c = (dr - t*inv(db)*b)*b c c where a = ( dr t ) c ( b db ) c c diagonal storage c c ... parameters -- c c n order of system c nsize size of an individual subsystem (if multiple c systems) c nr order of the red subsystem c ndim row dimension of coef array c maxnew number of columns in coef array c ndt number of upper diagonals in diagonal block c ndb number of lower diagonals in diagonal block c coef floating point data structure c b vector of length n containing bb behind br c c vector of length nr containing cr c dfac vector of length (1+nt+nb)*n to contain c factorization of diagonal block upon output c wksp workspace vector of length nb c c ... specifications for parameters c integer jcnew(2,1), maxnew(2) dimension coef(ndim,2), b(1), c(1), dfac(1), wksp(1) c n = nn nr = nrr ndt = ndtt ndb = ndbb nrp1 = nr + 1 nb = n - nr maxd = 1 + ndt + ndb maxz = maxnew(1) - maxd max2 = maxnew(2) - maxd c c ... cr = dr*br. c if (ndt+ndb .gt. 0) go to 15 do 10 i = 1,nr 10 c(i) = coef(i,1)*b(i) go to 20 15 call bmuln (ndim,nr,ndt,ndb,coef,coef(1,2),coef(1,ndt+2),b,c) c c ... wksp = b*br c 20 if (maxz*max2 .eq. 0) return do 25 i = 1,nb 25 wksp(i) = 0.0d0 call vaddd (ndim,2,nb,nr,max2,coef(nrp1,maxd+1), a jcnew(2,maxd+1),wksp,b,-nr) c c ... wksp = inv(db)*wksp c if (ndt+ndb .gt. 0) go to 35 do 30 i = 1,nb 30 wksp(i) = wksp(i)*dfac(i+nr) go to 40 35 call bdsol (n,nb,nsize,ndt,ndb,dfac(nrp1),wksp,wksp,1) c c ... cr = cr - t*wksp c 40 call vsubd (ndim,2,nr,nb,maxz,coef(1,maxd+1),jcnew(1,maxd+1), a c,wksp,nr) return end subroutine rsap (ndimm,n,nr,maxnz,jcoef,coef,b,c,wksp) implicit double precision (a-h, o-z) c c ... rsap computes c = (dr - t*inv(db)*b)*b c c where a = ( dr t ) c ( b db ) c c purdue format c c ... parameters -- c c ndim row dimension of coef,jcoef arrays c n order of total system c nr order of red subsystem c maxnz number of columns in coef,jcoef arrays c jcoef integer array of matrix column numbers c coef floating point array of matrix coefficients c b,c vectors of length nr c wksp workspace array of length n + nb c c ... specifications for parameters c integer jcoef(ndimm,2) dimension coef(ndimm,2), b(1), c(1), wksp(1) c ndim = ndimm do 10 i = 1,nr 10 c(i) = coef(i,1)*b(i) if (maxnz .le. 1) return np1 = n + 1 nb = n - nr nrp1 = nr + 1 maxm1 = maxnz - 1 do 15 i = 1,n 15 wksp(i) = 0.0d0 call vaddp (ndim,ndim,nb,maxm1,coef(nrp1,2),jcoef(nrp1,2), a wksp(nrp1),b,wksp(np1)) do 20 i = nrp1,n 20 wksp(i) = wksp(i)/coef(i,1) call vsubp (ndim,ndim,nr,maxm1,coef(1,2),jcoef(1,2),c,wksp,wksp) return end subroutine rsatd (nn,nsize,nrr,ndim,maxnew,ndtt,ndbb,jcnew, a coef,c,b,dfac,wksp) implicit double precision (a-h, o-z) c c ... rsatd computes c = ((dr**t) - (b**t)*(db**(-t))*(t**t))*b c c where a = ( dr t ) c ( b db ) c c diagonal storage c c ... parameters -- c c n order of system c nsize size of an individual subsystem (if multiple c systems) c nr order of the red subsystem c ndim row dimension of coef array c maxnew number of columns in coef array c ndt number of upper diagonals in diagonal block c ndb number of lower diagonals in diagonal block c coef floating point data structure c b vector of length n containing bb behind br c c vector of length nr containing cr c dfac vector of length (1+nt+nb)*n to contain c factorization of diagonal block upon output c wksp workspace vector of length nb c c ... specifications for parameters c integer jcnew(2,1), maxnew(2) dimension coef(ndim,2), b(1), c(1), dfac(1), wksp(1) c n = nn nr = nrr ndt = ndtt ndb = ndbb nrp1 = nr + 1 nb = n - nr maxd = 1 + ndt + ndb maxz = maxnew(1) - maxd max2 = maxnew(2) - maxd c c ... cr = (dr**t)*br. c if (ndt+ndb .gt. 0) go to 15 do 10 i = 1,nr 10 c(i) = coef(i,1)*b(i) go to 20 15 call bmulnt (ndim,nr,ndt,ndb,coef,coef(1,2),coef(1,ndt+2),b,c) c c ... wksp = (t**t)*br c 20 if (maxz*max2 .eq. 0) return do 25 i = 1,nb 25 wksp(i) = 0.0d0 call vadddt (ndim,2,nr,nb,maxz,coef(1,maxd+1), a jcnew(1,maxd+1),wksp,b,nr) c c ... wksp = (db**(-t))*wksp c if (ndt+ndb .gt. 0) go to 35 do 30 i = 1,nb 30 wksp(i) = wksp(i)*dfac(i+nr) go to 40 35 call bdsolt (n,nb,nsize,ndt,ndb,dfac(nrp1),wksp,wksp) c c ... cr = cr - (b**t)*wksp c 40 call vsubdt (ndim,2,nb,nr,max2,coef(nrp1,maxd+1), a jcnew(2,maxd+1),c,wksp,-nr) return end subroutine rsatp (ndimm,n,nr,maxnz,jcoef,coef,b,c,wksp) implicit double precision (a-h, o-z) c c ... rsatp computes c = (dr - (b**t)*inv(db)*(t**t))*b c c where a = ( dr t ) c ( b db ) c c purdue format c c ... parameters -- c c ndim row dimension of coef,jcoef arrays c n order of total system c nr order of red subsystem c maxnz number of columns in coef,jcoef arrays c jcoef integer array of matrix column numbers c coef floating point array of matrix coefficients c b,c vectors of length nr c wksp workspace array of length n + nb c c ... specifications for parameters c integer jcoef(ndimm,2) dimension coef(ndimm,2), b(1), c(1), wksp(1) c ndim = ndimm do 10 i = 1,nr 10 c(i) = coef(i,1)*b(i) if (maxnz .le. 1) return np1 = n + 1 nb = n - nr nrp1 = nr + 1 maxm1 = maxnz - 1 do 15 i = 1,n 15 wksp(i) = 0.0d0 call vaddpt (ndim,ndim,nr,maxm1,coef(1,2),jcoef(1,2),wksp,b, a wksp) do 20 i = nrp1,n 20 wksp(i) = wksp(i)/coef(i,1) call vsubpt (ndim,ndim,nb,maxm1,coef(nrp1,2),jcoef(nrp1,2),c, a wksp(nrp1),wksp(np1)) return end subroutine rsbegd (nn,nsize,nrr,ndim,maxnew,ndtt,ndbb,jcnew, a coef,c,b,dfac,wksp) implicit double precision (a-h, o-z) c c ... rsbegd computes cr = br - t*inv(db)*bb. c c where a = ( dr t ) c ( b db ) c c diagonal storage c c ... parameters -- c c n order of system c nsize size of an individual subsystem (if multiple c systems) c nr order of the red subsystem c ndim row dimension of coef array c maxnew number of columns in coef array c ndt number of upper diagonals in diagonal block c ndb number of lower diagonals in diagonal block c coef floating point data structure c b vector of length n containing bb behind br c c vector of length nr containing cr c dfac vector of length (1+nt+nb)*n containing c factorization of diagonal block upon input c wksp workspace vector of length nb c c ... specifications for parameters c integer jcnew(2,1), maxnew(2) dimension coef(ndim,2), b(1), c(1), dfac(1), wksp(1) c n = nn nr = nrr ndt = ndtt ndb = ndbb nrp1 = nr + 1 nb = n - nr maxd = 1 + ndt + ndb c c ... compute cr. c do 10 i = 1,nr 10 c(i) = b(i) call bdsol (n,nb,nsize,ndt,ndb,dfac(nrp1),b(nrp1),wksp,1) maxm1 = maxnew(1) - maxd call vsubd (ndim,2,nr,nb,maxm1,coef(1,maxd+1),jcnew(1,maxd+1), a c,wksp,nr) return end subroutine rsbegp (n,nr,ndim,maxnz,jcoef,coef,c,b,wksp) implicit double precision (a-h, o-z) c c ... rsbegp computes cr = br - t*inv(db)*bb. c c where a = ( dr t ) c ( b db ) c c purdue storage c c ... parameters -- c c n order of system c nr order of the red subsystem c ndim row dimension of coef array c maxnz number of columns in coef array c jcoef integer data structure c coef floating point data structure c b vector of length n containing bb behind br c c vector of length nr containing cr c wksp workspace vector of length n c c ... specifications for parameters c integer jcoef(ndim,2) dimension coef(ndim,2), b(1), c(1), wksp(1) c nrp1 = nr + 1 do 10 i = 1,nr 10 c(i) = b(i) if (maxnz .le. 1) return do 15 i = nrp1,n 15 wksp(i) = b(i)/coef(i,1) maxm1 = maxnz - 1 call vsubp (ndim,ndim,nr,maxm1,coef(1,2),jcoef(1,2),c, a wksp,wksp) return end subroutine rsendd (nn,nsize,nrr,ndim,maxnew,ndtt,ndbb,jcnew, a coef,x,b,dfac) implicit double precision (a-h, o-z) c c ... rsendd computes xb = inv(db)*(bb - b*xr) c c where a = ( dr t ) c ( b db ) c c diagonal storage c c ... parameters -- c c n order of system c nsize size of an individual subsystem (if multiple c systems) c nr order of the red subsystem c ndim row dimension of coef array c maxnew number of columns in coef array c ndt number of upper diagonals in diagonal block c ndb number of lower diagonals in diagonal block c coef floating point data structure c x vector of length n containing xr, xb c b vector of length n containing bb in the last c nb locations c dfac vector of length (1+nt+nb)*n containing c factorization of diagonal block upon input c c ... specifications for parameters c integer jcnew(2,1), maxnew(2) dimension coef(ndim,2), x(1), b(1), dfac(1) c n = nn nr = nrr ndt = ndtt ndb = ndbb nrp1 = nr + 1 nb = n - nr maxd = 1 + ndt + ndb c c ... compute xb. c do 10 i = nrp1,n 10 x(i) = b(i) max2 = maxnew(2) - maxd call vsubd (ndim,2,nb,nr,max2,coef(nrp1,maxd+1), a jcnew(2,maxd+1),x(nrp1),x,-nr) call bdsol (n,nb,nsize,ndt,ndb,dfac(nrp1),x(nrp1),x(nrp1),1) return end subroutine rsendp (n,nr,ndim,maxnz,jcoef,coef,x,b,wksp) implicit double precision (a-h, o-z) c c ... rsendp computes xb = inv(db)*(bb - b*xr) c c where a = ( dr t ) c ( b db ) c c purdue format c c ... parameters -- c c n order of matrix c nr order of red subsystem c ndim row dimension of ah and jah arrays c maxnz number of columns in coef and jcoef arrays c jcoef integer array of column numbers c coef floating point array of matrix coefficients c x vector of length n containing xr, xb c b vector of length n containing bb in the last c nb locations c wksp workspace array of length nb c c ... specifications for parameters c integer jcoef(ndim,2) dimension coef(ndim,2), x(1), b(1), wksp(1) c nrp1 = nr + 1 nb = n - nr do 10 i = nrp1,n 10 x(i) = b(i) if (maxnz .le. 1) go to 15 maxm1 = maxnz - 1 call vsubp (ndim,ndim,nb,maxm1,coef(nrp1,2),jcoef(nrp1,2), a x(nrp1),x,wksp) 15 do 20 i = nrp1,n 20 x(i) = x(i)/coef(i,1) return end subroutine rsmatd (ndim,nrr,nb,maxnew,jcnew,dr,ah,ak,db, a maxrss,jcrs,rs,maxlim,isym,ier) implicit double precision (a-h, o-z) c c ... rsmatd computes rs = dr - ah*inv(db)*ak where a has been c permuted to red-black form -- c c * dr ah * c a = * * c * ak db * c c (diagonal storage) c c dr is nr x nr ah is nr x nb c ak is nb x nr db is nb x nb c c ... definition of parameters -- c c ndim row dimension of ah and ak arrays c nr number of red points c nb number of black points c maxnew integer vector of length 2 indicating number c of diagonals stored in ah and ak, c respectively. c jcnew integer array of diagonal numbers c dr vector of length nr c ah array of size nr by (maxnew(1)-1) c ak array of size nb by (maxnew(2)-1) c db vector of length nb c maxrs number of columns needed to store reduced c system (output) c jcrs diagonal numbers for rs (output) c rs array to contain reduced system c maxlim maximum column width to be allowed for rs c isym symmetry switch for rs matrix c = 0 store only upper half of rs c = 1 store all of rs c ier error code c = 0 no errors detected c = -2 maxlim .lt. maxrs c c ... specifications for parameters c integer maxnew(2), jcnew(2,1), jcrs(1) dimension db(1), ak(ndim,1), ah(ndim,1), dr(1), rs(nrr,1) c nr = nrr maxrs = 1 jcrs(1) = 0 do 5 i = 1,nr 5 rs(i,1) = dr(i) maxh = maxnew(1) - 1 maxk = maxnew(2) - 1 do 35 lh = 1,maxh i = jcnew(1,lh+1) - nr ia1 = max (1,1-i) ib1 = min (nr,nb-i) do 30 lk = 1,maxk k = jcnew(2,lk+1) + nr l = i + k if (l .lt. 0 .and. isym .eq. 0) go to 30 do 10 ld = 1,maxrs if (jcrs(ld) .eq. l) go to 20 10 continue if (maxrs .eq. maxlim) go to 999 maxrs = maxrs + 1 ld = maxrs jcrs(maxrs) = l do 15 ii = 1,nr 15 rs(ii,maxrs) = 0.0d0 20 ist = max (ia1,1-l) ied = min (ib1,nr-l) do 25 m = ist,ied 25 rs(m,ld) = rs(m,ld) - ah(m,lh)*ak(m+i,lk)/db(m+i) 30 continue 35 continue maxrss = maxrs return c c ... error exit -- maxlim too small. c 999 ier = -2 return end subroutine rsmatp (ndim,nrr,maxnzz,jcoef,coef,maxrss,jcrs, a rs,maxlim,wksp,iwksp,ier) implicit double precision (a-h, o-z) c c ... rsmatp computes rs = dr - ah*inv(db)*ak where a has been c permuted to red-black form -- c c * dr ah * c a = * * c * ak db * c c (purdue storage) c c dr is nr x nr ah is nr x nb c ak is nb x nr db is nb x nb c c ... definition of parameters -- c c ndim row dimension of coef and jcoef arrays c nr number of red points c maxnz number of columns in coef and jcoef c jcoef array of column indices c coef array of matrix coefficients c maxrs number of columns needed to store reduced c system (output) c jcrs column numbers for rs (output) c rs array to contain reduced system c maxlim maximum column width to be allowed for rs c wksp workspace of length 2*nr c iwksp integer workspace of length nr c ier error code c = 0 no errors detected c = -2 maxlim .lt. maxrs c c ... specifications for parameters c integer jcoef(ndim,1), jcrs(nrr,1), iwksp(1) dimension coef(ndim,1), rs(nrr,1), wksp(1) c nr = nrr maxnz = maxnzz maxrs = 1 do 5 i = 1,nr rs(i,1) = coef(i,1) jcrs(i,1) = i 5 continue do 50 j = 2,maxnz call vgathr (nr,coef,jcoef(1,j),wksp) do 10 i = 1,nr 10 wksp(i) = coef(i,j)/wksp(i) do 45 jj = 2,maxnz call vgathr (nr,coef(1,jj),jcoef(1,j),wksp(nr+1)) call vgathi (nr,jcoef(1,jj),jcoef(1,j),iwksp) do 15 i = 1,nr 15 wksp(nr+i) = wksp(i)*wksp(nr+i) do 40 i = 1,nr jcol = iwksp(i) term = wksp(nr+i) if (jcol .gt. nr) go to 40 do 20 jjj = 1,maxrs if (jcrs(i,jjj) .ne. jcol) go to 20 rs(i,jjj) = rs(i,jjj) - term go to 40 20 continue if (maxrs .eq. 1) go to 30 do 25 jjj = 2,maxrs if (jcrs(i,jjj) .ne. i) go to 25 rs(i,jjj) = rs(i,jjj) - term jcrs(i,jjj) = jcol go to 40 25 continue 30 if (maxrs .eq. maxlim) go to 999 maxrs = maxrs + 1 do 35 ii = 1,nr jcrs(ii,maxrs) = ii rs(ii,maxrs) = 0.0d0 35 continue rs(i,maxrs) = -term jcrs(i,maxrs) = jcol 40 continue 45 continue 50 continue maxrss = maxrs return c c ... error exit -- maxlim too small. c 999 ier = -2 return end subroutine rsrhsd (nn,nrr,ndim,maxnew,jcnew,coef,c,b,wksp) implicit double precision (a-h, o-z) c c ... rsrhsd computes cr = br - t*inv(db)*bb. c c where a = ( dr t ) c ( b db ) c c diagonal storage c c ... parameters -- c c n order of system c systems) c nr order of the red subsystem c ndim row dimension of coef array c maxnew number of columns in coef array c coef floating point data structure c b vector of length n containing bb behind br c c vector of length nr containing cr c wksp workspace vector of length nb c c ... specifications for parameters c integer jcnew(2,2), maxnew(2) dimension coef(ndim,2), b(1), c(1), wksp(1) c n = nn nr = nrr nb = n - nr c c ... compute cr. c do 10 i = 1,nr 10 c(i) = b(i) do 15 i = 1,nb 15 wksp(i) = b(nr+i)/coef(nr+i,1) maxm1 = maxnew(1) - 1 call vsubd (ndim,2,nr,nb,maxm1,coef(1,2),jcnew(1,2), a c,wksp,nr) return end subroutine rsxbd (nn,nrr,ndim,maxnew,jcnew,coef,x,b) implicit double precision (a-h, o-z) c c ... rsxbd computes xb = inv(db)*(bb - b*xr) c c where a = ( dr t ) c ( b db ) c c diagonal storage c c ... parameters -- c c n order of system c systems) c nr order of the red subsystem c ndim row dimension of coef array c maxnew number of columns in coef array c coef floating point data structure c x vector of length n containing xr, xb c b vector of length n containing bb in the last c nb locations c c ... specifications for parameters c integer jcnew(2,2), maxnew(2) dimension coef(ndim,2), x(1), b(1) c n = nn nr = nrr nrp1 = nr + 1 nb = n - nr c c ... compute xb. c do 10 i = nrp1,n 10 x(i) = b(i) max2 = maxnew(2) - 1 call vsubd (ndim,2,nb,nr,max2,coef(nrp1,2), a jcnew(2,2),x(nrp1),x,-nr) do 15 i = nrp1,n 15 x(i) = x(i)/coef(i,1) return end subroutine sbbs (ldd,ldt,n,kblszz,nsize,lbhb,iblock,d,t, a jt,x,omega) implicit double precision (a-h, o-z) c c ... sbbs does an block ssor backward pass. c symmetric diagonal data structure, natural ordering. c block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c kblsz block size c nsize size of an individual subsystem within a c diagonal block c lbhb number of blocks per block row c iblock integer array of size 3 by lbhb c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer vector giving the diagonal numbers c for the off-diagonal blocks c x input/output vector of length n c omega over-relaxation factor c c ... specifications for parameters c integer jt(1), iblock(3,1) dimension d(ldd,2), t(ldt,1), x(1) c kblsz = kblszz l = n/kblsz nt = iblock(3,1) - 1 do 35 k = l,1,-1 ist = (k - 1)*kblsz + 1 ied = k*kblsz if (k .eq. l) go to 15 jjlim = min (lbhb,l-k+2) do 10 jj = 3,jjlim jblk = iblock(1,jj) jst = iblock(2,jj) mjj = iblock(3,jj) inc = jblk*kblsz istf = ist + inc if (istf .gt. n) go to 10 call vsubd (ldt,1,kblsz,kblsz,mjj,t(ist,jst),jt(jst), a x(ist),x(istf),inc) 10 continue 15 if (nt .ge. 1) go to 25 do 20 i = ist,ied 20 x(i) = omega*d(i,1)*x(i) go to 35 25 call bdsol (ldd,kblsz,nsize,nt,0,d(ist,1),x(ist),x(ist), a 0) do 30 i = ist,ied 30 x(i) = omega*x(i) 35 continue return end subroutine sbbsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif,wksp) implicit double precision (a-h, o-z) c c ... sbbsn does an block ssor backward solve. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c x input/output vector of length n c omega over-relaxation factor c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical unif c unif = iunif .eq. 1 c l = ncolor if (.not. unif) go to 10 na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) kk = 1 c c ... do backward solution. c 10 lm1 = l - 1 do 50 k = lm1,1,-1 if (unif) go to 15 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) go to 20 15 ist = (k - 1)*na + 1 20 ied = ist + na - 1 do 25 i = 1,na 25 wksp(i) = 0.0d0 do 30 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .le. k) go to 30 jstb = iblock(2,kk,j) mb = iblock(3,kk,j) if (unif) inc = (jcol - k)*na if (.not. unif) inc = ipt(jcol) - ipt(k) if (.not. unif) nb = nci(jcol) istb = ist + inc call vaddd (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb), a wksp,x(istb),inc) 30 continue if (ndt + ndb .ge. 1) go to 40 do 35 i = ist,ied 35 x(i) = x(i) - omega*d(i,1)*wksp(i-ist+1) go to 50 40 call bdsol (ldd,na,nsize,ndt,ndb,d(ist,1),wksp,wksp,1) do 45 i = ist,ied 45 x(i) = x(i) - omega*wksp(i-ist+1) 50 continue return end subroutine sbbsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif) implicit double precision (a-h, o-z) c c ... sbbsnt does an block ssor transpose backward solve. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c x input/output vector of length n c omega over-relaxation factor c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,2), t(ldt,1), x(1) logical unif c unif = iunif .eq. 1 c l = ncolor if (.not. unif) go to 10 na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) kk = 1 c c ... do backward solution. c 10 do 50 k = l,1,-1 if (unif) go to 15 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) go to 20 15 ist = (k - 1)*na + 1 20 ied = ist + na - 1 if (ndt + ndb .ge. 1) go to 30 do 25 i = ist,ied 25 x(i) = omega*d(i,1)*x(i) go to 40 30 call bdsolt (ldd,na,nsize,ndt,ndb,d(ist,1),x(ist),x(ist)) do 35 i = ist,ied 35 x(i) = omega*x(i) 40 do 45 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .ge. k) go to 45 jstb = iblock(2,kk,j) mb = iblock(3,kk,j) if (unif) inc = (jcol - k)*na if (.not. unif) inc = ipt(jcol) - ipt(k) if (.not. unif) nb = nci(jcol) istb = ist + inc call vsubdt (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb), a x(istb),x(ist),inc) 45 continue 50 continue return end subroutine sbfs (ldd,ldt,n,kblszz,nsize,lbhb,iblock,d,t, a jt,x,omega,wksp) implicit double precision (a-h, o-z) c c ... sbfs does an block ssor forward pass. c symmetric diagonal data structure, natural ordering. c block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c kblsz block size c nsize size of an individual subsystem within a c diagonal block c lbhb number of blocks per block row c iblock integer array of size 3 by lbhb c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer vector giving the diagonal numbers c for the off-diagonal blocks c x input/output vector of length n c omega over-relaxation factor c wksp floating point workspace vector c c ... specifications for parameters c integer jt(1), iblock(3,1) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) c kblsz = kblszz l = n/kblsz lm1 = l - 1 nt = iblock(3,1) - 1 do 35 k = 1,lm1 ist = (k - 1)*kblsz + 1 ied = k*kblsz if (nt .ge. 1) go to 15 do 10 i = ist,ied 10 wksp(i-ist+1) = omega*d(i,1)*x(i) go to 25 15 call bdsol (ldd,kblsz,nsize,nt,0,d(ist,1), a x(ist),wksp,0) do 20 i = 1,kblsz 20 wksp(i) = omega*wksp(i) 25 jjlim = min (lbhb,l-k+2) do 30 jj = 3,jjlim jblk = iblock(1,jj) jst = iblock(2,jj) mjj = iblock(3,jj) inc = jblk*kblsz istf = ist + inc if (istf .gt. n) go to 30 call vsubdt (ldt,1,kblsz,kblsz,mjj,t(ist,jst),jt(jst), a x(istf),wksp,inc) 30 continue 35 continue return end subroutine sbfsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif) implicit double precision (a-h, o-z) c c ... sbfsn does an block ssor forward solve. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c x input/output vector of length n c omega over-relaxation factor c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,2), t(ldt,1), x(1) logical unif c unif = iunif .eq. 1 c l = ncolor if (.not. unif) go to 10 na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) kk = 1 c c ... do forward solution. c 10 do 45 k = 1,l if (unif) go to 15 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) go to 20 15 ist = (k - 1)*na + 1 20 ied = ist + na - 1 do 25 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .ge. k) go to 25 jstb = iblock(2,kk,j) mb = iblock(3,kk,j) if (unif) inc = (jcol - k)*na if (.not. unif) inc = ipt(jcol) - ipt(k) if (.not. unif) nb = nci(jcol) istb = ist + inc call vsubd (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb), a x(ist),x(istb),inc) 25 continue if (ndt + ndb .ge. 1) go to 35 do 30 i = ist,ied 30 x(i) = omega*d(i,1)*x(i) go to 45 35 call bdsol (ldd,na,nsize,ndt,ndb,d(ist,1),x(ist),x(ist),1) do 40 i = ist,ied 40 x(i) = omega*x(i) 45 continue return end subroutine sbfsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif,wksp) implicit double precision (a-h, o-z) c c ... sbfsnt does an block ssor transpose forward solve. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c x input/output vector of length n c omega over-relaxation factor c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical unif c unif = iunif .eq. 1 c l = ncolor if (.not. unif) go to 10 na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) kk = 1 c c ... do forward solution. c 10 lm1 = l - 1 do 50 k = 1,lm1 if (unif) go to 15 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) go to 20 15 ist = (k - 1)*na + 1 20 ied = ist + na - 1 if (ndt + ndb .ge. 1) go to 30 do 25 i = ist,ied 25 wksp(i-ist+1) = omega*d(i,1)*x(i) go to 40 30 call bdsolt (ldd,na,nsize,ndt,ndb,d(ist,1),x(ist),wksp) do 35 i = 1,na 35 wksp(i) = omega*wksp(i) 40 do 45 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol .le. k) go to 45 jstb = iblock(2,kk,j) mb = iblock(3,kk,j) if (unif) inc = (jcol - k)*na if (.not. unif) inc = ipt(jcol) - ipt(k) if (.not. unif) nb = nci(jcol) istb = ist + inc call vsubdt (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb), a x(istb),wksp,inc) 45 continue 50 continue return end subroutine sbsl (ldd,ldt,n,kblsz,nsize,lbhb,iblock,d,t, a jt,y,x,omega,wksp) implicit double precision (a-h, o-z) c c ... sbsl does an block ssor solution. c symmetric diagonal data structure, natural ordering. c block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c kblsz block size c nsize size of an individual subsystem within a c diagonal block c lbhb number of blocks per block row c iblock integer array of size 3 by lbhb c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer vector giving the diagonal numbers c for the off-diagonal blocks c y input vector for the right-hand-side c x output vector for the solution to q*x = y c omega over-relaxation factor c wksp floating point workspace vector c c ... specifications for parameters c integer jt(1), iblock(3,1) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c const = 2.0d0 - omega do 10 i = 1,n 10 x(i) = const*y(i) call sbfs (ldd,ldt,n,kblsz,nsize,lbhb,iblock,d,t, a jt,x,omega,wksp) call sbbs (ldd,ldt,n,kblsz,nsize,lbhb,iblock,d,t, a jt,x,omega) return end subroutine sbsln (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,omega,iunif,wksp) implicit double precision (a-h, o-z) c c ... sbsln does an block ssor solution. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c omega over-relaxation factor c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c const = 2.0d0 - omega do 10 i = 1,n 10 x(i) = const*y(i) call sbfsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif) call sbbsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif,wksp) return end subroutine sbslnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,omega,iunif,wksp) implicit double precision (a-h, o-z) c c ... sbslnt does an block ssor transpose solution. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c omega over-relaxation factor c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c const = 2.0d0 - omega do 10 i = 1,n 10 x(i) = const*y(i) call sbfsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif,wksp) call sbbsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif) return end subroutine sbsln1 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,omega,iunif) implicit double precision (a-h, o-z) c c ... sbsln1 does an block ssor forward solution. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c omega over-relaxation factor c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), x(1), y(1) c const = 2.0d0 - omega do 10 i = 1,n 10 x(i) = const*y(i) call sbfsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif) return end subroutine sbsln2 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,omega,iunif,wksp) implicit double precision (a-h, o-z) c c ... sbsln2 does an block ssor back solution. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c omega over-relaxation factor c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c do 10 i = 1,n 10 x(i) = y(i) call sbbsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif,wksp) return end subroutine sbsln3 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,omega,iunif) implicit double precision (a-h, o-z) c c ... sbsln3 does an block ssor transpose forward solution. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c omega over-relaxation factor c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), x(1), y(1) c const = 2.0d0 - omega do 10 i = 1,n 10 x(i) = const*y(i) call sbbsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif) return end subroutine sbsln4 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,y,x,omega,iunif,wksp) implicit double precision (a-h, o-z) c c ... sbsln4 does an block ssor transpose back solution. c nonsymmetric diagonal data structure, natural or multi-color c orderings, block ssor preconditioning. c c ... parameters -- c c ldd row dimension of d array c ldt row dimension of t array c n size of system c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c ncolor = 1 if iunif = 1. c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c if iunif = 1, nci(1) is the constant block size. c ipt integer pointer vector of length ncolor+1 if c iunif = 0. formed in the factorization routine. c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c if iunif = 1, lbhb is of length 1. c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c d array for diagonal block c t array for off-diagonal blocks c jt integer array of size ncolor by whatever c giving the off-diagonal block diagonal numbers c for each distinct block size. jd is 1 by whatever c if iunif = 1. c y input vector of length n containing right-hand-side c x output vector containing the solution to q*x = y c omega over-relaxation factor c iunif uniform block size switch c = 0 diagonal blocks are not of uniform size c = 1 diagonal blocks are of uniform size c wksp floating point workspace vector c c ... specifications for parameters c integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), a iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) c do 10 i = 1,n 10 x(i) = y(i) call sbfsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb, a iblock,d,t,jt,x,omega,iunif,wksp) return end subroutine scal1 (nn,ndim,maxnzz,jcoef,coef,rhs,u,ubar, a diag,work,iflag,ier) implicit double precision (a-h, o-z) c c ... scal1 scales the original matrix to a unit diagonal matrix. c (purdue data structure) c rhs and u vectors are scaled accordingly. upon output, diag c contains the reciprocal square roots of the diagonal elements. c it is assumed that the diagonal of the matrix is in column one c of coef. c c ... parameters -- c c n dimension of matrix c ndim row dimension of coef array in defining routine c maxnz number of columns in coef array c jcoef integer matrix representation array c coef matrix representation array c rhs right hand side of matrix problem c u latest estimate of solution c ubar exact solution (optional) c diag work array of length n (nonvolatile) c work work array of length n (volatile) c iflag flag for ubar c = 0 do not scale ubar c = 1 scale ubar c ier error flag -- on return, values mean c 0 -- no errors detected c -4 -- nonpositive diagonal element c c ... specifications for parameters c integer jcoef(ndim,1) dimension coef(ndim,1), rhs(1), u(1), diag(1), work(1), a ubar(1) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c n = nn maxnz = maxnzz c c ... check for positive diagonal entries for each row. c cmin = vmin (n,coef) if (cmin .gt. 0.0d0) go to 10 c c ... fatal error -- nonpositive diagonal element. c ier = -4 return c c ... scale matrix. store reciprocal square roots c ... of diagonal entries in diag. c 10 do 15 i = 1,n 15 diag(i) = sqrt (coef(i,1)) c c ... scale rhs, u, and ubar. c do 20 i = 1,n 20 u(i) = diag(i)*u(i) if (iflag .eq. 0) go to 30 do 25 i = 1,n 25 ubar(i) = diag(i)*ubar(i) 30 do 35 i = 1,n 35 diag(i) = 1.0d0/diag(i) do 40 i = 1,n 40 rhs(i) = diag(i)*rhs(i) if (keygs .eq. 2) go to 55 c c ... using gathers. c do 50 j = 1,maxnz call vgathr (n,diag,jcoef(1,j),work) do 45 i = 1,n 45 coef(i,j) = diag(i)*coef(i,j)*work(i) 50 continue return c c ... not using gathers. c 55 do 65 j = 1,maxnz do 60 i = 1,n 60 coef(i,j) = diag(i)*coef(i,j)*diag(jcoef(i,j)) 65 continue return end subroutine scal2 (nn,ndim,maxnz,jcoef,coef,rhs,u,ubar, a diag,iflag,ier) implicit double precision (a-h, o-z) c c ... scal2 scales the original matrix to a unit diagonal matrix. c (diagonal data structure) c rhs and u vectors are scaled accordingly. upon output, diag c contains the reciprocal square roots of the diagonal elements. c it is assumed that the diagonal of the matrix is in column one c of coef. c c ... parameters -- c c n dimension of matrix c ndim row dimension of coef array in defining routine c maxnz number of columns in coef array c jcoef integer matrix representation array c coef matrix representation array c rhs right hand side of matrix problem c u latest estimate of solution c ubar exact solution (optional) c diag work array of length n (nonvolatile) c iflag flag for ubar c = 0 do not scale ubar c = 1 scale ubar c ier error flag -- on return, values mean c 0 -- no errors detected c -4 -- nonpositive diagonal element c c ... specifications for parameters c integer jcoef(2) dimension coef(ndim,1), rhs(1), u(1), diag(1), ubar(1) c c n = nn c c ... check for positive diagonal entries for each row. c cmin = vmin (n,coef) if (cmin .gt. 0.0d0) go to 10 c c ... fatal error -- nonpositive diagonal element. c ier = -4 return c c ... scale matrix. store reciprocal square roots c ... of diagonal entries in diag. c 10 do 15 i = 1,n 15 diag(i) = sqrt (coef(i,1)) c c ... scale rhs, u, and ubar. c do 20 i = 1,n 20 u(i) = diag(i)*u(i) if (iflag .eq. 0) go to 30 do 25 i = 1,n 25 ubar(i) = diag(i)*ubar(i) 30 do 35 i = 1,n 35 diag(i) = 1.0d0/diag(i) do 40 i = 1,n 40 rhs(i) = diag(i)*rhs(i) c c ... scale matrix. c do 60 j = 1,maxnz ind = jcoef(j) len = n - iabs(ind) if (ind .lt. 0) go to 50 do 45 i = 1,len 45 coef(i,j) = diag(i)*coef(i,j)*diag(i+ind) go to 60 50 do 55 i = 1,len 55 coef(i-ind,j) = diag(i-ind)*coef(i-ind,j)*diag(i) 60 continue return end subroutine scal3 (nn,nz,ia,ja,a,rhs,u,ubar,diag, a work,iflag,ier) implicit double precision (a-h, o-z) c c ... scal3 scales the original matrix to a unit diagonal matrix. c (sparse data structure) c rhs and u vectors are scaled accordingly. upon output, diag c contains the reciprocal square roots of the diagonal elements. c it is assumed that the diagonal of the matrix is in the c n first locations of a. c c ... parameters -- c c n dimension of matrix c nz length of ia, ja, and a vectors c a vector containing matrix coefficients c ia vector of i values c ja vector of j values c rhs right hand side of matrix problem c u latest estimate of solution c ubar exact solution (optional) c diag vector of length n containing the reciprocal c square roots of the diagonal elements upon c output c work workspace vector of length n c iflag flag for ubar c = 0 do not scale ubar c = 1 scale ubar c ier error flag -- on return, values mean c 0 -- no errors detected c -4 -- nonpositive diagonal element c c ... specifications for parameters c integer ia(1), ja(1) dimension a(1), rhs(1), u(1), diag(1), work(1), a ubar(1) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c n = nn c c ... check for positive diagonal entries for each row. c cmin = vmin (n,a) if (cmin .gt. 0.0d0) go to 10 c c ... fatal error -- nonpositive diagonal element. c ier = -4 return c c ... scale matrix. store reciprocal square roots c ... of diagonal entries in diag. c 10 do 15 i = 1,n 15 diag(i) = sqrt (a(i)) c c ... scale rhs, u, and ubar. c do 20 i = 1,n 20 u(i) = diag(i)*u(i) if (iflag .eq. 0) go to 30 do 25 i = 1,n 25 ubar(i) = diag(i)*ubar(i) 30 do 35 i = 1,n 35 diag(i) = 1.0d0/diag(i) do 40 i = 1,n 40 rhs(i) = diag(i)*rhs(i) if (keygs .eq. 2) go to 60 c c ... using gathers. c ist = 1 45 ied = min (ist-1+n,nz) if (ied .lt. ist) return len = ied - ist + 1 call vgathr (len,diag,ia(ist),work) do 50 i = ist,ied 50 a(i) = a(i)*work(i-ist+1) call vgathr (len,diag,ja(ist),work) do 55 i = ist,ied 55 a(i) = a(i)*work(i-ist+1) ist = ied + 1 go to 45 c c ... not using gathers. c 60 do 65 i = 1,nz 65 a(i) = a(i)*diag(ia(i))*diag(ja(i)) return end subroutine sorstp (n,u,ubar,dnrm,ccon) implicit double precision (a-h, o-z) c c ... sorstp performs a test to see if the sor c method has converged to a solution inside the error c tolerance, zeta. c c ... parameters -- c c n order of system c u present solution estimate c ubar exact solution c dnrm inner product of pseudo-residuals at preceding c iteration c con stopping test parameter (= ccon) c c ... specifications for parameters c dimension u(1), ubar(1) logical q1 save q1 c c *** begin -- itpack common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 c c *** end -- itpack common c con = ccon halt = .false. if (ntest .eq. 6) go to 25 c c ... special procedure for zeroth iteration. c if (in .ge. 1) go to 5 q1 = .false. udnm = 1.0d0 stptst = 1000.0d0 return c c ... test if udnm needs to be recomputed c 5 if (q1) go to 15 if ((in .gt. 5) .and. (mod(in,5) .ne. 0)) go to 15 uold = udnm udnm = 0.0d0 do 10 i = 1,n 10 udnm = udnm + u(i)*u(i) if (udnm .eq. 0.0d0) udnm = 1.0d0 if ((in .gt. 5) .and. a (abs (udnm-uold) .le. udnm*zeta)) q1 = .true. c c ... compute stopping test c 15 tr = sqrt (udnm) tl = 1.0d0 if (con .eq. 1.0d0) go to 20 tl = sqrt (dnrm) tr = tr*(1.0d0 - con) 20 stptst = tl/tr if (tl .ge. tr*zeta) return halt = .true. return c c ... second test. c 25 if (in .eq. 0) ubarnm = sqrt (vdot(n,ubar,ubar)) sum = 0.0d0 do 30 i = 1,n 30 sum = sum + (u(i) - ubar(i))**2 tl = sqrt (sum) tr = ubarnm stptst = tl/tr if (tl .lt. tr*zeta) halt = .true. return end subroutine sords (ndim,nn,maxtt,jt,d,t,omegaa,irwise, a u,rhs,unew,iwksp) implicit double precision (a-h, o-z) c c ... sords does an sor solve (natural ordering, c symmetric diagonal storage). c c unew = inv(d + w*l)*((1-w)*d*un + w*(rhs - u*un)) c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c u current solution vector c rhs right hand side c unew updated solution vector c iwksp integer workspace of length maxt c c ... specifications for parameters c dimension d(1), t(ndim,1), u(1), unew(1), rhs(1) integer jt(1), iwksp(1) c c n = nn maxt = maxtt omega = omegaa c c ... rhs = (1-w)*d*un + w*(rhs - u*un) c call vsubd (ndim,1,n,n,maxt,t,jt,rhs,u,0) con = 1.0d0 - omega do 10 i = 1,n 10 rhs(i) = con*d(i)*u(i) + omega*rhs(i) c c ... rhs = inv(i+w*l*inv(d))*rhs c c ... select rowwise or diagonal-wise algorithm. c if (irwise .eq. 1) go to 50 c c ... diagonal-wise algorithm. c do 15 i = 1,maxt 15 iwksp(i) = jt(i) + 1 c c ... determine nc, imin. c 20 nc = n do 25 i = 1,maxt nterm = iwksp(i) - 1 if (nterm .ge. nc) go to 25 nc = nterm imin = i 25 continue if (nc .ge. n) go to 70 ndel = jt(imin) ibeg = nc + 1 if (ndel .gt. 1) go to 40 c c ... special case for first minor subdiagonal. c nc1 = n do 30 i = 1,maxt if (i .eq. imin) go to 30 if (iwksp(i) .lt. nc1) nc1 = iwksp(i) 30 continue iwksp(imin) = nc1 + 1 do 35 j = ibeg,nc1 35 rhs(j) = rhs(j) - omega*t(j-1,imin)*rhs(j-1)/d(j-1) go to 20 c c ... far diagonals (do vector computations). c 40 iwksp(imin) = iwksp(imin) + ndel iend = min (ibeg+ndel-1,n) do 45 i = ibeg,iend 45 rhs(i) = rhs(i) - omega*t(i-ndel,imin)*rhs(i-ndel)/d(i-ndel) go to 20 c c ... rowwise algorithm. c 50 do 65 i = 1,n do 55 j = 1,maxt 55 iwksp(j) = min (n,i+jt(j)) term = omega*rhs(i)/d(i) do 60 j = 1,maxt 60 rhs(iwksp(j)) = rhs(iwksp(j)) - t(i,j)*term 65 continue c c ... unew = inv(d)*rhs c 70 do 75 i = 1,n 75 unew(i) = rhs(i)/d(i) return end subroutine sordn (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,omegaa, a irwise,u,rhs,unew,iwksp) implicit double precision (a-h, o-z) c c ... sordn does an sor solve (natural ordering, c nonsymmetric diagonal storage). c c unew = inv(d + w*l)*((1-w)*d*un + w*(rhs - u*un)) c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c maxb number of columns in b array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c b array of active size n by maxb giving the sub- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c u current solution vector c rhs right hand side c unew updated solution vector c iwksp integer workspace of length maxt c c ... specifications for parameters c dimension d(1), t(ndim,1), b(ndim,1), u(1), unew(1), rhs(1) integer jt(1), jb(1), iwksp(1) c c n = nn maxt = maxtt maxb = maxbb omega = omegaa c c ... rhs = (1-w)*d*un + w*(rhs - u*un) c call vsubd (ndim,1,n,n,maxt,t,jt,rhs,u,0) con = 1.0d0 - omega do 10 i = 1,n 10 rhs(i) = con*d(i)*u(i) + omega*rhs(i) c c ... rhs = inv(i+w*l*inv(d))*rhs c c ... select rowwise or diagonal-wise algorithm. c if (irwise .eq. 1) go to 50 c c ... diagonal-wise algorithm. c do 15 i = 1,maxb 15 iwksp(i) = 1 - jb(i) c c ... determine nc, imin. c 20 nc = n do 25 i = 1,maxb nterm = iwksp(i) - 1 if (nterm .ge. nc) go to 25 nc = nterm imin = i 25 continue if (nc .ge. n) go to 70 ndel = -jb(imin) ibeg = nc + 1 if (ndel .gt. 1) go to 40 c c ... special case for first minor subdiagonal. c nc1 = n do 30 i = 1,maxb if (i .eq. imin) go to 30 if (iwksp(i) .lt. nc1) nc1 = iwksp(i) 30 continue iwksp(imin) = nc1 + 1 do 35 j = ibeg,nc1 35 rhs(j) = rhs(j) - omega*b(j,imin)*rhs(j-1)/d(j-1) go to 20 c c ... far diagonals (do vector computations). c 40 iwksp(imin) = iwksp(imin) + ndel iend = min (ibeg+ndel-1,n) do 45 i = ibeg,iend 45 rhs(i) = rhs(i) - omega*b(i,imin)*rhs(i-ndel)/d(i-ndel) go to 20 c c ... rowwise algorithm. c 50 do 65 i = 1,n do 55 j = 1,maxb 55 iwksp(j) = max (1,i+jb(j)) sum = 0.0d0 do 60 j = 1,maxb 60 sum = sum + b(i,j)*rhs(iwksp(j))/d(iwksp(j)) rhs(i) = rhs(i) - omega*sum 65 continue c c ... unew = inv(d)*rhs c 70 do 75 i = 1,n 75 unew(i) = rhs(i)/d(i) return end subroutine sorp (ndim,nn,maxt,maxb,jt,jb,d,t,b,omega,u, a rhs,unew) implicit double precision (a-h, o-z) c c ... sorp does an sor solve c (natural ordering, purdue storage). c c unew = inv((1/w)*d + l)*(((1-w)/w)*d*un + (rhs - u*un)) c c ... parameters -- c c ndim row dimension of t array c n order of system c maxt number of columns in t array c maxb number of columns in b array c jt integer array giving the column numbers of the c corresponding elements in t c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the upper c triangle of the matrix c b array of active size n by maxb giving the lower c triangle of the matrix c omega over-relaxation factor c u current solution vector c rhs right hand side c unew updated solution vector c c ... specifications for parameters c dimension d(1), t(ndim,1), b(ndim,1), u(1), rhs(1), unew(1) integer jt(ndim,1), jb(ndim,1) n = nn c c ... rhs = ((1-w)/w)*d*un + (rhs - u*un) c call vsubp (ndim,ndim,n,maxt,t,jt,rhs,u,unew) con = (1.0d0 - omega)/omega do 10 i = 1,n 10 unew(i) = con*d(i)*u(i) + rhs(i) c c ... unew = inv((1/w)*d + l)*rhs c if (maxb .ge. 1) go to 20 do 15 i = 1,n 15 unew(i) = omega*unew(i)/d(i) return 20 do 30 i = 1,n sum = unew(i) do 25 j = 1,maxb sum = sum - b(i,j)*unew(jb(i,j)) 25 continue unew(i) = omega*sum/d(i) 30 continue return end subroutine sorcp (ndimm,n,jc,d,c,ncol,nc,nt,nb,omega, a u,rhs,unew) implicit double precision (a-h, o-z) c c ... sorcp does an sor solve. c (purdue storage, multicolor) c c unew = inv((1/w)*d + l)*(((1-w)/w)*d*un + (rhs - u*un)) c c ... parameters -- c c ndim row dimension of c,jc arrays c n order of system c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c omega over-relaxation factor c u current solution c rhs right-hand-side c unew updated solution c c ... specifications for parameters c integer jc(ndimm,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimm,1), u(1), rhs(1), unew(1) c ndim = ndimm ncolor = ncol c c ... rhs = ((1-w)/w)*d*un + (rhs - u*un) c ist = 1 do 10 icol = 1,ncolor npt = nc(icol) j2 = nt(icol) call vsubp (ndim,ndim,npt,j2,c(ist,1),jc(ist,1),rhs(ist),u, a unew) ist = ist + npt 10 continue con = (1.0d0 - omega)/omega do 15 i = 1,n 15 unew(i) = con*d(i)*u(i) + rhs(i) c c ... unew = inv((1/w)*d + l)*rhs c ist = 1 do 25 icol = 1,ncolor npt = nc(icol) ied = ist + npt - 1 j1 = nt(icol) + 1 mj = nb(icol) call vsubp (ndim,ndim,npt,mj,c(ist,j1),jc(ist,j1),unew(ist), a unew,rhs) do 20 i = ist,ied 20 unew(i) = omega*unew(i)/d(i) ist = ist + npt 25 continue return end subroutine sordb (ldf,ndim,nsize,kblszz,iblock,lbhb, a dfac,coef,jcoef,nn,omega,u,rhs,unew) implicit double precision (a-h, o-z) c c ... sordb does an sor pass c (symmetric block diagonal format, constant block size) c c unew = inv((1/w)*d + l)*(((1-w)/w)*d*un + (rhs - u*un)) c c ... parameters -- c c ldf row dimension of dfac c ndim row dimension of coef array c nsize size of an individual subsystem within a c diagonal block c iblock integer array of size 3 by lbhb c giving block constants c lbhb column size of iblock c dfac array for diagonal block factorization c coef array for matrix coefficients c jcoef vector for diagonal numbers c n size of system c omega relaxation parameter c u current solution estimate c rhs right-hand-side c unew updated solution estimate c c ... specifications for parameters c integer jcoef(2), iblock(3,1) dimension dfac(ldf,1), coef(ndim,2), u(1), rhs(1), unew(1) c n = nn kblsz = kblszz c c ... rhs = ((1-w)/w)*d*un + (rhs - u*un) c nwdiag = iblock (3,1) nt = nwdiag - 1 maxt = 0 if (lbhb .lt. 3) go to 15 do 10 j = 3,lbhb maxt = maxt + iblock(3,j) 10 continue 15 jbgn = nwdiag + 1 call vsubd (ndim,1,n,n,maxt,coef(1,jbgn),jcoef(jbgn),rhs, a u,0) call bmul (ndim,n,nt,coef,coef(1,2),u,unew) con = (1.0d0 - omega)/omega do 20 i = 1,n 20 unew(i) = con*unew(i) + rhs(i) c c ... unew = inv((1/w)*d + l)*rhs c l = n/kblsz do 50 k = 1,l ist = (k - 1)*kblsz + 1 ied = k*kblsz if (nt .ge. 1) go to 30 do 25 i = ist,ied 25 unew(i) = omega*dfac(i,1)*unew(i) go to 40 30 call bdsol (ldf,kblsz,nsize,nt,0,dfac(ist,1), a unew(ist),unew(ist),0) do 35 i = ist,ied 35 unew(i) = omega*unew(i) 40 if (k .eq. l) go to 50 jjlim = min (lbhb,l-k+2) do 45 jj = 3,jjlim jblk = iblock(1,jj) jst = iblock(2,jj) + nwdiag mjj = iblock(3,jj) inc = jblk*kblsz istf = ist + inc if (istf .gt. n) go to 45 call vsubdt (ndim,1,kblsz,kblsz,mjj,coef(ist,jst), a jcoef(jst),unew(istf),unew(ist),inc) 45 continue 50 continue return end subroutine sordnb (ldf,ndim,nsize,kblszz,iblock,lbhbb, a dfac,coef,jcoef,nn,omega,u,rhs,unew) implicit double precision (a-h, o-z) c c ... sordnb does an sor pass c (nonsymmetric block diagonal format, constant block size) c c unew = inv((1/w)*d + l)*(((1-w)/w)*d*un + (rhs - u*un)) c c ... parameters -- c c ldf row dimension of dfac c ndim row dimension of coef array c nsize size of an individual subsystem within a c diagonal block c iblock integer array of size 3 by lbhb c giving block constants c lbhb column size of iblock c dfac array for diagonal block factorization c coef array for matrix coefficients c jcoef vector for diagonal numbers c n size of system c omega relaxation parameter c u current solution estimate c rhs right-hand-side c unew updated solution estimate c c ... specifications for parameters c integer jcoef(2), iblock(3,2) dimension dfac(ldf,1), coef(ndim,2), u(1), rhs(1), unew(1) c n = nn kblsz = kblszz lbhb = lbhbb c c ... rhs = ((1-w)/w)*d*un + (rhs - u*un) c nt = iblock (3,1) - 1 nb = iblock (3,2) nwdiag = nt + nb + 1 maxt = 0 if (lbhb .lt. 3) go to 15 do 10 j = 3,lbhb ind = iblock(1,j) if (ind .gt. 0) maxt = maxt + iblock(3,j) 10 continue 15 jbgn = nwdiag + 1 call vsubd (ndim,1,n,n,maxt,coef(1,jbgn),jcoef(jbgn),rhs, a u,0) ind = nt + 2 call bmuln (ndim,n,nt,nb,coef,coef(1,2),coef(1,ind),u,unew) con = (1.0d0 - omega)/omega do 20 i = 1,n 20 unew(i) = con*unew(i) + rhs(i) c c ... unew = inv((1/w)*d + l)*rhs c l = n/kblsz do 45 k = 1,l ist = (k - 1)*kblsz + 1 ied = k*kblsz do 25 j = 3,lbhb jcol = k + iblock(1,j) if (jcol .ge. k .or. jcol .le. 0) go to 25 jstb = iblock(2,j) + nwdiag mb = iblock(3,j) inc = (jcol - k)*kblsz istb = ist + inc call vsubd (ndim,1,kblsz,kblsz,mb,coef(ist,jstb), a jcoef(jstb),unew(ist),unew(istb),inc) 25 continue if (nt + nb .ge. 1) go to 35 do 30 i = ist,ied 30 unew(i) = omega*dfac(i,1)*unew(i) go to 45 35 call bdsol (ldf,kblsz,nsize,nt,nb,dfac(ist,1),unew(ist), a unew(ist),1) do 40 i = ist,ied 40 unew(i) = omega*unew(i) 45 continue return end subroutine sordmb (ldf,ndim,nsize,iblock,lbhb,ncol,nc,ipt, a dfac,coef,jcnew,nn,omega,u,rhs,unew) implicit double precision (a-h, o-z) c c ... sordmb does an sor pass c (nonsymmetric block diagonal format, nonconstant block size) c c unew = inv((1/w)*d + l)*(((1-w)/w)*d*un + (rhs - u*un)) c c ... parameters -- c c ldf row dimension of dfac array c ndim row dimension of coef array c nsize size of an individual subsystem within a c diagonal block c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c ncolor number of distinct block sizes c nc integer vector of length ncolor, giving the number c of nodes for each distinct block size. c ipt integer pointer vector of length ncolor+1 c giving the starting locations of new block c rows c dfac array for diagonal block factorization c coef array of matrix coefficients c jcnew integer array of row dimension ncolor giving the c diagonal numbers for each block c n size of system c omega relaxation parameter c u current solution estimate c rhs right-hand-side c unew updated solution estimate c c ... specifications for parameters c integer jcnew(ncol,1), iblock(3,ncol,2), lbhb(1), nc(1), a ipt(1) dimension dfac(ldf,1), coef(ndim,2), u(1), rhs(1), unew(1) c n = nn ncolor = ncol c c ... rhs = ((1-w)/w)*d*un + (rhs - u*un) c ndt = iblock (3,1,1) - 1 ndb = iblock (3,1,2) nwdiag = ndt + ndb + 1 do 15 k = 1,ncolor ist = ipt(k) + 1 jlim = lbhb(k) na = nc(k) do 10 j = 3,jlim jcol = k + iblock(1,k,j) if (jcol .le. k .or. jcol .gt. ncolor) go to 10 jstb = iblock(2,k,j) + nwdiag mb = iblock(3,k,j) inc = ipt(jcol) - ipt(k) nb = nc(jcol) istb = ist + inc call vsubd (ndim,ncolor,na,nb,mb,coef(ist,jstb), a jcnew(k,jstb),rhs(ist),u(istb),inc) 10 continue 15 continue ind = ndt + 2 call bmuln (ndim,n,ndt,ndb,coef,coef(1,2),coef(1,ind),u,unew) con = (1.0d0 - omega)/omega do 20 i = 1,n 20 unew(i) = con*unew(i) + rhs(i) c c ... unew = inv((1/w)*d + l)*rhs c do 45 k = 1,ncolor ist = ipt(k) + 1 jlim = lbhb(k) na = nc(k) ndt = iblock(3,k,1) - 1 ndb = iblock(3,k,2) ied = ist + na - 1 do 25 j = 3,jlim jcol = k + iblock(1,k,j) if (jcol .ge. k .or. jcol .le. 0) go to 25 jstb = iblock(2,k,j) + nwdiag mb = iblock(3,k,j) inc = ipt(jcol) - ipt(k) nb = nc(jcol) istb = ist + inc call vsubd (ndim,ncolor,na,nb,mb,coef(ist,jstb), a jcnew(k,jstb),unew(ist),unew(istb),inc) 25 continue if (ndt + ndb .ge. 1) go to 35 do 30 i = ist,ied 30 unew(i) = omega*dfac(i,1)*unew(i) go to 45 35 call bdsol (ldf,na,nsize,ndt,ndb,dfac(ist,1),unew(ist), a unew(ist),1) do 40 i = ist,ied 40 unew(i) = omega*unew(i) 45 continue return end subroutine srbs (ndim,nn,maxtt,jt,d,t,omega,irwise,iwksp,x) implicit double precision (a-h, o-z) c c ... srbs does an sor back solve (natural ordering, c diagonal storage). c c (i + omega*inv(d)*t)*x = y c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c x on input, x contains y c on output, x is the solution to back-solve c c ... specifications for parameters c dimension x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c c n = nn maxt = maxtt if (maxt .le. 0) return c c ... select rowwise or diagonal-wise algorithm. c if (irwise .eq. 1) go to 60 c c ... diagonal-wise algorithm. c do 20 i = 1,maxt 20 iwksp(i) = n - jt(i) c c ... determine nc, imax. c 25 nc = 1 do 30 i = 1,maxt nterm = iwksp(i) + 1 if (nterm .le. nc) go to 30 nc = nterm imax = i 30 continue if (nc .le. 1) return ndel = jt(imax) iend = nc - 1 if (ndel .gt. 1) go to 50 c c ... special case for first super diagonal. c nc1 = 1 do 40 i = 1,maxt if (i .eq. imax) go to 40 if (iwksp(i) .gt. nc1) nc1 = iwksp(i) 40 continue iwksp(imax) = nc1 - 1 do 45 k = iend,nc1,-1 45 x(k) = x(k) - omega*t(k,imax)*x(k+1)/d(k) go to 25 c c ... far diagonals (do vector computations). c 50 iwksp(imax) = iwksp(imax) - ndel ibeg = max (iend - ndel,0) + 1 do 55 i = ibeg,iend 55 x(i) = x(i) - omega*t(i,imax)*x(i+ndel)/d(i) go to 25 c c ... rowwise algorithm. c 60 do 75 i = n,1,-1 do 65 j = 1,maxt 65 iwksp(j) = min (n,i+jt(j)) sum = 0.0d0 do 70 j = 1,maxt 70 sum = sum + t(i,j)*x(iwksp(j)) x(i) = x(i) - omega*sum/d(i) 75 continue return end subroutine srbst (ndim,nn,maxbb,jb,d,b,omega,irwise,iwksp,x) implicit double precision (a-h, o-z) c c ... srbst does an sor transpose back solve (natural ordering, c diagonal storage). c c (i + omega*inv(d)*(b**t))*x = y c c ... parameters -- c c ndim row dimension of b array c n order of system (= nn) c maxb number of columns in b array c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the matrix c b array of active size n by maxb giving the sub- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxb c x on input, x contains y c on output, x is the solution to back-solve c c ... specifications for parameters c dimension x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) c n = nn maxb = maxbb if (maxb .lt. 1) return c c ... select rowwise or diagonal-wise algorithm. c if (irwise .eq. 1) go to 70 c c ... diagonal-wise algorithm. c do 15 i = 1,maxb 15 iwksp(i) = n + jb(i) c c ... determine nc, imax. c 20 nc = 1 do 25 i = 1,maxb nterm = iwksp(i) + 1 if (nterm .le. nc) go to 25 nc = nterm imax = i 25 continue if (nc .le. 1) return ndel = -jb(imax) iend = nc - 1 if (ndel .gt. 1) go to 50 c c ... special case for first sub diagonal. c nc1 = 1 do 30 i = 1,maxb if (i .eq. imax) go to 30 if (iwksp(i) .gt. nc1) nc1 = iwksp(i) 30 continue iwksp(imax) = nc1 - 1 do 45 k = iend,nc1,-1 45 x(k) = x(k) - omega*b(k+1,imax)*x(k+1)/d(k) go to 20 c c ... far diagonals (do vector computations). c 50 iwksp(imax) = iwksp(imax) - ndel ibeg = max (iend - ndel,0) + 1 do 65 i = ibeg,iend 65 x(i) = x(i) - omega*b(i+ndel,imax)*x(i+ndel)/d(i) go to 20 c c ... rowwise algorithm. c 70 do 85 i = n,2,-1 do 75 j = 1,maxb 75 iwksp(j) = max (1,i+jb(j)) term = omega*x(i) do 80 j = 1,maxb 80 x(iwksp(j)) = x(iwksp(j)) - b(i,j)*term/d(iwksp(j)) 85 continue return end subroutine srfs (ndim,nn,maxbb,jb,d,b,omega,irwise,iwksp,x) implicit double precision (a-h, o-z) c c ... srfs does an sor forward solve (natural ordering, c diagonal storage). c c (i + omega*b*inv(d))*x = y c c ... parameters -- c c ndim row dimension of b array c n order of system (= nn) c maxb number of columns in b array c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the matrix c b array of active size n by maxb giving the sub- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxb c x on input, x contains y c on output, x is the solution to forward-solve c c ... specifications for parameters c dimension x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) c c n = nn maxb = maxbb if (maxb .le. 0) return c c ... select rowwise or diagonal-wise algorithm. c if (irwise .eq. 1) go to 60 c c ... diagonal-wise algorithm. c do 20 i = 1,maxb 20 iwksp(i) = 1 - jb(i) c c ... determine nc, imin. c 25 nc = n do 30 i = 1,maxb nterm = iwksp(i) - 1 if (nterm .ge. nc) go to 30 nc = nterm imin = i 30 continue if (nc .ge. n) return ndel = -jb(imin) ibeg = nc + 1 if (ndel .gt. 1) go to 50 c c ... special case for first minor subdiagonal. c nc1 = n do 40 i = 1,maxb if (i .eq. imin) go to 40 if (iwksp(i) .lt. nc1) nc1 = iwksp(i) 40 continue iwksp(imin) = nc1 + 1 do 45 j = ibeg,nc1 45 x(j) = x(j) - omega*b(j,imin)*x(j-1)/d(j-1) go to 25 c c ... far diagonals (do vector computations). c 50 iwksp(imin) = iwksp(imin) + ndel iend = min (ibeg+ndel-1,n) do 55 i = ibeg,iend 55 x(i) = x(i) - omega*b(i,imin)*x(i-ndel)/d(i-ndel) go to 25 c c ... rowwise algorithm. c 60 do 75 i = 1,n do 65 j = 1,maxb 65 iwksp(j) = max (1,i+jb(j)) sum = 0.0d0 do 70 j = 1,maxb 70 sum = sum + b(i,j)*x(iwksp(j))/d(iwksp(j)) x(i) = x(i) - omega*sum 75 continue return end subroutine srfst (ndim,nn,maxtt,jt,d,t,omega,irwise,iwksp,x) implicit double precision (a-h, o-z) c c ... srfst does an sor transpose forward solve (natural ordering, c diagonal storage). c c (i + omega*(t**t)*inv(d))*x = y c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c x on input, x contains y c on output, x is the solution to forward-solve c c ... specifications for parameters c dimension x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c n = nn maxt = maxtt if (maxt .lt. 1) return c c ... select rowwise or diagonal-wise algorithm. c if (irwise .eq. 1) go to 70 c c ... diagonal-wise algorithm. c do 15 i = 1,maxt 15 iwksp(i) = jt(i) + 1 c c ... determine nc, imin. c 20 nc = n do 25 i = 1,maxt nterm = iwksp(i) - 1 if (nterm .ge. nc) go to 25 nc = nterm imin = i 25 continue if (nc .ge. n) return ndel = jt(imin) ibeg = nc + 1 if (ndel .gt. 1) go to 50 c c ... special case for first minor subdiagonal. c nc1 = n do 30 i = 1,maxt if (i .eq. imin) go to 30 if (iwksp(i) .lt. nc1) nc1 = iwksp(i) 30 continue iwksp(imin) = nc1 + 1 do 45 j = ibeg,nc1 45 x(j) = x(j) - omega*t(j-1,imin)*x(j-1)/d(j-1) go to 20 c c ... far diagonals (do vector computations). c 50 iwksp(imin) = iwksp(imin) + ndel iend = min (ibeg+ndel-1,n) do 65 i = ibeg,iend 65 x(i) = x(i) - omega*t(i-ndel,imin)*x(i-ndel)/d(i-ndel) go to 20 c c ... rowwise algorithm. c 70 do 85 i = 1,n do 75 j = 1,maxt 75 iwksp(j) = min (n,i+jt(j)) term = omega*x(i)/d(i) do 80 j = 1,maxt 80 x(iwksp(j)) = x(iwksp(j)) - t(i,j)*term 85 continue return end subroutine srbsp (ndim,nn,maxt,jt,d,t,omega,x) implicit double precision (a-h, o-z) c c ... srbsp does an sor backward solve (natural ordering, c purdue storage). c ((1/omega)*d + t)*x = y c c ... parameters -- c c ndim row dimension of t array c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the upper c triangle of the matrix c omega relaxation factor c x on input, x contains y c on output, x is the solution to backward-solve c c ... specifications for parameters c dimension x(1), d(1), t(ndim,1) integer jt(ndim,1) c n = nn if (maxt .ge. 1) go to 15 do 10 i = 1,n 10 x(i) = omega*x(i)/d(i) return 15 do 30 i = n,1,-1 sum = x(i) do 25 j = 1,maxt sum = sum - t(i,j)*x(jt(i,j)) 25 continue x(i) = omega*sum/d(i) 30 continue return end subroutine srbstp (ndim,nn,maxb,jb,d,b,omega,x) implicit double precision (a-h, o-z) c c ... srbstp does an sor transpose back solve c (natural ordering, purdue storage). c ((1/omega)*d + (b**t))*x = y c c ... parameters -- c c ndim row dimension of b array c n order of system c maxb number of columns in b array c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the matrix c b array of active size n by maxb giving the lower c triangle of the matrix c omega over-relaxation factor c x on input, x contains y c x on output, x is the solution to back-solve c c ... specifications for parameters c dimension x(1), d(1), b(ndim,1) integer jb(ndim,1) c n = nn if (maxb .ge. 1) go to 15 do 10 i = 1,n 10 x(i) = omega*x(i)/d(i) return 15 do 30 i = n,1,-1 x(i) = omega*x(i)/d(i) term = x(i) do 25 j = 1,maxb x(jb(i,j)) = x(jb(i,j)) - b(i,j)*term 25 continue 30 continue return end subroutine srfsp (ndim,nn,maxb,jb,d,b,omega,x) implicit double precision (a-h, o-z) c c ... srfsp does an sor forward solve (natural ordering, c purdue storage). c ((1/omega)*d + b)*x = y c c ... parameters -- c c ndim row dimension of b array c n order of system c maxb number of columns in b array c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the matrix c b array of active size n by maxb giving the lower c triangle of the matrix c omega relaxation factor c x on input, x contains y c on output, x is the solution to forward-solve c c ... specifications for parameters c dimension x(1), d(1), b(ndim,1) integer jb(ndim,1) c n = nn if (maxb .ge. 1) go to 15 do 10 i = 1,n 10 x(i) = omega*x(i)/d(i) return 15 do 30 i = 1,n sum = x(i) do 25 j = 1,maxb sum = sum - b(i,j)*x(jb(i,j)) 25 continue x(i) = omega*sum/d(i) 30 continue return end subroutine srfstp (ndim,n,maxt,jt,d,t,omega,x) implicit double precision (a-h, o-z) c c ... srfstp does an sor transpose forward solve c (natural ordering, purdue storage). c ((1/omega)*d + (t**t))*x = y c c ... parameters -- c c ndim row dimension of t array c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the upper c triangle of the matrix c omega over-relaxation factor c x on input, x contains y c on output, x is the solution to forward-solve c c ... specifications for parameters c dimension x(1), d(1), t(ndim,1) integer jt(ndim,1) c if (maxt .ge. 1) go to 15 do 10 i = 1,n 10 x(i) = omega*x(i)/d(i) return 15 do 30 i = 1,n x(i) = omega*x(i)/d(i) term = x(i) do 25 j = 1,maxt x(jt(i,j)) = x(jt(i,j)) - t(i,j)*term 25 continue 30 continue return end subroutine srs (ndim,nn,maxtt,jt,d,t,omega,irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srs does an ssor solution (natural ordering, c symmetric diagonal storage). c c con*(i + w*(t**t)*inv(d))*d*(i + w*inv(d)*t)*x = y c con = 1/(w*(2-w)) and w = omega c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c c n = nn maxt = maxtt fac = omega*(2.0d0 - omega) do 10 i = 1,n 10 x(i) = y(i) call srfst (ndim,n,maxt,jt,d,t,omega,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = fac*x(i)/d(i) call srbs (ndim,n,maxt,jt,d,t,omega,irwise,iwksp,x) return end subroutine srs1 (ndim,nn,maxtt,jt,d,t,omega,irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srs1 does an ssor forward solve (natural ordering, c symmetric diagonal storage). c c con*(i + w*(t**t)*inv(d))*d*x = y c con = 1/(w*(2-w)) and w = omega c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c c n = nn maxt = maxtt fac = omega*(2.0d0 - omega) do 10 i = 1,n 10 x(i) = y(i) call srfst (ndim,n,maxt,jt,d,t,omega,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = fac*x(i)/d(i) return end subroutine srs2 (ndim,nn,maxtt,jt,d,t,omega,irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srs2 does an ssor back solve (natural ordering, c symmetric diagonal storage). c c (i + w*inv(d)*t)*x = y c w = omega c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c c n = nn maxt = maxtt do 10 i = 1,n 10 x(i) = y(i) call srbs (ndim,n,maxt,jt,d,t,omega,irwise,iwksp,x) return end subroutine srs3 (ndim,nn,maxtt,jt,d,t,omega,irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srs3 does an ssor transpose forward solve (natural ordering, c symmetric diagonal storage). c c con*d*(i + w*inv(d)*t)*x = y c con = 1/(w*(2-w)) and w = omega c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c c n = nn maxt = maxtt fac = omega*(2.0d0 - omega) do 10 i = 1,n 10 x(i) = fac*y(i)/d(i) call srbs (ndim,n,maxt,jt,d,t,omega,irwise,iwksp,x) return end subroutine srs4 (ndim,nn,maxtt,jt,d,t,omega,irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srs4 does an ssor transpose back solve (natural ordering, c symmetric diagonal storage). c c (i + w*(t**t)*inv(d))*x = y c w = omega c c ... parameters -- c c ndim row dimension of t array c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c c n = nn maxt = maxtt do 10 i = 1,n 10 x(i) = y(i) call srfst (ndim,n,maxt,jt,d,t,omega,irwise,iwksp,x) return end subroutine srsn (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,omega, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srsn does an ssor solution (natural ordering, c nonsymmetric diagonal storage). c c con*(i + w*b*inv(d))*d*(i + w*inv(d)*t)*x = y c where con = 1/(w*(2-w)) and w = omega c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxt number of columns in t array c maxb number of columns in b array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c b array of active size n by maxb giving the sub- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1), b(ndim,1) integer jt(1), jb(1), iwksp(1) c c n = nn maxt = maxtt maxb = maxbb fac = omega*(2.0d0 - omega) do 10 i = 1,n 10 x(i) = y(i) call srfs (ndim,n,maxb,jb,d,b,omega,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = fac*x(i)/d(i) call srbs (ndim,n,maxt,jt,d,t,omega,irwise,iwksp,x) return end subroutine srsnt (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,omega, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srsnt does a transpose ssor solution (natural ordering, c nonsymmetric diagonal storage). c c con*(i + w*(t**t)*inv(d))*d*(i + w*inv(d)*(b**t))*x = y c con = 1/(w*(2-w)) and w = omega c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxt number of columns in t array c maxb number of columns in b array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c b array of active size n by maxb giving the sub- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1), b(ndim,1) integer jt(1), jb(1), iwksp(1) c c n = nn maxt = maxtt maxb = maxbb fac = omega*(2.0d0 - omega) do 10 i = 1,n 10 x(i) = y(i) call srfst (ndim,n,maxt,jt,d,t,omega,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = fac*x(i)/d(i) call srbst (ndim,n,maxb,jb,d,b,omega,irwise,iwksp,x) return end subroutine srsn1 (ndim,n,maxb,jb,d,b,omega, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srsn1 does an ssor forward pass (natural ordering, c nonsymmetric diagonal storage). c c con*(i + w*b*inv(d))*d*(i + w*inv(d)*t)*x = y c where con = 1/(w*(2-w)) and w = omega c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxb number of columns in b array c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the matrix c b array of active size n by maxb giving the sub- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) c c fac = omega*(2.0d0 - omega) do 10 i = 1,n 10 x(i) = y(i) call srfs (ndim,n,maxb,jb,d,b,omega,irwise,iwksp,x) do 15 i = 1,n 15 x(i) = fac*x(i)/d(i) return end subroutine srsn2 (ndim,n,maxt,jt,d,t,omega, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srsn2 does an ssor backward pass (natural ordering, c nonsymmetric diagonal storage). c c con*(i + w*b*inv(d))*d*(i + w*inv(d)*t)*x = y c where con = 1/(w*(2-w)) and w = omega c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c do 10 i = 1,n 10 x(i) = y(i) call srbs (ndim,n,maxt,jt,d,t,omega,irwise,iwksp,x) return end subroutine srsn3 (ndim,n,maxb,jb,d,b,omega, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srsn3 does a transpose ssor back pass (natural ordering, c nonsymmetric diagonal storage). c c con*(i + w*(t**t)*inv(d))*d*(i + w*inv(d)*(b**t))*x = y c con = 1/(w*(2-w)) and w = omega c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxb number of columns in b array c jb integer vector of length maxb giving the diagonal c indices of the corresponding columns in b c d vector of length n giving the diagonal elements c of the matrix c b array of active size n by maxb giving the sub- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) c c fac = omega*(2.0d0 - omega) do 15 i = 1,n 15 x(i) = fac*y(i)/d(i) call srbst (ndim,n,maxb,jb,d,b,omega,irwise,iwksp,x) return end subroutine srsn4 (ndim,n,maxt,jt,d,t,omega, a irwise,iwksp,y,x) implicit double precision (a-h, o-z) c c ... srsn4 does a transpose ssor forward pass (natural ordering, c nonsymmetric diagonal storage). c c con*(i + w*(t**t)*inv(d))*d*(i + w*inv(d)*(b**t))*x = y c con = 1/(w*(2-w)) and w = omega c c ... parameters -- c c ndim row dimension of t and b arrays c n order of system (= nn) c maxt number of columns in t array c jt integer vector of length maxt giving the diagonal c indices of the corresponding columns in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the super- c diagonals of the matrix c omega over-relaxation factor c irwise rowwise algorithm switch c = 0 use diagonal algorithm c = 1 use row-wise algorithm c iwksp integer workspace of length maxt c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) c do 10 i = 1,n 10 x(i) = y(i) call srfst (ndim,n,maxt,jt,d,t,omega,irwise,iwksp,x) return end subroutine srsp (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,omega,y,x) implicit double precision (a-h, o-z) c c ... srsp does an ssor solution (natural ordering, c purdue storage). c con*((1/w)*d + b)*inv(d)*((1/w)*d + t)*x = y c where con = w/(2-w) and w = omega c c ... parameters -- c c ndim row dimension of t,b arrays c n order of system c maxt number of columns in t array c maxb number of columns in b array c jt integer array giving the column numbers of the c corresponding elements in t c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the upper c triangle of the matrix c b array of active size n by maxb giving the lower c triangle of the matrix c omega relaxation factor c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1), b(ndim,1) integer jt(ndim,1), jb(ndim,1) c c n = nn maxt = maxtt maxb = maxbb fac = (2.0d0 - omega)/omega do 10 i = 1,n 10 x(i) = y(i) call srfsp (ndim,n,maxb,jb,d,b,omega,x) do 15 i = 1,n 15 x(i) = fac*d(i)*x(i) call srbsp (ndim,n,maxt,jt,d,t,omega,x) return end subroutine srsp1 (ndim,n,maxb,jb,d,b,omega,y,x) implicit double precision (a-h, o-z) c c ... srsp1 does an ssor forward solve (natural ordering, c purdue storage). c c ... parameters -- c c ndim row dimension of t,b arrays c n order of system c maxb number of columns in b array c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the matrix c b array of active size n by maxb giving the lower c triangle of the matrix c omega relaxation factor c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), b(ndim,1) integer jb(ndim,1) c c fac = (2.0d0 - omega)/omega do 10 i = 1,n 10 x(i) = y(i) call srfsp (ndim,n,maxb,jb,d,b,omega,x) do 15 i = 1,n 15 x(i) = fac*d(i)*x(i) return end subroutine srsp2 (ndim,n,maxt,jt,d,t,omega,y,x) implicit double precision (a-h, o-z) c c ... srsp2 does an ssor back solve (natural ordering, c purdue storage). c c ... parameters -- c c ndim row dimension of t,b arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the upper c triangle of the matrix c omega relaxation factor c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(ndim,1) c do 10 i = 1,n 10 x(i) = y(i) call srbsp (ndim,n,maxt,jt,d,t,omega,x) return end subroutine srsp3 (ndim,n,maxb,jb,d,b,omega,y,x) implicit double precision (a-h, o-z) c c ... srsp3 does an ssor transpose back solve (natural ordering, c purdue storage). c c ... parameters -- c c ndim row dimension of t,b arrays c n order of system c maxb number of columns in b array c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the matrix c b array of active size n by maxb giving the lower c triangle of the matrix c omega relaxation factor c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), b(ndim,1) integer jb(ndim,1) c c fac = (2.0d0 - omega)/omega do 15 i = 1,n 15 x(i) = fac*d(i)*y(i) call srbstp (ndim,n,maxb,jb,d,b,omega,x) return end subroutine srsp4 (ndim,n,maxt,jt,d,t,omega,y,x) implicit double precision (a-h, o-z) c c ... srsp4 does an ssor transpose forward solve (natural ordering, c purdue storage). c c ... parameters -- c c ndim row dimension of t,b arrays c n order of system c maxt number of columns in t array c jt integer array giving the column numbers of the c corresponding elements in t c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the upper c triangle of the matrix c omega relaxation factor c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1) integer jt(ndim,1) c do 10 i = 1,n 10 x(i) = y(i) call srfstp (ndim,n,maxt,jt,d,t,omega,x) return end subroutine srsntp (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,omega,y,x) implicit double precision (a-h, o-z) c c ... srsntp does an ssor transpose solution (natural ordering, c purdue storage). c con*((1/w)*d + (t**t))*inv(d)*((1/w)*d + (b**t))*x = y c where con = w/(2-w) and w = omega c c ... parameters -- c c ndim row dimension of t,b arrays c n order of system c maxt number of columns in t array c maxb number of columns in b array c jt integer array giving the column numbers of the c corresponding elements in t c jb integer array giving the column numbers of the c corresponding elements in b c d vector of length n giving the diagonal elements c of the matrix c t array of active size n by maxt giving the upper c triangle of the matrix c b array of active size n by maxb giving the lower c triangle of the matrix c omega relaxation factor c y right-hand-side vector c x on output, x is the solution c c ... specifications for parameters c dimension y(1), x(1), d(1), t(ndim,1), b(ndim,1) integer jt(ndim,1), jb(ndim,1) c c n = nn maxt = maxtt maxb = maxbb fac = (2.0d0 - omega)/omega do 10 i = 1,n 10 x(i) = y(i) call srfstp (ndim,n,maxt,jt,d,t,omega,x) do 15 i = 1,n 15 x(i) = fac*d(i)*x(i) call srbstp (ndim,n,maxb,jb,d,b,omega,x) return end subroutine ssorad (ssorcp,coef,jcoef,wfac,jwfac,n,p,z,r,icode) implicit double precision (a-h, o-z) c c ... ssorad does the ssor adaptive process. c c ... parameters -- c c n order of system c p,z,r vectors from acceleration algorithm c icode key for restarting iteration c = 0 omega unchanged (no restart) c = 1 new omega (restart needed) c c ... specifications for parameters c dimension p(1), z(1), r(1), coef(1), jcoef(2), wfac(1), a jwfac(1) external ssorcp c c *** begin -- package common c common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, a iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d logical halt, maxadp, minadp, maxadd, minadd common / itcom2 / halt, maxadp, minadp, maxadd, minadd common / itcom3 / alpha, beta, zeta, emax, emin, pap, b alphao, gamma, sigma, rr, rho, dkq, dkm1, b ff, rqmin, rqmax, stptst, udnm, ubarnm, b bnorm, bnorm1 logical omgadp common / itcom5 / omega, alphab, betab, fff, specr, omgadp c c *** end -- package common c c c------------------------------------------------------------------ c parameter estimation formulas c------------------------------------------------------------------ c alp (w,beta,s) = ((1.0d0 + beta*w*w)*s - w*(2.0d0 - w)) / a (w*(2.0d0 - w - s)) c omg (alpha,beta) = 2.0d0/(1.0d0 + sqrt (1.0d0 + 2.0d0*alpha + a 4.0d0*beta)) c se (w,alpha,beta) = ((1.0d0 + alpha)*w*(2.0d0 - w)) / a (1.0d0 + alpha*w + beta*w*w) c cond (w,alpha,beta) = 1.0d0/se(w,alpha,beta) c rc (w,alpha,beta) = dlog ((sqrt (cond(w,alpha,beta))+1.0d0) / a (sqrt (cond(w,alpha,beta))-1.0d0)) c c------------------------------------------------------------------ c icode = 0 if (is .ge. 6 .and. (.not. minadp)) go to 5 tmo = 2.0d0 - omega if (emin .lt. tmo) alphab = min (alphab, alp(omega,betab,emin)) 5 if ((.not. omgadp) .or. (.not. minadp) .or. (is .le. 5)) return omegab = max (1.0d0, omg (alphab,betab)) if (rc(omega,alphab,betab) .gt. fff*rc(omegab,alphab,betab)) a return if (iacel .eq. 2) pap = vdot (n,p,z) call omgchg (ssorcp,coef,jcoef,wfac,jwfac,n,p,r) omega = max (1.0d0,omg(alphab,betab)) icode = 1 if (level .ge. 2) write (nout,10) in, alphab, betab, omega 10 format (/1x,15x,36hparameters were changed at iteration,i7/ a 1x,20x,19halphab ,f15.9/ a 1x,20x,19hbetab ,f15.9/ a 1x,20x,19homega ,f15.9/) return end subroutine ssord (ndim,maxt,jt,d,t,nn,p,r,pdp,pldup) implicit double precision (a-h, o-z) c c ... ssord computes pdp = (p,d*p) and c pldup = (p,l*inv(d)*u*p) c c for symmetric diagonal storage format. c c ... parameters -- c c ndim row dimension of coef array in defining routine c maxt number of diagonals in t c jt diagonal numbers for upper triangular part c d diagonal c t upper triangular diagonals c n order of system c p vector from acceleration algorithm c r workspace vector from acceleration algorithm c pdp (p,d*p) c pldup (p,l*d*u*p) c c ... specifications for parameters c integer jt(1) dimension d(1), t(ndim,1), p(1), r(1) c c ... compute pdp = (p,d*p). c n = nn sum = 0.0d0 do 10 i = 1,n 10 sum = sum + p(i)*d(i)*p(i) pdp = sum c c ... compute pldup = (p,l*inv(d)*u*p) = (u*p,inv(d)*u*p) c pldup = 0.0d0 if (maxt .le. 0) return do 15 i = 1,n 15 r(i) = 0.0d0 call vaddd (ndim,1,n,n,maxt,t,jt,r,p,0) sum = 0.0d0 do 20 i = 1,n 20 sum = sum + r(i)*r(i)/d(i) pldup = sum return end subroutine ssordn (ndim,maxt,maxb,jt,jb,d,t,b,nn,p,r, a wksp,pdp,pldup) implicit double precision (a-h, o-z) c c ... ssordn computes pdp = (p,d*p) and c pldup = (p,l*inv(d)*u*p) c c for nonsymmetric diagonal storage format. c c ... parameters -- c c ndim row dimension of coef array in defining routine c maxt number of diagonals in t c maxb number of diagonals in b c jt diagonal numbers for upper triangular part c jb diagonal numbers for lower triangular part c d diagonal c t upper triangular diagonals c b lower triangular diagonals c n order of system c p vector from acceleration algorithm c r workspace vector from acceleration algorithm c wksp workspace vector of length n c pdp (p,d*p) c pldup (p,l*d*u*p) c c ... specifications for parameters c integer jt(1), jb(1) dimension d(1), t(ndim,1), b(ndim,1), p(1), r(1), wksp(1) c c ... compute pdp = (p,d*p). c n = nn sum = 0.0d0 do 10 i = 1,n 10 sum = sum + p(i)*d(i)*p(i) pdp = sum c c ... compute pldup = (p,l*inv(d)*u*p) c pldup = 0.0d0 if (maxt .le. 0 .or. maxb .le. 0) return do 15 i = 1,n 15 r(i) = 0.0d0 call vaddd (ndim,1,n,n,maxt,t,jt,r,p,0) do 20 i = 1,n 20 r(i) = r(i)/d(i) do 25 i = 1,n 25 wksp(i) = 0.0d0 call vaddd (ndim,1,n,n,maxb,b,jb,wksp,r,0) sum = 0.0d0 do 30 i = 1,n 30 sum = sum + p(i)*wksp(i) pldup = sum return end subroutine ssorp (ndim,maxt,jt,d,t,nn,p,r,wksp,pdp,pldup) implicit double precision (a-h, o-z) c c ... ssorp computes pdp = (p,d*p) and c pldup = (p,l*inv(d)*u*p) c c for symmetric purdue storage format. c c ... parameters -- c c ndim row dimension of coef array in defining routine c maxt number of columns in t c jt column numbers for upper triangular part c d diagonal c t upper triangular part of a c n order of system c p vector from acceleration algorithm c r workspace vector from acceleration algorithm c wksp workspace vector of length n c (keygs = 1 only) c pdp (p,d*p) c pldup (p,l*d*u*p) c c ... specifications for parameters c integer jt(ndim,1) dimension d(1), t(ndim,1), p(1), r(1), wksp(1) c c ... compute pdp = (p,d*p). c n = nn sum = 0.0d0 do 10 i = 1,n 10 sum = sum + p(i)*d(i)*p(i) pdp = sum c c ... compute pldup = (p,l*inv(d)*u*p) = (u*p,inv(d)*u*p) c pldup = 0.0d0 if (maxt .le. 0) return do 15 i = 1,n 15 r(i) = 0.0d0 call vaddp (ndim,ndim,n,maxt,t,jt,r,p,wksp) sum = 0.0d0 do 20 i = 1,n 20 sum = sum + r(i)*r(i)/d(i) pldup = sum return end subroutine ssorpn (ndimm,maxt,maxb,jt,jb,d,t,b,nn,p,r, a wksp,pdp,pldup) implicit double precision (a-h, o-z) c c ... ssorpn computes pdp = (p,d*p) and c pldup = (p,l*inv(d)*u*p) c c for nonsymmetric purdue storage format. c c ... parameters -- c c ndim row dimension of coef array in defining routine c maxt number of columns in t c maxb number of columns in b c jt column numbers for upper triangular part c jb column numbers for lower triangular part c d diagonal c t upper triangular part c b lower triangular part c n order of system c p vector from acceleration algorithm c r workspace vector from acceleration algorithm c wksp workspace vector of length n c 2*n if keygs = 1 c pdp (p,d*p) c pldup (p,l*d*u*p) c c ... specifications for parameters c integer jt(ndimm,1), jb(ndimm,1) dimension d(1), t(ndimm,1), b(ndimm,1), p(1), r(1), wksp(1) c c ... compute pdp = (p,d*p). c n = nn ndim = ndimm sum = 0.0d0 do 10 i = 1,n 10 sum = sum + p(i)*d(i)*p(i) pdp = sum c c ... compute pldup = (p,l*inv(d)*u*p) c pldup = 0.0d0 if (maxt .le. 0 .or. maxb .le. 0) return do 15 i = 1,n 15 r(i) = 0.0d0 call vaddp (ndim,ndim,n,maxt,t,jt,r,p,wksp) do 20 i = 1,n 20 r(i) = r(i)/d(i) do 25 i = 1,n 25 wksp(i) = 0.0d0 np1 = n + 1 call vaddp (ndim,ndim,n,maxb,b,jb,wksp,r,wksp(np1)) sum = 0.0d0 do 30 i = 1,n 30 sum = sum + p(i)*wksp(i) pldup = sum return end subroutine ssrcd (ldf,ndim,maxnz,nsize,iblock,dfac,coef, a jcoef,nn,p,r,wksp,pdp,pldup) implicit double precision (a-h, o-z) c c ... ssrcd computes pdp = (p,d*p) and c pldup = (p,l*inv(d)*u*p) c c for symmetric block diagonal storage format. c c ... parameters -- c c ldf row dimension of dfac c ndim row dimension of coef array c maxnz number of diagonals stored in coef c nsize size of an individual subsystem within a c diagonal block c iblock integer array of size 3 by lbhb c giving block constants c dfac array for diagonal block factorization c coef array for matrix coefficients c jcoef vector for diagonal numbers c n size of system c p vector from acceleration algorithm c r workspace vector from acceleration algorithm c wksp workspace vector of length n c pdp (p,d*p) c pldup (p,l*d*u*p) c c ... specifications for parameters c integer jcoef(2), iblock(3,1) dimension dfac(ldf,1), coef(ndim,2), p(1), r(1), wksp(1) c c ... compute pdp = (p,d*p). c n = nn nwdiag = iblock (3,1) nt = nwdiag - 1 call bmul (ndim,n,nt,coef,coef(1,2),p,r) sum = 0.0d0 do 10 i = 1,n 10 sum = sum + p(i)*r(i) pdp = sum c c ... compute pldup = (p,l*inv(d)*u*p) = (u*p,inv(d)*u*p) c do 15 i = 1,n 15 r(i) = 0.0d0 jbgn = nwdiag + 1 mdiag = maxnz - nwdiag call vaddd (ndim,1,n,n,mdiag,coef(1,jbgn),jcoef(jbgn), a r,p,0) call bdsol (ldf,n,nsize,nt,0,dfac,r,wksp,0) sum = 0.0d0 do 25 i = 1,n 25 sum = sum + r(i)*wksp(i) pldup = sum return end subroutine ssrcdm (ldf,ndim,lbhb,nsize,ncol,nci,ipt, a iblock,dfac,coef,jcnew,nn,p,r,wksp, a pdp,pldup) implicit double precision (a-h, o-z) c c ... ssrcdm computes pdp = (p,d*p) and c pldup = (p,l*inv(d)*u*p) c c for nonsymmetric block diagonal storage format. c (nonconstant block size) c c ... parameters -- c c ldf row dimension of dfac array c ndim row dimension of coef array c lbhb integer vector of size ncolor giving the number c of diagonal blocks for each distinct block size. c nsize size of an individual subsystem within a c diagonal block c ncolor number of distinct block sizes c nci integer vector of length ncolor, giving the number c of nodes for each distinct block size. c ipt integer pointer vector of length ncolor+1 c giving the starting locations of new block c rows c iblock integer array of size 3 by ncolor by max(lbhb(i)) c giving block constants c dfac array for diagonal block factorization c coef array of matrix coefficients c jcnew integer array of row dimension ncolor giving the c diagonal numbers for each block c n size of system c p vector from acceleration algorithm c r workspace vector from acceleration algorithm c wksp workspace vector of length n c pdp (p,d*p) c pldup (p,l*d*u*p) c c ... specifications for parameters c integer jcnew(ncol,1), iblock(3,ncol,2), lbhb(1), a nci(1), ipt(1) dimension dfac(ldf,1), coef(ndim,2), p(1), r(1), wksp(1) c c ... define constants ndt, ndb. c n = nn ncolor = ncol ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) nwdiag = ndt + ndb + 1 c c ... compute pdp = (p,d*p). c ind = ndt + 2 call bmuln (ndim,n,ndt,ndb,coef,coef(1,2),coef(1,ind),p,r) sum = 0.0d0 do 10 i = 1,n 10 sum = sum + p(i)*r(i) pdp = sum c c ... compute pldup = (p,l*inv(d)*u*p) c do 15 i = 1,n r(i) = 0.0d0 wksp(i) = 0.0d0 15 continue do 25 k = 1,ncolor ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) do 20 j = 3,jlim jcol = k + iblock(1,k,j) if (jcol .le. k) go to 20 jstb = iblock(2,k,j) + nwdiag mb = iblock(3,k,j) inc = ipt(jcol) - ipt(k) nb = nci(jcol) istb = ist + inc call vaddd (ndim,ncolor,na,nb,mb,coef(ist,jstb), a jcnew(k,jstb),r(ist),p(istb),inc) 20 continue 25 continue call bdsol (ldf,n,nsize,ndt,ndb,dfac,r,r,1) do 35 k = 1,ncolor ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) do 30 j = 3,jlim jcol = k + iblock(1,k,j) if (jcol .ge. k) go to 30 jstb = iblock(2,k,j) + nwdiag mb = iblock(3,k,j) inc = ipt(jcol) - ipt(k) nb = nci(jcol) istb = ist + inc call vaddd (ndim,ncolor,na,nb,mb,coef(ist,jstb), a jcnew(k,jstb),wksp(ist),r(istb),inc) 30 continue 35 continue sum = 0.0d0 do 40 i = 1,n 40 sum = sum + p(i)*wksp(i) pldup = sum return end subroutine ssrcdn (ldf,ndim,lbhb,nsize,iblock,dfac,coef, a jcoef,nn,p,r,wksp,pdp,pldup) implicit double precision (a-h, o-z) c c ... ssrcdn computes pdp = (p,d*p) and c pldup = (p,l*inv(d)*u*p) c c for nonsymmetric block diagonal storage format. c (constant block size) c c ... parameters -- c c ldf row dimension of dfac c ndim row dimension of coef array c lbhb number of blocks per block row c nsize size of an individual subsystem within a c diagonal block c iblock integer array of size 3 by lbhb c giving block constants c dfac array for diagonal block factorization c coef array for matrix coefficients c jcoef vector for diagonal numbers c n size of system c p vector from acceleration algorithm c r workspace vector from acceleration algorithm c wksp workspace vector of length n c pdp (p,d*p) c pldup (p,l*d*u*p) c c ... specifications for parameters c integer jcoef(2), iblock(3,2) dimension dfac(ldf,1), coef(ndim,2), p(1), r(1), wksp(1) c c ... compute nt, nb, maxt, maxb c n = nn nt = iblock(3,1) - 1 nb = iblock(3,2) maxt = 0 maxb = 0 if (lbhb .lt. 3) go to 15 do 10 j = 3,lbhb ind = iblock(1,j) if (ind .gt. 0) maxt = maxt + iblock(3,j) if (ind .lt. 0) maxb = maxb + iblock(3,j) 10 continue c c ... compute pdp = (p,d*p). c 15 ind = nt + 2 call bmuln (ndim,n,nt,nb,coef,coef(1,2),coef(1,ind),p,r) sum = 0.0d0 do 20 i = 1,n 20 sum = sum + p(i)*r(i) pdp = sum c c ... compute pldup = (p,l*inv(d)*u*p) c do 25 i = 1,n wksp(i) = 0.0d0 r(i) = 0.0d0 25 continue ind = nt + nb + 2 indd = ind + maxt call vaddd (ndim,1,n,n,maxt,coef(1,ind),jcoef(ind), a r,p,0) call bdsol (ldf,n,nsize,nt,nb,dfac,r,r,1) call vaddd (ndim,1,n,n,maxb,coef(1,indd),jcoef(indd), a wksp,r,0) sum = 0.0d0 do 30 i = 1,n 30 sum = sum + p(i)*wksp(i) pldup = sum return end subroutine srbscp (ndim,n,jc,d,c,ncolor,nc,nt,omega, a wksp,x) implicit double precision (a-h, o-z) c c ... srbscp does a back sor solve. c (purdue storage, multicolor) c c ((1/w)*d + t)*x = y c c ... parameters -- c c ndim row dimension of c,jc arrays c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c omega over-relaxation factor c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c x on input, x contains y c on output, x is the solution to back-solve c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1) dimension d(1), c(ndim,1), x(1), wksp(1) c ied = n do 20 icol = ncolor,1,-1 npt = nc(icol) ist = ied - npt + 1 j2 = nt(icol) call vsubp (ndim,ndim,npt,j2,c(ist,1),jc(ist,1),x(ist),x,wksp) do 15 i = ist,ied 15 x(i) = omega*x(i)/d(i) ied = ied - npt 20 continue return end subroutine srbsct (ndim,n,jc,d,c,ncolor,nc,nt,nb,omega, a wksp,x) implicit double precision (a-h, o-z) c c ... srbsct does a transpose back sor solve. c (purdue storage, multicolor) c c ((1/w)*d + (b**t))*x = y c c ... parameters -- c c ndim row dimension of c,jc arrays c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c omega over-relaxation factor c wksp workspace vector of length max(nc(i)) c x on input, x contains y c on output, x is the solution to back-solve c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1), nb(1) dimension d(1), c(ndim,1), x(1), wksp(1) c ied = n do 20 icol = ncolor,1,-1 npt = nc(icol) ist = ied - npt + 1 do 15 i = ist,ied 15 x(i) = omega*x(i)/d(i) j1 = nt(icol) + 1 mj = nb(icol) call vsubpt (ndim,ndim,npt,mj,c(ist,j1),jc(ist,j1),x,x(ist), a wksp) ied = ied - npt 20 continue return end subroutine srfscp (ndim,jc,d,c,ncolor,nc,nt,nb,omega, a wksp,x) implicit double precision (a-h, o-z) c c ... srfscp does a forward sor solve. c (purdue storage, multicolor) c c ((1/w)*d + b)*x = y c c ... parameters -- c c ndim row dimension of c,jc arrays c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c omega over-relaxation factor c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c x on input, x contains y c on output, x is the solution to the forward solve c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1), nb(1) dimension d(1), c(ndim,1), x(1), wksp(1) c ist = 1 do 20 icol = 1,ncolor npt = nc(icol) ied = ist + npt - 1 j1 = nt(icol) + 1 mj = nb(icol) call vsubp (ndim,ndim,npt,mj,c(ist,j1),jc(ist,j1),x(ist),x, a wksp) do 15 i = ist,ied 15 x(i) = omega*x(i)/d(i) ist = ist + npt 20 continue return end subroutine srfsct (ndim,jc,d,c,ncolor,nc,nt,omega, a wksp,x) implicit double precision (a-h, o-z) c c ... srfsct does a transpose forward sor solve. c (purdue storage, multicolor) c c ((1/w)*d + (t**t))*x = y c c ... parameters -- c c ndim row dimension of c,jc arrays c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c omega over-relaxation factor c wksp workspace vector of length max(nc(i)) c x on input, x contains y c on output, x is the solution to the forward solve c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1) dimension d(1), c(ndim,1), x(1), wksp(1) c ist = 1 do 20 icol = 1,ncolor npt = nc(icol) ied = ist + npt - 1 do 15 i = ist,ied 15 x(i) = omega*x(i)/d(i) j2 = nt(icol) call vsubpt (ndim,ndim,npt,j2,c(ist,1),jc(ist,1),x,x(ist), a wksp) ist = ist + npt 20 continue return end subroutine srscp (ndim,nn,jc,d,c,ncolor,nc,nt,nb,omega, a wksp,y,x) implicit double precision (a-h, o-z) c c ... srscp does an ssor solve. c (purdue storage, multicolor) c con*((1/w)*d + b)*inv(d)*((1/w)*d + t)*x = y c where con = w/(2-w) and w = omega c c ... parameters -- c c ndim row dimension of c,jc arrays c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c omega over-relaxation factor c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1), nb(1) dimension d(1), c(ndim,1), x(1), y(1), wksp(1) c c n = nn fac = (2.0d0 - omega)/omega c do 10 i = 1,n 10 x(i) = y(i) call srfscp (ndim,jc,d,c,ncolor,nc,nt,nb,omega,wksp,x) do 15 i = 1,n 15 x(i) = fac*d(i)*x(i) call srbscp (ndim,n,jc,d,c,ncolor,nc,nt,omega,wksp,x) return end subroutine srscpt (ndim,nn,jc,d,c,ncolor,nc,nt,nb,omega, a wksp,y,x) implicit double precision (a-h, o-z) c c ... srscpt does an transpose ssor solve. c (purdue storage, multicolor) c c ... parameters -- c c ndim row dimension of c,jc arrays c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c omega over-relaxation factor c wksp workspace vector of length max(nc(i)) c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1), nb(1) dimension d(1), c(ndim,1), x(1), y(1), wksp(1) c c n = nn fac = (2.0d0 - omega)/omega c do 10 i = 1,n 10 x(i) = y(i) call srfsct (ndim,jc,d,c,ncolor,nc,nt,omega,wksp,x) do 15 i = 1,n 15 x(i) = fac*d(i)*x(i) call srbsct (ndim,n,jc,d,c,ncolor,nc,nt,nb,omega,wksp,x) return end subroutine ssrcp (ndim,jc,d,c,nn,ncolor,nc,nt,p,r,wksp, a pdp,pldup) implicit double precision (a-h, o-z) c c ... ssrcp computes pdp = (p,d*p) and c pldup = (p,l*inv(d)*u*p) c c for symmetric multicolor purdue storage format. c c ... parameters -- c c ndim row dimension of c,jc arrays c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c n order of system c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c p vector from acceleration algorithm c r workspace vector from acceleration algorithm c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c pdp (p,d*p) c pldup (p,l*d*u*p) c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1) dimension d(1), c(ndim,1), p(1), r(1), wksp(1) c c ... compute pdp = (p,d*p). c n = nn sum = 0.0d0 do 10 i = 1,n 10 sum = sum + p(i)*d(i)*p(i) pdp = sum c c ... compute pldup = (p,l*inv(d)*u*p) = (u*p,inv(d)*u*p) c do 15 i = 1,n 15 r(i) = 0.0d0 ist = 1 do 20 icol = 1,ncolor npt = nc(icol) mj = nt(icol) call vaddp (ndim,ndim,npt,mj,c(ist,1),jc(ist,1),r(ist),p,wksp) ist = ist + npt 20 continue sum = 0.0d0 do 25 i = 1,n 25 sum = sum + r(i)*r(i)/d(i) pldup = sum return end subroutine ssrcpn (ndimm,jc,d,c,nn,ncol,nc,nt,nb,p,r,wksp, a pdp,pldup) implicit double precision (a-h, o-z) c c ... ssrcpn computes pdp = (p,d*p) and c pldup = (p,l*inv(d)*u*p) c c for nonsymmetric multicolor purdue storage format. c c ... parameters -- c c ndim row dimension of c,jc arrays c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c n order of system c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c p vector from acceleration algorithm c r workspace vector from acceleration algorithm c wksp workspace vector of length c n + max(nc(i)) if keygs = 1 c n if keygs = 2 c pdp (p,d*p) c pldup (p,l*d*u*p) c c ... specifications for parameters c integer jc(ndimm,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimm,1), p(1), r(1), wksp(1) c c ... compute pdp = (p,d*p). c n = nn ndim = ndimm ncolor = ncol sum = 0.0d0 do 10 i = 1,n 10 sum = sum + p(i)*d(i)*p(i) pdp = sum c c ... compute pldup = (p,l*inv(d)*u*p) = (u*p,inv(d)*u*p) c np1 = n + 1 do 15 i = 1,n 15 r(i) = 0.0d0 ist = 1 do 20 icol = 1,ncolor npt = nc(icol) mj = nt(icol) call vaddp (ndim,ndim,npt,mj,c(ist,1),jc(ist,1),r(ist),p,wksp) ist = ist + npt 20 continue do 25 i = 1,n 25 r(i) = r(i)/d(i) do 30 i = 1,n 30 wksp(i) = 0.0d0 ist = 1 do 35 icol = 1,ncolor npt = nc(icol) j1 = nt(icol) + 1 mj = nb(icol) call vaddp (ndim,ndim,npt,mj,c(ist,j1),jc(ist,j1),wksp(ist), a r,wksp(np1)) ist = ist + npt 35 continue sum = 0.0d0 do 40 i = 1,n 40 sum = sum + p(i)*wksp(i) pldup = sum return end subroutine srscp1 (ndim,nn,jc,d,c,ncolor,nc,nt,nb,omega, a wksp,y,x) implicit double precision (a-h, o-z) c c ... srscp1 does an ssor forward solve. c (purdue storage, multicolor) c c ... parameters -- c c ndim row dimension of c,jc arrays c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c omega over-relaxation factor c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1), nb(1) dimension d(1), c(ndim,1), x(1), y(1), wksp(1) c c n = nn fac = (2.0d0 - omega)/omega c do 10 i = 1,n 10 x(i) = y(i) call srfscp (ndim,jc,d,c,ncolor,nc,nt,nb,omega,wksp,x) do 15 i = 1,n 15 x(i) = fac*d(i)*x(i) return end subroutine srscp2 (ndim,n,jc,d,c,ncolor,nc,nt,omega, a wksp,y,x) implicit double precision (a-h, o-z) c c ... srscp2 does an ssor back solve. c (purdue storage, multicolor) c c ... parameters -- c c ndim row dimension of c,jc arrays c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c omega over-relaxation factor c wksp workspace vector of length c max(nc(i)) if keygs = 1 c 0 if keygs = 2 c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1) dimension d(1), c(ndim,1), x(1), y(1), wksp(1) c do 10 i = 1,n 10 x(i) = y(i) call srbscp (ndim,n,jc,d,c,ncolor,nc,nt,omega,wksp,x) return end subroutine srscp3 (ndim,n,jc,d,c,ncolor,nc,nt,nb,omega, a wksp,y,x) implicit double precision (a-h, o-z) c c ... srscp3 does an transpose ssor back solve. c (purdue storage, multicolor) c c ... parameters -- c c ndim row dimension of c,jc arrays c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c nb integer vector of length ncolor giving the number c of lower columns for each color c omega over-relaxation factor c wksp workspace vector of length max(nc(i)) c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1), nb(1) dimension d(1), c(ndim,1), x(1), y(1), wksp(1) c c fac = (2.0d0 - omega)/omega c do 15 i = 1,n 15 x(i) = fac*d(i)*y(i) call srbsct (ndim,n,jc,d,c,ncolor,nc,nt,nb,omega,wksp,x) return end subroutine srscp4 (ndim,n,jc,d,c,ncolor,nc,nt,omega, a wksp,y,x) implicit double precision (a-h, o-z) c c ... srscp4 does an transpose ssor forward solve. c (purdue storage, multicolor) c c ... parameters -- c c ndim row dimension of c,jc arrays c n order of system (= nn) c jc integer array giving the column indices of the c corresponding elements in c c d vector of length n giving the diagonal elements c of the matrix c c array of active size n by maxc giving the c off diagonal elements of the matrix. c thus, a = d + c c ncolor number of colors used c nc integer vector of length ncolor giving the number c of nodes for each color c nt integer vector of length ncolor giving the number c of upper columns for each color c omega over-relaxation factor c wksp workspace vector of length max(nc(i)) c c ... specifications for parameters c integer jc(ndim,1), nc(1), nt(1) dimension d(1), c(ndim,1), x(1), y(1), wksp(1) c do 10 i = 1,n 10 x(i) = y(i) call srfsct (ndim,jc,d,c,ncolor,nc,nt,omega,wksp,x) return end double precision function tau (ii) implicit double precision (a-h, o-z) c c ... tau sets tau(ii) for the sor method. c c ... parameters -- c c ii number of times parameters have been changed c c ... specifications for parameters c c dimension t(9) c data t(1), t(2), t(3), t(4), t(5), t(6), t(7), t(8), t(9) a / 1.5d0, 1.8d0, 1.85d0, 1.9d0, 1.94d0, 1.96d0, 1.975d0, a 1.985d0, 1.992d0 / c tau = t(9) if (ii .le. 8) tau = t(ii) return end subroutine tbs (n,t,x) implicit double precision (a-h, o-z) c c ... tbs does a back substitution (i + t)*x = y where t is the c first super-diagonal. c c ... parameters -- c c n order of the system c t vector of length n-1 containing the super- c diagonal elements c x on input, x contains y c on output, x contains the solution to (i - t)*x = y c c ... specifications for parameters c dimension t(1), x(1) c do 10 i = n-1,1,-1 10 x(i) = x(i) - t(i)*x(i+1) return end subroutine tbsm (nn,nsize,t,x) implicit double precision (a-h, o-z) c c ... tbsm does a back substitution (i + t)*x = y where t c is a super diagonal composed of independent subsystems of c size nsize. c c ... parameters -- c c n order of system c nsize order of the individual subsystems c t linear array of length n-1 containing the super- c diagonal elements of the factorizations c x on input, x contains y c the solution to (i + t)*x = y c c ... specifications for parameters c dimension t(nsize,1), x(nsize,1) c n = nn nsys = n/nsize do 15 i = nsize-1,1,-1 do 10 j = 1,nsys 10 x(i,j) = x(i,j) - t(i,j)*x(i+1,j) 15 continue return end subroutine tfac (nn,d,t) implicit double precision (a-h, o-z) c c ... tfac computes a factorization of a single symmetric c tridiagonal matrix contained in d and t and replaces it. c c ... parameters -- c c n order of system (= nn) c d vector of length n containing the diagonal c elements of the matrix c t vector of length n-1 containing the super- c diagonal elements of the matrix c c ... specifications for parameters c dimension d(1), t(1) c n = nn nm1 = n - 1 do 10 i = 2,n 10 d(i) = d(i) - (t(i-1)*t(i-1))/d(i-1) do 15 i = 1,n 15 d(i) = 1.0d0/d(i) do 20 i = 1,nm1 20 t(i) = d(i)*t(i) return end subroutine tfacm (nn,nsize,d,t) implicit double precision (a-h, o-z) c c ... tfacm computes factorizations of multiple independent c symmetric tridiagonal matrices contained in d and t. c c ... parameters -- c c n order of global system (= nn) c nsize size of the individual subsystems c d linear array of length n containing the c diagonal elements of the systems c t linear array of length n-1 containing the c super-diagonal elements of the systems c c ... specifications for parameters c dimension d(nsize,1), t(nsize,1) c n = nn nm1 = n - 1 nsys = n/nsize do 10 i = 2,nsize do 5 j = 1,nsys 5 d(i,j) = d(i,j) - (t(i-1,j)**2)/d(i-1,j) 10 continue call vinv (n,d) call vexopy (nm1,t,d,t,3) return end subroutine tfacn (nn,d,t,b) implicit double precision (a-h, o-z) c c ... tfacn computes a factorization of a single nonsymmetric c tridiagonal matrix contained in d, t, and b and c replaces it. c c ... parameters -- c c n order of system (= nn) c d vector of length n containing the diagonal c elements of the matrix c t vector of length n-1 containing the super- c diagonal elements of the matrix c b vector of length n-1 containing the sub- c diagonal elements of the matrix c c ... specifications for parameters c dimension d(1), t(1), b(1) c n = nn nm1 = n - 1 do 10 i = 2,n 10 d(i) = d(i) - b(i-1)*t(i-1)/d(i-1) do 15 i = 1,n 15 d(i) = 1.0d0/d(i) do 20 i = 1,nm1 t(i) = d(i)*t(i) b(i) = d(i)*b(i) 20 continue return end subroutine tfacnm (nn,nsize,d,t,b) implicit double precision (a-h, o-z) c c ... tfacnm computes factorizations of multiple independent c nonsymmetric tridiagonal matrices contained in c d, t, and b. c c ... parameters -- c c n order of global system (= nn) c nsize order of single subsystem c d linear array of length n containing the c diagonal elements of the systems c t linear array of length n-1 containing the c super-diagonal elements of the systems c b linear array of length n-1 containing the c sub-diagonal elements of the systems c c ... specifications for parameters c dimension d(nsize,1), t(nsize,1), b(nsize,1) c n = nn nm1 = n - 1 nsys = n/nsize do 10 i = 2,nsize do 5 j = 1,nsys 5 d(i,j) = d(i,j) - b(i-1,j)*t(i-1,j)/d(i-1,j) 10 continue call vinv (n,d) call vexopy (nm1,t,d,t,3) call vexopy (nm1,b,d,b,3) return end subroutine tfs (n,b,x) implicit double precision (a-h, o-z) c c ... tfs does a forward substitution (i + b)*x = y, c where b is the first sub-diagonal. c c ... parameters -- c c n order of system c b vector of length n-1 containing the sub- c diagonal elements c x on input, x contains y c on output, x contains the solution to (i - b)*x = y c c ... specifications for parameters c dimension b(1), x(1) c do 10 i = 2,n 10 x(i) = x(i) - b(i-1)*x(i-1) return end subroutine tfsm (nn,nsize,b,x) implicit double precision (a-h, o-z) c c ... tfsm does a forward substitution (i + b)*x = y where b c is a sub-diagonal composed of independent subsystems of c size nsize. c c ... parameters -- c c n order of system c nsize order of the individual subsystems c b linear array of length n-1 containing the sub- c diagonal elements of the factorizations c x on input, x contains y c on output, x contains the solution to (i + b)*x = y c c ... specifications for parameters c dimension b(nsize,1), x(nsize,1) c n = nn nsys = n/nsize do 20 i = 2,nsize do 15 j = 1,nsys 15 x(i,j) = x(i,j) - b(i-1,j)*x(i-1,j) 20 continue return end subroutine tinv (nn,d,t) implicit double precision (a-h, o-z) c c ... tinv computes an approximate inverse to a single tridiagonal c symmetric matrix. d and u must contain upon input the c output from a factorization routine. c c ... parameters -- c c n order of system (= nn) c d vector of length n containing the diagonal c elements of the factorization c t vector of length n-1 containing the super- c diagonal elements of the factorization c c ... specifications for parameters c dimension d(1), t(1) c n = nn nm1 = n - 1 c do 10 i = nm1,1,-1 10 d(i) = d(i) + t(i)*t(i)*d(i+1) do 15 i = 1,nm1 15 t(i) = -d(i+1)*t(i) return end subroutine tinvm (nn,nsize,d,t) implicit double precision (a-h, o-z) c c ... tinvm computes an approximate inverse to multiple tridiagonal c symmetric matrices. d and t must contain upon input the c output from a factorization routine. c c ... parameters -- c c n order of system (= nn) c nsize size of a single subsystem c d vector of length n containing the diagonal c elements of the factorization c t vector of length n-1 containing the super- c diagonal elements of the factorization c c ... specifications for parameters c dimension d(nsize,1), t(nsize,1) c n = nn nm1 = n - 1 nsys = n/nsize nsm1 = nsize - 1 c do 20 i = nsm1,1,-1 do 15 l = 1,nsys 15 d(i,l) = d(i,l) + t(i,l)*t(i,l)*d(i+1,l) 20 continue call vemxty (nm1,t,d(2,1),t) return end subroutine tinvn (nn,d,t,b) implicit double precision (a-h, o-z) c c ... tinvn computes an approximate inverse to a single tridiagonal c nonsymmetric matrix. d, b, and t must contain upon c input the output from a factorization routine. c c ... parameters -- c c n order of system (= nn) c d vector of length n containing the diagonal c elements of the factorization c t vector of length n-1 containing the super- c diagonal elements of the factorization c b vector of length n-1 containing the sub- c diagonal elements of the factorization c c ... specifications for parameters c dimension d(1), t(1), b(1) c n = nn nm1 = n - 1 c do 10 i = nm1,1,-1 10 d(i) = d(i) + b(i)*t(i)*d(i+1) do 20 i = 1,nm1 t(i) = -d(i+1)*t(i) b(i) = -d(i+1)*b(i) 20 continue return end subroutine tinvnm (nn,nsize,d,t,b) implicit double precision (a-h, o-z) c c ... tinvnm computes an approximate inverse to multiple tridiagonal c nonsymmetric matrices. d, t, and b must contain upon c input the output from a factorization routine. c c ... parameters -- c c n order of system (= nn) c nsize size of a single subsystem c d vector of length n containing the diagonal c elements of the factorization c t vector of length n-1 containing the super- c diagonal elements of the factorization c b vector of length n-1 containing the sub- c diagonal elements of the factorization c c ... specifications for parameters c dimension d(nsize,1), t(nsize,1), b(nsize,1) c n = nn nm1 = n - 1 nsys = n/nsize nsm1 = nsize - 1 c do 20 i = nsm1,1,-1 do 15 l = 1,nsys 15 d(i,l) = d(i,l) + b(i,l)*t(i,l)*d(i+1,l) 20 continue call vemxty (nm1,t,d(2,1),t) call vemxty (nm1,b,d(2,1),b) return end subroutine tsoln (nn,d,t,b,y,x) implicit double precision (a-h, o-z) c c ... tsoln solves the system ax = y for x, where a is a single c tridiagonal system. d, t, and b contain c the main diagonal, the first super-diagonal, and the first c sub-diagonal, respectively of the factorization. c c ... parameters -- c c n order of system c d vector of length n containing the diagonal c elements of the factorization matrix c t vector of length n-1 containing the super- c diagonal elements of the factorization c b vector of length n-1 containing the sub- c diagonal elements of the factorization c y the right-hand side c x the solution to ax = y c c ... specifications for parameters c dimension d(1), t(1), b(1), x(1), y(1) c n = nn do 10 i = 1,n 10 x(i) = y(i) call tfs (n,b,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call tbs (n,t,x) return end subroutine tsolnm (nn,nsize,d,t,b,y,x) implicit double precision (a-h, o-z) c c ... tsolnm solves the system ax = y for x, where a contains c multiple tridiagonal systems. d, t, and b contain c the main diagonal, the first super-diagonal, and the first c sub-diagonal, respectively of the factorization. c c ... parameters -- c c n order of system c nsize size of an individual subsystem c d vector of length n containing the diagonal c elements of the factorization matrix c t vector of length n-1 containing the super- c diagonal elements of the factorization c b vector of length n-1 containing the sub- c diagonal elements of the factorization c y the right-hand side c x the solution to ax = y c c ... specifications for parameters c dimension d(1), t(1), b(1), x(1), y(1) c n = nn do 10 i = 1,n 10 x(i) = y(i) call tfsm (n,nsize,b,x) do 15 i = 1,n 15 x(i) = d(i)*x(i) call tbsm (n,nsize,t,x) return end subroutine tsum (nn,lda,ldb,ldc,ma,mbb,mc,mdd,incb,incc, a incdd,ja,jb,jc,jd,a,b,c,rows,cols,wksp, a icodee,omegaa) implicit double precision (a-h, o-z) c c ... tsum computes the row and column sum of (c**t)*a*b restricted c ... to the sparsity pattern of jd. a is assumed to be symmetric. c c ... parameters -- c c n orders of arrays a,b,c,d c lda,ldb,ldc row dimensions of arrays a,b,c c ma,mb,mc,md columns (diagonals) in arrays a,b,c,d c incb,incc, offsets for diagonal numbers of b,c,d arrays c incd c ja,jb,jc,jd diagonal index arrays for a,b,c,d c a,b,c arrays of dimension n x (ma,mb,md) c rows row sum of d = (c**t)*a*b upon output c cols column sum of d upon output c wksp workspace array of length n c icode key c = 0 if c .ne. b c = 1 if c .eq. b c omega relaxation factor between 0 and 1 c c ... specifications for parameters c integer ja(1), jb(1), jc(1), jd(1) dimension a(lda,1), b(ldb,1), c(ldc,1), wksp(1), rows(1), cols(1) c n = nn mb = mbb md = mdd incd = incdd icode = icodee omega = omegaa do 95 lc = 1,mc i = jc(lc) - incc ia1 = max (1,i+1) ib1 = min (n,n+i) do 90 la = 1,ma j = ja(la) l1 = -i + j ia2 = max (ia1,1-l1) ib2 = min (ib1,n-l1) do 45 lb = 1,mb k = jb(lb) - incb l = l1 + k do 10 ld = 1,md if (jd(ld)-incd .eq. l) go to 15 10 continue go to 45 15 ist = max (ia2,1-l) ied = min (ib2,n-l) do 20 kk = ist,ied 20 wksp(kk-ist+1) = c(kk-i,lc)*a(kk-i,la)*b(kk+l1,lb) do 25 kk = ist,ied 25 rows(kk) = rows(kk) + omega*wksp(kk-ist+1) if (l .eq. 0 .or. icode .ne. 1) go to 35 do 30 kk = ist,ied 30 rows(kk+l) = rows(kk+l) + omega*wksp(kk-ist+1) 35 if (icode .eq. 1) go to 45 do 40 kk = ist,ied 40 cols(kk+l) = cols(kk+l) + omega*wksp(kk-ist+1) 45 continue if (j .eq. 0) go to 90 l1 = -i - j ia2 = max (ia1,1-l1) ib2 = min (ib1,n-l1) do 85 lb = 1,mb k = jb(lb) - incb l = l1 + k do 50 ld = 1,md if (jd(ld)-incd .eq. l) go to 55 50 continue go to 85 55 ist = max (ia2,1-l) ied = min (ib2,n-l) do 60 kk = ist,ied 60 wksp(kk-ist+1) = c(kk-i,lc)*a(kk+l1,la)*b(kk+l1,lb) do 65 kk = ist,ied 65 rows(kk) = rows(kk) + omega*wksp(kk-ist+1) if (l .eq. 0 .or. icode .ne. 1) go to 75 do 70 kk = ist,ied 70 rows(kk+l) = rows(kk+l) + omega*wksp(kk-ist+1) 75 if (icode .eq. 1) go to 85 do 80 kk = ist,ied 80 cols(kk+l) = cols(kk+l) + omega*wksp(kk-ist+1) 85 continue 90 continue 95 continue return end subroutine tsumn (nn,np,nq,lda,ldb,ldc,ldj,ma,mb,mc,md, a incb,incc,incd,ja,jb,jc,jd,a,b,c, a rows,omega) implicit double precision (a-h, o-z) c c ... tsumn computes the row sum of c*a*b restricted c ... to the sparsity pattern of jd. c c c is np x nn b is nn x nq c a is nn x nn d is np x nq c c ... definition of parameters -- c c nn,np,nq orders of arrays c lda,ldb,ldc row dimensions of arrays a,b,c c ldj row dimension of ja,jb,jc,jd vectors c ma,mb,mc,md columns (diagonals) in arrays a,b,c,d c incb,incc, offsets for diagonal numbers of b,c,d arrays c incd c ja,jb,jc,jd diagonal index arrays for a,b,c,d c a,b,c arrays of dimension n x (ma,mb,md) c rows row sum of d = c*a*b upon output c omega relaxation factor between 0 and 1 c c ... specifications for parameters c integer ja(ldj,1), jb(ldj,1), jc(ldj,1), jd(ldj,1) dimension a(lda,1), b(ldb,1), c(ldc,1), rows(1) c n = nn do 40 lc = 1,mc i = jc(1,lc) - incc ia1 = max (1,1-i) ib1 = min (np,n-i) do 35 la = 1,ma j = ja(1,la) l1 = i + j ia2 = max (ia1,1-l1) ib2 = min (ib1,n-l1) do 30 lb = 1,mb k = jb(1,lb) - incb l = l1 + k do 15 ld = 1,md if (jd(1,ld)-incd .eq. l) go to 20 15 continue go to 30 20 ist = max (ia2,1-l) ied = min (ib2,nq-l) do 25 m = ist,ied 25 rows(m) = rows(m) + omega*c(m,lc)*a(m+i,la)*b(m+l1,lb) 30 continue 35 continue 40 continue return end subroutine t1prod (lda,ldb,ldc,ldd,ldj,nn,np,nq,ma,mb,mc,md, a incb,incc,incd,ja,jb,jc,jd,a,b,c,d) implicit double precision (a-h, o-z) c c ... t1prod computes d = d - c*a*b c ... c ... but restricted to the sparsity pattern of d. a is assumed to c ... be in nonsymmetric storage mode. c c c is np x nn b is nn x nq c a is nn x nn d is np x nq c c ... definition of parameters -- c c lda,ldb, row dimension of arrays a,b,c,d c ldc,ldd c ldj row dimension of arrays ja,jb,jc,jd c nn,np,nq orders of arrays c ma,mb,mc,md columns (diagonals) in arrays a,b,c,d c incb,incc, offsets for diagonal numbers of b,c,d arrays c incd c ja,jb,jc,jd diagonal index arrays for a,b,c,d c a,b,c,d arrays of dimension n x (ma,mb,mc, or md) c c ... specifications for parameters c integer ja(ldj,1), jb(ldj,1), jc(ldj,1), jd(ldj,1) dimension a(lda,1), b(ldb,1), c(ldc,1), d(ldd,1) c n = nn do 40 lc = 1,mc i = jc(1,lc) - incc ia1 = max (1,1-i) ib1 = min (np,n-i) do 35 la = 1,ma j = ja(1,la) l1 = i + j ia2 = max (ia1,1-l1) ib2 = min (ib1,n-l1) do 30 lb = 1,mb k = jb(1,lb) - incb l = l1 + k do 15 ld = 1,md if (jd(1,ld)-incd .eq. l) go to 20 15 continue go to 30 20 ist = max (ia2,1-l) ied = min (ib2,nq-l) do 25 m = ist,ied 25 d(m,ld) = d(m,ld) - c(m,lc)*a(m+i,la)*b(m+l1,lb) 30 continue 35 continue 40 continue return end subroutine t2prod (nn,nda,ndb,ndc,ndd,ma,mbb,mc,mdd,incb,incc, a incd,ja,jb,jc,jd,a,b,c,d) implicit double precision (a-h, o-z) c c ... t2prod computes d = d - (c**t)*a*b restricted to the c ... sparsity pattern of d. a is assumed to be symmetric. c c ... parameters -- c c n orders of arrays a,b,c,d c nda,ndb,ndc, row dimensions of arrays a,b,c,d c ndd c ma,mb,mc,md columns (diagonals) in arrays a,b,c,d c incb,incc, offsets for diagonal numbers of b,c,d arrays c incd c ja,jb,jc,jd diagonal index arrays for a,b,c,d c a,b,c,d arrays of dimension n x (ma,mb,mc, or md) c c ... specifications for parameters c integer ja(1), jb(1), jc(1), jd(1) dimension a(nda,1), b(ndb,1), c(ndc,1), d(ndd,1) c n = nn mb = mbb md = mdd do 65 lc = 1,mc i = jc(lc) - incc ia1 = max (1,i+1) ib1 = min (n,n+i) do 60 la = 1,ma j = ja(la) l1 = -i + j ia2 = max (ia1,1-l1) ib2 = min (ib1,n-l1) do 30 lb = 1,mb k = jb(lb) - incb l = l1 + k do 15 ld = 1,md if (jd(ld)-incd .eq. l) go to 20 15 continue go to 30 20 ist = max (ia2,1-l) ied = min (ib2,n-l) do 25 ir = ist,ied 25 d(ir,ld) = d(ir,ld) - c(ir-i,lc)*a(ir-i,la)*b(ir+l1,lb) 30 continue if (j .eq. 0) go to 60 l1 = -i - j ia2 = max (ia1,1-l1) ib2 = min (ib1,n-l1) do 55 lb = 1,mb k = jb(lb) - incb l = l1 + k do 40 ld = 1,md if (jd(ld)-incd .eq. l) go to 45 40 continue go to 55 45 ist = max (ia2,1-l) ied = min (ib2,n-l) do 50 ir = ist,ied 50 d(ir,ld) = d(ir,ld) - c(ir-i,lc)*a(ir+l1,la)*b(ir+l1,lb) 55 continue 60 continue 65 continue return end subroutine unpmdg (ndim,nn,maxnz,jcoef,coef,ncol,nc,p,ip, a maxd,maxnew,jcnew,wksp,iwksp,isym) implicit double precision (a-h, o-z) c c ... unpmdg reverses the permutation done by pmdiag. it c permutates the matrix according to index vector ip. c the permuted matrix is stored in diagonal format. c c ... parameters -- c c ndim row dimension of coef and jcoef arrays c in defining routine c n order of system (active row size of coef and jcoef) c maxnz active column size of coef and jcoef c jcoef integer array of column numbers c coef floating point array of coefficients c ncolor number of colors in the permutation (= ncol) c nc integer vector of length ncolor giving the c number of nodes for each color c p permutation vector c ip inverse permuation vector c maxd active column size of permuted matrix c jcnew integer array of size ncolor*max(maxnew(i)) c giving the diagonal numbers for each color c wksp floating point workspace of length n c iwksp integer workspace of length 2*n c isym symmetric storage switch c = 0 symmetric storage c = 1 nonsymmetric storage c c ... specifications for parameters c integer jcoef(2), nc(1), p(1), jcnew(ncol,1), maxnew(1), a iwksp(1), ip(1) dimension coef(ndim,1), wksp(1) c c n = nn ncolor = ncol c c ... set up pointer vector. c do 10 j = 1,maxnz jcol = jcoef(j) iwksp(n+jcol) = j 10 continue c c ... permute rows of matrix first. c do 15 j = 1,maxd do 12 i = 1,n 12 wksp(i) = coef(i,j) call vscatr (n,wksp,ip,coef(1,j)) 15 continue c c ... rearrange rows. c ist = 1 do 35 k = 1,ncolor ncc = nc(k) ied = ist + ncc - 1 lim = maxnew(k) do 30 i = ist,ied iip = ip(i) do 20 j = 2,maxd wksp(j) = coef(iip,j) coef(iip,j) = 0.0d0 20 continue do 25 j = 2,lim if (wksp(j) .eq. 0.0d0) go to 25 jcol = ip(i + jcnew(k,j)) - iip l = iwksp(n+jcol) coef(iip,l) = wksp(j) 25 continue 30 continue ist = ist + ncc 35 continue c c ... zero out lower triangular matrix if symmeteric storage used. c if (isym .ne. 0) return maxold = (maxnz + 1)/2 mp1 = maxold + 1 do 45 j = mp1,maxnz do 40 i = 1,n 40 coef(i,j) = 0.0d0 jcoef(j) = 0 45 continue maxnz = maxold return end subroutine uscal1 (nn,ndim,maxnzz,jcoef,coef,rhs,u,ubar, a diag,work,iflag) implicit double precision (a-h, o-z) c c ... uscal1 reverses the scaling done in routine scal1. diag must c contain upon input the output from scal1. c (purdue data structure) c c ... parameters -- c c n dimension of matrix c ndim row dimension of coef array in defining routine c maxnz number of columns in coef array c jcoef integer matrix representation array c coef matrix representation array c rhs right hand side of matrix problem c u latest estimate of solution c ubar exact solution (optional) c diag vector of the same name from scal1 routine c work work array of length n (volatile) c iflag flag for ubar c = 0 do not unscale ubar c = 1 unscale ubar c c ... specifications for parameters c integer jcoef(ndim,1) dimension coef(ndim,1), rhs(1), u(1), diag(1), work(1), a ubar(1) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c n = nn maxnz = maxnzz c c ... unscale u and rhs arrays. c do 10 i = 1,n 10 u(i) = diag(i)*u(i) if (iflag .eq. 0) go to 20 do 15 i = 1,n 15 ubar(i) = diag(i)*ubar(i) 20 do 25 i = 1,n 25 diag(i) = 1.0d0/diag(i) do 30 i = 1,n 30 rhs(i) = diag(i)*rhs(i) c c ... unscale matrix. c if (keygs .eq. 2) go to 45 c c ... using gathers. c do 40 j = 1,maxnz call vgathr (n,diag,jcoef(1,j),work) do 35 i = 1,n 35 coef(i,j) = diag(i)*coef(i,j)*work(i) 40 continue return c c ... not using gathers. c 45 do 55 j = 1,maxnz do 50 i = 1,n 50 coef(i,j) = diag(i)*coef(i,j)*diag(jcoef(i,j)) 55 continue return end subroutine uscal2 (nn,ndim,maxnz,jcoef,coef,rhs,u,ubar, a diag,iflag) implicit double precision (a-h, o-z) c c ... uscal2 reverses the scaling done in routine scal2. diag must c contain upon input the output from scal2. c (diagonal data structure) c c ... parameters -- c c n dimension of matrix c ndim row dimension of coef array in defining routine c maxnz number of columns in coef array c jcoef integer matrix representation array c coef matrix representation array c rhs right hand side of matrix problem c u latest estimate of solution c ubar exact solution (optional) c diag vector of the same name from scal2 routine c iflag flag for ubar c = 0 do not unscale ubar c = 1 unscale ubar c c ... specifications for parameters c integer jcoef(2) dimension coef(ndim,1), rhs(1), u(1), diag(1), ubar(1) c c n = nn c c ... unscale u and rhs arrays. c do 10 i = 1,n 10 u(i) = diag(i)*u(i) if (iflag .eq. 0) go to 20 do 15 i = 1,n 15 ubar(i) = diag(i)*ubar(i) 20 do 25 i = 1,n 25 diag(i) = 1.0d0/diag(i) do 30 i = 1,n 30 rhs(i) = diag(i)*rhs(i) c c ... unscale matrix. c do 50 j = 1,maxnz ind = jcoef(j) len = n - iabs(ind) if (ind .lt. 0) go to 40 do 35 i = 1,len 35 coef(i,j) = diag(i)*coef(i,j)*diag(i+ind) go to 50 40 do 45 i = 1,len 45 coef(i-ind,j) = diag(i)*coef(i-ind,j)*diag(i-ind) 50 continue return end subroutine uscal3 (nn,nz,ia,ja,a,rhs,u,ubar,diag,work,iflag) implicit double precision (a-h, o-z) c c ... uscal3 reverses the scaling done in routine scal3. diag must c contain upon input the output from scal3. c (sparse data structure) c c ... parameters -- c c n dimension of matrix c nz length of the vectors a, ia, and ja c a vector of matrix coefficients c ia vector of i values c ja vector of j values c rhs right hand side of matrix problem c u latest estimate of solution c ubar exact solution (optional) c diag vector of the same name from scal3 routine c work work array of length n (volatile) c iflag flag for ubar c = 0 do not unscale ubar c = 1 unscale ubar c c ... specifications for parameters c integer ia(1), ja(1) dimension a(1), rhs(1), u(1), diag(1), work(1), a ubar(1) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c n = nn c c ... unscale u and rhs arrays. c do 10 i = 1,n 10 u(i) = diag(i)*u(i) if (iflag .eq. 0) go to 20 do 15 i = 1,n 15 ubar(i) = diag(i)*ubar(i) 20 do 25 i = 1,n 25 diag(i) = 1.0d0/diag(i) do 30 i = 1,n 30 rhs(i) = diag(i)*rhs(i) c c ... unscale matrix. c if (keygs .eq. 2) go to 50 c c ... using gathers. c ist = 1 35 ied = min (ist-1+n,nz) if (ied .lt. ist) return len = ied - ist + 1 call vgathr (len,diag,ia(ist),work) do 40 i = ist,ied 40 a(i) = a(i)*work(i-ist+1) call vgathr (len,diag,ja(ist),work) do 45 i = ist,ied 45 a(i) = a(i)*work(i-ist+1) ist = ied + 1 go to 35 c c ... not using gathers. c 50 do 55 i = 1,nz 55 a(i) = a(i)*diag(ia(i))*diag(ja(i)) return end subroutine vaddd (lda,ldja,nn,m,mdiagg,a,ja,y,x,jofff) implicit double precision (a-h, o-z) c c ... vaddd computes y = y + a*x c c (diagonal storage) c c ... parameters -- c c lda leading dimension of a array c ldja leading dimension of ja array c n active row size of matrix c m active column size of matrix c mdiag number of diagonals in a c a array of matrix diagonals c ja array of matrix diagonal numbers c y,x vectors of length n c joff offset for diagonal numbers c c ... specifications for parameters c dimension a(lda,3), x(1), y(1) integer ja(ldja,3) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c n = nn mdiag = mdiagg joff = jofff if (mdiag .lt. 1) return if (keyzer .eq. 1) go to 20 do 15 j = 1,mdiag ind = ja(1,j) - joff ist = max (1,1-ind) ied = min (n,m-ind) do 10 i = ist,ied 10 y(i) = y(i) + a(i,j)*x(i+ind) 15 continue return c c ... unrolled version (requires memory to be zeroed out). c 20 l = mod (mdiag,4) if (l .eq. 0) go to 60 c c ... initial short computations c go to (25,35,45), l 25 do 30 i = 1,n 30 y(i) = y(i) + a(i,1)*x(i+ja(1,1)-joff) go to 55 35 do 40 i = 1,n 40 y(i) = y(i) + a(i,1)*x(i+ja(1,1)-joff) + a(i,2)*x(i+ja(1,2)-joff) go to 55 45 do 50 i = 1,n 50 y(i) = y(i) + a(i,1)*x(i+ja(1,1)-joff) + a(i,2)*x(i+ja(1,2)-joff) a + a(i,3)*x(i+ja(1,3)-joff) 55 if (mdiag .le. 4) return c c ... loop unrolling to a level of 4. c 60 lp1 = l + 1 do 70 j = lp1,mdiag,4 do 65 i = 1,n 65 y(i) = y(i) + a(i,j )*x(i+ja(1,j )-joff) a + a(i,j+1)*x(i+ja(1,j+1)-joff) a + a(i,j+2)*x(i+ja(1,j+2)-joff) a + a(i,j+3)*x(i+ja(1,j+3)-joff) 70 continue return end subroutine vadddt (lda,ldja,nn,m,mdiagg,a,ja,y,x,jofff) implicit double precision (a-h, o-z) c c ... vadddt computes y = y + (a**t)*x c c (diagonal storage) c c ... parameters -- c c lda leading dimension of a array c ldja leading dimension of ja array c n active row size of matrix c m active column size of matrix c mdiag number of diagonals in a c a array of matrix diagonals c ja array of matrix diagonal numbers c y,x vectors of length n c joff offset for diagonal numbers c c ... specifications for parameters c dimension a(lda,3), x(1), y(1) integer ja(ldja,3) c n = nn mdiag = mdiagg joff = jofff if (mdiag .lt. 1) return do 15 j = 1,mdiag ind = ja(1,j) - joff ist = max (1,1-ind) ied = min (n,m-ind) do 10 i = ist,ied 10 y(i+ind) = y(i+ind) + a(i,j)*x(i) 15 continue return end subroutine vaddp (ndimr,ndimi,nn,mm,a,ja,y,x,wksp) implicit double precision (a-h, o-z) c c ... vaddp does y = y + a*x (purdue format) c c ... parameters -- c c ndimr row dimension of a array c ndimi row dimension of ja array c n order of system c m number of columns in a and ja arrays c a floating point array of active size n by m c ja integer array of active size n by m c y accumulation vector c x right-hand-side vector c wksp workspace vector of length n (keygs = 1 only) c c ... specifications for parameters c dimension a(ndimr,3), ja(ndimi,3), x(1), y(1), wksp(1) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c n = nn m = mm if (m .le. 0) return if (keygs .eq. 1) go to 100 c c ... implicit gathers. c l = mod (m,4) if (l .eq. 0) go to 45 c c ... initial short computations c go to (10,20,30), l 10 do 15 i = 1,n 15 y(i) = y(i) + a(i,1)*x(ja(i,1)) go to 40 20 do 25 i = 1,n 25 y(i) = y(i) + a(i,1)*x(ja(i,1)) + a(i,2)*x(ja(i,2)) go to 40 30 do 35 i = 1,n 35 y(i) = y(i) + a(i,1)*x(ja(i,1)) + a(i,2)*x(ja(i,2)) a + a(i,3)*x(ja(i,3)) 40 if (m .le. 4) return c c ... loop unrolling to a level of 4. c 45 lp1 = l + 1 do 55 j = lp1,m,4 do 50 i = 1,n 50 y(i) = y(i) + a(i,j)*x(ja(i,j)) + a(i,j+1)*x(ja(i,j+1)) a + a(i,j+2)*x(ja(i,j+2)) + a(i,j+3)*x(ja(i,j+3)) 55 continue return c c ... explicit gathers. c 100 do 110 j = 1,m call vgathr (n,x,ja(1,j),wksp) do 105 i = 1,n 105 y(i) = y(i) + a(i,j)*wksp(i) 110 continue return end subroutine vaddpt (ndimr,ndimi,n,m,a,ja,y,x,wksp) implicit double precision (a-h, o-z) c c ... vaddpt does y = y + (a**t)*x (purdue format) c c ... parameters -- c c ndimr row dimension of a array c ndimi row dimension of ja array c n order of system c m number of columns in a and ja arrays c a floating point array of active size n by m c ja integer array of active size n by m c y accumulation vector c x right-hand-side vector c wksp workspace vector of length n c c ... specifications for parameters c dimension a(ndimr,3), ja(ndimi,3), x(1), y(1), wksp(1) c if (m .le. 0) return c do 20 j = 1,m do 15 i = 1,n y(ja(i,j)) = y(ja(i,j)) + a(i,j)*x(i) 15 continue 20 continue return end subroutine vadds (mm,np,ia,ja,a,y,x,wksp) implicit double precision (a-h, o-z) c c ... vadds does y = y + a*x (sparse format) c c ... parameters -- c c m number of partitions c np partition pointers c ia vector of i values c ja vector of j values c a vector of coefficients c y accumulation vector c x right-hand-side vector c wksp workspace vector of length 2*n (keygs = 1 only) c c ... specifications for parameters c dimension np(1), a(1), ia(1), ja(1), x(1), y(1), wksp(1) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c m = mm if (m .le. 0) return if (keygs .eq. 1) go to 20 c c ... implicit gathers. c do 15 k = 1,m ist = np(k) ied = np(k+1) - 1 cdir$ ivdep do 10 i = ist,ied 10 y(ia(i)) = y(ia(i)) + a(i)*x(ja(i)) 15 continue return c c ... explicit gathers. c 20 do 30 k = 1,m ist = np(k) nel = np(k+1) - ist call vgathr (nel,x,ja(ist),wksp) call vgathr (nel,y,ia(ist),wksp(nel+1)) do 25 i = 1,nel 25 wksp(i) = wksp(nel+i) + a(ist+i-1)*wksp(i) call vscatr (nel,wksp,ia(ist),y) 30 continue return end subroutine vcopy (n,x,y) implicit double precision (a-h, o-z) c c ... vcopy copies vector x to vector y. c c ... parameters -- c c n length of vectors c x,y vectors of length n c c ... specifications for parameters c dimension x(1), y(1) c if (n .le. 0) return do 10 i = 1,n 10 y(i) = x(i) return end double precision function vdot (n,x,y) implicit double precision (a-h, o-z) c c ... vdot computes the dot product of vectors x and y. c c ... parameters -- c c n length of vectors c x,y vectors of length n c c ... specifications for parameters c dimension x(1), y(1) c c vdot = 0.0d0 if (n .le. 0) return do i = 1,n vdot = vdot + x(i)*y(i) enddo return end subroutine vexopy (nn,v,x,y,icode) implicit double precision (a-h, o-z) c c ... vexopy computes v = x op y where v, x, and y are vectors c ... and op is one of the operations + - * / . c c ... parameters -- c c n length of vectors (= nn) c v,x,y vectors of length n c icode key indicating operation c = 1 for addition c = 2 for subtraction c = 3 for multiplication c = 4 for division c c ... specifications for parameters c dimension v(1), x(1), y(1) c n = nn if (n .le. 0) return go to (10,20,30,40), icode c c ... compute v = x + y c 10 do 15 i = 1,n 15 v(i) = x(i) + y(i) return c c ... compute v = x - y c 20 do 25 i = 1,n 25 v(i) = x(i) - y(i) return c c ... compute v = x * y c 30 do 35 i = 1,n 35 v(i) = x(i)*y(i) return c c ... compute v = x / y c 40 do 45 i = 1,n 45 v(i) = x(i)/y(i) return end subroutine vfill (n,v,val) implicit double precision (a-h, o-z) c c vfill fills a vector, v, with a constant value, val. c c ... parameters -- c c n integer length of vector v c v vector c val constant that fills first n locations of v c c ... specifications for parameters c dimension v(n) c if (n .le. 0) return do 10 i = 1,n 10 v(i) = val return end subroutine vgathi (n,ja,ia,jb) implicit double precision (a-h, o-z) c c ... vgathi gathers elements from array ja according to index c ... list ia and places them into consecutive locations in c ... array jb. c c ... parameters -- c c n order of arrays ia and jb c ja integer array of source elements c ia integer array of length n giving desired c elements of array ja c jb integer target array of length n c c ... specifications for parameters c integer ia(1), ja(1), jb(1) c if (n .le. 0) return do 10 i = 1,n 10 jb(i) = ja(ia(i)) c c205 jb(1;n) = q8vgathr (ja(1;n),ia(1;n);jb(1;n)) cray1 call gather (n,jb,ja,ia) c return end subroutine vgathr (n,a,ia,b) implicit double precision (a-h, o-z) c c ... vgathr gathers elements from array a according to index c ... list ia and places them into consecutive locations in c ... array b. c c ... parameters -- c c n order of arrays ia and b c a array of source elements c ia integer array of length n giving desired c elements of array a c b target array of length n c c ... specifications for parameters c integer ia(1) dimension a(1), b(1) c if (n .le. 0) return do 10 i = 1,n 10 b(i) = a(ia(i)) c c205 b(1;n) = q8vgathr (a(1;n),ia(1;n);b(1;n)) cray1 call gather (n,b,a,ia) c return end subroutine vinv (nn,v) implicit double precision (a-h, o-z) c c ... vinv computes v = 1/v c c ... parameters -- c c n length of vector (= nn) c v input/output vector of length n. c c ... specifications for parameters c dimension v(1) c n = nn if (n .le. 0) return do 10 i = 1,n 10 v(i) = 1.0d0 / v(i) return end double precision function vmax (n,v) implicit double precision (a-h, o-z) c c ... vmax determaxes the maximum algebraic element of vector v. c c ... parameters -- c c n length of vector c v floating point vector of length n c c ... specifications for parameters c dimension v(1) c vmax = v(1) if (n .le. 1) return do i = 2,n if (v(i) .gt. vmax) vmax = v(i) enddo return end double precision function vmin (n,v) implicit double precision (a-h, o-z) c c ... vmin determines the minimum algebraic element of vector v. c c ... parameters -- c c n length of vector c v floating point vector of length n c c ... specifications for parameters c dimension v(1) c vmin = v(1) if (n .le. 1) return do i = 2,n if (v(i) .lt. vmin) vmin = v(i) enddo return end subroutine vscati (n,ja,ia,jb) implicit double precision (a-h, o-z) c c ... vscati scatters elements from consecutive locations in array c ... ja to positions in array jb according to index list ia. c c ... parameters -- c c n order of arrays ia and ja c ja integer array of source elements c ia integer array of length n giving new locations c in array jb. c jb integer target array c c ... specifications for parameters c integer ia(1), ja(1), jb(1) c if (n .le. 0) return do 10 i = 1,n 10 jb(ia(i)) = ja(i) c c205 jb(1;n) = q8vscatr (ja(1;n),ia(1;n);jb(1;n)) cray1 call scatter (n,jb,ia,ja) c return end subroutine vscatr (n,a,ia,b) implicit double precision (a-h, o-z) c c ... vscatr scatters elements from consecutive locations in array a c ... to positions in array b according to index list ia. c c ... parameters -- c c n order of arrays ia and a c a array of source elements c ia integer array of length n giving new locations c in array b c b target array c c ... specifications for parameters c integer ia(1) dimension a(1), b(1) c if (n .le. 0) return do 10 i = 1,n 10 b(ia(i)) = a(i) c c205 b(1;n) = q8vscatr (a(1;n),ia(1;n);b(1;n)) cray1 call scatter (n,b,ia,a) c return end subroutine vsubd (lda,ldja,nn,m,mdiagg,a,ja,y,x,jofff) implicit double precision (a-h, o-z) c c ... vsubd computes y = y - a*x c c (diagonal storage) c c ... parameters -- c c lda leading dimension of a array c ldja leading dimension of ja array c n active row size of matrix c m active column size of matrix c mdiag number of diagonals in a c a array of matrix diagonals c ja array of matrix diagonal numbers c y,x vectors of length n c joff offset for diagonal numbers c c ... specifications for parameters c dimension a(lda,3), x(1), y(1) integer ja(ldja,3) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c n = nn mdiag = mdiagg joff = jofff if (mdiag .lt. 1) return if (keyzer .eq. 1) go to 20 do 15 j = 1,mdiag ind = ja(1,j) - joff ist = max (1,1-ind) ied = min (n,m-ind) do 10 i = ist,ied 10 y(i) = y(i) - a(i,j)*x(i+ind) 15 continue return c c ... unrolled version (requires memory to be zeroed out). c 20 l = mod (mdiag,4) if (l .eq. 0) go to 60 c c ... initial short computations c go to (25,35,45), l 25 do 30 i = 1,n 30 y(i) = y(i) - a(i,1)*x(i+ja(1,1)-joff) go to 55 35 do 40 i = 1,n 40 y(i) = y(i) - a(i,1)*x(i+ja(1,1)-joff) - a(i,2)*x(i+ja(1,2)-joff) go to 55 45 do 50 i = 1,n 50 y(i) = y(i) - a(i,1)*x(i+ja(1,1)-joff) - a(i,2)*x(i+ja(1,2)-joff) a - a(i,3)*x(i+ja(1,3)-joff) 55 if (mdiag .le. 4) return c c ... loop unrolling to a level of 4. c 60 lp1 = l + 1 do 70 j = lp1,mdiag,4 do 65 i = 1,n 65 y(i) = y(i) - a(i,j )*x(i+ja(1,j )-joff) a - a(i,j+1)*x(i+ja(1,j+1)-joff) a - a(i,j+2)*x(i+ja(1,j+2)-joff) a - a(i,j+3)*x(i+ja(1,j+3)-joff) 70 continue return end subroutine vsubdt (lda,ldja,nn,m,mdiagg,a,ja,y,x,jofff) implicit double precision (a-h, o-z) c c ... vsubdt computes y = y - (a**t)*x c c (diagonal storage) c c ... parameters -- c c lda leading dimension of a array c ldja leading dimension of ja array c n active row size of matrix c m active column size of matrix c mdiag number of diagonals in a c a array of matrix diagonals c ja array of matrix diagonal numbers c y,x vectors of length n c joff offset for diagonal numbers c c ... specifications for parameters c dimension a(lda,3), x(1), y(1) integer ja(ldja,3) c n = nn mdiag = mdiagg joff = jofff if (mdiag .lt. 1) return do 15 j = 1,mdiag ind = ja(1,j) - joff ist = max (1,1-ind) ied = min (n,m-ind) do 10 i = ist,ied 10 y(i+ind) = y(i+ind) - a(i,j)*x(i) 15 continue return end subroutine vsubp (ndimr,ndimi,nn,mm,a,ja,y,x,wksp) implicit double precision (a-h, o-z) c c ... vsubp does y = y - a*x (purdue format) c c ... parameters -- c c ndimr row dimension of a array c ndimi row dimension of ja array c n order of system c m number of columns in a and ja arrays c a floating point array of active size n by m c ja integer array of active size n by m c y accumulation vector c x right-hand-side vector c wksp workspace vector of length n (keygs = 1 only) c c ... specifications for parameters c dimension a(ndimr,3), ja(ndimi,3), x(1), y(1), wksp(1) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c n = nn m = mm if (m .le. 0) return if (keygs .eq. 1) go to 100 c c ... implicit gathers. c l = mod (m,4) if (l .eq. 0) go to 45 c c ... initial short computations c go to (10,20,30), l 10 do 15 i = 1,n 15 y(i) = y(i) - a(i,1)*x(ja(i,1)) go to 40 20 do 25 i = 1,n 25 y(i) = y(i) - a(i,1)*x(ja(i,1)) - a(i,2)*x(ja(i,2)) go to 40 30 do 35 i = 1,n 35 y(i) = y(i) - a(i,1)*x(ja(i,1)) - a(i,2)*x(ja(i,2)) a - a(i,3)*x(ja(i,3)) 40 if (m .le. 4) return c c ... loop unrolling to a level of 4. c 45 lp1 = l + 1 do 55 j = lp1,m,4 do 50 i = 1,n 50 y(i) = y(i) - a(i,j)*x(ja(i,j)) - a(i,j+1)*x(ja(i,j+1)) a - a(i,j+2)*x(ja(i,j+2)) - a(i,j+3)*x(ja(i,j+3)) 55 continue return c c ... explicit gathers. c 100 do 110 j = 1,m call vgathr (n,x,ja(1,j),wksp) do 105 i = 1,n 105 y(i) = y(i) - a(i,j)*wksp(i) 110 continue return end subroutine vsubpt (ndimr,ndimi,n,m,a,ja,y,x,wksp) implicit double precision (a-h, o-z) c c ... vsubpt does y = y - (a**t)*x (purdue format) c c ... parameters -- c c ndimr row dimension of a array c ndimi row dimension of ja array c n order of system c m number of columns in a and ja arrays c a floating point array of active size n by m c ja integer array of active size n by m c y accumulation vector c x right-hand-side vector c wksp workspace vector of length n c c ... specifications for parameters c dimension a(ndimr,3), ja(ndimi,3), x(1), y(1), wksp(1) c if (m .le. 0) return c do 20 j = 1,m do 15 i = 1,n y(ja(i,j)) = y(ja(i,j)) - a(i,j)*x(i) 15 continue 20 continue return end subroutine vsubs (mm,np,ia,ja,a,y,x,wksp) implicit double precision (a-h, o-z) c c ... vsubs does y = y - a*x (sparse format) c c ... parameters -- c c m number of partitions c np partition pointers c ia vector of i values c ja vector of j values c a vector of coefficients c y accumulation vector c x right-hand-side vector c wksp workspace vector of length 2*n (keygs = 1 only) c c ... specifications for parameters c dimension np(1), a(1), ia(1), ja(1), x(1), y(1), wksp(1) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c m = mm if (m .le. 0) return if (keygs .eq. 1) go to 20 c c ... implicit gathers. c do 15 k = 1,m ist = np(k) ied = np(k+1) - 1 cdir$ ivdep do 10 i = ist,ied 10 y(ia(i)) = y(ia(i)) - a(i)*x(ja(i)) 15 continue return c c ... explicit gathers. c 20 do 30 k = 1,m ist = np(k) nel = np(k+1) - ist call vgathr (nel,x,ja(ist),wksp) call vgathr (nel,y,ia(ist),wksp(nel+1)) do 25 i = 1,nel 25 wksp(i) = wksp(nel+i) - a(ist+i-1)*wksp(i) call vscatr (nel,wksp,ia(ist),y) 30 continue return end subroutine vtriad (n,c,a,con,b,icode) implicit double precision (a-h, o-z) c c ... vtriad computes c = a + con*b if icode = 1 c c = con*b if icode = 2 c c ... parameters -- c c n length of vectors c c,a,b vectors of length n c con multiplicative constant c icode switch c c ... specifications for parameters c dimension a(1), b(1), c(1) c if (n .le. 0) return if (icode .eq. 2) go to 15 c c ... compute c = a + con*b c do 10 i = 1,n 10 c(i) = a(i) + con*b(i) return c c ... compute c = con*b c 15 do 20 i = 1,n 20 c(i) = con*b(i) return end subroutine vsqrt (n,v,w) implicit double precision (a-h, o-z) c c routine to compute square root of a matrix, w = sqrt(v) c dimension v(1), w(1) c do 1 i=1,n 1 w(i) = sqrt(v(i)) return end subroutine vifill (n, iv, ival) implicit double precision (a-h, o-z) c c routine to fill an integer vector with a value. c integer iv(1) if (n .le. 0) return do 1 i=1,n 1 iv(i) = ival return end subroutine vicopy (n,iv1,iv2) implicit double precision (a-h, o-z) c c routine to copy one integer vector to another. c integer iv1(1), iv2(1) if (n .le. 0) return do 1 i=1,n 1 iv2(i) = iv1(i) return end subroutine vemxty (nn,v,x,y) implicit double precision (a-h, o-z) c c ... vemxty computes v = -x * y where v, x, and y are vectors c c ... parameters -- c c n length of vectors (= nn) c v,x,y vectors of length n c c ... specifications for parameters c dimension v(1), x(1), y(1) c n = nn if (n .le. 0) return do 10 i = 1,n 10 v(i) = -x(i)*y(i) return end subroutine vsrta1 (nz,ia,ja,a) implicit double precision (a-h, o-z) c c imsl routine name - vsrta c c----------------------------------------------------------------------- c c purpose - sorting of the sparse data structure by c rows first and then by columns within c rows c c usage - call vsrta1 (nz,ia,ja,a) c c arguments ia - on input, ia contains the i values of c the array to be sorted. c on output, ia contains the i values of c the sorted array. c ja - on input, ja contains the j values of c the array to be sorted. c on output, ja contains the j values of c the sorted array. c a - on input, a contains the coefficients c of the array to be sorted. c on output, a contains the coefficients c of the sorted array. c nz - input variable containing the number of c elements in the array to be sorted. c c precision/hardware - single/all c c reqd. imsl routines - none required c c notation - information on special notation and c conventions is available in the manual c introduction or through imsl routine uhelp c c copyright - 1978 by imsl, inc. all rights reserved. c c warranty - imsl warrants only that imsl testing has been c applied to this code. no other warranty, c expressed or implied, is applicable. c c----------------------------------------------------------------------- c specifications for arguments integer ia(nz), ja(nz) dimension a(nz) c specifications for local variables integer iu(21),il(21) c logical lt, le, eq lt (i1,j1,i2,j2) = i1 .lt. i2 .or. (i1 .eq. i2 .and. j1 .lt. j2) le (i1,j1,i2,j2) = i1 .lt. i2 .or. (i1 .eq. i2 .and. j1 .le. j2) eq (i1,j1,i2,j2) = i1 .eq. i2 .and. j1 .eq. j2 c c first executable statement m = 1 i = 1 j = nz r = 0.375d0 if (nz .le. 0) return 10 if (i .eq. j) go to 55 if (r .gt. 0.5898437d0) go to 20 r = r + 3.90625d-2 go to 25 20 r = r - 0.21875d0 25 k = i c select a central element of the c array and save it in location t ij = int ( dble(i) + dble(j-i)*r ) t = a(ij) it = ia(ij) jt = ja(ij) c if first element of array is greater c than t, interchange with t if ( le(ia(i),ja(i),it,jt) ) go to 30 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) = t t = a(ij) 30 l = j c if last element of array is less than c t, interchange with t if (.not. lt(ia(j),ja(j),it,jt) ) go to 40 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) = t t = a(ij) c if first element of array is greater c than t, interchange with t if ( le(ia(i),ja(i),it,jt) ) go to 40 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) = t t = a(ij) go to 40 35 if ( eq(ia(l),ja(l),ia(k),ja(k)) ) go to 40 itt = ia(l) ia(l) = ia(k) ia(k) = itt jtt = ja(l) ja(l) = ja(k) ja(k) = jtt tt = a(l) a(l) = a(k) a(k) = tt c find an element in the second half of c the array which is smaller than t 40 l = l - 1 if (.not. le (ia(l),ja(l),it,jt) ) go to 40 c find an element in the first half of c the array which is greater than t 45 k = k + 1 if ( lt (ia(k),ja(k),it,jt) ) go to 45 c interchange these elements if (k .le. l) go to 35 c save upper and lower subscripts of c the array yet to be sorted if (l-i .le. j-k) go to 50 il(m) = i iu(m) = l i = k m = m + 1 go to 60 50 il(m) = k iu(m) = j j = l m = m + 1 go to 60 c begin again on another portion of c the unsorted array 55 m = m - 1 if (m .eq. 0) return i = il(m) j = iu(m) 60 if (j-i .ge. 11) go to 25 if (i .eq. 1) go to 10 i = i - 1 65 i = i + 1 if (i .eq. j) go to 55 it = ia(i+1) jt = ja(i+1) t = a(i+1) if ( le (ia(i),ja(i),it,jt) ) go to 65 k = i 70 ia(k+1) = ia(k) ja(k+1) = ja(k) a(k+1) = a(k) k = k - 1 if ( lt (it,jt,ia(k),ja(k)) ) go to 70 ia(k+1) = it ja(k+1) = jt a(k+1) = t go to 65 end subroutine zbrent (n,tri,eps,nsig,aa,bb,maxfnn,ier) implicit double precision (a-h, o-z) c modified imsl routine name - zbrent c c----------------------------------------------------------------------- c c computer - cdc/single c c latest revision - january 1, 1978 c c purpose - zero of a function which changes sign in a c given interval (brent algorithm) c c usage - call zbrent (f,eps,nsig,a,b,maxfn,ier) c c arguments tri - a tridiagonal matrix of order n c eps - first convergence criterion (input). a root, c b, is accepted if abs(f(b)) is less than or c equal to eps. eps may be set to zero. c nsig - second convergence criterion (input). a root, c b, is accepted if the current approximation c agrees with the true solution to nsig c significant digits. c a,b - on input, the user must supply two points, a c and b, such that f(a) and f(b) are opposite c in sign. (= aa, bb) c on output, both a and b are altered. b c will contain the best approximation to the c root of f. see remark 1. c maxfn - on input, maxfn should contain an upper bound c on the number of function evaluations c required for convergence. on output, maxfn c will contain the actual number of function c evaluations used. (= maxfnn) c ier - error parameter. (output) c terminal error c ier = 3 indicates the algorithm failed to c converge in maxfn evaluations. c ier = 4 indicates f(a) and f(b) have the c same sign. c c precision/hardware - single and double/h32 c - single/h36,h48,h60 c c c notation - information on special notation and c conventions is available in the manual c introduction or through imsl routine uhelp c c remarks 1. let f(x) be the characteristic function of the matrix c tri evaluated at x. function determ evaluates f(x). c on exit from zbrent, when ier=0, a and b satisfy the c following, c f(a)*f(b) .le. 0, c abs(f(b)) .le. abs(f(a)), and c either abs(f(b)) .le. eps or c abs(a-b) .le. max(abs(b),0.1)*10.0**(-nsig). c the presence of 0.1 in this error criterion causes c leading zeroes to the right of the decimal point to be c counted as significant digits. scaling may be required c in order to accurately determine a zero of small c magnitude. c 2. zbrent is guaranteed to reach convergence within c k = (dlog((b-a)/d)+1.0)**2 function evaluations where c d=min(over x in (a,b) of c max(abs(x),0.1)*10.0**(-nsig)). c this is an upper bound on the number of evaluations. c rarely does the actual number of evaluations used by c zbrent exceed sqrt(k). d can be computed as follows, c p = min (abs(a),abs(b)) c p = max (0.1,p) c if ((a-0.1)*(b-0.1).lt.0.0) p = 0.1 c d = p*10.0**(-nsig) c c copyright - 1977 by imsl, inc. all rights reserved. c c warranty - imsl warrants only that imsl testing has been c applied to this code. no other warranty, c expressed or implied, is applicable. c c----------------------------------------------------------------------- c c ... specifications for parameters c dimension tri(2,1) c c c ... local package references -- c c determ c first executable statement a = aa b = bb maxfn = maxfnn t = 0.1d0**nsig ic = 2 fa = determ(n,tri,a) fb = determ(n,tri,b) s = b c test for same sign if (fa*fb .gt. 0.0d0) go to 50 5 c = a fc = fa d = b - c e = d 10 if (abs (fc) .ge. abs (fb)) go to 15 a = b b = c c = a fa = fb fb = fc fc = fa 15 continue tol = t * max (abs (b),0.1d0) rm = (c - b)/2.0d0 c test for first convergence criteria if (abs (fb) .le. eps) go to 40 c test for second convergence criteria if (abs (c-b) .le. tol) go to 40 c check evaluation counter if (ic .ge. maxfn) go to 45 c is bisection forced if (abs (e) .lt. tol) go to 30 if (abs (fa) .le. abs (fb)) go to 30 s = fb/fa if (a .ne. c) go to 20 c linear interpolation p = (c - b)*s q = 1.0d0 - s go to 25 c inverse quadratic interpolation 20 q = fa/fc r = fb/fc rone = r - 1.0d0 p = s*((c - b)*q*(q - r) - (b - a)*rone) q = (q - 1.0d0)*rone*(s - 1.0d0) 25 if (p .gt. 0.0d0) q = -q if (p .lt. 0.0d0) p = -p s = e e = d c if abs(p/q).ge.75*abs(c-b) then c force bisection if (p + p .ge. 3.0d0*rm*q) go to 30 c if abs(p/q).ge.0.5d0*abs(s) then force c bisection. s = the value of p/q c on the step before the last one if (p + p .ge. abs (s*q)) go to 30 d = p/q go to 35 c bisection 30 e = rm d = e c increment b 35 a = b fa = fb temp = d if (abs (temp) .le. tol/2.0d0) temp = sign (tol/2.0d0,rm) b = b + temp s = b fb = determ(n,tri,s) ic = ic + 1 if (fb*fc .le. 0.0d0) go to 10 go to 5 c convergence of b 40 a = c maxfn = ic go to 9000 c maxfn evaluations 45 ier = 3 a = c maxfn = ic call ershow (ier,'zbrent') go to 9000 c terminal error - f(a) and f(b) have c the same sign 50 ier = 4 maxfn = ic call ershow (ier,'zbrent') 9000 continue aa = a bb = b maxfnn = maxfn return end subroutine dfault (iparm,rparm) implicit double precision (a-h, o-z) c c ... dfault sets the default values of iparm and rparm. c c ... parameters -- c c iparm c and c rparm arrays specifying options and tolerances c c c ... specifications for parameters c integer iparm(30) dimension rparm(30) c c *** begin -- package common c common / itcom4 / srelpr, keyzer, keygs c c *** end -- package common c c description of variables in common blocks in main routine c c srelpr - computer precision (approx.) c if installer of package does not know srelpr value, c an approximate value can be determined from a simple c fortran program such as c c srelpr = 1.0d0 c 2 srelpr = 0.5d0*srelpr c temp = srelpr + 1.0d0 c if (temp .gt. 1.0d0) go to 2 c srelpr = 2.0d0*srelpr c write (6,3) srelpr c 3 format (1x,'srelpr = ',d20.10) c stop c end c c c some values are- c c srelpr = 7.1d-15 for cray x-mp (approx.) 2**-47 c = 1.49d-8 for dec 10 (approx.) 2**-26 c = 1.192d-7 for vax 11/780 (approx) 2**-23 c = 4.768d-7 for ibm 370/158 c c *** should be changed for other machines *** c c to facilitate convergence, rparm(1) should be set to c 500.*srelpr or larger c c srelpr = 7.1d-15 c c ... keygs is a flag to specify how gather/scatter operations c are performed. c = 1 gather explicitly into a workspace vector c = 2 gather implicitly using indirect addressing c c keygs = 1 c c ... keyzer is a flag to specify if memory has been zeroed out. c i.e., is the operation 0.0 * indefinite = 0.0 legal c = 0 not legal c = 1 legal c keyzer = 0 c c iparm(1) = 2 iparm(2) = 100 iparm(3) = 0 iparm(4) = 6 iparm(5) = 0 iparm(6) = 1 iparm(7) = 1 iparm(8) = 1 iparm(9) = 5 iparm(10) = 100000 iparm(11) = 0 iparm(12) = 2 iparm(13) = 0 iparm(14) = 0 iparm(15) = 1 iparm(16) = 0 iparm(17) = 0 iparm(18) = 2 iparm(19) = -1 iparm(20) = -1 iparm(21) = 1 iparm(22) = 1 iparm(23) = 2 iparm(24) = 0 iparm(25) = 1 c rparm(1) = 1.0d-6 rparm(2) = 2.0d0 rparm(3) = 1.0d0 rparm(4) = 0.75d0 rparm(5) = 0.75d0 rparm(6) = 0.0d0 rparm(7) = 0.0d0 rparm(8) = 0.0d0 rparm(9) = 1.0d0 rparm(10) = 0.0d0 rparm(11) = 0.25d0 rparm(12) = 0.0d0 rparm(13) = 0.0d0 rparm(14) = 0.0d0 rparm(15) = 500.0d0*srelpr rparm(16) = 0.0d0 c return end double precision function timer (timdmy) implicit double precision (a-h, o-z) c c ... timer is a routine to return the execution time in c ... seconds. timer uses the fortran timing routine second. c c ... parameters -- c c timdmy dummy argument c c c note -- on many computer systems there is a cpu-time subprogram c which is more accurate than the fortran routine second. c c c use the following when using second c c timer = second (0.0) c c c ********************************************* c ** ** c ** this routine is not portable. ** c ** ** c ********************************************* c c ... specifications for parameters c c timer = dble (second ()) c c real tarray(2) c time = dble(etime (tarray)) c c call system_clock (count = icount, count_rate = irate) c timer = dble(icount) / dble(irate) c return end