src/tool/Creation_Maillage/cmhomq.F

   1       subroutine cmhomq ( noehom, arehom, trihom, quahom,
   2      >                    somare, aretri,
   3      >                    arequa, filqua, hetqua,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  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
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    Creation du Maillage - HOMologues - les Quadrangles
  26 c    -           -          ---              -
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . noehom . es  . nbnoto . ensemble des noeuds homologues             .
  32 c . arehom . es  . nbarto . ensemble des aretes homologues             .
  33 c . trihom . es  . nbtrto . ensemble des triangles homologues          .
  34 c . quahom . es  . nbquto . ensemble des quadrangles homologues        .
  35 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  36 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  37 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  38 c . filqua . e   . nbquto . premier fils des quadrangles               .
  39 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  40 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  41 c . langue . e   .    1   . langue des messages                        .
  42 c .        .     .        . 1 : francais, 2 : anglais                  .
  43 c . codret . es  .    1   . code de retour des modules                 .
  44 c .        .     .        . 0 : pas de probleme                        .
  45 c ______________________________________________________________________
  46 c
  47 c====
  48 c 0. declarations et dimensionnement
  49 c====
  50 c
  51 c 0.1. ==> generalites
  52 c
  53       implicit none
  54       save
  55 c
  56       character*6 nompro
  57       parameter ( nompro = 'CMHOMQ' )
  58 c
  59 #include "nblang.h"
  60 c
  61 c 0.2. ==> communs
  62 c
  63 #include "envex1.h"
  64 c
  65 #include "ope1a4.h"
  66 #include "nombno.h"
  67 #include "nombar.h"
  68 #include "nombtr.h"
  69 #include "nombqu.h"
  70 #include "impr02.h"
  71 c
  72 c 0.3. ==> arguments
  73 c
  74       integer noehom(nbnoto), arehom(nbarto)
  75       integer trihom(nbtrto), quahom(nbquto)
  76       integer somare(2,nbarto), aretri(nbtrto,3)
  77       integer arequa(nbquto,4), filqua(nbquto), hetqua(nbquto)
  78 c
  79       integer ulsort, langue, codret
  80 c
  81 c 0.4. ==> variables locales
  82 c
  83       integer iaux
  84       integer lequad
  85       integer fach
  86       integer hist, etafac
  87       integer a2(4), n2f1(4), a2nin0(4), n20
  88       integer a1(4), n1f1(4), a1nin0(4), n10
  89       integer perma1, perma2
  90 c
  91       integer nbmess
  92       parameter ( nbmess = 10 )
  93       character*80 texte(nblang,nbmess)
  94 c
  95 c 0.5. ==> initialisations
  96 c ______________________________________________________________________
  97 c
  98 c====
  99 c 1. initialisations
 100 c====
 101 c
 102 #include "impr01.h"
 103 c
 104 #ifdef _DEBUG_HOMARD_
 105       write (ulsort,texte(langue,1)) 'Entree', nompro
 106       call dmflsh (iaux)
 107 #endif
 108 c
 109       texte(1,4) = '(''Etat du '',a,i10,'' : '',i4)'
 110       texte(1,5) = '(/,''Les deux '',a,'' homologues'',2i10)'
 111       texte(1,6) = '(''devraient etre coupes en 3.'')'
 112       texte(1,7) = '(''Il faudrait l''''arete'',i10,'' ou '',i10)'
 113       texte(1,9) = '(''Arete'',i10,'' de sommets'',2i10)'
 114       texte(1,10) = '(5x,''Erreur sur les '',a,'' homologues.'')'
 115 c
 116       texte(2,4) = '(''State of '',a,'' #'',i10,'' : '',i4)'
 117       texte(2,5) = '(/,''The two homologous '',a,'' #'',i10)'
 118       texte(2,6) = '(''should be cut into 3.'')'
 119       texte(2,7) = '(''It should be edge #'',i10,'' or #'',i10)'
 120       texte(2,9) = '(''Edge #'',i10,'' with vertices #'',2i10)'
 121       texte(2,10) = '(5x,''Error for homologous '',a)'
 122 c
 123 cgn 1788   format(a,i6,' : ',10i6)
 124 cgn 1789   format(10i6)
 125 cgn      write(ulsort,*)'hetqua'
 126 cgn      write(ulsort,1789)hetqua
 127 cgn      write(ulsort,*)'filqua'
 128 cgn      write(ulsort,1789)filqua
 129 cgn      write(ulsort,*)'noehom'
 130 cgn      write(ulsort,1789)noehom
 131 cgn      write(ulsort,*)'arehom'
 132 cgn      write(ulsort,1789)arehom
 133 cgn      write(ulsort,*)'trihom'
 134 cgn      write(ulsort,1789)trihom
 135 cgn      write(ulsort,*)'quahom'
 136 cgn      write(ulsort,1789)quahom
 137 c====
 138 c 2. on boucle uniquement sur les quadrangles de la face periodique 2
 139 c    qui viennent d'etre decoupes en 2 ou en 4 quadrangles ou en
 140 c    3 triangles
 141 c    on se rapportera a cmrdqu pour les conventions
 142 c====
 143 c
 144       do 21, lequad = 1, nbqupe
 145 c
 146         if ( codret.eq.0 ) then
 147 c
 148         if ( quahom(lequad).gt.0 ) then
 149 c
 150           fach = abs(quahom(lequad))
 151 c
 152           hist = hetqua(lequad)
 153           etafac = mod ( hist, 100 )
 154 cgn      write(ulsort,*)'lequad, hist, etafac = ',lequad, hist,etafac
 155 c
 156           if ( etafac.eq.4 ) then
 157 c
 158 c 2.1. ==> le quadrangle vient d'etre decoupe en 4
 159 c
 160 c 2.1.1. ==> infos sur lequad et ses fils
 161 c
 162             a2(1) = arequa(lequad,1)
 163             a2(2) = arequa(lequad,2)
 164             a2(3) = arequa(lequad,3)
 165             a2(4) = arequa(lequad,4)
 166 c
 167             n2f1(1) = filqua(lequad)
 168             n2f1(2) = n2f1(1) + 1
 169             n2f1(3) = n2f1(2) + 1
 170             n2f1(4) = n2f1(3) + 1
 171             a2nin0(1) = arequa(n2f1(1),2)
 172             a2nin0(2) = arequa(n2f1(2),2)
 173             a2nin0(3) = arequa(n2f1(3),2)
 174             a2nin0(4) = arequa(n2f1(4),2)
 175             n20 = somare(2,a2nin0(1))
 176 c
 177 c 2.1.2. ==> infos sur l'homologue de lequad et ses fils
 178 c
 179             a1(1) = arequa(fach,1)
 180             a1(2) = arequa(fach,2)
 181             a1(3) = arequa(fach,3)
 182             a1(4) = arequa(fach,4)
 183 c
 184             n1f1(1) = filqua(fach)
 185             n1f1(2) = n1f1(1) + 1
 186             n1f1(3) = n1f1(2) + 1
 187             n1f1(4) = n1f1(3) + 1
 188             a1nin0(1) = arequa(n1f1(1),2)
 189             a1nin0(2) = arequa(n1f1(2),2)
 190             a1nin0(3) = arequa(n1f1(3),2)
 191             a1nin0(4) = arequa(n1f1(4),2)
 192             n10 = somare(2,a1nin0(1))
 193 c
 194 cgn      write(ulsort,*) 'face 2'
 195 cgn      write(ulsort,1789) a2(1), a2(2), a2(3), a2(4)
 196 cgn      write(ulsort,1789) n2f1
 197 cgn      write(ulsort,1789) a2nin0
 198 cgn      write(ulsort,1789) n20
 199 cgn      write(ulsort,*) 'face 1'
 200 cgn      write(ulsort,1789) a1(1), a1(2), a1(3), a1(4)
 201 cgn      write(ulsort,1789) n1f1
 202 cgn      write(ulsort,1789) a1nin0
 203 cgn      write(ulsort,1789) n10
 204 c
 205 c 2.1.3.  ==> reperage des homologues
 206 c
 207 c 2.1.3.1. ==> recherche du positionnement relatif des deux quadrangles
 208 c              peres homologues
 209 c        perma1 : numero de la permutation sur les aretes a1(1) et a1(3)
 210 c        perma2 : numero de la permutation sur les aretes a1(2) et a1(4)
 211 c
 212 c                 a1(4)                     a2(4)
 213 c             .________.              .________.
 214 c             .        .              .        .
 215 c             .        .              .        .
 216 c          a1(1).        .a1(3)        a2(1).        .a2(3)
 217 c             .        .              .        .
 218 c             .________.              .________.
 219 c                 a1(2)                     a2(2)
 220 c
 221             perma1 = 100
 222             perma2 = 100
 223 c
 224             if ( arehom(a2(1)).eq.a1(1) ) then
 225               perma1 = 0
 226               if ( arehom(a2(2)).eq.a1(2) ) then
 227                 perma2 = 0
 228               elseif ( arehom(a2(2)).eq.a1(4) ) then
 229                 perma2 = 2
 230               endif
 231 c
 232             elseif ( arehom(a2(1)).eq.a1(2) ) then
 233               perma1 = 1
 234               if ( arehom(a2(2)).eq.a1(3) ) then
 235                 perma2 = 1
 236               elseif ( arehom(a2(2)).eq.a1(1) ) then
 237                 perma2 = 3
 238               endif
 239 c
 240             elseif ( arehom(a2(1)).eq.a1(3) ) then
 241               perma1 = 2
 242               if ( arehom(a2(2)).eq.a1(4) ) then
 243                 perma2 = 2
 244               elseif ( arehom(a2(2)).eq.a1(2) ) then
 245                 perma2 = 4
 246               endif
 247 c
 248             elseif ( arehom(a2(1)).eq.a1(4) ) then
 249               perma1 = 3
 250               if ( arehom(a2(2)).eq.a1(1) ) then
 251                 perma2 = 3
 252               elseif ( arehom(a2(2)).eq.a1(3) ) then
 253                 perma2 = 1
 254               endif
 255 c
 256             endif
 257 c
 258             if ( perma1.eq.100 .or. perma2.eq.100 ) then
 259 c
 260               write (ulsort,texte(langue,5)) mess14(langue,3,4),
 261      >                                       lequad, fach
 262               write (ulsort,texte(langue,9)) a2(1),
 263      >                              somare(1,a2(1)), somare(2,a2(1))
 264               write (ulsort,texte(langue,9)) a2(1), arehom(a2(1))
 265               codret = 2
 266 c
 267             endif
 268 cgn      write(ulsort,*)'perma1, perma2',perma1, perma2
 269 c
 270 c 2.1.3.2. ==> remplissage des tables
 271 c
 272             if ( codret.eq.0 ) then
 273 c
 274             iaux = per1a4(perma1,1)
 275             quahom(n2f1(1)) = n1f1(iaux)
 276             quahom(n1f1(iaux)) = -n2f1(1)
 277             arehom(a2nin0(1)) = a1nin0(iaux)
 278             arehom(a1nin0(iaux)) = -a2nin0(1)
 279 c
 280             iaux = per1a4(perma2,2)
 281             quahom(n2f1(2)) = n1f1(iaux)
 282             quahom(n1f1(iaux)) = -n2f1(2)
 283             arehom(a2nin0(2)) = a1nin0(iaux)
 284             arehom(a1nin0(iaux)) = -a2nin0(2)
 285 c
 286             iaux = per1a4(perma1,3)
 287             quahom(n2f1(3)) = n1f1(iaux)
 288             quahom(n1f1(iaux)) = -n2f1(3)
 289             arehom(a2nin0(3)) = a1nin0(iaux)
 290             arehom(a1nin0(iaux)) = -a2nin0(3)
 291 c
 292             iaux = per1a4(perma2,4)
 293             quahom(n2f1(4)) = n1f1(iaux)
 294             quahom(n1f1(iaux)) = -n2f1(4)
 295             arehom(a2nin0(4)) = a1nin0(iaux)
 296             arehom(a1nin0(iaux)) = -a2nin0(4)
 297 c
 298             noehom(n20) = n10
 299             noehom(n10) = -n20
 300 c
 301             endif
 302 c
 303           elseif ( etafac.eq.31 .or. etafac.eq.32 .or.
 304      >             etafac.eq.33 .or. etafac.eq.34 ) then
 305 c
 306 c 2.2. ==> le quadrangle vient d'etre decoupe en 3 triangles
 307 c
 308 c 2.2.1. ==> infos sur lequad et ses fils
 309 c
 310             n2f1(1) = -filqua(lequad)
 311             n2f1(2) = n2f1(1) + 1
 312             n2f1(3) = n2f1(2) + 1
 313             a2nin0(1) = aretri(n2f1(1),1)
 314             a2nin0(2) = aretri(n2f1(1),3)
 315             a2nin0(3) = aretri(n2f1(2),1)
 316 c
 317 c 2.2.2. ==> infos sur l'homologue de lequad et ses fils
 318 c
 319             n1f1(1) = -filqua(fach)
 320             n1f1(2) = n1f1(1) + 1
 321             n1f1(3) = n1f1(2) + 1
 322             a1nin0(1) = aretri(n1f1(1),1)
 323             a1nin0(2) = aretri(n1f1(1),3)
 324             a1nin0(3) = aretri(n1f1(2),1)
 325             a1nin0(4) = aretri(n1f1(3),1)
 326 c
 327 cgn      write(ulsort,*) 'face 2'
 328 cgn      write(ulsort,1788) 'fils de ',lequad,n2f1(1), n2f1(2), n2f1(3)
 329 cgn      write(ulsort,1788) 'aretes des fils de ',lequad,
 330 cgn     >                   a2nin0(1), a2nin0(2), a2nin0(3)
 331 cgn      write(ulsort,*) 'face 1'
 332 cgn      write(ulsort,1788) 'fils de ',fach,n1f1(1), n1f1(2), n1f1(3)
 333 cgn      write(ulsort,1788) 'aretes des fils de ',fach,
 334 cgn     >                   a1nin0
 335 cgn      write(ulsort,1789) arehom(a2nin0(3))
 336 c
 337 c 2.2.3.  ==> reperage des homologues
 338 c
 339             trihom(n2f1(1)) = n1f1(1)
 340             trihom(n1f1(1)) = -n2f1(1)
 341 c
 342             if ( arehom(a2nin0(3)).eq.a1nin0(3) ) then
 343 c
 344               arehom(a2nin0(1)) = a1nin0(1)
 345               arehom(a1nin0(1)) = -a2nin0(1)
 346               arehom(a2nin0(2)) = a1nin0(2)
 347               arehom(a1nin0(2)) = -a2nin0(2)
 348               trihom(n2f1(2)) = n1f1(2)
 349               trihom(n1f1(2)) = -n2f1(2)
 350               trihom(n2f1(3)) = n1f1(3)
 351               trihom(n1f1(3)) = -n2f1(3)
 352 c
 353             elseif ( arehom(a2nin0(3)).eq.a1nin0(4) ) then
 354 c
 355               arehom(a2nin0(1)) = a1nin0(2)
 356               arehom(a1nin0(2)) = -a2nin0(1)
 357               arehom(a2nin0(2)) = a1nin0(1)
 358               arehom(a1nin0(1)) = -a2nin0(2)
 359               trihom(n2f1(2)) = n1f1(3)
 360               trihom(n1f1(3)) = -n2f1(2)
 361               trihom(n2f1(3)) = n1f1(2)
 362               trihom(n1f1(2)) = -n2f1(3)
 363 c
 364             else
 365 c
 366               write (ulsort,texte(langue,5)) mess14(langue,3,4),
 367      >                                       lequad, fach
 368               write (ulsort,texte(langue,6))
 369               write (ulsort,texte(langue,4)) mess14(langue,1,4),
 370      >                                       lequad, hetqua(lequad)
 371               write (ulsort,texte(langue,4)) mess14(langue,1,4),
 372      >                                       fach, hetqua(fach)
 373               codret = 2
 374 c
 375             endif
 376 c
 377           endif
 378 c
 379         endif
 380 c
 381         endif
 382 c
 383    21 continue
 384 c
 385 c====
 386 c 3. la fin
 387 c====
 388 c
 389       if ( codret.ne.0 ) then
 390 c
 391 #include "envex2.h"
 392 c
 393       write (ulsort,texte(langue,1)) 'Sortie', nompro
 394       write (ulsort,texte(langue,2)) codret
 395 c
 396       endif
 397 c
 398 cgn      write(ulsort,*)'noehom'
 399 cgn      write(ulsort,1789)noehom
 400 cgn      write(ulsort,*)'arehom'
 401 cgn      write(ulsort,1789)arehom
 402 cgn      write(ulsort,*)'trihom'
 403 cgn      write(ulsort,1789)trihom
 404 cgn      write(ulsort,*)'quahom'
 405 cgn      write(ulsort,1789)quahom
 406 #ifdef _DEBUG_HOMARD_
 407       write (ulsort,texte(langue,1)) 'Sortie', nompro
 408       call dmflsh (iaux)
 409 #endif
 410 c
 411       end