1 : C AJMTK SOURCE MAGN 09/07/30 21:15:07 6458
2 : SUBROUTINE AJMTK(GMS,MK,IMPR,IRET)
3 : IMPLICIT INTEGER(I-N)
4 : IMPLICIT REAL*8 (A-H,O-Z)
5 : C***********************************************************************
6 : C NOM : AJMTK
7 : C DESCRIPTION : Ajoute à un objet matrice de type MATRIK, un objet
8 : C matrice simplifiée de type GMATSI (voir définition du
9 : C segment ci-dessous).
10 : C
11 : C
12 : C
13 : C LANGAGE : ESOPE
14 : C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
15 : C mél : gounand@semt2.smts.cea.fr
16 : C***********************************************************************
17 : C APPELES : -
18 : C APPELES (UTIL) : RSETI : copie d'un tableau d'entiers.
19 : C APPELE PAR : YLAP1{B,C,D,E}
20 : C***********************************************************************
21 : C ENTREES : MS (type MATSIM) : objet matrice à ajouter.
22 : C ENTREES/SORTIES : MK (type MATRIK) : en sortie, est égal à :
23 : C MK (en entrée) + MS
24 : C SORTIES : -
25 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
26 : C***********************************************************************
27 : C VERSION : v1, 03/08/2001, version initiale
28 : C HISTORIQUE : v1, 03/08/2001, création
29 : C HISTORIQUE :
30 : C HISTORIQUE :
31 : C***********************************************************************
32 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
33 : C en cas de modification de ce sous-programme afin de faciliter
34 : C la maintenance !
35 : C***********************************************************************
36 : -INC CCOPTIO
37 : -INC SMMATRIK
38 : INTEGER NRIGE,NMATRI,NKID,NKMT
39 : INTEGER NBSOUS,NBME
40 : INTEGER NBEL,NP,MP
41 : POINTEUR MK.MATRIK
42 : POINTEUR IK.IMATRI
43 : POINTEUR JK.IZAFM
44 : -INC SMELEME
45 : INTEGER NBNN,NBELEM,NBREF
46 : POINTEUR MAIPRI.MELEME
47 : POINTEUR MAIDUA.MELEME
48 : *
49 : * Objet matrice élémentaire simplifié
50 : *
51 : SEGMENT GMATSI
52 : INTEGER POIPR1(NPP1,NEL1)
53 : INTEGER POIDU1(1,NEL1)
54 : INTEGER POIPR2(NPP2,NEL2)
55 : INTEGER POIDU2(2,NEL2)
56 : POINTEUR LMATSI(0).MATSIM
57 : ENDSEGMENT
58 : POINTEUR GMS.GMATSI
59 : SEGMENT MATSIM
60 : CHARACTER*8 NOMPRI,NOMDUA
61 : REAL*8 VALMA1(1,NPP1,NEL1)
62 : REAL*8 VALMA2(2,NPP2,NEL2)
63 : ENDSEGMENT
64 : POINTEUR MS.MATSIM
65 : *
66 : INTEGER IMPR,IRET
67 : *
68 : INTEGER IPOPR1,IPOPR2,IMAT,IELEM1,IELEM2
69 : INTEGER NPOPR1,NPOPR2,NMAT,NELEM1,NELEM2
70 : *
71 : * Executable statements
72 : *
73 : IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans ajmtk.eso'
74 : SEGACT GMS
75 : NPOPR1=GMS.POIPR1(/1)
76 : NPOPR2=GMS.POIPR2(/1)
77 : NELEM1=GMS.POIPR1(/2)
78 : NELEM2=GMS.POIPR2(/2)
79 : IF (NELEM1.GT.0) THEN
80 : *
81 : * Création du premier MATRIK
82 : *
83 : * Création de MAIPRI
84 : NBNN=NPOPR1
85 : NBELEM=NELEM1
86 : NBSOUS=0
87 : NBREF=0
88 : SEGINI,MAIPRI
89 : C ITYPEL=32 -> 'POLY'
90 : MAIPRI.ITYPEL=32
90 : CALL RSETI(MAIPRI.NUM,GMS.POIPR1,NPOPR1*NELEM1)
91 : SEGDES MAIPRI
92 : * Création de MAIDUA
93 : NBNN=1
94 : NBELEM=NELEM1
95 : NBSOUS=0
96 : NBREF=0
97 : SEGINI,MAIDUA
98 : C ITYPEL=32 -> 'POLY'
99 : MAIDUA.ITYPEL=32
99 : CALL RSETI(MAIDUA.NUM,GMS.POIDU1,NELEM1)
100 : SEGDES MAIDUA
101 : * Création de IK (noms d'inconnues+pointeurs sur valeurs des matrices
102 : * élémentaires)
103 : NMAT=GMS.LMATSI(/1)
104 : NBME=NMAT
105 : NBSOUS=1
106 : SEGINI IK
107 : DO 1 IMAT=1,NMAT
108 : MS=GMS.LMATSI(IMAT)
109 : SEGACT MS
110 : * Création de JK (matrice élémentaire)
111 : NBEL=NELEM1
112 : NP=NPOPR1
113 : MP=1
114 : SEGINI JK
115 : DO 12 IELEM1=1,NELEM1
116 : DO 122 IPOPR1=1,NPOPR1
117 : JK.AM(IELEM1,IPOPR1,1)=MS.VALMA1(1,IPOPR1,IELEM1)
118 : 122 CONTINUE
119 : 12 CONTINUE
120 : SEGDES JK
121 : IK.LISPRI(IMAT)=MS.NOMPRI
122 : IK.LISDUA(IMAT)=MS.NOMDUA
123 : IK.LIZAFM(1,IMAT)=JK
124 : SEGDES MS
125 : 1 CONTINUE
126 : SEGDES IK
127 : * Mise à jour de MK (pointeurs sur les matrices élémentaires)
128 : SEGACT MK*MOD
129 : NMATRI=MK.IRIGEL(/2)+1
130 : NRIGE=MK.IRIGEL(/1)
131 : NKID=MK.KIDMAT(/1)
132 : NKMT=MK.KKMMT(/1)
133 : SEGADJ,MK
134 : MK.IRIGEL(1,NMATRI)=MAIPRI
135 : MK.IRIGEL(2,NMATRI)=MAIDUA
136 : MK.IRIGEL(4,NMATRI)=IK
137 : * Matrice rectangulaire
138 : MK.IRIGEL(7,NMATRI)=3
139 : SEGDES MK
140 : ENDIF
141 : IF (NELEM2.GT.0) THEN
142 : *
143 : * Création du deuxième MATRIK
144 : *
145 : * Création de MAIPRI
146 : NBNN=NPOPR2
147 : NBELEM=NELEM2
148 : NBSOUS=0
149 : NBREF=0
150 : SEGINI,MAIPRI
151 : C ITYPEL=32 -> 'POLY'
152 : MAIPRI.ITYPEL=32
152 : CALL RSETI(MAIPRI.NUM,GMS.POIPR2,NPOPR2*NELEM2)
153 : SEGDES MAIPRI
154 : * Création de MAIDUA
155 : NBNN=2
156 : NBELEM=NELEM2
157 : NBSOUS=0
158 : NBREF=0
159 : SEGINI,MAIDUA
160 : C ITYPEL=32 -> 'POLY'
161 : MAIDUA.ITYPEL=32
161 : CALL RSETI(MAIDUA.NUM,GMS.POIDU2,2*NELEM2)
162 : SEGDES MAIDUA
163 : * Création de IK (noms d'inconnues+pointeurs sur valeurs des matrices
164 : * élémentaires)
165 : NMAT=GMS.LMATSI(/1)
166 : NBME=NMAT
167 : NBSOUS=1
168 : SEGINI IK
169 : DO 3 IMAT=1,NMAT
170 : MS=GMS.LMATSI(IMAT)
171 : SEGACT MS
172 : * Création de JK (matrice élémentaire)
173 : NBEL=NELEM2
174 : NP=NPOPR2
175 : MP=2
176 : SEGINI JK
177 : DO 32 IELEM2=1,NELEM2
178 : DO 322 IPOPR2=1,NPOPR2
179 : JK.AM(IELEM2,IPOPR2,1)=MS.VALMA2(1,IPOPR2,IELEM2)
180 : JK.AM(IELEM2,IPOPR2,2)=MS.VALMA2(2,IPOPR2,IELEM2)
181 : 322 CONTINUE
182 : 32 CONTINUE
183 : SEGDES JK
184 : IK.LISPRI(IMAT)=MS.NOMPRI
185 : IK.LISDUA(IMAT)=MS.NOMDUA
186 : IK.LIZAFM(1,IMAT)=JK
187 : SEGDES MS
188 : 3 CONTINUE
189 : SEGDES IK
190 : SEGDES GMS
191 : * Mise à jour de MK (pointeurs sur les matrices élémentaires)
192 : SEGACT MK*MOD
193 : NMATRI=MK.IRIGEL(/2)+1
194 : NRIGE=MK.IRIGEL(/1)
195 : NKID=MK.KIDMAT(/1)
196 : NKMT=MK.KKMMT(/1)
197 : SEGADJ,MK
198 : MK.IRIGEL(1,NMATRI)=MAIPRI
199 : MK.IRIGEL(2,NMATRI)=MAIDUA
200 : MK.IRIGEL(4,NMATRI)=IK
201 : * Matrice rectangulaire
202 : MK.IRIGEL(7,NMATRI)=3
203 : SEGDES MK
204 : ENDIF
205 : *
206 : * Normal termination
207 : *
208 : IRET=0
209 : RETURN
210 : *
211 : * Format handling
212 : *
213 : *
214 : * Error handling
215 : *
216 : 9999 CONTINUE
217 : IRET=1
218 : WRITE(IOIMP,*) 'An error was detected in subroutine ajmtk'
219 : RETURN
220 : *
221 : * End of subroutine AJMTK
222 : *
223 : END
224 :
225 :
226 :
227 :
228 :
© Cast3M 2003 - All rights reserved.
Disclaimer