subroutine derco3 ( niveau, > decare, decfac, > merare, > posifa, facare, > hettri, aretri, pertri, nivtri, > voltri, > hetqua, arequa, perqua, nivqua, > tritet, > ulsort, langue, codret ) c ______________________________________________________________________ c c H O M A R D c c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D c c Version originale enregistree le 18 juin 1996 sous le numero 96036 c aupres des huissiers de justice Simart et Lavoir a Clamart c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014 c aupres des huissiers de justice c Lavoir, Silinski & Cherqui-Abrahmi a Clamart c c HOMARD est une marque deposee d'Electricite de France c c Copyright EDF 1996 c Copyright EDF 1998 c Copyright EDF 2002 c Copyright EDF 2020 c ______________________________________________________________________ c c traitement des DEcisions - Raffinement : COntamination - option 3 c -- - -- - c Complement sur la regle des ecarts de niveau pour du non-conforme c a 1 noeud pendant par arete c Remarque : cela ne peut concerner que des niveaux au moins egal a 2 c ______________________________________________________________________ c . . . . . c . nom . e/s . taille . description . c .____________________________________________________________________. c . niveau . e . 1 . niveau en cours d'examen . c . decare . es . nbarto . decisions des aretes . c . decfac . es . -nbquto. decision sur les faces (quad. + tri.) . c . . . :nbtrto. . c . merare . e . nbarto . mere des aretes . c . posifa . e . nbarto . pointeur sur tableau facare . c . facare . e . nbfaar . liste des faces contenant une arete . c . hettri . e . nbtrto . historique de l'etat des triangles . c . aretri . e . nbtrto . numeros des 3 aretes des triangles . c . pertri . e . nbtrto . pere des triangles . c . nivtri . e . nbtrto . niveau des triangles . c . voltri . e .2*nbtrto. numeros des 2 volumes par triangle . c . . . . voltri(i,k) definit le i-eme voisin de k . c . . . . 0 : pas de voisin . c . . . . j>0 : tetraedre j . c . . . . j<0 : pyramide/pentaedre dans pypetr(1/2,j). c . hetqua . e . nbquto . historique de l'etat des quadrangles . c . arequa . e . nbquto . numeros des 4 aretes des quadrangles . c . perqua . e . nbquto . pere des quadrangles . c . nivqua . e . nbquto . niveau des quadrangles . c . tritet . e .nbtecf*4. numeros des 4 triangles des tetraedres . c . ulsort . e . 1 . numero d'unite logique de la liste standard. c . langue . e . 1 . langue des messages . c . . . . 1 : francais, 2 : anglais . c . codret . es . 1 . code de retour des modules . c . . . . 0 : pas de probleme . c ______________________________________________________________________ c c==== c 0. declarations et dimensionnement c==== c c 0.1. ==> generalites c implicit none save c character*6 nompro parameter ( nompro = 'DERCO3' ) c #include "nblang.h" c c 0.2. ==> communs c #include "envex1.h" #include "nombar.h" #include "nombtr.h" #include "nombqu.h" #include "nombte.h" c c 0.3. ==> arguments c integer niveau integer decare(0:nbarto) integer decfac(-nbquto:nbtrto) integer merare(nbarto) integer posifa(0:nbarto), facare(nbfaar) integer hettri(nbtrto), aretri(nbtrto,3) integer pertri(nbtrto), nivtri(nbtrto) integer voltri(2,nbtrto) integer hetqua(nbquto), arequa(nbquto,4) integer perqua(nbquto), nivqua(nbquto) integer tritet(nbtecf,4) c integer ulsort, langue, codret c c 0.4. ==> variables locales c integer laface, tetrae, nbtetr integer ipos integer iaux, ideb, ifin integer iarelo, jarelo, ifalo, iarete, jarete, iface, itetra integer etatfa, merear, merefa, grdmfa integer nbare1, nbare2, liare1(4), liare2(4) c integer nbmess parameter ( nbmess = 30 ) character*80 texte(nblang,nbmess) c c 0.5. ==> initialisations c ______________________________________________________________________ c c==== c 1. initialisations c==== c #include "impr01.h" c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,1)) 'Entree', nompro call dmflsh (iaux) #endif c #ifdef _DEBUG_HOMARD_ #include "impr03.h" #endif c #include "derco1.h" c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,12)) niveau #endif c codret = 0 c c nombre maximum de tetraedres par triangle c if ( nbteto.eq.0 ) then nbtetr = 0 else nbtetr = 2 endif c c==== c 2. Complements sur la regle des ecarts de niveau c==== c do 2 , laface = -nbquto , nbtrto cgn print *,'entree de ',nompro,', ',laface,' :',decfac(laface) c c 2.1. ==> on s'interesse aux faces : c . du niveau courant c . actives c . qui ont une mere qui ne reapparait pas c . qui ont une grand-mere c grdmfa = 0 c if ( laface.gt.0 ) then c if ( nivtri(laface).eq.niveau ) then etatfa = mod( hettri(laface) , 10 ) if ( etatfa.eq.0 ) then merefa = pertri(laface) if ( merefa.gt.0 ) then if ( decfac(merefa).eq.0 ) then grdmfa = pertri(merefa) endif endif endif endif c elseif ( laface.lt.0 ) then c iaux = -laface if ( nivqua(iaux).eq.niveau ) then etatfa = mod( hetqua(iaux) , 100 ) if ( etatfa.eq.0 ) then merefa = perqua(iaux) if ( merefa.gt.0 ) then if ( decfac(-merefa).eq.0 ) then grdmfa = perqua(merefa) endif endif endif endif c endif c c 2.2. ==> on regarde les aretes de la face mere c if ( grdmfa.gt.0 ) then c c 2.2.1. ==> liste de ces aretes c if ( laface.gt.0 ) then c nbare2 = 3 do 2211 , iarelo = 1 , nbare2 liare2(iarelo) = aretri(merefa,iarelo) 2211 continue c else c nbare2 = 4 do 2212 , iarelo = 1 , nbare2 liare2(iarelo) = arequa(merefa,iarelo) 2212 continue c endif c nbare1 = 0 do 2213 , iaux = 1 , nbare2 if ( decare(liare2(iaux)).eq.0 ) then nbare1 = nbare1 + 1 liare1(nbare1) = liare2(iaux) endif 2213 continue c c on parcourt les aretes retenues c do 220 , iarelo = 1 , nbare1 c iarete = liare1(iarelo) c merear = merare(iarete) c if ( merear.ne.0 ) then c c 2.2.2. ==> l'arete iarete est sur le bord de la face grdmfa c ------------------------------------------------ c ==> pour toutes les faces qui s'appuient sur merear, c mere de cette arete iarete : c . si elles sont a reactiver, on les garde c ideb = posifa(merear-1)+1 ifin = posifa(merear) c do 2221 , ipos = ideb , ifin c iface = facare(ipos) c if ( decfac(iface).eq.-1 ) then c decfac(iface) = 0 if ( iface.gt.0 ) then do 2222 , jarelo = 1 , 3 jarete = aretri(iface,jarelo) decare(jarete) = 0 2222 continue else iaux = -iface do 2223 , jarelo = 1 , 4 jarete = arequa(iaux,jarelo) decare(jarete) = 0 2223 continue endif c endif c 2221 continue c else c c 2.2.3. ==> l'arete iarete est interieure a la face grdmfa c ---------------------------------------------- c ==> pour toutes les faces des tetraedres qui c s'appuient sur le triangle pere grdmfa : c . si elles sont a reactiver, on les garde c if ( laface.gt.0 ) then c do 2231 , itetra = 1 , nbtetr c c attention : on ne traite que les volumes traditionnels c tetra ou hexa, d'ou le codret=12 if ( voltri(itetra,grdmfa).lt.0 ) then codret = 12 goto 33 endif tetrae = voltri(itetra,grdmfa) if ( tetrae.ne.0 ) then c do 2232 , ifalo = 1 , 4 c iface = tritet(tetrae,ifalo) c if ( decfac(iface).eq.-1 ) then c decfac(iface) = 0 do 2233 , jarelo = 1 , 3 jarete = aretri(iface,jarelo) decare(jarete) = 0 2233 continue c endif c 2232 continue c endif c 2231 continue c endif c endif c 220 continue c endif c 2 continue c #ifdef _DEBUG_HOMARD_ write (ulsort,*) 'sortie de ',nompro do 1106 , iaux = 1 , nbquto write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux) cgn write (ulsort,90001) 'quadrangle', iaux, cgn > arequa(iaux,1), arequa(iaux,2), cgn > arequa(iaux,3), arequa(iaux,4) 1106 continue if ( nbquto.gt.0 ) then iaux = min(nbquto,5) write (ulsort,90001) 'quadrangle', iaux, > decare(arequa(iaux,1)), decare(arequa(iaux,2)), > decare(arequa(iaux,3)), decare(arequa(iaux,4)) iaux = min(nbquto,8) write (ulsort,90001) 'quadrangle', iaux, > decare(arequa(iaux,1)), decare(arequa(iaux,2)), > decare(arequa(iaux,3)), decare(arequa(iaux,4)) endif #endif c c==== c 3. la fin c==== c 33 continue c if ( codret.ne.0 ) then c #include "envex2.h" c write (ulsort,texte(langue,1)) 'Sortie', nompro write (ulsort,texte(langue,2)) codret c endif c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,1)) 'Sortie', nompro call dmflsh (iaux) #endif c end