src/tool/Gestion_MTU/gblboj.F

   1       subroutine gblboj ( nomter )
   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     liberation d'un objet 'nomter' structure ou simple
  23 c     et suppression de tous les attachements qui le concernent
  24 c ______________________________________________________________________
  25 c .        .     .        .                                            .
  26 c .  nom   . e/s . taille .           description                      .
  27 c .____________________________________________________________________.
  28 c . nomter . e   . char*8 . nom terminal de l'objet a liberer          .
  29 c ______________________________________________________________________
  30 c
  31 c====
  32 c 0. declarations et dimensionnement
  33 c====
  34 c
  35 c 0.1. ==> generalites
  36 c
  37       implicit none
  38       save
  39 c
  40       character*6 nompro
  41       parameter ( nompro = 'GBLBOJ' )
  42 c
  43 #include "gmmatc.h"
  44 #include "genbla.h"
  45 c
  46 c 0.2. ==> communs
  47 c
  48 #include "gmtoai.h"
  49 #include "gmtoas.h"
  50 #include "gmindi.h"
  51 #include "gminds.h"
  52 c
  53 #include "gmimpr.h"
  54 #include "envex1.h"
  55 #include "gmlang.h"
  56 #include "gmcoer.h"
  57 c
  58 c 0.3. ==> arguments
  59 c
  60       character*8 nomter
  61 c
  62 c 0.4. ==> variables locales
  63 c
  64       integer iaux,ioc,ioa,nbc,nba
  65       integer nroobj
  66       integer codre1
  67 c
  68       integer nbmess
  69       parameter ( nbmess = 10 )
  70       character*80 texte(nblang,nbmess)
  71 c
  72 c====
  73 c 1. initialisations
  74 c====
  75 c
  76 #include "impr01.h"
  77 c
  78 #ifdef _DEBUG_HOMARD_
  79       write (ulsort,texte(langue,1)) 'Entree', nompro
  80       call dmflsh (iaux)
  81 #endif
  82 c
  83 c====
  84 c 2. l'objet est-il alloue ?
  85 c    codre1 = 0 --> non alloue
  86 c    codre1 = 1 --> objet structure
  87 c    codre1 = 2 --> objet simple
  88 c====
  89 c
  90       call gbobal ( nomter , iaux , codre1 )
  91 c
  92       if ( codre1.eq.0 ) then
  93         coergm = -1
  94       else
  95         coergm = 0
  96       endif
  97 c
  98 c====
  99 c 3. Si l'objet est simple, on le desalloue par le programme basique
 100 c====
 101 c
 102       if ( coergm.eq.0 ) then
 103 c
 104       if ( codre1.eq.2 ) then
 105 c
 106         call gmdesa (nomter)
 107 c
 108       endif
 109 c
 110       endif
 111 c
 112 c====
 113 c 4. Si l'objet est structure, on le recherche dans la liste
 114 c====
 115 c
 116       if ( coergm.eq.0 ) then
 117 c
 118       if ( codre1.eq.1 ) then
 119 c
 120 c 4.1. ==> on le recherche dans la liste
 121 c
 122         nroobj = 0
 123         do 411 , iaux = 1,iptobj-1
 124           if (nomobj(iaux).eq.nomter) then
 125             nroobj = iaux
 126             goto 412
 127           endif
 128   411   continue
 129 c
 130   412   continue
 131 c
 132         iptobj = iptobj-1
 133 c
 134 c 4.2. ==> si c'est le dernier objet enregistre : on le supprime
 135 c          . on ramene aux valeurs indefinies toutes les informations
 136 c            qui concernent ses champs.
 137 c          . on memorise les nouvelles adresses des futurs
 138 c            champs et attributs
 139 c          . on ramene aux valeurs indefinies toutes les informations
 140 c            qui le concernent.
 141 c
 142         if ( nroobj.eq.iptobj ) then
 143 c
 144           do 421 , ioc = adrdso(nroobj),iptchp-1
 145             nomobc(ioc) = sindef
 146   421     continue
 147 c
 148           do 422 , ioa = adrdsa(nroobj),iptatt-1
 149             valatt(ioa) = iindef
 150   422     continue
 151 c
 152           iptchp = adrdso(nroobj)
 153           iptatt = adrdsa(nroobj)
 154 c
 155           nomobj(nroobj) = sindef
 156           adrdsa(nroobj) = iindef
 157           adrdso(nroobj) = iindef
 158           typobj(nroobj) = iindef
 159 c
 160         else
 161 c
 162 c 4.3. ==> si ce n'est pas le dernier objet enregistre :
 163 c          . on comprime la liste
 164 c
 165 c 4.3.1 ==> les noms des champs associes aux objets, puis mise
 166 c           a jour du pointeur
 167 c
 168           nbc = adrdso(nroobj+1)-adrdso(nroobj)
 169           do 431 , ioc = adrdso(nroobj),iptchp-nbc-1
 170             nomobc(ioc) = nomobc(ioc+nbc)
 171   431     continue
 172 c
 173           do 432 , ioc = iptchp-nbc,iptchp-1
 174             nomobc(ioc) = sindef
 175   432     continue
 176           iptchp = iptchp-nbc
 177 c
 178 c 4.3.2 ==> les attributs associes aux objets, puis mise
 179 c           a jour du pointeur
 180 c
 181           nba = adrdsa(nroobj+1)-adrdsa(nroobj)
 182           do 433 , ioa = adrdsa(nroobj),iptatt-nba-1
 183             valatt(ioa) = valatt(ioa+nba)
 184   433     continue
 185 c
 186           do 434 , ioa = iptatt-nba,iptatt-1
 187             valatt(ioa) = iindef
 188   434     continue
 189           iptatt = iptatt-nba
 190 c
 191 c 4.3.3. ==> les adresses dans les tableaux des champs et des attributs
 192 c
 193           do 435 , iaux = nroobj+1,iptobj-1
 194             adrdso(iaux) = adrdso(iaux+1)-nbc
 195             adrdsa(iaux) = adrdsa(iaux+1)-nba
 196   435     continue
 197           adrdsa(iptobj) = iindef
 198           adrdso(iptobj) = iindef
 199 c
 200 c 4.3.4. ==> les noms et types des objets alloues
 201 c
 202           do 436 , iaux = nroobj,iptobj-1
 203             nomobj(iaux) = nomobj(iaux+1)
 204             typobj(iaux) = typobj(iaux+1)
 205   436     continue
 206 c
 207           nomobj(iptobj) = sindef
 208           typobj(iptobj) = iindef
 209 c
 210         endif
 211 c
 212       endif
 213 c
 214       endif
 215 c
 216 c====
 217 c 5. Fin
 218 c====
 219 c
 220       if ( coergm.ne.0 ) then
 221 c
 222       write(ulsort,*) nompro, ', code retour ',coergm,' pour ',nomter
 223 c
 224 #include "envex2.h"
 225 c
 226       endif
 227 c
 228       end