src/tool/Creation_Maillage/cmrdtr.F

   1       subroutine cmrdtr ( somare, hetare, filare, merare,
   2      >                    aretri, hettri, filtri, pertri,
   3      >                    nivtri, decfac,
   4      >                    famare, famtri,
   5      >                    indare, indtri,
   6      >                    cfatri,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c    Creation du Maillage - Raffinement - Decoupage des TRiangles
  29 c    -           -          -             -             --
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  35 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  36 c . filare . es  . nouvar . premiere fille des aretes                  .
  37 c . merare . es  . nouvar . mere des aretes                            .
  38 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  39 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  40 c . filtri . es  . nouvtr . premier fils des triangles                 .
  41 c . pertri . es  . nouvtr . pere des triangles                         .
  42 c . nivtri . es  . nouvtr . niveau des triangles                       .
  43 c . decfac . es  . -nouvqu. decision sur les faces (quad. + tri.)      .
  44 c .        .     . :nouvtr.                                            .
  45 c . famare .     . nouvar . famille des aretes                         .
  46 c . famtri . es  . nouvtr . famille des triangles                      .
  47 c . indare . es  . 1      . indice de la derniere arete creee          .
  48 c . indtri . es  . 1      . indice du dernier triangle cree            .
  49 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  50 c .        .     . nbftri .   1 : famille MED                          .
  51 c .        .     .        .   2 : type de triangle                     .
  52 c .        .     .        .   3 : numero de surface de frontiere       .
  53 c .        .     .        .   4 : famille des aretes internes apres raf.
  54 c .        .     .        . + l : appartenance a l'equivalence l       .
  55 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  56 c . langue . e   .    1   . langue des messages                        .
  57 c .        .     .        . 1 : francais, 2 : anglais                  .
  58 c . codret . es  .    1   . code de retour des modules                 .
  59 c .        .     .        . 0 : pas de probleme                        .
  60 c ______________________________________________________________________
  61 c
  62 c====
  63 c 0. declarations et dimensionnement
  64 c====
  65 c
  66 c 0.1. ==> generalites
  67 c
  68       implicit none
  69       save
  70 c
  71       character*6 nompro
  72       parameter ( nompro = 'CMRDTR' )
  73 c
  74 #include "nblang.h"
  75 #include "cofatq.h"
  76 c
  77 c 0.2. ==> communs
  78 c
  79 #include "envex1.h"
  80 #include "nombtr.h"
  81 #include "nouvnb.h"
  82 #include "dicfen.h"
  83 #include "nbfami.h"
  84 c
  85 c 0.3. ==> arguments
  86 c
  87       integer decfac(-nouvqu:nouvtr)
  88       integer somare(2,nouvar), hetare(nouvar), filare(nouvar)
  89       integer merare(nouvar), aretri(nouvtr,3), hettri(nouvtr)
  90       integer filtri(nouvtr), pertri(nouvtr), nivtri(nouvtr)
  91       integer famare(nouvar), famtri(nouvtr)
  92       integer indare, indtri
  93       integer cfatri(nctftr,nbftri)
  94 c
  95       integer ulsort, langue, codret
  96 c
  97 c 0.4. ==> variables locales
  98 c
  99       integer fammer, letria
 100       integer n1, n2, n3, as1s2, as1s3, as2s3
 101       integer as1n2, as1n3, as2n1, as2n3, as3n1, as3n2
 102       integer af1, af2, af3, etat, nf, nf1, nf2, nf3, niv
 103       integer lepere
 104       integer iaux
 105 c
 106       integer nbmess
 107       parameter ( nbmess = 10 )
 108       character*80 texte(nblang,nbmess)
 109 c
 110 c 0.5. ==> initialisations
 111 c ______________________________________________________________________
 112 c
 113 c====
 114 c 1. preliminaires
 115 c====
 116 c
 117 #include "impr01.h"
 118 c
 119 #ifdef _DEBUG_HOMARD_
 120       write (ulsort,texte(langue,1)) 'Entree', nompro
 121       call dmflsh (iaux)
 122 #endif
 123 c
 124       texte(1,4) = '(''Decoupage du triangle'',i10)'
 125 c
 126       texte(2,4) = '(''Splitting of triangle #'',i10)'
 127 c
 128 #include "impr03.h"
 129 c
 130 c====
 131 c 1. decoupage en 4 des triangles de decision 4
 132 c====
 133 c
 134 cgn      print *,'indtri',indtri
 135 cgn      print *,'indare',indare
 136       do 100 , letria = 1 , nbtrpe
 137 cgn      print *,letria,decfac(letria)
 138 c
 139         if ( decfac(letria).eq.4 ) then
 140 #ifdef _DEBUG_HOMARD_
 141       write (ulsort,texte(langue,4)) letria
 142 #endif
 143 c
 144 c 1.1. ==> determination des numeros d'aretes
 145 c
 146           as2s3 = aretri(letria,1)
 147           as1s3 = aretri(letria,2)
 148           as1s2 = aretri(letria,3)
 149 cgn      write (ulsort,90002)'.. indqua',indqua
 150 cgn      write (ulsort,90002)'.. indare',indare
 151 cgn      write (ulsort,90002)'.. aretes     ',as2s3,as1s3,as1s2
 152 cgn      write (ulsort,90002)'.. de filles  ',filare(as2s3),
 153 cgn     >                    filare(as1s3),filare(as1s2)
 154 c
 155 c 1.2. ==> determination des 6 demi-aretes filles des precedentes
 156 c
 157           call utaftr ( somare, filare, as2s3, as1s3, as1s2,
 158      >                  as2n1, as3n1,
 159      >                  as3n2, as1n2,
 160      >                  as1n3, as2n3 )
 161 c
 162 c 1.3. ==> determination des noeuds milieux
 163 c
 164           n1 = somare(2,as2n1)
 165           n2 = somare(2,as1n2)
 166           n3 = somare(2,as1n3)
 167 c
 168 c 1.4. ==> creation des aretes internes
 169 c
 170 c 1.4.1. ==> leurs numeros
 171 c
 172           af1 = indare + 1
 173           af2 = indare + 2
 174           af3 = indare + 3
 175           indare = af3
 176 c
 177 c 1.4.2. ==> les numeros de leurs sommets avec la convention ad'hoc
 178 c
 179           somare(1,af1) = min ( n2 , n3 )
 180           somare(2,af1) = max ( n2 , n3 )
 181           somare(1,af2) = min ( n1 , n3 )
 182           somare(2,af2) = max ( n1 , n3 )
 183           somare(1,af3) = min ( n1 , n2 )
 184           somare(2,af3) = max ( n1 , n2 )
 185 c
 186 c 1.4.3. ==> leur famille
 187 c
 188 cgn      write(ulsort,90002) 'famtri(letria)',famtri(letria)
 189 cgn      write(ulsort,90002) 'avec cfatri',
 190 cgn     >(cfatri(iaux,famtri(letria)),iaux=1,nctftr)
 191 cgn      write(ulsort,90002) '==> famare', cfatri(cofafa,famtri(letria))
 192           iaux = cfatri(cofafa,famtri(letria))
 193           famare(af1) = iaux
 194           famare(af2) = iaux
 195           famare(af3) = iaux
 196 c
 197 c 1.4.4. ==> la parente
 198 c
 199           hetare(af1) = 50
 200           hetare(af2) = 50
 201           hetare(af3) = 50
 202           merare(af1) = 0
 203           merare(af2) = 0
 204           merare(af3) = 0
 205           filare(af1) = 0
 206           filare(af2) = 0
 207           filare(af3) = 0
 208 c
 209 c 1.5. ==> creation des 4 triangles fils
 210 c
 211 c         triangle central : nf
 212 c
 213           nf = indtri + 1
 214           aretri(nf,1) = af1
 215           aretri(nf,2) = af2
 216           aretri(nf,3) = af3
 217 c
 218 c         triangle : nf + 1
 219 c
 220           nf1 = nf + 1
 221           aretri(nf1,1) = af1
 222           aretri(nf1,2) = as1n2
 223           aretri(nf1,3) = as1n3
 224 c
 225 c         triangle : nf + 2
 226 c
 227           nf2 = nf + 2
 228           aretri(nf2,1) = as2n1
 229           aretri(nf2,2) = af2
 230           aretri(nf2,3) = as2n3
 231 c
 232 c         triangle : nf + 3
 233 c
 234           nf3 = nf + 3
 235           aretri(nf3,1) = as3n1
 236           aretri(nf3,2) = as3n2
 237           aretri(nf3,3) = af3
 238 c
 239           indtri = nf + 3
 240 c
 241 c 1.6. ==> mise a jour de la famille des 4 triangles fils
 242 c
 243           fammer = famtri(letria)
 244           famtri(nf)  = fammer
 245           famtri(nf1) = fammer
 246           famtri(nf2) = fammer
 247           famtri(nf3) = fammer
 248 c
 249           hettri(nf)  = 50
 250           hettri(nf1) = 50
 251           hettri(nf2) = 50
 252           hettri(nf3) = 50
 253           filtri(nf)  = 0
 254           filtri(nf1) = 0
 255           filtri(nf2) = 0
 256           filtri(nf3) = 0
 257           pertri(nf)  = letria
 258           pertri(nf1) = letria
 259           pertri(nf2) = letria
 260           pertri(nf3) = letria
 261           niv = nivtri(letria) + 1
 262           nivtri(nf)  = niv
 263           nivtri(nf1) = niv
 264           nivtri(nf2) = niv
 265           nivtri(nf3) = niv
 266 c
 267 c 1.7. ==> mise a jour du pere et du grand-pere eventuel
 268 c Remarque : si on est parti d'un macro-maillage non conforme,
 269 c            certains triangles ont des peres adoptifs de numero
 270 c            negatif. Il ne faut pas changer leur etat
 271 c            Le cas des peres negatif parce que quadrangle de conformite
 272 c            n'existe plus a ce stade : ces triangles ont ete detruits
 273 c            en amont
 274 c
 275           filtri(letria) = nf
 276           hettri(letria) = hettri(letria) + 4
 277           lepere = pertri(letria)
 278           if ( lepere.gt.0 ) then
 279             etat = hettri(lepere)
 280             hettri(lepere) = etat - mod(etat,10) + 9
 281           endif
 282 c
 283         endif
 284 c
 285   100 continue
 286 cgn      print *,'indtri',indtri
 287 cgn      print *,'indare',indare
 288 c
 289 c====
 290 c 2. la fin
 291 c====
 292 c
 293       if ( codret.ne.0 ) then
 294 c
 295 #include "envex2.h"
 296 c
 297       write (ulsort,texte(langue,1)) 'Sortie', nompro
 298       write (ulsort,texte(langue,2)) codret
 299 c
 300       endif
 301 c
 302 #ifdef _DEBUG_HOMARD_
 303       write (ulsort,texte(langue,1)) 'Sortie', nompro
 304       call dmflsh (iaux)
 305 #endif
 306 c
 307       end