--- /dev/null
+ subroutine cmhomt ( arehom, trihom,
+ > somare,
+ > aretri, filtri, hettri,
+ > 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 - HOMologues - les Triangles
+c - - --- -
+c ______________________________________________________________________
+c . . . . .
+c . nom . e/s . taille . description .
+c .____________________________________________________________________.
+c . arehom . es . nbarto . ensemble des aretes homologues .
+c . trihom . es . nbtrto . ensemble des triangles homologues .
+c . somare . e .2*nbarto. numeros des extremites d'arete .
+c . aretri . e .nbtrto*3. numeros des 3 aretes des triangles .
+c . filtri . e . nbtrto . premier fils des triangles .
+c . hettri . e . nbtrto . historique de l'etat des triangles .
+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 ______________________________________________________________________
+c
+c====
+c 0. declarations et dimensionnement
+c====
+c
+c 0.1. ==> generalites
+c
+ implicit none
+ save
+c
+ character*6 nompro
+ parameter ( nompro = 'CMHOMT' )
+c
+#include "nblang.h"
+c
+c 0.2. ==> communs
+c
+#include "envex1.h"
+c
+#include "demitr.h"
+#include "nombar.h"
+#include "nombtr.h"
+#include "impr02.h"
+c
+c 0.3. ==> arguments
+c
+ integer arehom(nbarto), trihom(nbtrto)
+ integer somare(2,nbarto)
+ integer aretri(nbtrto,3), filtri(nbtrto), hettri(nbtrto)
+c
+ integer ulsort, langue, codret
+c
+c 0.4. ==> variables locales
+c
+ integer iaux
+ integer letria
+ integer fach
+ integer hist, etafac, etafho, an2, an1, n2f, n1f
+ integer a2f1, a2f2, a2f3, a1f1, a1f2, a1f3
+ integer f2k, f2j, f1k, f1j
+ integer na2k, na1k, na1j
+ integer a2s2s3, a2s1s3
+ integer a1s1s2, a1s2s3, a1s1s3
+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
+ texte(1,4) = '(''Etat du '',a,i10,'' : '',i4)'
+ texte(1,5) = '(/,''Les deux '',a,'' homologues'',2i10)'
+ texte(1,6) = '(''devraient etre coupes en 2.'')'
+ texte(1,7) = '(''Elle a pour homologue '',i10)'
+ texte(1,8) = '(''Il faudrait l''''arete'',i10,'' ou '',i10)'
+ texte(1,9) = '(''Arete'',i10,'' de sommets'',2i10)'
+ texte(1,10) = '(5x,''Erreur sur les '',a,'' homologues.'')'
+c
+ texte(2,4) = '(''State of '',a,'' #'',i10,'' : '',i4)'
+ texte(2,5) = '(/,''The two homologous '',a,'' #'',i10)'
+ texte(2,6) = '(''should be cut into 2.'')'
+ texte(2,7) = '(''Its homologous is ''i10)'
+ texte(2,8) = '(''It should be edge #'',i10,'' or #'',i10)'
+ texte(2,9) = '(''Edge #'',i10,'' with vertices #'',2i10)'
+ texte(2,10) = '(5x,''Error for homologous '',a)'
+c
+c====
+c 2. on boucle uniquement sur les triangles de la face periodique 2
+c qui viennent d'etre decoupes en 2 ou en 4
+c====
+c
+ do 21, letria = 1, nbtrpe
+c
+ if ( trihom(letria).gt.0 ) then
+c
+ hist = hettri(letria)
+ etafac = mod ( hist, 10 )
+c
+ if ( hist.eq. 4 .or. hist.eq.14 .or.
+ > hist.eq.24 .or. hist.eq.34 ) then
+c
+ fach = abs(trihom(letria))
+c
+c 2.1. ==> le triangle vient d'etre decoupe en 4
+c
+c 2.1.1. ==> recuperation des infos sur les fils de letria
+c
+ n2f = filtri(letria)
+c
+c recuperation des numeros d'aretes
+c
+ a2s2s3 = aretri(letria,1)
+ a2s1s3 = aretri(letria,2)
+c
+c recuperation des aretes internes
+c
+ a2f1 = aretri(n2f,1)
+ a2f2 = aretri(n2f,2)
+ a2f3 = aretri(n2f,3)
+c
+c 2.1.2. ==> recuperation des infos sur le triangle homologue
+c
+ n1f = filtri(fach)
+c
+c recuperation des numeros d'aretes
+c
+ a1s1s2 = aretri(fach,3)
+ a1s2s3 = aretri(fach,1)
+ a1s1s3 = aretri(fach,2)
+c
+c recuperation des aretes internes
+c
+ a1f1 = aretri(n1f,1)
+ a1f2 = aretri(n1f,2)
+ a1f3 = aretri(n1f,3)
+c
+c 2.1.3. ==> reperage des homologues
+c
+c dans tous les cas on a correspondance entre
+c les triangles n2f et n1f, fils aines.
+c n2f est sur la meme face que "larete" c'est-a-dire la face 2
+c donc noehom(n2f) est positif.
+c s1f est sur l'autre face, donc noehom(s1f) est negatif
+c
+ trihom(n2f) = n1f
+ trihom(n1f) = -n2f
+c
+ if ( abs(arehom(a2s2s3)).eq.a1s2s3 ) then
+c
+c les aretes 1 correspondent donc on a correspondance entre
+c les triangles n2f+1 et n1f+1
+c les aretes a2f1 et a1f1
+c
+ arehom(a2f1) = a1f1
+ arehom(a1f1) = -a2f1
+c
+ trihom(n2f+1) = (n1f+1)
+ trihom(n1f+1) = -(n2f+1)
+c
+ if ( abs(arehom(a2s1s3)).eq.a1s1s3 ) then
+c
+c les aretes 2 correspondent donc
+c on a correspondance entre
+c les triangles n2f+2 et n1f+2
+c les triangles n2f+3 et n1f+3
+c les aretes a2f2 et a1f2
+c les aretes a2f3 et a1f3
+c
+ arehom(a2f2) = a1f2
+ arehom(a1f2) = -a2f2
+ arehom(a2f3) = a1f3
+ arehom(a1f3) = -a2f3
+c
+ trihom(n2f+2) = (n1f+2)
+ trihom(n1f+2) = -(n2f+2)
+ trihom(n2f+3) = (n1f+3)
+ trihom(n1f+3) = -(n2f+3)
+c
+ else
+c
+c les aretes 2 et 3 correspondent
+c donc on a correspondance entre
+c les triangles n2f+2 et n1f+3
+c les triangles n2f+3 et n1f+2
+c les aretes a2f2 et a1f3
+c les aretes a2f3 et a1f2
+c
+ arehom(a2f2) = a1f3
+ arehom(a1f3) = -a2f2
+ arehom(a2f3) = a1f2
+ arehom(a1f2) = -a2f3
+c
+ trihom(n2f+2) = (n1f+3)
+ trihom(n1f+3) = -(n2f+2)
+ trihom(n2f+3) = (n1f+2)
+ trihom(n1f+2) = -(n2f+3)
+c
+ endif
+c
+ elseif ( abs(arehom(a2s2s3)).eq.a1s1s3 ) then
+c
+c les aretes 1 et 2 correspondent
+c donc on a correspondance entre
+c les triangles n2f+1 et n1f+2
+c les aretes a2f1 et a1f2
+c
+ arehom(a2f1) = a1f2
+ arehom(a1f2) = -a2f1
+c
+ trihom(n2f+1) = (n1f+2)
+ trihom(n1f+2) = -(n2f+1)
+c
+ if ( abs(arehom(a2s1s3)).eq.a1s2s3 ) then
+c
+c les aretes 2 et 1 correspondent
+c donc on a correspondance entre
+c les triangles n2f+2 et n1f+1
+c les triangles n2f+3 et n1f+3
+c les aretes a2f2 et a1f1
+c les aretes a2f3 et a1f3
+c
+ arehom(a2f2) = a1f1
+ arehom(a1f1) = -a2f2
+ arehom(a2f3) = a1f3
+ arehom(a1f3) = -a2f3
+c
+ trihom(n2f+2) = (n1f+1)
+ trihom(n1f+1) = -(n2f+2)
+ trihom(n2f+3) = (n1f+3)
+ trihom(n1f+3) = -(n2f+3)
+c
+ else
+c
+c les aretes 2 et 3 correspondent
+c donc on a correspondance entre
+c les triangles n2f+2 et n1f+3
+c les triangles n2f+3 et n1f+1
+c les aretes a2f2 et a1f3
+c les aretes a2f3 et a1f1
+c
+ arehom(a2f2) = a1f3
+ arehom(a1f3) = -a2f2
+ arehom(a2f3) = a1f1
+ arehom(a1f1) = -a2f3
+c
+ trihom(n2f+2) = (n1f+3)
+ trihom(n1f+3) = -(n2f+2)
+ trihom(n2f+3) = (n1f+1)
+ trihom(n1f+1) = -(n2f+3)
+c
+ endif
+c
+ elseif ( abs(arehom(a2s2s3)).eq.a1s1s2 ) then
+c
+c les aretes 1 et 3 correspondent
+c donc on a correspondance entre
+c les triangles n2f+1 et n1f+3
+c les aretes a2f1 et a1f3
+c
+ arehom(a2f1) = a1f3
+ arehom(a1f3) = -a2f1
+c
+ trihom(n2f+1) = (n1f+3)
+ trihom(n1f+3) = -(n2f+1)
+c
+ if ( abs(arehom(a2s1s3)).eq.a1s2s3 ) then
+c
+c les aretes 2 et 1 correspondent
+c donc on a correspondance entre
+c les triangles n2f+2 et n1f+1
+c les triangles n2f+3 et n1f+2
+c les aretes a2f2 et a1f1
+c les aretes a2f3 et a1f2
+c
+ arehom(a2f2) = a1f1
+ arehom(a1f1) = -a2f2
+ arehom(a2f3) = a1f2
+ arehom(a1f2) = -a2f3
+c
+ trihom(n2f+2) = (n1f+1)
+ trihom(n1f+1) = -(n2f+2)
+ trihom(n2f+3) = (n1f+2)
+ trihom(n1f+2) = -(n2f+3)
+c
+ else
+c
+c les aretes 2 correspondent
+c donc on a correspondance entre
+c les triangles n2f+2 et n1f+2
+c les triangles n2f+3 et n1f+1
+c les aretes a2f2 et a1f3
+c les aretes a2f3 et a1f1
+c
+ arehom(a2f2) = a1f2
+ arehom(a1f2) = -a2f2
+ arehom(a2f3) = a1f1
+ arehom(a1f1) = -a2f3
+c
+ trihom(n2f+2) = (n1f+2)
+ trihom(n1f+2) = -(n2f+2)
+ trihom(n2f+3) = (n1f+1)
+ trihom(n1f+1) = -(n2f+3)
+c
+ endif
+c
+ else
+ write (ulsort,texte(langue,10)) mess14(langue,3,2)
+ endif
+c
+ elseif ( etafac.eq.1 .or. etafac.eq.2 .or. etafac.eq.3 ) then
+c
+c 2.2. ==> le triangle vient d'etre decoupe en 2
+c . il n'y a aucune regle d'ordre de creation des
+c demi-triangles entre les deux meres homologues.
+c . il n'y a pas de probleme d'axe a gerer, car letria est
+c sur la face 2 par hypothese, et donc fach sur la face 1
+c . la seule information dont on est certain est la
+c correspondance entre les filles des aretes decoupees : le
+c tableau arehom a ete mis a jour precedemment
+c
+c letria fach
+c
+c s2i s1i
+c x x
+c ... ...
+c . . . . . .
+c are2j . . . are2k <--> are1j . . . are1k
+c . a. . . a. .
+c . n. . . n. .
+c . 2. . . 1. .
+c . f2k . f2j . . f1k . f1j .
+c . . . . . .
+c x-----------------x x-----------------x
+c s2k na2k n2 na2j s2j s1k na1k n1 na1j s1j
+c
+c alternative : f2k est homologue de f1k
+c ou : f2k est homologue de f1j
+c
+c 2.2.1. ==> recuperation des infos sur les fils de letria
+c
+ if ( etafac.eq.1 ) then
+c
+c le triangle a ete decoupe en 2 par l'arete numero 1
+c
+c recuperation des triangles fils
+c
+ f2k = filtri(letria) + nutrde(1,2)
+ f2j = filtri(letria) + nutrde(1,3)
+c
+c recuperation des nouvelles aretes
+c
+ na2k = aretri(f2k,1)
+c
+ an2 = aretri(f2k,3)
+c
+ elseif ( etafac.eq.2 ) then
+c
+c le triangle a ete decoupe en 2 par l'arete numero 2
+c
+c recuperation des triangles fils
+c
+ f2k = filtri(letria) + nutrde(2,3)
+ f2j = filtri(letria) + nutrde(2,1)
+c
+c recuperation des nouvelles aretes
+c
+ na2k = aretri(f2k,2)
+c
+ an2 = aretri(f2k,1)
+c
+ elseif ( etafac.eq.3 ) then
+c
+c le triangle a ete decoupe en 2 par l'arete numero 3
+c
+c recuperation des triangles fils
+c
+ f2k = filtri(letria) + nutrde(3,1)
+ f2j = filtri(letria) + nutrde(3,2)
+c
+c recuperation des nouvelles aretes
+c
+ na2k = aretri(f2k,3)
+c
+ an2 = aretri(f2k,2)
+c
+ endif
+c
+c 2.2.2. ==> recuperation des infos sur le triangle homologue
+c
+ fach = abs(trihom(letria))
+c
+ etafho = mod ( hettri(fach), 10 )
+c
+ if ( etafho.eq.1 ) then
+c
+c le triangle a ete decoupe en 2 par l'arete numero 1
+c
+c recuperation des triangles fils
+c
+ f1k = filtri(fach) + nutrde(1,2)
+ f1j = filtri(fach) + nutrde(1,3)
+c
+c recuperation des nouvelles aretes
+c
+ na1k = aretri(f1k,1)
+ na1j = aretri(f1j,1)
+c
+ an1 = aretri(f1k,3)
+c
+ elseif ( etafho.eq.2 ) then
+c
+c le triangle a ete decoupe en 2 par l'arete numero 2
+c
+c recuperation des triangles fils
+c
+ f1k = filtri(fach) + nutrde(2,3)
+ f1j = filtri(fach) + nutrde(2,1)
+c
+c recuperation des nouvelles aretes
+c
+ na1k = aretri(f1k,2)
+ na1j = aretri(f1j,2)
+c
+ an1 = aretri(f1k,1)
+c
+ elseif ( etafho.eq.3 ) then
+c
+c le triangle a ete decoupe en 2 par l'arete numero 3
+c
+c recuperation des triangles fils
+c
+ f1k = filtri(fach) + nutrde(3,1)
+ f1j = filtri(fach) + nutrde(3,2)
+c
+c recuperation des nouvelles aretes
+c
+ na1k = aretri(f1k,3)
+ na1j = aretri(f1j,3)
+c
+ an1 = aretri(f1k,2)
+c
+ else
+c
+c le triangle homologue n'est pas coupe en deux ???
+c
+ write (ulsort,texte(langue,5))mess14(langue,3,2),
+ > letria, fach
+ write (ulsort,texte(langue,6))
+ write (ulsort,texte(langue,4)) mess14(langue,1,2),
+ > letria, etafac
+ write (ulsort,texte(langue,4)) mess14(langue,1,2),
+ > fach, etafho
+ codret = 2
+c
+ endif
+c
+c 2.2.3. ==> reperage des homologues
+c
+ arehom(an2) = an1
+ arehom(an1) = -an2
+c
+ if ( arehom(na2k).eq.na1k ) then
+c
+ trihom(f2k) = f1k
+ trihom(f2j) = f1j
+ trihom(f1k) = -f2k
+ trihom(f1j) = -f2j
+c
+ elseif ( arehom(na2k).eq.na1j ) then
+c
+ trihom(f2k) = f1j
+ trihom(f2j) = f1k
+ trihom(f1k) = -f2j
+ trihom(f1j) = -f2k
+c
+ else
+c
+c l'arete n'a pas d'homologue ?
+c
+ write (ulsort,texte(langue,5)) mess14(langue,3,2),
+ > letria, fach
+ write (ulsort,texte(langue,9))
+ > na2k, somare(1,na2k), somare(2,na2k)
+ write (ulsort,texte(langue,7)) arehom(na2k)
+ if ( arehom(na2k).ne.0 ) then
+ write (ulsort,texte(langue,9)) abs(arehom(na2k)),
+ > somare(1,abs(arehom(na2k))), somare(2,abs(arehom(na2k)))
+ endif
+ write (ulsort,texte(langue,8)) na1k, na1j
+ write (ulsort,texte(langue,9))
+ > na1k, somare(1,na1k), somare(2,na1k)
+ write (ulsort,texte(langue,9))
+ > na1j, somare(1,na1j), somare(2,na1j)
+ codret = 2
+c
+ endif
+c
+ endif
+c
+ endif
+c
+ 21 continue
+c
+c====
+c 3. 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
