1 subroutine pcs2p4 ( nbfop2, profho, vap2ho,
6 c ______________________________________________________________________
10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
13 c aupres des huissiers de justice Simart et Lavoir a Clamart
14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
15 c aupres des huissiers de justice
16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
18 c HOMARD est une marque deposee d'Electricite de France
24 c ______________________________________________________________________
26 c aPres adaptation - Conversion de Solution -
28 c interpolation p2 sur les noeuds - decoupage des Pentaedres - 4
30 c D'un milieu d'arete a un autre
31 c remarque : pcs2p4 et pcsip4 sont des clones
32 c ______________________________________________________________________
34 c . nom . e/s . taille . description .
35 c .____________________________________________________________________.
36 c . nbfop2 . e . 1 . nombre de fonctions P2 .
37 c . profho . es . * . pour chaque entite en numerotation homard :.
38 c . . . . 0 : l'entite est absente du profil .
39 c . . . . 1 : l'entite est presente dans le profil .
40 c . vap2ho . es . nbfop2*. variables p2 numerotation homard .
42 c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes .
43 c . etapen . e . 1 . etat du pentaedre a traiter .
44 c . listso . e . 6 . Liste des sommets ordonnes du pentaedre .
45 c . listno . e . 9 . Liste des noeuds ordonnees du pentaedre .
46 c . nbarco . e . 1 . nombre d'aretes concernees .
47 c . nuaret . e . nbarco . numero des aretes a traiter .
48 c ______________________________________________________________________
51 c 0. declarations et dimensionnement
54 c 0.1. ==> generalites
70 integer np2are(nbarto)
72 integer listso(6), listno(9)
73 integer nbarco, nuaret(nbarco)
75 double precision vap2ho(nbfop2,*)
77 c 0.4. ==> variables locales
84 c ______________________________________________________________________
88 cgn write(1,90002) 'listso', (listso(iaux),iaux=1,6)
89 cgn write(1,90002) 'listno', (listno(iaux),iaux=1,9)
91 cgn write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco)
94 c 2. Les 2 sommets sur l'arete oppose et les 4 autres sommets
97 if ( etapen.eq.21 ) then
104 elseif ( etapen.eq.22 ) then
111 elseif ( etapen.eq.23 ) then
118 elseif ( etapen.eq.24 ) then
125 elseif ( etapen.eq.25 ) then
141 listns(1) = listso(iaux1(1))
142 listns(2) = listso(iaux1(2))
143 listns(3) = listso(iaux1(3))
144 listns(4) = listso(iaux1(4))
145 listns(5) = listso(iaux1(5))
146 listns(6) = listso(iaux1(6))
147 cgn write(1,90002) 'listns 1-6', (listns(iaux),iaux=1,6)
151 c 7, 8 : les 2 noeuds sur la face triangulaire non coupee, du cote
152 c de l'arete de quadrangle coupee
153 c 9 : le dernier noeud sur la face triangulaire non coupee
154 c 10, 11, 12 : les noeuds semblables sur la face coupee
157 if ( etapen.eq.21 ) then
164 elseif ( etapen.eq.22 ) then
171 elseif ( etapen.eq.23 ) then
178 elseif ( etapen.eq.24 ) then
185 elseif ( etapen.eq.25 ) then
201 listns( 7) = listno(iaux1(1))
202 listns( 8) = listno(iaux1(2))
203 listns( 9) = listno(iaux1(3))
204 listns(10) = listno(iaux1(4))
205 listns(11) = listno(iaux1(5))
206 listns(12) = listno(iaux1(6))
207 cgn write(1,90002) 'listns 7-12', (listns(iaux),iaux=7,12)
211 c 13 : le noeud milieu de l'arete quadrangulaire coupee
212 c 14, 15 : les deux autres noeuds 'quadrangle'
215 if ( etapen.eq.21 .or. etapen.eq.24 ) then
219 elseif ( etapen.eq.22 .or. etapen.eq.25 ) then
229 listns(13) = listno(iaux1(1))
230 listns(14) = listno(iaux1(2))
231 listns(15) = listno(iaux1(3))
232 cgn write(1,90002) 'listns 13-15', (listns(iaux),iaux=13,15)
238 sm = np2are(nuaret(1))
239 cgn write(1,90002) 'sm',sm
243 do 51 , nuv = 1, nbfop2
245 vap2ho(nuv,sm) = unshu * ( vap2ho(nuv,listns(7))
246 > + vap2ho(nuv,listns(8))
247 > - vap2ho(nuv,listns(1))
248 > - vap2ho(nuv,listns(2)) )
249 > + trssz * ( vap2ho(nuv,listns(10))
250 > + vap2ho(nuv,listns(11))
251 > + vap2ho(nuv,listns(12))
252 > - vap2ho(nuv,listns(3))
253 > - vap2ho(nuv,listns(4))
254 > - vap2ho(nuv,listns(5))
255 > - vap2ho(nuv,listns(6)) )
256 > + unssz * vap2ho(nuv,listns(9))
257 > + trshu * ( vap2ho(nuv,listns(13))
258 > + vap2ho(nuv,listns(14))
259 > + vap2ho(nuv,listns(15)) )
260 cgn write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm)