src/tool/Modification/mmagr4.F

   1       subroutine mmagr4 ( nbte06, tbaux5, tbaux6,
   2      >                    aretri,
   3      >                    tritet, cotrte,
   4      >                    famtet, cfatet,
   5      >                    ulsort, langue, codret )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c    Modification de Maillage - AGRegat - phase 4
  27 c    -               -          ---             -
  28 c    On marque chaque triangle et chaque arete avec la famille MED
  29 c    du tetraedre voisin. Quand une arete ou un triangle est voisin
  30 c    de deux familles differentes, la derniere valeur est gardee
  31 c    mais peu importe car ces aretes/triangles sont ailleurs
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . nbte06 . e   .   1    . nombre de tetr. des j. ponctuels d'ordre 6 .
  37 c . tbaux5 .  s  . nbarto . numero MED du volume de l'arete            .
  38 c . tbaux6 .  s  . nbtrto . numero MED du volume du triangle           .
  39 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  40 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  41 c . famtet . e   . nbteto . famille des tetraedres                     .
  42 c . cfatet . e   . nctfte. codes des familles des tetraedres           .
  43 c .        .     . nbftet .   1 : famille MED                          .
  44 c .        .     .        .   2 : type de tetraedres                   .
  45 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  46 c . langue . e   .    1   . langue des messages                        .
  47 c .        .     .        . 1 : francais, 2 : anglais                  .
  48 c . codret . es  .    1   . code de retour des modules                 .
  49 c .        .     .        . 0 : pas de probleme                        .
  50 c ______________________________________________________________________
  51 c
  52 c====
  53 c 0. declarations et dimensionnement
  54 c====
  55 c
  56 c 0.1. ==> generalites
  57 c
  58       implicit none
  59       save
  60 c
  61       character*6 nompro
  62       parameter ( nompro = 'MMAGR4' )
  63 c
  64 #include "nblang.h"
  65 c
  66 c 0.2. ==> communs
  67 c
  68 #include "envex1.h"
  69 c
  70 #include "coftex.h"
  71 #include "nbfami.h"
  72 #include "dicfen.h"
  73 #include "nombar.h"
  74 #include "nombtr.h"
  75 #include "nombte.h"
  76 #include "impr02.h"
  77 c
  78 c 0.3. ==> arguments
  79 c
  80       integer nbte06
  81       integer tbaux5(nbarto), tbaux6(nbtrto)
  82       integer aretri(nbtrto,3)
  83       integer tritet(nbtecf,4), cotrte(nbtecf,4)
  84       integer famtet(nbteto), cfatet(nctfte,nbftet)
  85 c
  86       integer ulsort, langue, codret
  87 c
  88 c 0.4. ==> variables locales
  89 c
  90       integer iaux, jaux, kaux
  91 c
  92       integer letetr
  93       integer listar(6)
  94       integer fammed
  95 c
  96       integer nbmess
  97       parameter ( nbmess = 30 )
  98       character*80 texte(nblang,nbmess)
  99 c
 100 c 0.5. ==> initialisations
 101 c ______________________________________________________________________
 102 c
 103 c====
 104 c 1. initialisations
 105 c====
 106 c 1.1. ==> messages
 107 c
 108 #include "impr01.h"
 109 c
 110 #ifdef _DEBUG_HOMARD_
 111       write (ulsort,texte(langue,1)) 'Entree', nompro
 112       call dmflsh (iaux)
 113 #endif
 114 c
 115 #include "mmag01.h"
 116 c
 117 c 1.2. ==> rien au depart
 118 c
 119       do 121 , iaux = 1 , nbarto
 120         tbaux5(iaux) = 0
 121   121 continue
 122       do 122 , iaux = 1 , nbtrto
 123         tbaux6(iaux) = 0
 124   122 continue
 125 c
 126       codret = 0
 127 c
 128 c====
 129 c 2. Parcours des tetraedres
 130 c====
 131 #ifdef _DEBUG_HOMARD_
 132       write (ulsort,texte(langue,5)) mess14(langue,3,3)
 133 #endif
 134 c
 135       kaux = nbteto - nbte06
 136 c
 137       do 21 , iaux = 1 , kaux
 138 c
 139         letetr = iaux
 140 c
 141 #ifdef _DEBUG_HOMARD_
 142       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,3), letetr
 143 #endif
 144 c
 145 #ifdef _DEBUG_HOMARD_
 146       write (ulsort,texte(langue,3)) 'UTARTE', nompro
 147 #endif
 148         call utarte ( letetr,
 149      >                nbtrto, nbtecf,
 150      >                aretri, tritet, cotrte,
 151      >                listar )
 152 c
 153         fammed = cfatet(cofamd,famtet(letetr))
 154 cgn        write(ulsort,*) fammed
 155         do 211 , jaux = 1 , 6
 156           tbaux5(listar(jaux)) = fammed
 157   211   continue
 158         do 212 , jaux = 1 , 4
 159           tbaux6(tritet(letetr,jaux)) = fammed
 160   212   continue
 161 c
 162    21 continue
 163 c
 164 c====
 165 c 3. la fin
 166 c====
 167 c
 168       if ( codret.ne.0 ) then
 169 c
 170 #include "envex2.h"
 171 c
 172       write (ulsort,texte(langue,1)) 'Sortie', nompro
 173       write (ulsort,texte(langue,2)) codret
 174 c
 175       endif
 176 c
 177 #ifdef _DEBUG_HOMARD_
 178       write (ulsort,texte(langue,1)) 'Sortie', nompro
 179       call dmflsh (iaux)
 180 #endif
 181 c
 182       end