1 subroutine pcsptz ( etan, etanp1, trhn, trhnp1,
5 > nbfonc, ngauss, vafoen, vafott,
6 > ulsort, langue, codret )
7 c ______________________________________________________________________
11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
14 c aupres des huissiers de justice Simart et Lavoir a Clamart
15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
16 c aupres des huissiers de justice
17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
19 c HOMARD est une marque deposee d'Electricite de France
25 c ______________________________________________________________________
27 c aPres adaptation - Conversion de Solution Points de Gauss -
29 c Triangles d'etat anterieur Zero
31 c ______________________________________________________________________
33 c . nom . e/s . taille . description .
34 c .____________________________________________________________________.
35 c . etan . e . 1 . ETAt du triangle a l'iteration N .
36 c . etanp1 . e . 1 . ETAt du triangle a l'iteration N+1 .
37 c . trhn . e . 1 . TRiangle courant en numerotation Homard .
38 c . . . . a l'iteration N .
39 c . trhnp1 . e . 1 . TRiangle courant en numerotation Homard .
40 c . . . . a l'iteration N+1 .
41 c . prfcan . e . * . En numero du calcul a l'iteration n : .
42 c . . . . 0 : l'entite est absente du profil .
43 c . . . . i : l'entite est au rang i dans le profil .
44 c . prfcap . es . * . En numero du calcul a l'iteration n+1 : .
45 c . . . . 0 : l'entite est absente du profil .
46 c . . . . 1 : l'entite est presente dans le profil .
47 c . filtri . e . nbtrto . premier fils des triangles .
48 c . ntreca . e . retrto . numero des triangles dans le calcul entree .
49 c . ntrsca . e . rstrto . numero des triangles du calcul en sortie .
50 c . nbfonc . e . 1 . nombre de fonctions elements de volume .
51 c . ngauss . e . 1 . nbre de points de Gauss des fonctions pg .
52 c . vafoen . e . nbfonc*. variables en entree de l'adaptation .
55 c . vafott . es . nbfonc*. tableau temporaire de la solution .
58 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
59 c . langue . e . 1 . langue des messages .
60 c . . . . 1 : francais, 2 : anglais .
61 c . codret . es . 1 . code de retour des modules .
62 c . . . . 0 : pas de probleme .
63 c . . . . 1 : probleme .
64 c ______________________________________________________________________
67 c 0. declarations et dimensionnement
70 c 0.1. ==> generalites
76 parameter ( nompro = 'PCSPTZ' )
88 integer etan, etanp1, trhn, trhnp1
89 integer nbfonc, ngauss
90 integer prfcan(*), prfcap(*)
91 integer filtri(nbtrto)
92 integer ntreca(retrto), ntrsca(rstrto)
94 double precision vafoen(nbfonc,ngauss,*)
95 double precision vafott(nbfonc,ngauss,*)
97 integer ulsort, langue, codret
99 c 0.4. ==> variables locales
101 #ifdef _DEBUG_HOMARD_
105 c trcn = TRiangle courant en numerotation Calcul a l'iteration N
106 c trcnp1 = TRiangle courant en numerotation Calcul a l'iteration N+1
110 c f1hp = Fils 1er du triangle en numerotation Homard a l'it. N+1
111 c f1cp = Fils 1er du triangle en numerota. du Calcul a l'it. N+1
112 c f2cp = Fils 2eme du triangle en numerota. du Calcul a l'it. N+1
113 c f3cp = Fils 3eme du triangle en numerota. du Calcul a l'it. N+1
114 c f4cp = Fils 4eme du triangle en numerota. du Calcul a l'it. N+1
117 integer f1cp, f2cp, f3cp, f4cp
120 integer nrofon, nugaus
122 double precision daux
123 double precision daux1
126 parameter ( nbmess = 10 )
127 character*80 texte(nblang,nbmess)
129 c 0.5. ==> initialisations
130 c ______________________________________________________________________
138 #ifdef _DEBUG_HOMARD_
139 write (ulsort,texte(langue,1)) 'Entree', nompro
144 >'(/,''Triangle en cours : nro a l''''iteration '',a3,'' : '',i10)'
146 > '( '' etat a l''''iteration '',a3,'' : '',i4)'
149 >'(/,''Current triangle : # at iteration '',a3,'' : '',i10)'
151 > '( '' status at iteration '',a3,'' : '',i4)'
157 c 1.2. ==> on repere son ancien numero dans le calcul
162 c 2. etan = 0 : le triangle etait actif
163 c On explore tous les etats du triangle a l'iteration n+1
166 if ( prfcan(trcn).gt.0 ) then
168 c ===> etanp1 = 0 : le triangle etait actif et l'est encore ;
170 c c'est le cas le plus simple : on prend la valeur de la
171 c fonction associee a l'ancien numero du triangle.
180 c ................. .................
182 if ( etanp1.eq.0 ) then
184 trcnp1 = ntrsca(trhnp1)
187 do 21 , nrofon = 1 , nbfonc
188 cgn write(ulsort,90014) nrofon,
189 cgn > (vafoen(nrofon,nugaus,trcn),nugaus=1,ngauss)
190 do 211 , nugaus = 1 , ngauss
191 vafott(nrofon,nugaus,trcnp1) =
192 > vafoen(nrofon,nugaus,prfcan(trcn))
195 cgn write(21,91010) trcnp1
196 cgn write(ulsort,91010) trcn,-1,trcnp1
198 c ==> etanp1 = 1, 2, 3 : le triangle etait actif et est decoupe en 2.
200 elseif ( etanp1.ge.1 .and. etanp1.le.3 ) then
202 f1hp = filtri(trhnp1)
204 f2cp = ntrsca(f1hp+1)
207 daux1 = 1.d0/dble(ngauss)
208 do 22 , nrofon = 1, nbfonc
209 daux = vafoen(nrofon,1,prfcan(trcn))
210 do 221 , nugaus = 2, ngauss
211 daux = daux + vafoen(nrofon,nugaus,prfcan(trcn))
214 do 222 , nugaus = 1 , ngauss
215 vafott(nrofon,nugaus,f1cp) = daux
216 vafott(nrofon,nugaus,f2cp) = daux
220 c ==> etanp1 = 4,6,7,8 : le triangle etait actif et est decoupe en 4.
222 elseif ( etanp1.eq.4 .or.
223 > ( etanp1.ge.6 .and. etanp1.le.8 ) ) then
225 f1hp = filtri(trhnp1)
227 f2cp = ntrsca(f1hp+1)
228 f3cp = ntrsca(f1hp+2)
229 f4cp = ntrsca(f1hp+3)
234 daux1 = 1.d0/dble(ngauss)
235 do 23 , nrofon = 1, nbfonc
236 daux = vafoen(nrofon,1,prfcan(trcn))
237 do 231 , nugaus = 2, ngauss
238 daux = daux + vafoen(nrofon,nugaus,prfcan(trcn))
241 do 232 , nugaus = 1 , ngauss
242 vafott(nrofon,nugaus,f1cp) = daux
243 vafott(nrofon,nugaus,f2cp) = daux
244 vafott(nrofon,nugaus,f3cp) = daux
245 vafott(nrofon,nugaus,f4cp) = daux
249 c ==> aucun autre etat sur le triangle courant n'est possible
254 write (ulsort,texte(langue,4)) 'n ', trhn
255 write (ulsort,texte(langue,5)) 'n ', etan
256 write (ulsort,texte(langue,4)) 'n+1', trhnp1
257 write (ulsort,texte(langue,5)) 'n+1', etanp1
267 if ( coderr.ne.0 ) then
269 write (ulsort,texte(langue,1)) 'Sortie', nompro
270 write (ulsort,texte(langue,2)) coderr