src/tool/Utilitaire/uthcai.F

   1       subroutine uthcai ( lehexa, bindec,
   2      >                    aretri,
   3      >                    arequa,
   4      >                    quahex, coquhe, arehex,
   5      >                    filhex, fhpyte,
   6      >                    tritet, cotrte, aretet,
   7      >                    facpyr, cofapy, arepyr,
   8      >                    areint )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c     UTilitaire : Hexaedre coupe par Conformite - Aretes Internes
  30 c     --           -                  -            -      -
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . lehexa . e   .  1     . numero de l'hexaedre a examiner            .
  36 c . bindec . e   .  1     . binaire du decoupage                       .
  37 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  38 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  39 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  40 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  41 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  42 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  43 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  44 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  45 c . filhex . e   . nbheto . premier fils des hexaedres                 .
  46 c . fhpyte . e   .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide   .
  47 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
  48 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
  49 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
  50 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  51 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  52 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  53 c . areint .  s  . nbarhi . les aretes internes a l'hexaedre           .
  54 c .____________________________________________________________________.
  55 c
  56 c====
  57 c 0. declarations et dimensionnement
  58 c====
  59 c
  60 c 0.1. ==> generalites
  61 c
  62       implicit none
  63       save
  64 c
  65 c 0.2. ==> communs
  66 c
  67 #include "nombar.h"
  68 #include "nombtr.h"
  69 #include "nombqu.h"
  70 #include "nombhe.h"
  71 #include "nombpy.h"
  72 #include "nombte.h"
  73 #include "hexcf0.h"
  74 c
  75 c 0.3. ==> arguments
  76 c
  77       integer lehexa, bindec
  78       integer aretri(nbtrto,3)
  79       integer arequa(nbquto,4)
  80       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
  81       integer filhex(nbheto), fhpyte(2,nbheco)
  82       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
  83       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
  84       integer areint(*)
  85 c
  86 c 0.4. ==> variables locales
  87 c
  88       integer iaux, jaux, kaux
  89       integer f1hp, lequad
  90       integer listar(12), listaf(12)
  91       integer nbarmx, nbarhi
  92       integer nbfipy, filspy
  93       integer nbfite, filste
  94       integer nbfihe, filshe
  95 c
  96 #include "impr03.h"
  97 c
  98 c====
  99 c 1. Les aretes externes de l'hexaedre
 100 c====
 101 c
 102       call utarhe ( lehexa,
 103      >              nbquto, nbhecf,
 104      >              arequa, quahex, coquhe,
 105      >              listar )
 106 c
 107 c====
 108 c 2. Les aretes internes de l'hexaedre
 109 c    On examine les aretes de chaque fils. Si elle est interne, on
 110 c    l'ajoute a la liste. On s'arrete quand le compte est bon
 111 c====
 112 c
 113       nbarmx = nbarto - nbarin
 114       nbarhi = 0
 115 c
 116 c 2.1. ==> nombre de fils
 117 c
 118       nbfihe = chnhe(bindec)
 119       nbfipy = chnpy(bindec)
 120       nbfite = chnte(bindec)
 121 #ifdef _DEBUG_HOMARD_
 122       write (*,90002) 'bindec', bindec
 123       write (*,90002) 'nbfihe', nbfihe
 124       write (*,90002) 'nbfipy', nbfipy
 125       write (*,90002) 'nbfite', nbfite
 126 #endif
 127 c
 128       f1hp = filhex(lehexa)
 129 cgn      write (*,90002) 'f1hp', f1hp
 130 c
 131 c 2.2. ==> Examen des pyramides
 132 c
 133       if ( nbfipy.ne.0 ) then
 134 c
 135         filspy = fhpyte(1,-f1hp)
 136 cgn        write (*,90002) 'filspy', bindec
 137         do 22 , kaux = 1 , nbfipy
 138 #ifdef _DEBUG_HOMARD_
 139           write (*,90002) '. Pyramide', filspy
 140 #endif
 141           if ( filspy.le.nbpycf ) then
 142             call utarpy ( filspy,
 143      >                    nbtrto, nbpycf,
 144      >                    aretri, facpyr, cofapy,
 145      >                    listaf )
 146           else
 147             do 221 , iaux = 1 , 8
 148               listaf(iaux) = arepyr(filspy-nbpycf,iaux)
 149   221       continue
 150           endif
 151 c
 152           do 222 , iaux = 1 , 8
 153             if ( listaf(iaux).gt.nbarmx ) then
 154               do 2221 , jaux = 1 , nbarhi
 155                 if ( listaf(iaux).eq.areint(jaux) ) then
 156                   goto 222
 157                 endif
 158  2221         continue
 159               nbarhi = nbarhi + 1
 160               areint(nbarhi) = listaf(iaux)
 161               if ( nbarhi.eq.chnar(bindec) ) then
 162                 goto 9999
 163               endif
 164             endif
 165   222     continue
 166 c
 167           filspy = filspy + 1
 168 c
 169    22   continue
 170 c
 171       endif
 172 c
 173 c 2.3. ==> Examen des tetraedres
 174 c
 175       if ( nbfite.ne.0 ) then
 176 c
 177         filste = fhpyte(2,-f1hp)
 178         do 23 , kaux = 1 , nbfite
 179 #ifdef _DEBUG_HOMARD_
 180           write (*,90002) '. Tetraedre', filste
 181 #endif
 182           if ( filste.le.nbtecf ) then
 183             call utarte ( filste,
 184      >                    nbtrto, nbtecf,
 185      >                    aretri, tritet, cotrte,
 186      >                    listaf )
 187           else
 188             do 231 , iaux = 1 , 4
 189               listaf(iaux) = aretet(filste-nbtecf,iaux)
 190   231       continue
 191           endif
 192 c
 193           do 232 , iaux = 1 , 4
 194             if ( listaf(iaux).gt.nbarmx ) then
 195               do 2321 , jaux = 1 , nbarhi
 196                 if ( listaf(iaux).eq.areint(jaux) ) then
 197                   goto 232
 198                 endif
 199  2321         continue
 200               nbarhi = nbarhi + 1
 201               areint(nbarhi) = listaf(iaux)
 202               if ( nbarhi.eq.chnar(bindec) ) then
 203                 goto 9999
 204               endif
 205             endif
 206   232     continue
 207 c
 208           filste = filste + 1
 209 c
 210    23   continue
 211 c
 212       endif
 213 c
 214 c 2.4. ==> Examen des hexaedres
 215 c 2.4.1. ==> Cas du decoupage en 8
 216 c
 217       if ( bindec.eq.4095 ) then
 218 #ifdef _DEBUG_HOMARD_
 219           write (*,*) '. Hexaedre coupe en 8'
 220 #endif
 221 c
 222         do 241 , iaux = 1 , 6
 223 c
 224           if ( iaux.eq.1) then
 225             lequad = quahex(f1hp,5)
 226           elseif ( iaux.eq.2) then
 227             lequad = quahex(f1hp,4)
 228           elseif ( iaux.eq.3) then
 229             lequad = quahex(f1hp,6)
 230           elseif ( iaux.eq.4) then
 231             lequad = quahex(f1hp+7,1)
 232           elseif ( iaux.eq.5) then
 233             lequad = quahex(f1hp+7,3)
 234           else
 235             lequad = quahex(f1hp+7,2)
 236           endif
 237           nbarhi = nbarhi + 1
 238           areint(nbarhi) = arequa(lequad,2)
 239 c
 240   241   continue
 241 c
 242 c 2.4.2. ==> Cas du decoupage de conformite
 243 c
 244       else
 245 c
 246         filshe = f1hp
 247         do 242 , kaux = 1 , nbfihe
 248 #ifdef _DEBUG_HOMARD_
 249           write (*,90002) '. Hexaedre', filshe
 250 #endif
 251           if ( filshe.le.nbhecf ) then
 252             call utarhe ( filshe,
 253      >                    nbquto, nbhecf,
 254      >                    arequa, quahex, coquhe,
 255      >                    listaf )
 256           else
 257             do 2421 , iaux = 1 , 12
 258               listaf(iaux) = arehex(filshe-nbhecf,iaux)
 259  2421       continue
 260           endif
 261 c
 262           do 2422 , iaux = 1 , 12
 263             if ( listaf(iaux).gt.nbarmx ) then
 264               do 24221 , jaux = 1 , nbarhi
 265                 if ( listaf(iaux).eq.areint(jaux) ) then
 266                   goto 2422
 267                 endif
 268 24221         continue
 269               nbarhi = nbarhi + 1
 270               areint(nbarhi) = listaf(iaux)
 271               if ( nbarhi.eq.chnar(bindec) ) then
 272                 goto 9999
 273               endif
 274             endif
 275  2422     continue
 276 c
 277           filshe = filshe + 1
 278 c
 279   242   continue
 280 c
 281       endif
 282 c
 283  9999 continue
 284 #ifdef _DEBUG_HOMARD_
 285           write (*,90002) '. Nombre d''aretes internes', nbarhi
 286 #endif
 287 c
 288       end