src/tool/Gestion_MTU/gbntcr.F

   1       subroutine gbntcr ( nom )
   2 c ______________________________________________________________________
   3 c
   4 c                             H O M A R D
   5 c
   6 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   7 c
   8 c Version originale enregistree le 18 juin 1996 sous le numero 96036
   9 c aupres des huissiers de justice Simart et Lavoir a Clamart
  10 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  11 c aupres des huissiers de justice
  12 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  13 c
  14 c    HOMARD est une marque deposee d'Electricite de France
  15 c
  16 c Copyright EDF 1996
  17 c Copyright EDF 1998
  18 c Copyright EDF 2002
  19 c Copyright EDF 2020
  20 c ______________________________________________________________________
  21 c     cree un nouveau nom d'objet temporaire
  22 c ______________________________________________________________________
  23 c .        .     .        .                                            .
  24 c .  nom   . e/s . taille .           description                      .
  25 c .____________________________________________________________________.
  26 c . nom    .  s  . char*8 . nom de l'objet temporaire                  .
  27 c ______________________________________________________________________
  28 c
  29 c====
  30 c 0. declarations et dimensionnement
  31 c====
  32 c
  33 c 0.1. ==> generalites
  34 c
  35       implicit none
  36       save
  37 c
  38 #include "gmmaxt.h"
  39 #include "gmmatc.h"
  40 c
  41 #include "gmcain.h"
  42 c
  43 c 0.2. ==> communs
  44 c
  45 #include "gmtenb.h"
  46 #include "gmteno.h"
  47 #ifdef _DEBUG_HOMARD_
  48 #include "gmimpr.h"
  49 #endif
  50 c
  51 c 0.3. ==> arguments
  52 c
  53       character*(*) nom
  54 c
  55 c 0.4. ==> variables locales
  56 c
  57       integer numero, iaux
  58 c
  59 #ifdef _DEBUG_HOMARD_
  60       integer jaux
  61 #endif
  62 c
  63 c 0.5. ==> initialisations
  64 c
  65 c ______________________________________________________________________
  66 c
  67 c====
  68 c 1. determination d'un nouveau nom
  69 c    on lui impose de commencer par le premier caractere interdit
  70 c    on recherche un numero non utilise. il y en a forcement un
  71 c    car on s'autorise 3*maxtab+nobjx tableaux temporaires ce qui est le
  72 c    nombre maxi de tableaux en general. Or ce dernier sera
  73 c    forcement atteint avant (NB: il y a 3 types possibles pour les
  74 c    objets simples, d'ou le 3*maxtab).
  75 c====
  76 c
  77       nom = caint1//caint1//caint1//caint1//caint1//caint1//caint1//' '
  78 c
  79       do 11 iaux = 1 , mxtbtp
  80          if ( numete(iaux).eq.0 ) then
  81             numero = iaux
  82             goto 13
  83          endif
  84    11 continue
  85 c
  86       if ( mxtbtp.lt.maxtbt ) then
  87         mxtbtp = mxtbtp + 1
  88       endif
  89       numero = max( 1, min(mxtbtp,9999999) )
  90 c
  91    13 continue
  92 c
  93       if ( numero.lt.10 ) then
  94          write ( nom(8:8),'(i1)') numero
  95       elseif ( numero.lt.100 ) then
  96          write ( nom(7:8),'(i2)') numero
  97       elseif ( numero.lt.1000 ) then
  98          write ( nom(6:8),'(i3)') numero
  99       elseif ( numero.lt.10000 ) then
 100          write ( nom(5:8),'(i4)') numero
 101       elseif ( numero.lt.100000 ) then
 102          write ( nom(4:8),'(i5)') numero
 103       elseif ( numero.lt.1000000 ) then
 104          write ( nom(3:8),'(i6)') numero
 105       else
 106          write ( nom(2:8),'(i7)') numero
 107       endif
 108 c
 109       numete(numero) = 1
 110       nomalt(numero) = nom
 111 c
 112 #ifdef _DEBUG_HOMARD_
 113       jaux = 5
 114       write (ulsort,*) 'SP GBNTCR :'
 115       write (ulsort,*) 'Numero et nom du dernier objet : ',
 116      >numero,' ',nom
 117       write (ulsort,*) 'Les ',jaux,' premiers noms sont :'
 118       write (ulsort,10000) (iaux,nomalt(iaux),iaux=1,jaux)
 119 10000 format(5(i5,' : ',a8,' | '))
 120 #endif
 121 c
 122       end