uses enum
[scilab.git] / 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
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