src/tool/Gestion_MTU/gmsgoj.F

   1       subroutine gmsgoj ( nomemc, codret )
   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
  22 c     supprimer le graphe d'un objet en memoire centrale
  23 c     et le detruire
  24 c ______________________________________________________________________
  25 c .        .     .        .                                            .
  26 c .  nom   . e/s . taille .           description                      .
  27 c .____________________________________________________________________.
  28 c . nomemc . e   .char(*) . nom etendu en memoire centrale             .
  29 c . codret .  s  . ent    . code retour de l'operation                 .
  30 c .        .     .        .  0 : OK                                    .
  31 c .        .     .        . -1 : Probleme dans la suppression du graphe.
  32 c .        .     .        . -2 : Probleme dans la liberation de l'objet.
  33 c .____________________________________________________________________.
  34 c
  35 c====
  36 c 0. declarations et dimensionnement
  37 c====
  38 c
  39 c 0.1. ==> generalites
  40 c
  41       implicit none
  42       save
  43 c
  44       character*6 nompro
  45       parameter ( nompro = 'GMSGOJ' )
  46 c
  47 c
  48 #include "genbla.h"
  49 c
  50 #include "gmcain.h"
  51 c
  52 c 0.2. ==> communs
  53 c
  54 #include "envex1.h"
  55 #include "gmcoer.h"
  56 #include "gmimpr.h"
  57 #include "gmlang.h"
  58 c
  59 c 0.3. ==> arguments
  60 c
  61       integer codret
  62 c
  63       character*(*) nomemc
  64 c
  65 c 0.4. ==> variables locales
  66 c
  67       integer iaux
  68       integer icar, imin, imax
  69 c
  70       character*8 nomter, nomaux
  71 c
  72       integer nbmess
  73       parameter ( nbmess = 20 )
  74       character*80 texte(nblang,nbmess)
  75 c
  76 c 0.5. ==> initialisations
  77 c ______________________________________________________________________
  78 c
  79 c====
  80 c 1. messages
  81 c====
  82 c
  83 #include "impr01.h"
  84 c
  85 #ifdef _DEBUG_HOMARD_
  86       write (ulsort,texte(langue,1)) 'Entree', nompro
  87       call dmflsh (iaux)
  88 #endif
  89 c
  90       texte(1,10) = '(''Suppression du graphe de l''''objet '',a8)'
  91       texte(1,4) = '(''en memoire centrale.'')'
  92       texte(1,11) = '(''Probleme a la suppression du graphe.'')'
  93       texte(1,12) = '(''Probleme a la liberation de l''''objet.'')'
  94 c
  95       texte(2,10) = '(''Suppression of the graph of the object '',a8)'
  96       texte(2,4) = '(''in central memory.'')'
  97       texte(2,11) = '(''Problem in freeing the graph.'')'
  98       texte(2,12) = '(''Problem in freeing the object.'')'
  99 c
 100 c====
 101 c 2. on supprime le graphe seul
 102 c====
 103 c
 104       call gasgmc (nomemc,codret)
 105 c
 106 c====
 107 c 3. si l'objet est structure et que la suppression du graphe
 108 c    s'est bien passe
 109 c    ou : si l'objet est simple
 110 c    detachement de l'objet de tous ses supports
 111 c    si c'est un objet temporaire et que c'est une tete, on le raye
 112 c    de la liste
 113 c====
 114 c
 115       if ( codret.eq.0 .or. codret.eq.-5 ) then
 116 c
 117         call gmnomc (nomemc, nomter, codret)
 118 c
 119         if ( codret.eq.0 ) then
 120 c
 121           call gblboj ( nomter )
 122           codret = coergm
 123 c
 124         endif
 125 c
 126         if ( codret.eq.0 ) then
 127 c
 128           nomaux = '        '
 129           call gbdtoj ( nomaux, nomter )
 130           codret = coergm
 131 c
 132         endif
 133 c
 134         if ( codret.ne.0 ) then
 135           codret = -2
 136         endif
 137 c
 138       else
 139 c
 140          codret = - 1
 141 c
 142       endif
 143 c
 144       if ( codret.eq.0 .and. len(nomemc).ge.8 ) then
 145 c
 146 c avant de supprimer le nom de la liste des noms d'objets temporaires,
 147 c on verifie que le nom (terminal) a bien la structure d'un nom
 148 c temporaire : un certain nombre (>0) de caracteres caint1 (% a priori),
 149 c suivis d'un entier (le tout, code sur 8 caracteres).
 150 c
 151           if ( nomter(1:1).eq.caint1 .and.
 152      >         nomter.eq.nomemc(1:8)       ) then
 153             imin = 2
 154             imax = 11
 155             do 80 icar = 2, 8
 156               iaux = index('0123456789'//caint1, nomter(icar:icar))
 157               if (iaux.lt.imin.or.iaux.gt.imax) then
 158                 goto 91
 159               else
 160                 if (iaux.ne.11) then
 161                   imin = 1
 162                   imax = 10
 163                 endif
 164               endif
 165    80       continue
 166             if (imax.ne.11) then
 167               call gbntde ( nomter , iaux )
 168             endif
 169           endif
 170 c
 171       endif
 172 c
 173 c====
 174 c 9. gestion des erreurs
 175 c====
 176 c
 177    91 continue
 178 c
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,*) '9. Gestions des erreurs ; codret = ', codret
 181 #endif
 182 c
 183       if ( codret.ne.0 ) then
 184 c
 185         write (ulsort,90000)
 186         write (ulsort,texte(langue,1)) 'Sortie', nompro
 187         write (ulsort,texte(langue,10))
 188         write (ulsort,*) nomemc
 189         write (ulsort,texte(langue,4))
 190         if ( abs(codret).le.2 .and. coergm.eq.0 ) then
 191           iaux = 10+abs(codret)
 192           write (ulsort,texte(langue,iaux))
 193         endif
 194         write (ulsort,90000)
 195 c
 196 #include "envex2.h"
 197 c
 198       endif
 199 c
 200 90000 format (70('='))
 201 c
 202       end