subroutine cmch33 ( lehexa, listar, listso, > indnoe, indare, indtri, indtet, indpyr, > indptp, > coonoe, hetnoe, arenoe, > famnoe, > hetare, somare, > filare, merare, famare, > hettri, aretri, > filtri, pertri, famtri, > nivtri, > filqua, > hettet, tritet, cotrte, > filtet, pertet, famtet, > hetpyr, facpyr, cofapy, > filpyr, perpyr, fampyr, > quahex, coquhe, > famhex, cfahex, > 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 Creation du Maillage - Conformite - decoupage des Hexaedres c - - - - c - par 2 Aretes - etat 33 c -- c Decoupage par les aretes 3 et 10 c ______________________________________________________________________ c . . . . . c . nom . e/s . taille . description . c .____________________________________________________________________. c . lehexa . e . 1 . hexaedre a decouper . c . listar . e . 12 . liste des aretes de l'hexaedre a decouper . c . listso . e . 8 . liste des sommets de l'hexaedre a decouper . c . indnoe . es . 1 . indice du dernier noeud cree . c . indare . es . 1 . indice de la derniere arete creee . c . indtri . es . 1 . indice du dernier triangle cree . c . indtet . es . 1 . indice du dernier tetraedre cree . c . indpyr . es . 1 . indice de la derniere pyramide creee . c . indptp . e . 1 . indice du dernier pere enregistre . c . coonoe . es .nouvno*3. coordonnees des noeuds . c . hetnoe . es . nouvno . historique de l'etat des noeuds . c . arenoe . es . nouvno . arete liee a un nouveau noeud . c . famnoe . es . nouvno . famille des noeuds . c . hetare . es . nouvar . historique de l'etat des aretes . c . somare . es .2*nouvar. numeros des extremites d'arete . c . filare . es . nouvar . premiere fille des aretes . c . merare . es . nouvar . mere des aretes . c . famare . . nouvar . famille des aretes . c . hettri . es . nouvtr . historique de l'etat des triangles . c . aretri . es .nouvtr*3. numeros des 3 aretes des triangles . c . filtri . es . nouvtr . premier fils des triangles . c . pertri . es . nouvtr . pere des triangles . c . famtri . es . nouvtr . famille des triangles . c . nivtri . es . nouvtr . niveau des triangles . c . filqua . e . nouvqu . premier fils des quadrangles . c . hettet . es . nouvte . historique de l'etat des tetraedres . c . tritet . es .nouvtf*4. numeros des 4 triangles des tetraedres . c . cotrte . es .nouvtf*4. code des 4 triangles des tetraedres . c . filtet . es . nouvte . premier fils des tetraedres . c . pertet . es . nouvte . pere des tetraedres . c . . . . si pertet(i) > 0 : numero du tetraedre . c . . . . si pertet(i) < 0 : -numero dans pthepe . c . famtet . es . nouvte . famille des tetraedres . c . hetpyr . es . nouvpy . historique de l'etat des pyramides . c . facpyr . es .nouvyf*5. numeros des 5 faces des pyramides . c . cofapy . es .nouvyf*5. codes des faces des pyramides . c . filpyr . es . nouvpy . premier fils des pyramides . c . perpyr . es . nouvpy . pere des pyramides . c . . . . si perpyr(i) > 0 : numero de la pyramide . c . . . . si perpyr(i) < 0 : -numero dans pphepe . c . fampyr . es . nouvpy . famille des pyramides . c . quahex . e .nouvhf*6. numeros des 6 quadrangles des hexaedres . c . coquhe . e .nouvhf*6. codes des 6 quadrangles des hexaedres . c . famhex . e . nouvhe . famille des hexaedres . c . cfahex . . nctfhe. codes des familles des hexaedres . c . . . nbfhex . 1 : famille MED . c . . . . 2 : type d'hexaedres . c . . . . 3 : famille des tetraedres de conformite . c . . . . 4 : famille des pyramides de conformite . c . ulsort . e . 1 . unite logique de la sortie generale . 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 . . . . 1 : aucune arete ne correspond . c ______________________________________________________________________ c c==== c 0. declarations et dimensionnement c==== c c 0.1. ==> generalites c implicit none save c character*6 nompro parameter ( nompro = 'CMCH33' ) c #include "nblang.h" c c 0.2. ==> communs c #include "envex1.h" c #include "envca1.h" #include "dicfen.h" #include "nbfami.h" #include "nouvnb.h" c c 0.3. ==> arguments c integer lehexa integer listar(12), listso(8) integer indnoe, indare, indtri, indtet, indpyr integer indptp integer hetnoe(nouvno), arenoe(nouvno) integer famnoe(nouvno) integer hetare(nouvar), somare(2,nouvar) integer filare(nouvar), merare(nouvar), famare(nouvar) integer hettri(nouvtr), aretri(nouvtr,3) integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr) integer nivtri(nouvtr) integer filqua(nouvqu) integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4) integer filtet(nouvte), pertet(nouvte), famtet(nouvte) integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5) integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy) integer quahex(nouvhf,6), coquhe(nouvhf,6) integer famhex(nouvhe), cfahex(nctfhe,nbfhex) c double precision coonoe(nouvno,sdim) c integer ulsort, langue, codret c c 0.4. ==> variables locales c integer nbsomm parameter ( nbsomm = 8 ) c integer iaux integer lesnoe(10), lesare(10) integer tab1(4), tab2(4) integer nulofa(4) integer areint(10) integer areqtr(4,2) integer triint(22) integer trifad(4,0:2), cotrvo(4,0:2) integer niveau c integer nbmess parameter ( nbmess = 10 ) 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 codret = 0 c c==== c 2. grandeurs dependant du cas traite c lesnoe(1) = S2 c lesnoe(2) = S5 c lesnoe(3) = S6 c lesnoe(4) = S1 c lesnoe(5) = S3 c lesnoe(6) = S8 c lesnoe(7) = S7 c lesnoe(8) = S4 c lesnoe( 9) = N3 c lesnoe(10) = N10 c==== c iaux = numero local de la 1ere arete coupee iaux = 3 c c lesnoe(9) = noeud milieu de la 1ere arete coupee lesnoe(9) = somare(2,filare(listar(iaux))) c c iaux = numero local de la 2eme arete coupee iaux = 10 c c lesnoe(10) = noeud milieu de la 2eme arete coupee lesnoe(10) = somare(2,filare(listar(iaux))) c c lesnoe(i) = sommet a joindre au centre de l'hexaedre pour c definir la ieme arete interne lesnoe(1) = listso(2) lesnoe(2) = listso(5) lesnoe(3) = listso(6) lesnoe(4) = listso(1) lesnoe(5) = listso(3) lesnoe(6) = listso(8) lesnoe(7) = listso(7) lesnoe(8) = listso(4) #ifdef _DEBUG_HOMARD_ write(ulsort,2000) 'listso', listso write(ulsort,2000) 'arete 1', listar(iaux) write(ulsort,2000) 'lesnoe(9)', lesnoe(9) write(ulsort,2000) 'arete 2', listar(iaux) write(ulsort,2000) 'lesnoe(10)', lesnoe(10) write(ulsort,2001) 'lesnoe(1)', lesnoe(1),'lesnoe(2)', lesnoe(2) write(ulsort,2001) 'lesnoe(3)', lesnoe(3),'lesnoe(4)', lesnoe(4) write(ulsort,2001) 'lesnoe(5)', lesnoe(5),'lesnoe(6)', lesnoe(6) write(ulsort,2001) 'lesnoe(7)', lesnoe(7),'lesnoe(8)', lesnoe(8) 2000 format(a,10i10) 2001 format(a,i10,', ',a,i10) #endif c c Triangles et aretes tracees sur les faces coupees en 3 c La premiere pyramide s'appuie sur celle des 2 faces de c l'hexaedre qui est non decoupee et de plus petit numero c local. Le positionnement de la pyramide a defini une c orientation de sa face quadrangulaire. c On traite les faces de l'hexaedre coupees en 3 comme suit : c . la 1ere et la 2eme partagent la 1ere arete coupee c . la 3eme et la 4eme partagent la 2nde arete coupee c Le choix de la 1ere est tel que l'ordre 1/2 corresponde a c l'orientation de la pyramide numero 1. Idem pour 3/4. c trifad(p,0) : triangle central de ce decoupage c trifad(p,1) : triangle bordant la pyramide 1 c trifad(p,2) : triangle bordant la pyramide 2 c cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la c description du tetraedre voisin c areqtr(p,1) : arete interne au quadrangle de bord et bordant le c triangle trifad(p,1) c areqtr(p,2) : arete interne au quadrangle de bord et bordant le c triangle trifad(p,2) c c trifad(1,0) = triangle central de la face 1 : FF1 c trifad(1,1) = triangle de la face 1 bordant PYR1 : FF1 + 1/2 c trifad(1,2) = triangle de la face 1 bordant PYR2 : FF1 + 2/1 c areqtr(1,1) : AS1N3 c areqtr(1,2) : AS4N3 c c trifad(2,0) = triangle central de la face 2 : FF4 c trifad(2,1) = triangle de la face 2 bordant PYR1 : FF4 + 2/1 c trifad(2,2) = triangle de la face 2 bordant PYR2 : FF4 + 1/2 c areqtr(2,1) : AS5N3 c areqtr(2,2) : AS8N3 c c trifad(3,0) = triangle central de la face 3 : FF6 c trifad(3,1) = triangle de la face 3 bordant PYR1 : FF6 + 1/2 c trifad(3,2) = triangle de la face 3 bordant PYR2 : FF6 + 2/1 c areqtr(3,1) : AS5N10 c areqtr(3,2) : AS8N10 c c trifad(4,0) = triangle central de la face 4 : FF3 c trifad(4,1) = triangle de la face 4 bordant PYR1 : FF3 + 2/1 c trifad(4,2) = triangle de la face 4 bordant PYR2 : FF3 + 1/2 c areqtr(4,1) : AS1N10 c areqtr(4,2) : AS4N10 c nulofa(1) = 1 nulofa(2) = 4 nulofa(3) = 6 nulofa(4) = 3 c if ( codret.eq.0 ) then c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'CMCHAA', nompro #endif call cmchaa ( nulofa, lehexa, > somare, > aretri, nivtri, > filqua, > quahex, coquhe, > niveau, areqtr, > trifad, cotrvo, > ulsort, langue, codret ) c endif c c==== c 3. Creation du noeud interne et des dix aretes internes c noecen : N0 c areint(1) : AS2N0 c areint(2) : AS5N0 c areint(3) : AS6N0 c areint(4) : AS1N0 c areint(5) : AS3N0 c areint(6) : AS8N0 c areint(7) : AS7N0 c areint(8) : AS4N0 c areint( 9) : AN3N0 c areint(10) : AN10N0 c==== c if ( codret.eq.0 ) then c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'CMCHAB', nompro write (ulsort,3001) indnoe+1 3001 format('.. noeud',i10) write (ulsort,3002) indare+1, indare+10 3002 format('.. aretes de',i10,' a',i10) #endif iaux = 10 call cmchpb ( indnoe, indare, iaux, > nbsomm, lesnoe, areint, > coonoe, hetnoe, arenoe, > famnoe, > hetare, somare, > filare, merare, famare, > ulsort, langue, codret ) c endif c c==== c 4. Creation des triangles internes c triint(1) : FA1 c triint(2) : FA6 c triint(3) : FA9 c triint(4) : FA5 c triint(5) : FA4 c triint(6) : FA8 c triint(7) : FA12 c triint(8) : FA7 c triint(9) : FA11 c triint(10) : FA2 c triint(11) : FS1N3 c triint(12) : FS5N3 c triint(13) : FS5N10 c triint(14) : FS1N10 c triint(15) : FS4N3 c triint(16) : FS8N3 c triint(17) : FS8N10 c triint(18) : FS4N10 c triint(19) : FS2N3 c triint(20) : FS6N10 c triint(21) : FS3N3 c triint(22) : FS7N10 c==== c if ( codret.eq.0 ) then c lesare(1) = listar(1) lesare(2) = listar(6) lesare(3) = listar(9) lesare(4) = listar(5) lesare(5) = listar(4) lesare(6) = listar(8) lesare(7) = listar(12) lesare(8) = listar(7) lesare(9) = listar(11) lesare(10) = listar(2) c tab1(1) = areint(9) tab2(1) = areint(1) tab1(2) = areint(3) tab2(2) = areint(10) tab1(3) = areint(5) tab2(3) = areint(9) tab1(4) = areint(10) tab2(4) = areint(7) c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'CMCHAC', nompro write (ulsort,4000) indtri+1, indtri+10 4000 format('.. triangles de',i10,' a',i10) #endif call cmchac ( indtri, triint, > lesare, tab1, tab2, > trifad, areint, areqtr, niveau, > aretri, famtri, hettri, > filtri, pertri, nivtri, > ulsort, langue, codret ) c endif c c==== c 5. Creation des deux pyramides c==== c if ( codret.eq.0 ) then c nulofa(1) = 2 nulofa(2) = 5 tab1(1) = 0 tab1(2) = -2 #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'CMCHAD', nompro write (ulsort,5000) indpyr+1, indpyr+2 5000 format('.. pyramides de',i10,' a',i10) #endif call cmchad ( nulofa, lehexa, > indpyr, indptp, > triint, tab1, > hetpyr, facpyr, cofapy, > filpyr, perpyr, fampyr, > quahex, coquhe, > famhex, cfahex, > ulsort, langue, codret ) c endif c c==== c 6. Creation des douze tetraedres dans l'ordre suivant : c tetraedre 1 c tetraedre 2 c tetraedre 3 c tetraedre 7 c tetraedre 8 c tetraedre 9 c tetraedre 10 c tetraedre 11 c tetraedre 12 c tetraedre 4 c tetraedre 5 c tetraedre 6 c==== c if ( codret.eq.0 ) then c #ifdef _DEBUG_HOMARD_ write (ulsort,texte(langue,3)) 'CMCHAE', nompro write (ulsort,6000) indtet+1, indtet+12 6000 format('.. tetraedres de',i10,' a',i10) #endif c iaux = 1 call cmchae ( lehexa, indtet, indptp, iaux, > trifad, cotrvo, triint, > hettet, tritet, cotrte, > filtet, pertet, famtet, > famhex, cfahex, > ulsort, langue, codret ) c endif c c==== c 7. la fin c==== 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