The R Project SVN R

Rev

Rev 7184 | Rev 75248 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 7184 Rev 12256
Line 87... Line 87...
87 
c
 87 
c
88 
c     linpack. this version dated 08/14/78 .
 88 
c     linpack. this version dated 08/14/78 .
89 
c              correction made to shift 2/84.
 89 
c              correction made to shift 2/84.
90 
c     g.w. stewart, university of maryland, argonne national lab.
 90 
c     g.w. stewart, university of maryland, argonne national lab.
91 
c
 91 
c
- 
 
 92 
c     Modified 2000-12-28 to use a relative convergence test,
- 
 
 93 
c     as this was infinite-looping on ix86.
- 
 
 94 
c
92 
c     dsvdc uses the following functions and subprograms.
 95 
c     dsvdc uses the following functions and subprograms.
93 
c
 96 
c
94 
c     external drot
 97 
c     external drot
95 
c     blas daxpy,ddot,dscal,dswap,dnrm2,drotg
 98 
c     blas daxpy,ddot,dscal,dswap,dnrm2,drotg
96 
c     fortran dabs,dmax1,max0,min0,mod,dsqrt
 99 
c     fortran dabs,dmax1,max0,min0,mod,dsqrt
Line 103... Line 106...
103 
c
 106 
c
104 
      integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit,
 107 
      integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit,
105 
     *        mm,mm1,mp1,nct,nctp1,ncu,nrt,nrtp1
 108 
     *        mm,mm1,mp1,nct,nctp1,ncu,nrt,nrtp1
106 
      double precision ddot,t
 109 
      double precision ddot,t
107 
      double precision b,c,cs,el,emm1,f,g,dnrm2,scale,shift,sl,sm,sn,
 110 
      double precision b,c,cs,el,emm1,f,g,dnrm2,scale,shift,sl,sm,sn,
108 
     *                 smm1,t1,test,ztest
 111 
     *                 smm1,t1,test,ztest,acc
109 
      logical wantu,wantv
 112 
      logical wantu,wantv
110 
c
 113 
c
111 
c     unnecessary initializations of l and ls to keep g77 -Wall happy
 114 
c     unnecessary initializations of l and ls to keep g77 -Wall happy
112 
c
 115 
c
113 
      l = 0
 116 
      l = 0
Line 321... Line 324...
321 
            l = m - ll
 324 
            l = m - ll
322 
c        ...exit
 325 
c        ...exit
323 
            if (l .eq. 0) go to 400
 326 
            if (l .eq. 0) go to 400
324 
            test = dabs(s(l)) + dabs(s(l+1))
 327 
            test = dabs(s(l)) + dabs(s(l+1))
325 
            ztest = test + dabs(e(l))
 328 
            ztest = test + dabs(e(l))
- 
 
 329 
            acc = dabs(test - ztest)/(1.0d-100 + test)
- 
 
 330 
            if (acc .gt. 1.d-15) goto 380
326 
            if (ztest .ne. test) go to 380
 331 
c            if (ztest .ne. test) go to 380
327 
               e(l) = 0.0d0
 332 
               e(l) = 0.0d0
328 
c        ......exit
 333 
c        ......exit
329 
               go to 400
 334 
               go to 400
330 
  380       continue
 335 
  380       continue
331 
  390    continue
 336 
  390    continue
Line 342... Line 347...
342 
               if (ls .eq. l) go to 440
 347 
               if (ls .eq. l) go to 440
343 
               test = 0.0d0
 348 
               test = 0.0d0
344 
               if (ls .ne. m) test = test + dabs(e(ls))
 349 
               if (ls .ne. m) test = test + dabs(e(ls))
345 
               if (ls .ne. l + 1) test = test + dabs(e(ls-1))
 350 
               if (ls .ne. l + 1) test = test + dabs(e(ls-1))
346 
               ztest = test + dabs(s(ls))
 351 
               ztest = test + dabs(s(ls))
- 
 
 352 
c 1.0d-100 is to guard against a zero matrix, hence zero test
- 
 
 353 
               acc = dabs(test - ztest)/(1.0d-100 + test)
- 
 
 354 
               if (acc .gt. 1.d-15) goto 420
347 
               if (ztest .ne. test) go to 420
 355 
c               if (ztest .ne. test) go to 420
348 
                  s(ls) = 0.0d0
 356 
                  s(ls) = 0.0d0
349 
c           ......exit
 357 
c           ......exit
350 
                  go to 440
 358 
                  go to 440
351 
  420          continue
 359 
  420          continue
352 
  430       continue
 360 
  430       continue