1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
C/MEMBR ADD NAME=DMPEXT,SSI=0
subroutine dmpext(mp,d,m,n,row,nr,col,nc,mp1,d1,job,ierr)
c!but
c dmpext extrait une sous matrice definie par un choix de lignes
c et un choix de colonnes,d'une matrice polynomiale donnee.
c!liste d'appel
c subroutine dmpext(mp,d,m,n,row,nr,col,nc,mp1,d1,job,ierr)
c double precision mp(*),mp1(*)
c integer d(*),m,n,row(*),nr,col(*),nc,d1(*),job,ierr
c
c mp:tableau contenant les coefficients des polynomes de la
c matrice polynomiale donnee
c d:tableau des pointeurs sur les premiers coeff de chaque poly
c m: nombre de ligne de la matrice polynomiale
c n: nombre de colonnes
c row:vecteur contenant les indices des lignes choisies
c si nr <=0 row n'est pas reference
c nr:nombre de lignes choisies ,si nr < 0 on choisit toutes
c les lignes
c col:vecteur contenant les indices des colonnes choisies
c si nc <=0 col n'est pas reference.
c nc:nombre de colonnes choisies, si nc < 0 on choisit toutes
c les colonnes
c mp1:tableau contenant les coeff de la matrice polynomiale
c resultat. si job=0 mp1 n'est pas referencee
c d1:matrice des pointeurs de la matrice polynomiale resultat
c d1 est calculee si job.ne.1,si job =1 d1 doit etre fournie
c job:indicateur d'execution
c job=0 seul d1 est calcule
c job=1 mp1 est calcule supposant d1 donnee
c sinon d1 et mp1 sont calcules
c ierr:indicateur d'erreur:
c ierr=0 ok
c ierr>0 une des lignes (colonnes) choisies n'appartient
c pas a la matrice donnee.
c!origine
c Serge Steer INRIA 5/02/86
c!sous programmes appeles
c dcopy (blas)
c!
double precision mp(*),mp1(*)
integer d(*),m,n,row(*),nr,col(*),nc,d1(*),job,ierr
c
if(nr*nc.eq.0) return
if(m.le.0.or.n.le.0) return
if(nr.lt.0) goto 40
if(nc.lt.0) goto 50
c
c un choix de lignes et un choix de colonnes
c
c verifications de la validite des vecteurs row et col
do 10 j=1,nc
if(col(j).le.0.or.col(j).gt.n) goto 100
10 continue
do 11 i=1,nr
if(row(i).le.0.or.row(i).gt.m) goto 100
11 continue
c
if(job.eq.1) goto 25
c calcul de la matrice deplacement de la matrice polynomiale resultat
d1(1)=1
id1=1
do 20 j=1,nc
id=m*(col(j)-1)+1
do 20 i=1,nr
id1=id1+1
20 d1(id1)=d1(id1-1)+d(id+row(i))-d(id+row(i)-1)
if(job.eq.0) return
c
25 id1=1
do 26 j=1,nc
id=m*(col(j)-1)
do 26 i=1,nr
id1=id1+1
call dcopy(d1(id1)-d1(id1-1),mp(d(id+row(i))),1,mp1(d1(id1-1)),1)
26 continue
return
c
40 if(nc.lt.0) goto 60
c toutes les lignes et un choix de colonnes (nr<0)
do 41 j=1,nc
if(col(j).le.0.or.col(j).gt.n) goto 100
41 continue
if(job.eq.1) goto 45
id1=1
d1(id1)=1
do 42 j=1,nc
id=m*(col(j)-1)+1
do 42 i=1,m
id1=id1+1
d1(id1)=d1(id1-1)+d(id+i)-d(id+i-1)
42 continue
if(job.eq.0) return
45 id1=1
do 46 j=1,nc
id=1+m*(col(j)-1)
call dcopy(d(id+m)-d(id),mp(d(id)),1,mp1(d1(id1)),1)
id1=id1+m
46 continue
return
c
50 continue
c toutes les colonnnes et un choix de lignes
do 51 i=1,nr
if(row(i).le.0.or.row(i).gt.m) goto 100
51 continue
if(job.eq.1) goto 55
id1=1
d1(1)=1
id=1-m
do 52 j=1,n
id=id+m
do 52 i=1,nr
id1=id1+1
d1(id1)=d1(id1-1)+d(id+row(i))-d(id+row(i)-1)
52 continue
if(job.eq.0) return
55 continue
id1=1
do 53 j=1,n
id=(j-1)*m
do 53 i=1,nr
idi=id+row(i)
call dcopy(d(idi+1)-d(idi),mp(d(idi)),1,mp1(d1(id1)),1)
id1=id1+1
53 continue
return
c
60 continue
c toutes les lignes et toutes les colonnes
if(job.eq.1) goto 65
do 61 i=1,m*n+1
d1(i)=d(i)
61 continue
if(job.eq.0) return
65 call dcopy(d(m*n+1)-1,mp,1,mp1,1)
return
100 ierr=1
return
end
|
