1 subroutine pcsiqu ( nbfop2, profho, vap2ho,
2 > hetqua, arequa, filqua,
5 c ______________________________________________________________________
9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
12 c aupres des huissiers de justice Simart et Lavoir a Clamart
13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
14 c aupres des huissiers de justice
15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
17 c HOMARD est une marque deposee d'Electricite de France
23 c ______________________________________________________________________
25 c aPres adaptation - Conversion de Solution -
27 c interpolation iso-p2 sur les noeuds - decoupage des QUadrangles
29 c remarque : on devrait optimiser cela car si le quadrangle etait dans
30 c un etat de decoupage similaire, on recalcule une valeur
31 c qui est deja presente
32 c remarque : pcs2qu et pcsiqu sont des clones
33 c ______________________________________________________________________
35 c . nom . e/s . taille . description .
36 c .____________________________________________________________________.
37 c . nbfop2 . e . 1 . nombre de fonctions P2 .
38 c . profho . es . * . pour chaque entite en numerotation homard :.
39 c . . . . 0 : l'entite est absente du profil .
40 c . . . . 1 : l'entite est presente dans le profil .
41 c . vap2ho . es . nbfop2*. variables iso-p2 numerotation homard .
43 c . hetqua . e . nbquto . historique de l'etat des quadrangles .
44 c . arequa . e .nbquto*4. numeros des 4 aretes des quadrangles .
45 c . filqua . e . nbquto . premier fils des quadrangles .
46 c . somare . e .2*nbarto. numeros des extremites d'arete .
47 c . np2are . e . nbarto . numero des noeuds p2 milieux d'aretes .
48 c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
49 c ______________________________________________________________________
52 c 0. declarations et dimensionnement
55 c 0.1. ==> generalites
73 integer profho(nbnoto)
74 integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
75 integer somare(2,nbarto), np2are(nbarto)
76 integer aretri(nbtrto,3)
78 double precision vap2ho(nbfop2,*)
80 c 0.4. ==> variables locales
84 integer typdec, etanp1
88 integer listar(4), listno(8)
89 integer nbain, areint(4)
91 c f1hp = Fils 1er du quadrangle en numerotation Homard a l'it. N+1
96 c 0.5. ==> initialisations
99 c ______________________________________________________________________
100 cgn write (1,*) 'PCSIQU'
101 cgn 1789 format(a,10i4)
102 cgn 1791 format(8g12.5)
104 do 10 , lequad = 1, nbquto
107 c 1. interpolation iso-p2 pour un quadrangle qui vient d'etre decoupe
111 call pcs0qu ( iaux, profho,
114 > afaire, listar, listno, typdec, etanp1 )
116 cgn write (1,90002) 'quad/typdec', lequad, typdec
119 f1hp = filqua(lequad)
122 c 2. L'eventuel noeud central
125 if ( typdec.eq.4 .or.
126 > ( etanp1.ge.41 .and. etanp1.le.44 ) ) then
128 if ( typdec.eq.4 ) then
129 sm = somare(2,arequa(f1hp,2))
131 sm = somare(2,arequa(f1hp,3))
134 cgn write(6,1789) 'f1hp =', f1hp
135 cgn write(6,1789) 'sm =', sm
137 c interpolation = 1/4 (u5+u6+u7+u8)
139 cgn 1789 format( 4g13.5)
140 do 21, nuv = 1, nbfop2
141 cgn write(6,1791) vap2ho(nuv,listno(5)), vap2ho(nuv,listno(6))
142 cgn > , vap2ho(nuv,listno(7)), vap2ho(nuv,listno(8))
144 vap2ho(nuv,sm) = + unsqu * ( vap2ho(nuv,listno(5))
145 > + vap2ho(nuv,listno(6))
146 > + vap2ho(nuv,listno(7))
147 > + vap2ho(nuv,listno(8)) )
148 cgn write(6,1791) vap2ho(nuv,sm)
155 c 3. Les noeuds sur les aretes internes
157 c 3.1. Recherche des aretes internes
158 c voir cmrdqu, cmcdq2, cmcdq3 et cmcdq5 pour les conventions
161 if ( typdec.eq.4) then
164 areint(nbain) = arequa(f1hp+iaux,2)
166 elseif ( typdec.eq.21 .or. typdec.eq.22 ) then
168 areint(nbain) = arequa(f1hp,4)
169 elseif ( typdec.ge.31 .and. typdec.le.34 ) then
171 areint(nbain) = aretri(-f1hp,1)
173 areint(nbain) = aretri(-f1hp,3)
174 elseif ( typdec.ge.41 .and. typdec.le.44 ) then
176 areint(nbain) = arequa(f1hp,3)
178 areint(nbain) = arequa(f1hp,4)
180 areint(nbain) = arequa(f1hp+1,3)
182 cgn write(1,90002) 'nbain', nbain, (areint(iaux),iaux=1,nbain)
184 c 3.2. ==> les valeurs sur les noeuds
186 do 32 , iaux = 1 , nbain
188 s1 = somare(1,areint(iaux))
189 s2 = somare(2,areint(iaux))
190 noemi = np2are(areint(iaux))
193 do 321, nuv = 1 , nbfop2
195 vap2ho(nuv,noemi) = unsde * ( vap2ho(nuv,s1)
197 cgn write(*,*) 'vap2ho(nuv,',noemi,') =',vap2ho(nuv,noemi)