src/tool/Utilitaire/utre01.F

   1       subroutine utre01 ( typenh, option,
   2      >                    norenu, nbelem, nbento,
   3      >                    adenho, adenca, adenic,
   4      >                    ulsort, langue, codret)
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    UTilitaire - REnumerotation - 01
  26 c    --           --               --
  27 c ______________________________________________________________________
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . typenh . e   .   1    . code des entites au sens homard            .
  31 c .        .     .        .  -1 : noeuds                               .
  32 c .        .     .        .   0 : mailles-points                       .
  33 c .        .     .        .   1 : segments                             .
  34 c .        .     .        .   2 : triangles                            .
  35 c .        .     .        .   3 : tetraedres                           .
  36 c .        .     .        .   4 : quadrangles                          .
  37 c .        .     .        .   5 : pyramides                            .
  38 c .        .     .        .   6 : hexaedres                            .
  39 c .        .     .        .   7 : pentaedres                           .
  40 c . option . e   .   1    . option de pilotage                         .
  41 c .        .     .        . c'est un multiple des entiers suivants :   .
  42 c .        .     .        .  2 : nombre d'entites actives              .
  43 c .        .     .        .  3 : nombre d'entites                      .
  44 c .        .     .        .  5 : branche HOMARD                        .
  45 c .        .     .        .  7 : branche Calcul                        .
  46 c .        .     .        . 11 : branche InfoSupE associee             .
  47 c . norenu . e   . char8  . nom de la branche Renum du maillage HOMARD .
  48 c . nbelem . e   .    1   . nbr d'elements utiles et contenant entites .
  49 c . nbento . e   .    1   . nombre d'entites                           .
  50 c . adenho .   s .    1   . adresse de la numerotation dans HOMARD     .
  51 c . adenca .   s .    1   . adresse de la numerotation dans le calcul  .
  52 c . adenic .   s .    1   . adresse de la numerotation dans le calcul  .
  53 c .        .     .        . supplementaire (InfoSupE)                  .
  54 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  55 c . langue . e   .    1   . langue des messages                        .
  56 c .        .     .        . 1 : francais, 2 : anglais                  .
  57 c . codret . es  .    1   . code de retour des modules                 .
  58 c .        .     .        . 0 : pas de probleme                        .
  59 c .        .     .        . 6 : probleme d'ecriture                    .
  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 = 'UTRE01' )
  73 c
  74 #include "nblang.h"
  75 c
  76 c 0.2. ==> communs
  77 c
  78 #include "envex1.h"
  79 #include "enti01.h"
  80 #include "impr02.h"
  81 c
  82 c 0.3. ==> arguments
  83 c
  84       integer typenh, option
  85       integer nbelem, nbento
  86       integer adenho, adenca, adenic
  87 c
  88       character*8 norenu
  89 c
  90       integer ulsort, langue, codret
  91 c
  92 c 0.4. ==> variables locales
  93 c
  94       integer iaux
  95       integer codre1, codre2, codre3, codre4
  96       integer codre0
  97 c
  98       character*1 saux01
  99       character*3 saux03
 100 #ifdef _DEBUG_HOMARD_
 101       character*6 saux06
 102 #endif
 103 c
 104       integer nbmess
 105       parameter ( nbmess = 10 )
 106       character*80 texte(nblang,nbmess)
 107 c
 108 c 0.5. ==> initialisations
 109 c ______________________________________________________________________
 110 c
 111 c====
 112 c 1. initialisations
 113 c====
 114 c
 115 c 1.1. ==> les messages
 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) =
 125      > '(''Allocations des renumerotations relatives aux '',a)'
 126       texte(1,5) = '(''Attributs impossibles a ecrire.'')'
 127       texte(1,6) = '(''Allocations impossibles.'')'
 128 c
 129       texte(2,4) = '(''Allocations of renumbering for '',a)'
 130       texte(2,5) = '(''Attributes cannot be written.'')'
 131       texte(2,6) = '(''Allocations cannot be done.'')'
 132 c
 133 #ifdef _DEBUG_HOMARD_
 134       if ( typenh.gt.0 ) then
 135 c
 136       write(ulsort,texte(langue,4)) mess14(langue,3,typenh)
 137       write(ulsort,*) 'nbelem = ', nbelem
 138       saux06 = 'nb'//suffix(2,typenh)(1:2)//'to'
 139       write(ulsort,*) saux06, ' = ', nbento
 140 c
 141       endif
 142 #endif
 143 c
 144 c 1.2. ==> types d'entites
 145 c
 146       saux03 = '.'//suffix(3,typenh)(1:2)
 147 cgn      if (saux03(2:3).eq.'Ar' )then
 148 cgn        write(ulsort,*) 'glop'
 149 cgn      endif
 150 c
 151 c====
 152 c 2. Les attributs
 153 c====
 154 c
 155       iaux = 3 + 2*typenh
 156 c
 157       if ( mod(option,2).eq.0 ) then
 158         call gmecat ( norenu, iaux  , nbelem, codre1 )
 159       else
 160         codre1 = 0
 161       endif
 162 c
 163       if ( mod(option,3).eq.0 ) then
 164         call gmecat ( norenu, iaux+1, nbento, codre2 )
 165       else
 166         codre2 = 0
 167       endif
 168 c
 169       codre0 = min ( codre1, codre2 )
 170       codret = max ( abs(codre0), codret,
 171      >               codre1, codre2 )
 172       if ( codret.ne.0 ) then
 173         codret = 1
 174       endif
 175 c
 176 c====
 177 c 3. Allocations
 178 c====
 179 c
 180 #ifdef _DEBUG_HOMARD_
 181       write (ulsort,*) '3. Allocations ; codret = ', codret
 182 #endif
 183 c
 184       if ( codret.eq.0 ) then
 185 c
 186       if ( mod(option,5).eq.0 .and. nbelem.ne.0 ) then
 187         call gmaloj ( norenu//saux03//'HOMARD', ' ',
 188      >                nbelem, adenho, codre1 )
 189       else
 190         codre1 = 0
 191       endif
 192 c
 193       if ( mod(option,7).eq.0 .and. nbento.ne.0 ) then
 194         call gmaloj ( norenu//saux03//'Calcul', ' ',
 195      >                nbento, adenca, codre2 )
 196       else
 197         codre2 = 0
 198       endif
 199 c
 200       if ( mod(option,11).eq.0 .and. nbento.ne.0 ) then
 201         write(saux01,'(i1)') typenh+2
 202         call gmaloj ( norenu//'.InfoSupE.Tab'//saux01, ' ',
 203      >                nbento, adenic, codre3 )
 204         call gmecat ( norenu//'.InfoSupE', typenh+2, nbento, codre4 )
 205       else
 206         codre3 = 0
 207         codre4 = 0
 208       endif
 209 c
 210       codre0 = min ( codre1, codre2, codre3, codre4 )
 211       codret = max ( abs(codre0), codret,
 212      >               codre1, codre2, codre3, codre4 )
 213       if ( codret.ne.0 ) then
 214         codret = 2
 215       endif
 216 c
 217       endif
 218 c
 219 c====
 220 c 4. la fin
 221 c====
 222 c
 223       if ( codret.ne.0 ) then
 224 c
 225 #include "envex2.h"
 226 c
 227       write (ulsort,texte(langue,1)) 'Sortie', nompro
 228       write (ulsort,texte(langue,2)) codret
 229       write(ulsort,texte(langue,4)) mess14(langue,3,typenh)
 230       write(ulsort,texte(langue,4+codret))
 231       call gmprsx (nompro,norenu)
 232 c
 233       endif
 234 c
 235 #ifdef _DEBUG_HOMARD_
 236       write (ulsort,texte(langue,1)) 'Sortie', nompro
 237       call dmflsh (iaux)
 238 #endif
 239 c
 240       end