1 subroutine pcs1he ( nbfop1, profho,
4 > tritet, cotrte, aretet,
5 > quahex, coquhe, arehex,
6 > filhex, hethex, fhpyte,
7 > facpyr, cofapy, arepyr,
9 c ______________________________________________________________________
13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
16 c aupres des huissiers de justice Simart et Lavoir a Clamart
17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
18 c aupres des huissiers de justice
19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
21 c HOMARD est une marque deposee d'Electricite de France
27 c ______________________________________________________________________
29 c aPres adaptation - Conversion de Solution -
31 c interpolation p1 sur les noeuds lors du decoupage des HExaedres
33 c remarque : on devrait optimiser cela car si l'hexaedre etait dans
34 c un etat de decoupage avec presence de noeud central, on
35 c recalcule une valeur qui est deja presente
36 c ______________________________________________________________________
38 c . nom . e/s . taille . description .
39 c .____________________________________________________________________.
40 c . nbfop1 . e . 1 . nombre de fonctions P1 .
41 c . profho . es . * . pour chaque entite en numerotation homard :.
42 c . . . . 0 : l'entite est absente du profil .
43 c . . . . 1 : l'entite est presente dans le profil .
44 c . somare . e .2*nbarto. numeros des extremites d'arete .
45 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
46 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
47 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
48 c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres .
49 c . cotrte . e .nbtecf*4. code des 4 triangles des tetraedres .
50 c . aretet . e .nbteca*6. numeros des 6 aretes des tetraedres .
51 c . quahex . e .nbhecf*6. numeros des 6 quadrangles des hexaedres .
52 c . coquhe . e .nbhecf*6. codes des 6 quadrangles des hexaedres .
53 c . arehex . e .nbheca12. numeros des 12 aretes des hexaedres .
54 c . filhex . e . nbheto . premier fils des hexaedres .
55 c . hethex . e . nbheto . historique de l'etat des hexaedres .
56 c . fhpyte . e .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide .
57 c . . . . fille de l'hexaedre k tel que filhex(k) =-j.
58 c . . . . fhpyte(2,j) = numero du 1er tetraedre .
59 c . . . . fils de l'hexaedre k tel que filhex(k) = -j.
60 c . facpyr . e .nbpycf*5. numeros des 5 faces des pyramides .
61 c . cofapy . e .nbpycf*5. codes des 5 faces des pyramides .
62 c . arepyr . e .nbpyca*8. numeros des 8 aretes des pyramides .
63 c . vap1ho . es . nbfop1*. variables p1 numerotation homard .
65 c ______________________________________________________________________
68 c 0. declarations et dimensionnement
71 c 0.1. ==> generalites
92 integer profho(nbnoto)
93 integer somare(2,nbarto)
94 integer aretri(nbtrto,3)
95 integer arequa(nbquto,4)
96 integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
97 integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
98 integer filhex(nbheto), hethex(nbheto)
99 integer fhpyte(2,nbheco)
100 integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
102 double precision vap1ho(nbfop1,*)
104 c 0.4. ==> variables locales
106 integer lehexa, lehex0
107 integer listar(12), listso(8)
112 double precision daux
113 c ______________________________________________________________________
118 c 1. interpolation p1 pour les hexaedres qui viennent d'etre decoupes
119 c avec creation d'un noeud central. Ce noeud est au barycentre
120 c des 8 sommets de l'hexaedre pere. Donc on prend la moyenne de la
121 c fonction sur ces 8 noeuds.
124 if ( nbfop1.ne.0 ) then
126 do 10 , lehex0 = 1, nbheto
130 etahex = mod(hethex(lehexa),1000)
131 cgn write(6,90015) 'hexa',lehexa,' => etat, binaire, chnp1',
132 cgn > hethex(lehexa), chbiet(etahex), chnp1(chbiet(etahex))
133 cgn write(6,*) (quahex(lehexa,iaux),iaux=1,6)
134 cgn write(6,*) (coquhe(lehexa,iaux),iaux=1,6)
136 if ( chnp1(chbiet(etahex)).gt.0 ) then
138 c les aretes et les sommets de l'hexaedre
140 call utashe ( lehexa,
141 > nbquto, nbhecf, nbheca,
143 > quahex, coquhe, arehex,
145 cgn write(6,*) listso
147 c tous les sommets doivent etre dans le profil
149 do 102 , iaux = 1 , 8
150 if ( profho(listso(iaux)).ne.1 ) then
155 c recherche du noeud central
158 call utnmhe ( iaux, sm,
159 > somare, aretri, arequa,
160 > tritet, cotrte, aretet,
161 > quahex, coquhe, filhex, fhpyte,
162 > facpyr, cofapy, arepyr )
163 cgn write(6,*) 'sm', sm
165 c le noeud central est a ajouter dans le profil
169 c interpolation = 1/8 (u1+u2+u3...u8)
171 do 103 , nuv = 1, nbfop1
174 do 1031 , iaux = 1 , 8
175 daux = daux + vap1ho(nuv,listso(iaux))
177 vap1ho(nuv,sm) = unshu * daux