src/tool/Gestion_MTU/gmstop.F

   1       subroutine gmstop ( gmimp )
   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 but : arrete le programme proprement
  23 c ______________________________________________________________________
  24 c .        .     .        .                                            .
  25 c .  nom   . e/s . taille .           description                      .
  26 c .____________________________________________________________________.
  27 c . gmimp  . e   .    1   . 0 => pas d'impression                      .
  28 c .        .     .        . 1 => bilan d'utilisation de la memoire     .
  29 c .        .     .        . 2 => impressions des tables des objets     .
  30 c .        .     .        .      dans l'etat courant                   .
  31 c ______________________________________________________________________
  32 c
  33 c====
  34 c 0. declarations et dimensionnement
  35 c====
  36 c
  37 c 0.1. ==> generalites
  38 c
  39       implicit none
  40       save
  41 c
  42 #include "gmmatc.h"
  43 #include "gmmaxt.h"
  44 c
  45 c 0.2. ==> communs
  46 c
  47 #include "gmtoai.h"
  48 #include "gmtoas.h"
  49 #include "gmtors.h"
  50 c
  51 #include "gmtren.h"
  52 #include "gmtrrl.h"
  53 #include "gmtrst.h"
  54 c
  55 #include "gmalen.h"
  56 #include "gmalrl.h"
  57 #include "gmalst.h"
  58 c
  59 #include "gminds.h"
  60 c
  61 #include "gmimpr.h"
  62 c
  63 c 0.3. ==> arguments
  64 c
  65       integer gmimp
  66 c
  67 c 0.4. ==> variables locales
  68 c
  69       integer codret
  70       integer iaux, nbrobj, letype
  71 c
  72       character*8 obrepc, obterc, chterc
  73       character*8 nomost(nobjx), nomosi(maxtab)
  74 c
  75 c 0.5. ==> initialisations
  76 c ______________________________________________________________________
  77 c
  78 c====
  79 c 1. impressions gm
  80 c    en deboggage, on imprime quelle que soit la valeur de gmimp
  81 c    em mode standard, on n'imprime que si gmimp est superieur a 1
  82 c====
  83 c
  84 #ifdef _DEBUG_HOMARD_
  85       iaux = gmimp
  86 #else
  87       if ( gmimp.le.2 ) then
  88         iaux = 2
  89       else
  90         iaux = gmimp
  91       endif
  92 #endif
  93 c
  94       if ( gmimp.ge.iaux ) then
  95 c
  96          call dmflsh (iaux)
  97          call gmdmp ( nomtyb(1), gmimp )
  98          call gmdmp ( nomtyb(2), gmimp )
  99          call gmdmp ( nomtyb(3), gmimp )
 100          call gmdmp ( nomtyb(4), gmimp )
 101          call dmflsh (iaux)
 102 c
 103       endif
 104 c
 105 c====
 106 c 2. desallocation de tous les objets presents en memoire centrale
 107 c    il est plus rapide de commencer par tous les simples. Ainsi,
 108 c    quand on desallouera les structures, il n'y aura que des problemes
 109 c    de graphes a regler
 110 c====
 111 c
 112 c 2.1. ==> liberation des objets simples
 113 c
 114 #ifdef _DEBUG_HOMARD_
 115       write(ulsort,*) 'Debut etape 2.1'
 116       call dmflsh (iaux)
 117 #endif
 118 c
 119 c 2.1.1. ==> les entiers
 120 c
 121 #ifdef _DEBUG_HOMARD_
 122       write(ulsort,*) 'Debut etape 2.1.1 avec nbrobj = ',nballi
 123       call dmflsh (iaux)
 124 #endif
 125 c
 126       nbrobj = nballi
 127       do 2111 , iaux = 1 , nbrobj
 128         nomosi(iaux) = nomali(iaux)
 129  2111 continue
 130 c
 131       do 2112 , iaux = nbrobj , 1 , -1
 132         call gmdesa ( nomosi(iaux) )
 133  2112 continue
 134 c
 135 c 2.1.2. ==> les reels
 136 c
 137 #ifdef _DEBUG_HOMARD_
 138       write(ulsort,*) 'Debut etape 2.1.2 avec nbrobj = ',nballr
 139       call dmflsh (iaux)
 140 #endif
 141 c
 142       nbrobj = nballr
 143       do 2121 , iaux = 1 , nbrobj
 144         nomosi(iaux) = nomalr(iaux)
 145  2121 continue
 146 c
 147       do 2122 , iaux = nbrobj , 1 , -1
 148         call gmdesa ( nomosi(iaux) )
 149  2122 continue
 150 c
 151 c 2.1.3. ==> les chaines
 152 c
 153 #ifdef _DEBUG_HOMARD_
 154       write(ulsort,*) 'Debut etape 2.1.3 avec nbrobj = ',nballs
 155       call dmflsh (iaux)
 156 #endif
 157 c
 158       nbrobj = nballs
 159       do 2131 , iaux = 1 , nbrobj
 160         nomosi(iaux) = nomals(iaux)
 161  2131 continue
 162 c
 163       do 2132 , iaux = nbrobj , 1 , -1
 164         call gmdesa ( nomosi(iaux) )
 165  2132 continue
 166 c
 167 c 2.1.6. ==> bilan
 168 c
 169 #ifdef _DEBUG_HOMARD_
 170       write(ulsort,*) 'Debut etape 2.1.6'
 171       call dmflsh (iaux)
 172 #endif
 173 c
 174 c 2.2. ==> les objets structures
 175 c          en fait il suffit de s'interesser aux tetes
 176 c         attention : la liberation d'un objet structure conduit au
 177 c                     compactage des listes. Il faut donc boucler sur le
 178 c                     nombre initial d'objets structures et s'interesser
 179 c                     a la liste initiale. En effet la liste courante
 180 c                     sera remaniee.
 181 c
 182 #ifdef _DEBUG_HOMARD_
 183       write(ulsort,*) 'Debut etape 2.2'
 184       call dmflsh (iaux)
 185 #endif
 186 c
 187       nbrobj = iptobj-1
 188       do 221 , iaux = 1 , nbrobj
 189          nomost(iaux) = nomobj(iaux)
 190   221 continue
 191 c
 192       do 222 , iaux = nbrobj , 1 , -1
 193 c
 194          call gbdnoe (nomost(iaux),obrepc,obterc,chterc,codret)
 195 c
 196          if ( codret.ge.0 .and. nomost(iaux).ne.sindef ) then
 197 c
 198             call gbobal ( nomost(iaux) , letype , codret )
 199 c
 200             if ( codret.ne.0) then
 201                call gmsgoj ( nomost(iaux) , codret )
 202                if ( codret.ne.0) then
 203                  write(ulsort,20000) nomost(iaux), codret
 204                endif
 205             endif
 206 c
 207          else
 208 c
 209               write(ulsort,*) 'gmstop --> gbdnoe : codret = ',codret
 210 c
 211          endif
 212 c
 213   222 continue
 214 c
 215 20000 format(' GMSTOP pb a la suppression de l''objet ',a8,
 216      >     /,' Code retour de la suppression : ',i5)
 217 c
 218 #ifdef _DEBUG_HOMARD_
 219       call gmdmp ( nomtyb(4), gmimp )
 220 #endif
 221 c
 222 c====
 223 c 3. statistiques gm
 224 c====
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227       write(ulsort,*) '3. statistiques gm'
 228       call dmflsh (iaux)
 229 #endif
 230 c
 231       call gmstat ( gmimp )
 232 c
 233 #ifdef _DEBUG_HOMARD_
 234       write(ulsort,*) 'Fin de gmstop'
 235       call dmflsh (iaux)
 236 #endif
 237 c
 238       end