← Back to branch summary

~ubuntu-branches/debian/sid/arpack/sid

« back to all changes in this revision

Viewing changes to PARPACK/SRC/BLACS/pcnapps.f

  • Committer: Package Import Robot
  • Author(s): Sylvestre Ledru
  • Date: 2012-02-22 11:05:03 UTC
  • mfrom: (1.2.5)
  • Revision ID: package-import@ubuntu.com-20120222110503-h6ux3f5ilm5q76w0
Tags: 3.1.0-1
New upstream release

Show diffs side-by-side

added added

removed removed

Lines of Context:
PARPACK/SRC/BLACS/pcnapps.f
127
127
c     Starting Point: Serial Complex Code FILE: napps.F   SID: 2.1
128
128
c
129
129
c\SCCS Information:
130
 
c FILE: napps.F   SID: 1.3   DATE OF SID: 06/04/98
 
130
c FILE: napps.F   SID: 1.4   DATE OF SID: 10/25/03
131
131
c
132
132
c\Remarks
133
133
c  1. In this version, each shift is applied to all the sublocks of
243
243
c        | REFERENCE: LAPACK subroutine clahqr           |
244
244
c        %-----------------------------------------------%
245
245
c
246
 
         unfl = slamch( 'safe minimum' )
 
246
         unfl = pslamch( 'safe minimum' )
247
247
         ovfl = real(one / unfl)
248
248
         call slabad( unfl, ovfl )
249
249
         ulp = slamch( 'precision' )
283
283
      do 110 jj = 1, np
284
284
         sigma = shift(jj)
285
285
c
 
286
         if (msglvl .gt. 2 ) then
 
287
            call pivout (comm, logfil, 1, jj, ndigit, 
 
288
     &               '_napps: shift number.')
 
289
            call pcvout (comm, logfil, 1, sigma, ndigit, 
 
290
     &               '_napps: Value of the shift ')
 
291
         end if
 
292
c
286
293
         istart = 1
287
294
   20    continue
288
295
c
299
306
     &         tst1 = clanhs( '1', kplusp-jj+1, h, ldh, workl )
300
307
            if ( abs(real(h(i+1,i))) 
301
308
     &           .le. max(ulp*tst1, smlnum) )  then
 
309
               if (msglvl .gt. 0) then
 
310
                  call pivout (comm, logfil, 1, i, ndigit, 
 
311
     &                 '_napps: matrix splitting at row/column no.')
 
312
                  call pivout (comm, logfil, 1, jj, ndigit, 
 
313
     &                 '_napps: matrix splitting with shift number.')
 
314
                  call pcvout (comm, logfil, 1, h(i+1,i), ndigit, 
 
315
     &                 '_napps: off diagonal element.')
 
316
               end if
302
317
               iend = i
303
318
               h(i+1,i) = zero
304
319
               go to 40
307
322
         iend = kplusp
308
323
   40    continue
309
324
c
 
325
         if (msglvl .gt. 2) then
 
326
             call pivout (comm, logfil, 1, istart, ndigit, 
 
327
     &                   '_napps: Start of current block ')
 
328
             call pivout (comm, logfil, 1, iend, ndigit, 
 
329
     &                   '_napps: End of current block ')
 
330
         end if
310
331
c
311
332
c        %------------------------------------------------%
312
333
c        | No reason to apply a shift to block of order 1 |
475
496
      if ( real( h(kev+1,kev) ) .gt. rzero )
476
497
     &   call caxpy (n, h(kev+1,kev), v(1,kev+1), 1, resid, 1)
477
498
c
 
499
      if (msglvl .gt. 1) then
 
500
         call pcvout (comm, logfil, 1, q(kplusp,kev), ndigit,
 
501
     &        '_napps: sigmak = (e_{kev+p}^T*Q)*e_{kev}')
 
502
         call pcvout (comm, logfil, 1, h(kev+1,kev), ndigit,
 
503
     &        '_napps: betak = e_{kev+1}^T*H*e_{kev}')
 
504
         call pivout (comm, logfil, 1, kev, ndigit, 
 
505
     &               '_napps: Order of the final Hessenberg matrix ')
 
506
         if (msglvl .gt. 2) then
 
507
            call pcmout (comm, logfil, kev, kev, h, ldh, ndigit,
 
508
     &      '_napps: updated Hessenberg matrix H for next iteration')
 
509
         end if
 
510
c
 
511
      end if
 
512
c
478
513
 9000 continue
479
514
      call second (t1)
480
515
      tcapps = tcapps + (t1 - t0)