src/tool/Gestion_MTU/gmdesa.F

   1       subroutine gmdesa ( nomtab )
   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 . derniere modif octo 93 gn double precision
  23 c .          modif juin 93 jyb prise en compte du type character*8
  24 c .          modif 15/06/89 jc jyb
  25 c ......................................................................
  26 c .
  27 c .  - interet:
  28 c .     permet de liberer la place occupee par un tableau reel, entier
  29 c .     ou caractere*8 en indiquant simplement
  30 c .     le nom sous lequel il a ete cree.
  31 c .     'attention' : ceci suppose que le nom apparaisse une fois
  32 c .     et une seule
  33 c .
  34 c .  - arguments:
  35 c .       nomtab --> chaine de 8 car. maxi contenant le nom du tableau
  36 c .                      (reel ou entier) a liberer
  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 c
  48       character*6 nompro
  49       parameter ( nompro = 'GMDESA' )
  50 c
  51 #include "genbla.h"
  52 #include "gmmaxt.h"
  53 c
  54 c 0.2. ==> communs
  55 c
  56 #include "gmtrrl.h"
  57 #include "gmtren.h"
  58 #include "gmtrst.h"
  59 #include "gmalrl.h"
  60 #include "gmalen.h"
  61 #include "gmalst.h"
  62 #include "gmimpr.h"
  63 #include "gmcoer.h"
  64 #include "envex1.h"
  65 #include "gmlang.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       character *(*) nomtab
  70 c
  71 c 0.4. ==> variables locales
  72 c
  73       character*1 carint(1)
  74       character*8   nomvar
  75 c
  76       integer ilong
  77       integer iaux
  78 c
  79       integer icptr, numr, icpti, numi, icpts, nums
  80       integer nbcain
  81 c
  82       logical detlg0
  83 c
  84       integer nbmess
  85       parameter ( nbmess = 10 )
  86       character*80 texte(nblang,nbmess)
  87 c
  88 c====
  89 c 1. initialisations
  90 c====
  91 c
  92 #include "impr01.h"
  93 c
  94 #ifdef _DEBUG_HOMARD_
  95       write (ulsort,texte(langue,1)) 'Entree', nompro
  96       call dmflsh (iaux)
  97 #endif
  98 c
  99 c====
 100 c 2. recherche des caracteristiques associe au tableau demande
 101 c====
 102 c
 103 c 2.1. ==> nature du nom
 104 c          aucun caractere n'est interdit, mais on met un blanc
 105 c          dans le tableau pour ne plus avoir de messages ftnchek
 106 c
 107       nbcain = 0
 108       carint(1) = ' '
 109       call gmntve ( nomtab, nomvar, nbcain, carint, coergm )
 110 c
 111       if ( coergm.ne.0 ) then
 112          write(ulsort,20000) nomtab
 113 20000    format( 2x,' mauvais appel au spg gmdesa',
 114      >          /,4x,'   ===>  arret dans le gestionnaire de memoire')
 115         goto 9999
 116       endif
 117 c
 118       ilong = 0
 119 c
 120 c 2.1. ==> controle de nom donne en double dans une categorie
 121 c
 122       icptr = 0
 123       do 21  iaux = 1, nballr
 124         if ( nomvar.eq.nomalr(iaux) ) then
 125            icptr = icptr + 1
 126            numr = iaux
 127         endif
 128    21 continue
 129       if ( icptr.gt.1) then
 130         coergm = 1
 131         write(ulsort,21000) nomvar
 132 21000   format(//2x,' =====  spg  gmdesa ======',/2x,' le tableau ',
 133      >  a8,' apparait plusieurs fois dans les reels')
 134       endif
 135 c
 136       icpti = 0
 137       do 23  iaux = 1, nballi
 138         if ( nomvar.eq.nomali(iaux) ) then
 139            icpti = icpti + 1
 140            numi = iaux
 141         endif
 142    23 continue
 143       if ( icpti.gt.1) then
 144         coergm = 1
 145         write(ulsort,23000) nomvar
 146 23000   format(//2x,' =====  spg  gmdesa ======',/2x,'le tableau ',
 147      >  a8,' apparait plusieurs fois dans les entiers')
 148       endif
 149 c
 150       icpts = 0
 151       do 24  iaux = 1, nballs
 152         if ( nomvar.eq.nomals(iaux) ) then
 153            icpts = icpts + 1
 154            nums = iaux
 155         endif
 156  24   continue
 157       if ( icpts.gt.1) then
 158         coergm = 1
 159         write(ulsort,24000) nomvar
 160 24000   format(//2x,' =====  spg  gmdesa ======',/2x,'le tableau ',
 161      >  a8,' apparait plusieurs fois dans les character*8')
 162       endif
 163 c
 164       if ( coergm.eq.0 ) then
 165         iaux = icptr + icpti + icpts
 166         if ( iaux.eq.0 ) then
 167           write(ulsort,26001) nomvar
 168 26001     format(//2x,' =====  spg  gmdesa  ======',/2x,'le tableau ',
 169      >  a8,' est inconnu')
 170           coergm = 1
 171         endif
 172         if ( iaux.gt.1 ) then
 173           write(ulsort,26002) nomvar
 174 26002     format(//2x,' =====  spg  gmdesa  ======',/2x,'le tableau ',
 175      >  a8,' apparait dans plusieurs types simples.')
 176           coergm = 1
 177         endif
 178       endif
 179 c
 180 c  verification globale du code retour
 181 c
 182       if ( coergm. ne .0)  then
 183            write(ulsort,20001) nomvar , coergm
 184 20001      format(/2x,' =======  spg gmdesa  =======',/2x,
 185      >     'la recherche du tableau ', a8,' s''est mal passee ',i2)
 186         goto 9999
 187       endif
 188 c
 189 c====
 190 c 3.la demande etant valide, on desalloue le tableau en fonction du type
 191 c   on precise que l'on supprime la memoire
 192 c====
 193 c
 194 c 3.1. ==> on precise que l'on supprime la memoire
 195 c
 196       detlg0 = .true.
 197 c
 198 c 3.2. ==> c'est parti
 199 c
 200 c reel
 201 c
 202       if ( icptr . ne . 0 ) then
 203 c
 204         ilong = lgallr(numr)
 205         call gmdesr ( nomtab , ilong, detlg0 )
 206 c
 207       endif
 208 c
 209 c entier
 210 c
 211       if ( icpti . ne . 0 ) then
 212 c
 213         ilong = lgalli(numi)
 214         call gmdesi ( nomtab , ilong, detlg0 )
 215 c
 216       endif
 217 c
 218 c character*8
 219 c
 220       if ( icpts . ne . 0 ) then
 221 c
 222         ilong = lgalls(nums)
 223         call gmdess ( nomtab , ilong, detlg0 )
 224 c
 225       endif
 226 c
 227 c====
 228 c 3. Fin
 229 c====
 230 c
 231  9999 continue
 232 c
 233       if ( coergm.ne.0 ) then
 234 c
 235 #include "envex2.h"
 236 c
 237       endif
 238 c
 239       end