1 subroutine pcseq3 ( etanp1, quhn, quhnp1, typint,
10 > nbfonc, vafoen, vafott,
13 > ulsort, langue, codret )
14 c ______________________________________________________________________
18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
21 c aupres des huissiers de justice Simart et Lavoir a Clamart
22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
23 c aupres des huissiers de justice
24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
26 c HOMARD est une marque deposee d'Electricite de France
32 c ______________________________________________________________________
34 c aPres adaptation - Conversion de Solution Elements de volume -
36 c Quadrangles d'etat anterieur 4
38 c ______________________________________________________________________
40 c . nom . e/s . taille . description .
41 c .____________________________________________________________________.
42 c . etanp1 . e . 1 . ETAt du quadrangle a l'iteration N+1 .
43 c . quhn . e . 1 . Quadrangle courant en numerotation Homard .
44 c . . . . a l'iteration N .
45 c . quhnp1 . e . 1 . Quadrangle courant en numerotation Homard .
46 c . . . . a l'iteration N+1 .
47 c . typint . e . 1 . type d'interpolation .
48 c . . . . 0, si automatique .
49 c . . . . elements : 0 si intensif, sans orientation.
50 c . . . . 1 si extensif, sans orientation.
51 c . . . . 2 si intensif, avec orientation.
52 c . . . . 3 si extensif, avec orientation.
53 c . . . . noeuds : 1 si degre 1 .
54 c . . . . 2 si degre 2 .
55 c . . . . 3 si iso-P2 .
56 c . typint . e . 1 . type d'interpolation .
57 c . . . . 0, si automatique .
58 c . . . . elements : 0 si intensif, sans orientation.
59 c . . . . 1 si extensif, sans orientation.
60 c . . . . 2 si intensif, avec orientation.
61 c . . . . 3 si extensif, avec orientation.
62 c . . . . noeuds : 1 si degre 1 .
63 c . . . . 2 si degre 2 .
64 c . . . . 3 si iso-P2 .
65 c . deraff . e . 1 . vrai, s'il y a eu du deraffinement en .
66 c . . . . passant de l'iteration n a n+1 ; faux sinon.
67 c . prfcan . e . * . En numero du calcul a l'iteration n : .
68 c . . . . 0 : l'entite est absente du profil .
69 c . . . . i : l'entite est au rang i dans le profil .
70 c . prfcap . es . * . En numero du calcul a l'iteration n+1 : .
71 c . . . . 0 : l'entite est absente du profil .
72 c . . . . 1 : l'entite est presente dans le profil .
73 c . coonoe . e . nbnoto . coordonnees des noeuds .
75 c . somare . e .2*nbarto. numeros des extremites d'arete .
76 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
77 c . filqua . e . nbquto . premier fils des quadrangles .
78 c . nbanqu . e . 1 . nombre de quadrangles decoupes par .
79 c . . . . conformite sur le maillage avant adaptation.
80 c . anfiqu . e . nbanqu . tableau filqua du maillage de l'iteration n.
81 c . nqueca . e . * . nro des quadrangles dans le calcul en ent. .
82 c . nqusca . e . rsquto . numero des quadrangles du calcul .
83 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
84 c . ntrsca . e . rstrto . numero des triangles du calcul .
85 c . nbfonc . e . 1 . nombre de fonctions elements de volume .
86 c . vafoen . e . nbfonc*. variables en entree de l'adaptation .
88 c . vafott . a . nbfonc*. tableau temporaire de la solution .
90 c . vatrtt . a . nbfonc*. tableau temporaire de la solution pour .
91 c . . . * . les triangles de conformite .
92 c . prftrp . es . * . En numero du calcul a l'iteration n+1 : .
93 c . . . . 0 : le triangle est absent du profil .
94 c . . . . 1 : le triangle est present dans le profil .
95 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
96 c . langue . e . 1 . langue des messages .
97 c . . . . 1 : francais, 2 : anglais .
98 c . codret . es . 1 . code de retour des modules .
99 c . . . . 0 : pas de probleme .
100 c . . . . 1 : probleme .
101 c ______________________________________________________________________
104 c 0. declarations et dimensionnement
107 c 0.1. ==> generalites
113 parameter ( nompro = 'PCSEQ3' )
130 integer etanp1, quhn, quhnp1
133 integer prfcan(*), prfcap(*)
134 integer somare(2,nbarto)
135 integer arequa(nbquto,4), filqua(nbquto)
136 integer nbanqu, anfiqu(nbanqu)
137 integer nqueca(requto), nqusca(rsquto)
138 integer aretri(nbtrto,3)
139 integer ntrsca(rstrto)
142 double precision coonoe(nbnoto,sdim)
143 double precision vafoen(nbfonc,*)
144 double precision vafott(nbfonc,*)
145 double precision vatrtt(nbfonc,*)
147 integer ulsort, langue, codret
149 c 0.4. ==> variables locales
151 c qucnp1 = QUadrangle courant en numerotation Calcul a l'it. N+1
155 c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1
156 c f1cp = Fils 1er du quadrangle en numerotation Calcul a l'it. N+1
157 c f2cp = Fils 2eme du quadrangle en numerotation Calcul a l'it. N+1
158 c f3cp = Fils 3eme du quadrangle en numerotation Calcul a l'it. N+1
161 integer f1cp, f2cp, f3cp
163 c f1hn = Fils 1er du quadrangle en numerotation Homard a l'it. N
164 c f1cn = Fils 1er du quadrangle en numerotation Calcul a l'it. N
165 c f2cn = Fils 2eme du quadrangle en numerotation Calcul a l'it. N
166 c f3cn = Fils 3eme du quadrangle en numerotation Calcul a l'it. N
167 c f4cn = Fils 4eme du quadrangle en numerotation Calcul a l'it. N
170 integer f1cn, f2cn, f3cn, f4cn
176 double precision daux
177 double precision daux0, daux1, daux2, daux3
180 parameter ( nbmess = 10 )
181 character*80 texte(nblang,nbmess)
183 c 0.5. ==> initialisations
184 c ______________________________________________________________________
194 #ifdef _DEBUG_HOMARD_
195 write (ulsort,texte(langue,1)) 'Entree', nompro
200 >'(''Quad. en cours : nro a l''''iteration '',a3,'' :'',i10)'
201 texte(1,5) = '( 16x,''etat a l''''iteration '',a3,'' : '',i4)'
204 >'(''Current quadrangle : # at iteration '',a3,'' : '',i10)'
205 texte(2,5) = '( 17x,''status at iteration '',a3,'' : '',i4)'
209 c 1.2. ==> on repere les numeros dans le calcul pour les fils
214 f2cn = nqueca(f1hn+1)
215 f3cn = nqueca(f1hn+2)
216 f4cn = nqueca(f1hn+3)
218 if ( prfcan(f1cn).gt.0 .and. prfcan(f2cn).gt.0 .and.
219 > prfcan(f3cn).gt.0 .and. prfcan(f3cn).gt.0 ) then
222 c 2. le quadrangle etait coupe en 4 quadrangles
224 c 2.1. ==> etanp1 = 0 : le quadrangle est actif ; il est reactive.
225 c on lui attribue la valeur moyenne des quatre anciens fils.
226 c remarque : cela arrive seulement avec du deraffinement.
227 c ................. .................
231 c ................. ===> . .
235 c ................. .................
237 if ( etanp1.eq.0 ) then
238 cgn write(ulsort,*)'... quadrangle reactive'
240 qucnp1 = nqusca(quhnp1)
243 if ( typint.eq.0 ) then
248 do 21 , nrofon = 1 , nbfonc
249 daux = daux1 * ( vafoen(nrofon,prfcan(f1cn))
250 > + vafoen(nrofon,prfcan(f2cn))
251 > + vafoen(nrofon,prfcan(f3cn))
252 > + vafoen(nrofon,prfcan(f4cn)) )
253 cgn write(ulsort,90004) 'daux', daux
254 vafott(nrofon,qucnp1) = daux
257 c 2.2. ==> etanp1 = 21/22 : le quadrangle est decoupe en
259 c On donne la valeur moyenne de la fonction sur les deux
260 c anciens fils a chaque nouveau fils.
261 c remarque : on pourrait certainement faire mieux, avec des
262 c moyennes ponderees en fonction du recouvrement
263 c des anciens et nouveaux fils. c'est trop
264 c complique pour que cela vaille le coup.
265 c ................. .................
269 c ................. ===> . . .
273 c ................. .................
274 elseif ( etanp1.ge.21 .and. etanp1.le.22 ) then
275 cgn write(ulsort,*)'... quadrangle coupe en 2'
277 f1hp = filqua(quhnp1)
279 f2cp = nqusca(f1hp+1)
283 if ( typint.eq.0 ) then
284 do 221 , nrofon = 1 , nbfonc
285 daux = unsqu * ( vafoen(nrofon,prfcan(f1cn))
286 > + vafoen(nrofon,prfcan(f2cn))
287 > + vafoen(nrofon,prfcan(f3cn))
288 > + vafoen(nrofon,prfcan(f4cn)) )
289 vafott(nrofon,f1cp) = daux
290 vafott(nrofon,f2cp) = daux
293 call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa )
294 call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa )
295 daux0 = daux1 + daux2
296 daux1 = daux1 / daux0
297 daux2 = daux2 / daux0
298 do 222 , nrofon = 1 , nbfonc
299 daux = vafoen(nrofon,prfcan(f1cn))
300 > + vafoen(nrofon,prfcan(f2cn))
301 > + vafoen(nrofon,prfcan(f3cn))
302 > + vafoen(nrofon,prfcan(f4cn))
303 vafott(nrofon,f1cp) = daux * daux1
304 vafott(nrofon,f2cp) = daux * daux2
308 c 2.3. ==> etanp1 = 31, 32, 33 ou 34 : le quadrangle est
309 c decoupe en trois triangles.
310 c on attribue la valeur moyenne sur les quatre anciens
311 c fils a chacune des trois nouveaux fils.
312 c remarque : on pourrait certainement faire mieux, avec des
313 c moyennes ponderees en fonction du recouvrement
314 c des anciens et nouveaux fils. c'est trop
315 c complique pour que cela vaille le coup.
316 c remarque : cela arrive seulement avec du deraffinement.
317 c ................. .................
321 c ................. ===> . . . .
325 c ................. .................
327 elseif ( etanp1.ge.31 .and. etanp1.le.34 ) then
328 cgn write(ulsort,*)'... quadrangle coupe en 3 triangles'
330 f1hp = -filqua(quhnp1)
332 f2cp = ntrsca(f1hp+1)
333 f3cp = ntrsca(f1hp+2)
337 if ( typint.eq.0 ) then
338 do 231 , nrofon = 1 , nbfonc
339 daux = unsqu * ( vafoen(nrofon,prfcan(f1cn))
340 > + vafoen(nrofon,prfcan(f2cn))
341 > + vafoen(nrofon,prfcan(f3cn))
342 > + vafoen(nrofon,prfcan(f4cn)) )
343 vatrtt(nrofon,f1cp) = daux
344 vatrtt(nrofon,f2cp) = daux
345 vatrtt(nrofon,f3cp) = daux
348 call utqtri ( f1hp , daux, daux1, coonoe, somare, aretri )
349 call utqtri ( f1hp+1, daux, daux2, coonoe, somare, aretri )
350 call utqtri ( f1hp+2, daux, daux3, coonoe, somare, aretri )
351 daux0 = daux1 + daux2 + daux3
352 daux1 = daux1 / daux0
353 daux2 = daux2 / daux0
354 daux3 = daux3 / daux0
355 do 232 , nrofon = 1 , nbfonc
356 daux = vafoen(nrofon,prfcan(f1cn))
357 > + vafoen(nrofon,prfcan(f2cn))
358 > + vafoen(nrofon,prfcan(f3cn))
359 > + vafoen(nrofon,prfcan(f4cn))
360 vatrtt(nrofon,f1cp) = daux * daux1
361 vatrtt(nrofon,f2cp) = daux * daux2
362 vatrtt(nrofon,f3cp) = daux * daux3
366 c 2.4. ==> etanp1 = 41, 42, 43 ou 43 : le quadrangle est decoupe en
368 c c'est ce qui se passe quand un decoupage de conformite
369 c est supprime au debut des algorithmes d'adaptation. il y
370 c a du deraffinement dans la zone qui induisait le decoupage
371 c de conformite et raffinement sur une autre zone.
372 c On donne la valeur moyenne de la fonction sur les trois
373 c anciens fils a chaque nouveau fils.
374 c remarque : on pourrait certainement faire mieux, avec des
375 c moyennes ponderees en fonction du recouvrement
376 c des anciens et nouveaux fils. c'est trop
377 c complique pour que cela vaille le coup.
378 c remarque : cela arrive seulement avec du deraffinement.
380 c ................. .................
384 c ................. ===> ......... .
388 c ................. .................
390 elseif ( etanp1.ge.41 .and. etanp1.le.44 ) then
391 cgn print *,'... le quadrangle est coupe en 3 quadrangles'
393 f1hp = filqua(quhnp1)
395 f2cp = nqusca(f1hp+1)
396 f3cp = nqusca(f1hp+2)
401 if ( typint.eq.0 ) then
403 do 241 , nrofon = 1 , nbfonc
404 daux = unsqu * ( vafoen(nrofon,prfcan(f1cn))
405 > + vafoen(nrofon,prfcan(f2cn))
406 > + vafoen(nrofon,prfcan(f3cn))
407 > + vafoen(nrofon,prfcan(f4cn)) )
408 cgn write(ulsort,90004) 'daux', daux
409 vafott(nrofon,f1cp) = daux
410 vafott(nrofon,f2cp) = daux
411 vafott(nrofon,f3cp) = daux
416 call utqqua ( f1hp , daux, daux1, coonoe, somare, arequa )
417 call utqqua ( f1hp+1, daux, daux2, coonoe, somare, arequa )
418 call utqqua ( f1hp+2, daux, daux3, coonoe, somare, arequa )
419 daux0 = daux1 + daux2 + daux3
420 daux1 = daux1 / daux0
421 daux2 = daux2 / daux0
422 daux3 = daux3 / daux0
423 do 242 , nrofon = 1 , nbfonc
424 daux = vafoen(nrofon,prfcan(f1cn))
425 > + vafoen(nrofon,prfcan(f2cn))
426 > + vafoen(nrofon,prfcan(f3cn))
427 > + vafoen(nrofon,prfcan(f4cn))
428 cgn write(ulsort,90004) 'unsqu*daux', unsqu*daux
429 cgn write(ulsort,90004) 'trshu*daux', trshu*daux
430 vafott(nrofon,f1cp) = daux * daux1
431 vafott(nrofon,f2cp) = daux * daux2
432 vafott(nrofon,f3cp) = daux * daux3
445 if ( coderr.ne.0 ) then
447 write (ulsort,texte(langue,1)) 'Sortie', nompro
448 write (ulsort,texte(langue,2)) coderr
449 codret = codret + coderr
453 #ifdef _DEBUG_HOMARD_
454 write (ulsort,texte(langue,1)) 'Sortie', nompro