2749cb2f80b6204d64935b05748264b1b4d857b4
[scilab.git] / scilab / modules / cacsd / src / fortran / dlslv.f
1 c Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 c Copyright (C) INRIA - Serge STEER
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
10       subroutine dlslv(a,na,n,b,nb,m,w,rcond,ierr,job)
11 c!but
12 c      ce sous programme effectue:
13 c        la factorisation lu de la matrice a si job=0
14 c        la resolution du systeme a*x=b si job=1
15 c        la resolution du systeme x*a=b si job=2
16 c        l'inversion de a si job=3
17 c
18 c!liste d'appel
19 c           subroutine dlslv(a,na,n,b,nb,m,w,rcond,ierr,job)
20 c      a:tableau de taille na*n contenant la matrice a
21 c         apres execution a contient la factorisation lu
22 c      na:dimensionnement de a dans le programme appelant
23 c      n:dimensions de la matrice a
24 c      b:tableau de taille nb*m contenant la matrice b et le resultat x
25 c      nb:dimensionnement de b dans le programme appelant
26 c      m:nombre de colonnes de b si job=1 ;ou nombre de ligne si job=2
27 c      w:tableau de travail de taille n+adr(n,1)
28 c      rcond:reel contenant le conditionnement inverse de a
29 c      ierr:indicateur de deroulement
30 c          ierr=0 ok
31 c          ierr=1 rcond=0
32 c          ierr=-1 rcond negligeable
33 c      job:
34 c     si a et w n'ont pas ete modifies on peut reentrer dans le
35 c     sous programme avec une nouvelle matrice b (job=-1 ou job=-2)
36 c
37 c!sous programmes appeles
38 c     dgeco dgesl dgedi (linpack)
39 c     dcopy (blas)
40 c     abs (fortran)
41 c!
42       double precision a(na,n),b(*),w(*),rcond,dt(2)
43       integer sadr
44 c
45 c     
46 c      iadr(l)=l+l-1
47       sadr(l)=(l/2)+1
48 c
49       k1=1+sadr(n)
50       ierr=0
51       if(job.lt.0) goto 20
52 c factorisation lu
53       call dgeco(a,na,n,w,rcond,w(k1))
54       if(rcond.eq.0.0d+0) goto 70
55       if(rcond+1.0d+0.eq.1.0d+0) ierr=-1
56       if(job.eq.0) return
57       if(job.eq.3) goto 60
58 c resolution
59   20  if(abs(job).eq.2) goto 40
60       jb=1
61       do 30 j=1,m
62       call dgesl(a,na,n,w,b(jb),0)
63       jb=jb+nb
64    30 continue
65       return
66    40 do 50 j=1,m
67       call dcopy(n,b(j),nb,w(k1),1)
68       call dgesl(a,na,n,w,w(k1),1)
69       call dcopy(n,w(k1),1,b(j),nb)
70    50 continue
71       return
72    60 call dgedi(a,na,n,w,dt,w(k1),1)
73       return
74    70 ierr=1
75       return
76       end