src/tool/Utilitaire/utmffa.F

   1       subroutine utmffa ( nomail,
   2      >                    ulsort, langue, codret)
   3 c ______________________________________________________________________
   4 c
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c
  23 c    UTilitaire - passage de Mere a Fille pour les FAces
  24 c    --                      -      -              --
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . nomail . e   . char8  . nom de l'objet maillage homard             .
  30 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  31 c . langue . e   .    1   . langue des messages                        .
  32 c .        .     .        . 1 : francais, 2 : anglais                  .
  33 c . codret . es  .    1   . code de retour des modules                 .
  34 c .        .     .        . 0 : pas de probleme                        .
  35 c .        .     .        . 1 : probleme                               .
  36 c ______________________________________________________________________
  37 c
  38 c====
  39 c 0. declarations et dimensionnement
  40 c====
  41 c
  42 c 0.1. ==> generalites
  43 c
  44       implicit none
  45       save
  46 c
  47       character*6 nompro
  48       parameter ( nompro = 'UTMFFA' )
  49 c
  50 #include "nblang.h"
  51 c
  52 c 0.2. ==> communs
  53 c
  54 #include "envex1.h"
  55 #include "envca1.h"
  56 c
  57 c 0.3. ==> arguments
  58 c
  59       character*8 nomail
  60 c
  61       integer ulsort, langue, codret
  62 c
  63 c 0.4. ==> variables locales
  64 c
  65       integer nbenti(2)
  66       integer iaux, jaux
  67       integer codre1, codre2
  68       integer codre0
  69 c
  70       character*4 saux04(2)
  71       character*8 nhenti(2)
  72 c
  73       integer nbmess
  74       parameter ( nbmess = 10 )
  75       character*80 texte(nblang,nbmess)
  76 c
  77 c 0.5. ==> initialisations
  78 c ______________________________________________________________________
  79 c
  80 c====
  81 c 1. messages
  82 c====
  83 c
  84 #include "impr01.h"
  85 c
  86 #ifdef _DEBUG_HOMARD_
  87       write (ulsort,texte(langue,1)) 'Entree', nompro
  88       call dmflsh (iaux)
  89 #endif
  90 c
  91       texte(1,4) =
  92      > '(''Reperage des fils a partir des peres pour les faces'')'
  93       texte(1,5) = '(''. Type d''''entites   : '',a)'
  94       texte(1,6) = '(''. Nombre d''''entites :'',i10)'
  95 c
  96       texte(2,4) = '(''Son arrays from father arrays for faces'')'
  97       texte(2,5) = '(''. Type of entities  : '',a)'
  98       texte(2,6) = '(''. Number of entities:'',i10)'
  99 c
 100 #ifdef _DEBUG_HOMARD_
 101       write (ulsort,texte(langue,4))
 102 #endif
 103 c
 104 c====
 105 c 2. recuperation des donnees du maillage d'entree
 106 c====
 107 c
 108       call gmliat ( nomail, 3, degre, codre0 )
 109       codret = max ( abs(codre0), codret )
 110 c
 111 c====
 112 c 3. les triangles puis les quadrangles
 113 c====
 114 c
 115 #ifdef _DEBUG_HOMARD_
 116         if ( codret.eq.0 ) then
 117         call gmprsx (nompro, nomail//'.Face' )
 118         endif
 119 #endif
 120 c
 121       do 30 , iaux = 1 , 2
 122 c
 123 c 3.1. ==> nom de la branche
 124 c
 125         if ( codret.eq.0 ) then
 126 c
 127         jaux = mod(iaux,2) + 1
 128         if ( degre.eq.1 ) then
 129           saux04(iaux) = 'Tr03'
 130           saux04(jaux) = 'Qu04'
 131         else
 132           if ( mod(mailet,2).eq.0 .or. mod(mailet,3).eq.0 ) then
 133             saux04(iaux) = 'Tr07'
 134             saux04(jaux) = 'Qu09'
 135           else
 136             saux04(iaux) = 'Tr06'
 137             saux04(jaux) = 'Qu08'
 138           endif
 139         endif
 140 c
 141 #ifdef _DEBUG_HOMARD_
 142         if ( codret.eq.0 ) then
 143         write (ulsort,texte(langue,5)) saux04(1)
 144 cgn        call gmprsx (nompro, nomail//'.Face.HOM_'//saux04(1) )
 145         endif
 146 #endif
 147 c
 148         call gmobal ( nomail//'.Face.HOM_'//saux04(1) , codre0 )
 149         if ( codre0.eq.0 ) then
 150           goto 30
 151         elseif ( codre0.ne.1 ) then
 152           codret = 1
 153         endif
 154 c
 155         endif
 156 c
 157 c 3.2. ==> combien d'entites de ce type ?
 158 c
 159         if ( codret.eq.0 ) then
 160 c
 161         call gmliat ( nomail//'.Face.HOM_'//saux04(1),
 162      >                1, nbenti(1), codre0 )
 163         codret = max ( abs(codre0), codret )
 164 c
 165 #ifdef _DEBUG_HOMARD_
 166         if ( codret.eq.0 ) then
 167         write (ulsort,texte(langue,6)) nbenti(1)
 168         endif
 169 #endif
 170 c
 171         endif
 172 c
 173 c 3.3. ==> s'il y en a, on recupere la structure qui les decrit
 174 c          sinon, on passe a la suite
 175 c
 176         if ( codret.eq.0 ) then
 177 c
 178         if ( nbenti(1).eq.0 ) then
 179 c
 180           goto 30
 181 c
 182         else
 183 c
 184           call gmnomc ( nomail//'.Face.HOM_'//saux04(1),
 185      >                  nhenti(1), codre1 )
 186           codret = max ( abs(codre0), codret )
 187 c
 188         endif
 189 c
 190         endif
 191 c
 192 c 3.4. ==> A-t-on le type frere ?
 193 c
 194         if ( codret.eq.0 ) then
 195 c
 196         call gmobal ( nomail//'.Face.HOM_'//saux04(2) , codre0 )
 197         if ( codre0.eq.1 ) then
 198           call gmliat ( nomail//'.Face.HOM_'//saux04(2),
 199      >                  1, nbenti(2), codre1 )
 200           call gmnomc ( nomail//'.Face.HOM_'//saux04(2),
 201      >                  nhenti(2), codre2 )
 202           codre0 = min ( codre1, codre2 )
 203           codret = max ( abs(codre0), codret,
 204      >                   codre1, codre2 )
 205         else
 206           nbenti(2) = 0
 207         endif
 208 c
 209         endif
 210 c
 211 c 3.5. ==> Appel du programme generique
 212 c
 213         if ( codret.eq.0 ) then
 214 c
 215 #ifdef _DEBUG_HOMARD_
 216       write (ulsort,texte(langue,3)) 'UTMFEN', nompro
 217 #endif
 218         call utmfen ( nhenti(1), nhenti(2), nbenti(2),
 219      >                ulsort, langue, codret )
 220 c
 221         endif
 222 c
 223    30 continue
 224 c
 225 c====
 226 c 4. la fin
 227 c====
 228 c
 229       if ( codret.ne.0 ) then
 230 c
 231 #include "envex2.h"
 232 c
 233       write (ulsort,texte(langue,1)) 'Sortie', nompro
 234       write (ulsort,texte(langue,2)) codret
 235 c
 236       endif
 237 c
 238 #ifdef _DEBUG_HOMARD_
 239       write (ulsort,texte(langue,1)) 'Sortie', nompro
 240       call dmflsh (iaux)
 241 #endif
 242 c
 243       end