src/tool/Utilitaire/utacma.F

   1       subroutine utacma ( nocmai, typnom, typcca,
   2      >                      sdim,   mdim,
   3      >                     degre, mailet, maconf, homolo, hierar,
   4      >                    nbnoto, nctfno, nbelem, nbmane, attrib,
   5      >                    ncinfo, ncnoeu, nccono, nccode,
   6      >                    nccoex, ncfami,
   7      >                    ncequi, ncfron, ncnomb,
   8      >                    ulsort, langue, codret )
   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 - Allocation pour le Calcul - MAillage
  30 c    --           -                  -        --
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . nocmai . es  . char8  . nom de l'objet maillage homard             .
  36 c . typnom . e   .    1   . type du nom de l'objet maillage            .
  37 c .        .     .        . 0 : le nom est a creer automatiquement     .
  38 c .        .     .        . 1 : le nom est impose par l'appel          .
  39 c . typcca . e   .   1    . type du code de calcul                     .
  40 c . sdim   . e   .    1   . dimension de l'espace                      .
  41 c . mdim   . e   .    1   . dimension du maillage                      .
  42 c . degre  . e   .    1   . degre du maillage                          .
  43 c . mailet . e   .    1   . presence de mailles etendues               .
  44 c .        .     .        .  1 : aucune                                .
  45 c .        .     .        . 2x : TRIA7                                 .
  46 c .        .     .        . 3x : QUAD9                                 .
  47 c .        .     .        . 5x : HEXA27                                .
  48 c . maconf . e   .    1   . conformite du maillage                     .
  49 c .        .     .        .  0 : oui                                   .
  50 c .        .     .        .  1 : non-conforme avec au minimum 2 aretes .
  51 c .        .     .        .      non decoupees en 2 par face           .
  52 c .        .     .        .  2 : non-conforme avec 1 seul noeud pendant.
  53 c .        .     .        .      par arete                             .
  54 c .        .     .        .  3 : non-conforme fidele a l'indicateur    .
  55 c .        .     .        . -1 : conforme, avec des boites pour les    .
  56 c .        .     .        .      quadrangles, hexaedres et pentaedres  .
  57 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  58 c .        .     .        .      decoupee en 2 et des boites pour les  .
  59 c .        .     .        .       quadrangles, hexaedres et pentaedres .
  60 c .        .     .        . 10 : non-conforme sans autre connaissance  .
  61 c . homolo . e   .    1   . type de relations par homologues           .
  62 c .        .     .        . 0 : pas d'homologues                       .
  63 c .        .     .        . 1 : relations sur les noeuds               .
  64 c .        .     .        . 2 : relations sur les noeuds et les aretes .
  65 c .        .     .        . 3 : relations sur les noeuds, les aretes   .
  66 c .        .     .        .     et les triangles                       .
  67 c . hierar . e   .    1   . maillage hierarchique                      .
  68 c .        .     .        . 0 : non                                    .
  69 c .        .     .        . 1 : oui                                    .
  70 c . nbnoto . e   .    1   . nombre de noeuds total                     .
  71 c . nctfno . e   .    1   . nombre de carac. des familles de noeuds    .
  72 c . nbelem . e   .    1   . nombre d'elements                          .
  73 c . nbmane . e   .    1   . nombre maximum de noeuds par element       .
  74 c . attrib . e   .    1   . attribut auxiliaire                        .
  75 c . ncinfo .   s . char8  . nom de la branche InfoGene                 .
  76 c . ncnoeu .   s . char8  . nom de la branche Noeud                    .
  77 c . nccono .   s . char8  . nom de la branche ConnNoeu                 .
  78 c . nccode .   s . char8  . nom de la branche ConnDesc                 .
  79 c . nccoex .   s . char8  . nom de la branche CodeExte                 .
  80 c . ncfami .   s . char8  . nom de la branche Famille                  .
  81 c . ncequi .   s . char8  . nom de la branche Equivalt                 .
  82 c . ncfron .   s . char8  . nom de la branche Frontier                 .
  83 c . ncnomb .   s . char8  . nom de la branche Nombres                  .
  84 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  85 c . langue . e   .    1   . langue des messages                        .
  86 c .        .     .        . 1 : francais, 2 : anglais                  .
  87 c . codret . es  .    1   . code de retour des modules                 .
  88 c .        .     .        . 0 : pas de probleme                        .
  89 c .        .     .        . -1 : mauvaise demande pour le type de nom  .
  90 c .        .     .        . autre : probleme dans l'allocation         .
  91 c ______________________________________________________________________
  92 c
  93 c====
  94 c 0. declarations et dimensionnement
  95 c====
  96 c
  97 c 0.1. ==> generalites
  98 c
  99       implicit none
 100       save
 101 c
 102       character*6 nompro
 103       parameter ( nompro = 'UTACMA' )
 104 c
 105       integer nbnomb
 106       parameter ( nbnomb = 50 )
 107 c
 108 #include "nblang.h"
 109 c
 110 c 0.2. ==> communs
 111 c
 112 #include "envex1.h"
 113 c
 114 c 0.3. ==> arguments
 115 c
 116       character*8 nocmai
 117 c
 118       integer typnom, typcca
 119       integer sdim, mdim
 120       integer degre, mailet, maconf, homolo, hierar
 121       integer nbnoto, nctfno, nbelem, nbmane, attrib
 122 c
 123       character*8 ncinfo, ncnoeu, nccono, nccode
 124       character*8 nccoex, ncfami
 125       character*8 ncequi, ncfron, ncnomb
 126 c
 127       integer ulsort, langue, codret
 128 c
 129 c 0.4. ==> variables locales
 130 c
 131       integer iaux, jaux
 132       integer codre1, codre2, codre3, codre4, codre5
 133       integer codre6, codre7, codre8
 134       integer codre0
 135 c
 136       integer nbmess
 137       parameter ( nbmess = 10 )
 138       character*80 texte(nblang,nbmess)
 139 c
 140 c 0.5. ==> initialisations
 141 c ______________________________________________________________________
 142 c
 143 c====
 144 c 1. messages
 145 c====
 146 c
 147 #include "impr01.h"
 148 c
 149 #ifdef _DEBUG_HOMARD_
 150       write (ulsort,texte(langue,1)) 'Entree', nompro
 151       call dmflsh (iaux)
 152 #endif
 153 c
 154       texte(1,4) =
 155      > '(5x,''Allocation d''''un objet maillage de calcul'',/)'
 156       texte(1,5) = '(''Mauvaise demande de type de nom :'',i6)'
 157       texte(1,6) = '(''Probleme pour allouer l''''objet '',a8)'
 158       texte(1,7) = '(''Probleme pour allouer un objet temporaire.'')'
 159 c
 160       texte(2,4) =
 161      > '(5x,''Allocation of an object calculation mesh'',/)'
 162       texte(2,5) = '(''Bad request for the type of name :'',i6)'
 163       texte(2,6) = '(''Problem while allocating object '',a8)'
 164       texte(2,7) = '(''Problem while allocating a temporary object.'')'
 165 c
 166 #include "impr03.h"
 167 c
 168 #ifdef _DEBUG_HOMARD_
 169       write (ulsort,texte(langue,4))
 170 #endif
 171 c
 172 c====
 173 c 2. allocation de la structure du maillage de calcul
 174 c    on n'alloue que les objets structures du graphe
 175 c====
 176 c
 177 c 2.1. ==> allocation de la tete du maillage de calcul
 178 c
 179       if ( typnom.eq.0 ) then
 180 c
 181         call gmalot ( nocmai, 'Cal_Mail', 0, iaux, codre1 )
 182         codret = abs(codre1)
 183 c
 184       elseif ( typnom.eq.1 ) then
 185 c
 186         call gmaloj ( nocmai, 'Cal_Mail', 0, iaux, codre1 )
 187         codret = abs(codre1)
 188 c
 189       else
 190 c
 191         codret = -1
 192 c
 193       endif
 194 c
 195 c 2.2. ==> Allocation des branches principales
 196 #ifdef _DEBUG_HOMARD_
 197       write (ulsort,90002) '2.2. branches ppales ; codret', codret
 198 #endif
 199 c
 200       if ( codret.eq.0 ) then
 201 c
 202       call gmecat ( nocmai, 1, sdim, codre1 )
 203       call gmecat ( nocmai, 2, mdim, codre2 )
 204       call gmecat ( nocmai, 3, degre, codre3 )
 205       call gmecat ( nocmai, 4, maconf, codre4 )
 206       call gmecat ( nocmai, 5, homolo, codre5 )
 207       call gmecat ( nocmai, 6, hierar, codre6 )
 208       call gmecat ( nocmai, 7, nbnomb, codre7 )
 209       call gmecat ( nocmai, 8, mailet, codre8 )
 210 c
 211       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 212      >               codre6, codre7, codre8 )
 213       codret = max ( abs(codre0), codret,
 214      >               codre1, codre2, codre3, codre4, codre5,
 215      >               codre6, codre7, codre8 )
 216 c
 217 #ifdef _DEBUG_HOMARD_
 218       write (ulsort,90002)'codes',codre1, codre2, codre3,
 219      >      codre4, codre5,codre6, codre7, codre8
 220       call gmprsx(nompro, nocmai)
 221 #endif
 222 c
 223       endif
 224 c
 225 #ifdef _DEBUG_HOMARD_
 226       write (ulsort,90002) '2.2. avant nocmai 1 ; codret', codret
 227 #endif
 228 c
 229       if ( codret.eq.0 ) then
 230 c
 231       call gmaloj ( nocmai//'.InfoGene', ' ', 0, iaux, codre1 )
 232       call gmaloj ( nocmai//'.Noeud'   , ' ', 0, iaux, codre2 )
 233       call gmaloj ( nocmai//'.ConnNoeu', ' ', 0, iaux, codre3 )
 234       call gmaloj ( nocmai//'.ConnDesc', ' ', 0, iaux, codre4 )
 235 c
 236       codre0 = min ( codre1, codre2, codre3, codre4 )
 237       codret = max ( abs(codre0), codret,
 238      >               codre1, codre2, codre3, codre4 )
 239 c
 240       endif
 241 c
 242 #ifdef _DEBUG_HOMARD_
 243       write (ulsort,90002) '2.2. avant nocmai 2 ; codret', codret
 244 #endif
 245 c
 246       if ( codret.eq.0 ) then
 247 c
 248       call gmaloj ( nocmai//'.CodeExte' , ' ', 0, iaux, codre1 )
 249       call gmaloj ( nocmai//'.Famille'  , ' ', 0, iaux, codre2 )
 250       call gmaloj ( nocmai//'.Equivalt' , ' ', 0, iaux, codre3 )
 251       call gmaloj ( nocmai//'.Nombres'  , ' ', nbnomb, iaux, codre4 )
 252 c
 253       codre0 = min ( codre1, codre2, codre3, codre4 )
 254       codret = max ( abs(codre0), codret,
 255      >               codre1, codre2, codre3, codre4 )
 256 c
 257       endif
 258 c
 259       if ( codret.eq.0 ) then
 260 c
 261       iaux = 0
 262       call gmaloj ( nocmai//'.Frontier', ' ', iaux, jaux, codret )
 263 c
 264       endif
 265 c
 266 c 2.3. ==> nom interne de ces branches
 267 #ifdef _DEBUG_HOMARD_
 268       write (ulsort,90002) '2.3. nom interne ; codret', codret
 269 #endif
 270 c
 271       if ( codret.eq.0 ) then
 272 c
 273 #ifdef _DEBUG_HOMARD_
 274       write (ulsort,texte(langue,3)) 'UTNOMC', nompro
 275 #endif
 276       call utnomc ( nocmai,
 277      >                sdim,   mdim,
 278      >               degre, mailet, maconf, homolo, hierar,
 279      >              iaux,
 280      >              ncinfo, ncnoeu, nccono, nccode,
 281      >              nccoex, ncfami,
 282      >              ncequi, ncfron, ncnomb,
 283      >              ulsort, langue, codret)
 284 #ifdef _DEBUG_HOMARD_
 285       write (ulsort,90003) 'ncnoeu', ncnoeu
 286       write (ulsort,90003) 'nccono', nccono
 287 #endif
 288 c
 289       endif
 290 c
 291 c 2.4. ==> attributs
 292 #ifdef _DEBUG_HOMARD_
 293       write (ulsort,90002) '2.4. attributs ; codret', codret
 294 #endif
 295 c
 296       if ( codret.eq.0 ) then
 297 c
 298       call gmecat ( ncnoeu, 1, nbnoto, codre1 )
 299       call gmecat ( ncnoeu, 2, nctfno, codre2 )
 300       call gmecat ( ncnoeu, 3, 0     , codre2 )
 301 c
 302       codre0 = min ( codre1, codre2, codre3  )
 303       codret = max ( abs(codre0), codret,
 304      >               codre1, codre2, codre3  )
 305 c
 306       call gmecat ( nccono, 1, nbelem, codre1 )
 307       call gmecat ( nccono, 2, nbmane, codre2 )
 308       call gmecat ( nccono, 3, attrib, codre3 )
 309 c
 310       codre0 = min ( codre1, codre2, codre3  )
 311       codret = max ( abs(codre0), codret,
 312      >               codre1, codre2, codre3  )
 313 c
 314       endif
 315 c
 316 #ifdef _DEBUG_HOMARD_
 317       if ( codret.eq.0 ) then
 318       call gmprsx(nompro, nocmai)
 319       call gmprsx(nompro, nocmai//'.Nombres')
 320       call gmprsx(nompro//' - ncnoeu', ncnoeu)
 321       call gmprsx(nompro//' - nccono', nccono)
 322       endif
 323 #endif
 324 c
 325 c====
 326 c 3. la fin
 327 c====
 328 #ifdef _DEBUG_HOMARD_
 329       write (ulsort,90002) '3. la fin ; codret', codret
 330 #endif
 331 c
 332       if ( codret.ne.0 ) then
 333 c
 334 #include "envex2.h"
 335 c
 336       write (ulsort,texte(langue,1)) 'Sortie', nompro
 337       write (ulsort,texte(langue,2)) codret
 338       if ( codret.eq.-1 ) then
 339         write (ulsort,texte(langue,5)) typnom
 340       else
 341         if ( typnom.eq.1 ) then
 342           write (ulsort,texte(langue,6)) nocmai
 343         else
 344           write (ulsort,texte(langue,7))
 345         endif
 346       endif
 347 c
 348       endif
 349 c
 350 #ifdef _DEBUG_HOMARD_
 351       write (ulsort,texte(langue,1)) 'Sortie', nompro
 352       call dmflsh (iaux)
 353 #endif
 354 c
 355       end