subroutine adinfn ( nn, ndim, maxnzz, jcoef, coef, nstore, ainf, wksp ) !*****************************************************************************80 ! !! ADINFN computes an upper bound on the spectral radius of inverse(D)*A. ! ! Parameters: ! ! Input, integer NN, the order of the system. ! ! ndim row dimension of coef array in defining routine ! ! maxnz number of columns in coef array (= maxnzz) ! ! jcoef integer matrix representation array ! ! coef matrix representation array ! ! nstore matrix storage mode ! = 2 symmetric diagonal format ! = 3 nonsymmetric diagonal format ! ! ainf upper bound estimate upon output ! ! wksp workspace vector of length n ! implicit real ( kind = 8 ) ( a - h, o - z ) integer ndim real ( kind = 8 ) ainf real ( kind = 8 ) coef(ndim,*) integer i integer j integer jcoef(2) integer jd integer n integer nn real ( kind = 8 ) wksp(*) n = nn maxnz = maxnzz if ( 0.0D+00 < ainf ) then return end if wksp(1:n) = coef(1:n,1) do jd = 1, maxnz do j = 1, maxnz if ( jcoef(j) == jd ) then wksp(1:n) = wksp(1:n) - abs ( coef(1:n,j) ) if (nstore == 3) go to 25 do i = 1, n - jd wksp(i+jd) = wksp(i+jd) - abs (coef(i,j)) end do go to 25 end if end do exit 25 continue end do if ( nstore /= 2 ) then do jd = 1,maxnz do j = 1,maxnz if ( jcoef(j) == -jd ) then wksp(1:n) = wksp(1:n) - abs ( coef(1:n,j) ) go to 45 end if end do exit 45 continue end do end if ! ! Factor. ! t1 = vmin ( n, wksp ) if ( t1 <= 0.0D+00 ) then t1 = 1.0D+00 end if call ainfn ( n, ndim, maxnz, jcoef, coef, nstore, ainf, wksp ) ainf = ainf / t1 return end subroutine adjust ( n, ndim, maxnzz, jcoef, key ) !*****************************************************************************80 ! !! ADJUST makes adjustments to the JCOEF array. ! ! Parameters: ! ! Input, integer N, the dimension of the matrix. ! ! ndim row dimension of jcoef array in defining routine ! ! maxnz number of columns in jcoef array ! ! jcoef integer matrix representation array ! ! key indicator flag ! 1 remove zeros from jcoef array ! 2 restore zeros to jcoef array ! implicit real ( kind = 8 ) ( a - h, o - z ) integer ndim integer jcoef(ndim,1) maxnz = maxnzz if ( maxnz < 2 ) then return end if ! ! Change zero elements of JCOEF array. ! if ( key /= 2 ) then do j = 2, maxnz do i = 1, n if (jcoef(i,j) <= 0) then jcoef(i,j) = i end if end do end do ! ! Put original zeros back in JCOEF array. ! else do j = 2, maxnz do i = 1, n if ( jcoef(i,j) == i ) then jcoef(i,j) = 0 end if end do end do end if return end subroutine ainfn ( nn, ndim, maxnzz, jcoef, coef, nstore, ainf, wksp ) !*****************************************************************************80 ! !! AINFN calculates the infinity norm of a matrix. ! ! Parameters: ! ! Input, integer NN, the dimension of the matrix. ! ! ndim row dimension of coef array in defining routine ! maxnz number of columns in coef array (= maxnzz) ! jcoef integer matrix representation array ! coef matrix representation array ! nstore matrix storage mode ! = 1 Purdue format ! = 2 symmetric diagonal format ! = 3 nonsymmetric diagonal format ! = 4 symmetric sparse format ! = 5 nonsymmetric sparse format ! ainf the infinity norm of the matrix, //a//, upon ! output ! wksp workspace vector of length n ! implicit real ( kind = 8 ) ( a - h, o - z ) integer ndim real ( kind = 8 ) coef(ndim,1) integer jcoef(ndim,2) real ( kind = 8 ) wksp(1) n = nn maxnz = maxnzz if ( 0.0D+00 < ainf ) then return end if ! ! Ellpack data structure. ! if ( nstore == 1 ) then wksp(1:n) = abs ( coef(1:n,1) ) do j = 2, maxnz do i = 1, n wksp(i) = wksp(i) + abs ( coef(i,j) ) end do end do ! ! Symmetric diagonal data structure. ! else if ( nstore == 2 ) then wksp(1:n) = abs (coef(1:n,1)) do j = 2,maxnz ind = jcoef(j,1) len = n - ind wksp(1:len) = wksp(1:len) + abs (coef(1:len,j)) do i = 1,len wksp(i+ind) = wksp(i+ind) + abs (coef(i,j)) end do end do ! ! nonsymmetric diagonal data structure. ! else if ( nstore == 3 ) then wksp(1:n) = abs (coef(1:n,1)) do j = 2,maxnz ind = jcoef(j,1) len = n - iabs(ind) ist1 = max(1,1 - ind) ist2 = min(n,n - ind) do i = ist1,ist2 wksp(i) = wksp(i) + abs (coef(i,j)) end do end do ! ! symmetric sparse structure. ! else if ( nstore == 4 ) then wksp(1:n) = abs (coef(1:n,1)) do k = n+1,maxnz wksp(jcoef(k,1)) = wksp(jcoef(k,1)) + abs (coef(k,1)) end do do k = n+1,maxnz wksp(jcoef(k,2)) = wksp(jcoef(k,2)) + abs (coef(k,1)) end do ! ! nonsymmetric sparse structure. ! else if ( nstore == 5 ) then wksp(1:n) = abs (coef(1:n,1)) do k = n+1,maxnz wksp(jcoef(k,1)) = wksp(jcoef(k,1)) + abs (coef(k,1)) end do end if ! ! Determine ainf = max (wksp(i)). ! ainf = vmax ( n, wksp ) return end subroutine basic ( suba, subat, subql, subqlt, subqr, subqrt, subadp, & coef, jcoef, n, u, ubar, rhs, wksp, iwksp, iparm, rparm, ier ) !*****************************************************************************80 ! !! BASIC: user interface to basic unaccelerated iteration, with preconditioning. ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension u(1) dimension ubar(1), rhs(1), coef(1), jcoef(2) dimension wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax nw = lenr - irpnt + 1 call basicw ( suba,subql,subqr,coef,jcoef,wksp,iwksp,n,u,ubar,rhs, & wksp(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine basicw ( suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk, & nw,iparm,rparm,ier) !*****************************************************************************80 ! !! BASICW runs the basic (unaccelerated) iterative method, with preconditioning. ! ! Discussion: ! ! This routine applies the fixed point method to the preconditioned system. ! Two-sided preconditioning is efficiently implemented. ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2) dimension wfac(1), jwfac(1) logical iql, iqr external suba, subql, subqr dimension iparm(30), rparm(30) common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, & alphao, gamma, sigma, rr, rho, dkq, dkm1, & ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! Preliminary calculations ! iacel = 0 ier = 0 nwusd = 0 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 996 if (level >= 2) write (nout,496) 496 format (' basic') ! ! use knowledge about spectrum to optimally extrapolate. ! extrap = ( emax + emin ) / 2.0D+00 iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 ! ! Initialize the stopping test. ! call inithv (0) zthave = .true. nwpstp = nw call pstop (0,suba,subql,subqr, coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 735 ! ! Bust up workspace. ! izt = 1 iv1 = izt + n iwfree = iv1 + n if (iqlr == 0) iwfree = iv1 nwusd = max(nwusd,iwfree-1) ! ! Check the memory usage. ! if ( nwusd > nw ) go to 999 ! ! Do preliminary calculations. ! in = 0 is = 0 go to (151,152,153,154),iqlr + 1 151 call suba (coef,jcoef,wfac,jwfac,n,u,wk(izt)) call vexopy (n,wk(izt),rhs,wk(izt),2) go to 10 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 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 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 ! ! begin iteration loop. ! ! determine whether or not to stop. ! 10 continue call inithv (1) nwpstp = nw - (iwfree-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,wk(izt),wk(iwfree),nwpstp,ier) nwusd = max(nwusd,nwpstp+iwfree-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! ! Form iterate. ! call vtriad ( n, u, u, 1.0D+00 / extrap,wk(izt), 1 ) ! ! form residuals, as necessary. ! go to (161,162,163,164),iqlr + 1 ! 161 call suba (coef,jcoef,wfac,jwfac,n,u,wk(izt)) call vexopy (n,wk(izt),rhs,wk(izt),2) go to 110 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 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 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 ! ! proceed to next iteration ! 110 in = in + 1 is = is + 1 go to 10 ! ! finish up. ! 900 if (halt) go to 715 ier = 1 call ershow (ier,'basicw') zeta = stptst go to 725 715 continue if (level >= 1) write (nout,720) in 720 format (/' basic method converged in ',i5,' iterations.') 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! error returns ! 996 call ershow (ier,'basicw') go to 735 ! ! insuff. real wksp. 999 ier = -2 call ershow (ier,'basicw') go to 735 end subroutine bbs ( ndim, nn, maxt, t, x ) !*****************************************************************************80 ! !! BBS does a banded back substitution. ! ! Discussion: ! ! (i + t)*x = y. ! ! T is a rectangular matrix of adjacent super-diagonals. ! ! Parameters: ! ! ndim row dimension of t array in defining routine ! ! Input, integer NN, the dimension of the matrix. ! ! maxt number of columns in t array ! t array of active size n by maxt giving the super- ! diagonals in the order 1,2,3,... ! x on input, x contains y ! vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension t(ndim,1), x(1) n = nn do i = n-1,1,-1 sum = x(i) lim = min (maxt,n-i) do j = 1, lim sum = sum - t(i,j)*x(i+j) end do x(i) = sum end do return end subroutine bbsm ( nsize, nsys, maxt, t, x ) !*****************************************************************************80 ! !! BBSM does a banded back solve. ! ! Discussion: ! ! (i + t)*x = y. ! ! T is an array containing superdiagonals in order 1,2,... . ! ! Parameters: ! ! nsize size of a single subsystem ! nsys number of independent subsystems ! maxt number of columns in t array ! t array of active size n by maxt containing ! the super-diagonal elements of the factorization ! x on input, x contains y ! vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension t(nsize,nsys,1) dimension x(nsize,1) do i = nsize-1,1,-1 lim = min (nsize-i, maxt) do j = 1,lim ij = i + j do l = 1,nsys x(i,l) = x(i,l) - t(i,l,j)*x(ij,l) end do end do end do return end subroutine bbst ( ndim, nn, maxb, b, x ) !*****************************************************************************80 ! !! BBST does a banded backward substitution. ! ! Discussion: ! ! (i + (b**t))*x = y. ! ! The array b represents sub-diagonals. b corresponds ! to a banded system. ! ! Parameters: ! ! ndim row dimension of b in defining routine ! ! Input, integer NN, the dimension of the matrix. ! ! maxb number of diagonals stored in b ! b array of active size n x maxb giving the ! sub-diagonals in the order -1,-2,... . ! x on input, x contains y ! vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension b(ndim,1), x(1) n = nn do i = n, 2, -1 term = x(i) lim = min (i-1,maxb) do j = 1, lim x(i-j) = x(i-j) - b(i,j)*term end do end do return end subroutine bbstm ( nsize, nsys, maxb, b, x ) !*****************************************************************************80 ! !! BBSTM does the backward solve. ! ! Discussion: ! ! (i + (b**t))*x = y. ! ! B contains subdiagonals for multiple banded systems. ! ! Parameters: ! ! n order of system ! nsize the size of an individual subsystem ! nsys the number of subsystems ! maxb number of columns in b array ! b array of active size n by maxb containing ! sub-diagonals in the order -1,-2,-3,... ! x on input, x contains y ! vector containing solution upon output ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension b(nsize,nsys,1) dimension x(nsize,1) do i = nsize,2,-1 lim = min (i-1,maxb) do j = 1,lim do l = 1,nsys x(i-j,l) = x(i-j,l) - b(i,l,j)*x(i,l) end do end do end do return end subroutine bcgs ( suba, subat, subql, subqlt, subqr, subqrt, subadp, coef, & jcoef, n, u, ubar, rhs, wksp, iwksp, iparm, rparm, ier ) !*****************************************************************************80 ! !! BCGS is the user interface to the biconjugate-gradient-squared algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2) dimension wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax nw = lenr - irpnt + 1 call bcgsw (suba,subql,subqr,coef,jcoef,wksp,iwksp,n,u,ubar,rhs, & wksp(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine bcgsw ( suba, subql, subqr, coef, jcoef, wfac, jwfac, n, u, ubar, & rhs, wk, nw, iparm, rparm, ier ) !*****************************************************************************80 ! !! BCGSW runs the biconjugate-gradient-squared algorithm. ! ! Discussion: ! ! the algorithm is taken from "preconditioned biconjugate gradient ! methods for numerical reservoir simulation", by p. joly and r. ! eymard, to appear in journal of computational physics. the original ! reference is p. sonneveld, "cgs, a fast lanczos-type solver for ! unsymmetric linear systems," report 84-16, delft university of ! technology, dept. of mathematics and informatics. ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), wfac(1), jwfac(1) external suba, subql, subqr dimension iparm(30), rparm(30) logical iql, iqr common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, & alphao, gamma, sigma, rr, rho, dkq, dkm1, & ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav nwusd = 0 ier = 0 iacel = 15 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 997 if (level >= 2) write (nout,496) 496 format (' bcgs') iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 if (iqr) go to 995 ! ! initialize the stopping test. ! call inithv (0) zhave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 730 ! ! 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 ! ! check the memory usage. ! if (nwusd > nw) go to 999 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)) ! ! Begin iteration loop. ! ! Determine whether or not to stop. ! 10 continue call inithv (1) nwpstp = nw - (iv2-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,wk(iz),wk(izt),wk(iv2),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv2-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 if (in /= 0) go to 110 ! ! perform first-iterate calculations ! 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 ! ! perform subsequent-iterate calculations ! 110 r0rold = r0r r0r = vdot (n,wk(ir0),wk(iz)) if (abs(r0rold) < srelpr**2) go to 996 beta = r0r/r0rold ! ! form direction vectors. ! 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) ! ! Form the iterate. ! ! at this point we have the vectors p and q and the new dot(r,r0). ! now form aq. ! 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 ! ! dot(r0,aq). ! r0aq = vdot (n,wk(ir0),wk(iaq)) if (abs(r0aq) < srelpr**2) go to 998 alpha = r0r / r0aq ! ! 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) ! ! get u. ! call vtriad (n,u,u,alpha,wk(ippaaq),1) ! ! 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 ! ! proceed to next iteration ! in = in + 1 is = is + 1 go to 10 ! ! finish up. ! 900 if (halt) go to 715 ier = 1 call ershow (ier,'bcgsw') zeta = stptst go to 725 715 continue if (level >= 1) write (nout,720) in 720 format (/' bcgs converged in ',i5,' iterations.') ! 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! error returns ! 995 ier = -16 call ershow (ier,'bcgsw') go to 725 ! 996 ier = -13 call ershow (ier,'bcgsw') go to 725 ! 997 call ershow (ier,'bcgsw') go to 735 998 ier = -15 call ershow (ier,'bcgsw') go to 725 999 ier = -2 call ershow (ier,'bcgsw') go to 735 end subroutine bdfac ( lda, nn, nsizee, nt, nb, a, isym ) !*****************************************************************************80 ! !! BDFAC computes the factorization of a dense banded matrix. ! ! Parameters: ! ! lda leading dimension of array a ! n active size of array a ! nsize size of an individual subsystem (if multiple systems) ! nsize = n upon input if not a multiple system ! nt number of diagonals needed to store the super- ! diagonals ! nb number of diagonals needed to store the sub- ! diagonals ! a array ! isym symmetry switch ! = 0 matrix is symmetric ! = 1 matrix is nonsymmetric ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension a(lda,5) data lenv / 10 / ! n = nn maxt = nt nsize = nsizee nsys = n/nsize ! ! branch on symmetry. ! if (isym == 1) go to 30 ! ! symmetric case. ! ! diagonal case (maxt = 0). ! if (maxt /= 0) go to 15 a(1:n,1) = 1.0D+00 / a(1:n,1) return ! ! tridiagonal case (maxt = 1). ! 15 if (maxt /= 1) go to 20 if (nsys <= lenv) call tfac (n,a,a(1,2)) if (nsys > lenv) call tfacm (n,nsize,a,a(1,2)) return ! ! pentadiagonal case (maxt = 2). ! 20 if (maxt /= 2) go to 25 if (nsys <= lenv) call pfac (n,a,a(1,2),a(1,3)) if (nsys > lenv) call pfacm (n,nsize,a,a(1,2),a(1,3)) return ! ! banded case (maxt > 2). ! 25 if (nsys <= lenv) call bfac (lda,n,maxt,a,a(1,2)) if (nsys > lenv) call bfacm (n,nsize,nsys,maxt,a,a(1,2)) return ! ! nonsymmetric case. ! 30 maxb = nb ! ! diagonal case (maxt = maxb = 0). ! if (maxt /= 0 .or. maxb /= 0) go to 40 a(1:n,1) = 1.0D+00 / a(1:n,1) return ! ! tridiagonal case (maxt = maxb = 1). ! 40 if (maxt /= 1 .or. maxb /= 1) go to 45 if (nsys <= lenv) call tfacn (n,a,a(1,2),a(2,3)) if (nsys > lenv) call tfacnm (n,nsize,a,a(1,2),a(2,3)) return ! ! pentadiagonal case (maxt = maxb = 2). ! 45 if (maxt /= 2 .or. maxb /= 2) go to 50 if (nsys <= lenv) call pfacn (n,a,a(1,2),a(1,3),a(2,4),a(3,5)) if (nsys > lenv) call pfacnm (n,nsize,a,a(1,2),a(1,3),a(2,4),a(3,5)) return ! ! all other cases. ! 50 if (nsys <= lenv) call bfacn (lda,n,maxt,maxb,a,a(1,2),a(1,maxt+2)) if (nsys > lenv) call bfacnm (n,nsize,nsys,maxt,maxb,a,a(1,2),a(1,maxt+2)) return end subroutine bdinv ( lda, nn, nsizee, nt, nb, fac, isym ) !*****************************************************************************80 ! !! BDINV computes the inverse of a dense banded matrix. ! ! Parameters: ! ! lda leading dimension of factorization matrix fac ! n active size of factorization matrix fac ! nsize size of an individual subsystem (if multiple systems) ! nsize = n upon input if not a multiple system ! nt number of diagonals needed to store the super- ! diagonals ! nb number of diagonals needed to store the sub- ! diagonals ! fac array containing factorization upon input ! isym symmetry switch ! = 0 matrix is symmetric ! = 1 matrix is nonsymmetric ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension fac(lda,3) data lenv / 10 / n = nn maxt = nt nsize = nsizee nsys = n/nsize ! ! branch on symmetry. ! if (isym == 1) go to 30 ! ! symmetric case. ! if (maxt - 1) 10,20,25 ! ! diagonal case (maxt = 0). ! 10 return ! ! tridiagonal case (maxt = 1). ! 20 if (nsys <= lenv) call tinv (n,fac,fac(1,2)) if (nsys > lenv) call tinvm (n,nsize,fac,fac(1,2)) return ! ! banded case (maxt >= 2). ! 25 call binv (lda,n,maxt+1,fac) return ! ! nonsymmetric case. ! 30 maxb = nb ! ! diagonal case (maxt = maxb = 0). ! if (maxt /= 0 .or. maxb /= 0) go to 40 return ! ! tridiagonal case (maxt = maxb = 1). ! 40 continue if (maxt /= 1 .or. maxb /= 1) go to 45 if (nsys <= lenv) call tinvn (n,fac,fac(1,2),fac(2,3)) if ( lenv < nsys ) then call tinvnm (n,nsize,fac,fac(1,2),fac(2,3)) end if return ! ! all other cases. ! 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 ) !*****************************************************************************80 ! !! BDSOL computes the solution to a dense banded matrix. ! ! Discussion: ! ! thus, bdsol finds the solution to a*x = y, where fac ! contains the factorization of the a matrix. ! ! Parameters: ! ! lda leading dimension of array fac ! n active size of array fac ! nsize size of an individual subsystem (if multiple systems) ! nsize = n upon input if not a multiple system ! nt number of diagonals needed to store the super- ! diagonals of the factorization ! nb number of diagonals needed to store the sub- ! diagonals of the factorization ! fac array containing the factorization of the matrix ! y upon input, y conains the right hand side ! x upon output, x contains the solution to a*x = y ! isym symmetry switch ! = 0 matrix is symmetric ! = 1 matrix is nonsymmetric ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension fac(lda,5), x(1), y(1) data lenv / 10 / n = nn maxt = nt nsize = nsizee nsys = n/nsize ! ! branch on symmetry. ! if (isym == 1) go to 30 ! ! symmetric case. ! ! diagonal case (maxt = 0). ! if (maxt /= 0) go to 15 x(1:n) = fac(1:n,1) * y(1:n) return ! ! tridiagonal case (maxt = 1). ! 15 if (maxt /= 1) go to 20 if (nsys <= lenv) call tsoln (n,fac,fac(1,2),fac(1,2),y,x) if (nsys > lenv) call tsolnm (n,nsize,fac,fac(1,2),fac(1,2),y,x) return ! ! pentadiagonal case (maxt = 2). ! 20 if (maxt /= 2) go to 25 if (nsys <= lenv) call psoln (n,fac,fac(1,2),fac(1,3),fac(1,2),fac(1,3),y,x) if (nsys > lenv) then call psolnm (n,nsize,fac,fac(1,2),fac(1,3),fac(1,2),fac(1,3),y,x) end if return ! ! banded case (maxt >= 3). ! 25 if (nsys <= lenv) call bsol (lda,n,maxt,fac,fac(1,2),y,x) if (nsys > lenv) call bsolm (n,nsize,maxt,fac,fac(1,2),y,x) return ! ! nonsymmetric case. ! 30 maxb = nb ! ! diagonal case (maxt = maxb = 0). ! if (maxt /= 0 .or. maxb /= 0) go to 40 x(1:n) = fac(1:n,1) * y(1:n) return ! ! tridiagonal case (maxt = maxb = 1). ! 40 if (maxt /= 1 .or. maxb /= 1) go to 45 if (nsys <= lenv) call tsoln (n,fac,fac(1,2),fac(2,3),y,x) if (nsys > lenv) call tsolnm (n,nsize,fac,fac(1,2),fac(2,3), y,x) return ! ! pentadiagonal case (maxt = maxb = 2). ! 45 if (maxt /= 2 .or. maxb /= 2) go to 50 if (nsys <= lenv) call psoln (n,fac,fac(1,2),fac(1,3),fac(2,4),fac(3,5),y,x) if (nsys > lenv) then call psolnm (n,nsize,fac,fac(1,2),fac(1,3),fac(2,4),fac(3,5),y,x) end if return ! ! all other cases. ! 50 if (nsys <= lenv) then call bsoln (lda,n,maxt,maxb,fac,fac(1,2),fac(1,maxt+2),y,x) end if if (nsys > lenv) then call bsolnm (n,nsize,maxt,maxb,fac,fac(1,2),fac(1,maxt+2),y,x) end if return end subroutine bdsolt ( lda, nn, nsizee, nt, nb, fac, y, x ) !*****************************************************************************80 ! !! BDSOLT computes the transpose solution to a nonsymmetric dense banded matrix. ! ! Discussion: ! ! The routine solves A'*x = y, where FAC ! contains the factorization of the A matrix. ! ! Parameters: ! ! Input, integer LDA, the leading dimension of FAC. ! ! Input, integer NN, the active size of FAC. ! ! nsize size of an individual subsystem (if multiple systems) ! nsize = n upon input if not a multiple system ! nt number of diagonals needed to store the super- ! diagonals of the factorization ! nb number of diagonals needed to store the sub- ! diagonals of the factorization ! fac array containing the factorization of the matrix ! y upon input, y conains the right hand side ! x upon output, x contains the solution to a*x = y ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer nn ! dimension fac(lda,5) dimension x(nn) dimension y(nn) ! data lenv / 10 / ! n = nn maxt = nt maxb = nb nsize = nsizee nsys = n/nsize ! ! nonsymmetric case. ! ! diagonal case (maxt = maxb = 0). ! if (maxt /= 0 .or. maxb /= 0) go to 15 x(1:n) = fac(1:n,1) * y(1:n) return ! ! tridiagonal case (maxt = maxb = 1). ! 15 if (maxt /= 1 .or. maxb /= 1) go to 20 if ( nsys <= lenv ) then call tsoln (n,fac,fac(2,3),fac(1,2),y,x) else call tsolnm (n,nsize,fac,fac(2,3),fac(1,2),y,x) end if return ! ! pentadiagonal case (maxt = maxb = 2). ! 20 if (maxt /= 2 .or. maxb /= 2) go to 25 if (nsys <= lenv) then call psoln (n,fac,fac(2,4),fac(3,5),fac(1,2),fac(1,3),y,x) else call psolnm (n,nsize,fac,fac(2,4),fac(3,5),fac(1,2),fac(1,3),y,x) end if return ! ! all other cases. ! 25 continue if ( nsys <= lenv ) then call bsolnt (lda,n,maxt,maxb,fac,fac(1,2),fac(1,maxt+2),y,x) else call bsontm (n,nsize,maxt,maxb,fac,fac(1,2),fac(1,maxt+2),y,x) end if return end subroutine bfac ( ndim, nn, maxt, d, t ) !*****************************************************************************80 ! !! BFAC computes a factorization to a single banded symmetric matrix. ! ! Parameters: ! ! ndim row dimension of t array in defining routine ! n order of system (= nn) ! maxt number of columns in t array ! d vector containing the diagonal elements of a ! t array of active size n by maxt containing the ! super-diagonals in the order 1,2,3,... ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension d(1) dimension t(ndim,1) n = nn nm1 = n - 1 do k = 1, nm1 pivot = d(k) lim = min (n-k,maxt) do j1 = 1,lim term = t(k,j1)/pivot jcol1 = k + j1 d(jcol1) = d(jcol1) - term*t(k,j1) j1p1 = j1 + 1 do j2 = j1p1,lim jcol2 = j2 - j1 t(jcol1,jcol2) = t(jcol1,jcol2) - term*t(k,j2) end do end do end do d(1:n) = 1.0D+00 / d(1:n) do j = 1,maxt len = n - j t(1:len,j) = d(1:len) * t(1:len,j) end do return end subroutine bfacm ( n, nsize, nsys, maxt, d, t ) !*****************************************************************************80 ! !! BFACM computes factorizations to multiple banded symmetric matrices. ! ! ! Parameters: ! ! n order of global system (= nn) ! nsize order of a single system ! nsys number of independent subsystems ! maxt number of columns in t array ! d vector of length n containing the diagonal ! elements of a ! t array of active size n by maxt containing the ! super-diagonals in the order 1,2,3,... ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension d(nsize,1), t(nsize,nsys,1) ! nsm1 = nsize - 1 do k = 1,nsm1 lim = min (nsize-k,maxt) do j1 = 1,lim jcol1 = k + j1 do l = 1,nsys d(jcol1,l) = d(jcol1,l) - (t(k,l,j1)**2)/d(k,l) end do j1p1 = j1 + 1 do j2 = j1p1,lim jcol2 = j2 - j1 do l = 1,nsys t(jcol1,l,jcol2) = t(jcol1,l,jcol2) - t(k,l,j1)*t(k,l,j2)/d(k,l) end do end do end do end do call vinv (n,d) do jj = 1,maxt len = n - jj call vexopy (len,t(1,1,jj),d,t(1,1,jj),3) end do return end subroutine bfacmy ( methf, factor, coef, jcoef, wksp, iwksp, nn, ier ) !*****************************************************************************80 ! !! BFACMY computes a block factorization. (multicolor nonsymmetric diagonal) ! ! parameters ! ! n order of system ! nfactr amount of real workspace needed for factorization ! ier error flag ! ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external factor common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, & ifact, kblsz, lvfill, ltrunc, ndeg, & 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, jcnew, lbhb, iblock, & ncmax logical omgadp common / itcom5 / omgadp common / itcom55 / omega, alphab, betab, fff, specr dimension coef(1), wksp(1) integer jcoef(2), iwksp(1) n = nn if (methf <= 2) ivers = 1 if (methf > 2) ivers = 2 ! ! calculate constants. ! if (ipropa == 0) propa = .false. if (ipropa == 1) propa = .true. ! ! calculate fill-in and factor. ! call fillbc (n,ncolor,coef,jcoef,iwksp(iblock),wksp,iwksp,ier) if (ier < 0) return nwdiag = ndt + ndb + 1 nwnew = nwdiag + 2*ltrunc if (methf == 1) nwkp = ncmax*nwnew if (methf == 2) nwkp = ncmax*(nwnew + 1) if (methf == 3) nwkp = 0 if (methf == 4) nwkp = n + 2*ncmax call needw ('bfacmy',0,irpnt,nwkp,ier) if (ier < 0) return if (propa) then call factor (n,ndim,n,iwksp(iipnt),iwksp(jcnew+ncolor*nwdiag), & wksp(ifactr),coef(ndim*nwdiag+1),ncolor, & iwksp(nc),iwksp(iblock),iwksp(lbhb),0,1, & iwksp(ipt),omega,wksp(irpnt),ier) else call factor (n,n,n,iwksp(iipnt),iwksp(jcnew+ncolor*nwdiag), & wksp(ifactr),wksp(iwkpt2),ncolor,iwksp(nc),iwksp(iblock), & iwksp(lbhb),0,0,iwksp(ipt),omega,wksp(irpnt),ier) end if return end subroutine bfacmz ( methf, factor, coef, jcoef, wksp, iwksp, nn, ier ) !*****************************************************************************80 ! !! BFACMZ computes a block factorization. (nonsymmetric diagonal) ! ! parameters ! ! n order of system ! nfactr amount of real workspace needed for factorization ! ier error flag ! ! ! implicit real ( kind = 8 ) ( a - h, o - z ) external factor common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, 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, jcnew, lbhb, & iblock, ncmax logical omgadp common / itcom5 / omgadp common / itcom55 / omega, alphab, betab, fff, specr dimension coef(1), wksp(1) integer idumb(3), jcoef(2), iwksp(1) n = nn if (methf <= 2) ivers = 1 if (methf > 2) ivers = 2 ! ! if requested, find out if matrix has block property a. ! ncol = n/kblsz if (ipropa == 0) propa = .false. if (ipropa == 1) propa = .true. if (lvfill > 0) propa = .false. if (lvfill > 0) go to 15 if (ipropa /= 2) go to 15 call needw ('bfacmz',1,iipnt,2*ncol,ier) if (ier < 0) return iwksp(iipnt) = lbhb call prbblk (ncol,1,iwksp(iblock),iwksp(iipnt),iwksp(iipnt+1), & iwksp(iipnt+ncol+1),propa) if (propa) ipropa = 1 if (.not. propa) ipropa = 0 ! ! calculate fill-in and factor. ! 15 call fillbn (n,coef,jcoef,iwksp(iblock),wksp,iwksp,ier) if (ier < 0) return nwnew = iwksp(iblock+2) + iwksp(iblock+5) nwdiag = nwnew - 2*ltrunc if (methf == 1) nwkp = kblsz*nwnew if (methf == 2) nwkp = kblsz*(nwnew + 1) if (methf == 3) nwkp = 0 if (methf == 4) nwkp = n + 2*kblsz call needw ('fillbn',0,irpnt,nwkp,ier) if (ier < 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),wksp(ifactr), & coef(ndim*nwdiag+1),1,idumb(1),iwksp(iblock),idumb(3),1,1, & idumb(2),omega,wksp(irpnt),ier) end if if (.not. propa .and. lvfill == 0) then call factor (n,n,n,iwksp(iipnt),jcoef(nwdiag+1),wksp(ifactr), & wksp(iwkpt2),1,idumb(1),iwksp(iblock),idumb(3),1,0, & idumb(2),omega,wksp(irpnt),ier) end if if (lvfill > 0) then call factor (n,n,n,iwksp(ipt1),iwksp(ipt2),wksp(ifactr),wksp(iwkpt2),1, & idumb(1),iwksp(iblock),idumb(3),1,0,idumb(2),omega,wksp(irpnt),ier) end if return end subroutine bfacn ( ndim, nn, maxt, maxb, d, t, b ) !*****************************************************************************80 ! !! BFACN computes a factorization to a single banded nonsymmetric matrix. ! ! Parameters: ! ! ndim row dimension of t and b in defining routine ! n order of system (= nn) ! maxt number of diagonals stored in t ! maxb number of diagonals stored in b ! d vector of length n containing the diagonal ! elements of a ! t array of active size n x maxt giving the ! super-diagonals in the order 1,2,3,... ! b array of active size n x maxb giving the ! sub-diagonals in the order -1,-2,-3,... ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension d(1), t(ndim,1), b(ndim,1) n = nn nm1 = n - 1 do k = 1,nm1 pivot = d(k) liml = min (maxb,n-k) limu = min (maxt,n-k) do ip = 1,liml i = k + ip term = b(i,ip)/pivot do jp = 1,limu term1 = term*t(k,jp) l = jp - ip if ( l < 0 ) then b(i,-l) = b(i,-l) - term1 else if ( l == 0 ) then d(i) = d(i) - term1 else if ( 0 < l ) then t(i,l) = t(i,l) - term1 end if end do end do end do d(1:n) = 1.0D+00 / d(1:n) do j = 1,maxt len = n - j t(1:len,j) = d(1:len) * t(1:len,j) end do do j = 1,maxb len = n - j do i = 1,len b(i+j,j) = d(i)*b(i+j,j) end do end do return end subroutine bfacnm ( nn, nsize, nsys, maxt, maxb, d, t, b ) !*****************************************************************************80 ! !! BFACNM computes a factorization to multiple banded nonsymmetric matrices. ! ! Parameters: ! ! nsize size of a subsystem ! nsys number of independent subsystems ! maxt number of diagonals stored in t ! maxb number of diagonals stored in b ! n order of system (= nn) ! d vector of length n containing the diagonal ! elements of a ! t array of active size n x maxt giving the ! super-diagonals in the order 1,2,3,... ! b array of active size n x maxb giving the ! sub-diagonals in the order -1,-2,-3,... ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension d(nsize,1), t(nsize,nsys,1), b(nsize,nsys,1) 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 m = 1,nsys b(i,m,-l) = b(i,m,-l) - b(i,m,ip)*t(k,m,jp)/d(k,m) end do go to 40 20 do m = 1,nsys d(i,m) = d(i,m) - b(i,m,ip)*t(k,m,jp)/d(k,m) end do go to 40 30 continue do m = 1,nsys t(i,m,l) = t(i,m,l) - b(i,m,ip)*t(k,m,jp)/d(k,m) end do 40 continue 45 continue 50 continue call vinv (n,d) do j = 1,maxt len = n - j call vexopy (len,t(1,1,j),d,t(1,1,j),3) end do do j = 1,maxb len = n - j call vexopy (len,b(j+1,1,j),d,b(j+1,1,j),3) end do return end subroutine bfacs ( methf, factor, coef, jcoef, wksp, iwksp, nn, ier ) !*****************************************************************************80 ! !! BFACS computes a block factorization. (symmetric diagonal) ! ! parameters ! ! n order of system ! nfactr amount of real workspace needed for factorization ! ier error flag ! ! ! implicit real ( kind = 8 ) ( a - h, o - z ) external factor common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, 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, jcnew, lbhb, & iblock, ncmax logical omgadp common / itcom5 / omgadp common / itcom55 / omega, alphab, betab, fff, specr integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) n = nn if (methf <= 2) ivers = 1 if (methf > 2) ivers = 2 ! ! if requested, find out if matrix has block property a. ! ncol = n/kblsz if (ipropa == 0) propa = .false. if (ipropa == 1) propa = .true. if (lvfill > 0) propa = .false. if (lvfill > 0) go to 15 if (ipropa /= 2) go to 15 call needw ('bfacs',1,iipnt,2*ncol,ier) if (ier < 0) return iwksp(iipnt) = lbhb call prbblk (ncol,1,iwksp(iblock),iwksp(iipnt), iwksp(iipnt+1), & iwksp(iipnt+ncol+1),propa) if (propa) ipropa = 1 if (.not. propa) ipropa = 0 ! ! calculate fill-in and factor. ! 15 call fillb (n,coef,jcoef,iwksp(iblock),wksp,iwksp,ier) if (ier < 0) return nwnew = iwksp(iblock+2) nwdiag = nwnew - ltrunc if (methf == 1) nwkp = kblsz*nwnew if (methf == 2) nwkp = kblsz*(nwnew + 1) if (methf == 3) nwkp = 0 if (methf == 4) nwkp = n + 2*kblsz call needw ('fillb',0,irpnt,nwkp,ier) if (ier < 0) return ipt1 = iblock + 3*lbhb ipt2 = ipt1 + nwnew if (propa) then call factor (n,ndim,n,iwksp(iipnt),jcoef(nwdiag+1),wksp(ifactr), & coef(ndim*nwdiag+1),kblsz,iwksp(iblock),lbhb,1,omega,wksp(irpnt),ier) end if if (.not. propa .and. lvfill == 0) then call factor (n,n,n,iwksp(iipnt),jcoef(nwdiag+1),wksp(ifactr), & wksp(iwkpt2),kblsz,iwksp(iblock),lbhb,0,omega,wksp(irpnt),ier) end if if (lvfill > 0) then call factor (n,n,n,iwksp(ipt1),iwksp(ipt2),wksp(ifactr),wksp(iwkpt2), & kblsz,iwksp(iblock),lbhb,0,omega,wksp(irpnt),ier) end if return end subroutine bfs ( ndim, nn, maxb, b, x ) !*****************************************************************************80 ! !! BFS does a forward substitution. ! ! (i + b)*x = y. ! ! ! The array b represents sub-diagonals. b corresponds to a banded system. ! ! Parameters: ! ! ndim row dimension of b in defining routine ! n order of system (= nn) ! maxb number of diagonals stored in b ! b array of active size n x maxb giving the ! sub-diagonals in the order -1,-2,-3,... . ! x on input, x contains y ! vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension b(ndim,1) real ( kind = 8 ) x(1) n = nn do i = 2,n lim = min (i-1,maxb) sum1 = x(i) do j = 1,lim sum1 = sum1 - b(i,j)*x(i-j) end do x(i) = sum1 end do return end subroutine bfsm ( nsize, nsys, maxb, b, x ) !*****************************************************************************80 ! !! BFSM does the forward solve. ! ! (i + b)*x = y. ! ! B contains subdiagonals for multiple banded systems. ! ! Parameters: ! ! n order of system ! nsize the size of an individual subsystem ! nsys the number of subsystems ! maxb number of columns in b array ! b array of active size n by maxb containing ! sub-diagonals in the order -1,-2,-3,... . ! x on input, x contains y ! vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension b(nsize,nsys,1) dimension x(nsize,1) do i = 2,nsize lim = min (i-1,maxb) do j = 1,lim do l = 1,nsys x(i,l) = x(i,l) - b(i,l,j)*x(i-j,l) end do end do end do return end subroutine bfst ( ndim, nn, maxt, t, x ) !*****************************************************************************80 ! !! BFST does a banded forward substitution. ! ! (i + (t**t))*x = y. ! ! ! t is a rectangular matrix of adjacent super-diagonals. ! ! Parameters: ! ! ndim row dimension of t array in defining routine ! n order of system ! maxt number of columns in t array ! t array of active size n by maxt giving the super- ! diagonals in the order 1,2,3,... ! x on input, x contains y ! vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension t(ndim,1), x(1) n = nn nm1 = n - 1 do i = 1,nm1 term = x(i) lim = min (maxt,n-i) do j = 1,lim x(i+j) = x(i+j) - t(i,j)*term end do end do return end subroutine bfstm ( nsize, nsys, maxt, t, x ) !*****************************************************************************80 ! !! BFSTM does a forward solve. ! ! (i + (t**t))*x = y. ! ! ! T is an array containing superdiagonals in order 1,2,... . ! (multiple systems) ! ! Parameters: ! ! n order of system ! nsize size of a single subsystem ! nsys number of independent subsystems ! maxt number of columns in t array ! t array of active size n by maxt containing ! the super-diagonal elements of the factorization ! x on input, x contains y ! vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension t(nsize,nsys,1), x(nsize,1) nsm1 = nsize - 1 do i = 1,nsm1 lim = min (maxt,nsize-i) do j = 1,lim ij = i + j do l = 1,nsys x(ij,l) = x(ij,l) - t(i,l,j)*x(i,l) end do end do end do return end subroutine bic2 ( accel, coef, jcoef, n, u, ubar, rhs, wksp, iwksp, iparm, & rparm, ier ) !*****************************************************************************80 ! !! BIC2 drives the block factorization (version 1) method. ! implicit real ( kind = 8 ) ( a - h, o - z ) 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) common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call bfacs (1,ibfcs1,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + kblsz if (ier < 0) return call split (accel,suba1,suba1,subq25,subq25,subq25,subq25,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - kblsz return end subroutine bic3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) !*****************************************************************************80 ! !! BIC3 drives the block factorization (version 1) method. ! implicit real ( kind = 8 ) ( a - h, o - z ) external accel, suba4, suba5, subq70, subq71, subq72, subq73, subq74 external subq75, noadp external ibfcn1 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call bfacmz (1,ibfcn1,coef,jcoef,wksp,iwksp, n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*kblsz call split (accel,suba4,suba5,subq70,subq71,subq72,subq73,subq74,subq75, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*kblsz return end subroutine bic7 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) !*****************************************************************************80 ! !! BIC7 drives the block factorization method. (multi-color ordering) ! implicit real ( kind = 8 ) ( a - h, o - z ) external accel, suba2, suba3, subq34, subq35, subq36 external 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) common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, jcnew, lbhb, & iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 t1 = timer (dummy) if (ifact == 1) call bfacmy (1,ibfcn1,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*ncmax call split (accel,suba2,suba3,subq34,subq35,subq36,subq37,subq38,subq39, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*ncmax return end subroutine bicol (n,nz,ia,ja,count,father,oppos,propa) !*****************************************************************************80 ! !! BICOLOR determines whether or not a matrix is bi-colorable. ! ! The matrix is represented in the sparse (ia,ja) format is bi-colorable. ! the algorithm used is the union-find algorithm. ! ! Parameters: ! ! n number of vertices ! nz number of edges (length of ia and ja vectors) ! ia integer vector of i values ! ja integer vector of j values ! count integer workspace vectors of length n each ! father upon output, count gives the color of each node ! oppos ! propa logical variable indicating on output whether ! matrix has property a ! implicit real ( kind = 8 ) ( a - h, o - z ) logical propa integer ia(1), ja(1), count(1), father(1), oppos(1) integer v, w, w0, a, b, c, d count(1:n) = 1 father(1:n) = 0 oppos(1:n) = 0 do 60 k = 1,nz if (ia(k) == ja(k)) go to 60 ! ! a = find (ia(k)). ! v = ia(k) 15 if (father(v) == 0) go to 20 v = father(v) go to 15 20 w = ia(k) 25 if (father(w) == 0) go to 30 w0 = w w = father(w) father(w0) = v go to 25 30 a = v ! ! b = find (ja(k)). ! v = ja(k) 35 if (father(v) == 0) go to 40 v = father(v) go to 35 40 w = ja(k) 45 if (father(w) == 0) go to 50 w0 = w w = father(w) father(w0) = v go to 45 50 b = v ! ! test for a = b. ! if (a /= b) go to 55 propa = .false. return ! ! do unioning. ! 55 if (oppos(a) == b) go to 60 if (oppos(b) == 0) then c = a else ! ! c = merge (a,oppos(b)). ! i = a j = oppos(b) if (count(i) >= 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 end if end if if (oppos(a) == 0) then d = b else ! ! d = merge (b,oppos(a)). ! i = b j = oppos(a) if (count(i) >= 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 end if end if oppos(c) = d oppos(d) = c 60 continue ! ! do coloring. ! count(1:n) = 0 do 90 i = 1,n ! ! a = find(i). ! v = i 70 if (father(v) == 0) go to 75 v = father(v) go to 70 75 w = i 80 if (father(w) == 0) go to 85 w0 = w w = father(w) father(w0) = v go to 80 85 a = v if (count(a) == 0) then count(a) = 1 count(i) = 1 j = oppos(a) if (j /= 0) count(j) = 2 else count(i) = count(a) end if 90 continue propa = .true. return end subroutine bicx2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) !*****************************************************************************80 ! !! BICX2 drives the block factorization (version 2) method. ! implicit real ( kind = 8 ) ( a - h, o - z ) 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) common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call bfacs (3,ibfcs2,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + kblsz if (ier < 0) return call split (accel,suba1,suba1,subq25,subq25,subq25,subq25,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - kblsz return end subroutine bicx3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) !*****************************************************************************80 ! !! BICX3 drives the block factorization (version 2) method. ! implicit real ( kind = 8 ) ( a - h, o - z ) external accel, suba4, suba5, subq70, subq71, subq72 external 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) common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call bfacmz (3,ibfcn2,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*kblsz call split (accel,suba4,suba5,subq70,subq71,subq72,subq73,subq74,subq75, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*kblsz return end subroutine bicx7 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) !*****************************************************************************80 ! !! BICX7 drives the block factorization (v2) method (multi-color ordering) ! implicit real ( kind = 8 ) ( a - h, o - z ) external accel, suba2, suba3, subq34, subq35, subq36 external 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) common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, jcnew, lbhb, & iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 t1 = timer (dummy) if (ifact == 1) call bfacmy (3,ibfcn2,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*ncmax call split (accel,suba2,suba3,subq34,subq35,subq36,subq37,subq38,subq39, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*ncmax return end subroutine binv (ndim,nn,maxnz,fact) !*****************************************************************************80 ! !! BINV computes an approximate inverse to a single banded symmetric matrix. ! ! fact must contain upon input the output from a factorization routine. ! ! Parameters: ! ! ndim row dimension of fact in the defining routine ! n order of system (= nn) ! maxnz bandwidth of the factorization and inverse ! fact array containing factorization diagonals ! in the order 0,1,2,3,... ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension fact(ndim,2) n = nn nm1 = n - 1 ! ! general banded matrix. ! do ik = 1,nm1 k = n - ik lim = min (ik+1,maxnz) sum1= 0.0D+00 do i = 2,lim t1 = fact(k,i) sum2 = 0.0D+00 do 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) end do fact(n,i) = sum2 sum1 = sum1 - t1*sum2 end do fact(k,1) = fact(k,1) + sum1 fact(k,2:lim) = fact(n,2:lim) end do fact(n,2:maxnz)= 0.0D+00 return end subroutine binvn (ndim,nn,maxt,maxb,d,t,b) !*****************************************************************************80 ! !! BINVN computes an approximate inverse to a banded nonsymmetric matrix. ! ! d, t, and b must contain upon input ! the output from a factorization routine. ! ! Parameters: ! ! ndim row dimension of t and b in the defining routine ! n order of system (= nn) ! maxt number of columns in t ! maxb number of columns in b ! d vector of length n containing the diagonal ! elements of the factorization ! t array of active size n by maxt containing ! the superdiagonals of the factorization ! in the order 1,2,3,... ! b array of active size n by maxb containing ! the subdiagonals of the factorization ! in the order -1,-2,-3,.... ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension d(1), t(ndim,1), b(ndim,1) n = nn nm1 = n - 1 ! ! general banded matrix. ! do 75 ik = 1,nm1 k = n - ik ! ! copy kth row and column into wksp. ! limr = min (maxt,ik) limc = min (maxb,ik) t(n,1:limr) = t(k,1:limr) do j = 1,limc b(1,j) = b(k+j,j) end do ! ! do computations for kth row. ! do 40 j = 1,limr sum= 0.0D+00 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 ! ! do computations for kth column. ! do 65 j = 1,limc sum= 0.0D+00 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 ! ! compute kth diagonal element. ! sum = d(k) lim = min (limr,limc) do j = 1,lim sum = sum - t(n,j)*b(k+j,j) end do d(k) = sum 75 continue ! ! zero out workspace rows. ! t(n,1:maxt)= 0.0D+00 b(1,1:maxb)= 0.0D+00 return end subroutine blkdef (coef,jcoef,wksp,iwksp,nn,ier) !*****************************************************************************80 ! !! BLKDEF defines various block constants for a constant block size matrix. ! ! Parameters: ! ! n problem size ! implicit real ( kind = 8 ) ( a - h, o - z ) 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, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, jcnew, lbhb, & iblock, ncmax integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) n = nn call needw ('blkdef',1,iipnt,3*(maxnz+1),ier) if (ier < 0) return call move5 (ndim,n,maxnz,jcoef,coef) if (ifact == 0) return ifacti = iipnt iblock = ifacti call defcon (ndim,n,maxnz,jcoef,coef,kblsz,iwksp(ifacti),lbhb) nfacti = 3*lbhb iipnt = ifacti + 3*lbhb return end subroutine bmul (ndim,n,maxt,d,t,x,y) !*****************************************************************************80 ! !! BMUL computes y = A*x, where A is a banded symmetric matrix. ! ! Parameters: ! ! ndim row dimension of array t ! n order of matrix ! maxt number of columns in t ! d vector of length n giving the ! diagonal elements of a ! t array of size n by maxt giving the ! superdiagonals of a in the order ! 1,2,.... ! x,y vectors of order n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension d(1), t(ndim,1), x(1), y(1) y(1:n) = d(1:n) * x(1:n) do la = 1,maxt len = n - la do i = 1,len y(i) = y(i) + t(i,la)*x(i+la) end do do i = 1,len y(i+la) = y(i+la) + t(i,la)*x(i) end do end do return end subroutine bmuln (ndim,n,maxt,maxb,d,t,b,x,y) !*****************************************************************************80 ! !! BMULN computes y = A*x, where A is in nonsymmetric band format. ! ! A is represented by arrays d, t, and b. ! ! Parameters: ! ! ndim row dimension of arrays t and b ! n order of array a ! maxt number of columns in t array ! maxb number of columns in b array ! d vector of length n giving the diagonal ! elements of a ! t array of active size n by maxt giving ! the super-diagonals of a in the order ! 1,2,3,... ! b array of active size n by maxb giving ! the sub-diagonals of a in the order ! -1,-2,-3,.... ! x,y vectors of order n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) real ( kind = 8 ) b(ndim,1) real ( kind = 8 ) d(1) real ( kind = 8 ) t(ndim,1) real ( kind = 8 ) x(1) real ( kind = 8 ) y(1) y(1:n) = d(1:n) * x(1:n) do j = 1,maxt len = n - j y(1:len) = y(1:len) + t(1:len,j)*x(1+j:len+j) end do do j = 1,maxb len = n - j do i = 1,len y(i+j) = y(i+j) + b(i+j,j)*x(i) end do end do return end subroutine bmulnt (ndim,n,maxt,maxb,d,t,b,x,y) !*****************************************************************************80 ! !! BMULNT computes y = (A**t)*x, where A is in nonsymmetric band format. ! ! A is represented by d, t, and b. ! ! Parameters: ! ! ndim row dimension of arrays t and b ! n order of array a ! maxt number of columns in t array ! maxb number of columns in b array ! d vector of length n giving the diagonal ! elements of a ! t array of active size n by maxt giving ! the super-diagonals of a in the order ! 1,2,3,... ! b array of active size n by maxb giving ! the sub-diagonals of a in the order ! -1,-2,-3,... ! x,y vectors of order n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension b(ndim,1) dimension d(1) dimension t(ndim,1) dimension x(1) dimension y(1) y(1:n) = d(1:n) * x(1:n) do j = 1, maxt len = n - j do i = 1, len y(i+j) = y(i+j) + t(i,j) * x(i) end do end do do j = 1, maxb len = n - j do i = 1, len y(i) = y(i) + b(i+j,j) * x(i+j) end do end do return end subroutine bsol ( ndim, nn, maxt, d, t, y, x ) !*****************************************************************************80 ! !! BSOL solves A*x = y for a banded and symmetric matrix A. ! ! Discussion: ! ! D and T must contain upon input the factorization arrays from BFAC. ! ! Parameters: ! ! ndim row dimension of t array in defining routine ! n order of system ! maxt number of columns in t array ! d vector of length n containing the diagonal ! pivots of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization in the order ! 1,2,3,... ! y right-hand-side vector ! x vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) real ( kind = 8 ) d(1) dimension t(ndim,1) real ( kind = 8 ) x(1) real ( kind = 8 ) y(1) n = nn x(1:n) = y(1:n) call bfst (ndim,n,maxt,t,x) x(1:n) = d(1:n)*x(1:n) call bbs (ndim,n,maxt,t,x) return end subroutine bsolm (nn,nsize,maxt,d,t,y,x) !*****************************************************************************80 ! !! BSOLM solves the system A*x = y where A is multiple symmetric banded matrices ! ! The factorizations are contained in d and t. ! ! Parameters: ! ! n order of system ! nsize size of a single subsystem ! maxt number of columns in t array ! d vector of length n containing the diagonal ! elements of the factorization ! t array of active size n by maxt containing ! the super-diagonal elements of the factorization ! in the order 1,2,3,... ! y right-hand-side vector ! x vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension d(1), t(1), y(1), x(1) n = nn x(1:n) = y(1:n) nsys = n/nsize call bfstm (nsize,nsys,maxt,t,x) x(1:n) = d(1:n)*x(1:n) call bbsm (nsize,nsys,maxt,t,x) return end subroutine bsoln (ndim,nn,maxt,maxb,d,t,b,y,x) !*****************************************************************************80 ! !! BSOLN solves A*x = y for a banded and nonsymmetric matrix. ! ! d, t, and b must contain upon input the factorization arrays ! from bfacn. ! ! Parameters: ! ! ndim row dimension of t array in defining routine ! n order of system ! maxt number of columns in t array ! maxb number of columns in b array ! d vector of length n containing the diagonal ! pivots of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization in the order ! 1,2,3,... ! b array of active size n by maxb giving the sub- ! diagonals of the factorization in the order ! -1,-2,-3,... ! y right-hand-side vector ! x vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension t(ndim,1), x(1), y(1), d(1), b(ndim,1) n = nn x(1:n) = y(1:n) call bfs (ndim,n,maxb,b,x) x(1:n) = d(1:n)*x(1:n) call bbs (ndim,n,maxt,t,x) return end subroutine bsolnm (nn,nsize,maxt,maxb,d,t,b,y,x) !*****************************************************************************80 ! !! BSOLNM solves A*x = y for a banded and nonsymmetric matrix. ! ! d, t, and b must contain upon input the factorization arrays ! from bfacnm. (multiple systems) ! ! Parameters: ! ! n order of system ! nsize size of an individual subsystem ! maxt number of columns in t array ! maxb number of columns in b array ! d vector of length n containing the diagonal ! pivots of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization in the order ! 1,2,3,... ! b array of active size n by maxb giving the sub- ! diagonals of the factorization in the order ! -1,-2,-3,... ! y right-hand-side vector ! x vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension t(1), x(1), y(1), d(1), b(1) n = nn x(1:n) = y(1:n) nsys = n/nsize call bfsm (nsize,nsys,maxb,b,x) x(1:n) = d(1:n)*x(1:n) call bbsm (nsize,nsys,maxt,t,x) return end subroutine bsolnt (ndim,nn,maxt,maxb,d,t,b,y,x) !*****************************************************************************80 ! !! BSOLNT solves (A**t)*x = y for a banded and nonsymmetric matrix. ! ! d, t, and b must contain upon input the ! factorization arrays from bfacn. ! ! Parameters: ! ! ndim row dimension of t array in defining routine ! n order of system ! maxt number of columns in t array ! maxb number of columns in b array ! d vector of length n containing the diagonal ! pivots of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization in the order ! 1,2,3,... ! b array of active size n by maxb giving the sub- ! diagonals of the factorization in the order ! -1,-2,-3,... ! y right-hand-side vector ! x vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension t(ndim,1), x(1), y(1), d(1), b(ndim,1) n = nn x(1:n) = y(1:n) call bfst (ndim,n,maxt,t,x) x(1:n) = d(1:n) * x(1:n) call bbst (ndim,n,maxb,b,x) return end subroutine bsontm (nn,nsize,maxt,maxb,d,t,b,y,x) !*****************************************************************************80 ! !! BSONTM solves (A**t)*x = y for a banded and nonsymmetric matrix. ! ! d, t, and b must contain upon input the ! factorization arrays from bfacnm. (multiple systems) ! ! Parameters: ! ! n order of system ! nsize size of an individual subsystem ! maxt number of columns in t array ! maxb number of columns in b array ! d vector of length n containing the diagonal ! pivots of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization in the order ! 1,2,3,... ! b array of active size n by maxb giving the sub- ! diagonals of the factorization in the order ! -1,-2,-3,... ! y right-hand-side vector ! x vector containing solution upon output ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension t(1), x(1), y(1), d(1), b(1) n = nn x(1:n) = y(1:n) nsys = n/nsize call bfstm (nsize,nsys,maxt,t,x) x(1:n) = d(1:n) * x(1:n) call bbstm (nsize,nsys,maxb,b,x) return end subroutine cg ( suba, subat, subql, subqlt, subqr, subqrt, subadp, coef, & jcoef, n, u, ubar, rhs, wksp, iwksp, iparm, rparm, ier ) !*****************************************************************************80 ! !! CG is the user interface to the conjugate gradient algorithm. ! implicit real ( kind = 8 ) ( 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) common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, & iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ier = 0 call needw ( 'CG', 0, irpnt, 3*n+2*itmax, ier ) if ( ier < 0 ) then return end if nw = lenr - irpnt + 1 call cgw ( suba, subql, coef, jcoef, wksp, iwksp, n, u, ubar, rhs, & wksp(irpnt), nw, iparm, rparm, ier ) irmax = irpnt + nw - 1 return end subroutine cgcr (suba,subat,subql,subqlt,subqr,subqrt,subadp,coef,jcoef, & n,u,ubar,rhs,wk,iwk,iparm,rparm,ier) !*****************************************************************************80 ! !! CGCR implements the constrained residual method. ! ! The CGCR method of j. r. wallis is coupled with truncated/restarted ! orthomin. for further information about the algorithm, see ! "constrained residual acceleration of conjugate residual methods", ! by j. r. wallis, ! r. p. kendall and t. e. little of j. s. nolen and assocs. inc.; ! report spe 13536, society of petroleum engineers, 1985. ! ! right preconditioning only is allowed in this algorithm. ! ! unfortunately, this routine is limited -- all blocks must be the ! same size. but the idea can be easily generalized. ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), 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 common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, & iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! ! data common blocks common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / ccgcr / nblk, nband, ictac, ieta, ivcgcr ! ! time to proceed. ! if (nstore/=2 .and. nstore/=3) go to 998 irpsav = irpnt iql = iqlr==1 .or. iqlr==3 iqr = iqlr==2 .or. iqlr==3 if (iql) go to 998 ipl = .false. ipr = .true. iplr = 0 if (ipl) iplr = iplr + 1 if (ipr) iplr = iplr + 2 ! ! Form the c**(t)*a*c matrix ! 1 continue if (nbl1d<=0 .or. nbl2d<=0) go to 998 nbl0d = 1 if (mod(nbl2d,nbl1d)/=0 .or. mod(nbl1d,nbl0d)/=0) go to 998 nblk = n / nbl2d if (nblk == 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 < 0) go to 999 irpnt = ictac + nblk*nband ! ! perform first-iterate calculations ! ieta = irpnt ivcgcr = ieta + nblk iv2 = ivcgcr + n irmax = max(irmax,iv2-1+n) if (irmax > lenr) go to 997 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),wk(ivcgcr)) call vexopy (n,u,u,wk(ivcgcr),1) ! ! Pass it on to orthomin. ! irpnt = iv2 nw = lenr - irpnt + 1 call omingw (suba,subql,subqr,nullpl,cgcrpr,coef,jcoef,wk,iwk,n,u,ubar, & rhs,wk(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) irpnt = irpsav return ! ! error returns. ! ! insuff. real workspace. 997 ier = -2 call ershow (ier,'cgcr') return ! ! unimplemented option. 998 ier = -16 call ershow (ier,'cgcr') return ! ! generic handler. 999 ier = ierpp return end subroutine cgcrpr (coef,jcoef,wk,iwk,n,subql,suba,subqr,u,v) !*****************************************************************************80 ! !! CGCRPR is a right preconditioner routine to use with the CGCR method. ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension u(1), v(1), coef(1), jcoef(2), wk(1), iwk(1) common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, & iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / ccgcr / nblk, nband, ictac, ieta, ivcgcr external subql, suba, subqr ! ! 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), wk(ivcgcr)) call vexopy (n,v,v,wk(ivcgcr),2) return end subroutine cgnr (suba,subat,subql,subqlt,subqr,subqrt,subadp,coef,jcoef,n, & u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) !*****************************************************************************80 ! !! CGNR is the user interfact to the conjugate gradient algorithm on the normal equations. ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax nw = lenr - irpnt + 1 call cgnrw (suba,subat,subql,subqlt,subqr,subqrt,coef,jcoef,wksp,iwksp,n, & u,ubar,rhs,wksp(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine cgnrw (suba,subat,subql,subqlt,subqr,subqrt,coef,jcoef,wfac, & jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) !*****************************************************************************80 ! !! CGNRW runs the conjugate gradient algorithm on the normal equations. ! ! in this variant, the residual of the original system is minimized ! per iteration. currently, only left preconditioning is implemented. ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), wfac(1), jwfac(1) external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, & 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, alphao, gamma, sigma, & rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, bnorm, & bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! preliminary calculations. ! nwusd = 0 ier = 0 iacel = 5 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 997 iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 if (iqr) go to 995 if (level >= 2) write (nout,496) 496 format (' cgnr') maxadp = maxadd minadp = minadd alphao = 0.0D+00 alpha = 0.0D+00 beta = 0.0D+00 ! ! initialize the stopping test. ! call inithv (0) zthave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 730 itri = 1 ip = itri if ( .not. (maxadd .or. minadd) ) go to 850 ip = itri + 2*itmax call vfill ( 2*itmax, wk(itri), 0.0D+00 ) 850 ir = ip + n iv1 = ir + n iv2 = iv1 + n nwusd = max(nwusd,iv2-1+n) ! ! check the memory usage. ! if (nwusd > nw) go to 999 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)) ! ! begin iteration loop. ! ! Determine whether or not to stop. ! 10 continue call inithv (1) nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,wk(ir),wk(iv1),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv1-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! if (in /= 0) go to 110 ! ! perform first-iterate calculations ! 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 ! ! perform subsequent-iterate calculations ! 110 ardold = ard ! if (abs(ardold) < 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 ! ! proceed to form the iterate. ! 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) < srelpr**2) go to 998 vlamda = ard/pap call vtriad (n,u,u,vlamda,wk(ip),1) call vtriad (n,wk(ir),wk(ir),-vlamda,wk(iv2),1) ! ! update eigenvalue estimates ! alphao = alpha alpha = vlamda if (maxadp .or. minadp) call chgcon (wk(itri),ier) if (ier < 0) go to 725 ! ! proceed to next iteration ! in = in + 1 is = is + 1 go to 10 ! ! finish up. ! 900 if (halt) go to 715 ier = 1 call ershow (ier,'cgnrw') zeta = stptst go to 725 715 continue if (level >= 1) write (nout,720) in 720 format (/' cgnr converged in ',i5,' iterations.') 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! error returns ! 995 ier = -16 call ershow (ier,'cgnrw') return ! 996 ier = -13 call ershow (ier,'cgnrw') go to 725 ! 997 call ershow (ier,'cgnrw') go to 735 ! 998 ier = -15 call ershow (ier,'cgnrw') go to 725 ! 999 ier = -2 call ershow (ier,'cgnrw') go to 735 ! end subroutine cgw (suba,subq,coef,jcoef,wfac,jwfac,nn,u,ubar,rhs,wksp,nw, & iparm,rparm,ier) ! !*****************************************************************************80 ! !! CGW drives the conjugate gradient algorithm. ! ! ! Parameters: ! ! suba matrix-vector multiplication routine ! subq preconditioning routine ! n input integer. order of the system (= nn) ! u input/output vector. on input, u contains the ! initial guess to the solution. on output, it ! contains the latest estimate to the solution. ! ubar input vector containing the true solution ! (optional) ! rhs input vector. contains the right hand side ! of the matrix problem. ! wksp vector used for working space. ! nw length of wksp array. if this length is less than ! the amount needed, nw will give the needed amount ! upon output. ! iparm integer vector of length 30. allows user to ! specify some integer parameters which affect ! the method. ! rparm real vector of length 30. allows user to ! specify some real parameters which affect ! the method. ! ier output integer. error flag. ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external suba, subq integer iparm(30), jcoef(2), jwfac(1) dimension rhs(1), u(1), ubar(1), wksp(1), rparm(30), coef(1), wfac(1) ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, & iplr, iqlr, ntest, is, iacel, idgts, nbl1d, nbl2d common / itcom3 / alpha, beta, zeta, emax, emin, pap, alphao, gamma, sigma, & rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 logical omgadp common / itcom5 / omgadp common / itcom55 / omega, alphab, betab, fff, specr ! ! initialize common blocks ! ier = 0 n = nn t1 = timer (dummy) iacel = 1 timit = 0.0D+00 digit1 = 0.0D+00 digit2 = 0.0D+00 call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 35 if (level >= 2) write (nout,10) 10 format (1x,'cg') ! ! compute workspace base addresses and check for sufficient ! workspace. ! iw1 = 1 iw2 = iw1 + n iw3 = iw2 + n iw4 = iw3 + n nwksp = 3*n + 2*itmax if (nw >= 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 < 0) go to 30 ! ! zero out workspace ! call vfill ( nwksp, wksp, 0.0D+00 ) ! ! iteration sequence ! call itcg (suba,subq,coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wksp(iw1), & wksp(iw2),wksp(iw3),wksp(iw4),ier) ! if (ier < 0 .or. ier == 1) go to 25 ! ! method has converged ! if (level >= 1) write (nout,20) in 20 format (/1x,'cg has converged in ',i5,' iterations' ) ! ! optional error analysis ! 25 continue if (idgts < 0) go to 30 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wksp,digit1,digit2,idgts) ! ! set return parameters in iparm and rparm ! 30 continue 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 ! 35 continue if (level >= 3) call echall (n,iparm,rparm,2,2,ier) return end subroutine chgcon ( tri, ier ) ! !*****************************************************************************80 ! !! CHGCON computes new estimates for the largest and smallest eigenvalues. ! ! ! Discussion: ! ! These estimates are used for conjugate gradient acceleration. ! ! Parameters: ! ! tri tridiagonal matrix associated with the eigenvalues ! of the conjugate gradient polynomial. ! ! ier error code ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension tri(2,2) ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, & 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, alphao, gamma, sigma, & rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer ! ! ! ! description of variables in common blocks in main routine ! save tl1,tl2,bl1,bl2 ip = is if (ip - 1) 10,20,30 ! ! ip = 0 ! 10 continue end = 1.0D+00 / alpha tri(1,1) = end tri(2,1)= 0.0D+00 if (maxadp) emax = end if (minadp) emin = end return ! ! ip = 1 ! 20 continue t1 = 1.0D+00 / 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.0*t2 ) if (maxadp) emax = (t3 + t4)/2.0 if (minadp) emin = (t3 - t4)/2.0 return ! ! ip >= 2 ! 30 continue t1 = 1.0D+00 / 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 ! ! compute new estimate of emax. ! tl1 = max (tl1,tl2+tsqr) tl2 = t1 + tsqr emaxo = emax end = max (tl1,tl2) e1 = eigvss ( ip+1, tri, emaxo, end, 2, ier ) ! ! poor estimate for emax. therefore need to stop adaptive ! procedure and keep old value of emax. ! if ( ier == 3 .or. ier == 4 ) then maxadp = .false. if (level >= 2) write (nout,31) ier,in,emaxo 31 format (/5x,'estimation of maximum eigenvalue emax halted' & /5x,'routine zbrent returned ier = ',i5 & /5x,'adaptive procedure turned off at iteration ',i5 & /5x,'final estimate of maximum eigenvalue =',e15.7/) ! ! valid emax estimate. check for small relative change in emax. ! else emax = e1 if (abs (emax - emaxo) < emax*zeta) maxadp = .false. end if ! ! compute new estimate of emin. ! 40 continue if ( .not. minadp ) return bl1 = min (bl1,bl2-tsqr) bl2 = t1 - tsqr start = max ( 0.0D+00, min (bl1,bl2) ) emino = emin e1 = eigvss ( ip+1, tri, start, emino, 1, ier ) ! ! poor estimate for emin. therefore need to stop adaptive ! procedure and keep old value of emin. ! if ( ier == 3 .or. ier == 4 ) then minadp = .false. if (level >= 2 ) write (nout,41) ier,in,emino 41 format (/5x,'estimation of minimum eigenvalue emin halted' & /5x,'routine zbrent returned ier = ',i5 & /5x,'adaptive procedure turned off at iteration ',i5 & /5x,'final estimate of minimum eigenvalue =',e15.7/) return end if ! ! valid emin estimate. check for small relative change in emin. ! emin = e1 if ( abs ( emin - emino ) < emin * zeta ) then minadp = .false. end if return end subroutine chgsi (suba,coef,jcoef,wfac,jwfac,nn,z,wksp,icode,ier) ! !*****************************************************************************80 ! !! CHGSI adapts on the iteration parameters. ! ! ! Parameters: ! ! n order of system (= nn) ! z current pseudo-residual vector ! wksp workspace vector of length n ! icode output indicator of parameter changes ! = 0 estimates of emax, emin not changed ! = 1 estimates of emax, emin changed ! ier error code ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external suba integer jcoef(2), jwfac(1) dimension z(1), wksp(1), coef(1), wfac(1) ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, & 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! n = nn ! istar = 3 icode = 0 if (is == 0) return rnrm = sqrt (rzdot) rnrmq = sqrt (dkq) rnrm1 = sqrt (dkm1) qa = rnrm/rnrmq t1 = rr**is qt = 2.0 * sqrt ( t1 ) / ( 1.0D+00 + t1 ) if (qa <= qt**ff) return if (qa <= 1.0D+00 .and. is <= istar) return icode = 1 ! ! Compute rayleigh quotient. ! rq = (z,a*z)/(r,z) ! call suba (coef,jcoef,wfac,jwfac,n,z,wksp) top = dot_product ( z(1:n), wksp(1:n) ) if (top >= 0.0D+00) go to 15 ier = -6 call ershow (ier,'chgsi') return 15 rq = top/rzdot kode = 0 if (rq > rqmax) kode = 1 rqmin = min (rq,rqmin) rqmax = max (rq,rqmax) yy = ( 1.0D+00 + t1 ) * ( qa + sqrt ( qa * qa - qt * qt ) ) / 2.0D+00 xx = yy** ( 1.0D+00 / real ( is, kind = 8 ) ) if (qa > 1.0D+00 ) go to 25 if (kode == 1) go to 25 ! ! emin adjustment. ! eminp = (emax+emin)*(1.0D+00-xx)*(xx-rr)/(2.0*xx*(rr+1.0D+00)) if (minadp) emin = min (emin,eminp,rqmin) if (maxadp) emax = max (emax,rqmax) if (level >= 2) write (nout,20) in,rq,eminp,emin,emax 20 format (/1x,15x,'parameters were changed at iteration',i7/ & 1x,20x,'rayleigh quotient ',f15.9/ & 1x,20x,'young estimate ',f15.9/ & 1x,20x,'emin ',f15.9/ & 1x,20x,'emax ',f15.9/) return ! ! emax adjustment. ! 25 emaxp = (emax+emin)*(1.0D+00+xx)*(xx+rr)/(2.0*xx*(rr+1.0D+00)) uu = ((1.0D+00+t1)/(1.0D+00+rr**(is-1))) * (rnrm/rnrm1) emaxpp = (emax+emin)*(1.0D+00+uu)*(uu+rr)/(2.0*uu*(rr+1.0D+00)) if (maxadp) emax = max (emax,1.1D+00*emaxp,1.1D+00*emaxpp,1.1D+00*rqmax) if (minadp) emin = rqmin if (level >= 2) write (nout,30) in,rq,emaxp,emaxpp,emin,emax 30 format (/1x,15x,'parameters were changed at iteration',i7/ & 20x,'rayleigh quotient ',f15.9/ & 20x,'young estimate ',f15.9/ & 20x,'hageman estimate ',f15.9/ & 20x,'emin ',f15.9/ & 20x,'emax ',f15.9/) return end subroutine ckconv (ier) ! !*****************************************************************************80 ! !! CKCONV checks if the iterative method has stagnated or had other misfortunes. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! parameter (nst=20) parameter (eps=1.e-7) common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, iplr, iqlr, ntest, & is, iacel, idgts, nbl1d, nbl2d common / itcom3 / alpha, beta, zeta, emax, emin, pap, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 ! dimension stold(nst) save stold, ist ind(i) = 1 + mod(i,nst) ! if (in <= 0) ist = 0 ! ist = ist + 1 stold(ind(ist)) = stptst if (ist < nst) then return end if do i = nst-1, 1, -1 val = abs(stold(ind(ist-i))-stptst) if (val > eps*stptst) then return end if end do ier = -19 call ershow (ier,'ckconv') return end subroutine color ( nxp, nyp, nzp, nx, ny, nz, pp, p ) ! !*****************************************************************************80 ! !! COLOR expands a color pattern to a full grid color array. ! ! ! Discussion: ! ! The (small) color pattern array PP is repeatedly mapped onto ! the large grid color array P, in the same way that a 2 by 2 ! block of red/black squares can be used to define the color ! pattern on a large checkerboard. ! ! Parameters: ! ! nxp, integer variables giving the x, y, and z dimensions ! nyp, of the pattern array, respectively. ! nzp ! nx,ny, integer variables giving the x, y, and z dimensions ! nz of the grid, respectively. ! pp integer vector of length nxp*nyp*nzp ! giving the color pattern to be repeated ! p integer vector of length nxg*nyg*nzg ! which contains upon output the grid coloring ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer nx integer nxp integer ny integer nyp integer nz integer nzp ! integer i integer ip integer j integer jp integer k integer kp integer p(nx,ny,nz) integer pp(nxp,nyp,nzp) ! do k = 1, nz kp = mod ( k - 1, nzp ) + 1 do j = 1, ny jp = mod ( j - 1, nyp ) + 1 do i = 1, nx ip = mod ( i - 1, nxp ) + 1 p(i,j,k) = pp(ip,jp,kp) end do end do end do return end subroutine copy (coef,jcoef,wksp,iwksp,n,r,z) ! !*****************************************************************************80 ! !! COPY does a vector copy (null preconditioner). ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jcoef(2), iwksp(1) dimension r(1), z(1), coef(1), wksp(1) ! z(1:n) = r(1:n) return end subroutine defcon (ndim,nn,maxnz,jcoef,coef,kblsz,iblock,lbhb) ! !*****************************************************************************80 ! !! DEFCON defines block constants for block-structured matrices. ! ! ! (diagonal data structure, constant block size) ! ! Parameters: ! ! ndim row dimension of coef array in defining routine ! nn size of system ! maxnz number of diagonals in coef ! jcoef integer vector of size maxnz giving the diagonal ! numbers ! coef matrix representation array ! kblsz constant block size ! iblock integer array of size 3 by lbhb ! giving block constants upon output ! lbhb integer giving the number of diagonal blocks ! upon output. ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jcoef(2) integer iblock(3,3) dimension coef(ndim,1) ! 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 i = 1,n if (coef(i,j) /= 0.0D+00) go to 15 end do go to 25 15 jcol = i + jd ! ! find block for jcol. ! ib = (i-1)/kblsz + 1 jb = (jcol-1)/kblsz + 1 id = jb - ib if (id == 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 ! ! Split zero diagonal block into super and sub diagonals. ! jlim = iblock(3,2) do j = 1,jlim jd = jcoef(j) if (jd < 0) go to 35 iblock(3,1) = iblock(3,1) + 1 iblock(3,2) = iblock(3,2) - 1 end do j = jlim + 1 35 iblock(2,2) = j ! ! form starting positions. ! if (lbhb <= 2) return iblock(2,3) = 1 do j = 4,lbhb iblock(2,j) = iblock(2,j-1) + iblock(3,j-1) end do return end subroutine define (ndim,maxnew,jcnew,coef,ncol,nc,iblock,lbhb) ! !*****************************************************************************80 ! !! DEFINE defines block constants for block-structured matrices. ! ! ! (diagonal data structure, nonconstant block size) ! ! Parameters: ! ! ndim row dimension of coef array in defining routine ! maxnew integer vector giving the number of diagonals ! for each distinct block size. ! jcnew integer array of size ncolor*max(maxnew(i)) ! giving the diagonal numbers for each distinct ! block size. ! coef matrix representation array ! ncolor number of distinct block sizes ! nc integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants upon output ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size ! upon output. ! ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer maxnew(ncol), jcnew(ncol,1), nc(ncol), lbhb(ncol), iblock(3,ncol,3) dimension coef(ndim,1) ! 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 i = ist,ied if ( coef(i,j) /= 0.0D+00 ) then go to 15 end if end do go to 35 15 jcol = i + jd ! ! find block for jcol. ! ib = k js = 0 do ij = 1,ncolor js = js + nc(ij) if ( js >= jcol ) then exit end if end do jb = ij id = jb - ib if (id == 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 ! ! split zero diagonal block into super and sub diagonals. ! jlim = iblock(3,k,2) do j = 1,jlim jd = jcnew(k,j) if (jd < 0) go to 45 iblock(3,k,1) = iblock(3,k,1) + 1 iblock(3,k,2) = iblock(3,k,2) - 1 end do j = jlim + 1 45 iblock(2,k,2) = j ! ! form starting positions. ! jlim = lbhb(k) if (jlim <= 2) go to 55 iblock(2,k,3) = 1 if (jlim <= 3) go to 55 do j = 4,jlim iblock(2,k,j) = iblock(2,k,j-1) + iblock(3,k,j-1) end do 55 ist = ied + 1 60 continue return end function determ ( n, tri, xlmda ) ! !*****************************************************************************80 ! !! DETERM computes the determinant of a symmetric tridiagonal matrix. ! ! ! Discussion: ! ! The matrix is given by tri. det(tri - xlmda*i) = 0 ! ! Parameters: ! ! Input, integer N, order of tridiagonal system. ! ! Input, real ( kind = 8 ) TRI(2,N), symmetric tridiagonal matrix of order N. ! ! Input, real ( kind = 8 ) XLMDA, argument for characteristic equation ! ! Output, real ( kind = 8 ) DETERM, the determinant of the matrix. ! implicit none ! integer n ! real ( kind = 8 ) d1 real ( kind = 8 ) d2 real ( kind = 8 ) d3 real ( kind = 8 ) determ integer j real ( kind = 8 ) tri(2,n) real ( kind = 8 ) xlmda ! d2 = tri(1,n) - xlmda d1 = d2 * (tri(1,n-1) - xlmda) - tri(2,n) do j = n-1, 2, -1 d3 = d2 d2 = d1 d1 = ( tri(1,j-1) - xlmda ) * d2 - d3 * tri(2,j) end do determ = d1 return end subroutine detsym ( ndim, maxnzz, coef, jcoef, nn, isymm ) !*****************************************************************************80 ! !! DETSYM determines if the matrix is symmetric. ! ! (Purdue storage format) ! ! Parameters: ! ! ndim row dimension of coef in defining routine ! maxnz number of columns in coef ! coef array of matrix nonzeros ! jcoef array of matrix column numbers ! n order of matrix (= nn) ! isymm symmetry switch. upon output, ! isymm = 0 if matrix is symmetric ! = 1 if matrix is nonsymmetric ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension coef(ndim,2) integer jcoef(ndim,2) n = nn maxnz = maxnzz isymm = 0 if (maxnz <= 1) return do i = 1,n do j = 2,maxnz jcol = jcoef(i,j) if ( jcol == i ) then cycle end if val = coef(i,j) do jj = 2,maxnz jcol1 = jcoef(jcol,jj) if (jcol1 == i) then val1 = coef(jcol,jj) if (val1 == val) go to 15 isymm = 1 return end if end do isymm = 1 return 15 continue end do end do return end subroutine dfault ( iparm, rparm ) !*****************************************************************************80 ! !! DFAULT sets the default values of IPARM and RPARM. ! ! Parameters: ! ! iparm ! and ! rparm arrays specifying options and tolerances ! ! implicit real ( kind = 8 ) ( a - h, o - z ) integer iparm(30) dimension rparm(30) common / itcom4 / srelpr, keygs, keyzer ! ! description of variables in common blocks in main routine ! ! srelpr - computer precision (approx.) ! if installer of package does not know srelpr value, ! an approximate value can be determined from a simple ! fortran program such as ! ! srelpr = 1.0D+00 ! 2 srelpr = 0.5D+00*srelpr ! temp = srelpr + 1.0D+00 ! if (temp > 1.0D+00) go to 2 ! srelpr = 2.0D+00*srelpr ! write (6,3) srelpr ! 3 format (1x,'srelpr = ',e20.10) ! stop ! end ! ! ! some values are- ! ! srelpr = 7.1e-15 for cray x-mp (approx.) 2**-47 ! = 1.49e-8 for dec 10 (approx.) 2**-26 ! = 1.192e-7 for vax 11/780 (approx) 2**-23 ! = 4.768e-7 for ibm 370/158 ! ! *** should be changed for other machines *** ! ! to facilitate convergence, rparm(1) should be set to ! 500.*srelpr or larger ! ! srelpr = epsilon ( srelpr ) ! ! keygs is a flag to specify how gather/scatter operations ! are performed. ! = 1 gather explicitly into a workspace vector ! = 2 gather implicitly using indirect addressing ! ! keygs = 1 ! ! keyzer is a flag to specify if memory has been zeroed out. ! i.e., is the operation 0.0 * indefinite = 0.0 legal ! = 0 not legal ! = 1 legal ! keyzer = 0 ! 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 rparm(1) = 1.0D-4 rparm(2) = 2.0D+00 rparm(3) = 1.0D+00 rparm(4) = 0.75D+00 rparm(5) = 0.75D+00 rparm(6) = 0.0D+00 rparm(7) = 0.0D+00 rparm(8) = 0.0D+00 rparm(9) = 1.0D+00 rparm(10) = 0.0D+00 rparm(11) = 0.25D+00 rparm(12) = 0.0D+00 rparm(13) = 0.0D+00 rparm(14) = 0.0D+00 rparm(15) = 500.0D+00 * srelpr rparm(16) = 0.0D+00 return end subroutine echall (n,iparm,rparm,icall,icallr,ier) ! !*****************************************************************************80 ! !! ECHALL initializes the package common blocks. ! ! ! It uses the information contained in iparm and rparm. echall also ! prints the values of all parameters in iparm and rparm. ! ! Parameters: ! ! iparm ! and ! rparm arrays of parameters specifying options and ! tolerances ! icall indicator of which parameters are being printed ! icall = 1, initial parameters ! = 2, final parameters ! icallr indicator of calling routine ! = 1, called from nspcg ! = 2, called from accelerator ! ! ! ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer logical omgadp common / itcom5 / omgadp common / itcom55 / omega, alphab, betab, fff, specr common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / itcom8 / ainf ! ! ! 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', & 'maxadp', 'minadp', 'iomgad', 'ns1', 'ns2', 'ns3', & 'nstore', 'iscale', 'iperm', 'ifact', 'lvfill', & 'ltrunc', 'ipropa', 'kblsz', 'nbl2d', 'ifctv', & 'iqlr', 'isymm', 'ielim', 'ndeg' / data rnames / 'zeta', 'emax', 'emin', 'ff', 'fff', 'timit', & 'digit1', 'digit2', 'omega', 'alphab', 'betab', & 'specr', 'timfac', 'timtot', 'tol', 'ainf' / ! if (icall /= 1) go to 20 ! ! handle accelerator parameters. ! ntest = iparm(1) itmax = iparm(2) level = iparm(3) nout = iparm(4) idgts = iparm(5) maxad = iparm(6) maxadd = (maxad == 1) minad = iparm(7) minadd = (minad == 1) maxadp = maxadd minadp = minadd iomgad = iparm(8) omgadp = (iomgad == 1) ns1 = iparm(9) ns2 = iparm(10) ns3 = iparm(11) iqlr = iparm(22) iplr = iqlr 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) erflag = .false. erflag = erflag .or. ntest < 1 .or. ntest > 10 erflag = erflag .or. itmax <= 0 erflag = erflag .or. maxad < 0 .or. maxad > 1 erflag = erflag .or. minad < 0 .or. minad > 1 erflag = erflag .or. ns1 < 0 erflag = erflag .or. ns2 < 0 erflag = erflag .or. emax < 0.0D+00 erflag = erflag .or. emin < 0.0D+00 erflag = erflag .or. ff <= 0.0D+00 .or. ff > 1.0D+00 if (erflag) go to 999 ! ! test if eps is too small ! temp = 500.0D+00 * srelpr if (zeta >= temp) go to 150 ier = 2 call ershow (ier,'echall') zeta = temp rparm(1) = temp ! ! verify n ! 150 if (n > 0 ) go to 200 ier = -1 call ershow (ier,'echall') return ! ! now handle preconditioner parameters. ! 200 if (icallr == 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) ! if (nbl1d == -1) nbl1d = n if (nbl2d == -1) nbl2d = n kblsz = nbl1d erflag = .false. erflag = erflag .or. iqlr < 0 .or. iqlr > 3 erflag = erflag .or. ipropa < 0 .or. ipropa > 3 if (erflag) go to 999 ! ! ! initialize rest of common variables ! 50 halt = .false. stptst= 0.0D+00 udnm = 1.0D+00 in = 0 ! ! Prepare to do output. ! if (level <= 2) return write ( nout, * ) ' ' write ( nout, * ) 'Initial iterative parameters' write ( nout, * ) ' ' go to 30 20 if (level <= 2) return write ( nout, * ) ' ' write ( nout, * ) 'Final iterative parameters' write ( nout, * ) ' ' 30 if (icallr == 2) go to 305 write ( nout, * ) ' ' write ( nout, * ) 'Preprocessor and preconditioner parameters' write ( nout, * ) ' ' ibip = naiprm + 1 ieip = 25 ibrp = narprm + 1 ierp = 16 go to 300 305 continue write ( nout, * ) ' ' write ( nout, * ) 'General and acceleration parameters' write ( nout, * ) ' ' ibip = 1 ieip = naiprm ibrp = 1 ierp = narprm 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,') =',e15.8,4x,'(',a6,')' ) return ! ! error returns. ! ! inadmissible option. 999 ier = -10 call ershow (ier,'echall') return end function eigvss ( n, tri, start, end, icode, ier ) ! !*****************************************************************************80 ! !! EIGVSS computes a selected eigenvalue of a symmetric tridiagonal matrix. ! ! ! Discussion: ! ! The eigenvalue is computed for conjugate gradient acceleration. ! The modified imsl routine zbrent is used. ! ! Parameters: ! ! n order of tridiagonal system ! tri symmetric tridiagonal matrix of order n ! start initial lower bound of interval containing root ! end initial upper bound of interval containing root ! icode operation key ! = 1 minimum eigenvalue sought ! = 2 maximum eigenvalue sought ! ier error flag ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer n ! real ( kind = 8 ) tri(2,n) ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer eigvss = 0.0D+00 itmp = int ( -log10 ( abs ( zeta ) ) ) nsig = max ( itmp, 4 ) maxfn = max ( itmax, 50 ) eps = 0.0D+00 a = start b = end call zbrent ( n, tri, eps, nsig, a, b, maxfn, ier ) if ( icode == 1 ) then eigvss = max ( a, b ) else if ( icode == 2 ) then eigvss = min ( a, b ) end if return end subroutine elim (n,jcoef,coef,rhs,wksp,iwksp,toll) ! !*****************************************************************************80 ! !! ELIM removes certains rows of the matrix. ! ! ! Discussion: ! ! The eliminated rows are those for which the ratio of the ! sum of off-diagonal elements to the diagonal element is ! small (less than tol) in absolute value. ! ! this is to take care of matrices arising from finite ! element discretizations of partial differential equations ! with dirichlet boundary conditions implemented by penalty ! methods. any such rows and corresponding columns are then ! eliminated (set to the identity after correcting the rhs). ! ! Parameters: ! ! n dimension of matrix ! jcoef integer array of matrix representation ! coef array of sparse matrix representation ! rhs right hand side of matrix problem ! wksp wksp array of length n ! tol tolerance factor (= toll) ! implicit real ( kind = 8 ) ( a - h, o - z ) ! common / cmpart / mpstrt, mpart common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv integer jcoef(2), iwksp(1) dimension coef(1), rhs(1), wksp(1) ! 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 continue call elim4 (mpart,iwksp(mpstrt),jcoef,jcoef(ndim+1),coef,rhs,wksp(irpnt),tol) return 25 continue call elim5 (mpart,iwksp(mpstrt),jcoef,jcoef(ndim+1),coef,rhs,wksp(irpnt),tol) return end subroutine elim1 (nn,ndim,maxnzz,jcoef,coef,rhs,wksp,toll) ! !*****************************************************************************80 ! !! ELIM1 removes certina rows of the matrix. ! ! ! Discussion: ! ! The elminated rows are those for which the ratio of the ! sum of off-diagonal elements to the diagonal element is ! small (less than tol) in absolute value. ! ! this is to take care of matrices arising from finite ! element discretizations of partial differential equations ! with dirichlet boundary conditions implemented by penalty ! methods. any such rows and corresponding columns are then ! eliminated (set to the identity after correcting the rhs). ! Purdue format. ! ! Parameters: ! ! n dimension of matrix ( = nn) ! ndim row dimension of arrays jcoef and coef in the ! calling program ! maxnz maximum number of nonzero entries per row (=maxnzz) ! jcoef integer array of matrix representation ! coef array of sparse matrix representation ! rhs right hand side of matrix problem ! wksp wksp array of length n ! tol tolerance factor (= toll) ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jcoef(ndim,1) dimension coef(ndim,1), rhs(1), wksp(1) ! n = nn maxnz = maxnzz tol = toll if (n <= 0 .or. maxnz < 2) return ! ! Find maximum off-diagonal elements in absolute value. ! wksp(1:n)= 0.0D+00 do j = 2,maxnz wksp(1:n) = wksp(1:n) + abs (coef(1:n,j)) end do wksp(1:n) = wksp(1:n) / abs(coef(1:n,1)) ! ! eliminate desired rows and columns. ! do i = 1,n if ( wksp(i) <= tol ) then rhs(i) = rhs(i)/coef(i,1) coef(i,1) = 1.0D+00 coef(i,2:maxnz)= 0.0D+00 jcoef(i,2:maxnz) = i end if end do do j = 2,maxnz do i = 1,n jcol = jcoef(i,j) if ( wksp(jcol) <= tol ) then rhs(i) = rhs(i) - coef(i,j)*rhs(jcol) coef(i,j)= 0.0D+00 jcoef(i,j) = i end if end do end do return end subroutine elim2 (nn,ndim,maxnzz,jcoef,coef,rhs,wksp,toll) ! !*****************************************************************************80 ! !! ELIM2 removes certain rows of the matrix. ! ! ! The eliminated rows are those for which the ratio of the ! sum of off-diagonal elements to the diagonal element is ! small (less than tol) in absolute value. ! this is to take care of matrices arising from finite ! element discretizations of partial differential equations ! with dirichlet boundary conditions implemented by penalty ! methods. any such rows and corresponding columns are then ! eliminated (set to the identity after correcting the rhs). ! symmetric diagonal format. ! ! Parameters: ! ! n dimension of matrix ( = nn) ! ndim row dimension of array coef in the ! calling program ! maxnz number of diagonals stored ! jcoef integer vector of diagonal numbers ! coef array of sparse matrix representation ! rhs right hand side of matrix problem ! wksp wksp array of length n ! tol tolerance factor (= toll) ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jcoef(1) dimension coef(ndim,1), rhs(1), wksp(1) ! n = nn maxnz = maxnzz tol = toll if (n <= 0 .or. maxnz < 2) return ! ! Find maximum off-diagonal elements in absolute value. ! wksp(1:n)= 0.0D+00 do j = 2,maxnz ind = jcoef(j) len = n - ind wksp(1:len) = wksp(1:len) + abs (coef(1:len,j)) do i = 1,len wksp(i+ind) = wksp(i+ind) + abs (coef(i,j)) end do end do wksp(1:n) = wksp(1:n) / abs(coef(1:n,1)) ! ! eliminate desired rows and columns. ! do 50 i = 1,n if (wksp(i) > tol) go to 50 rhs(i) = rhs(i)/coef(i,1) coef(i,1) = 1.0D+00 do 40 j = 2, maxnz jcol = jcoef(j) iback = i - jcol iforw = i + jcol if (iforw > n) go to 35 if (wksp(iforw) <= tol) go to 35 rhs(iforw) = rhs(iforw) - coef(i,j)*rhs(i) 35 if (iback < 1) go to 40 rhs(iback) = rhs(iback) - coef(iback,j)*rhs(i) coef(iback,j)= 0.0D+00 40 continue coef(i,2:maxnz)= 0.0D+00 50 continue return end subroutine elim3 (nn,ndim,maxnzz,jcoef,coef,rhs,wksp,toll) ! !*****************************************************************************80 ! !! ELIM3 removes certain rows of the matrix. ! ! ! The eliminated rows are those for which the ratio of the ! sum of off-diagonal elements to the diagonal element is ! small (less than tol) in absolute value. ! this is to take care of matrices arising from finite ! element discretizations of partial differential equations ! with dirichlet boundary conditions implemented by penalty ! methods. any such rows and corresponding columns are then ! eliminated (set to the identity after correcting the rhs). ! nonsymmetric diagonal format. ! ! Parameters: ! ! n dimension of matrix ( = nn) ! ndim row dimension of array coef in the ! calling program ! maxnz number of diagonals stored ! jcoef integer vector of diagonal numbers ! coef array of sparse matrix representation ! rhs right hand side of matrix problem ! wksp wksp array of length n ! tol tolerance factor (= toll) ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jcoef(1) dimension coef(ndim,1), rhs(1), wksp(1) ! n = nn maxnz = maxnzz tol = toll if (n <= 0 .or. maxnz < 2) return ! ! Find maximum off-diagonal elements in absolute value. ! wksp(1:n)= 0.0D+00 do j = 2,maxnz ind = jcoef(j) ist1 = max(1,1 - ind) ist2 = min(n,n - ind) wksp(ist1:ist2) = wksp(ist1:ist2) + abs (coef(ist1:ist2,j)) end do wksp(1:n) = wksp(1:n) / abs(coef(1:n,1)) ! ! eliminate desired rows and columns. ! do i = 1,n if ( wksp(i) <= tol ) then rhs(i) = rhs(i)/coef(i,1) coef(i,1) = 1.0D+00 coef(i,2:maxnz)= 0.0D+00 end if end do do 45 i = 1,n if (wksp(i) > tol) go to 45 do 40 j = 2,maxnz inew = i - jcoef(j) if (inew < 1 .or. inew > n) go to 40 rhs(inew) = rhs(inew) - coef(inew,j)*rhs(i) coef(inew,j)= 0.0D+00 40 continue 45 continue return end subroutine elim4 (mm,np,ia,ja,a,rhs,wksp,toll) ! !*****************************************************************************80 ! !! ELIM4 removes certain rows of the matrix. ! ! ! The eliminated rows are those for which the ratio of the ! sum of off-diagonal elements to the diagonal element is ! small (less than tol) in absolute value. ! this is to take care of matrices arising from finite ! element discretizations of partial differential equations ! with dirichlet boundary conditions implemented by penalty ! methods. any such rows and corresponding columns are then ! eliminated (set to the identity after correcting the rhs). ! symmetric sparse format. ! ! Parameters ! ! m number of partitions ! np pointer vector to partitions ! ia vector of i values ! ja vector of j values ! a vector of coefficients ! rhs right hand side of matrix problem ! wksp wksp vector of length n (2n if keygs = 1) ! tol tolerance factor (= toll) ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ia(1), ja(1), np(2) dimension a(1), rhs(1), wksp(1) ! ! ! common / itcom4 / srelpr, keygs, keyzer ! ! ! m = mm n = np(2) - 1 nz = np(m+1) - 1 tol = toll np1 = n + 1 ! ! find sum of absolute values of off-diagonal coefficients. ! wksp(1:n)= 0.0D+00 if (keygs == 1) go to 30 do k = 2,m ist = np(k) ied = np(k+1) - 1 !dir$ ivdep do i = ist,ied wksp(ia(i)) = wksp(ia(i)) + abs(a(i)) end do !dir$ ivdep do i = ist,ied wksp(ja(i)) = wksp(ja(i)) + abs(a(i)) end do end do 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 i = ist,ied wksp(i-ist+1+n) = wksp(i-ist+1+n) + abs(a(i)) end do call vscatr (len,wksp(n+1),ia(ist),wksp) call vgathr (len,wksp,ja(ist),wksp(n+1)) do i = ist,ied wksp(i-ist+1+n) = wksp(i-ist+1+n) + abs(a(i)) end do call vscatr (len,wksp(n+1),ja(ist),wksp) 45 continue 50 continue wksp(1:n) = wksp(1:n) / abs(a(1:n)) ! ! eliminate desired rows and columns. ! do 70 l = 1,n if (wksp(l) > tol) go to 70 rhs(l) = rhs(l)/a(l) a(l) = 1.0D+00 do 60 k = np1,nz i = ia(k) j = ja(k) if (i == l .and. wksp(j) > tol) rhs(j) = rhs(j) - a(k)*rhs(i) if (j == l) then rhs(i) = rhs(i) - a(k)*rhs(j) a(k) = 0.0D+00 end if 60 continue do k = np1,nz if (ia(k) == l) then a(k) = 0.0D+00 end if end do 70 continue return end subroutine elim5 (mm,np,ia,ja,a,rhs,wksp,toll) ! !*****************************************************************************80 ! !! ELIM5 removes certain rows of the matrix. ! ! The elminated rows are those for which the ratio of the ! sum of off-diagonal elements to the diagonal element is ! small (less than tol) in absolute value. ! this is to take care of matrices arising from finite ! element discretizations of partial differential equations ! with dirichlet boundary conditions implemented by penalty ! methods. any such rows and corresponding columns are then ! eliminated (set to the identity after correcting the rhs). ! nonsymmetric sparse format. ! ! Parameters: ! ! m number of partitions ! np pointer vector to partitions ! ia vector of i values ! ja vector of j values ! a vector of coefficients ! rhs right hand side of matrix problem ! wksp wksp vector of length n (2n if keygs = 1) ! tol tolerance factor (= toll) ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ia(1), ja(1), np(2) dimension a(1), rhs(1), wksp(1) ! common / itcom4 / srelpr, keygs, keyzer ! ! ! m = mm n = np(2) - 1 nz = np(m+1) - 1 tol = toll ! ! find sum of absolute values of off-diagonal coefficients. ! wksp(1:n)= 0.0D+00 if (keygs == 1) go to 25 do k = 2,m ist = np(k) ied = np(k+1) - 1 !dir$ ivdep do i = ist,ied wksp(ia(i)) = wksp(ia(i)) + abs(a(i)) end do end do go to 40 25 continue do 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 i = ist,ied wksp(i-ist+1+n) = wksp(i-ist+1+n) + abs(a(i)) end do call vscatr (len,wksp(n+1),ia(ist),wksp) end do 40 continue wksp(1:n) = wksp(1:n) / abs(a(1:n)) ! ! Eliminate desired rows and columns. ! do i = 1,n if ( wksp(i) <= tol ) then rhs(i) = rhs(i)/a(i) a(i) = 1.0D+00 end if end do np1 = n + 1 do k = np1,nz if (wksp(ia(k)) <= tol) a(k) = 0.0D+00 end do do k = np1,nz j = ja(k) if ( wksp(j) <= tol ) then i = ia(k) rhs(i) = rhs(i) - a(k)*rhs(j) a(k) = 0.0D+00 end if end do return end subroutine ershow (ierr,iname) ! !*****************************************************************************80 ! !! ERSHOW prints an appropriate error message for the error numbered IER. ! ! ! Parameters: ! ! ier error number (input) ! > 0 for warning errors ! < 0 for fatal errors ! iname routine name in which error occurred ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! character*(*) iname ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, iplr, iqlr, ntest, & is, iacel, idgts, nbl1d, nbl2d common / itcom3 / alpha, beta, zeta, emax, emin, pap, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer ! ! ! character*80 fmess(20), wmess(6) data fmess(1) / 'nonpositive matrix size n' / data fmess(2) / 'insufficient real 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' / ! ier = ierr if ( ier == 0 ) then return end if if ( ier < 0 .and. level < 0 ) then return end if if (ier > 0 .and. level < 1) return if (ier < -19) ier = -20 if (ier > 5) ier = 6 if (ier < 0) write (nout,10) 10 format (//1x,60('*') /1x,18('*'),' Fatal error ',18('*') /1x,60('*') /) if (ier > 0) write (nout,20) 20 format (//1x,60('*') /1x,16('*'),' Warning error ',16('*') /1x,60('*') /) write (nout,23) iname 23 format (' Routine ',a) inum = iabs ( ier ) if ( ier > 0 ) go to 30 ! ! print out fatal errors. ! write ( nout, 25 ) fmess(inum) 25 format (a80) go to 999 ! ! print out warning errors. ! 30 write (nout,25) wmess(inum) if (inum /= 2) go to 999 temp = 500.0D+00 * srelpr write (nout,35) zeta, srelpr, temp 35 format ('rparm(1) =',e10.3,' (zeta)' & / 'a value this small may hinder convergence' & / 'since machine precision srelpr = ',e10.3 & / 'zeta reset to ',e10.3) ! ! print ending line. ! 999 write (nout,1000) 1000 format (/60('*')/) return end subroutine fillb ( nn, coef, jcoef, block, wksp, iwksp, ier ) ! !*****************************************************************************80 ! !! FILLB calculates block fill-in for block factorization methods. ! ! (symmetric diagonal storage) ! ! Parameters: ! ! n order of system ! coef real matrix coefficient array ! jcoef integer matrix coefficient array ! block array for block information ! wksp real workspace array ! iwksp integer workspace array ! ier error flag ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, 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, jcnew, lbhb, & iblock, ncmax dimension coef(1), wksp(1) integer jcoef(1), block(3,3), iwksp(1) ! n = nn ! ! determine block fill-in pattern. ! if (lvfill > 0) then lbhbsa = lbhb do lv = 1,lvfill lbhbl = lbhb do j1 = 3,lbhb do 15 j2 = 3,lbhb jd = block(1,j1) - block(1,j2) if (jd <= 0) go to 15 do j3 = 3,lbhbl if (block(1,j3) == jd) go to 15 end do lbhbl = lbhbl + 1 block(1,lbhbl) = jd block(3,lbhbl) = 0 15 continue end do lbhb = lbhbl end do end if ! ! compute constants and check for sufficient workspace. ! call needw ('fillb',1,iblock,3*lbhb,ier) if (ier < 0) return nwdiag = block(3,1) nwnew = nwdiag + ltrunc iipnt = iblock + 3*lbhb ifactr = irpnt nwk = 3*lbhb + maxnz + ltrunc + (lbhb-2)*(2*nwnew-1) call needw ('fillb',1,iblock,nwk,ier) if (ier < 0) return do j = 1,nwnew iwksp(iipnt+j-1) = j - 1 end do block(3,1) = nwnew ! ! determine diagonal numbers in filled-in block matrix. ! if (lvfill > 0) then jmax = 3 do j = 3,lbhbsa if (block(1,j) > block(1,jmax)) jmax = j end do jnext = iipnt + nwnew do 50 jjc = 3,lbhb if (jjc <= lbhbsa) then jstc = block(2,jjc) mc = block(3,jjc) j1 = jnext do j = 1,mc iwksp(jnext) = jcoef(nwdiag+jstc+j-1) jnext = jnext + 1 end do j2 = jnext - 1 end if if (jjc == jmax) go to 50 jblkc = block(1,jjc) inc = jblkc*kblsz lim1 = inc - (nwnew - 1) lim2 = inc + (nwnew - 1) do 45 j = lim1,lim2 if (jjc <= lbhbsa) then do jj = j1,j2 if (iwksp(jj) == j) go to 45 end do end if iwksp(jnext) = j jnext = jnext + 1 block(3,jjc) = block(3,jjc) + 1 45 continue 50 continue if (lbhb >= 4) then do 52 jjc = 4,lbhb 52 block(2,jjc) = block(2,jjc-1) + block(3,jjc-1) end if end if ! ! copy matrix into wksp. ! if (propa) then nfactr = n*nwnew nfacti = 3*lbhb end if if (.not. propa .and. lvfill == 0) then nfactr = n*(maxnz + ltrunc) nfacti = 3*lbhb end if if (lvfill > 0) then ndg = 0 do j = 1,lbhb ndg = ndg + block(3,j) end do nfactr = n*ndg nfacti = ndg + 3*lbhb end if call needw ('fillb',0,ifactr,nfactr,ier) if (ier < 0) return call needw ('fillb',1,ifacti,nfacti,ier) if (ier < 0) return call vfill ( nfactr, wksp(ifactr), 0.0D+00 ) 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 == 0) then do j = nwdiag+1,maxnz call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n end do end if if (lvfill > 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) /= jcol) go to 65 ipt2 = iwkpt2 + (jj-j1)*n call vcopy (n,coef(ipt1),wksp(ipt2)) go to 70 65 continue 70 continue end if irpnt = ifactr + nfactr iipnt = ifacti + nfacti return end subroutine fillbc ( nn, ncolor, coef, jcoef, block, wksp, iwksp, ier ) ! !*****************************************************************************80 ! !! FILLBC sets up WKSP for block factorization methods. ! ! ! (multicolor nonsymmetric diagonal) ! ! Modified: ! ! 11 June 2004 ! ! Parameters: ! ! n order of system ! coef real matrix coefficient array ! jcoef integer matrix coefficient array ! block array for block information ! wksp real workspace array ! iwksp integer workspace array ! ier error flag ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, 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, jcnew, lbhb, & iblock, ncmax dimension coef(1), wksp(1) integer jcoef(1), block(3,ncolor,3), iwksp(1) ! n = nn ! ! Compute constants and check for sufficient workspace. ! ndt = 0 ndb = 0 do j = 1,ncolor ndt = max (ndt,block(3,j,1)-1) ndb = max (ndb,block(3,j,2)) end do nwdiag = ndt + ndb + 1 nwnew = nwdiag + 2*ltrunc ifactr = irpnt ! ! Copy matrix into wksp. ! if (propa) nfactr = n*nwnew if (.not. propa) nfactr = n*nwnew + n*(maxd-nwdiag) call needw ('fillbc',0,ifactr,nfactr,ier) if (ier < 0) return call needw ('fillbc',1,iipnt,nwnew*ncolor,ier) if (ier < 0) return call vfill ( nfactr, wksp(ifactr), 0.0D+00 ) ipt1 = 1 ipt2 = ifactr do j = 1,ndt+1 call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n end do ipt2 = ipt2 + n*ltrunc do j = ndt+2,nwdiag call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n end do iwkpt2 = ifactr + n*nwnew ipt2 = iwkpt2 if (.not. propa) then do j = nwdiag+1,maxd call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n end do end if irpnt = ifactr + nfactr do ico = 1,ncolor do j = 1,ndt+ltrunc+1 iwksp(iipnt+(j-1)*ncolor+ico-1) = j - 1 end do do j = ndt+ltrunc+2,nwnew iwksp(iipnt+(j-1)*ncolor+ico-1) = -(j - ndt - ltrunc - 1) end do end do do ico = 1,ncolor block(3,ico,1) = ndt + ltrunc + 1 block(3,ico,2) = ndb + ltrunc block(2,ico,2) = block(2,ico,1) + block(3,ico,1) end do return end subroutine fillbn ( nn, coef, jcoef, block, wksp, iwksp, ier ) ! !*****************************************************************************80 ! !! FILLBN calculates block fill-in for block factorization methods. ! ! ! (nonsymmetric diagonal storage) ! ! Parameters: ! ! n order of system ! coef real matrix coefficient array ! jcoef integer matrix coefficient array ! block array for block information ! wksp real workspace array ! iwksp integer workspace array ! ier error flag ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! common / dscons / ndim, mdim, maxnz common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, 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, jcnew, lbhb, & iblock, ncmax dimension coef(1), wksp(1) integer jcoef(1), block(3,3), iwksp(1) ! n = nn ! ! determine block fill-in pattern. ! if (lvfill > 0) then lbhbsa = lbhb do lv = 1,lvfill lbhbl = lbhb do j1 = 3,lbhb do 15 j2 = 3,lbhb jd = block(1,j1) + block(1,j2) if (block(1,j1)*block(1,j2) >= 0) go to 15 do j3 = 1,lbhbl if (block(1,j3) == jd) go to 15 end do lbhbl = lbhbl + 1 block(1,lbhbl) = jd block(3,lbhbl) = 0 15 continue end do lbhb = lbhbl end do end if ! ! Compute constants and check for sufficient workspace. ! call needw ('fillbn',1,iblock,3*lbhb,ier) if (ier < 0) return ndt = block(3,1) - 1 ndb = block(3,2) nwdiag = ndt + ndb + 1 nwnew = nwdiag + 2*ltrunc iipnt = iblock + 3*lbhb ifactr = irpnt nwk = 3*lbhb + maxnz + 2*ltrunc + (lbhb-2)*nwnew call needw ('fillbn',1,iblock,nwk,ier) if (ier < 0) return do j = 1,ndt+ltrunc+1 iwksp(iipnt+j-1) = j - 1 end do do j = ndt+ltrunc+2,nwnew iwksp(iipnt+j-1) = -(j - ndt - ltrunc - 1) end do block(3,1) = ndt + ltrunc + 1 block(3,2) = ndb + ltrunc block(2,2) = block(2,1) + block(3,1) ! ! determine diagonal numbers in filled-in block matrix. ! if (lvfill > 0) then jmax = 3 jmin = 3 do j = 3,lbhbsa if (block(1,j) > block(1,jmax)) jmax = j if (block(1,j) < block(1,jmin)) jmin = j end do jnext = iipnt + nwnew do 50 jjc = 3,lbhb if (jjc <= lbhbsa) then jstc = block(2,jjc) mc = block(3,jjc) j1 = jnext do j = 1,mc iwksp(jnext) = jcoef(nwdiag+jstc+j-1) jnext = jnext + 1 end do j2 = jnext - 1 end if if (jjc == jmax .or. jjc == jmin) go to 50 jblkc = block(1,jjc) inc = jblkc*kblsz lim1 = inc - (ndb + ltrunc) lim2 = inc + (ndt + ltrunc) do 45 j = lim1,lim2 if (jjc <= lbhbsa) then do jj = j1,j2 if (iwksp(jj) == j) go to 45 end do end if iwksp(jnext) = j jnext = jnext + 1 block(3,jjc) = block(3,jjc) + 1 45 continue 50 continue if (lbhb >= 4) then do 52 jjc = 4,lbhb 52 block(2,jjc) = block(2,jjc-1) + block(3,jjc-1) end if end if ! ! copy matrix into wksp. ! if (propa) then nfactr = n*nwnew nfacti = 3*lbhb end if if (.not. propa .and. lvfill == 0) then nfactr = n*(maxnz + 2*ltrunc) nfacti = 3*lbhb end if if (lvfill > 0) then ndg = 0 do j = 1,lbhb ndg = ndg + block(3,j) end do nfactr = n*ndg nfacti = ndg + 3*lbhb end if call needw ('fillbn',0,ifactr,nfactr,ier) if (ier < 0) return call needw ('fillbn',1,ifacti,nfacti,ier) if (ier < 0) return call vfill ( nfactr, wksp(ifactr), 0.0D+00 ) ipt1 = 1 ipt2 = ifactr do j = 1,ndt+1 call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n end do 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 == 0) then do j = nwdiag+1,maxnz call vcopy (n,coef(ipt1),wksp(ipt2)) ipt1 = ipt1 + ndim ipt2 = ipt2 + n end do end if if (lvfill > 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) /= jcol) go to 65 ipt2 = iwkpt2 + (jj-j1)*n call vcopy (n,coef(ipt1),wksp(ipt2)) go to 70 65 continue 70 continue end if irpnt = ifactr + nfactr iipnt = ifacti + nfacti return end subroutine filln (maxnz,jcoef) ! !*****************************************************************************80 ! !! FILLN determines the fill-in diagonals for nonsymmetric diagonal storage. ! ! ! Parameters: ! ! maxnz upon input, the number of diagonals ! upon output, the number of diagonals with fill-in ! jcoef upon input, the diagonal numbers ! upon output, the diagonal numbers with fill-in ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jcoef(2) ! maxn = maxnz do j1 = 1,maxnz do 15 j2 = 1,maxnz jd = jcoef(j1) + jcoef(j2) if (jcoef(j1)*jcoef(j2) >= 0) go to 15 do j3 = 1,maxn if (jcoef(j3) == jd) go to 15 end do maxn = maxn + 1 jcoef(maxn) = jd 15 continue end do maxnz = maxn return end subroutine fillnp (ndim,nn,maxcc,jc,c,mwidth,ier) ! !*****************************************************************************80 ! !! FILLNP determines the fill-in structure. ! ! ! (Purdue storage, nonsymmetric matrix) ! ! Parameters: ! ! ndim row dimension of jc and c arrays ! n order of system (= nn) ! maxc upon input, maxc is the number of columns in ! the c array ! upon output, maxc is the number of columns in ! the c array with fill-in ! jc integer array of active size n by maxc giving the ! column numbers of the corresponding elements in c ! c array of active size n by maxc giving the ! coefficients of the off-diagonal elements ! mwidth maximum column width to be allowed for fill-in ! ier error code ! = 0 no errors detected ! = -2 mwidth too small to accomodate fill-in ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jc(ndim,1) dimension c(ndim,1) ! ! n = nn maxc = maxcc maxu = maxc if (maxc < 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) /= k) go to 35 do 30 j2 = 1,maxc j = jc(k,j2) if (j <= k .or. j == i) go to 30 do j3 = 1,maxu if (j == iabs(jc(i,j3))) go to 30 end do do 15 j3 = 1,maxu if (jc(i,j3) /= i) go to 15 jc(i,j3) = -j go to 30 15 continue maxu = maxu + 1 if (maxu <= mwidth) go to 20 ier = -2 return 20 do ii = 1,n jc(ii,maxu) = ii c(ii,maxu)= 0.0D+00 end do jc(i,maxu) = -j 30 continue 35 continue 40 continue 45 continue ! ! Decode new elements of jt, jb. ! jc(1:n,1:maxu) = abs ( jc(1:n,1:maxu) ) maxcc = maxu return end subroutine fills ( maxt, jt ) ! !*****************************************************************************80 ! !! FILLS determines the fill-in diagonals for symmetric diagonal storage. ! ! ! Parameters: ! ! maxt upon input, the number of diagonals in the ! upper triangle ! upon output, the number of diagonals in the ! upper triangle with fill-in ! jt upon input, the diagonal numbers in the upper ! triangle ! upon output, the diagonal numbers in the upper ! triangle with fill-in ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jt(1) ! maxn = maxt do j1 = 1,maxt do 15 j2 = 1,maxt jd = jt(j1) - jt(j2) if (jd <= 0) go to 15 do j3 = 1,maxn if (jt(j3) == jd) go to 15 end do maxn = maxn + 1 jt(maxn) = jd 15 continue end do maxt = maxn return end subroutine fillsp (ndim,nn,maxtt,jt,t,mwidth,ier) ! !*****************************************************************************80 ! !! FILLSP determines the fill-in structure. ! ! (Purdue storage, symmetric matrix) ! ! Parameters: ! ! ndim row dimension of t and jt arrays ! n order of system (= nn) ! maxt upon input, maxt is the number of columns in ! the t array ! upon output, maxt is the number of columns in ! the t array with fill-in ! jt integer array of active size n by maxt giving the ! column numbers of the corresponding elements in t ! t array of active size n by maxt giving the ! coefficients of the upper triangle of the matrix ! mwidth maximum column width of jt and t to be allowed ! ier error code ! = 0 no error detected ! = -2 mwidth too small to store factor ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension t(ndim,1) integer jt(ndim,1) ! n = nn maxt = maxtt maxu = maxt ier = 0 if (maxt < 1) return nm1 = n - 1 do 40 k = 1,nm1 do 35 j1 = 1,maxt jcol1 = jt(k,j1) if (jcol1 <= 0 .or. jcol1 == k) go to 35 do 30 j2 = 1,maxt jcol2 = jt(k,j2) if (jcol2 <= 0 .or. jcol2 == k) go to 30 if (jcol2 <= jcol1) go to 30 do j3 = 1,maxu if (jcol2 == iabs(jt(jcol1,j3))) go to 30 end do do 15 j3 = 1,maxu if (jt(jcol1,j3) /= jcol1) go to 15 jt(jcol1,j3) = -jcol2 go to 30 15 continue maxu = maxu + 1 if (maxu <= mwidth) go to 20 ier = -2 return 20 do i = 1,n jt(i,maxu) = i t(i,maxu) = 0.0D+00 end do jt(jcol1,maxu) = -jcol2 30 continue 35 continue 40 continue ! ! Decode new elements of jt. ! jt(1:n,1:maxu) = abs ( jt(1:n,1:maxu) ) maxtt = maxu return end subroutine gauss (ndim,n,a,rhs,u,ier) ! !*****************************************************************************80 ! !! GAUSS is a Gaussian elimination routine. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension a(ndim,ndim), rhs(ndim), u(ndim) common / itcom4 / srelpr, keygs, keyzer ier = 0 do i = 1, n-1 if ( abs ( a(i,i)) < srelpr**2 ) then ier = -100 return end if do j = i+1,n fact = a(j,i)/a(i,i) a(j,i) = 0.0D+00 do k = i+1,n a(j,k) = a(j,k) - fact*a(i,k) end do rhs(j) = rhs(j) - fact*rhs(i) end do end do do i = 1,n k = n - i + 1 if (abs(a(k,k)) < srelpr**2) go to 999 u(k) = rhs(k) if (i == 1) go to 44 do j = k+1,n u(k) = u(k) - u(j)*a(k,j) end do 44 u(k) = u(k)/a(k,k) end do return 999 ier = -100 return end subroutine getblk ( coef, jcoef, n, nblk, nband, ctac, nw, ier ) ! !*****************************************************************************80 ! !! GETBLK computes and factors the matrix (C**t)*A*C and factors it. ! ! ! this is a utility routine for the cgcr algorithm. ! here, each column of c is zero ! everywhere except it is all 1's on one of its blocks. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension ctac(nblk,1), coef(1), jcoef(2) logical symm ! common / itcom4 / srelpr, keygs, keyzer common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! ! data common blocks ! common / dscons / ndim, mdim, maxnz ! ! nband = 0 ! ! Find the bandwidth ! idmin = 0 idmax = 0 do i=1,maxnz idiag = jcoef(i) idmin = min (idmin,idiag) idmax = max (idmax,idiag) end do if (nstore == 2) idmin = - idmax ihalf = max(-idmin,idmax) nbsiz = n / nblk nhband = (ihalf+nbsiz-1)/nbsiz nband = 1 + 2*nhband ! ! now form the matrix. basically what we need to do here is to ! add up all the elements in each block of the a-matrix. ! if (nblk*nband > nw) go to 999 nw = nblk*nband call vfill ( nblk*nband, ctac, 0.0D+00 ) ! ! 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 ! symm = nstore==2 .and. idiag/=0 idm1 = idiag - 1 iomid = -idm1 nmid = n - idiag nhbp1 = nhband + 1 ! ! loop over the rows of ctac. ! do 2 j=ibbeg,ibend ibeg = max(1+(j-1)*nbsiz,iomid) iend = min(j*nbsiz,nmid) ! ic1 = (ibeg+idiag-1)/nbsiz + 1 ! ic2 = (iend+idiag-1)/nbsiz + 1 ! id1 = ic1 - j + nhband + 1 ! 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 /= id2) go to 3 ! ctac(j,id1) = ctac(j,id1) ! a + vadd(iend-ibeg+1,coef(ibase+ibeg)) ! do ii=ibeg,iend if (symm) ctac(j1s,id1s) = ctac(j1s,id1s) + coef(ibase+ii) ctac(j,id1) = ctac(j,id1) + coef(ibase+ii) end do go to 2 !3 imid = 1 + (ic2-1)*nbsiz - idiag 3 imid = iomid + itemp2*nbsiz ! ctac(j,id1) = ctac(j,id1) ! 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) ! ctac(j,id2) = ctac(j,id2) ! 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) ! 2 continue ! 1 continue ! ! do lu factorization ! do i=1,nblk-1 denom = ctac(i,nhbp1) if (abs(denom) < srelpr) go to 998 xpivot = 1.0D+00 / denom nsubmt = min(nhband,nblk-i) do j=1,nsubmt ipj = i + j ind2 = nhbp1 - j do k=1,nsubmt ind = nhbp1 - j + k ctac(ipj,ind) = ctac(ipj,ind) - xpivot*ctac(ipj,ind2)*ctac(i,nhbp1+k) end do end do do j=1,nsubmt ipj = i + j ind1 = nhbp1 - j ind2 = nhbp1 + j ctac(ipj,ind1) = ctac(ipj,ind1)*xpivot ctac(i ,ind2) = ctac(i ,ind2)*xpivot end do end do return ! ! error returns ! ! breakdown. ! 998 ier = -6 call ershow (ier,'getblk') return ! ! insuff. memory. ! 999 ier = -2 call ershow (ier,'getblk') nw = nblk*nband return end subroutine gmres (suba,subat,subql,subqlt,subqr,subqrt,subadp,coef,jcoef, & n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! GMRES is the user interface to the truncated/restarted GMRES algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2) dimension wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! nw = lenr - irpnt + 1 call gmresw (suba,subql,subqr,coef,jcoef,wksp,iwksp,n,u,ubar,rhs, & wksp(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine gmresw (suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & wk,nw,iparm,rparm,ier) ! !*****************************************************************************80 ! !! GMRESW runs the truncated/restarted GMRES algorithm. ! ! ! a detailed ! description of this useful algorithm may be found in the paper, ! "gmres: a generalized minimal residual algorithm for solving ! nonsymmetric linear systems", youcef saad and martin h. schultz, ! siam j. sci. stat. comput., v. 7, no. 3, july 1986. ! ! further scoop on how to set up qr factorizations can be obtained in ! "practical use of some krylov subspace methods for solving ! indefinite and unsymmetric linear systems", youcef saad, siam j. sci. ! stat. comput., v. 5, no. 1, march 1984. ! ! the advantage of this algorithm over its competitors orthomin and gcr ! is that work and storage are saved by avoiding the computation of ! certain vectors. ! ! this routine now handles right and 2-sided preconditioning. the main ! thing to note about this is that a new table of basis vecttors is now ! necessary, to use to update the solution. ! ! this routine also avoids explicit scaling of the p and w vectors. ! ! for the pure restarted case, we actually compute the final arnoldi ! vector, rather than just estimating its norm. this is a diversion ! from the saad/schultz paper. this was done because in some cases it ! was found that the norm estimation was subject to significant ! numerical error. ! ! modified feb. 1990 to make the restarted method more efficient. ! specifically, new formulas were installed for the scalar part of ! the computation to give an optimal asymptotic dependence on ns2. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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 ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! ! ! indexing functions. ! ! the following function accesses the arnoldi vectors. indp(i) = ip + mod(i,nv)*n ! ! the following accesses q-r times the arnoldi vectors indpt(i) = ipt + mod(i,nvt)*n ! ! fudge factor for the arnoldi vectors. p(actual) = p(stored)*pfudge. ! (we do the same trick with a*p.) indpf(i) = ipf + mod(i,nv) ! ! the following accesses the w-vectors. indw(i) = iw + n*mod(i,nv) ! ! fudge factors for the w vectors. ! ! (similarly, the vector "xi" is fudged.) indwf(i) = iwf + mod(i,nv) ! ! the following accesses the Hessenberg matrix -- stored by diagonals. ! indhes(i,j) = ihess + (i-1) + (j-i+1)*nhess ! ! the following are the cosines and sines of the rotations. indc(i) = icos + mod(i,nrot) inds(i) = isin + mod(i,nrot) ! ! the following accesses the u matrix -- stored by columns. ! indu(i,j) = iu + j-i+1 + mod(j-1,nuc)*nbwuh ! ! the following accesses the z-vector. ! indzc(i) = izc + mod(i-1,nzc) ! ! preliminary calculations. ! nwusd = 0 ier = 0 iacel = 11 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 996 iql = iqlr==1 .or. iqlr==3 iqr = iqlr==2 .or. iqlr==3 iadpt = ns3 evadpt = (maxadd.or.minadd) .and. iadpt/=0 trunc = ns1 < (ns2-1) exact = .not. trunc if (ns1 < 2) go to 995 if (level >= 2) write (nout,496) 496 format (' gmres') ! ! initialize the stopping test. ! call inithv (0) zdhav = .not. (trunc .and. .not.exact) nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 730 ! ! uneed tells us whether u must be computed explicitly per iteration. ! similarly for zneed. uneed = rcalp .or. udhav .or. ntest == 6 .or. level >= 3 zneed = zcalp hadest = .false. ! ! associated integer variables. ! ! effective ns2. ns2e = min(ns2,itmax) ! length of diags of hess matrix. nhess = ns2e + 2 ! bandwidth of the hess matrix. nbwh = min(ns1+1,ns2e+1) ! bandwidth of u-or-h. nbwuh = min(ns1+2, ns2e+1) ! number columns stored of the u matrix. if ( trunc) nuc = 1 if (.not.trunc) nuc = ns2e ! 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 ! number of givens rotations to store. nrot = min(ns1,ns2e) ! number of elts of z-vector to store. if ( trunc) nzc = 2 if (.not.trunc) nzc = ns2e + 1 ! ! memory layout. ! 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) ! ! check the memory usage. ! if (nwusd > nw) go to 999 ! in = 0 is = 0 rstrtd = .true. ! ! begin iteration loop. ! ! handle first iteration after restart. ! ! 10 call inithv (1) zdhav = .not.(trunc.and..not.exact) .and. in/=0 if (.not. rstrtd) go to 100 ! 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 ! get resid norm. if (.not. zdhav) then zdot = vdot (n,wk(iz),wk(iz)) zdhav = .true. end if if (zdot < 0.0D+00 ) go to 994 vnorm = sqrt(zdot) if (vnorm < srelpr**2) go to 997 call vcopy (n,wk(iz),wk(indp(is))) wk(indpf(is)) = 1.0D+00 / vnorm wk(indzc(is+1)) = vnorm ! ! perform stopping test. ! 100 nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,wk(iz),xxx,wk(iv1),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv1-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! ! rstrt tells us whether this is the last step before restarting. ! rstrt = (is+1 == ns2) if (evadpt .and. is==0) call vfill ( nhess*nbwh, wk(ihess), 0.0D+00 ) ! ! compute the new arnoldi vector. ! ! pn(is+1)*p(is+1) = a*p(is) + sum (i=0 to is) (beta(is+1,i)*p(i)), ! ! get a times old vec. if (iqr) call subqr (coef,jcoef,wfac,jwfac,n,wk(indp (is)),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)) ! compute arnoldi vector. ibeg = max(is+1-ns1,0) iend = is if (ibeg > 0) wk(indu(ibeg,is+1)) = 0.0D+00 pfnew = apf do 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 == ibeg) call vtriad (n,wk(indp(is+1)),wk(iv2), & -h*wk(indpf(i))/pfnew,wk(indp(i)),1) if (i /= ibeg) call vtriad (n,wk(indp(is+1)),wk(indp(is+1)), & -h*wk(indpf(i))/pfnew,wk(indp(i)),1) end do wk(indpf(is+1)) = pfnew ! get norm. dot = vdot (n,wk(indp(is+1)),wk(indp(is+1))) * pfnew**2 vnorm = sqrt(dot) if (vnorm < srelpr**2) go to 192 wk(indu(is+2,is+1)) = vnorm if (evadpt) wk(indhes(is+2,is+1)) = vnorm ! scale. wk(indpf(is+1)) = wk(indpf(is+1))/vnorm if (abs(wk(indpf(is+1))) 1.0D+00 / srelpr ) then call vtriad (n,wk(indp(is+1)),xxx,wk(indpf(is+1)), wk(indp(is+1)),2) wk(indpf(is+1)) = 1.0D+00 end if ! ! update the qr factorization. ! 192 continue ! ! apply old rotations. ! ibgn = max(0,is-ns1) iuold = indu(ibgn+1,is+1) do 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 iuold = iunew end do iunew = indu(is+2,is+1) ! ! calc new rotation. ! v1 = wk(iuold) v2 = wk(iunew) denom = sqrt (v1**2 + v2**2) if (denom < srelpr) go to 998 wk(indc(is+1)) = v1/denom wk(inds(is+1)) = v2/denom ! ! apply new rotation. ! wk(iuold) = denom wk(iunew) = 0.0D+00 ! ! compute w, if needed. ! uc = wk(indu(is+1,is+1)) if (abs(uc) < srelpr**2) go to 998 if (.not.trunc) go to 572 ! ! case of explicit w calc. ! if (is == 0) then call vcopy (n,wk(indpt(is)),wk(indw(1))) wk(indwf(is+1)) = wk(indpf(is))/uc ! call vtriad (n,wk(indw(is+1)),xxx,1.0D+00/uc,wk(indpt(is)),2) go to 572 end if wfnew = wk(indpf(is)) ibeg = max(1,is+1-ns1) iend = is do i = ibeg, iend if (i == ibeg) call vtriad (n,wk(indw(is+1)),wk(indpt(is)), & -wk(indu(i,is+1))*wk(indwf(i))/wfnew,wk(indw(i)),1) if (i /= ibeg) call vtriad (n,wk(indw(is+1)),wk(indw(is+1)), & -wk(indu(i,is+1))*wk(indwf(i))/wfnew,wk(indw(i)),1) end do wk(indwf(is+1)) = wfnew/uc if (abs(wk(indwf(is+1)))1.0D+00/srelpr) then call vtriad (n,wk(indw(is+1)),xxx,wk(indwf(is+1)),wk(indw(is+1)),2) wk(indwf(is+1)) = 1.0D+00 end if 572 continue ! ! 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)) ! ! u-vector computation section. ! if (trunc) then ! ! truncated case. call vtriad (n,u,u,wk(indzc(is+1))*wk(indwf(is+1)),wk(indw(is+1)),1) else ! ! non-truncated case. if (.not.(uneed .or. rstrt)) go to 410 iynew = iv1 nwusd = max(nwusd,iynew+ns2e-1) if (nwusd > nw) go to 999 ! 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)) ! form iterate. do 625 i = 0, nm-1 val = wk(iynew+i) if (uneed .and. i/=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)) end if 410 continue ! ! residual computation section. ! zhvold = zhave zhave = .false. if (trunc) go to 671 ! ! non-truncated case. ! ! do it if resid needed by pstop or if restarting. if (zneed .or. rstrt) then ipznew = iv1 nwusd = max(nwusd,ipznew+ns2e) if (nwusd > nw) go to 999 call vcopy (is+1,wk(izc),wk(ipznew)) wk(ipznew+is+1) = 0.0D+00 ! 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 ! form resid. do 645 i = 0, is+1 val = wk(ipznew+i) if (zhvold .and. i/=is+1) val = val - wk(ipz) 645 call vtriad (n,wk(iz),wk(iz),-val*wk(indpf(i)),wk(indp(i)),1) call vcopy (is+2,wk(ipznew),wk(ipz)) zhave = .true. end if go to 425 ! ! truncated case. ! ! do it if pstop needs it or if we may restart later. 671 if ( zneed .or. (itmax>ns2) ) then ! update xi. if (is == 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),wk(indc(is))*wk(indpf(is))/xif, & wk(indp(is)),1) end if if (abs(xif)1.0D+00/srelpr) then call vtriad (n,wk(ixi),xxx,xif,wk(ixi),2) xif = 1.0D+00 end if ! form resid. call vtriad (n,wk(iz),wk(iz), & -wk(indzc(is+1))*wk(indc(is+1))*xif,wk(ixi),1) call vtriad (n,wk(iz),wk(iz), & -wk(indzc(is+1))*wk(inds(is+1))*wk(indpf(is+1)),wk(indp(is+1)),1) zhave = .true. end if 425 continue ! ! get resid norm. ! if (exact) then zdot = wk(indzc(is+2))**2 end if ! ! ev est. ! if (evadpt) then nwhe = nw - (iv1-1) call hesest (wk(ihess),nhess,nv+2,is+1,iadpt,havest,emaxnw,eminnw, & wk(iv1),nwhe,ier) nwusd = max(nwusd,iv1-1+nwhe) if (ier /= 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 ! ! finish up the iteration. ! 874 in = in + 1 is = is + 1 if (rstrt) is = 0 rstrtd = rstrt go to 10 ! ! wrap it up. ! ! form u, if not up-to-date. ! 900 if (uneed .or. rstrtd .or. trunc) go to 901 iynew = iv1 nwusd = max(nwusd,iynew+ns2e-1) if (nwusd > nw) go to 999 ! 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)) ! ! 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) ! ! Head out of here. ! 901 continue if (halt) go to 715 ier = 1 call ershow (ier,'gmresw') zeta = stptst go to 725 715 continue if (level >= 1) write (nout,720) in 720 format (/' gmres converged in ',i5,' iterations.') ! 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! Error returns. ! 994 ier = -15 call ershow (ier,'gmresw') return ! 995 ier = -16 call ershow (ier,'gmresw') return ! 996 call ershow (ier,'gmresw') go to 735 ! 997 ier = -13 call ershow (ier,'gmresw') go to 725 ! 998 ier = -14 call ershow (ier,'gmresw') go to 725 ! 999 ier = -2 call ershow (ier,'gmresw') go to 735 ! end subroutine hesest (hess,nhess,nd,esize,imode,havest,emax,emin,wk,nw,ier) ! !*****************************************************************************80 ! !! HESEST calculates the extremal eigenvalue moduli of a banded Hessenberg matrix. ! ! ! Parameters: ! ! hess - the Hessenberg matrix, stored by diagonals ! nhess, nd - dimensions of array hess ! esize - indicator of how many rows/cols of hess have been ! filled out so far ! imode - style of eigenvalue estimation: ! abs(imode) - use this size of principal submatrix to do estimate ! sign(imode) - use either leading or trailing principal submatrix ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension hess(nhess,nd), wk(1) logical havest integer esize ! havest = .false. if (imode > 0 .and. esize > imode) return ! ! memory allocation ! ndim = min(esize,iabs(imode)) if (ndim <= 0) return imat = 1 ireal = imat + ndim*ndim iimag = ireal + ndim nwusd = iimag - 1 + ndim if (nwusd > nw) go to 999 nw = nwusd ! ! make the hess matrix into a full matrix ! if (imode < 0) go to 1 ibeg = 1 iend = esize go to 2 1 ibeg = max (1,esize-iabs(imode)+1) iend = esize 2 continue call vfill ( ndim*ndim, wk(imat), 0.0D+00 ) 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) ! ! Call EISPACK routine to calculate eigenvalues ! ierr = 0 call hqr (ndim,ndim,1,ndim,wk(imat),wk(ireal),wk(iimag),ierr) if (ierr /= 0) go to 998 ! ! Find eigenvalues with largest and smallest modulus ! emax = wk(ireal)**2 + wk(iimag)**2 emin = emax do i=2,ndim vmod = wk(ireal-1+i)**2 + wk(iimag-1+i)**2 emax = max (emax,vmod) emin = min (emin,vmod) end do emax = sqrt (emax) emin = sqrt (emin) havest = .true. return ! ! ! error returns ! ! error in call to eispack 998 ier = -18 call ershow (ier,'hesest') return ! ! insuff. real workspace 999 ier = -2 nw = nwusd call ershow (ier,'hesest') return end subroutine hqr(nm,n,low,igh,h,wr,wi,ierr) !*****************************************************************************80 ! !! HQR finds the eigenvalues of a real upper Hessenberg matrix by the QR method. ! ! HQR is a translation of the algol procedure hqr, ! num. math. 14, 219-231(1970) by martin, peters, and wilkinson. ! handbook for auto. comp., vol.ii-linear algebra, 359-371(1971). ! ! on input ! ! nm must be set to the row dimension of two-dimensional ! array parameters as declared in the calling program ! dimension statement. ! ! n is the order of the matrix. ! ! low and igh are integers determined by the balancing ! routine balanc. if balanc has not been used, ! set low=1, igh=n. ! ! h contains the upper Hessenberg matrix. information about ! the transformations used in the reduction to Hessenberg ! form by elmhes or orthes, if performed, is stored ! in the remaining triangle under the Hessenberg matrix. ! ! on output ! ! h has been destroyed. therefore, it must be saved ! before calling hqr if subsequent calculation and ! back transformation of eigenvectors is to be performed. ! ! wr and wi contain the real and imaginary parts, ! respectively, of the eigenvalues. the eigenvalues ! are unordered except that complex conjugate pairs ! of values appear consecutively with the eigenvalue ! having the positive imaginary part first. if an ! error exit is made, the eigenvalues should be correct ! for indices ierr+1,...,n. ! ! ierr is set to ! zero for normal return, ! j if the limit of 30*n iterations is exhausted ! while the j-th eigenvalue is being sought. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer i,j,k,l,m,n,en,ll,mm,na,nm,igh,itn,its,low,mp2,enm2,ierr real ( kind = 8 ) h(nm,n),wr(n),wi(n) real ( kind = 8 ) p,q,r,s,t,w,x,y,zz,norm,tst1,tst2 logical notlas ! ierr = 0 norm = 0.0D+00 k = 1 ! ! Store roots isolated by balanc and compute matrix norm. ! do 50 i = 1, n do j = k, n norm = norm + abs(h(i,j)) end do k = i if ( i >= low .and. i <= igh ) go to 50 wr(i) = h(i,i) wi(i) = 0.0D+00 50 continue en = igh t = 0.0D+00 itn = 30*n ! ! Search for next eigenvalues. ! 60 if (en < low) go to 1001 its = 0 na = en - 1 enm2 = na - 1 ! ! Look for single small sub-diagonal element ! for l=en step -1 until low do --........ 70 do 80 ll = low, en l = en + low - ll if (l == low) go to 100 s = abs(h(l-1,l-1)) + abs(h(l,l)) if ( s == 0.0D+00 ) then s = norm end if tst1 = s tst2 = tst1 + abs(h(l,l-1)) if (tst2 == tst1) go to 100 80 continue ! ........ form shift. 100 x = h(en,en) if (l == en) go to 270 y = h(na,na) w = h(en,na) * h(na,en) if (l == na) go to 280 if (itn == 0) go to 1000 if (its /= 10 .and. its /= 20) go to 130 ! ........ form exceptional shift. t = t + x ! do 120 i = low, en 120 h(i,i) = h(i,i) - x ! s = abs(h(en,na)) + abs(h(na,enm2)) x = 0.75 * s y = x w = -0.4375 * s * s 130 its = its + 1 itn = itn - 1 ! ........ look for two consecutive small ! sub-diagonal elements. ! 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 == 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 == tst1) go to 150 140 continue ! 150 mp2 = m + 2 ! do 160 i = mp2, en h(i,i-2) = 0.0D+00 if (i == mp2) go to 160 h(i,i-3) = 0.0D+00 160 continue ! ........ double qr step involving rows l to en and ! columns m to en........ do 260 k = m, na notlas = k /= na if (k == m) go to 170 p = h(k,k-1) q = h(k+1,k-1) r = 0.0D+00 if (notlas) r = h(k+2,k-1) x = abs(p) + abs(q) + abs(r) if ( x == 0.0D+00 ) 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 == m) go to 180 h(k,k-1) = -s * x go to 190 180 if (l /= 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 ! ! Row modification. ! do 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 end do j = min(en,k+3) ! ! Column modification. ! do 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 end do go to 255 225 continue ! ........ row modification. do 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 end do j = min(en,k+3) ! ........ column modification. do 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 end do 255 continue ! 260 continue ! go to 70 ! ........ one root found. 270 wr(en) = x + t wi(en) = 0.0D+00 en = na go to 60 ! ........ two roots found. 280 p = (y - x) / 2.0 q = p * p + w zz = sqrt(abs(q)) x = x + t if (q < 0.0D+00) go to 320 ! ........ real pair. zz = p + sign(zz,p) wr(na) = x + zz wr(en) = wr(na) if (zz /= 0.0D+00) wr(en) = x - w / zz wi(na) = 0.0D+00 wi(en) = 0.0D+00 go to 330 ! ........ complex pair. 320 wr(na) = x + p wr(en) = x + p wi(na) = zz wi(en) = -zz 330 en = enm2 go to 60 ! ........ set error -- all eigenvalues have not ! converged after 30*n iterations. 1000 ierr = en 1001 return end subroutine ibbs (ldd,ldt,n,kblszz,nsize,lbhb,block,d,t,jt,x,ivers,wksp) ! !*****************************************************************************80 ! !! IBBS does an incomplete block backward pass. ! ! ! symmetric diagonal data structure, natural ordering. ! block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! kblsz block size ! nsize size of an individual subsystem within a ! diagonal block ! lbhb number of blocks per block row ! block integer array of size 3 by lbhb ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer vector giving the diagonal numbers ! for the off-diagonal blocks ! x input/output vector of length n ! ivers key for version of factorization ! = 1 version 1 ! = 2 version 2 ! wksp real workspace vector ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jt(1), block(3,1) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical vers2 ! kblsz = kblszz l = n/kblsz nt = block(3,1) - 1 vers2 = ivers == 2 do 40 k = l,1,-1 ist = (k - 1)*kblsz + 1 ied = k*kblsz if (k == l) go to 15 jjlim = min (lbhb,l-k+2) do jj = 3,jjlim jblk = block(1,jj) jst = block(2,jj) mjj = block(3,jj) inc = jblk*kblsz istf = ist + inc if ( istf <= n ) then call vsubd (ldt,1,kblsz,kblsz,mjj,t(ist,jst),jt(jst), & x(ist),x(istf),inc) end if end do 15 if (nt >= 1) go to 25 x(ist:ied) = d(ist:ied,1)*x(ist:ied) go to 40 25 if (vers2) go to 30 call bdsol (ldd,kblsz,nsize,nt,0,d(ist,1),x(ist),x(ist),0) go to 40 30 call bmul (ldd,kblsz,nt,d(ist,1),d(ist,2),x(ist),wksp) do i = ist,ied x(i) = wksp(i-ist+1) end do 40 continue return end subroutine ibbsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,block,d,t,jt,x, & ivers,iunif,wksp) ! !*****************************************************************************80 ! !! IBBSN does an incomplete block backward solve. ! ! ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! nsize size of an individual subsystem within a ! diagonal block ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0. formed in the factorization routine. ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! block integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! x input/output vector of length n ! ivers key for version number ! = 1 version 1 ! = 2 version 2 ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! wksp real workspace vector ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), block(3,ncolor,2) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical unif, vers2 ! vers2 = ivers == 2 unif = iunif == 1 ! l = ncolor if ( unif ) then na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = block(3,1,1) - 1 ndb = block(3,1,2) kk = 1 end if ! ! do backward solution. ! 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 = block(3,k,1) - 1 ndb = block(3,k,2) go to 20 15 ist = (k - 1)*na + 1 20 ied = ist + na - 1 wksp(1:na) = 0.0D+00 do j = 3,jlim jcol = k + block(1,kk,j) if ( k < jcol ) then jstb = block(2,kk,j) mb = block(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 <= n ) then call vaddd (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb),wksp, & x(istb),inc) end if end if end do if (ndt + ndb >= 1) go to 35 do i = ist,ied x(i) = x(i) - d(i,1)*wksp(i-ist+1) end do go to 50 35 if (vers2) go to 40 call bdsol (ldd,na,nsize,ndt,ndb,d(ist,1),wksp,wksp,1) do i = ist,ied x(i) = x(i) - wksp(i-ist+1) end do go to 50 40 nap1 = na + 1 call bmuln (ldd,na,ndt,ndb,d(ist,1),d(ist,2),d(ist,ndt+2),wksp,wksp(nap1)) do i = ist,ied x(i) = x(i) - wksp(i-ist+nap1) end do 50 continue return end subroutine ibbsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,block,d,t,jt,x, & ivers,iunif,wksp) ! !*****************************************************************************80 ! !! IBBSNT does an incomplete block transpose backward solve. ! ! ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! nsize size of an individual subsystem within a ! diagonal block ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0. formed in the factorization routine. ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! block integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! x input/output vector of length n ! ivers key for version number ! = 1 version 1 ! = 2 version 2 ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), block(3,ncolor,2) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical unif, vers1 ! vers1 = ivers == 1 unif = iunif == 1 ! l = ncolor if (.not. unif) go to 10 na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = block(3,1,1) - 1 ndb = block(3,1,2) kk = 1 ! ! do backward solution. ! 10 continue do 45 k = l,1,-1 if (unif) go to 15 kk = k ist = ipt(k) + 1 jlim = lbhb(k) na = nci(k) ndt = block(3,k,1) - 1 ndb = block(3,k,2) go to 20 15 ist = (k - 1)*na + 1 20 ied = ist + na - 1 if (ndt + ndb >= 1) go to 30 x(ist:ied) = d(ist:ied,1)*x(ist:ied) go to 35 30 if (vers1) call bdsolt(ldd,na,nsize,ndt,ndb,d(ist,1),x(ist),x(ist)) if (vers1) go to 35 call bmulnt (ldd,na,ndt,ndb,d(ist,1),d(ist,2),d(ist,ndt+2),x(ist),wksp) do i = ist,ied x(i) = wksp(i-ist+1) end do 35 do 40 j = 3,jlim jcol = k + block(1,kk,j) if (jcol >= k) go to 40 jstb = block(2,kk,j) mb = block(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 < 1) go to 40 call vsubdt (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb), & x(istb),x(ist),inc) 40 continue 45 continue return end subroutine ibfcn1 (lddd,ldtt,n,jd,jt,d,t,ncol,nci,iblock,lbhb,iunif,ipropa, & ipt,omega,wksp,ier) ! !*****************************************************************************80 ! !! IBFCN1 does an incomplete block factorization. ! ! ! The matrix is contained in d and t (version 1, unmodified). ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic (version 1) preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! jd integer array of size ncolor by whatever ! giving the diagonal block diagonal numbers for ! each distinct block size. jd is 1 by whatever ! if iunif = 1. ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! d array for diagonal block ! t array for off-diagonal blocks ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! ipropa property a switch ! = 0 matrix does not have block property a ! = 1 matrix has block property a ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0 ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jd(ncol,1), jt(ncol,1), nci(1), lbhb(1), iblock(3,ncol,2) dimension d(lddd,1), t(ldtt,1), wksp(1) logical unif, propa ! ldd = lddd ldt = ldtt ncolor = ncol unif = iunif == 1 propa = ipropa == 1 ! ! define various constants. ! if ( .not. unif ) then klim = ncolor else 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 end if ! ! start factorization. ! 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 == klim .or. jlim <= 2) go to 95 do 90 i = k+1,klim if (unif) go to 35 ii = i llim = lbhb(i) 35 if (llim <= 2) go to 90 do l = 3,llim jcol = i + iblock(1,ii,l) if (jcol == k) go to 45 end do 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 <= k) go to 85 jdiff = jcol - i if (jdiff /= 0 .and. propa) go to 85 do m = 1,llim if (iblock(1,ii,m) == jdiff) go to 65 end do 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 == 1) go to 80 call t1prod (na,ldt,ldt,ldt,ncolor,na,nc,nb, & ma,mb,mc,md,incb,incc,incd,jd(kk,1), & jt(kk,jstb),jt(ii,jstc), & jt(ii,jstd),wksp,t(istb,jstb), & 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, & ma,mb,mc,md,incb,incc,incd,jd(kk,1), & jt(kk,jstb),jt(ii,jstc), & jd(ii,jstd),wksp,t(istb,jstb), & 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,iblock,lbhb,iunif, & ipropa,ipt,omega,wksp,ier) ! !*****************************************************************************80 ! !! IBFCN2 does an incomplete block factorization. ! ! the matrix is contained in d and t (version 2, unmodified). ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic (version 2) preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! jd integer array of size ncolor by whatever ! giving the diagonal block diagonal numbers for ! each distinct block size. jd is 1 by whatever ! if iunif = 1. ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! d array for diagonal block ! t array for off-diagonal blocks ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! ipropa property a switch ! = 0 matrix does not have block property a ! = 1 matrix has block property a ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0 ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jd(ncol,1), jt(ncol,1), nci(1), lbhb(1), iblock(3,ncol,2) dimension d(lddd,1), t(ldtt,1), wksp(1) logical unif, propa ! ldd = lddd ldt = ldtt ncolor = ncol unif = iunif == 1 propa = ipropa == 1 ! ! define various constants. ! 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 ! ! start factorization. ! 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 == klim .or. jlim <= 2) go to 95 do 90 i = k+1,klim if (unif) go to 35 ii = i llim = lbhb(i) 35 if (llim <= 2) go to 90 do l = 3,llim jcol = i + iblock(1,ii,l) if (jcol == k) go to 45 end do 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 <= k) go to 85 jdiff = jcol - i if (jdiff /= 0 .and. propa) go to 85 do m = 1,llim if (iblock(1,ii,m) == jdiff) go to 65 end do 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 == 1) go to 80 call t1prod (ldd,ldt,ldt,ldt,ncolor,na,nc,nb, & ma,mb,mc,md,incb,incc,incd,jd(kk,1), & jt(kk,jstb),jt(ii,jstc), & jt(ii,jstd),d(ist,1),t(istb,jstb), & 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, & ma,mb,mc,md,incb,incc,incd,jd(kk,1), & jt(kk,jstb),jt(ii,jstc), & jd(ii,jstd),d(ist,1),t(istb,jstb), & 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,iblock,lbhb,iunif, & ipropa,ipt,omega,wksp,ier) ! !*****************************************************************************80 ! !! IBFCN3 does an incomplete block factorization. ! ! ! The matrix is contained in d and t (version 1, modified). ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic (version 1) preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! jd integer array of size ncolor by whatever ! giving the diagonal block diagonal numbers for ! each distinct block size. jd is 1 by whatever ! if iunif = 1. ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! d array for diagonal block ! t array for off-diagonal blocks ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! ipropa property a switch ! = 0 matrix does not have block property a ! = 1 matrix has block property a ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0 ! omega relaxation factor between 0 and 1. ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jd(ncol,1), jt(ncol,1), nci(1), lbhb(1), iblock(3,ncol,2) dimension d(lddd,1), t(ldtt,1), wksp(1) logical unif, propa ! ldd = lddd ldt = ldtt ncolor = ncol unif = iunif == 1 propa = ipropa == 1 ! ! define various constants. ! 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 ! ! start factorization. ! 20 continue 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 == klim .or. jlim <= 2) go to 100 do 95 i = k+1,klim if (unif) go to 35 ii = i llim = lbhb(i) 35 if (llim <= 2) go to 95 do l = 3,llim jcol = i + iblock(1,ii,l) if (jcol == k) go to 45 end do 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 <= 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 /= 0 .and. propa) go to 85 do m = 1,llim if (iblock(1,ii,m) == jdiff) go to 75 end do go to 85 75 jstd = iblock(2,ii,m) md = iblock(3,ii,m) if (m == 1) go to 80 call t1prod (na,ldt,ldt,ldt,ncolor,na,nc,nb, & ma,mb,mc,md,incb,incc,incd,jd(kk,1), & jt(kk,jstb),jt(ii,jstc), & jt(ii,jstd),wksp,t(istb,jstb), & t(istc,jstc),t(istd,jstd)) call tsumn & (na,nc,nb,na,ldt,ldt,ncolor,ma,mb,mc,md,incb, & incc,incd,jd(kk,1),jt(kk,jstb),jt(ii,jstc), & jt(ii,jstd),wksp,t(istb,jstb),t(istc,jstc), & d(istd,1),omega) go to 85 80 md = md + iblock(3,ii,2) call t1prod (na,ldt,ldt,ldd,ncolor,na,nc,nb, & ma,mb,mc,md,incb,incc,incd,jd(kk,1), & jt(kk,jstb),jt(ii,jstc), & jd(ii,jstd),wksp,t(istb,jstb), & t(istc,jstc),d(istd,jstd)) call tsumn & (na,nc,nb,na,ldt,ldt,ncolor,ma,mb,mc,md,incb, & incc,incd,jd(kk,1),jt(kk,jstb),jt(ii,jstc), & jd(ii,jstd),wksp,t(istb,jstb),t(istc,jstc), & d(istd,1),omega) 85 call rowsum (ldt,na,mb,t(istb,jstb),wksp(ip1),1) wksp(ip1:ip2) = omega*wksp(ip1:ip2) call bdsol (ldd,na,na,ndt,ndb,d(ist,1),wksp(ip1),wksp(ip1),1) call vsubd (ldt,ncolor,nc,na,mc,t(istc,jstc), & 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,iblock,lbhb,iunif, & ipropa,ipt,omega,wksp,ier) ! !*****************************************************************************80 ! !! IBFCN4 does an incomplete block factorization. ! ! ! The matrix is contained in d and t (version 2, modified). ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic (version 2) preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! jd integer array of size ncolor by whatever ! giving the diagonal block diagonal numbers for ! each distinct block size. jd is 1 by whatever ! if iunif = 1. ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! d array for diagonal block ! t array for off-diagonal blocks ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! ipropa property a switch ! = 0 matrix does not have block property a ! = 1 matrix has block property a ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0 ! omega relaxation factor between 0 and 1. ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jd(ncol,1), jt(ncol,1), nci(1), lbhb(1), iblock(3,ncol,2) dimension d(lddd,2), t(ldtt,1), wksp(1) logical unif, propa ! ldd = lddd ldt = ldtt ncolor = ncol unif = iunif == 1 propa = ipropa == 1 ! ! define various constants. ! ip1 = n + 1 if (unif) go to 15 klim = ncolor do 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) end do 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) ! ! start factorization. ! 20 continue 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), & wksp(ist),wksp(ip1)) do iii = ist,isu if (wksp(iii) == 0.0D+00 ) then ier = -12 call ershow (ier,'ibfcn4') return end if end do do iii = ist,isu d(iii,1) = d(iii,1) + omega*(1.0D+00 - wksp(iii-ist+ip1))/wksp(iii) end do ip2 = ip1 + na if (k == klim .or. jlim <= 2) go to 100 do 95 i = k+1,klim if (unif) go to 35 ii = i llim = lbhb(i) 35 if (llim <= 2) go to 95 do l = 3,llim jcol = i + iblock(1,ii,l) if (jcol == k) go to 45 end do 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 <= 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 /= 0 .and. propa) go to 85 do m = 1,llim if (iblock(1,ii,m) == jdiff) go to 75 end do go to 85 75 jstd = iblock(2,ii,m) md = iblock(3,ii,m) if (m == 1) go to 80 call t1prod (ldd,ldt,ldt,ldt,ncolor,na,nc,nb, & ma,mb,mc,md,incb,incc,incd,jd(kk,1), & jt(kk,jstb),jt(ii,jstc), & jt(ii,jstd),d(ist,1),t(istb,jstb), & t(istc,jstc),t(istd,jstd)) call tsumn & (na,nc,nb,ldd,ldt,ldt,ncolor,ma,mb,mc,md,incb, & incc,incd,jd(kk,1),jt(kk,jstb),jt(ii,jstc), & jt(ii,jstd),d(ist,1),t(istb,jstb),t(istc,jstc), & wksp(istd),1.0D+00) go to 85 80 md = md + iblock(3,ii,2) call t1prod (ldd,ldt,ldt,ldd,ncolor,na,nc,nb, & ma,mb,mc,md,incb,incc,incd,jd(kk,1), & jt(kk,jstb),jt(ii,jstc), & jd(ii,jstd),d(ist,1),t(istb,jstb), & 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), & d(ist,ndt+2),wksp(ip1),wksp(ip2)) call vsubd (ldt,ncolor,nc,na,mc,t(istc,jstc), & 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, iblock,lbhb,ipropa,omega, & wksp,ier) ! !*****************************************************************************80 ! !! IBFCS1 does an incomplete block factorization. ! ! ! The matrix is contained in d and t (version 1, unmodified). ! symmetric diagonal data structure, natural ordering. ! block ic (version 1) preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! jd integer vector giving the diagonal numbers ! for the diagonal block ! jt integer vector giving the diagonal numbers ! for the off-diagonal blocks ! d array for diagonal block ! t array for off-diagonal blocks ! kblsz block size ! iblock integer array of size 3 by lbhb ! giving block constants ! lbhb number of blocks per block row ! ipropa property a switch ! = 0 matrix does not have block property a ! = 1 matrix has block property a ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jd(1), jt(1), iblock(3,3) dimension d(lddd,1), t(ldtt,1), wksp(1) logical propa ! n = nn ldd = lddd ldt = ldtt na = kblszz propa = ipropa == 1 klim = n/na ma = iblock(3,1) ndt = ma - 1 ! ! block tridiagonal case. ! if (lbhb > 3) go to 25 jblkb = iblock(1,3) mb = iblock(3,3) incb = jblkb*na do k = 1,klim ist = (k - 1)*na + 1 istd = ist + incb call bdfac (ldd,na,na,ndt,0,d(ist,1),0) if ( istd <= n ) then 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,incb,incb,0,jd,jt,jt,jd, & wksp,t(ist,1),t(ist,1),d(istd,1)) end if end do return ! ! general block structure. ! 25 continue do 50 k = 1,klim ist = (k - 1)*na + 1 call bdfac (ldd,na,na,ndt,0,d(ist,1),0) if (k == 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 > 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 < 0) go to 40 if (jdiff /= 0 .and. propa) go to 40 do jjd = 1,jjlim if (jdiff == iblock(1,jjd)) go to 35 end do go to 40 35 jblkd = iblock(1,jjd) jstd = iblock(2,jjd) md = iblock(3,jjd) incd = jblkd*na if (jjd /= 1) call t2prod(na,na,ldt,ldt,ldt,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jt(jstd),wksp,t(ist,jstb),t(ist,jstc),t(istd,jstd)) if (jjd == 1) call t2prod(na,na,ldt,ldt,ldd,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jd,wksp,t(ist,jstb),t(ist,jstc),d(istd,1)) 40 continue 45 continue 50 continue return end subroutine ibfcs2 (lddd,ldtt,nn,jd,jt,d,t,kblszz,iblock,lbhb,ipropa, & omega,wksp,ier) ! !*****************************************************************************80 ! !! IBFCS2 does an incomplete block factorization. ! ! ! The matrix is contained in d and t (version 2, unmodified). ! symmetric diagonal data structure, natural ordering. ! block ic (version 2) preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! jd integer vector giving the diagonal numbers ! for the diagonal block ! jt integer vector giving the diagonal numbers ! for the off-diagonal blocks ! d array for diagonal block ! t array for off-diagonal blocks ! kblsz block size ! iblock integer array of size 3 by lbhb ! giving block constants ! lbhb number of blocks per block row ! ipropa property a switch ! = 0 matrix does not have block property a ! = 1 matrix has block property a ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jd(1), jt(1), iblock(3,3) dimension d(lddd,1), t(ldtt,1), wksp(1) logical propa ! n = nn ldd = lddd ldt = ldtt na = kblszz propa = ipropa == 1 klim = n/na ma = iblock(3,1) ndt = ma - 1 ! ! block tridiagonal case. ! if (lbhb > 3) go to 25 jblkb = iblock(1,3) mb = iblock(3,3) incb = jblkb*na do 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 <= n ) then call t2prod (na,ldd,ldt,ldt,ldd,ma,mb,mb,ma,incb,incb,0,jd,jt,jt, & jd,d(ist,1),t(ist,1),t(ist,1),d(istd,1)) end if end do return ! ! general block structure. ! 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 == 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 > 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 < 0) go to 40 if (jdiff /= 0 .and. propa) go to 40 do jjd = 1,jjlim if (jdiff == iblock(1,jjd)) go to 35 end do go to 40 35 jblkd = iblock(1,jjd) jstd = iblock(2,jjd) md = iblock(3,jjd) incd = jblkd*na if (jjd /= 1) call t2prod(na,ldd,ldt,ldt,ldt,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jt(jstd),d(ist,1),t(ist,jstb),t(ist,jstc),t(istd,jstd)) if (jjd == 1) call t2prod(na,ldd,ldt,ldt,ldd,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jd,d(ist,1),t(ist,jstb),t(ist,jstc),d(istd,1)) 40 continue 45 continue 50 continue return end subroutine ibfcs3 (lddd,ldtt,nn,jd,jt,d,t,kblszz,iblock,lbhb,ipropa, & omegaa,wksp,ier) ! !*****************************************************************************80 ! !! IBFCS3 does an incomplete block factorization. ! ! ! The matrix is contained in d and t (version 1, modified). ! symmetric diagonal data structure, natural ordering. ! block ic (version 1) preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! jd integer vector giving the diagonal numbers ! for the diagonal block ! jt integer vector giving the diagonal numbers ! for the off-diagonal blocks ! d array for diagonal block ! t array for off-diagonal blocks ! kblsz block size ! iblock integer array of size 3 by lbhb ! giving block constants ! lbhb number of blocks per block row ! ipropa property a switch ! = 0 matrix does not have block property a ! = 1 matrix has block property a ! omega relaxation factor between 0. and 1. ! = 0 no modification ! = 1 full modification ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jd(1), jt(1), iblock(3,3) dimension d(lddd,1), t(ldtt,1), wksp(1) logical propa ! n = nn ldd = lddd ldt = ldtt na = kblszz omega = omegaa propa = ipropa == 1 klim = n/na ma = iblock(3,1) ndt = ma - 1 ! ! block tridiagonal case. ! if (lbhb > 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 > 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,incb,incb,0,jd,jt,jt,jd, & wksp,t(ist,1),t(ist,1),d(istd,1)) call tsum (na,na,ldt,ldt,ma,mb,mb,ma,incb,incb,0,jd,jt,jt,jd,wksp, & t(ist,1),t(ist,1),d(istd,1),d(istd,1),wksp(ip1),1,omega) call rowsum (ldt,na,mb,t(ist,1),wksp(ip1),1) do iii = ip1,ip2 wksp(iii) = omega*wksp(iii) end do call bdsol (ldd,na,na,ndt,0,d(ist,1),wksp(ip1),wksp(ip1),0) call vsubdt (ldt,1,na,na,mb,t(ist,1),jt,d(istd,1),wksp(ip1),incb) 20 continue return ! ! general block structure. ! 25 continue 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 == 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 > 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 > n) go to 50 jdiff = jblkb - jblkc if (jdiff < 0) go to 50 if (jdiff /= 0 .and. propa) go to 40 do jjd = 1,jjlim if (jdiff == iblock(1,jjd)) go to 35 end do go to 40 35 jblkd = iblock(1,jjd) jstd = iblock(2,jjd) md = iblock(3,jjd) incd = jblkd*na if (jjd /= 1) call t2prod(na,na,ldt,ldt,ldt,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jt(jstd),wksp,t(ist,jstb),t(ist,jstc), & t(istd,jstd)) if (jjd == 1) call t2prod(na,na,ldt,ldt,ldd,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jd,wksp,t(ist,jstb),t(ist,jstc), & d(istd,1)) if (jjd /= 1) call tsum(na,na,ldt,ldt,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jt(jstd),wksp,t(ist,jstb),t(ist,jstc), & d(istd,1),d(istdd,1),wksp(ip1),0,omega) if (jjd == 1) call tsum(na,na,ldt,ldt,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jd,wksp,t(ist,jstb),t(ist,jstc), & d(istd,1),d(istdd,1),wksp(ip1),1,omega) 40 call rowsum (ldt,na,mb,t(ist,jstb),wksp(ip1),1) wksp(ip1:ip2) = omega*wksp(ip1:ip2) call bdsol (ldd,na,na,ndt,0,d(ist,1),wksp(ip1),wksp(ip1),0) call vsubdt (ldt,1,na,na,mc,t(ist,jstc),jt(jstc), & d(istd,1),wksp(ip1),incc) if (jdiff == 0) go to 50 call rowsum (ldt,na,mc,t(ist,jstc),wksp(ip1),1) wksp(ip1:ip2) = omega*wksp(ip1:ip2) call bdsol (ldd,na,na,ndt,0,d(ist,1),wksp(ip1),wksp(ip1),0) call vsubdt (ldt,1,na,na,mb,t(ist,jstb),jt(jstb), & d(istdd,1),wksp(ip1),incb) 50 continue 55 continue 60 continue return end subroutine ibfcs4 (lddd,ldtt,nn,jd,jt,d,t,kblszz,iblock,lbhb,ipropa, & omegaa,wksp,ier) ! !*****************************************************************************80 ! !! IBFCS4 does an incomplete block factorization. ! ! ! The matrix is contained in d and t (version 2, modified). ! symmetric diagonal data structure, natural ordering. ! block ic (version 2) preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! jd integer vector giving the diagonal numbers ! for the diagonal block ! jt integer vector giving the diagonal numbers ! for the off-diagonal blocks ! d array for diagonal block ! t array for off-diagonal blocks ! kblsz block size ! iblock integer array of size 3 by lbhb ! giving block constants ! lbhb number of blocks per block row ! ipropa property a switch ! = 0 matrix does not have block property a ! = 1 matrix has block property a ! omega relaxation factor between 0. and 1. ! = 0 no modification ! = 1 full modification ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jd(1), jt(1), iblock(3,3) dimension d(lddd,2), t(ldtt,1), wksp(1) logical propa ! n = nn ldd = lddd ldt = ldtt na = kblszz omega = omegaa propa = ipropa == 1 klim = n/na ma = iblock(3,1) ndt = ma - 1 ! ! block tridiagonal case. ! if (lbhb > 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 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 ii = ist,isu if ( wksp(ii) == 0.0D+00 ) then ier = -12 call ershow (ier,'ibfcs4') return end if end do do ii = ist,isu d(ii,1) = d(ii,1) + omega*(1.0D+00 - wksp(ii-ist+ip1))/wksp(ii) end do if ( istd <= n ) then call t2prod (na,ldd,ldt,ldt,ldd,ma,mb,mb,ma,incb,incb,0,jd,jt,jt,jd, & d(ist,1),t(ist,1),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),wksp(ip2)) call vsubdt (ldt,1,na,na,mb,t(ist,1),jt,wksp(istd),wksp(ip2),incb) end if end do return ! ! general block structure. ! 25 continue 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 ii = ist,isu if (wksp(ii) == 0.0D+00 ) then ier = -12 call ershow (ier,'ibfcs4') return end if end do do ii = ist,isu d(ii,1) = d(ii,1) + omega*(1.0D+00 - wksp(ii-ist+ip1))/ wksp(ii) end do if (k == 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 > 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 > n) go to 50 jdiff = jblkb - jblkc if (jdiff < 0) go to 50 if (jdiff /= 0 .and. propa) go to 40 do jjd = 1,jjlim if (jdiff == iblock(1,jjd)) go to 35 end do go to 40 35 jblkd = iblock(1,jjd) jstd = iblock(2,jjd) md = iblock(3,jjd) incd = jblkd*na if (jjd /= 1) call t2prod(na,ldd,ldt,ldt,ldt,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jt(jstd),d(ist,1),t(ist,jstb),t(ist,jstc), & t(istd,jstd)) if (jjd == 1) call t2prod(na,ldd,ldt,ldt,ldd,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jd,d(ist,1),t(ist,jstb),t(ist,jstc), & d(istd,1)) if (jjd /= 1) call tsum(na,ldd,ldt,ldt,ma,mb,mc,md,incb, & incc,incd,jd,jt(jstb),jt(jstc), & jt(jstd),d(ist,1),t(ist,jstb),t(ist,jstc), & wksp(istd),wksp(istdd),wksp(ip1),0,1.0D+00) ! 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),wksp(ip2)) call vsubdt (ldt,1,na,na,mc,t(ist,jstc),jt(jstc), & wksp(istd),wksp(ip2),incc) if (jdiff == 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),wksp(ip2)) call vsubdt (ldt,1,na,na,mb,t(ist,jstb),jt(jstb), & wksp(istdd),wksp(ip2),incb) 50 continue 55 continue 60 continue return end subroutine ibfs (ldd,ldt,n,kblszz,nsize,lbhb,iblock,d,t,jt,x,ivers,wksp) ! !*****************************************************************************80 ! !! IBFS does an incomplete block forward pass. ! ! ! symmetric diagonal data structure, natural ordering. ! block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! kblsz block size ! nsize size of an individual subsystem within a ! diagonal block ! lbhb number of blocks per block row ! iblock integer array of size 3 by lbhb ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer vector giving the diagonal numbers ! for the off-diagonal blocks ! x input/output vector of length n ! ivers key for version of factorization ! = 1 version 1 ! = 2 version 2 ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jt(1), iblock(3,1) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical vers1, vers2 ! kblsz = kblszz l = n/kblsz lm1 = l - 1 nt = iblock(3,1) - 1 vers1 = ivers == 1 vers2 = ivers == 2 do k = 1,lm1 ist = (k - 1)*kblsz + 1 ied = k*kblsz if (nt >= 1) go to 15 do i = ist,ied wksp(i-ist+1) = d(i,1)*x(i) end do go to 20 15 if (vers1) call bdsol (ldd,kblsz,nsize,nt,0,d(ist,1),x(ist),wksp,0) if (vers2) call bmul (ldd,kblsz,nt,d(ist,1),d(ist,2),x(ist),wksp) 20 jjlim = min (lbhb,l-k+2) do jj = 3, jjlim jblk = iblock(1,jj) jst = iblock(2,jj) mjj = iblock(3,jj) inc = jblk*kblsz istf = ist + inc if ( istf <= n ) then call vsubdt (ldt,1,kblsz,kblsz,mjj,t(ist,jst),jt(jst),x(istf),wksp,inc) end if end do end do return end subroutine ibfsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,x, & ivers,iunif,wksp) ! !*****************************************************************************80 ! !! IBFSN does an incomplete block forward solve. ! ! ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! nsize size of an individual subsystem within a ! diagonal block ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0. formed in the factorization routine. ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! x input/output vector of length n ! ivers key for version number ! = 1 version 1 ! = 2 version 2 ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jt(ncolor,1), nci(1), lbhb(1),iblock(3,ncolor,2) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical unif, vers2 ! vers2 = ivers == 2 unif = iunif == 1 l = ncolor if ( unif ) then na = nci(1) nb = na jlim = lbhb(1) l = n/na ndt = iblock(3,1,1) - 1 ndb = iblock(3,1,2) kk = 1 end if ! ! do forward solution. ! 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 >= 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 < 1) go to 25 call vsubd (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb),x(ist), & x(istb),inc) 25 continue if (ndt + ndb >= 1) go to 35 x(ist:ied) = d(ist:ied,1)*x(ist:ied) 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),x(ist),wksp) do i = ist,ied x(i) = wksp(i-ist+1) end do 50 continue return end subroutine ibfsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,x, & ivers,iunif,wksp) ! !*****************************************************************************80 ! !! IBFSNT does an incomplete block transpose forward solve. ! ! ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! nsize size of an individual subsystem within a ! diagonal block ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0. formed in the factorization routine. ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! x input/output vector of length n ! ivers key for version number ! = 1 version 1 ! = 2 version 2 ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jt(ncolor,1), nci(1), lbhb(1),iblock(3,ncolor,2) dimension d(ldd,2), t(ldt,1), wksp(1), x(1) logical unif, vers1, vers2 ! vers1 = ivers == 1 vers2 = ivers == 2 unif = iunif == 1 ! 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 ! ! do forward solution. ! 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 >= 1) go to 30 do i = ist,ied wksp(i-ist+1) = d(i,1)*x(i) end do go to 35 30 if (vers1) call bdsolt(ldd,na,nsize,ndt,ndb,d(ist,1),x(ist),wksp) if (vers2) call bmulnt(ldd,na,ndt,ndb,d(ist,1),d(ist,2),d(ist,ndt+2), & x(ist),wksp) 35 do 40 j = 3,jlim jcol = k + iblock(1,kk,j) if (jcol <= 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 > n) go to 40 call vsubdt (ldt,ncolor,na,nb,mb,t(ist,jstb),jt(kk,jstb), & x(istb),wksp,inc) 40 continue 45 continue return end subroutine ibsl (ldd,ldt,n,kblsz,nsize,lbhb,iblock,d,t,jt,y,x,ivers,wksp) ! !*****************************************************************************80 ! !! IBSL does an incomplete block solution. ! ! ! symmetric diagonal data structure, natural ordering. ! block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! kblsz block size ! nsize size of an individual subsystem within a ! diagonal block ! lbhb number of blocks per block row ! iblock integer array of size 3 by lbhb ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer vector giving the diagonal numbers ! for the off-diagonal blocks ! y input vector for the right-hand-side ! x output vector for the solution to q*x = y ! ivers key for version of factorization ! = 1 version 1 ! = 2 version 2 ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jt(1), iblock(3,1) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) ! x(1:n) = y(1:n) call ibfs (ldd,ldt,n,kblsz,nsize,lbhb,iblock,d,t,jt,x,ivers,wksp) call ibbs (ldd,ldt,n,kblsz,nsize,lbhb,iblock,d,t,jt,x,ivers,wksp) return end subroutine ibsln (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,y,x, & ivers,iunif,wksp) ! !*****************************************************************************80 ! !! IBSLN does an incomplete block solution. ! ! ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! nsize size of an individual subsystem within a ! diagonal block ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0. formed in the factorization routine. ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! y input vector of length n containing right-hand-side ! x output vector containing the solution to q*x = y ! ivers key for version number ! = 1 version 1 ! = 2 version 2 ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! wksp real workspace vector ! ! ! integer ipt(1), jt(ncolor,1), nci(1), lbhb(1),iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) ! x(1:n) = y(1:n) call ibfsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,x,ivers, & iunif,wksp) call ibbsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,x,ivers, & iunif,wksp) return end subroutine ibsln1 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,y,x, & ivers,iunif,wksp) ! !*****************************************************************************80 ! !! IBSLN1 does an incomplete block forward pass. ! ! ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! nsize size of an individual subsystem within a ! diagonal block ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0. formed in the factorization routine. ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! y input vector of length n containing right-hand-side ! x output vector containing the solution to q*x = y ! ivers key for version number ! = 1 version 1 ! = 2 version 2 ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) ! x(1:n) = y(1:n) call ibfsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,x,ivers, & iunif,wksp) return end subroutine ibsln2 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,y,x, & ivers,iunif,wksp) ! !*****************************************************************************80 ! !! IBSLN2 does an incomplete block backward pass. ! ! ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! nsize size of an individual subsystem within a ! diagonal block ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0. formed in the factorization routine. ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! y input vector of length n containing right-hand-side ! x output vector containing the solution to q*x = y ! ivers key for version number ! = 1 version 1 ! = 2 version 2 ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) ! x(1:n) = y(1:n) call ibbsn (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,x,ivers, & iunif,wksp) return end subroutine ibsln3 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,y,x, & ivers,iunif,wksp) ! !*****************************************************************************80 ! !! IBSLN3 does an incomplete block transpose back solve. ! ! ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! nsize size of an individual subsystem within a ! diagonal block ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0. formed in the factorization routine. ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! y input vector of length n containing right-hand-side ! x output vector containing the solution to q*x = y ! ivers key for version number ! = 1 version 1 ! = 2 version 2 ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) ! x(1:n) = y(1:n) call ibbsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,x,ivers, & iunif,wksp) return end subroutine ibsln4 (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,y,x, & ivers,iunif,wksp) ! !*****************************************************************************80 ! !! IBSLN4 does an incomplete block transpose forward pass. ! ! ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! nsize size of an individual subsystem within a ! diagonal block ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0. formed in the factorization routine. ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! y input vector of length n containing right-hand-side ! x output vector containing the solution to q*x = y ! ivers key for version number ! = 1 version 1 ! = 2 version 2 ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) ! x(1:n) = y(1:n) call ibfsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,x,ivers, & iunif,wksp) return end subroutine ibslnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,y,x, & ivers,iunif,wksp) ! !*****************************************************************************80 ! !! IBSLNT does an incomplete block transpose solution. ! ! ! nonsymmetric diagonal data structure, natural or multi-color ! orderings, block ic preconditioning. ! ! Parameters: ! ! ldd row dimension of d array ! ldt row dimension of t array ! n size of system ! nsize size of an individual subsystem within a ! diagonal block ! ncolor number of distinct block sizes ! ncolor = 1 if iunif = 1. ! nci integer vector of length ncolor, giving the number ! of nodes for each distinct block size. ! if iunif = 1, nci(1) is the constant block size. ! ipt integer pointer vector of length ncolor+1 if ! iunif = 0. formed in the factorization routine. ! lbhb integer vector of size ncolor giving the number ! of diagonal blocks for each distinct block size. ! if iunif = 1, lbhb is of length 1. ! iblock integer array of size 3 by ncolor by max(lbhb(i)) ! giving block constants ! d array for diagonal block ! t array for off-diagonal blocks ! jt integer array of size ncolor by whatever ! giving the off-diagonal block diagonal numbers ! for each distinct block size. jd is 1 by whatever ! if iunif = 1. ! y input vector of length n containing right-hand-side ! x output vector containing the solution to q*x = y ! ivers key for version number ! = 1 version 1 ! = 2 version 2 ! iunif uniform block size switch ! = 0 diagonal blocks are not of uniform size ! = 1 diagonal blocks are of uniform size ! wksp real workspace vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), jt(ncolor,1), nci(1), lbhb(1), iblock(3,ncolor,2) dimension d(ldd,1), t(ldt,1), wksp(1), x(1), y(1) ! x(1:n) = y(1:n) call ibfsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,x,ivers, & iunif,wksp) call ibbsnt (ldd,ldt,n,nsize,ncolor,nci,ipt,lbhb,iblock,d,t,jt,x,ivers, & iunif,wksp) return end subroutine ic1 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp, iparm,rparm,ier) ! !*****************************************************************************80 ! !! IC1 drives the IC preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba8, suba9, subq86, subq87, subq88 external subq89, subq90, subq91, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) ! 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, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! n = nn if (ifact == 0 .and. lvfill > 0) go to 20 call move1 (ndim,mdim,n,maxnz,jcoef,coef,maxt,maxb,ier) if (ier < 0) then call ershow (ier,'ic1') return end if 20 t1 = timer (dummy) if (ifact == 1) call pfact1 (coef,jcoef,wksp,iwksp,n,1,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba8,suba9,subq86,subq87,subq88,subq89,subq90,subq91, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine ic2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! IC2 drives the symmetric IC preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba1, subq13, subq14, subq15, subq16, subq17, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) ! common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 ! ! t1 = timer (dummy) if (ifact == 1) call pfact2 (coef,jcoef,wksp,iwksp,n,1,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return leniw = max (maxnz,nfacti) iwkpt1 = iipnt iipnt = iipnt + leniw call split (accel,suba1,suba1,subq13,subq13,subq14,subq15,subq16,subq17, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) iipnt = iipnt - leniw return end subroutine ic3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! IC3 drives the nonsymmetric IC preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba4, suba5, subq48, subq49, subq50 external subq51, subq52, subq53, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, 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 ! ! n = nn call needw ('ic3',1,iipnt,maxnz,ier) if (ier < 0) return call needw ('ic3',0,irpnt,n,ier) if (ier < 0) return if (ifact == 0 .and. lvfill > 0) go to 20 call move2 (ndim,n,maxnz,jcoef,coef,wksp(irpnt),iwksp(iipnt),maxt,maxb) 20 t1 = timer (dummy) if (ifact == 1) call pfact3 (coef,jcoef,wksp,iwksp,n,1,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return leniw = max (maxnz,nfacti) iwkpt1 = iipnt iipnt = iipnt + leniw call split (accel,suba4,suba5,subq48,subq49,subq50,subq51,subq52,subq53, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) iipnt = iipnt - leniw return end subroutine ic6 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! IC6 drives the IC preconditioner. ! ! (multi-color ordering) ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba8, suba9, sub104, sub105, sub106, sub107, sub108 external sub109, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) ! 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, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! ! n = nn t1 = timer (dummy) if (ifact == 1) call pfactc (coef,jcoef,wksp,iwksp,n,1,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba8,suba9,sub104,sub105,sub106,sub107,sub108,sub109, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine icbs (ndim,nn,maxtt,jt,d,t,ipropa,irwise,iwksp,x) ! !*****************************************************************************80 ! !! ICBS does an IC back solve (natural ordering, diagonal storage). ! ! ! (i + t)*x = y if not property a ! (i + d*t)*x = y if property a ! ! Parameters: ! ! ndim row dimension of t array ! n order of system (= nn) ! maxt number of columns in t array ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t ! d vector of length n giving the diagonal elements ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! x on input, x contains y ! on output, x is the solution to back-solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) logical propa ! n = nn maxt = maxtt nm1 = n - 1 propa = ipropa == 1 if (maxt < 1) return ! ! select rowwise or diagonal-wise algorithm. ! if (irwise == 1) go to 70 ! ! diagonal-wise algorithm. ! iwksp(1:maxt) = n - jt(1:maxt) ! ! determine nc, imax. ! 20 nc = 1 do 25 i = 1,maxt nterm = iwksp(i) + 1 if ( nterm <= nc ) go to 25 nc = nterm imax = i 25 continue if (nc <= 1) return ndel = jt(imax) iend = nc - 1 if (ndel > 1) go to 50 ! ! special case for first super diagonal. ! nc1 = 1 do i = 1,maxt if ( i /= imax ) then if (iwksp(i) > nc1) nc1 = iwksp(i) end if end do 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 continue do k = iend,nc1,-1 x(k) = x(k) - d(k)*t(k,imax)*x(k+1) end do go to 20 ! ! far diagonals (do vector computations). ! 50 iwksp(imax) = iwksp(imax) - ndel ibeg = max (iend - ndel,0) + 1 if (propa) go to 60 !dir$ ivdep do i = ibeg,iend x(i) = x(i) - t(i,imax)*x(i+ndel) end do go to 20 !dir$ ivdep 60 do 65 i = ibeg,iend 65 x(i) = x(i) - d(i)*t(i,imax)*x(i+ndel) go to 20 ! ! rowwise algorithm. ! 70 continue do i = nm1,1,-1 do j = 1,maxt iwksp(j) = min (n,i+jt(j)) end do sum = 0.0D+00 do j = 1,maxt sum = sum + t(i,j)*x(iwksp(j)) end do if (propa) sum = d(i)*sum x(i) = x(i) - sum end do return end subroutine icbscp (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,ipropa,wksp,x) ! !*****************************************************************************80 ! !! ICBSCP does a back IC solve. (Purdue storage, multicolor) ! ! ! (i + t)*x = y if ipropa = 0 ! (d + t)*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! n order of system (= nn) ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! nc integer vector of length ncolor giving the number ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! wksp workspace vector of length ! max(nc(i)) if keygs = 1 ! 0 if keygs = 2 ! x on input, x contains y ! on output, x is the solution to the back solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jc(ndimi,1), nc(1), nt(1) dimension d(1), c(ndimr,1), x(1), wksp(1) logical propa ! propa = ipropa == 1 ied = n do 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,wksp) if (.not. propa) go to 20 x(ist:ied) = x(ist:ied)*d(ist:ied) 20 ied = ied - npt end do return end subroutine icbsct (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,nb,ipropa, wksp,x) ! !*****************************************************************************80 ! !! ICBSCT does a transpose back IC solve. (Purdue storage, multicolor) ! ! ! (i + (b**t))*x = y if ipropa = 0 ! (d + (b**t))*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! n order of system (= nn) ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! nc integer vector of length ncolor giving the number ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! nb integer vector of length ncolor giving the number ! of lower columns for each color ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! wksp workspace vector of length max(nc(i)) ! x on input, x contains y ! on output, x is the solution to the back solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), wksp(1) logical propa ! propa = ipropa == 1 ied = n do icol = ncolor,1,-1 npt = nc(icol) ist = ied - npt + 1 if (.not. propa) go to 20 x(ist:ied) = x(ist:ied)*d(ist:ied) 20 j1 = nt(icol) + 1 mj = nb(icol) call vsubpt (ndimr,ndimi,npt,mj,c(ist,j1),jc(ist,j1),x,x(ist), wksp) ied = ied - npt end do return end subroutine icbsp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) ! !*****************************************************************************80 ! !! ICBSP does an IC back solve (natural ordering, Purdue storage). ! ! ! (i + t)*x = y if ipropa = 0 ! (d + t)*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! jt integer array giving the column numbers of the ! corresponding elements in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! x on input, x contains y ! on output, x is the solution to back-solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension x(1), d(1), t(ndimr,1) integer jt(ndimi,1) logical propa ! propa = ipropa == 1 if ( maxt < 1 ) then if (.not. propa) return x(1:n) = x(1:n) * d(1:n) return end if do i = n,1,-1 sum = x(i) do j = 1,maxt sum = sum - t(i,j)*x(jt(i,j)) end do if (propa) sum = sum*d(i) x(i) = sum end do return end subroutine icbst (ndim,nn,maxbb,jb,d,b,ipropa,irwise,iwksp,x) ! !*****************************************************************************80 ! !! ICBST does an iC back solve (natural ordering, diagonal storage). ! ! ! (i + (b**t))*x = y if not property a ! (i + d*(b**t))*x = y if property a ! ! Parameters: ! ! ndim row dimension of b array ! n order of system (= nn) ! maxb number of columns in b array ! jb integer vector of length maxb giving the diagonal ! indices of the corresponding columns in b ! d vector of length n giving the diagonal elements ! of the factorization ! b array of active size n by maxb giving the sub- ! diagonals of the factorization if not property a ! or the sub-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxb ! x on input, x contains y ! on output, x is the solution to back-solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) logical propa ! n = nn maxb = maxbb propa = ipropa == 1 if (maxb < 1) return ! ! select rowwise or diagonal-wise algorithm. ! if (irwise == 1) go to 70 ! ! diagonal-wise algorithm. ! iwksp(1:maxb) = n + jb(1:maxb) ! ! determine nc, imax. ! 20 nc = 1 do 25 i = 1,maxb nterm = iwksp(i) + 1 if (nterm <= nc) go to 25 nc = nterm imax = i 25 continue if (nc <= 1) return ndel = -jb(imax) iend = nc - 1 if (ndel > 1) go to 50 ! ! special case for first sub diagonal. ! nc1 = 1 do i = 1,maxb if ( i /= imax ) then if (iwksp(i) > nc1) nc1 = iwksp(i) end if end do iwksp(imax) = nc1 - 1 if (propa) go to 40 do k = iend,nc1,-1 x(k) = x(k) - b(k+1,imax)*x(k+1) end do go to 20 40 continue do k = iend,nc1,-1 x(k) = x(k) - d(k)*b(k+1,imax)*x(k+1) end do go to 20 ! ! far diagonals (do vector computations). ! 50 iwksp(imax) = iwksp(imax) - ndel ibeg = max (iend - ndel,0) + 1 if (propa) go to 60 !dir$ ivdep do i = ibeg,iend x(i) = x(i) - b(i+ndel,imax)*x(i+ndel) end do go to 20 60 continue !dir$ ivdep do i = ibeg,iend x(i) = x(i) - d(i)*b(i+ndel,imax)*x(i+ndel) end do go to 20 ! ! rowwise algorithm. ! 70 if (propa) go to 90 do i = n,2,-1 do j = 1,maxb iwksp(j) = max (1,i+jb(j)) end do term = x(i) do j = 1,maxb x(iwksp(j)) = x(iwksp(j)) - b(i,j)*term end do end do return 90 continue do i = n,2,-1 do j = 1,maxb iwksp(j) = max (1,i+jb(j)) end do term = x(i) do j = 1,maxb x(iwksp(j)) = x(iwksp(j)) - d(iwksp(j))*b(i,j)*term end do end do return end subroutine icbstp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) ! !*****************************************************************************80 ! !! ICBSTP does a transpose IC back solve (natural ordering, Purdue storage). ! ! ! (i + (b**t))*x = y if ipropa = 0 ! (d + (b**t))*x = y if ipropa = 1 ! ! Parameters: ! ! n order of system ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! maxb number of columns in b array ! jb integer array giving the column numbers of the ! corresponding elements in b ! d vector of length n giving the diagonal elements ! of the factorization ! b array of active size n by maxb giving the lower ! triangle of the factorization if ipropa = 0 ! or the lower triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! x on input, x contains y ! on output, x is the solution to back-solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension x(1), d(1), b(ndimr,1) integer jb(ndimi,1) logical propa ! propa = ipropa == 1 if (maxb >= 1) go to 15 if (.not. propa) return x(1:n) = x(1:n) * d(1:n) return 15 continue do i = n,1,-1 if (propa) x(i) = x(i)*d(i) term = x(i) do j = 1,maxb x(jb(i,j)) = x(jb(i,j)) - b(i,j)*term end do end do return end subroutine icf (ndim,nn,maxtt,jt,d,t,meth,ipropa,omega,wksp,iwksp,iflag) ! !*****************************************************************************80 ! !! ICF computes an incomplete factorization. (symmetric diagonal storage) ! ! ! The matrix is stored in d and t and the factorization replaces it. ! ! ! Parameters: ! ! ndim row dimension of t array ! n order of system (= nn) ! maxt number of columns in t array ! jt integer vector giving the diagonal indices of ! the corresponding columns in t ! d vector of length n giving the diagonal elements ! of the matrix ! t array of active size n by maxt giving the ! super-diagonals of the matrix ! meth point factorization wanted ! = 1 ic ! = 2 mic ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! omega modification factor between 0.0 and 1.0 ! = 0 no modification ! = 1 full modification ! wksp workspace vector of length n ! iwksp integer workspace of length maxt**2 ! iflag indicator of factorization stability ! iflag = 0 no errors detected ! = 1 zero pivot encountered ! (unsuccessful factorization) ! = 2 negative pivot encountered ! (successful factorization) ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jt(1), iwksp(1) dimension d(1), t(ndim,1), wksp(1) logical propa ! ! n = nn maxt = maxtt iflag = 0 propa = ipropa == 1 if (maxt < 1) go to 500 nm1 = n - 1 if (meth /= 1 .or. .not. propa) go to 20 ! ! ic, propa = t. ! do k = 1,nm1 pivot = d(k) if (pivot == 0.0D+00 ) go to 995 do j = 1,maxt kf = k + jt(j) if (kf <= n) then d(kf) = d(kf) - t(k,j)**2/pivot end if end do end do if (d(n) == 0.0D+00 ) go to 995 go to 500 20 if (meth /= 2 .or. .not. propa) go to 50 ! ! mic, propa = t. ! wksp(1:n) = 0.0D+00 do j = 1,maxt wksp(1:n) = wksp(1:n) + t(1:n,j) end do do 45 k = 1,nm1 pivot = d(k) if (pivot == 0.0D+00 ) go to 995 do 40 i = 1,maxt kf = k + jt(i) if (kf > n) go to 40 term = t(k,i)/pivot d(kf) = d(kf) - term*(omega*wksp(k)-(omega-1.0D+00)*t(k,i)) 40 continue 45 continue if (d(n) == 0.0D+00 ) go to 995 go to 500 ! ! ic, mic for propa = f. ! 50 nbig = maxt + 1 do 70 i = 1,maxt do 65 j = i,maxt if (j == i) go to 65 iloc = (j - 1)*maxt + i id = iabs (jt(j) - jt(i)) do k = 1,maxt if ( jt(k) == id) then iwksp(iloc) = k go to 65 end if end do iwksp(iloc) = nbig 65 continue 70 continue do 100 k = 1,nm1 pivot = d(k) if (pivot == 0.0D+00 ) go to 995 do 95 i = 1,maxt kf = k + jt(i) if (kf > 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 == i) go to 90 kg = k + jt(j) if (kg > n) go to 90 iloc = (j-1)*maxt+i id = iwksp(iloc) if (id == nbig) go to 85 kff = min (kf,kg) t(kff,id) = t(kff,id) - wksp(j) go to 90 85 if (meth == 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) == 0.0D+00 ) go to 995 ! ! store reciprocals of pivots. ! 500 continue d(1:n) = 1.0D+00 / d(1:n) if (maxt < 1 .or. propa) go to 990 do j = 1,maxt len = n - jt(j) do i = 1,len t(i,j) = d(i)*t(i,j) end do end do ! ! check for negative pivots. ! 990 continue if ( vmin ( n, d ) < 0.0D+00 ) then iflag = 2 end if return ! ! error - matrix cannot be factored since a pivot is zero ! 995 iflag = 1 return end subroutine icfcp (ndimr,ndimi,nn,maxcc,jc,d,c,ncolor,nt,nb,meth,ipropa, & ipt,omega,iflag) ! !*****************************************************************************80 ! !! ICFCP computes an incomplete factorization. (Purdue storage, multicolor) ! ! ! The matrix is stored in d and c and the factorization replaces it. ! ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! n order of system (= nn) ! maxc number of columns in c array ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! nb integer vector of length ncolor giving the number ! of lower columns for each color ! meth point factorization wanted ! = 1 ic ! = 2 mic ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! ipt integer pointer vector of length ncolor + 1 ! omega modification factor between 0.0 and 1.0 ! = 0 no modification ! = 1 full modification ! iflag indicator of factorization stability ! iflag = 0 no errors detected ! = 1 zero pivot encountered ! (unsuccessful factorization) ! = 2 negative pivot encountered ! (successful factorization) ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jc(ndimi,1), nt(1), nb(1), ipt(1) dimension d(1), c(ndimr,1) logical propa ! ! n = nn maxc = maxcc ncol = ncolor iflag = 0 propa = ipropa == 1 if (maxc < 1) go to 75 ! ! do factorization. ! do 65 icol = 1,ncol-1 k1 = ipt(icol) + 1 k2 = ipt(icol+1) j22 = nt(icol) if (j22 <= 0) go to 65 do 60 k = k1,k2 pivot = d(k) if (pivot == 0.0D+00 ) 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 > j12) go to 55 do 50 j1 = j11,j12 do 45 i = i1,i2 jcol1 = jc(i,j1) if (jcol1 /= k) go to 45 term1 = c(i,j1)/pivot do 40 j2 = 1,j22 j = jc(k,j2) if (j <= k) go to 40 term2 = term1*c(k,j2) if (j == i) go to 35 if (propa) go to 30 if (j > i) go to 20 do 15 j3 = j11,j12 if (jc(i,j3) /= j) go to 15 c(i,j3) = c(i,j3) - term2 go to 40 15 continue go to 30 20 if (j32 <= 0) go to 30 do 25 j3 = 1,j32 if (jc(i,j3) /= j) go to 25 c(i,j3) = c(i,j3) - term2 go to 40 25 continue 30 if (meth == 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) == 0.0D+00 ) go to 995 70 continue ! ! store reciprocals of pivots. ! 75 continue d(1:n) = 1.0D+00 / d(1:n) if (maxc < 1 .or. propa) go to 990 do icol = 1,ncol nt2 = nt(icol) i1 = ipt(icol) + 1 i2 = ipt(icol+1) do 100 j = 1,maxc if (j > nt2) go to 90 c(i1:i2,j) = d(i1:i2)*c(i1:i2,j) go to 100 90 do i = i1,i2 c(i,j) = c(i,j)*d(jc(i,j)) end do 100 continue end do ! ! check for negative pivots. ! 990 continue if ( vmin(n,d) < 0.0D+00 ) then iflag = 2 end if return ! ! error - matrix cannot be factored since a pivot is zero ! 995 iflag = 1 return end subroutine icfn (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,meth, ipropa,omega,wksp, & iwksp,iflag) ! !*****************************************************************************80 ! !! ICFN computes an incomplete factorization. (nonsymmetric diagonal storage) ! ! ! The matrix is stored in d, t, and b and the factorization replaces it. ! ! ! Parameters: ! ! ndim row dimension of t,b arrays ! n order of system (= nn) ! maxt number of columns in t array ! maxb number of columns in b array ! jt integer vector giving the diagonal indices of ! the corresponding columns in t ! jb integer vector giving the diagonal indices of ! the corresponding columns in b ! d vector of length n giving the diagonal elements ! of the matrix ! t array of active size n by maxt giving the ! super-diagonals of the matrix ! b array of active size n by maxb giving the ! sub-diagonals of the matrix ! meth point factorization wanted ! = 1 ic ! = 2 mic ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! omega modification factor between 0.0 and 1.0 ! = 0 no modification ! = 1 full modification ! wksp workspace vector of length n ! iwksp integer workspace of length maxb*maxt ! iflag indicator of factorization stability ! iflag = 0 no errors detected ! = 1 zero pivot encountered ! (unsuccessful factorization) ! = 2 negative pivot encountered ! (successful factorization) ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jt(1), jb(1), iwksp(1) dimension d(1), t(ndim,1), b(ndim,1), wksp(1) logical propa ! ! n = nn maxt = maxtt maxb = maxbb iflag = 0 propa = ipropa == 1 if (maxt < 1 .or. maxb < 1) go to 500 nm1 = n - 1 if (meth /= 1 .or. .not. propa) go to 30 ! ! ic, propa = t. ! nval = 0 do j = 1,maxb i1 = -jb(j) do i = 1,maxt i2 = jt(i) if ( i1 == i2 ) then nval = nval + 1 iwksp(3*nval-2) = j iwksp(3*nval-1) = i iwksp(3*nval) = i2 exit end if end do end do if (nval == 0) go to 500 do k = 1,nm1 pivot = d(k) if (pivot == 0.0D+00 ) go to 995 do j = 1,nval kf = k + iwksp(3*j) if ( kf <= n ) then i1 = iwksp(3*j-2) i2 = iwksp(3*j-1) d(kf) = d(kf) - b(kf,i1)*t(k,i2)/pivot end if end do end do if (d(n) == 0.0D+00 ) go to 995 go to 500 30 if (meth /= 2 .or. .not. propa) go to 70 ! ! mic, propa = t. ! wksp(1:n) = 0.0D+00 do j = 1,maxt wksp(1:n) = wksp(1:n) + t(1:n,j) end do do 55 i = 1,maxb i1 = -jb(i) do j = 1,maxt i2 = jt(j) if ( i1 == i2 ) then iwksp(i) = j go to 55 end if end do iwksp(i) = 0 55 continue do k = 1,nm1 pivot = d(k) if (pivot == 0.0D+00 ) go to 995 do i = 1,maxb kf = k - jb(i) if ( kf <= n ) then term = b(kf,i)/pivot t1 = 0.0D+00 i1 = iwksp(i) if (i1 /= 0) t1 = t(k,i1) d(kf) = d(kf) - term*(omega*wksp(k)-(omega-1.0D+00)*t1) end if end do end do if (d(n) == 0.0D+00) go to 995 go to 500 ! ! ic, mic for propa = f. ! 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) /= 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) /= 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 == 0.0D+00) go to 995 do 135 i = 1,maxb kf = k - jb(i) if (kf > n) go to 135 do j = 1,maxt wksp(j) = b(kf,i)*t(k,j)/pivot end do 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 /= nbig) t(kf,id) = t(kf,id) - wksp(j) if (id == nbig .and. meth == 2) then d(kf) = d(kf) - omega*wksp(j) end if 130 continue 135 continue 140 continue if (d(n) == 0.0D+00 ) go to 995 ! ! store reciprocals of pivots. ! 500 continue d(1:n) = 1.0D+00 / d(1:n) if ( propa ) go to 520 do j = 1,maxt len = n - jt(j) do i = 1,len t(i,j) = d(i)*t(i,j) end do end do 520 if ( propa ) go to 990 do j = 1,maxb ind = jb(j) len = n + ind do i = 1,len b(i-ind,j) = d(i)*b(i-ind,j) end do end do ! ! check for negative pivots. ! 990 continue if ( vmin(n,d) < 0.0D+00 ) then iflag = 2 end if return ! ! error - matrix cannot be factored since a pivot is zero ! 995 iflag = 1 return end subroutine icfnp (ndimr,ndimi,nn,maxtt,maxbb,jt,jb,d,t,b,meth,ipropa, & omega,iflag) ! !*****************************************************************************80 ! !! ICFNP computes an incomplete factorization. (Purdue storage, nonsymmetric matrix) ! ! ! The matrix is stored in d, t, and b and the factorization replaces it. ! ! ! Parameters: ! ! ndimr row dimension of t and b arrays ! ndimi row dimension of jt and jb arrays ! n order of system (= nn) ! maxt number of columns in t,jt arrays ! maxb number of columns in b,jb arrays ! jt integer array giving the column indices of the ! corresponding elements in t ! jb integer array giving the column indices of the ! corresponding elements in b ! d vector of length n giving the diagonal elements ! of the matrix ! t array of active size n by maxt giving the ! upper triangle of the matrix ! b array of active size n by maxb giving the ! lower triangle of the matrix ! meth point factorization wanted ! = 1 ic ! = 2 mic ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! omega modification factor between 0.0 and 1.0 ! = 0 no modification ! = 1 full modification ! iflag indicator of factorization stability ! iflag = 0 no errors detected ! = 1 zero pivot encountered ! (unsuccessful factorization) ! = 2 negative pivot encountered ! (successful factorization) ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jt(ndimi,1), jb(ndimi,1) dimension d(1), t(ndimr,1), b(ndimr,1) logical propa ! ! n = nn maxt = maxtt maxb = maxbb iflag = 0 propa = ipropa == 1 ! if (maxt < 1 .or. maxb < 1) go to 50 nm1 = n - 1 do 45 k = 1,nm1 pivot = d(k) if (pivot == 0.0D+00 ) go to 995 kp1 = k + 1 do 40 j1 = 1,maxb do 35 i = kp1,n jcol1 = jb(i,j1) if (jcol1 /= k) go to 35 term1 = b(i,j1)/pivot do 30 j2 = 1,maxt j = jt(k,j2) if (j <= k) go to 30 term2 = term1*t(k,j2) jdiff = j - i if (jdiff == 0) go to 27 if (propa) go to 25 if (jdiff > 0) go to 15 do 10 j3 = 1,maxb if (jb(i,j3) /= 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) /= j) go to 20 t(i,j3) = t(i,j3) - term2 go to 30 20 continue 25 if (meth == 1) go to 30 27 d(i) = d(i) - omega*term2 30 continue 35 continue 40 continue 45 continue if (d(n) == 0.0D+00 ) go to 995 ! ! store reciprocals of pivots. ! 50 continue d(1:n) = 1.0D+00 / d(1:n) if ( propa ) go to 70 do j = 1,maxt t(1:n,j) = d(1:n)*t(1:n,j) end do 70 if ( propa) go to 990 do j = 1,maxb b(1:n,j) = b(1:n,j)*d(jb(1:n,j)) end do ! ! check for negative pivots. ! 990 continue if ( vmin(n,d) < 0.0D+00 ) then iflag = 2 end if return ! ! error - matrix cannot be factored since a pivot is zero ! 995 iflag = 1 return end subroutine icfp (ndimr,ndimi,nn,maxtt,jt,d,t,meth,ipropa,omega,wksp,iflag) ! !*****************************************************************************80 ! !! ICFP computes an incomplete factorization. (Purdue storage, symmetric matrix) ! ! ! The matrix is stored in d and t and the factorization replaces it. ! ! ! Parameters: ! ! ndimr row dimension of t array ! ndimi row dimension of jt array ! n order of system (= nn) ! maxt number of columns in t array ! jt integer array of active size n by maxt giving the ! column numbers of the corresponding elements in t ! d vector of length n giving the diagonal elements ! of the matrix ! t array of active size n by maxt giving the ! coefficients of the upper triangle of the matrix ! meth point factorization wanted ! = 1 ic ! = 2 mic ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! omega modification factor between 0.0 and 1.0 ! = 0 no modification ! = 1 full modification ! wksp workspace array of length n ! iflag indicator of factorization stability ! iflag = 0 no errors detected ! = 1 zero pivot encountered ! (unsuccessful factorization) ! = 2 negative pivot encountered ! (successful factorization) ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension d(1), t(ndimr,1), wksp(1) integer jt(ndimi,1) logical propa ! n = nn maxt = maxtt iflag = 0 propa = ipropa == 1 if (maxt < 1) go to 500 nm1 = n - 1 if (meth /= 1 .or. .not. propa) go to 20 ! ! ic, propa = t. ! do k = 1,nm1 pivot = d(k) if (pivot == 0.0D+00 ) go to 995 do j = 1,maxt jcol = jt(k,j) d(jcol) = d(jcol) - t(k,j)**2/pivot end do end do if (d(n) == 0.0D+00 ) go to 995 go to 500 20 if (meth /= 2 .or. .not. propa) go to 50 ! ! mic, propa = t. ! wksp(1:n) = 0.0D+00 do j = 1,maxt wksp(1:n) = wksp(1:n) + t(1:n,j) end do do k = 1,nm1 pivot = d(k) if (pivot == 0.0D+00 ) go to 995 do 40 i = 1,maxt jcol = jt(k,i) if (jcol == k) go to 40 term = t(k,i)/pivot d(jcol) = d(jcol) - term*(omega*wksp(k)-(omega-1.0D+00)*t(k,i)) 40 continue end do if (d(n) == 0.0D+00 ) go to 995 go to 500 ! ! ic, mic for propa = f. ! 50 do 70 k = 1,nm1 pivot = d(k) if (pivot == 0.0D+00) go to 995 do 65 j1 = 1,maxt jcol1 = jt(k,j1) if (jcol1 == 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 <= jcol1) go to 60 if (jcol2 == k) go to 60 term2 = term1*t(k,j2) do 55 j3 = 1,maxt if (jcol2 /= jt(jcol1,j3)) go to 55 t(jcol1,j3) = t(jcol1,j3) - term2 go to 60 55 continue if (meth == 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) == 0.0D+00) go to 995 ! ! store reciprocals of pivots and scale t. ! 500 continue d(1:n) = 1.0D+00 / d(1:n) if ( propa ) go to 990 do j = 1,maxt t(1:n,j) = d(1:n) * t(1:n,j) end do ! ! check for negative pivots. ! 990 if (vmin(n,d) < 0.0D+00) iflag = 2 return ! ! error - matrix cannot be factored since a pivot is zero ! 995 iflag = 1 return end subroutine icfs (ndim,nn,maxbb,jb,d,b,ipropa,irwise,iwksp,x) ! !*****************************************************************************80 ! !! ICFS does an IC forward solve (natural ordering, diagonal storage). ! ! ! (i + b)*x = y if not property a ! (i + b*d)*x = y if property a ! ! Parameters: ! ! ndim row dimension of b array ! n order of system (= nn) ! maxb number of columns in b array ! jb integer vector of length maxb giving the diagonal ! indices of the corresponding columns in b ! d vector of length n giving the diagonal elements ! of the factorization ! b array of active size n by maxb giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxb ! x on input, x contains y ! on output, x is the solution to forward-solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) logical propa ! n = nn maxb = maxbb propa = ipropa == 1 if (maxb < 1) return ! ! select rowwise or diagonal-wise algorithm. ! if (irwise == 1) go to 70 ! ! diagonal-wise algorithm. ! iwksp(1:maxb) = 1 - jb(1:maxb) ! ! determine nc, imin. ! 20 nc = n do i = 1,maxb nterm = iwksp(i) - 1 if ( nterm < nc ) then nc = nterm imin = i end if end do if (nc >= n) return ndel = -jb(imin) ibeg = nc + 1 if (ndel > 1) go to 50 ! ! special case for first minor subdiagonal. ! nc1 = n do 30 i = 1,maxb if (i == imin) go to 30 if (iwksp(i) < 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 ! ! far diagonals (do vector computations). ! 50 iwksp(imin) = iwksp(imin) + ndel iend = min (ibeg+ndel-1,n) if (propa) go to 60 !dir$ ivdep do 55 i = ibeg,iend 55 x(i) = x(i) - b(i,imin)*x(i-ndel) go to 20 !dir$ ivdep 60 do 65 i = ibeg,iend 65 x(i) = x(i) - d(i-ndel)*b(i,imin)*x(i-ndel) go to 20 ! ! rowwise algorithm. ! 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 continue do i = 2,n do j = 1,maxb iwksp(j) = max (1,i+jb(j)) end do sum = x(i) do j = 1,maxb sum = sum - d(iwksp(j))*b(i,j)*x(iwksp(j)) end do x(i) = sum end do return end subroutine icfscp (ndimr,ndimi,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp,x) ! !*****************************************************************************80 ! !! ICFSCP does a forward IC solve. (Purdue storage, multicolor) ! ! ! (i + b)*x = y if ipropa = 0 ! (d + b)*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! nc integer vector of length ncolor giving the number ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! nb integer vector of length ncolor giving the number ! of lower columns for each color ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! wksp workspace vector of length ! max(nc(i)) if keygs = 1 ! 0 if keygs = 2 ! x on input, x contains y ! on output, x is the solution to the back solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), wksp(1) logical propa ! propa = ipropa == 1 ist = 1 do 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,wksp) if (.not. propa) go to 20 x(ist:ied) = x(ist:ied)*d(ist:ied) 20 ist = ist + npt end do return end subroutine icfsct (ndimr,ndimi,jc,d,c,ncolor,nc,nt,ipropa,wksp,x) ! !*****************************************************************************80 ! !! ICFSCT does a transpose forward ic solve. (Purdue storage, multicolor) ! ! ! (i + (t**t))*x = y if ipropa = 0 ! (d + (t**t))*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! nc integer vector of length ncolor giving the number ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! wksp workspace vector of length max(nc(i)) ! x on input, x contains y ! on output, x is the solution to the forward solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jc(ndimi,1), nc(1), nt(1) dimension d(1), c(ndimr,1), x(1), wksp(1) logical propa ! propa = ipropa == 1 ist = 1 do icol = 1,ncolor npt = nc(icol) ied = ist + npt - 1 if (.not. propa) go to 20 x(ist:ied) = x(ist:ied)*d(ist:ied) 20 j2 = nt(icol) call vsubpt (ndimr,ndimi,npt,j2,c(ist,1),jc(ist,1),x,x(ist),wksp) ist = ist + npt end do return end subroutine icfsp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) ! !*****************************************************************************80 ! !! ICFSP does an IC forward solve (natural ordering, Purdue storage). ! ! ! (i + b)*x = y if ipropa = 0 ! (d + b)*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxb number of columns in b array ! jb integer array giving the column numbers of the ! corresponding elements in b ! d vector of length n giving the diagonal elements ! of the factorization ! b array of active size n by maxb giving the lower ! triangle of the factorization if ipropa = 0 ! or the lower triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! x on input, x contains y ! on output, x is the solution to forward-solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension x(1), d(1), b(ndimr,1) integer jb(ndimi,1) logical propa ! propa = ipropa == 1 if (maxb >= 1) go to 15 if (.not. propa) return x(1:n) = x(1:n) * d(1:n) return 15 continue do i = 1,n sum = x(i) do j = 1,maxb sum = sum - b(i,j)*x(jb(i,j)) end do if (propa) sum = sum*d(i) x(i) = sum end do return end subroutine icfst (ndim,nn,maxtt,jt,d,t,ipropa,irwise,iwksp,x) ! !*****************************************************************************80 ! !! ICFST does an IC forward solve (natural ordering, diagonal storage). ! ! ! (i + (t**t))*x = y if not property a ! (i + (t**t)*d)*x = y if property a ! ! Parameters: ! ! ndim row dimension of t array ! n order of system (= nn) ! maxt number of columns in t array ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! x on input, x contains y ! on output, x is the solution to forward-solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) logical propa n = nn maxt = maxtt nm1 = n - 1 propa = ipropa == 1 if (maxt < 1) return ! ! select rowwise or diagonal-wise algorithm. ! if (irwise == 1) go to 70 ! ! diagonal-wise algorithm. ! iwksp(1:maxt) = jt(1:maxt) + 1 ! ! determine nc, imin. ! 20 continue nc = n do 25 i = 1,maxt nterm = iwksp(i) - 1 if (nterm >= nc) go to 25 nc = nterm imin = i 25 continue if (nc >= n) return ndel = jt(imin) ibeg = nc + 1 if (ndel > 1) go to 50 ! ! special case for first minor subdiagonal. ! nc1 = n do 30 i = 1,maxt if (i == imin) go to 30 if (iwksp(i) < 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 ! ! far diagonals (do vector computations). ! 50 iwksp(imin) = iwksp(imin) + ndel iend = min (ibeg+ndel-1,n) if (propa) go to 60 !dir$ ivdep do i = ibeg,iend x(i) = x(i) - t(i-ndel,imin)*x(i-ndel) end do go to 20 !dir$ 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 ! ! rowwise algorithm. ! 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 icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) ! !*****************************************************************************80 ! !! ICFSTP does a transpose IC forward solve (natural ordering, Purdue storage). ! ! ! (i + (t**t))*x = y if ipropa = 0 ! (d + (t**t))*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! jt integer array giving the column numbers of the ! corresponding elements in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! x on input, x contains y ! on output, x is the solution to forward-solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension x(1), d(1), t(ndimr,1) integer jt(ndimi,1) logical propa ! propa = ipropa == 1 if (maxt >= 1) go to 15 if (.not. propa) return x(1:n) = x(1:n) * d(1:n) return 15 continue do i = 1,n if (propa) x(i) = x(i)*d(i) term = x(i) do j = 1,maxt x(jt(i,j)) = x(jt(i,j)) - t(i,j)*term end do end do return end subroutine icfv (ndim,nn,maxtt,jt,d,t,meth,ipropa,omega,wksp,iwksp,iflag) ! !*****************************************************************************80 ! !! ICFV computes an incomplete factorization. (symmetric diagonal storage, vectorized version) ! ! ! The matrix is stored in d and t and the factorization replaces it. ! ! ! Parameters: ! ! ndim row dimension of t array ! n order of system (= nn) ! maxt number of columns in t array ! jt integer vector giving the diagonal indices of ! the corresponding columns in t ! d vector of length n giving the diagonal elements ! of the matrix ! t array of active size n by maxt giving the ! super-diagonals of the matrix ! meth point factorization wanted ! = 1 ic ! = 2 mic ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! omega modification factor between 0.0 and 1.0 ! = 0 no modification ! = 1 full modification ! wksp workspace vector of length n ! iwksp integer workspace of length maxt**2 ! iflag indicator of factorization stability ! iflag = 0 no errors detected ! = 1 zero pivot encountered ! (unsuccessful factorization) ! = 2 negative pivot encountered ! (successful factorization) ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jt(1), iwksp(1) dimension d(1), t(ndim,1), wksp(1) logical propa ! n = nn maxt = maxtt iflag = 0 propa = ipropa == 1 if (maxt < 1) go to 500 if (meth /= 1 .or. .not. propa) go to 45 ! ! ic, propa = t. ! iwksp(1:maxt) = jt(1:maxt) + 1 ! ! determine nc, imin. ! 15 nc = n do i = 1,maxt nterm = iwksp(i) - 1 if ( nterm < nc ) then nc = nterm imin = i end if end do if (nc >= n) go to 500 ndel = jt(imin) ibeg = nc + 1 if (ndel > 1) go to 35 ! ! special case for first super-diagonal. ! nc1 = n do 25 i = 1,maxt if (i == imin) go to 25 if (iwksp(i) < nc1) nc1 = iwksp(i) 25 continue iwksp(imin) = nc1 + 1 do j = ibeg,nc1 d(j) = d(j) - (t(j-1,imin)**2)/d(j-1) end do go to 15 ! ! far diagonals. ! 35 iwksp(imin) = iwksp(imin) + ndel ied = min (ibeg+ndel-1,n) !dir$ ivdep do i = ibeg,ied d(i) = d(i) - (t(i-ndel,imin)**2)/d(i-ndel) end do go to 15 45 if (meth /= 2 .or. .not. propa) go to 100 ! ! mic, propa = t. ! wksp(1:n) = 0.0D+00 do j = 1,maxt wksp(1:n) = wksp(1:n) + t(1:n,j) end do do i = 1,maxt iwksp(i) = jt(i) + 1 end do ! ! determine nc, imin. ! 70 nc = n do 75 i = 1,maxt nterm = iwksp(i) - 1 if (nterm >= nc) go to 75 nc = nterm imin = i 75 continue if (nc >= n) go to 500 ndel = jt(imin) ibeg = nc + 1 if (ndel > 1) go to 90 ! ! special case for first super-diagonal. ! nc1 = n do 80 i = 1,maxt if (i == imin) go to 80 if (iwksp(i) < 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) - (omega-1.0D+00) * t(j-1,imin)) / d(j-1) go to 70 ! ! far diagonals. ! 90 iwksp(imin) = iwksp(imin) + ndel ied = min (ibeg+ndel-1,n) !dir$ ivdep do i = ibeg,ied d(i) = d(i) - t(i-ndel,imin)*(omega*wksp(i-ndel)- & (omega-1.0D+00)*t(i-ndel,imin))/d(i-ndel) end do go to 70 ! ! set up pointers for propa = f case. ! 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) /= id) go to 105 iwksp(iloc) = k go to 110 105 continue iwksp(iloc) = nbig 110 continue 115 continue ! ! ic, mic for propa = f. ! do 120 i = 1,maxt 120 iwksp(i) = jt(i) + 1 ! ! determine nc, imin. ! 125 nc = n do 130 i = 1,maxt nterm = iwksp(i) - 1 if (nterm >= nc) go to 130 nc = nterm imin = i 130 continue if (nc >= n) go to 500 ndel = jt(imin) iwksp(imin) = iwksp(imin) + ndel ibeg = nc + 1 ied = min (ibeg+ndel-1,n) !dir$ ivdep do i = ibeg,ied d(i) = d(i) - (t(i-ndel,imin)**2)/d(i-ndel) end do do 160 j = 1,maxt jcol = jt(j) if (jcol <= ndel) go to 160 iloc = j*maxt + imin id = iwksp(iloc) ied1 = min (ied,n-jcol+ndel) if (id == nbig) go to 145 !dir$ ivdep do i = ibeg,ied1 t(i,id) = t(i,id) - t(i-ndel,imin)*t(i-ndel,j)/d(i-ndel) end do go to 160 145 if (meth == 1) go to 160 do i = ibeg,ied1 wksp(i) = omega*t(i-ndel,imin)*t(i-ndel,j)/d(i-ndel) end do ish = jcol - ndel do i = ibeg,ied1 d(i) = d(i) - wksp(i) d(i+ish) = d(i+ish) - wksp(i) end do 160 continue go to 125 ! ! store reciprocals of pivots. ! 500 continue do i = 1,n if (d(i) == 0.0D+00) then iflag = 1 return end if end do d(1:n) = 1.0D+00 / d(1:n) if ( propa ) go to 990 do j = 1,maxt len = n - jt(j) t(1:len,j) = d(1:len)*t(1:len,j) end do ! ! check for negative pivots. ! 990 if (vmin(n,d) < 0.0D+00) iflag = 2 return end subroutine ics (ndim,nn,maxtt,jt,d,t,ipropa,irwise,iwksp,y,x) ! !*****************************************************************************80 ! !! ICS does an IC solution (natural ordering, symmetric diagonal storage). ! ! ! (i + (t**t))*inv(d)*(i + t)*x = y propa = .false. ! (i + (t**t)*d)*inv(d)*(i + d*t)*x = y propa = .true. ! ! Parameters: ! ! ndim row dimension of t array ! n order of system (= nn) ! maxt number of columns in t array ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) ! n = nn maxt = maxtt x(1:n) = y(1:n) call icfst (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) x(1:n) = d(1:n)*x(1:n) 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) ! !*****************************************************************************80 ! !! ICS1 does an IC forward solution (natural ordering, symmetric diagonal storage). ! ! ! (i + (t**t))*inv(d)*x = y propa = .false. ! (i + (t**t)*d)*inv(d)*x = y propa = .true. ! ! Parameters: ! ! ndim row dimension of t array ! n order of system (= nn) ! maxt number of columns in t array ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) ! n = nn maxt = maxtt x(1:n) = y(1:n) call icfst (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) x(1:n) = sqrt(abs(d(1:n)))*x(1:n) return end subroutine ics2 ( ndim, nn, maxtt, jt, d, t, ipropa, irwise, iwksp, y, x ) !*****************************************************************************80 ! !! ICS2 does an IC back solution (natural ordering, symmetric diagonal storage). ! ! (i + t)*x = y propa = .false. ! (i + d*t)*x = y propa = .true. ! ! Modified: ! ! 03 July 2007 ! ! Parameters: ! ! ndim row dimension of t array. ! ! n order of system (= nn). ! ! maxt number of columns in t array. ! ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t. ! ! d vector of length n giving the diagonal elements ! of the factorization. ! ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a. ! ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a. ! ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm. ! ! iwksp integer workspace of length maxt. ! ! y right-hand-side vector ! ! x on output, x is the solution ! implicit none integer maxtt integer nn integer ndim real ( kind = 8 ) d(nn) integer ipropa integer irwise integer iwksp(maxtt) integer jt(maxtt) integer maxt integer n real ( kind = 8 ) t(ndim,maxtt) real ( kind = 8 ) x(nn) real ( kind = 8 ) y(nn) n = nn maxt = maxtt x(1:n) = y(1:n) * sign ( 1.0D+00, d(1:n) ) * sqrt ( abs ( d(1:n) ) ) 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) !*****************************************************************************80 ! !! ICS3 does an IC transpose backward solution (natural ordering, symmetric diagonal storage). ! ! ! inv(d)*(i + t)*x = y propa = .false. ! inv(d)*(i + d*t)*x = y propa = .true. ! ! Parameters: ! ! ndim row dimension of t array ! n order of system (= nn) ! maxt number of columns in t array ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) n = nn maxt = maxtt x(1:n) = sqrt(abs(d(1:n)))*y(1:n) 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) !*****************************************************************************80 ! !! ICS4 does an IC transpose forward solution (natural ordering, symmetric diagonal storage). ! ! ! (i + (t**t))*x = y propa = .false. ! (i + (t**t)*d)*x = y propa = .true. ! ! Parameters: ! ! ndim row dimension of t array ! n order of system (= nn) ! maxt number of columns in t array ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) n = nn maxt = maxtt x(1:n) = y(1:n) call icfst (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) x(1:n) = x(1:n)*sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n))) return end subroutine icscp (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp,y,x) !*****************************************************************************80 ! !! ICSCP does an IC solve. (Purdue storage, multicolor) ! ! (i + b)*d*(i + t)*x = y if ipropa = 0 ! (d + b)*inv(d)*(d + t)*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! n order of system (= nn) ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! nc integer vector of length ncolor giving the number ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! nb integer vector of length ncolor giving the number ! of lower columns for each color ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! wksp workspace vector of length ! max(nc(i)) if keygs = 1 ! 0 if keygs = 2 ! y on input, y is the right-hand-side vector ! x on output, x is the solution to the forward solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) n = nn x(1:n) = y(1:n) call icfscp (ndimr,ndimi,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp,x) if ( ipropa /= 1 ) then x(1:n) = x(1:n) * d(1:n) else x(1:n) = x(1:n) / d(1:n) end if call icbscp (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,ipropa,wksp,x) return end subroutine icscp1 (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,nb,ipropa, wksp,y,x) !*****************************************************************************80 ! !! ICSCP1 does an IC forward solve. (Purdue storage, multicolor) ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! n order of system (= nn) ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! nc integer vector of length ncolor giving the number ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! nb integer vector of length ncolor giving the number ! of lower columns for each color ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! wksp workspace vector of length ! max(nc(i)) if keygs = 1 ! 0 if keygs = 2 ! y on input, y is the right-hand-side vector ! x on output, x is the solution to the forward solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) n = nn x(1:n) = y(1:n) call icfscp (ndimr,ndimi,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp,x) if ( ipropa /= 1) then x(1:n) = x(1:n)*sqrt(abs(d(1:n))) else x(1:n) = x(1:n)/sqrt(abs(d(1:n))) end if return end subroutine icscp2 (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,ipropa,wksp,y,x) !*****************************************************************************80 ! !! ICSCP2 does an IC back solve. (Purdue storage, multicolor) ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! n order of system (= nn) ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! nc integer vector of length ncolor giving the number ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! wksp workspace vector of length ! max(nc(i)) if keygs = 1 ! 0 if keygs = 2 ! y on input, y is the right-hand-side vector ! x on output, x is the solution to the forward solve ! ! implicit real ( kind = 8 ) ( a - h, o - z ) integer jc(ndimi,1), nc(1), nt(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) n = nn if (ipropa == 1) go to 20 x(1:n) = y(1:n)*sign(1.0D+00,d(1:n)) * sqrt(abs(d(1:n))) go to 30 20 continue x(1:n) = y(1:n)/(sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n)))) 30 continue call icbscp (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,ipropa,wksp,x) return end subroutine icscp3 (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp,y,x) !*****************************************************************************80 ! !! ICSCP3 does a transpose IC forward solve. (Purdue storage, multicolor) ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! n order of system (= nn) ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! nc integer vector of length ncolor giving the number ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! nb integer vector of length ncolor giving the number ! of lower columns for each color ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! wksp workspace vector of length max(nc(i)) ! y on input, y is the right-hand-side vector ! x on output, x is the solution vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) n = nn if (ipropa == 1) go to 20 x(1:n) = y(1:n)*sqrt(abs(d(1:n))) go to 30 20 continue x(1:n) = y(1:n)/sqrt(abs(d(1:n))) 30 continue call icbsct (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp,x) return end subroutine icscp4 (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,ipropa,wksp,y,x) !*****************************************************************************80 ! !! ICSCP4 does a transpose IC back solve. (Purdue storage, multicolor) ! ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! n order of system (= nn) ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! nc integer vector of length ncolor giving the number ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! wksp workspace vector of length max(nc(i)) ! y on input, y is the right-hand-side vector ! x on output, x is the solution vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) integer jc(ndimi,1), nc(1), nt(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) n = nn x(1:n) = y(1:n) call icfsct (ndimr,ndimi,jc,d,c,ncolor,nc,nt,ipropa,wksp,x) if (ipropa == 1) go to 20 x(1:n) = x(1:n)*sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n))) return 20 continue x(1:n) = x(1:n)/(sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n)))) return end subroutine icscpt (ndimr,ndimi,nn,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp,y,x) !*****************************************************************************80 ! !! ICSCPT does a transpose IC solve. (Purdue storage, multicolor) ! ! (i + (t**t))*d*(i + (b**t))*x = y if ipropa = 0 ! (d + (t**t))*inv(d)*(d + (b**t))*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of c array ! ndimi row dimension of jc array ! n order of system (= nn) ! jc integer array giving the column indices of the ! corresponding elements in c ! d vector of length n giving the diagonal elements ! of the matrix ! c array of active size n by maxc giving the ! off diagonal elements of the matrix. ! thus, a = d + c ! ncolor number of colors used ! nc integer vector of length ncolor giving the number ! of nodes for each color ! nt integer vector of length ncolor giving the number ! of upper columns for each color ! nb integer vector of length ncolor giving the number ! of lower columns for each color ! ipropa property a flag ! = 0 matrix does not have property a ! = 1 matrix has property a ! wksp workspace vector of length max(nc(i)) ! y on input, y is the right-hand-side vector ! x on output, x is the solution vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) integer jc(ndimi,1), nc(1), nt(1), nb(1) dimension d(1), c(ndimr,1), x(1), y(1), wksp(1) n = nn x(1:n) = y(1:n) call icfsct (ndimr,ndimi,jc,d,c,ncolor,nc,nt,ipropa,wksp,x) if ( ipropa /= 1 ) then x(1:n) = x(1:n) * d(1:n) else x(1:n) = x(1:n) / d(1:n) end if call icbsct (ndimr,ndimi,n,jc,d,c,ncolor,nc,nt,nb,ipropa,wksp,x) return end subroutine icsn (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,ipropa,irwise,iwksp,y,x) !*****************************************************************************80 ! !! ICSN does an IC solution (natural ordering, nonsymmetric diagonal storage). ! ! (i + b)*inv(d)*(i + t)*x = y propa = .false. ! (i + b*d)*inv(d)*(i + d*t)*x = y propa = .true. ! ! Parameters: ! ! ndim row dimension of t and b arrays ! n order of system (= nn) ! maxt number of columns in t array ! maxb number of columns in b array ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t ! jb integer vector of length maxb giving the diagonal ! indices of the corresponding columns in b ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! b array of active size n by maxb giving the sub- ! diagonals of the factorization if not property a ! or the sub-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), t(ndim,1), b(ndim,1) integer jt(1), jb(1), iwksp(1) n = nn maxt = maxtt maxb = maxbb x(1:n) = y(1:n) call icfs (ndim,n,maxb,jb,d,b,ipropa,irwise,iwksp,x) x(1:n) = d(1:n)*x(1:n) call icbs (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) return end subroutine icsn1 (ndim,n,maxb,jb,d,b,ipropa,irwise,iwksp,y,x) !*****************************************************************************80 ! !! ICSN1 does an IC forward pass (natural ordering, nonsymmetric diagonal storage). ! ! (i + b)*inv(d)*(i + t)*x = y propa = .false. ! (i + b*d)*inv(d)*(i + d*t)*x = y propa = .true. ! ! Parameters: ! ! ndim row dimension of t and b arrays ! n order of system (= nn) ! maxb number of columns in b array ! jb integer vector of length maxb giving the diagonal ! indices of the corresponding columns in b ! d vector of length n giving the diagonal elements ! of the factorization ! b array of active size n by maxb giving the sub- ! diagonals of the factorization if not property a ! or the sub-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension y(1), x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) ! x(1:n) = y(1:n) call icfs (ndim,n,maxb,jb,d,b,ipropa,irwise,iwksp,x) x(1:n) = sqrt ( abs ( d(1:n) ) ) * x(1:n) return end subroutine icsn2 (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,y,x) ! !*****************************************************************************80 ! !! ICSN2 does an IC back pass (natural ordering, nonsymmetric diagonal storage). ! ! ! (i + b)*inv(d)*(i + t)*x = y propa = .false. ! (i + b*d)*inv(d)*(i + d*t)*x = y propa = .true. ! ! Parameters: ! ! ndim row dimension of t and b arrays ! n order of system (= nn) ! maxt number of columns in t array ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) x(1:n) = y(1:n)*sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n))) call icbs (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) return end subroutine icsn3 (ndim,n,maxb,jb,d,b,ipropa,irwise,iwksp,y,x) ! !*****************************************************************************80 ! !! ICSN3 does an IC transpose back pass (natural ordering, nonsymmetric diagonal storage). ! ! ! (i + b)*inv(d)*(i + t)*x = y propa = .false. ! (i + b*d)*inv(d)*(i + d*t)*x = y propa = .true. ! ! Parameters: ! ! ndim row dimension of t and b arrays ! n order of system (= nn) ! maxb number of columns in b array ! jb integer vector of length maxb giving the diagonal ! indices of the corresponding columns in b ! d vector of length n giving the diagonal elements ! of the factorization ! b array of active size n by maxb giving the sub- ! diagonals of the factorization if not property a ! or the sub-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), b(ndim,1) integer jb(1), iwksp(1) x(1:n) = sqrt(abs(d(1:n)))*y(1:n) call icbst (ndim,n,maxb,jb,d,b,ipropa,irwise,iwksp,x) return end subroutine icsn4 (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,y,x) ! !*****************************************************************************80 ! !! ICSN4 does an IC transpose forward pass (natural ordering, nonsymmetric diagonal storage). ! ! ! (i + b)*inv(d)*(i + t)*x = y propa = .false. ! (i + b*d)*inv(d)*(i + d*t)*x = y propa = .true. ! ! Parameters: ! ! ndim row dimension of t and b arrays ! n order of system (= nn) ! maxt number of columns in t array ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), t(ndim,1) integer jt(1), iwksp(1) x(1:n) = y(1:n) call icfst (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) x(1:n) = x(1:n)*sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n))) return end subroutine icsnp (ndimr,ndimi,nn,maxtt,maxbb,jt,jb,d,t,b,ipropa,y,x) ! !*****************************************************************************80 ! !! ICSNP does an IC solution (natural ordering, Purdue storage, nonsymmetric matrix). ! ! ! (i + b)*d*(i + t)*x = y if ipropa = 0 ! (d + b)*inv(d)*(d + t)*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! maxb number of columns in b array ! jt integer array giving the column numbers of the ! corresponding elements in t ! jb integer array giving the column numbers of the ! corresponding elements in b ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! b array of active size n by maxb giving the lower ! triangle of the factorization if ipropa = 0 ! or the lower triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), t(ndimr,1), b(ndimr,1) integer jt(ndimi,1), jb(ndimi,1) n = nn maxt = maxtt maxb = maxbb x(1:n) = y(1:n) call icfsp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) if (ipropa == 1) go to 20 x(1:n) = x(1:n)*d(1:n) go to 30 20 continue x(1:n) = x(1:n)/d(1:n) 30 continue call icbsp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) return end subroutine icsnp1 (ndimr,ndimi,nn,maxb,jb,d,b,ipropa,y,x) ! !*****************************************************************************80 ! !! ICSNP1 does an IC forward solution (natural ordering, Purdue storage, nonsymmetric matrix). ! ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxb number of columns in b array ! jb integer array giving the column numbers of the ! corresponding elements in b ! d vector of length n giving the diagonal elements ! of the factorization ! b array of active size n by maxb giving the lower ! triangle of the factorization if ipropa = 0 ! or the lower triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), b(ndimr,1) integer jb(ndimi,1) n = nn x(1:n) = y(1:n) call icfsp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) if (ipropa == 1) go to 20 x(1:n) = x(1:n)*sqrt(abs(d(1:n))) return 20 continue x(1:n) = x(1:n)/sqrt(abs(d(1:n))) return end subroutine icsnp2 (ndimr,ndimi,n,maxt,jt,d,t,ipropa,y,x) ! !*****************************************************************************80 ! !! ICSNP2 does an IC back solution (natural ordering, Purdue storage, nonsymmetric matrix). ! ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! jt integer array giving the column numbers of the ! corresponding elements in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) if (ipropa == 1) go to 20 x(1:n) = y(1:n)*sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n))) go to 30 20 continue x(1:n) = y(1:n)/(sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n)))) 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) ! !*****************************************************************************80 ! !! ICSNP3 does a transpose IC forward solution (natural ordering, Purdue storage, nonsymmetric matrix). ! ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxb number of columns in b array ! jb integer array giving the column numbers of the ! corresponding elements in b ! d vector of length n giving the diagonal elements ! of the factorization ! b array of active size n by maxb giving the lower ! triangle of the factorization if ipropa = 0 ! or the lower triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension y(1), x(1), d(1), b(ndimr,1) integer jb(ndimi,1) ! if (ipropa == 1) go to 20 x(1:n) = y(1:n)*sqrt(abs(d(1:n))) go to 30 20 continue x(1:n) = y(1:n)/sqrt(abs(d(1:n))) 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) ! !*****************************************************************************80 ! !! ICSNP4 does a transpose IC back solution (natural ordering, Purdue storage, nonsymmetric matrix). ! ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! jt integer array giving the column numbers of the ! corresponding elements in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) x(1:n) = y(1:n) call icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) if (ipropa == 1) go to 20 x(1:n) = x(1:n)*sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n))) return 20 continue x(1:n) = x(1:n)/(sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n)))) return end subroutine icsnt (ndim,nn,maxtt,maxbb,jt,jb,d,t,b,ipropa,irwise,iwksp,y,x) ! !*****************************************************************************80 ! !! ICSNT does a transpose IC solution (natural ordering, nonsymmetric diagonal storage). ! ! ! (i + (t**t))*inv(d)*(i + (b**t))*x = y propa = .false. ! (i + (t**t)*d)*inv(d)*(i + d*(b**t))*x = y propa = .true. ! ! Parameters: ! ! ndim row dimension of t and b arrays ! n order of system (= nn) ! maxt number of columns in t array ! maxb number of columns in b array ! jt integer vector of length maxt giving the diagonal ! indices of the corresponding columns in t ! jb integer vector of length maxb giving the diagonal ! indices of the corresponding columns in b ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the super- ! diagonals of the factorization if not property a ! or the super-diagonals of the matrix if property a ! b array of active size n by maxb giving the sub- ! diagonals of the factorization if not property a ! or the sub-diagonals of the matrix if property a ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! irwise rowwise algorithm switch ! = 0 use diagonal algorithm ! = 1 use row-wise algorithm ! iwksp integer workspace of length maxt ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), t(ndim,1), b(ndim,1) integer jt(1), jb(1), iwksp(1) n = nn maxt = maxtt maxb = maxbb x(1:n) = y(1:n) call icfst (ndim,n,maxt,jt,d,t,ipropa,irwise,iwksp,x) x(1:n) = d(1:n)*x(1:n) call icbst (ndim,n,maxb,jb,d,b,ipropa,irwise,iwksp,x) return end subroutine icsntp (ndimr,ndimi,nn,maxtt,maxbb,jt,jb,d,t,b,ipropa,y,x) ! !*****************************************************************************80 ! !! ICSNTP does a transpose IC solution (natural ordering, Purdue storage, nonsymmetric matrix). ! ! ! (i + (t**t))*d*(i + (b**t))*x = y if ipropa = 0 ! (d + (t**t))*inv(d)*(d + (b**t))*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! maxb number of columns in b array ! jt integer array giving the column numbers of the ! corresponding elements in t ! jb integer array giving the column numbers of the ! corresponding elements in b ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! b array of active size n by maxb giving the lower ! triangle of the factorization if ipropa = 0 ! or the lower triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension y(1), x(1), d(1), t(ndimr,1), b(ndimr,1) integer jt(ndimi,1), jb(ndimi,1) n = nn maxt = maxtt maxb = maxbb x(1:n) = y(1:n) call icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) if (ipropa == 1) go to 20 x(1:n) = x(1:n)*d(1:n) go to 30 20 continue x(1:n) = x(1:n)/d(1:n) 30 continue call icbstp (ndimr,ndimi,n,maxb,jb,d,b,ipropa,x) return end subroutine icsp (ndimr,ndimi,nn,maxtt,jt,d,t,ipropa,y,x) ! !*****************************************************************************80 ! !! ICSP does an IC solution (natural ordering, Purdue storage, symmetric matrix). ! ! ! (i + (t**t))*d*(i + t)*x = y if ipropa = 0 ! (d + (t**t))*inv(d)*(d + t)*x = y if ipropa = 1 ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! jt integer array giving the column numbers of the ! corresponding elements in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) ! n = nn maxt = maxtt x(1:n) = y(1:n) call icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) if (ipropa == 1) go to 20 x(1:n) = x(1:n)*d(1:n) go to 30 20 continue x(1:n) = x(1:n) / d(1:n) 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) ! !*****************************************************************************80 ! !! ICSP1 does an IC forward solution (natural ordering, Purdue storage, symmetric matrix). ! ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! jt integer array giving the column numbers of the ! corresponding elements in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) ! n = nn x(1:n) = y(1:n) call icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) if (ipropa == 1) go to 20 x(1:n) = x(1:n)*sqrt(abs(d(1:n))) return 20 continue x(1:n) = x(1:n)/sqrt(abs(d(1:n))) return end subroutine icsp2 (ndimr,ndimi,n,maxt,jt,d,t,ipropa,y,x) ! !*****************************************************************************80 ! !! ICSP2 does an IC back solution (natural ordering, Purdue storage, symmetric matrix). ! ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! jt integer array giving the column numbers of the ! corresponding elements in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) ! if (ipropa == 1) go to 20 x(1:n) = y(1:n)*sign(1.0D+00,d(1:n)) * sqrt(abs(d(1:n))) go to 30 20 continue x(1:n) = y(1:n)/(sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n)))) 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) ! !*****************************************************************************80 ! !! ICSP3 does an IC transpose forward solution (natural ordering, Purdue storage, symmetric matrix). ! ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! jt integer array giving the column numbers of the ! corresponding elements in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) ! if (ipropa == 1) go to 20 x(1:n) = y(1:n)*sqrt(abs(d(1:n))) go to 30 20 continue x(1:n) = y(1:n)/sqrt(abs(d(1:n))) 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) ! !*****************************************************************************80 ! !! ICSP4 does an IC transpose back solution (natural ordering, Purdue storage, symmetric matrix). ! ! ! Parameters: ! ! ndimr row dimension of real arrays ! ndimi row dimension of integer arrays ! n order of system ! maxt number of columns in t array ! jt integer array giving the column numbers of the ! corresponding elements in t ! d vector of length n giving the diagonal elements ! of the factorization ! t array of active size n by maxt giving the upper ! triangle of the factorization if ipropa = 0 ! or the upper triangle of the matrix if ipropa = 1 ! ipropa property a switch ! = 0 matrix does not have property a ! = 1 matrix does have property a ! y right-hand-side vector ! x on output, x is the solution ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension y(1), x(1), d(1), t(ndimr,1) integer jt(ndimi,1) ! x(1:n) = y(1:n) call icfstp (ndimr,ndimi,n,maxt,jt,d,t,ipropa,x) if (ipropa == 1) go to 20 x(1:n) = x(1:n)*sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n))) return 20 continue x(1:n) = x(1:n)/(sign(1.0D+00,d(1:n))*sqrt(abs(d(1:n)))) return end subroutine inithv (icall) ! !*****************************************************************************80 ! !! INITHV initializes dot and vector "haves" to FALSE. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! udhav = .false. rdhav = .false. rzhav = .false. rzthav = .false. zdhav = .false. zzthav = .false. ztdhav = .false. if (icall == 1) return rhave = .false. zhave = .false. zthave = .false. ! return end subroutine iom (suba,subat,subql,subqlt,subqr,subqrt,subadp,coef,jcoef,n,u, & ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! IOM is the user interface to the (truncated) IOM algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! nw = lenr - irpnt + 1 call iomw (suba,subql,subqr,coef,jcoef,wksp,iwksp,n,u,ubar,rhs,wksp(irpnt), & nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine iomw (suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & wk,nw,iparm,rparm,ier) ! !*****************************************************************************80 ! !! IOMW runs the (truncated) IOM algorithm. ! ! ! the reference is ! youcef saad, "krylov subspace methods.", mathematics of ! computation, vol. 37, july 1981, pp. 105f. ! ! in the symmetric case this algorithm reduces to the symmlq ! algorithm of paige and saunders, except paige and saunders have ! implemented a trick to avoid breakdown before convergence. this ! trick is not implemented here. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), 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 ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! ! ! next, the indexing functions. ! 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) ! ! preliminary calculations. ! nwusd = 0 ier = 0 iacel = 10 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 996 iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 gamize = .true. if (iqr) go to 995 if (level >= 2) write (nout,496) 496 format (' iom') ! the following flag tells us whether the truncating actually ! throws out important information. it should actually be set to ! true if the matrix is symmetric. exact = .false. ! ! initialize the stopping test. ! call inithv (0) zdhav = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 730 ! ! associated integer variables. ! 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) ! ! check the memory usage -- ! if (nwusd > nw) go to 999 ! in = 0 is = 0 uneed = rcalp .or. zcalp .or. ztcalp .or. udhav .or. ntest == 6 .or. & level >= 3 ! ! Begin iteration loop. ! ! perform first-iterate calculations. ! 10 if (is /= 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,wk(ibeta1), & gdum,gamize,wk(iv2),wkxxx,ier) gamma1 = gdum(1) if (ier < 0) go to 997 gamma2 = gamma1 vnorm1 = 1.0D+00 / gamma1 vnorm2 = 1.0D+00 / gamma2 zdot = vnorm1**2 ucnp1= 0.0D+00 ! 100 call inithv (1) zdhav = .true. nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk(iv1),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv1-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! ! ! compute q(n+1), etc -- the direction vectors ! 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,wk(ibeta1), & gdum,gamize,wk(iv2),wkxxx,ier) gamma1 = gdum(1) if (ier < 0) go to 997 gamma2 = gamma1 ! ! now record norms. ! vn1old = vnorm1 vnorm1 = 1.0D+00 / gamma1 vn2old = vnorm2 vnorm2 = 1.0D+00 / gamma2 ! ! now update the factorization ! ucnbar = ucnp1 ibgn = max(0,is+1-os) do i = ibgn,is wk(indu(i+1)) = -wk(indbe2(i)) end do if (ibgn > 0) wk(indu(ibgn))= 0.0D+00 call qrupd (is+1,os+1,os,wk(icos),wk(isin),ucnbar,ucn,wk(iu),vn2old,ier) if (ier < 0) go to 998 ucnp1 = wk(indu(is+1)) ! ! update the old w vector. ! if (is /= 0) then call vtriad (n,wk(indw(is-1)),xxx,ucnbar/ucn,wk(indw(is-1)),2) end if ! ! now generate the new w vector. ! if (abs(ucnp1) < srelpr) go to 998 call vcopy (n,wk(indv1(is)),wk(iv1)) ibgn = max(1,is-os+1) iend = is do i = ibgn,iend call vtriad (n,wk(iv1),wk(iv1),-wk(indu(i)),wk(indw(i-1)),1) end do call vtriad (n,wk(indw(is)),xxx,1.0D+00/ucnp1,wk(iv1),2) if (is /= 0) go to 205 ! ! update iterate u(0). ! zold= 0.0D+00 zbar = vn1old if (uneed) call vtriad (n,u,u,zbar,wk(indw(0)),1) go to 210 ! ! update subsequent iterates u(n). ! 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) ! to avoid breakdown for the symmetric indefinite case, we'd only add ! in w(is-1) here, i believe. 210 continue zdot = (zbar/ucnp1*vnorm1)**2 ! ! proceed to next iteration ! in = in + 1 is = is + 1 go to 10 ! ! Finish up. ! 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 >= 1) write (nout,720) in 720 format (/' iom converged in ',i5,' iterations.') ! 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! error returns ! 995 ier = -16 call ershow (ier,'iomw') return 996 call ershow (ier,'iomw') go to 735 997 ier = -13 call ershow (ier,'iomw') go to 725 998 ier = -14 call ershow (ier,'iomw') go to 725 999 ier = -2 call ershow (ier,'iomw') go to 735 end function ipstr (omega) ! !*****************************************************************************80 ! !! IPSTR finds a suitable exponent for OMEGA-1. ! ! ! Discussion: ! ! IPSTR is the smallest integer such that ! ! ipstr * (omega-1)**(ipstr-1) <= 0.50. ! ! IPSTR is required to be greater than 5. ! ! Parameters: ! ! omega relaxation factor for sor method ! implicit real ( kind = 8 ) ( a - h, o - z ) ! wm1 = omega - 1.0D+00 factor = wm1**5 do ip = 6, 940 if ( real ( ip, kind = 8 ) * factor <= 0.5D+00 ) then ipstr = ip return end if factor = factor*wm1 end do ipstr = 940 return end subroutine iptgen (ncolor,ipt,nc) ! !*****************************************************************************80 ! !! IPTGEN generates the pointer vector to block rows. ! ! ! The algorithm is for block structured matrices with nonconstant block size. ! ! Parameters: ! ! ncolor the number of colors (block rows) ! ipt upon input, an integer vector of length ncolor+1 ! upon output, the pointer vector ! nc integer vector of length ncolor giving the ! number of nodes for each color ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer ipt(1), nc(1) ! ipt(1) = 0 do k = 1, ncolor ipt(k+1) = ipt(k) + nc(k) end do return end subroutine itcg ( suba, subq, coef, jcoef, wfac, jwfac, nn, u, ubar, rhs, & r, p, z, tri, ier ) ! !*****************************************************************************80 ! !! ITCG does the conjugate gradient iterations. ! ! ! Parameters: ! ! suba matrix-vector multiplication routine ! subq preconditioning routine ! n order of system (= nn) ! u current solution ! ubar known solution (optional) ! rhs right hand side vector ! r,p,z workspace vectors of length n each ! tri tridiagonal matrix associated with the ! eigenvalues of the tridiagonal matrix. ! ier error code ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! n = nn in = 0 is = 0 rzdot = 0.0D+00 alpha = 0.0D+00 beta = 0.0D+00 alphao = 0.0D+00 maxadp = maxadd minadp = minadd ! ! Compute R = residual. ! call suba ( coef, jcoef, wfac, jwfac, n, u, r ) r(1:n) = rhs(1:n) - r(1:n) ! ! Begin iteration loop. ! do ! ! Preconditioning: solve Q*z = r. ! call subq ( coef, jcoef, wfac, jwfac, n, r, z ) ! ! Compute rzdot = (r,z) ! dkm1 = rzdot rzdot = dot_product ( r(1:n), z(1:n) ) if ( rzdot <= 0.0D+00 ) then ier = -7 call ershow ( ier, 'itcg' ) stop end if ! ! Determine whether or not to stop. ! call pstops ( n, r, z, u, ubar, ier ) if ( 2 <= level ) then call iterm ( n, u ) end if if ( halt .or. ier < 0 ) then exit end if if ( itmax <= in ) then ier = 1 call ershow ( ier, 'itcg' ) zeta = stptst exit end if ! ! Compute beta = rzdot/dkm1 ! if ( in /= 0 ) then beta = rzdot / dkm1 end if ! ! Compute p = z + beta*p ! p(1:n) = z(1:n) + beta * p(1:n) ! ! Compute alpha = rzdot / (p,a*p) ! call suba ( coef, jcoef, wfac, jwfac, n, p, z ) alphao = alpha pap = dot_product ( p(1:n), z(1:n) ) alpha = rzdot / pap if ( pap <= 0.0D+00 ) then ier = -6 call ershow ( ier, 'itcg' ) stop end if ! ! Compute eigenvalue estimates. ! if ( maxadp .or. minadp ) then call chgcon ( tri, ier ) end if ! ! Compute new solution u = u + alpha*p ! u(1:n) = u(1:n) + alpha * p(1:n) in = in + 1 is = is + 1 r(1:n) = r(1:n) - alpha * z(1:n) end do return end subroutine iterm ( nn, u ) ! !*****************************************************************************80 ! !! ITERM produces the iteration summary line at the end of each iteration. ! ! ! if level >= 4, the latest approximation ! to the solution will be printed. ! ! Parameters: ! ! n order of system (= nn) ! u solution estimate ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1) ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer logical omgadp common / itcom5 / omgadp common / itcom55 / omega, alphab, betab, fff, specr ! ! ! n = nn ! ! print various parameters after each iteration ! if (in > 0) go to 15 ! ! print header ! if (iacel /= 3) write (nout,10) 10 format (/5x,'intermediate output after each iteration' & /' iteration',11x,'convergence ', & 5x,'emax',9x,'emin' /7x,'n',7x,'s',8x,'test' /) if (iacel == 3) write (nout,12) 12 format (////5x,'intermediate output after each iteration' & //' number of',11x,'convergence',5x, & 'emax',8x,'omega',7x,'spectral' /' iterations', & 13x,'test',34x,'radius' //) ! ! print summary line ! 15 if (iacel /= 3) write (nout,20) in,is,stptst,emax,emin 20 format (3x,i5,3x,i5,3x,3e13.5) if (iacel == 3) write (nout,22) in,is,stptst,emax,omega,specr 22 format (3x,i5,3x,i5,3x,5e13.5) if (level >= 4) go to 25 return ! 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 (//) ! return end subroutine itsi (suba,subq,coef,jcoef,wfac,jwfac,nn,u,ubar,rhs,r,p,z,wksp,ier) ! !*****************************************************************************80 ! !! ITSI does the semi-iterative iterations. ! ! ! Parameters: ! ! suba matrix-vector multiplication routine ! subq preconditioning routine ! n order of system (= nn) ! u current solution ! ubar known solution (optional) ! rhs right hand side vector ! r,p,z, workspace vectors of length n each ! wksp volatile workspace ! ier error code ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! ! n = nn in = 0 ! ! new chebychev sequence. ! 10 continue is = 0 alpha = 0.0D+00 beta = 0.0D+00 rho = 1.0D+00 rzdot = 0.0D+00 gamma = 2.0D+00 / (emax + emin) sigma = (emax - emin)/(emax + emin) term = sqrt (1.0D+00 - sigma*sigma) rr = (1.0D+00 - term)/(1.0D+00 + term) maxadp = maxadd minadp = minadd ! ! compute r = residual ! call suba (coef,jcoef,wfac,jwfac,n,u,r) r(1:n) = rhs(1:n) - r(1:n) go to 30 ! ! begin iteration loop. ! 20 continue r(1:n) = r(1:n) - alpha*z(1:n) ! ! do preconditioning step -- solve q*z = r for z. ! 30 continue call subq (coef,jcoef,wfac,jwfac,n,r,z) ! ! compute rzdot = (r,z) ! dkm1 = rzdot rzdot = dot_product ( r(1:n), z(1:n) ) if (is == 0) dkq = rzdot if (rzdot >= 0.0D+00) go to 40 ier = -7 call ershow (ier,'itsi') return ! ! determine whether or not to stop. ! 40 call pstops (n,r,z,u,ubar,ier) if (level >= 2) call iterm (n,u) if (halt .or. ier < 0) return if ( itmax <= in ) then ier = 1 call ershow (ier,'itsi') zeta = stptst return end if ! ! compute iteration parameters. ! call parsi ! ! compute p = z + beta*p ! u = u + alpha*p ! p(1:n) = z(1:n) + beta*p(1:n) u(1:n) = u(1:n) + alpha*p(1:n) ! ! adapt on emin and emax ! 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 < 0) return ! ! check if new estimates of emax, emin are to be used. ! if (icode == 1) go to 10 ! ! estimates of emax, emin are still good. ! 55 continue is = is + 1 call suba ( coef, jcoef, wfac, jwfac, n, p, z ) go to 20 end subroutine itsor ( subq, coef, jcoef, wfac, jwfac, nn, u, ubar, rhs, wksp, & ier ) !*****************************************************************************80 ! !! ITSOR does the SOR iterations. ! ! Parameters: ! ! subq routine to do an sor pass ! n size of system ! rhs right hand side ! u solution vector ! ubar known solution (optional) ! wksp workspace vector of length 2*n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jcoef(2), jwfac(1) dimension coef(1), wfac(1) dimension rhs(1), u(1), ubar(1), wksp(1) external subq logical change ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 logical omgadp common / itcom5 / omgadp common / itcom55 / omega, alphab, betab, fff, specr ! ! set initial parameters not already set ! n = nn in = 0 is = 0 ip = 0 iss = 0 iphat = 2 delnnm = 0.0D+00 delsnm = 0.0D+00 call sorstp ( n, u, ubar, 0.0D+00, 0.0D+00 ) change = omgadp ib2 = n + 1 if ( omgadp ) then omegap = omega omega = 1.0D+00 ipstar = 4 if (omegap <= 1.0D+00 ) change = .false. end if ! ! start iterating. ! 10 continue do 55 iter = 1,itmax+1 ! ! output intermediate information ! if (level >= 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.0D+00)/(2.0D+00-omega) ) ) ipstar = ipstr (omega) ! ! compute u (in + 1) and norm of del(s,p) ! 15 continue delsnm = delnnm spcrm1 = specr wksp(1:n) = rhs(1:n) call subq (coef,jcoef,wfac,jwfac,n,u,wksp,wksp(ib2)) do i = 1, n wksp(i) = u(i) - wksp(n+i) end do delnnm = sqrt ( sum ( wksp(1:n)**2 ) ) do i = 1, n u(i) = wksp(i+n) end do if (delnnm == 0.0D+00) go to 35 if (in /= 0) specr = delnnm / delsnm if (ip < iphat) go to 50 ! ! stopping test, set h ! if (specr >= 1.0D+00 ) go to 50 if (.not. (specr > (omega - 1.0D+00 ))) go to 35 h = specr go to 40 35 continue iss = iss + 1 h = omega - 1.0D+00 ! ! perform stopping test. ! 40 continue dnrm = delnnm**2 call sorstp (n,u,ubar,dnrm,h) if (halt) go to 50 ! ! method has not converged yet, test for changing omega ! if (.not. omgadp) go to 50 if (ip < ipstar) go to 50 if (omega > 1.0D+00) go to 45 emax = sqrt (abs (specr)) omegap = 2.0D+00 / (1.0D+00 + sqrt (abs (1.0D+00 - specr))) change = .true. go to 50 45 if (iss /= 0) go to 50 if (specr <= (omega - 1.0D+00)**fff) go to 50 if ((specr + 0.00005D+00 ) <= spcrm1) go to 50 ! ! change parameters ! emax = (specr + omega - 1.0D+00) / (sqrt (abs (specr))*omega) omegap = 2.0D+00 / (1.0D+00 + sqrt (abs (1.0D+00 - emax*emax))) change = .true. ! 50 ip = ip + 1 in = in + 1 55 continue ier = 1 in = in - 1 call ershow (ier,'itsor') zeta = stptst return end subroutine itsrcg (suba,subq,subadp,coef,jcoef,wfac,jwfac,nn,u,ubar, & rhs,r,p,z,tri,ier) ! !*****************************************************************************80 ! !! ITSRCG does the SSOR conjugate gradient iterations. ! ! ! Parameters: ! ! suba matrix-vector multiplication routine ! subq preconditioning routine ! subadp adpation routine ! n order of system (= nn) ! u current solution ! ubar known solution (optional) ! rhs right hand side vector ! r,p,z workspace vectors of length n each ! tri tridiagonal matrix associated with the ! eigenvalues of the tridiagonal matrix. ! ier error code ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! n = nn in = 0 isw = 1 5 continue is = 0 rzdot = 0.0D+00 alpha = 0.0D+00 beta = 0.0D+00 alphao = 0.0D+00 maxadp = maxadd minadp = minadd ! ! recompute bnorm ! call nmcalc (coef,jcoef,wfac,jwfac,isw,subq,n,rhs,ubar,r,ier) if ( ier < 0 ) return isw = 2 ! ! compute r = residual ! call suba (coef,jcoef,wfac,jwfac,n,u,r) r(1:n) = rhs(1:n) - r(1:n) go to 25 ! ! begin iteration loop. ! 15 continue r(1:n) = r(1:n) - alpha*z(1:n) ! ! do preconditioning step -- solve q*z = r for z. ! 25 continue call subq (coef,jcoef,wfac,jwfac,n,r,z) ! ! compute rzdot = (r,z) ! dkm1 = rzdot rzdot = dot_product ( r(1:n), z(1:n) ) if ( rzdot < 0.0D+00 ) then ier = -7 call ershow (ier,'itsrcg') return end if ! ! determine whether or not to stop. ! call pstops (n,r,z,u,ubar,ier) if ( 2 <= level ) then call iterm (n,u) end if if ( halt .or. ier < 0 ) then return end if if ( itmax <= in ) then ier = 1 call ershow (ier,'itsrcg') zeta = stptst return end if ! ! Compute beta = rzdot/dkm1 ! if ( is /= 0 ) then beta = rzdot / dkm1 end if ! ! Compute p = z + beta*p ! p(1:n) = z(1:n) + beta*p(1:n) ! ! compute alpha = rzdot / (p,a*p) ! call suba (coef,jcoef,wfac,jwfac,n,p,z) alphao = alpha pap = dot_product ( p(1:n), z(1:n) ) alpha = rzdot / pap if ( pap < 0.0D+00 ) then ier = -6 call ershow (ier,'itsrcg') return end if ! ! Compute latest eigenvalue estimates. ! if ( minadp ) then call chgcon (tri,ier) end if ! ! compute new solution u = u + alpha*p ! u(1:n) = u(1:n) + alpha*p(1:n) is = is + 1 in = in + 1 call ssorad (subadp,coef,jcoef,wfac,jwfac,n,p,z,r,icode) if (icode == 0) go to 15 go to 5 end subroutine itsrsi (suba,subq,subadp,coef,jcoef,wfac,jwfac,nn,u,ubar, & rhs,r,p,z,wksp,ier) ! !*****************************************************************************80 ! !! ITSRSI does the SSOR semi-iterative iterations. ! ! Parameters: ! ! suba matrix-vector multiplication routine ! subq preconditioning routine ! subadp adpation routine ! n order of system (= nn) ! u current solution ! ubar known solution (optional) ! rhs right hand side vector ! r,p,z, workspace vectors of length n each ! wksp volatile workspace ! ier error code ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! ! n = nn ! in = 0 isw = 1 ! ! recompute bnorm ! 5 call nmcalc (coef,jcoef,wfac,jwfac,isw,subq,n,rhs,ubar,r,ier) if (ier < 0) return isw = 2 ! ! update rayleigh quotient . ! if (in == 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 ! ! new chebychev sequence. ! 10 is = 0 alpha = 0.0D+00 beta = 0.0D+00 rho = 1.0D+00 rzdot = 0.0D+00 gamma = 2.0D+00 /( emax + emin) sigma = (emax - emin)/(emax + emin) term = sqrt (1.0D+00 - sigma*sigma) rr = (1.0D+00 - term)/(1.0D+00 + term) minadp = minadd ! ! compute r = residual ! call suba (coef,jcoef,wfac,jwfac,n,u,r) r(1:n) = rhs(1:n) - r(1:n) go to 30 ! ! begin iteration loop. ! 20 continue r(1:n) = r(1:n) - alpha*z(1:n) ! ! do preconditioning step -- solve q*z = r for z. ! 30 call subq (coef,jcoef,wfac,jwfac,n,r,z) ! ! compute rzdot = (r,z) ! dkm1 = rzdot rzdot = dot_product ( r(1:n), z(1:n) ) if (is == 0) dkq = rzdot if (rzdot >= 0.0D+00) go to 40 ier = -7 call ershow (ier,'itsrsi') return ! ! determine whether or not to stop. ! 40 continue call pstops (n,r,z,u,ubar,ier) if (level >= 2) call iterm (n,u) if (halt .or. ier < 0) return if ( itmax <= in ) then ier = 1 call ershow (ier,'itsrsi') zeta = stptst return end if ! ! compute iteration parameters. ! call parsi ! ! compute p = z + beta*p ! u = u + alpha*p ! p(1:n) = z(1:n) + beta*p(1:n) u(1:n) = u(1:n) + alpha*p(1:n) ! ! adapt on emin and emax ! in = in + 1 if (.not. minadp) go to 55 call chgsi (suba,coef,jcoef,wfac,jwfac,n,z,wksp,icode,ier) if (ier < 0) return ! ! check if new estimates of emax, emin are to be used. ! if (icode == 1) go to 10 ! ! estimates of emax, emin are still good. ! 55 continue 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 == 0) go to 20 go to 5 end subroutine jac1 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! JAC1 drives the Jacobi preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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, keygs, keyzer ! iwkpt1 = irpnt if (keygs == 1) irpnt = irpnt + n call split (accel,suba8,suba9,subq1,subq1,subq1,subq1,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) if (keygs == 1) irpnt = irpnt - n return end subroutine jac2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! JAC2 drives the Jacobi preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! call split (accel,suba1,suba1,subq1,subq1,subq1,subq1,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine jac3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! JAC3 drives the Jacobi preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! call split (accel,suba4,suba5,subq1,subq1,subq1,subq1,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine jac4 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! JAC4 drives the Jacobi preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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, keygs, keyzer ! iwkpt1 = irpnt if (keygs == 1) irpnt = irpnt + 2*n call split (accel,suba12,suba12,subq1,subq1,subq1,subq1,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) if (keygs == 1) irpnt = irpnt - 2*n return end subroutine jac5 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! JAC5 drives the Jacobi preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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, keygs, keyzer ! iwkpt1 = irpnt if (keygs == 1) irpnt = irpnt + 2*n call split (accel,suba13,suba14,subq1,subq1,subq1,subq1,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) if (keygs == 1) irpnt = irpnt - 2*n return end subroutine landir (suba,subat,subql,subqlt,subqr,subqrt,subadp,coef,jcoef, & n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LANDIR is the user interface to the Lanczos/ORTHODIR algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! nw = lenr - irpnt + 1 call ldirw (suba,subat,subql,subqlt,subqr,subqrt,coef,jcoef,wksp,iwksp,n, & u,ubar,rhs,wksp(irpnt),nw,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,coef,jcoef,n, & u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LANMIN is the user interface to the Lanczos/ORTHOMIN algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! nw = lenr - irpnt + 1 call lminw (suba,subat,subql,subqlt,subqr,subqrt,coef,jcoef,wksp,iwksp,n, & u,ubar,rhs,wksp(irpnt),nw,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,coef,jcoef,n, & u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LANRES is the user interface to the Lanczos/ORTHORES algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! nw = lenr - irpnt + 1 call lresw (suba,subat,subql,subqlt,subqr,subqrt,coef,jcoef,wksp,iwksp,n, & u,ubar,rhs,wksp(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine ldirw (suba,subat,subql,subqlt,subqr,subqrt,coef,jcoef,wfac, & jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LDIRW runs the Lanczos/ORTHODIR algorithm. ! ! see jea and young, in ! linear algebra and its applications, vol 52/3, 1983, pp399f. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), wfac(1), jwfac(1) external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! ! ! indexing functions. ! indq(i) = iq + n*mod(i,2) indqt(i) = iqt + n*mod(i,2) ! ! preliminary calculations. ! nwusd = 0 ier = 0 iacel = 14 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 997 iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 if (iqr) go to 995 if (level >= 2) write (nout,496) 496 format (' landir') ! ! initialize the stopping test. ! call inithv (0) zhave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 730 ! 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) ! ! check the memory usage. ! if (nwusd > nw) go to 999 ! 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)) ! ! begin iteration loop ! ! determine whether or not to stop. ! 10 call inithv (1) nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,wk(ir),xxx,wk(iv1),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv1-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! if (in /= 0) go to 110 ! ! perform first-iterate calculations ! call vcopy (n,wk(ir),wk(indq(in))) call vcopy (n,wk(indq(in)),wk(indqt(in))) qaq= 0.0D+00 go to 115 ! ! proceed to calculate the direction vectors, for in > 0. ! 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 /= 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) ! ! proceed to form the iterate. ! 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) < 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) ! ! proceed to next iteration ! in = in + 1 is = is + 1 go to 10 ! ! Finish up. ! 900 if (halt) go to 715 ier = 1 call ershow (ier,'ldirw') zeta = stptst go to 725 715 continue if (level >= 1) write (nout,720) in 720 format (/' lanczos/orthodir converged in ',i5,' iterations.') 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! error returns ! 995 ier = -16 call ershow (ier,'ldirw') return ! 997 call ershow (ier,'ldirw') go to 735 ! 998 ier = -15 call ershow (ier,'ldirw') go to 725 ! 999 ier = -2 call ershow (ier,'ldirw') go to 735 ! end subroutine lfact (coef,jcoef,wksp,nn,ier) ! !*****************************************************************************80 ! !! LFACT computes a line factorization. ! ! ! Parameters: ! ! n problem size ! nfactr factorization size ! implicit real ( kind = 8 ) ( a - h, o - z ) ! common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, 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) ! ! check for sufficient workspace to store factor. ! n = nn if (nstore == 2) isym = 0 if (nstore == 3) isym = 1 ndt = 0 ndb = 0 do 20 jd = 1,maxnz do 15 j = 1,maxnz if (jcoef(j) /= jd) go to 15 ndt = ndt + 1 go to 20 15 continue go to 25 20 continue 25 if (isym == 0) go to 40 do 35 jd = 1,maxnz do 30 j = 1,maxnz if (jcoef(j) /= -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 < 0) return ! ifactr = irpnt call vcopy (n,coef,wksp(ifactr)) ndt = 0 do 55 jd = 1,maxnz do 50 j = 1,maxnz if (jcoef(j) /= 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 == 0) go to 75 do 70 jd = 1,maxnz do 65 j = 1,maxnz if (jcoef(j) /= -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 ! ! factor. ! 75 call bdfac (n,n,kblsz,ndt,ndb,wksp(ifactr),isym) irpnt = irpnt + nfactr return end subroutine linv (coef,jcoef,wksp,nn,ier) ! !*****************************************************************************80 ! !! LINV computes a line approximate inverse. ! ! ! Parameters: ! ! n problem size ! nfactr factorization size ! implicit real ( kind = 8 ) ( a - h, o - z ) ! common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, 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) ! ! check for sufficient workspace to store factor. ! n = nn if (nstore == 2) isym = 0 if (nstore == 3) isym = 1 ndt = 0 ndb = 0 do 20 jd = 1,maxnz do 15 j = 1,maxnz if (jcoef(j) /= jd) go to 15 ndt = ndt + 1 go to 20 15 continue exit 20 continue 25 continue if (isym == 0) go to 40 do 35 jd = 1,maxnz do 30 j = 1,maxnz if (jcoef(j) /= -jd) go to 30 ndb = ndb + 1 go to 35 30 continue go to 40 35 continue ! 40 ndt = ndt + ltrunc if (isym == 1) ndb = ndb + ltrunc nfactr = (ndt + ndb + 1)*n call needw ('linv',0,irpnt,nfactr,ier) if (ier < 0) return ifactr = irpnt call vfill ( nfactr, wksp(ifactr), 0.0D+00 ) call vcopy ( n, coef, wksp(ifactr) ) it = 0 do 55 jd = 1,maxnz do 50 j = 1,maxnz if (jcoef(j) /= 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 == 0) go to 75 it = ndt do 70 jd = 1,maxnz do 65 j = 1,maxnz if (jcoef(j) /= -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 ! ! factor and invert. ! 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 ljac2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LJAC2 drives the line Jacobi preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! t1 = timer (dummy) if (ifact == 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return call split (accel,suba1,suba1,subq2,subq2,subq2,subq2,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine ljac3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LJAC3 drives the line Jacobi preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! t1 = timer (dummy) if (ifact == 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return call split (accel,suba4,suba5,subq2,subq3,subq2,subq3,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine ljacx2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LJACX2 drives the line Jacobi preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! t1 = timer (dummy) if (ifact == 1) call linv (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return call split (accel,suba1,suba1,subq4,subq4,subq4,subq4,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine ljacx3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LJACX3 drives the line Jacobi preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! t1 = timer (dummy) if (ifact == 1) call linv (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return call split (accel,suba4,suba5,subq4,subq5,subq4,subq5,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine llsp2 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LLSP2 drives the line least squares polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! 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, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! n = nn call needw ('llsp2',0,irpnt,n,ier) if (ier < 0) return call adinfn (n,ndim,maxnz,jcoef,coef,2,ainf,wksp(irpnt)) t1 = timer (dummy) if (ifact == 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return call needw ('llsp2',0,irpnt,2*n,ier) if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*n call split (accel,suba1,suba1,subq23,subq23,subq23,subq23,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine llsp3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LLSP3 drives the line least squares polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! 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, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! n = nn call needw ('llsp3',0,irpnt,n,ier) if (ier < 0) return call adinfn (n,ndim,maxnz,jcoef,coef,3,ainf,wksp(irpnt)) t1 = timer (dummy) if (ifact == 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return call needw ('llsp3',0,irpnt,2*n,ier) if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*n call split (accel,suba4,suba5,subq66,subq67,subq66,subq67,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine lminw (suba,subat,subql,subqlt,subqr,subqrt,coef,jcoef,wfac, & jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LMINW runs the Lanczos/ORTHOMIN algorithm. ! ! ! Here, zhat and phat will refer to the "dummy" system of the ! lanczos method. ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension u(1) dimension ubar(1) dimension rhs(1) dimension wk(1), coef(1), jcoef(2),wfac(1), jwfac(1) external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav nwusd = 0 ier = 0 iacel = 15 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 997 if (level >= 2) write (nout,496) 496 format (' lanmin') ! ! initialize the stopping test. ! iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 call inithv (0) zhave = .true. zthave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 730 ! ! 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 == 0) nwusd = max(nwusd,iv1-1+n) if (iqlr /= 0) nwusd = max(nwusd,iv2-1+n) ! ! check the memory usage. ! if (nwusd > nw) go to 999 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)) ! ! begin iteration loop ! ! determine whether or not to stop. ! 10 call inithv (1) nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,wk(iz),wk(izt),wk(iv1),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv1-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! if (in /= 0) go to 110 ! ! perform first-iterate calculations ! 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 ! ! perform subsequent-iterate calculations ! 110 rdold = rd ! if (abs(rdold) < srelpr) go to 996 if (abs(rdold) == 0.0D+00 ) go to 996 ! ! 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) ! ! 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) ! ! Form the iterate. ! 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)) ! if (abs(pap) < srelpr**2) go to 998 if (abs(pap) == 0.0D+00) go to 998 vlamda = rd/pap 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) ! ! proceed to next iteration ! 151 in = in + 1 is = is + 1 go to 10 ! ! Finish up. ! 900 if (halt) go to 715 ier = 1 call ershow (ier,'lminw') zeta = stptst go to 725 715 continue if (level >= 1) write (nout,720) in 720 format (/' lanczos/orthomin converged in ',i5,' iterations.') 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! error returns ! 996 ier = -13 call ershow (ier,'lminw') go to 725 ! 997 call ershow (ier,'lminw') go to 735 ! 998 ier = -15 call ershow (ier,'lminw') go to 725 ! 999 ier = -2 call ershow (ier,'lminw') go to 735 ! end subroutine lneu2 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LNEU2 drives the line Neumann polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! 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, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! n = nn t1 = timer (dummy) if (ifact == 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return call needw ('lneu2',0,irpnt,2*n,ier) if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*n call split (accel,suba1,suba1,subq24,subq24,subq24,subq24,copy,copy,noadp, & 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,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LNEU3 drives the line Neumann polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! 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, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! n = nn t1 = timer (dummy) if (ifact == 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return call needw ('lneu3',0,irpnt,2*n,ier) if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*n call split (accel,suba4,suba5,subq68,subq69,subq68,subq69,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine lresw (suba,subat,subql,subqlt,subqr,subqrt,coef,jcoef,wfac, & jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LRESW runs the Lanczos/ORTHORES algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), wfac(1), jwfac(1) external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! indexing functions. ! indu(i) = iu + n*mod(i,nv) indr(i) = ir + n*mod(i,nv) indrt(i) = irt + n*mod(i,nv) ! ! preliminary calculations. ! nwusd = 0 ier = 0 iacel = 16 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 997 iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 if (iqr) go to 995 if (level >= 2) write (nout,496) 496 format (' lanres') ! ! initialize the stopping test. ! call inithv (0) zhave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 730 nv = 2 iu = 1 ir = iu + nv*n irt = ir + nv*n iv1 = irt + nv*n nwusd = max(nwusd,iv1-1+n) ! ! check the memory usage. ! if (nwusd > nw) go to 999 ! ! note -- we will use the vector 'u' for scratch storage, to save space. ! 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))) ! ! Begin iteration loop. ! ! determine whether or not to stop. ! 10 call inithv (1) nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,wk(indu(in)), & ubar,rhs,xxx,wk(indr(in)),xxx,wk(iv1),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv1-1) if (level >= 2) call iterm (n,wk(indu(in))) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! ! proceed to calculate the parameters. ! first, gamma. ! 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) < srelpr) go to 998 gam = rd / rar ! ! now, rho. ! if (in /= 0) go to 118 rho = 1.0D+00 go to 119 118 if (abs(gamold) < srelpr) go to 998 if (abs(rdold) < srelpr) go to 998 if (abs(rho) < srelpr) go to 998 rhoinv = 1.0D+00 - (gam/gamold)*(rd/rdold)/rho if (abs(rhoinv) < srelpr) go to 998 rho = 1.0D+00 / rhoinv ! ! now work on updating u, r, rt. ! first, the first iteration. ! 119 if (in /= 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 ! ! now work on subsequent iterations. ! 150 call vtriad (n,wk(indu(in+1)),xxx,1.0D+00-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,wk(indr(in)),1) call vtriad (n,wk(indr(in+1)),xxx,1.0D+00-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.0D+00-rho,wk(indrt(in-1)),2) call vtriad (n,wk(indrt(in+1)),wk(indrt(in+1)),rho,wk(indrt(in)),1) call vtriad (n,wk(indrt(in+1)),wk(indrt(in+1)),-rho*gam,u,1) ! ! proceed to next iteration ! 151 gamold = gam rdold = rd in = in + 1 is = is + 1 go to 10 ! ! Finish up. ! 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 >= 1) write (nout,720) in 720 format (/' lanczos/orthores converged in ',i5,' iterations.') ! 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! error returns ! 995 ier = -16 call ershow (ier,'lresw') return ! 997 call ershow (ier,'lresw') go to 735 ! 998 ier = -15 call ershow (ier,'lresw') go to 725 ! 999 ier = -2 call ershow (ier,'lresw') go to 735 ! end subroutine lsor2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LSOR2 drives the line SOR method. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return call split (accel,suba1,suba1,subq20,subq20,subq20,subq20,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine lsor3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LSOR3 drives the line SOR method. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return call split (accel,suba4,suba5,subq58,subq58,subq58,subq58,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) return end subroutine lsp1 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LSP1 drives the least squares polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! 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, keygs, keyzer ! n = nn call needw ('lsp1',0,irpnt,2*n,ier) if (ier < 0) return call ainfn (n,ndim,maxnz,jcoef,coef,1,ainf,wksp(irpnt)) iwkpt2 = irpnt irpnt = irpnt + 2*n iwkpt1 = irpnt if (keygs == 1) irpnt = irpnt + n call split (accel,suba8,suba9,subq92,subq93,subq92,subq93,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n if (keygs == 1) irpnt = irpnt - n return end subroutine lsp2 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LSP2 drives the least squares polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / itcom8 / ainf common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 ! n = nn call needw ('lsp2',0,irpnt,2*n,ier) if (ier < 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,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine lsp3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LSP3 drives the least squares polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / itcom8 / ainf common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 ! n = nn call needw ('lsp3',0,irpnt,2*n,ier) if (ier < 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,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n return end subroutine lsp4 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LSP4 drives the least squares polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! 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, keygs, keyzer ! n = nn call needw ('lsp4',0,irpnt,2*n,ier) if (ier < 0) return call ainfn (n,ndim,maxnz,jcoef,coef,4,ainf,wksp(irpnt)) iwkpt2 = irpnt irpnt = irpnt + 2*n iwkpt1 = irpnt if (keygs == 1) irpnt = irpnt + 2*n call split (accel,suba12,suba12,sub110,sub110,sub110,sub110,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n if (keygs == 1) irpnt = irpnt - 2*n return end subroutine lsp5 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LSP5 drives the least squares polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! 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, keygs, keyzer ! n = nn call needw ('lsp5',0,irpnt,2*n,ier) if (ier < 0) return call ainfn (n,ndim,maxnz,jcoef,coef,5,ainf,wksp(irpnt)) iwkpt2 = irpnt irpnt = irpnt + 2*n iwkpt1 = irpnt if (keygs == 1) irpnt = irpnt + 2*n call split (accel,suba13,suba14,sub112,sub113,sub112,sub113,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*n if (keygs == 1) irpnt = irpnt - 2*n return end subroutine lsqr (suba,subat,subql,subqlt,subqr,subqrt,subadp,coef,jcoef,n,u, & ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LSQR is the user interface to the LSQR algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! nw = lenr - irpnt + 1 call lsqrw (suba,subat,subql,subqlt,subqr,subqrt,coef,jcoef,wksp,iwksp,n,u, & ubar,rhs,wksp(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine lsqrw (suba,subat,subql,subqlt,subqr,subqrt,coef,jcoef,wfac, & jwfac,n,u,ubar,rhs,wk,nw,iparm,rparm,ier) !*****************************************************************************80 ! !! LSQRW runs the LSQR algorithm. ! ! the algorithm is taken from ! the article 'lsqr -- an algorithm for sparse linear equations ! and sparse least squares.' ! by c. c. paige amd m. a. saunders, in acm transactions on ! mathematical software, vol. 8, no. 1, march 1982, pp. 43-71. ! the iterates produced are the same as those of cgnr, in exact ! arithmetic, but this should be more stable. only left ! preconditioning is currently implemented. ! implicit real ( kind = 8 ) ( a - h, o - z ) dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), wfac(1), jwfac(1) external suba, subat, subql, subqlt, subqr, subqrt dimension iparm(30), rparm(30) logical iql, iqr ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! ! ! preliminary calculations. ! nwusd = 0 ier = 0 iacel = 6 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 996 iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 if (iqr) go to 995 if (level >= 2) write (nout,496) 496 format (' lsqr') ! ! initialize the stopping test. ! call inithv (0) zdhav = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 735 ! ! associated integer variables. ! iu = 1 iv = iu + n iw = iv + n iv1 = iw + n iv2 = iv1 + n nwusd = max(nwusd,iv2-1+n) ! ! check the memory usage. ! if (nwusd > nw) go to 999 in = 0 is = 0 ! ! now, perform first-iterate calculations ! 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) < srelpr) go to 997 call vtriad (n,wk(iu),xxx,1.0D+00/beta,wk(iv2),2) 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) < srelpr) go to 997 call vtriad (n,wk(iv),xxx,1.0D+00/alpha,wk(iv2),2) call vcopy (n,wk(iv),wk(iw)) phibar = beta rhobar = alpha zdot = phibar**2 ! if u(0) is zero, then the norm of u(n) can be calculated for free. ! otherwise, i don't know. ! ! Begin iteration loop. ! ! determine whether or not to stop -- ! 10 call inithv (1) zdhav = .true. nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk(iv1),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv1-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! ! compute the lanczos vectors. ! 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) < srelpr) go to 997 call vtriad (n,wk(iu),xxx,1.0D+00/beta,wk(iu),2) 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) < srelpr) go to 997 call vtriad (n,wk(iv),xxx,1.0D+00/alpha,wk(iv),2) ! ! continue by calculating various scalars. ! rho = sqrt(rhobar**2+beta**2) if (rho < srelpr) go to 998 c = rhobar/rho s = beta/rho theta = s*alpha rhobar = -c*alpha phi = c*phibar phibar = s*phibar ! ! now generate the new u and w vectors. ! call vtriad (n,u,u,phi/rho,wk(iw),1) call vtriad (n,wk(iw),wk(iv),-theta/rho,wk(iw),1) ! ! proceed to next iteration ! zdot = phibar**2 in = in + 1 is = is + 1 go to 10 ! ! Finish up. ! 900 if (halt) go to 715 ier = 1 call ershow (ier,'lsqrw') zeta = stptst go to 725 715 continue if (level >= 1) write (nout,720) in 720 format (/' lsqr converged in ',i5,' iterations.') 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! error returns ! 995 ier = -16 call ershow (ier,'lsqrw') return ! 996 call ershow (ier,'lsqrw') go to 735 ! 997 ier = -13 call ershow (ier,'lsqrw') go to 725 ! 998 ier = -14 call ershow (ier,'lsqrw') go to 725 ! 999 ier = -2 call ershow (ier,'lsqrw') go to 735 ! end subroutine lssor2 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LSSOR2 drives the line SSOR method. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! n = nn call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + n if (ier < 0) return call split (accel,suba1,suba1,subq21,subq21,subq21,subq21,copy,copy,subq22, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine lssor3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! LSSOR3 drives the line SSOR method. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba4, suba5, subq59, subq60, subq61, subq62, subq63 external subq64, subq65 integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! n = nn call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call lfact (coef,jcoef,wksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + n if (ier < 0) return call split (accel,suba4,suba5,subq59,subq60,subq61,subq62,subq63,subq64, & subq65,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine mbic2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! MBIC2 drives the block factorization (version 1, modified) method. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 ! call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call bfacs (2,ibfcs3,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + kblsz if (ier < 0) return call split (accel,suba1,suba1,subq25,subq25,subq25,subq25,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - kblsz return end subroutine mbic3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! MBIC3 drives the block factorization (version 1, modified) method. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba4, suba5, subq70, subq71, subq72 external 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call bfacmz (2,ibfcn3,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*kblsz call split (accel,suba4,suba5,subq70,subq71,subq72,subq73,subq74,subq75, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*kblsz return end subroutine mbic7 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! MBIC7 drives the block factorization (version 1, modified) method. ! ! (multi-color ordering) ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba2, suba3, subq34, subq35, subq36 external 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, jcnew, lbhb, & iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 ! t1 = timer (dummy) if (ifact == 1) call bfacmy (2,ibfcn3,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*ncmax call split (accel,suba2,suba3,subq34,subq35,subq36,subq37,subq38,subq39, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*ncmax return end subroutine mbicx2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! MBICX2 drives the block factorization (version 2, modified) method. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 ! call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call bfacs (4,ibfcs4,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 iwkpt1 = irpnt irpnt = irpnt + kblsz if (ier < 0) return call split (accel,suba1,suba1,subq25,subq25,subq25,subq25,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - kblsz return end subroutine mbicx3 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! MBICX3 drives the block factorization (version 2, modified) method. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba4, suba5, subq70, subq71, subq72 external 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! call blkdef (coef,jcoef,wksp,iwksp,n,ier) if (ier < 0) return t1 = timer (dummy) if (ifact == 1) call bfacmz (4,ibfcn4,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*kblsz call split (accel,suba4,suba5,subq70,subq71,subq72,subq73,subq74,subq75, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*kblsz return end subroutine mbicx7 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwkspiparm,rparm,ier) ! !*****************************************************************************80 ! !! MBICX7 drives the block factorization (version 2, modified method). ! ! (multi-color ordering) ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba2, suba3, subq34, subq35, subq36 external 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv logical propa common / cblock / propa, ncolor, maxd, nc, ipt, maxnew, jcnew, lbhb, & iblock, ncmax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 ! t1 = timer (dummy) if (ifact == 1) call bfacmy (4,ibfcn4,coef,jcoef,wksp,iwksp,n,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + 2*ncmax call split (accel,suba2,suba3,subq34,subq35,subq36,subq37,subq38,subq39, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - 2*ncmax return end subroutine mcopy (lda,ldb,n,m,a,b) ! !*****************************************************************************80 ! !! MCOPY copies an array into array. ! ! ! Parameters: ! ! lda leading dimension of array a ! ldb leading dimension of array b ! n number of rows in a to be copied ! m number of columns in a to be copied ! a,b arrays ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension a(lda,1), b(ldb,1) ! b(1:n,1:m) = a(1:n,1:m) return end subroutine me (suba,subat,subql,subqlt,subqr,subqrt,subadp,coef,jcoef,n,u, & ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! ME is the user interface to the minimal error algorithm of Fridman. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! nw = lenr - irpnt + 1 call mew (suba,subql,subqr,coef,jcoef,wksp,iwksp,n,u,ubar,rhs,wksp(irpnt), & nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine mew (suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk,nw, & iparm,rparm,ier) ! !*****************************************************************************80 ! !! MEW runs the minimal error algorithm of Fridman. ! ! ! the reference is: v. m. fridman, "the method of minimum iterations !.", ussr computational math. and math. phys., vol. 2, 1962, ! pp. 362-3. ! ! two-sided preconditioning is implemented. the iteration matrix ! should be symmetric for this algorithm to work. ! ! we have introduced periodic scaling of the direction vectors, to ! prevent overflow. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), wfac(1), jwfac(1) external suba, subql, subqr dimension iparm(30), rparm(30) logical iql, iqr ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! ! ! the following indexing functions are used to access the old ! direction vectors -- ! indp(i) = ip + mod(i,2)*n indpt(i) = ipt + mod(i,2)*n ! ! various preliminary calculations. ! dot = 0.0D+00 nwusd = 0 ier = 0 iacel = 4 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 997 if (level >= 2) write (nout,496) 496 format (' me') iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 ! ! initialize the stopping test. ! call inithv (0) zhave = .true. nwpstp = nw call pstop (0,suba,subql,subqr, coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx, wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 730 ! ! memory allocation, etc. ! ! nomenclature -- r -- residual of the original system. ! z -- inv(ql)*r ! zt -- inv(qr)*z ! 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 ! ! note that memory usage has been overlapped whenever possible, ! in order to save space. ! nwusd = max(nwusd,iwfree-1) ! ! check the memory usage. ! if (nwusd > nw) go to 999 in = 0 is = 0 rhave = rcalp zthave = ztcalp ! ! perform first-iterate calculations ! 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)) ! ! Begin iteration loop. ! ! determine whether or not to stop -- ! note that we have already done the calculations necessary so that suba ! and subql are not actually used by pstop. ! 10 call inithv (1) nwpstp = nw - (iwfree-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & wk(ir),wk(iz),wk(izt),wk(iwfree),nwpstp,ier) nwusd = max(nwusd,nwpstp+iwfree-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! ! compute p(n), the direction vector, and inv(qr)*p(n) (=pt(n)). ! scal = 1.0D+00 ! ! first, case of in == 0 ! if (in /= 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 ! ! case in > 0 ! 100 toplam = vdot (n,wk(indp(in-1)),wk(iz)) bet1 = - vdot (n,wk(indp(in-1)),wk(iqlap)) / dot if (in /= 1) go to 110 ! ! case in == 1 ! 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 ! ! case in > 1 ! 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) ! ! at this point, we are finished forming the latest direction vector. ! we proceed to calculate lambda and update the solution and the ! residual. ! 120 dotold = dot dot = vdot (n,wk(indp(in)),wk(indp(in))) ! if (dot < srelpr) go to 998 ! ! scale direction vector if necessary. if (dot(1.0D+00/srelpr**2)) then scal = sqrt(dot) call vtriad (n,wk(indp(in)), xxx,1.0D+00/scal,wk(indp(in)), 2) call vtriad (n,wk(indpt(in)),xxx,1.0D+00/scal,wk(indpt(in)),2) dot = 1.0D+00 end if ! 124 vlamda = toplam / dot / scal ! ! u -- ! call vtriad (n,u,u,vlamda,wk(indpt(in)),1) ! ! r -- ! 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) ! ! z -- ! call subql (coef,jcoef,wfac,jwfac,n,wk(iv2),wk(iqlap)) call vtriad (n,wk(iz),wk(iz),-vlamda,wk(iqlap),1) ! ! zt -- ! call subqr (coef,jcoef,wfac,jwfac,n,wk(iqlap),wk(iqrlap)) if (zthave) call vtriad (n,wk(izt),wk(izt),-vlamda,wk(iqrlap),1) ! ! proceed to next iteration ! in = in + 1 is = is + 1 go to 10 ! ! Finish up. ! 900 if (halt) go to 715 ier = 1 call ershow (ier,'mew') zeta = stptst go to 725 715 continue if (level >= 1) write (nout,720) in 720 format (/' me converged in ',i5,' iterations.') ! 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! error returns ! 997 call ershow (ier,'mew') go to 735 ! 998 ier = -15 call ershow (ier,'mew') go to 725 ! 999 ier = -2 call ershow (ier,'mew') go to 735 ! end subroutine mfact (coef,jcoef,wksp,iwksp,nn,ier) ! !*****************************************************************************80 ! !! MFACT computes a line factorization of a multi-color matrix. ! ! ! Parameters: ! ! n problem size ! nfactr factorization size ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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, jcnew, lbhb, & iblock, ncmax integer jcoef(2), iwksp(1) dimension coef(1), wksp(1) ! ! check for sufficient workspace to store factor. ! 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 < 0) return ! ifactr = irpnt do j = 1,nwdiag ipt1 = (j - 1)*ndim + 1 ipt2 = (j - 1)*n + ifactr call vcopy (n,coef(ipt1),wksp(ipt2)) end do ! ! factor. ! call bdfac (n,n,n,ndt,ndb,wksp(ifactr),1) irpnt = irpnt + nfactr return end subroutine mic1 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! MIC1 drives the MIC preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba8, suba9, subq86, subq87, subq88 external subq89, subq90, subq91, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) ! 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, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! ! n = nn if (ifact == 0 .and. lvfill > 0) go to 20 call move1 (ndim,mdim,n,maxnz,jcoef,coef,maxt,maxb,ier) if (ier < 0) then call ershow (ier,'mic1') return end if 20 t1 = timer (dummy) if (ifact == 1) call pfact1 (coef,jcoef,wksp,iwksp,n,2,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba8,suba9,subq86,subq87,subq88,subq89,subq90,subq91, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine mic2 (accel,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! MIC2 drives the symmetric MIC preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba1, subq13, subq14, subq15, subq16, subq17, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv common / dscons / ndim, mdim, maxnz common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 ! ! t1 = timer (dummy) if ( ifact == 1 ) then call pfact2 ( coef, jcoef, wksp, iwksp, n, 2, ier ) end if t2 = timer (dummy) timfac = t2 - t1 if ( ier < 0 ) then return end if leniw = max ( maxnz, nfacti ) iwkpt1 = iipnt iipnt = iipnt + leniw call split (accel,suba1,suba1,subq13,subq13,subq14,subq15,subq16,subq17, & noadp,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,iparm,rparm,ier) ! !*****************************************************************************80 ! !! MIC3 drives the nonsymmetric MIC preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba4, suba5, subq48, subq49, subq50 external subq51, subq52, subq53, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, 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 ! ! n = nn call needw ('mic3',1,iipnt,maxnz,ier) if (ier < 0) return call needw ('mic3',0,irpnt,n,ier) if (ier < 0) return if (ifact == 0 .and. lvfill > 0) go to 20 call move2 (ndim,n,maxnz,jcoef,coef,wksp(irpnt),iwksp(iipnt),maxt,maxb) 20 t1 = timer (dummy) if (ifact == 1) call pfact3 (coef,jcoef,wksp,iwksp,n,2,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return leniw = max (maxnz,nfacti) iwkpt1 = iipnt iipnt = iipnt + leniw call split (accel,suba4,suba5,subq48,subq49,subq50,subq51,subq52,subq53, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) iipnt = iipnt - leniw return end subroutine mic6 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! MIC6 drives the MIC preconditioner. ! ! (multi-color ordering) ! implicit real ( kind = 8 ) ( a - h, o - z ) ! external accel, suba8, suba9, sub104, sub105, sub106 external sub107, sub108, sub109, noadp integer iparm(30), jcoef(2), iwksp(1) dimension rhs(1), u(1), ubar(1), rparm(30), coef(1), wksp(1) ! 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, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! ! n = nn t1 = timer (dummy) if (ifact == 1) call pfactc (coef,jcoef,wksp,iwksp,n,2,ier) t2 = timer (dummy) timfac = t2 - t1 if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba8,suba9,sub104,sub105,sub106,sub107,sub108,sub109, & noadp,coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine move1 (ndim,mdim,nn,maxnzz,jcoef,coef,nt,nb,ier) ! !*****************************************************************************80 ! !! MOVE1 moves the data structure to the form d/t/b. ! ! ! d is the main diagonal, the t columns contain only upper ! triangular elements and the b columns contain only lower ! triangular elements. thus the upper and lower triangle ! elements are segregated into separate columns of coef, ! with the upper elements coming first. ! (Purdue data structure, natural ordering, with point ! ic or point ssor preconditionings) ! ! Parameters: ! ! ndim row dimension of coef array in defining routine ! mdim column dimension of coef array in defining routine ! n order of system (= nn) ! maxnz number of columns in coef array (= maxnzz) ! jcoef integer matrix representation array ! coef matrix representation array ! nt number of columns needed to store t, the upper ! triangular part of coef ! nb number of columns needed to store b, the lower ! triangular part of coef ! ier error code ! = 0 no errors detected ! = -9 mdim < 1+nt+nb. hence insufficient room ! to store adjusted matrix ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jcoef(ndim,1) dimension coef(ndim,1) n = nn maxnz = maxnzz ! ! determine maximum number of nonzeros per row in t and b. ! ntt = 0 nbb = 0 if (maxnz <= 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 > ntt) ntt = ntrow if (nbrow > nbb) nbb = nbrow 25 continue ! ! shuffle matrix so that t is first. ! ndtb = ntt + nbb + 1 if (ndtb <= mdim) go to 30 ! ! error -- mdim is too small. ! ier = -9 go to 999 ! ! permute elements of each row. ! 30 if (ntt*nbb == 0) go to 999 if (ndtb <= maxnz) go to 40 maxz = maxnz + 1 do 35 j = maxz,ndtb do 35 i = 1,n coef(i,j) = 0.0D+00 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) >= i) go to 50 45 jbc = jbc + 1 if (jcoef(i,jbc) < 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) <= i) go to 60 55 jtc = jtc + 1 if (jcoef(i,jtc) > 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 ! ! exit. ! 999 nt = ntt nb = nbb maxnzz = maxnz return end subroutine move2 (ndim,nn,maxnzz,jcoef,coef,work,iwork,nt,nb) ! !*****************************************************************************80 ! !! MOVE2 moves the data structure to the form d/t/b. ! ! ! d is the main diagonal, the t columns contain only upper ! triangular elements and the b columns contain only lower ! triangular elements. thus the upper and lower triangle ! elements are segregated into separate columns of coef, ! with the upper elements coming first. ! (diagonal data structure, natural ordering, with point ! ic or point ssor preconditionings) ! ! Parameters: ! ! ndim row dimension of coef array in defining routine ! n order of system (= nn) ! maxnz number of columns in coef array (= maxnzz) ! jcoef integer matrix representation array ! coef matrix representation array ! work real workspace array of length n ! iwork integer work array of length maxnz ! nt number of columns needed to store t, the upper ! triangular part of coef ! nb number of columns needed to store b, the lower ! triangular part of coef ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jcoef(2), iwork(1) dimension coef(ndim,1), work(1) ! n = nn maxnz = maxnzz ntt = 0 nbb = 0 if (maxnz <= 1) go to 999 ! ! compute nbb and ntt. ! do j = 1,maxnz ndiag = jcoef(j) if (ndiag > 0) ntt = ntt + 1 if (ndiag < 0) nbb = nbb + 1 end do ! ! compute pointers into sorted jcoef. ! ! code jcoef. ! do j = 1,maxnz if (jcoef(j) < 0) jcoef(j) = n - jcoef(j) end do iwork(1) = 1 do j = 2,maxnz iaux = jcoef(j) do k = 1,j-1 i = j - k ktemp = iwork(i) if (iaux > jcoef(ktemp)) go to 25 iwork(i+1) = iwork(i) end do i = 0 25 iwork(i+1) = j end do ! ! decode jcoef. ! do j = 1,maxnz if (jcoef(j) > n) jcoef(j) = n - jcoef(j) end do ! ! sort coef and jcoef. ! do i = 1,maxnz if (iwork(i) == i) iwork(i) = 0 end do do 65 ii = 1,maxnz k = iwork(ii) if (k == 0) go to 65 i = ii 45 jtemp = jcoef(i) jcoef(i) = jcoef(k) jcoef(k) = jtemp do l = 1,n work(l) = coef(l,i) coef(l,i) = coef(l,k) coef(l,k) = work(l) end do iwork(i) = 0 do 55 j = ii,maxnz if (iwork(j) == i) go to 60 55 continue go to 65 60 i = j if (i /= k) go to 45 iwork(k) = 0 65 continue ! ! exit. ! 999 nt = ntt nb = nbb return end subroutine move3 (ndim,mdim,nn,maxnzz,jcoef,coef,nt,nb,ncolor,nc,ier) ! !*****************************************************************************80 ! !! MOVE3 moves the data structure to the form d/t/b. ! ! ! d is the main diagonal, the t columns contain only upper ! triangular elements and the b columns contain only lower ! triangular elements. thus the upper and lower triangle ! elements are segregated into separate columns of coef, ! with the upper elements coming first. ! the above segregation is done for each color. ! (Purdue data structure, multi-color ordering, with point ! ic or point ssor preconditionings) ! ! Parameters: ! ! ndim row dimension of coef array in defining routine ! mdim column dimension of coef array in defining routine ! n order of system (= nn) ! maxnz number of columns in coef array (= maxnzz) ! jcoef integer matrix representation array ! coef matrix representation array ! nt integer vector of length ncolor. for each color, ! the number of columns needed to store t, the upper ! triangular part of the matrix for those rows. ! nb integer vector of length ncolor. for each color, ! the number of columns needed to store b, the lower ! triangular part of the matrix for those rows. ! ncolor number of colors ! nc integer vector of length ncolor, giving the number ! of nodes for each color. ! ier error code ! = 0 no errors detected ! = -9 mdim < 1+nt+nb. hence insufficient room ! to store adjusted matrix ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer jcoef(ndim,1), nt(1), nb(1), nc(1) dimension coef(ndim,1) ! ! n = nn maxnz = maxnzz ! ist = 1 do 85 icol = 1,ncolor ncol = nc(icol) ied = ist + ncol - 1 ! ! determine maximum number of nonzeros per row in t and b. ! ntt = 0 nbb = 0 if (maxnz <= 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 > ntt) ntt = ntrow if (nbrow > nbb) nbb = nbrow 25 continue ! ! shuffle matrix so that t is first. ! ndtb = ntt + nbb + 1 if (ndtb <= mdim) go to 30 ! ! error -- mdim is too small. ! ier = -9 go to 999 ! ! permute elements of each row. ! 30 if (ndtb <= maxnz) go to 40 maxz = maxnz + 1 do 35 j = maxz,ndtb do 35 i = 1,n coef(i,j) = 0.0D+00 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 > nt2) go to 50 if (jcoef(i,jtc) >= i) go to 50 45 jbc = jbc + 1 if (jcoef(i,jbc) < 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 > maxnz) go to 60 if (jcoef(i,jbc) <= i) go to 60 55 jtc = jtc + 1 if (jcoef(i,jtc) > 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 > maxnz) go to 70 if (jcoef(i,jzc) >= i) go to 70 65 jbc = jbc + 1 if (jcoef(i,jbc) < 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 ! 80 nt(icol) = ntt nb(icol) = nbb ist = ist + ncol 85 continue ! ! exit. ! 999 maxnzz = maxnz return end subroutine move4 (ndim,nn,maxnew,jcnew,coef,ncol,nc,work,iwork) ! !*****************************************************************************80 ! !! MOVE4 moves the data structure to the form dc/tc/bc. ! ! ! dc is the main diagonal block, tc is the upper triangular ! block matrices, and db is the lower triangular block ! matrices. ! the above segregation is done for each color. ! (diagonal data structure, multi-color ordering, with ! ic or ssor preconditionings (point or block)) ! ! Parameters: ! ! ndim row dimension of coef array in defining routine ! n order of system (= nn) ! maxnew integer vector giving the number of diagonals ! created for each color ! jcnew integer array of size ncolor*max(maxnew(i)) ! giving the diagonal numbers for each color ! coef matrix representation array ! ncolor number of colors ! nc integer vector of length ncolor, giving the number ! of nodes for each color. ! work real workspace array of length max (nc(i)) ! iwork integer work array of length max (maxnew(i)) ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer maxnew(1), jcnew(ncol,1), nc(1), iwork(1) dimension coef(ndim,1), work(1) ! n = nn ncolor = ncol ist = 1 do 70 icol = 1,ncolor ncc = nc(icol) ied = ist + ncc - 1 ! ! compute pointers into sorted jcnew. ! ! code jcnew. ! maxnz = maxnew(icol) do 15 j = 1,maxnz do i = ist,ied if (coef(i,j) /= 0.0D+00) go to 10 end do go to 15 10 jd = jcnew(icol,j) jcol = i + jd if (jcol < i .and. jcol >= ist) jcnew(icol,j) = n - jd if (jcol > ied) jcnew(icol,j) = 2*n + jd if (jcol < ist) jcnew(icol,j) = 3*n - jd 15 continue iwork(1) = 1 do j = 2,maxnz iaux = jcnew(icol,j) do k = 1,j-1 i = j - k ktemp = iwork(i) if (iaux > jcnew(icol,ktemp)) go to 25 iwork(i+1) = iwork(i) end do i = 0 25 iwork(i+1) = j end do ! ! decode jcnew. ! do j = 1,maxnz jd = jcnew(icol,j) if (jd > n .and. jd < 2*n) jcnew(icol,j) = n - jd if (jd > 2*n .and. jd < 3*n) jcnew(icol,j) = jd - 2*n if (jd > 3*n) jcnew(icol,j) = 3*n - jd end do ! ! sort coef and jcnew. ! do i = 1,maxnz if (iwork(i) == i) iwork(i) = 0 end do do 65 ii = 1,maxnz k = iwork(ii) if (k == 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) == i) go to 60 55 continue go to 65 60 i = j if (i /= k) go to 45 iwork(k) = 0 65 continue ist = ist + ncc 70 continue ! ! exit. ! return end subroutine move5 (ndim,n,maxnz,jcoef,coef) ! !*****************************************************************************80 ! !! MOVE5 moves the data structure to the form dc/tc/bc. ! ! ! dc is the main diagonal block, tc is the upper triangular ! block matrices, and db is the lower triangular block ! matrices. ! (diagonal data structure, with constant block size) ! ! Parameters: ! ! ndim row dimension of coef array in defining routine ! n order of system ! maxnz number of diagonals stored ! jcoef integer vector of length maxnz giving the ! diagonal numbers ! coef matrix representation array ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension coef(ndim,maxnz), jcoef(maxnz) ! ! move dc to the first columns. ! jsh = 1 jcol = 1 jget = 0 5 continue do j = 1,maxnz jd = jcoef(j) if (jd == jget) go to 15 end do if (jsh < 0) go to 30 jsh = -1 jget = -1 go to 5 15 continue if (j == jcol) go to 25 do i = 1,n temp = coef(i,j) coef(i,j) = coef(i,jcol) coef(i,jcol) = temp end do jcoef(j) = jcoef(jcol) jcoef(jcol) = jd 25 continue jcol = jcol + 1 jget = jget + jsh go to 5 ! ! move tc, bc to the next columns. ! 30 if (jcol > maxnz) return do j = jcol,maxnz jd = jcoef(j) if (jd < 0) jcoef(j) = n - jd end do jcolsv = jcol 40 jsml = jcol do j = jcol,maxnz jd = jcoef(j) if (jd < jcoef(jsml)) jsml = j end do if (jsml == jcol) go to 55 do i = 1,n temp = coef(i,jsml) coef(i,jsml) = coef(i,jcol) coef(i,jcol) = temp end do jtemp = jcoef(jsml) jcoef(jsml) = jcoef(jcol) jcoef(jcol) = jtemp 55 jcol = jcol + 1 if (jcol <= maxnz) go to 40 ! ! uncode jcoef. ! do j = jcolsv,maxnz jd = jcoef(j) if (jd > n) jcoef(j) = n - jd end do return end subroutine mul1t (ndim,maxnz,coef,jcoef,wksp,nn,x,y) ! !*****************************************************************************80 ! !! MUL1T computes y = (A**t)*x, a matrix-vector product. ! ! ! the diagonal is assumed to be in column one. ! (Purdue storage format) ! ! Parameters: ! ! ndim row dimension of coef in defining routine ! maxnz number of columns in coef ! coef array of matrix nonzeros ! jcoef array of matrix column numbers ! wksp workspace array of length n ! n dimension of matrix (= nn) ! x multiplying vector of length n ! y product vector of length n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension coef(ndim,2), x(1), y(1), wksp(1) integer jcoef(ndim,2) ! n = nn do i = 1,n y(i) = coef(i,1)*x(i) end do if (maxnz <= 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) ! !*****************************************************************************80 ! !! MUL2NT computes y = (A**t)*x, a matrix-vector product. ! ! ! the diagonal is assumed to be in column one. all diagonals of ! the matrix must be stored. ! (nonsymmetric diagonal storage format) ! ! Parameters: ! ! ndim row dimension of coef in defining routine ! maxnz number of columns in coef ! coef array of matrix diagonals ! jcoef array of matrix diagonal numbers ! n dimension of matrix (= nn) ! x multiplying vector of length n ! y product vector of length n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension coef(ndim,2), x(1), y(1) integer jcoef(2) ! n = nn do i = 1,n y(i) = coef(i,1)*x(i) end do if (maxnz <= 1) return maxm1 = maxnz - 1 call vadddt (ndim,1,n,n,maxm1,coef(1,2),jcoef(2),y,x,0) return end subroutine mul3nt (mm,np,a,ia,ja,wksp,x,y) ! !*****************************************************************************80 ! !! MUL3NT computes y = (A**t)*x, a matrix-vector product. ! ! ! the diagonal is assumed to be in the first partition. ! (nonsymmetric sparse storage format) ! ! Parameters: ! ! m number of partitions ! np integer vector of length m+1 giving partition ! pointers ! a real vector giving matrix coefficients ! ia integer vector giving i values ! ja integer vector giving j values ! wksp workspace vector of length 2*n (keygs = 1 only) ! x multiplying vector of length n ! y product vector of length n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension a(1), x(1), y(1), wksp(1) integer np(2), ia(1), ja(1) ! m = mm ied = np(2) - 1 do i = 1,ied y(i) = a(i)*x(i) end do mm1 = m - 1 call vadds (mm1,np(2),ja,ia,a,y,x,wksp) return end subroutine muldc (ndim,nn,coef,ncolor,nc,maxnew,jcnew,x,y) ! !*****************************************************************************80 ! !! MULDC computes y = A*x for a matrix permuted to an ncolor x ncolor block matrix.. ! ! ! The matrix is stored in diagonal format. ! ! Parameters: ! ! ndim row dimension of coef array ! n order of system ! coef real array of coefficients ! ncolor number of colors in the permutation (= ncol) ! nc integer vector of length ncolor giving the ! number of nodes for each color ! maxnew integer vector giving the number of diagonals ! created for each color ! jcnew integer array of size ncolor*max(maxnew(i)) ! giving the diagonal numbers for each color ! x vector of length n to be multiplied by ! y vector of length n to contain result vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer nc(1), maxnew(1), jcnew(ncolor,2) dimension coef(ndim,2), x(1), y(1) ! n = nn do i =1,n y(i) = coef(i,1)*x(i) end do i1 = 1 joff = 0 do k = 1,ncolor ncc = nc(k) jlim = maxnew(k) - 1 call vaddd (ndim,ncolor,ncc,n,jlim,coef(i1,2),jcnew(k,2), y(i1),x,joff) i1 = i1 + ncc joff = joff - ncc end do return end subroutine muldct (ndim,nn,coef,ncolor,nc,maxnew,jcnew,x,y) ! !*****************************************************************************80 ! !! MULDCT computes y = (A**t)*x for a matrix permuted to an ncolor x ncolor block matrix. ! ! ! The matrix is stored in diagonal format. ! ! Parameters: ! ! ndim row dimension of coef array ! n order of system ! coef real array of coefficients ! ncolor number of colors in the permutation (= ncol) ! nc integer vector of length ncolor giving the ! number of nodes for each color ! maxnew integer vector giving the number of diagonals ! created for each color ! jcnew integer array of size ncolor*max(maxnew(i)) ! giving the diagonal numbers for each color ! x vector of length n to be multiplied by ! y vector of length n to contain result vector ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer nc(1), maxnew(1), jcnew(ncolor,2) dimension coef(ndim,2), x(1), y(1) ! n = nn do i =1,n y(i) = coef(i,1)*x(i) end do i1 = 1 joff = 0 do k = 1,ncolor ncc = nc(k) jlim = maxnew(k) - 1 call vadddt (ndim,ncolor,ncc,n,jlim,coef(i1,2),jcnew(k,2),y,x(i1),joff) i1 = i1 + ncc joff = joff - ncc end do return end subroutine mult1 (ndim,maxnz,coef,jcoef,wksp,nn,x,y) ! !*****************************************************************************80 ! !! MULT1 computes y = A*x, a matrix-vector product. ! ! ! the diagonal is assumed to be in column one. ! (Purdue storage format) ! ! Parameters: ! ! ndim row dimension of coef in defining routine ! maxnz number of columns in coef ! coef array of matrix nonzeros ! jcoef array of matrix column numbers ! wksp workspace array of length n ! n order of matrix (= nn) ! x multiplying vector of length n ! y product vector of length n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension coef(ndim,2), x(1), y(1), wksp(1) integer jcoef(ndim,2) ! n = nn maxm1 = maxnz - 1 y(1:n) = coef(1:n,1)*x(1:n) 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) ! !*****************************************************************************80 ! !! MULT2N computes y = A*x, a matrix-vector product. ! ! ! the diagonal is assumed to be in column one. all diagonals of ! the matrix must be stored. ! (nonsymmetric diagonal storage format) ! ! Parameters: ! ! ndim row dimension of coef in defining routine ! maxnz number of columns in coef ! coef array of matrix diagonals ! jcoef array of matrix diagonal numbers ! n dimension of matrix (= nn) ! x multiplying vector of length n ! y product vector of length n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension coef(ndim,2), x(1), y(1) integer jcoef(2) ! n = nn do i = 1,n y(i) = coef(i,1)*x(i) end do if (maxnz <= 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) ! !*****************************************************************************80 ! !! MULT2S computes y = A*x, a matrix-vector product. ! ! ! the diagonal is assumed to be in column 1. only the upper ! diagonals and the main diagonal are assumed stored. ! (symmetric diagonal storage format) ! ! Parameters: ! ! ndim row dimension of coef in defining routine ! maxnz number of columns in coef ! coef array of matrix diagonals ! jcoef array of matrix diagonal numbers ! n dimension of matrix (= nn) ! x multiplying vector of length n ! y product vector of length n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension coef(ndim,1), x(1), y(1) integer jcoef(2) ! n = nn do i = 1,n y(i) = coef(i,1)*x(i) end do do j = 2, maxnz ind = jcoef(j) len = n - ind do i = 1,len y(i) = y(i) + coef(i,j)*x(i+ind) end do do i = 1,len y(i+ind) = y(i+ind) + coef(i,j)*x(i) end do end do return end subroutine mult3 ( mm, np, a, ia, ja, wksp, x, y ) ! !*****************************************************************************80 ! !! MULT3 computes y = A*x, a matrix-vector product. ! ! ! the diagonal is assumed to be in the first partition. ! (symmetric sparse storage format) ! ! Parameters: ! ! m number of partitions ! np integer vector of length m+1 giving partition ! pointers ! a real vector giving matrix coefficients ! ia integer vector giving i values ! ja integer vector giving j values ! wksp workspace vector of length 2*n (keygs = 1 only) ! x multiplying vector of length n ! y product vector of length n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension a(1), x(1), y(1), wksp(1) integer np(2), ia(1), ja(1) ! m = mm ied = np(2) - 1 do i = 1, ied y(i) = a(i)*x(i) end do 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) ! !*****************************************************************************80 ! !! MULT3N computes y = A*x, a matrix-vector product. ! ! ! the diagonal is assumed to be in the first partition. ! (nonsymmetric sparse storage format) ! ! Parameters: ! ! m number of partitions ! np integer vector of length m+1 giving partition ! pointers ! a real vector giving matrix coefficients ! ia integer vector giving i values ! ja integer vector giving j values ! wksp workspace vector of length 2*n (keygs = 1 only) ! x multiplying vector of length n ! y product vector of length n ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension a(1), x(1), y(1), wksp(1) integer np(2), ia(1), ja(1) ! m = mm ied = np(2) - 1 do i = 1,ied y(i) = a(i) * x(i) end do mm1 = m - 1 call vadds (mm1,np(2),ia,ja,a,y,x,wksp) return end subroutine needw ( subnam, isw, istart, length, ier ) ! !*****************************************************************************80 ! !! NEEDW determines if enough integer or real workspace is available. ! ! ! Parameters: ! ! subnam name of calling routine ! isw switch for real or integer workspace check ! = 0 real ! = 1 integer ! istart starting address ! length length desired ! ier error indicator (output) ! = -2 insufficient real workspace ! = -3 insufficient integer workspace ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! character ( len = * ) subnam common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! newlen = istart + length - 1 if ( isw /= 1 ) then if ( lenr < newlen ) then write ( *, * ) ' ' write ( *, * ) 'NEEDW - Insufficient real workspace.' write ( *, * ) ' The increase needed is ', newlen - lenr ier = -2 call ershow ( ier, subnam ) end if irmax = max ( irmax, newlen ) else if ( leni < newlen ) then write ( *, * ) ' ' write ( *, * ) 'NEEDW - Insufficient integer workspace.' write ( *, * ) ' Increase needed is ', newlen - leni ier = -3 call ershow ( ier, subnam ) end if iimax = max ( iimax, newlen ) end if return end subroutine neu1 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! NEU1 drives the Neumann polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom4 / srelpr, keygs, keyzer ! n = nn call needw ('neu1',0,irpnt,n,ier) if (ier < 0) return iwkpt2 = irpnt irpnt = irpnt + n iwkpt1 = irpnt if (keygs == 1) irpnt = irpnt + n call split (accel,suba8,suba9,subq94,subq95,subq94,subq95,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n if (keygs == 1) irpnt = irpnt - n return end subroutine neu2 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! NEU2 drives the Neumann polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 ! n = nn call needw ('neu2',0,irpnt,n,ier) if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba1,suba1,subq19,subq19,subq19,subq19,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine neu3 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! NEU3 drives the Neumann polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 ! n = nn call needw ('neu3',0,irpnt,n,ier) if (ier < 0) return iwkpt1 = irpnt irpnt = irpnt + n call split (accel,suba4,suba5,subq56,subq57,subq56,subq57,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n return end subroutine neu4 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! NEU4 drives the Neumann polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom4 / srelpr, keygs, keyzer ! n = nn call needw ('neu4',0,irpnt,n,ier) if (ier < 0) return iwkpt2 = irpnt irpnt = irpnt + n iwkpt1 = irpnt if (keygs == 1) irpnt = irpnt + 2*n call split (accel,suba12,suba12,sub111,sub111,sub111,sub111,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n if (keygs == 1) irpnt = irpnt - 2*n return end subroutine neu5 (accel,coef,jcoef,nn,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! NEU5 drives the Neumann polynomial preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! 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) ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / point / iptscl, iwkpt1, iwkpt2, iwkpt3 common / itcom4 / srelpr, keygs, keyzer ! n = nn call needw ('neu5',0,irpnt,n,ier) if (ier < 0) return iwkpt2 = irpnt irpnt = irpnt + n iwkpt1 = irpnt if (keygs == 1) irpnt = irpnt + 2*n call split (accel,suba13,suba14,sub114,sub115,sub114,sub115,copy,copy,noadp, & coef,jcoef,n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) irpnt = irpnt - n if (keygs == 1) irpnt = irpnt - 2*n return end subroutine nmcalc (coef,jcoef,wfac,jwfac,icall,subq,nn,rhs,ubar,wksp,ier) ! !*****************************************************************************80 ! !! NMCALC calculates the quantities ! ! bnorm = sqrt (rhs,rhs) ! bnorm1 = any other norm of rhs needed for the stopping test ! ubarnm = sqrt (ubar,ubar) ! ! which are needed in the stopping tests. ! ! the stopping tests are -- ! ! (1) (emax/emin) * sqrt ( (r ,zt)/(rhs,inv(q)*rhs) ) ! (2) ( 1.0/emin) * sqrt ( (zt,zt)/(u,u) ) ! (3) (emax/emin) * sqrt ( (zt,zt)/(inv(q)*rhs,inv(q)*rhs) ) ! (4) sqrt ( (zt,zt)/(inv(q)*rhs,inv(q)*rhs) ) ! (5) sqrt ( (r ,r )/(rhs,rhs) ) ! (6) sqrt ( (u-ubar,u-ubar)/(ubar,ubar) ) ! (7) (emax/emin) * sqrt ( (r,z)/(rhs,inv(ql)*rhs) ) ! (8) ( 1.0/emin) * sqrt ( (z,z)/(u,u) ) ! (9) (emax/emin) * sqrt ( (z,z)/(inv(ql)*rhs,inv(ql)*rhs) ) ! (10) sqrt ( (z,z)/(inv(ql)*rhs,inv(ql)*rhs) ) ! ! Parameters: ! ! icall key for initial or secondary call ! = 1 initial call ! = 2 later call (needed if q is changed) ! subq preconditioning routine ! n order of system ! rhs right hand side ! ubar known solution ! wksp workspace vector of length n ! ier error code ! = 0 no error detected ! = -7 q is not positive definite ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension rhs(1), ubar(1), wksp(1), coef(1), jcoef(2), wfac(1), jwfac(1) external subq ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, iplr, iqlr, ntest, & is, iacel, idgts, nbl1d, nbl2d common / itcom3 / alpha, beta, zeta, emax, emin, pap, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer n = nn nteste = ntest if (ntest > 6) nteste = ntest - 6 go to (10,50,20,20,30,40), nteste ! ! bnorm1: sqrt(b,q(inv)b). ! 10 call subq (coef,jcoef,wfac,jwfac,n,rhs,wksp) sum = vdot (n,rhs,wksp) if (sum >= 0.0D+00) go to 15 ier = -7 call ershow (ier,'nmcalc') return 15 bnorm1 = max ( sqrt(sum), srelpr ) return ! ! bnorm1: sqrt(q(inv)b,q(inv)b). ! 20 call subq (coef,jcoef,wfac,jwfac,n,rhs,wksp) sum = vdot ( n, wksp, wksp ) bnorm1 = max ( sqrt(sum),srelpr ) return ! ! bnorm. ! 30 if (icall == 2) return sum = vdot (n,rhs,rhs) bnorm = max ( sqrt(sum),srelpr ) bnorm1 = bnorm return ! ! ubarnm. ! 40 continue if (icall == 2) return sum = vdot (n,ubar,ubar) ubarnm = max ( sqrt(sum), srelpr ) return ! ! exit. ! 50 return end subroutine noadp ( coef, jcoef, wksp, iwksp, n, p, r, pdp, pldup ) ! !*****************************************************************************80 ! !! NOADP is a dummy routine to do no adaption. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer iwksp(1) integer jcoef(2) dimension p(1), r(1), coef(1), wksp(1) ! return end subroutine nspcg ( precon, accel, ndimm, mdimm, nn, maxnzz, coef, jcoef, & p, ip, u, ubar, rhs, wksp, iwksp, nw, inw, iparm, rparm, ier ) ! !*****************************************************************************80 ! !! NSPCG is the driver for the NSPCG package. ! ! ! Modified: ! ! 11 June 2004 ! ! Parameters: ! ! Input, external PRECON, the preconditioning module. ! ! Input, external ACCEL, the acceleration module. ! ! Input, integer NDIMM, ? ! ! Input, integer MDIMM, ? ! ! Input, integer NN, the order of the system. ! ! Input/output, integer MAXNZZ, ? ! ! Input, real COEF(*), the matrix data array. ! ! Input, integer JCOEF(*), the matrix data array. ! ! Workspace, integer P(NN), IP(NN), pivot and inverse pivot information. ! For certain solvers, these vectors may not be necessary. ! ! Input/output, real U(NN). ! On input, U contains the initial guess to the solution. ! On output, it contains the latest estimate to the solution. ! ! Input, real UBAR(NN), an optional input quantity containing ! the true solution. ! ! Input, real RHS(NN), the right hand side of the matrix problem. ! ! Workspace, real WKSP(NW). ! ! Workspace, integer IWKSP(INW). ! ! Input, integer NW, the length of WKSP. ! ! Input, integer INW, the length of IWKSP. ! ! Input/output, integer IPARM(30), allows the user to ! specify some integer parameters which affect the method. ! ! Input/output, real RPARM(30), allows the user to ! specify some real parameters which affect the method. ! ! Output, integer IER, the error flag. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! integer inw integer nn integer nw ! real ( kind = 8 ) coef(*) integer ier integer ip(nn) integer iparm(30) integer iwksp(inw) integer jcoef(2) integer ndim integer p(nn) real ( kind = 8 ) rhs(nn) real ( kind = 8 ) rparm(30) real ( kind = 8 ) u(nn) real ( kind = 8 ) ubar(nn) real ( kind = 8 ) wksp(nw) ! external accel external precon ! common / itcom6 / method, iscale, iperm, nstore, ifact, kblsz, lvfill, & ltrunc, ndeg, ipropa, isymm, ifctv ! ! data common blocks ! common / dscons / ndim, mdim, maxnz common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax common / cfactr / nfactr, nfacti, ifactr, ifacti, timfac ! 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 < 0 ) then return end if timfac = 0.0D+00 call pointr ( 1, wksp, iwksp, ier ) ! ! Call preparatory routines. ! ! Remove zeros from jcoef for Purdue data structure. ! if ( nstore == 1 ) then call adjust ( n, ndim, maxnz, jcoef, 1 ) end if call prep ( coef, jcoef, wksp(irpnt), iwksp(iipnt), n, nstore, ier ) if ( ier < 0 ) then call ershow ( ier, 'nspcg' ) go to 20 end if ! ! Eliminate penalty-method Dirichlet points, if requested. ! ielim = iparm(24) tol = rparm(15) if ( ielim == 1 ) then call elim ( n, jcoef, coef, rhs, wksp, iwksp, tol ) end if ! ! Determine the symmetry of matrix. ! if ( nstore == 1 .and. isymm == 2 ) then call detsym ( ndim, maxnz, coef, jcoef, n, isymm ) end if ! ! Scale the matrix. ! call scale ( coef, jcoef, wksp, 1, n, u, ubar, rhs, ier ) if ( 0 <= ier ) then ! ! Permute the matrix. ! call permut ( coef, jcoef, p, ip, wksp, iwksp, 1, n, u, & ubar, rhs, ier ) if ( ier >= 0 ) then ! ! Call the iterative routine. ! call precon ( accel, coef, jcoef, n, u, ubar, rhs, wksp, iwksp, & iparm, rparm, ier ) ! ! Unpermute the matrix. ! call permut ( coef, jcoef, p, ip, wksp, iwksp, 2, n, u, ubar, & rhs, ier ) end if ! ! Unscale the matrix. ! call scale ( coef, jcoef, wksp, 2, n, u, ubar, rhs, ier ) end if ! ! Restore zeros to JCOEF for the Purdue data structure. ! 20 continue if ( nstore == 1 ) then call adjust ( n, ndim, maxnz, jcoef, 2 ) end if 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 ) call pointr ( 2, wksp, iwksp, ier ) ! ! It is a sin against convention to use NW and INW in this way! ! JVB 13 September 2000 ! ! nw = irmax ! inw = iimax ! maxnzz = maxnz return end subroutine nullpl (coef,jcoef,wk,iwk,n,subql,suba,subqr,u,v) ! !*****************************************************************************80 ! !! NULLPL applies the left preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), v(1), coef(1), jcoef(2), wk(1), iwk(1) external subql, suba, subqr ! call subql (coef,jcoef,wk,iwk,n,u,v) return end subroutine nullpr (coef,jcoef,wk,iwk,n,subql,suba,subqr,u,v) ! !*****************************************************************************80 ! !! NULLPR applies the right preconditioner. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), v(1), coef(1), jcoef(2), wk(1), iwk(1) external subql, suba, subqr ! call subqr (coef,jcoef,wk,iwk,n,u,v) return end subroutine odir (suba,subat,subql,subqlt,subqr,subqrt,subadp,coef,jcoef, & n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! ODIR is the user interface to the ORTHODIR algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! nw = lenr - irpnt + 1 call odirw (suba,subql,subqr,coef,jcoef,wksp,iwksp,n,u,ubar,rhs, & wksp(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine odirw (suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & wk,nw,iparm,rparm,ier) ! !*****************************************************************************80 ! !! ODIRW implements ORTHODIR. ! ! ! The algorithm includes truncation, restarting and 2-sided preconditioning. ! the effective value of the z matrix is (inv(ql)*a*inv(qr))**t. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), wfac(1), jwfac(1) logical iql, iqr external suba, subql, subqr dimension iparm(30), rparm(30) ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! ! ! the following indexing functions are used to access the old ! direction vectors and dot products -- ! indpt(i) = ipt + mod(i,nv)*n indqap(i) = iqapt + mod(i,nv)*n inddot(i) = idot + mod(i,nv) ! ! various preliminary calculations. ! ! nwusd = 0 ier = 0 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 997 write (nout,496) 496 format (' orthodir') iacel = 7 iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 ! ! initialize the stopping test. ! call inithv (0) zhave = .true. zthave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 997 ! ! memory allocation, etc. ! 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 ! if (iql) nwusd = max(nwusd,iv2-1+n) if (.not. iql) nwusd = max(nwusd,iv1-1+n) ! ! check the memory usage -- ! if (nwusd > nw) go to 999 ! in = 0 is = 0 ! ! perform first-iterate calculations ! 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)) ! if (.not. iqr) zdot = vdot (n,wk(iz),wk(iz)) ! ! Begin iteration loop. ! ! ! determine whether or not to stop. ! 10 call inithv (1) nwpstp = nw - (iv1-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,wk(iz),wk(izt),wk(iv1),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv1-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! ! proceed to calculate the direction vectors. ! ! first, case of no old p vectors. ! np = min(mod(in,ns2),ns1) if (np /= 0) go to 100 ! if (is == 0) call vcopy (n,wk(izt),wk(indpt(in))) if (is /= 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 ! ! case of at least one old p vector. ! this case is handled in a tricky way, to optimize the workspace. ! 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)) ! 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 > 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 ! ! periodically scale the direction vector, to prevent overflow. ! 120 continue dot = vdot (n,wk(indqap(in)),wk(indqap(in))) if (dot(1.0D+00/srelpr**2)) then call vtriad (n,wk(indpt(in)), xxx,1.0D+00/dot,wk(indpt(in)), 2) call vtriad (n,wk(indqap(in)),xxx,1.0D+00/dot,wk(indqap(in)),2) dot = 1.0D+00 end if ! ! at this point, we are finished forming the latest direction vector. ! we proceed to calculate lambda and update the solution and ! the residuals. ! 129 continue ! if (abs(dot) < srelpr) go to 998 wk(inddot(in)) = dot top = vdot (n,wk(indqap(in)),wk(iz)) vlamda = top / dot ! the following commented-out line is unstable. but it can be fixed. ! if (.not. iqr) zdot = zdot - 2*vlamda*top + vlamda**2*dot ! ! u -- ! call vtriad (n,u,u,vlamda,wk(indpt(in)),1) ! ! z -- ! call vtriad (n,wk(iz),wk(iz),-vlamda,wk(indqap(in)),1) ! ! zt -- ! 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) ! ! proceed to next iteration ! in = in + 1 is = is + 1 if (is == ns2) is = 0 go to 10 ! ! Finish up. ! 900 if (.not. halt) go to 996 if (level >= 1) write (nout,720) in 720 format (/' orthodir converged in ',i5,' iterations.') ! 725 continue if (idgts >= 0) then call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1,digit2,idgts) end if ! ! 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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! ! error returns ! ! no convergence. 996 ier = 1 call ershow (ier,'odirw') zeta = stptst go to 725 ! ! generic error handler. 997 call ershow (ier,'odirw') go to 735 ! ! breakdown. 998 ier = -15 call ershow (ier,'odirw') go to 725 ! ! insufficient real wksp. 999 ier = -2 call ershow (ier,'odirw') go to 735 end subroutine omgchg (ssorcp,coef,jcoef,wfac,jwfac,n,p,r) ! !*****************************************************************************80 ! !! OMGCHG changes ALPHAB and BETAB for a new estimate of OMEGA. ! ! ! Parameters: ! ! n order of system (= nn) ! p vector from acceleration algorithm ! r workspace vector from acceleration algorithm ! ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension p(1), r(1), coef(1), jcoef(2), wfac(1), jwfac(1) external ssorcp ! ! ! common / itcom3 / alpha, beta, zeta, emax, emin, pap, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 logical omgadp common / itcom5 / omgadp common / itcom55 / omega, alphab, betab, fff, specr ! ! ! ! ! update alphab and betab. ! call ssorcp (coef,jcoef,wfac,jwfac,n,p,r,pdp,pldup) alphab = min (alphab, (pap/pdp) - 1.0D+00) betab = max (betab , pldup/pdp) return end subroutine omin (suba,subat,subql,subqlt,subqr,subqrt,subadp,coef,jcoef, & n,u,ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! OMIN is the user interface to the truncated/restarted ORTHOMIN algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! nw = lenr - irpnt + 1 call ominw (suba,subql,subqr,coef,jcoef,wksp,iwksp,n,u,ubar,rhs, & wksp(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine omingw (suba,subql,subqr,precl,precr,coef,jcoef,wfac,jwfac,n, & u,ubar,rhs,wk,nw,iparm,rparm,ier) ! !*****************************************************************************80 ! !! OMINGW is a generalized version of the OMINW routine. ! ! It allows a more general computational form for the preconditioning. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), wfac(1), jwfac(1) logical ipl, ipr external suba, subql, subqr, precl, precr dimension iparm(30), rparm(30) logical ztget, havest, hadest, evest ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! ! ! the following indexing functions are used to access the old ! direction vectors and dot products -- ! 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) ! ! various preliminary calculations. ! t1 = timer (dummy) ! ipl = iplr == 1 .or. iplr == 3 ipr = iplr == 2 .or. iplr == 3 ! iacel = 8 nwusd = 0 if (level >= 1) write (nout,497) 497 format (' omin') ! ! initialize the stopping test. ! call inithv (0) zhave = .true. zthave = .true. nwpstp = nw call pstopg (0,suba,subql,subqr,precl,precr,coef,jcoef,wfac,jwfac,n,u, & ubar,rhs,xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 997 ztget = ztcalp zthave = ztget ! ! memory allocation, etc. ! numbig = 1000 methev = 1 if (iabs(ns3) >= numbig) then if (ns3 > 0) ns3 = ns3 - numbig if (ns3 < 0) ns3 = ns3 + numbig methev = 2 end if ! evest = ns3/=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 ! nwtmp = iv1 - 1 + n if (ipl) nwtmp = iv2 - 1 + n nwusd = max(nwusd,nwtmp) ! ! check the memory usage -- ! if (nwusd > nw) go to 999 ! in = 0 is = 0 ! ! perform first-iterate calculations ! 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,wk(ir),wk(iz)) hadest = .false. ! ! Begin iteration loop. ! ! determine whether or not to stop. ! 10 if (.not. ztget) go to 710 if (ipr) call precr (coef,jcoef,wfac,jwfac,n,subql,suba,subqr,wk(iz),wk(izt)) 710 call inithv (1) nwpstp = nw - (iv1-1) call pstopg (1,suba,subql,subqr,precl,precr,coef,jcoef,wfac,jwfac,n,u, & ubar,rhs,xxx,wk(iz),wk(izt),wk(iv1),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv1-1) if (level >= 2) call iterm (n,u) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! if (zthave) go to 711 if (ipr) call precr (coef,jcoef,wfac,jwfac,n,subql,suba,subqr,wk(iz),wk(izt)) ! ! Proceed to calculate the direction vectors. ! ! first, case of no old p vectors. ! 711 np = min(mod(in,ns2),ns1) if (np /= 0) go to 100 ! 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,wk(iv1),wk(indqap(in))) end if go to 120 ! ! case of at least one old p vector. ! this case is handled in a tricky way, to optimize the workspace. ! 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,wk(iv2),wk(iv1)) end if 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) 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) ! ! at this point, we are finished forming the latest direction vector. ! we proceed to calculate lambda and update the solution and ! the residuals. ! 120 continue apap = vdot (n,wk(indqap(in)),wk(indqap(in))) ! if (abs(apap) < srelpr**2) go to 998 if (abs(apap) == 0.0D+00) go to 998 wk(inddot(in)) = apap top = vdot (n,wk(indqap(in)),wk(iz)) vlamda = top / apap ! if (.not. ipr) zzdot = zzdot - 2*vlamda*top + vlamda**2*apap ! ! u -- call vtriad (n,u,u,vlamda,wk(indpt(in)),1) ! ! z -- call vtriad (n,wk(iz),wk(iz),-vlamda,wk(indqap(in)),1) ! ! Hess matrix update. ! ! there are two schemes here, based on two different ways of projecting ! the iteration matrix. ! ! update Hessenberg matrix: scheme 1 ! if (.not. evest) go to 955 wk(indlam(in)) = vlamda if (is == 0) call vfill ( nhess*(nv+2), wk(ihess), 0.0D+00 ) if (methev /= 1) go to 746 ! do 954 i=in-np,in if (i == in) apar = apap if (i /= in) apar = wk(inapar(i)) wk(indhes(i+1+(is-in),in-i+2)) = wk(indhes(i+1+(is-in),in-i+2)) & + apar/wk(indlam(in)) / sqrt(wk(inddot(in))*wk(inddot(i))) if (is /= 0) & wk(indhes(i+1+(is-in),in-i+1)) = wk(indhes(i+1+(is-in),in-i+1)) & - apar/wk(indlam(in-1)) / sqrt(wk(inddot(in-1))*wk(inddot(i))) 954 continue iesize = is go to 747 ! ! update Hessenberg matrix: scheme 2 ! 746 iesize = is + 1 wk(indhes(is+2,1)) = -1.0D+00 / vlamda wk(indhes(is+1,2)) = 1.0D+00 / vlamda if (np == 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 )) & - wk(inapar(i))/wk(inddot(i))/wk(indlam(i)) 748 wk(indhes(is+2-id,id+1)) = wk(indhes(is+2-id,id+1)) & + wk(inapar(i))/wk(inddot(i))/wk(indlam(i)) 749 continue ! ! estimate eigenvalues. ! 747 nwhe = nw - (iv1-1) call hesest (wk(ihess),nhess,nv+2,iesize,ns3,havest,emaxnw,eminnw, & wk(iv1),nwhe,ier) nwusd = max (nwusd,iv1-1+nwhe) if (ier /= 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) ! ! Proceed to next iteration. ! 955 in = in + 1 is = is + 1 if (is == ns2) is = 0 go to 10 ! ! Finish up. ! 900 if (.not. halt) go to 996 if (level >= 1) write (nout,720) in 720 format (/' orthomin converged in ',i5,' iterations.') ! 725 if (idgts >= 0) then call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,digit1,digit2,idgts) end if ! ! 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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! Error returns. ! ! unimplemented option. 995 ier = -16 call ershow (ier,'omingw') go to 725 ! ! no convergence. 996 ier = 1 call ershow (ier,'omingw') zeta = stptst go to 725 ! ! generic error handler. 997 call ershow (ier,'omingw') go to 735 ! ! breakdown. 998 ier = -15 call ershow (ier,'omingw') go to 725 ! ! insufficient real wksp. 999 ier = -2 call ershow (ier,'omingw') go to 735 end subroutine ominw (suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs,wk, & nw,iparm,rparm,ier) ! !*****************************************************************************80 ! !! OMINW implements the truncated/restarted ORTHOMIN algorithm. ! ! ! eigenvalue estimation is implemented. ! note that this also implements the gcr algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), wfac(1), jwfac(1) external suba, subql, subqr external nullpl, nullpr dimension iparm(30), rparm(30) ! ier = 0 call echall (n,iparm,rparm,1,2,ier) if (ier < 0) return ! ! pass on to workhorse routine. ! call omingw (suba,subql,subqr,nullpl,nullpr,coef,jcoef,wfac,jwfac,n,u, & ubar,rhs,wk,nw,iparm,rparm,ier) return end subroutine ores (suba,subat,subql,subqlt,subqr,subqrt,subadp,coef,jcoef,n,u, & ubar,rhs,wksp,iwksp,iparm,rparm,ier) ! !*****************************************************************************80 ! !! ORES is the user interface to the ORTHORES algorithm. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), coef(1), jcoef(2), wksp(1), iwksp(1) dimension iparm(30), rparm(30) external suba, subql, subqr external subat, subqlt, subqrt external subadp ! ! data common blocks ! common / cwkcon / lenr, irpnt, irmax, leni, iipnt, iimax ! nw = lenr - irpnt + 1 call oresw (suba,subql,subqr,coef,jcoef,wksp,iwksp,n,u,ubar,rhs, & wksp(irpnt),nw,iparm,rparm,ier) irmax = max (irmax,irpnt-1+nw) iimax = max (iimax,iipnt-1) return end subroutine oresw (suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & wk,nw,iparm,rparm,ier) ! !*****************************************************************************80 ! !! ORESW implements ORTHORES. ! ! ! The algorithm includes truncation, restarting and 2-sided preconditioning. ! the value of z is ! the identity. the code is optimal in speed and workspace ! requirements, for general a, ql and qr. ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension u(1), ubar(1), rhs(1), wk(1), coef(1), jcoef(2), wfac(1), jwfac(1) external suba, subql, subqr dimension iparm(30), rparm(30) logical iql, iqr ! ! ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer common / itcom9 / & rdot, rzdot, rztdot, zdot, zztdot, ztdot, & rhave, zhave, zthave, rcalp, zcalp, ztcalp, & udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav logical rhave, zhave, zthave, rcalp, zcalp, ztcalp logical udhav, rdhav, rzhav, rzthav, zdhav, zzthav, ztdhav ! ! ! ! the following indexing functions are used to access the old ! direction vectors and dot products -- ! indu(i) = iu + mod(i,nv)*n indz(i) = iz + mod(i,nv)*n inddot(i) = idot + mod(i,nv) ! ! various preliminary calculations. ! nwusd = 0 ier = 0 iacel = 9 t1 = timer (dummy) call echall (n,iparm,rparm,1,2,ier) if (ier < 0) go to 997 if (level >= 2) write (nout,496) 496 format (' orthores') iql = iqlr == 1 .or. iqlr == 3 iqr = iqlr == 2 .or. iqlr == 3 ! ! initialize the stopping test. ! call inithv (0) zhave = .true. zthave = .true. nwpstp = nw call pstop (0,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,u,ubar,rhs, & xxx,xxx,xxx,wk,nwpstp,ier) nwusd = max(nwusd,nwpstp) if (ier < 0) go to 730 ! ! memory allocation, etc. ! ! nomenclature -- r -- residual of the original system. ! z -- inv(ql)*r ! zt -- inv(qr)*z ! 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) ! ! check the memory usage -- ! if (nwusd > nw) go to 999 ! in = 0 ! ! perform first-iterate calculations. ! note -- we will use the vector 'u' to store ztilde. the u vectors ! will be stored in the table. wk(iv1) will hold r. ! 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))) ! ! Begin iteration loop. ! ! determine whether or not to stop -- ! 10 call inithv (1) nwpstp = nw - (iv2-1) call pstop (1,suba,subql,subqr,coef,jcoef,wfac,jwfac,n,wk(indu(in)), & ubar,rhs,xxx,wk(indz(in)),u,wk(iv2),nwpstp,ier) nwusd = max(nwusd,nwpstp+iv2-1) if (level >= 2) call iterm (n,wk(indu(in))) if (halt .or. in >= itmax .or. ier < 0) go to 900 ! ! proceed to calculate the iterates. ! 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 > iend) go to 613 do 612 i = ibegin,iend top = vdot (n,wk(indz(i)),wk(iv2)) den = wk(inddot(i)) if (abs(den) < 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) < srelpr) go to 998 vlamda = 1.0D+00 / 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))) ! call subqr (coef,jcoef,wfac,jwfac,n,wk(indz(in+1)),u) ! ! proceed to next iteration ! in = in + 1 go to 10 ! ! Finish up. ! 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 >= 1) write (nout,720) in 720 format (/' orthores converged in ',i5,' iterations.') ! 725 continue if (idgts < 0) go to 730 call perror2 (suba,coef,jcoef,wfac,jwfac,n,u,rhs,wk,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 >= 3) call echall (n,iparm,rparm,2,2,ier) nw = nwusd return ! ! error returns ! 997 call ershow (ier,'oresw') go to 735 ! 998 ier = -15 call ershow (ier,'oresw') go to 725 ! 999 ier = -2 call ershow (ier,'oresw') go to 735 ! end subroutine out (nn,v,iswt,noutt) ! !*****************************************************************************80 ! !! OUT prints the residual and solution vectors. ! ! ! Parameters: ! ! v vector of length n ! iswt labelling information ! nout output device number (= noutt) ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! dimension v(nn) ! n = nn nout = noutt if (n <= 0) return ! kupper = min (n, 4) if (iswt == 1) write (nout,10) 10 format (//5x,'residual vector') if (iswt == 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('-') /) ! 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,'+ ',4e15.5) 35 continue ! return end subroutine parsi ! !*****************************************************************************80 ! !! PARSI computes the iteration parameters. ! ! ! implicit real ( kind = 8 ) ( a - h, o - z ) ! common / itcom1 / in, itmax, level, nout, ns1, ns2, ns3, 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, alphao, gamma, & sigma, rr, rho, dkq, dkm1, ff, rqmin, rqmax, stptst, udnm, ubarnm, & bnorm, bnorm1 common / itcom4 / srelpr, keygs, keyzer ! ! ! rhol = rho if (is - 1) 10,15,20 10 rho = 1.0D+00 go to 25 15 rho = 1.0D+00 / (1.0D+00 - sigma*sigma/2.0D+00) go to 25 20 rho = 1.0D+00 / (1.0D+00 - sigma*sigma*rhol/4.0D+00) ! ! compute alpha, beta. ! 25 alpha = rho*gamma beta = rhol*(rho - 1.0D+00) / rho return end subroutine pbneu (suba,dsolve,coef,jcoef,wfac,jwfac,nd,wksp