scilab/modules/output_stream/src/fortran/dspdsp.f

   1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
   2 c Copyright (C) INRIA
   3 c
   4 c This file must be used under the terms of the CeCILL.
   5 c This source file is licensed as described in the file COPYING, which
   6 c you should have received as part of this distribution.  The terms
   7 c are also available at
   8 c http://www.cecill.info/licences/Licence_CeCILL_V2-en.txt
   9       subroutine dspdsp(ne,ind,x,m,n,maxc,mode,ll,lunit,cw)
  10 c!but
  11 c     dspdsp visualise une matrice  creuse
  12 c!liste d'appel
  13 c
  14 c     subroutine dspdsp(ne,ind,x,m,n,maxc,mode,ll,lunit,cw)
  15 c
  16 c     double precision x(*)
  17 c     integer ind(*)
  18 c     integer nx,m,n,maxc,mode,ll,lunit
  19 c     character cw*(*)
  20 c
  21 c     c : nombre d'elements nons nuls de la matrice
  22 c     ind : indices specifiant la position des elements non nuls
  23 c     x : tableau contenant les elements non nuls
  24 c     m : nombre de ligne de la matrice
  25 c     n : nombre de colonnes de la matrice
  26 c     maxc : nombre de caracteres maximum autorise pour
  27 c            representer un nombre
  28 c     mode : si mode=1 representation variable
  29 c            si mode=0 representation d(maxc).(maxc-7)
  30 c     ll : longueur de ligne maximum admissible
  31 c     lunit : etiquette logique du support d'edition
  32 c     cw : chaine de caracteres de travail de longueur au moins ll
  33 c!
  34       double precision x(*),a,a1,a2,fact,eps,dlamch
  35       integer maxc,mode,fl,typ
  36       integer ind(*)
  37       character cw*(*),sgn*1,dl*1
  38       character*10 form(2)
  39 c
  40       if(ne.eq.0) then
  41          write(cw,'(''('',i5,'','',i5,'') zero sparse matrix'')') m,n
  42          call basout(io,lunit,cw(1:32))
  43          call basout(io,lunit,' ')
  44          goto 99
  45       else
  46          write(cw,'(''('',i5,'','',i5,'') sparse matrix'')') m,n
  47          call basout(io,lunit,cw(1:27))
  48          call basout(io,lunit,' ')
  49          if(io.eq.-1) goto 99
  50       endif
  51       ilr=1
  52       ilc=m+1
  53       nx=1
  54       eps=dlamch('p')
  55       cw=' '
  56       write(form(1),130) maxc,maxc-7
  57       dl=' '
  58       if(m*n.gt.1) dl=' '
  59
  60 c
  61 c facteur d'echelle
  62 c
  63       fact=1.0d+0
  64       a1=0.0d+0
  65       if(ne.eq.1) goto 10
  66       a2=abs(x(1))
  67       do 05 i=1,ne
  68          a=abs(x(i))
  69          if(a.eq.0.0d+0.or.a.gt.dlamch('o')) goto 05
  70          a1=max(a1,a)
  71          a2=min(a2,a)
  72    05 continue
  73       imax=0
  74       imin=0
  75       if(a1.gt.0.0d+0) imax=int(log10(a1))
  76       if(a2.gt.0.0d+0) imin=int(log10(a2))
  77       if(imax*imin.le.0) goto 10
  78       imax=(imax+imin)/2
  79       if(abs(imax).ge.maxc-2)  fact=10.0d+0**(-imax)
  80    10 continue
  81       eps=a1*fact*eps
  82 c
  83       if(fact.ne.1.0d+0) then
  84          write(cw(1:12),'(1x,1pd9.1,'' *'')')  1.0d+0/fact
  85          call basout(io,lunit,cw(1:12))
  86          call basout(io,lunit,' ')
  87          if(io.eq.-1) goto 99
  88       endif
  89       i0=0
  90       i1=i0
  91       l=1
  92       do 20 k=1,ne
  93          cw=' '
  94  11      i0=i0+1
  95          if(i0-i1.gt.ind(l)) then
  96             i1=i0
  97             l=l+1
  98             goto 11
  99          endif
 100          i=l
 101          j=ind(ilc-1+k)
 102          write(cw,'(''('',i5,'','',i5,'')'')') i,j
 103          l1=14
 104           a=x(k)*fact
 105 c         if(abs(a).lt.eps.and.mode.ne.0) a=0.0d+0
 106          sgn=' '
 107          if(a.lt.0.0d+0) sgn='-'
 108          a=abs(a)
 109
 110 c     determination du format devant representer a
 111          cw(l1:l1+6)='      '//sgn
 112          l1=l1+7
 113
 114          typ=1
 115          if(mode.eq.1) call fmt(a,maxc,typ,n1,n2)
 116          if(typ.eq.2) typ=n2+32*n1
 117          call formatnumber(a,typ,maxc,cw(l1:),fl)
 118          l1=l1+fl
 119          call basout(io,lunit,cw(1:l1) )
 120          if (io.eq.-1) goto 99
 121
 122    20 continue
 123  99   continue
 124 c
 125   120 format('(f',i2,'.',i2,')')
 126   130 format('(1pd',i2,'.',i2,')')
 127       end