src/tool/Gestion_MTU/gasgmc.F

   1       subroutine gasgmc ( 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 ______________________________________________________________________
  24 c .        .     .        .                                            .
  25 c .  nom   . e/s . taille .           description                      .
  26 c .____________________________________________________________________.
  27 c . nomemc . e   .char(*) . nom etendu en memoire centrale             .
  28 c . codret .  s  . ent    . code retour de l'operation                 .
  29 c .        .     .        .  0 : OK                                    .
  30 c .        .     .        . -1 : nom d'objet invalide                  .
  31 c .        .     .        . -2 : Probleme dans la liberation d'un objet.
  32 c .        .     .        .      du chemin                             .
  33 c .        .     .        . -3 : Probleme au detachement               .
  34 c .        .     .        . -4 : L'objet n'est pas alloue.             .
  35 c .        .     .        . -5 : L'objet est simple                    .
  36 c .        .     .        . -6 : dimensionnement insuffisant           .
  37 c .____________________________________________________________________.
  38 c
  39 c====
  40 c 0. declarations et dimensionnement
  41 c====
  42 c
  43 c 0.1. ==> generalites
  44 c
  45       implicit none
  46       save
  47       character*6 nompro
  48       parameter ( nompro = 'GASGMC' )
  49 c
  50 c
  51 #include "genbla.h"
  52 c
  53 #include "gmmatc.h"
  54 c
  55 c 0.2. ==> communs
  56 c
  57 #include "gminds.h"
  58 c
  59 #include "gmcoer.h"
  60 #include "envex1.h"
  61 #include "gmimpr.h"
  62 #include "gmlang.h"
  63 c
  64 c 0.3. ==> arguments
  65 c
  66       integer codret
  67 c
  68       character*(*) nomemc
  69 c
  70 c 0.4. ==> variables locales
  71 c
  72 #include "gmixjx.h"
  73 c
  74       character*8   chemin(ix,jx), objter
  75       character*8   objdet(nbjx), objlib(nbjx)
  76       character*8   obrepc, obterc, chterc
  77       character*40  mess
  78 c
  79       integer iaux, jaux, kaux
  80       integer igrp, nj1, nbojdl, nbojdd, ityc, ioal
  81       integer impopt, nbchem, lgchem(ix)
  82 c
  83       logical alloue, attach
  84 c
  85       integer nbmess
  86       parameter ( nbmess = 20 )
  87       character*80 texte(nblang,nbmess)
  88 c
  89 c 0.5. ==> initialisations
  90 c
  91 c ... juste pour ne plus avoir de messages ftnchek :
  92 c
  93       data objdet / nbjx * '        ' /
  94       data objlib / nbjx * '        ' /
  95 c
  96 #ifdef _DEBUG_HOMARD_
  97       impopt = 1
  98 #else
  99       impopt = 0
 100 #endif
 101 c ______________________________________________________________________
 102 c
 103 c====
 104 c 1. messages
 105 c====
 106 c
 107 #include "impr01.h"
 108 c
 109 #ifdef _DEBUG_HOMARD_
 110       write (ulsort,texte(langue,1)) 'Entree', nompro
 111       call dmflsh (iaux)
 112 #endif
 113 c
 114       texte(1,6) = '(1x,''Suppression du graphe de l''''objet '',a8)'
 115       texte(1,4) = '(1x,''en memoire centrale.'')'
 116       texte(1,11) = '(1x,''Le nom d''''objet est invalide.'')'
 117       texte(1,12) =
 118      >  '(1x,''Probleme a la liberation d''''un objet du chemin.'')'
 119       texte(1,13) = '(1x,''Probleme lors d''''un detachement.'')'
 120       texte(1,14) = '(1x,''L''''objet n''''est pas alloue.'')'
 121       texte(1,15) = '(1x,''L''''objet est simple.'')'
 122       texte(1,16) = '(1x,''Dimensionnement du chemin insuffisant.'')'
 123 c
 124       texte(2,6) = '(1x,''Suppression of the graph of the object '',a8)'
 125       texte(2,4) = '(1x,''in central memory.'')'
 126       texte(2,11) = '(1x,''The name of the object is not valid.'')'
 127       texte(2,12) = '(1x,''Problem in freeing an object of the path.'')'
 128       texte(2,13) = '(1x,''Problem in untighting.'')'
 129       texte(2,14) = '(1x,''The object is not allocated.'')'
 130       texte(2,15) = '(1x,''The object is simple.'')'
 131       texte(2,16) = '(1x,''Unsufficient path dimension.'')'
 132 c
 133       mess = '                                        '
 134 c
 135 c====
 136 c 2. on recherche le type d'allocation
 137 c====
 138 c
 139 c 2.1. ==> decodage du nom
 140 c
 141       call gbdnoe(nomemc,obrepc,obterc,chterc,codret)
 142 cgn      write(1,*) nompro, codret
 143 c
 144       if ( codret.lt.0 .or. codret.eq.1 .or. codret.eq.2 ) then
 145          codret = -1
 146       else
 147          codret = 0
 148       endif
 149 cgn      write(1,*) nompro, codret, coergm
 150 c
 151 c 2.2. ==> l'objet "obterc" est-il alloue ?
 152 c        ioal = 0    : objet non alloue
 153 c        ioal = 1    : objet structure alloue
 154 c        ioal = 2    : objet simple    alloue
 155 c
 156       if ( codret.eq.0 ) then
 157 c
 158          call gbobal ( obterc, ityc, ioal )
 159 c
 160 cgn       write(1,*) nompro, ioal, coergm
 161       endif
 162 c
 163 c====
 164 c 3. si l'objet est structure
 165 c====
 166 c
 167       if ( codret.eq.0 ) then
 168 c
 169        if ( ioal.eq.1 ) then
 170 c
 171 c 3.1. ==> nbojdl : nombre d'objets deja liberes
 172 c          nbojdd : nombre d'objets deja detaches
 173 c
 174          nbojdl = 0
 175          nbojdd = 0
 176 c
 177 c 3.2. ==> construction du graphe de 'nomemc'
 178 c                          * pour simple alloue
 179 c                          > pour structure alloue
 180 c                          = pour simple non alloue
 181 c                          + pour structure non alloue
 182 c                          - pour simple non defini
 183 c                          < pour structure non defini
 184 c
 185          iaux = ix
 186          jaux = jx
 187          call gagpmc(obterc,iaux,jaux,chemin,lgchem,nbchem,impopt,igrp)
 188 c
 189          if (igrp.lt.0) then
 190             mess = ' gasgmc -> gagpmc -> codret : '
 191             write(mess(29:30),'(i2)') igrp
 192             codret = -6
 193             goto 91
 194          endif
 195 cgn       write(1,*) nompro, codret, coergm
 196 c
 197 c 3.3. ==> liberation de tous les objets du chemin
 198 c
 199          do 33 , iaux = nbchem , 1 , -1
 200 c
 201 c 3.3.1. ==> recherche de la profondeur du chemin
 202 c
 203             do 331 , jaux = 3 , jx , 2
 204                if ((chemin(iaux,jaux)(1:1).eq.'*').or.
 205      >          (chemin(iaux,jaux)(1:1).eq.'=').or.
 206      >          (chemin(iaux,jaux)(1:1).eq.'+').or.
 207      >          (chemin(iaux,jaux)(1:1).eq.'-').or.
 208      >          (chemin(iaux,jaux)(1:1).eq.'<')) then
 209                   nj1 = jaux-1
 210                   goto 332
 211                endif
 212   331       continue
 213             codret = -6
 214             goto 91
 215 c
 216   332       continue
 217 c
 218 c 3.3.2. ==> exploration des branches de ce chemin, a l'envers
 219 c            on s'interesse a tous ceux que le graphe declare comme
 220 c            etant alloues. neanmoins, il faut verifier a chaque
 221 c            fois que l'objet est encore alloue car il a pu etre
 222 c            desalloue dans un chemin precedent.
 223 c            quand on arrive au bout du chemin, il faut detacher
 224 c            le dernier objet de la racine
 225 c
 226             do 333 , jaux = nj1 , 2 ,-2
 227 c
 228                objter = chemin(iaux,jaux)
 229 c
 230                alloue = .true.
 231                if (objter.eq.sindef) then
 232                   alloue = .false.
 233                endif
 234                if ((chemin(iaux,jaux+1)(1:1).eq.'=').or.
 235      >          (chemin(iaux,jaux+1)(1:1).eq.'+').or.
 236      >          (chemin(iaux,jaux+1)(1:1).eq.'-').or.
 237      >          (chemin(iaux,jaux+1)(1:1).eq.'<')) then
 238                   alloue = .false.
 239                endif
 240                do 334 , kaux = 1,nbojdl
 241                   if (objlib(kaux).eq.objter) then
 242                      alloue = .false.
 243                   endif
 244   334          continue
 245 c
 246                if ( alloue ) then
 247 c
 248                   call gblboj (objter)
 249 cgn       write(1,*) nompro, 'call gblboj (objter)', coergm
 250                   if ( coergm.ne.0 ) then
 251                      mess(1:8) = objter
 252                      codret = -2
 253                      goto 91
 254                   endif
 255 c
 256                   nbojdl = nbojdl+1
 257                   objlib(nbojdl) = objter
 258 c
 259                endif
 260 c
 261                if ( jaux.eq.2 .and. chemin(iaux,2).ne.sindef ) then
 262 c
 263                   attach = .true.
 264                   do 335 , kaux = 1,nbojdd
 265                      if (objdet(kaux).eq.chemin(iaux,1)) then
 266                         attach = .false.
 267                      endif
 268   335             continue
 269 c
 270                   if ( attach ) then
 271 c
 272                      call gmdtoj ( obterc//'.'//chemin(iaux,1) , kaux )
 273 cgn      write (ulsort,*) obterc//'.'//chemin(iaux,1) , kaux, coergm
 274                      if ( kaux.ne.0 ) then
 275                         mess(1:17) = obterc//'.'//chemin(iaux,1)
 276                         codret = -3
 277                         goto 91
 278                      endif
 279 c
 280                      nbojdd = nbojdd+1
 281                      objdet(nbojdd) = chemin(iaux,1)
 282 c
 283                   endif
 284 c
 285                endif
 286 c
 287   333       continue
 288 c
 289    33    continue
 290 c
 291 c====
 292 c 4. si l'objet est simple : pas de chemin
 293 c====
 294 c
 295        elseif ( ioal.eq.2 ) then
 296 c
 297          codret = -5
 298 c
 299 c====
 300 c 5. l'objet n'est pas alloue
 301 c====
 302 c
 303        else
 304 c
 305          codret = -4
 306 c
 307        endif
 308 c
 309       endif
 310 c
 311 c====
 312 c 9. gestion des erreurs
 313 c====
 314 c
 315    91 continue
 316 c
 317 #ifdef _DEBUG_HOMARD_
 318       write (ulsort,*) '9. Gestions des erreurs ; codret = ', codret
 319       write (ulsort,*) '9. Gestions des erreurs ; coergm = ', coergm
 320 #endif
 321 c
 322       if ( codret.ne.0 ) then
 323 c
 324         write (ulsort,90000)
 325         write (ulsort,texte(langue,1)) 'Sortie', nompro
 326         write (ulsort,texte(langue,6))
 327         write (ulsort,*) nomemc
 328         write (ulsort,texte(langue,4))
 329         if ( abs(codret).le.6 .and. coergm.eq.0 ) then
 330           iaux = 10+abs(codret)
 331           write (ulsort,texte(langue,iaux))
 332         endif
 333         write (ulsort,*) mess
 334         write (ulsort,90000)
 335 c
 336 #include "envex2.h"
 337 c
 338       endif
 339 c
 340 90000 format (1x,70('='))
 341 c
 342       end