src/tool/Gestion_MTU/ugstop.F

   1       subroutine ugstop ( appela, messul, guimp, gmimp, raison )
   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 : arreter une execution apres avoir arrete les gestionnaires
  23 c       - gestionnaire de memoire
  24 c       - gestionnaire des mesures de temps de calcul
  25 c       - gestionnaire d'unites logiques
  26 c       - execution elle-meme
  27 c
  28 c       ATTENTION : dans certains cas tordus d'arret de GM ou GU, il y a
  29 c                   bouclage sur l'appel a ugstop. On empeche cela
  30 c                   en ne faisant les impressions qu'au premier appel
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . appela . e   .    1   . nom du programme appelant                  .
  36 c . messul . e   .    1   . unite logique pour les messages            .
  37 c . guimp  . e   .    1   . pilotage des impressions gu                .
  38 c . gmimp  . e   .    1   . pilotage des impressions gm                .
  39 c . raison . e   .    1   . raison de l'appel :                        .
  40 c .        .     .        . 0 : arret normal, sans core                .
  41 c .        .     .        . >0 : call abort -> core                    .
  42 c .        .     .        . <0 : arret des gestionnaires, puis sortie  .
  43 c ______________________________________________________________________
  44 c
  45 c====
  46 c 0. declarations et dimensionnement
  47 c====
  48 c
  49 c 0.1. ==> generalites
  50 c
  51       implicit none
  52       save
  53 c
  54       character*6 nompro
  55       parameter ( nompro = 'UGSTOP' )
  56 c
  57 #include "genbla.h"
  58 c
  59 c 0.2. ==> communs
  60 c
  61 c 0.3. ==> arguments
  62 c
  63       integer messul, raison, guimp, gmimp
  64 c
  65       character *(*) appela
  66 c
  67 c 0.4. ==> variables locales
  68 c
  69       integer lgtage
  70       parameter ( lgtage = 4 )
  71 c
  72       integer code
  73       integer langue
  74       integer tabges(lgtage)
  75 c
  76       integer nropas, enstul, sostul, ulsort
  77       integer iaux, jaux
  78 c
  79       character*06 saux06
  80       character*38 appelo
  81       character*38 saux38
  82 c
  83       logical afaire
  84 c
  85       integer nbmess
  86       parameter ( nbmess = 10 )
  87       character*80 texte(nblang,nbmess)
  88 c
  89 c 0.5. ==> initialisations
  90 c
  91       data nropas / 0 /
  92 c
  93 c ______________________________________________________________________
  94 c
  95 c====
  96 c 1. messages
  97 c====
  98 c
  99       if ( messul.le.0 ) then
 100         call dmunit ( enstul, sostul )
 101         ulsort = sostul
 102       else
 103         ulsort = messul
 104       endif
 105 c
 106 #include "impr01.h"
 107 c
 108       texte(1,4) = ':  A la demande du programme '
 109 c                   12345678901234567890123456789012345678
 110       texte(1,5) = ':           ARRET NORMAL             :'
 111       texte(1,6) = ':   ARRET pour cause de probleme     :'
 112       texte(1,7) = ':   ARRET sur bouclage dans '
 113 c
 114       texte(2,4) = ':    Requested by subroutine '
 115       texte(2,5) = ':            NORMAL STOP             :'
 116       texte(2,6) = ':      STOP because of problem       :'
 117       texte(2,7) = ':   STOP because of loop in '
 118 c
 119 10000 format (
 120      >   15x,'......................................')
 121 10001 format (
 122      >   15x,':                                    :',
 123      > /,15x,a38,
 124      > /,15x,':....................................:')
 125 10002 format (
 126      >   15x,':                                    :',
 127      > /,15x,a38,
 128      > /,15x,a38,
 129      > /,15x,':....................................:')
 130 c
 131 c====
 132 c 2. recuperation de l'etat des differents gestionnaires
 133 c
 134 c     (1): unites logiques (1 : initialise, 0 : non)
 135 c     (2): mesures de temps de calcul (1 : initialise, 0 : non)
 136 c     (3): memoire (1 : initialise, 0 : non)
 137 c     (4): langue (1: francais, 2:anglais)
 138 c====
 139 c
 140 #ifdef _DEBUG_HOMARD_
 141       write (ulsort,texte(1,3)) 'UGTABL', nompro
 142 #endif
 143       code = 1
 144       call ugtabl ( code, tabges, ulsort )
 145 c
 146       langue = tabges(4)
 147 c
 148 #ifdef _DEBUG_HOMARD_
 149       write (ulsort,texte(langue,1)) 'Entree', nompro
 150       call dmflsh (iaux)
 151 #endif
 152 c
 153       if ( langue.le.0 .or. langue.gt.nblang ) then
 154         langue = 1
 155       endif
 156 c
 157 c====
 158 c 3. entete
 159 c====
 160 c
 161       nropas = nropas + 1
 162 c
 163 c recopie prudente du nom de l'appelant, appela dans appelo :
 164 c
 165       iaux = len(appela)
 166 #ifdef _DEBUG_HOMARD_
 167       write (ulsort,texte(langue,3)) 'DMCPCH', nompro
 168 #endif
 169       call dmcpch( appela, iaux, appelo, jaux )
 170 c
 171       if ( jaux.eq.0 ) then
 172         appelo = '? ? ? '
 173         jaux = 6
 174       endif
 175 c
 176 #ifdef _DEBUG_HOMARD_
 177       afaire = .true.
 178 #else
 179       if ( raison.le.0 ) then
 180         afaire = .false.
 181       else
 182         afaire = .true.
 183       endif
 184 #endif
 185 c
 186       if ( raison.ne.0 ) then
 187         write (ulsort,10000)
 188       endif
 189       if ( raison.le.0 ) then
 190         write (ulsort,10001) texte(langue,5)
 191       endif
 192 c
 193       if ( afaire ) then
 194 c
 195       if ( jaux.le.6 ) then
 196         saux06(1:iaux) = appelo(1:jaux)
 197         do 311 , iaux = jaux+1 , 6
 198           saux06(iaux:iaux) = ' '
 199   311   continue
 200         write (ulsort,10001) texte(langue,4)(1:29)//saux06//'  :'
 201       else
 202         saux38(1:2) = ': '
 203         saux38(3:iaux+2) = appelo(1:jaux)
 204         do 312 , iaux = jaux+3 , 38
 205           saux38(iaux:iaux) = ' '
 206   312   continue
 207         saux38(38:38) = ':'
 208         write (ulsort,10002) texte(langue,4)(1:29)//'        :',
 209      >                       saux38//'  :'
 210       endif
 211 c
 212       if ( raison.gt.0 ) then
 213         if ( nropas.eq.1 ) then
 214           write (ulsort,10001) texte(langue,6)
 215         else
 216           write (ulsort,10001) texte(langue,7)(1:29)//nompro//'  :'
 217         endif
 218       endif
 219 c
 220       endif
 221 c
 222       call dmflsh(iaux)
 223 c
 224 c====
 225 c 4. arret de la gestion de la memoire, le cas echeant
 226 c====
 227 c
 228       if ( tabges(3).ne.0 .and. nropas.eq.1 ) then
 229 #ifdef _DEBUG_HOMARD_
 230       write (ulsort,texte(langue,3)) 'GMSTOP', nompro
 231 #endif
 232         call gmstop ( gmimp )
 233         call dmflsh(iaux)
 234       endif
 235 c
 236 c====
 237 c 5. arret de la gestion des mesures de temps de calcul, le cas echeant
 238 c====
 239 c
 240       if ( tabges(2).ne.0 .and. nropas.eq.1 ) then
 241 #ifdef _DEBUG_HOMARD_
 242       write (ulsort,texte(langue,3)) 'GTBILA', nompro
 243 #endif
 244         call gtbila
 245         call dmflsh(iaux)
 246       endif
 247 c
 248 c====
 249 c 6. arret de la gestion unites logiques, le cas echeant
 250 c    . en mode debug, on respecte la decision d'impression.
 251 c    . en mode optim, on n'imprime jamais.
 252 c====
 253 c
 254       if ( tabges(1).ne.0 .and. nropas.eq.1 ) then
 255 #ifdef _DEBUG_HOMARD_
 256       write (ulsort,texte(langue,3)) 'GUBILA', nompro
 257 #endif
 258 #ifdef _DEBUG_HOMARD_
 259         iaux = guimp
 260 #else
 261         iaux = 0
 262 #endif
 263         call gubila ( iaux )
 264         call dmflsh(iaux)
 265       endif
 266 c
 267 c====
 268 c 7. arret general de l'execution :
 269 c      0 : normal
 270 c     >0 : plantage
 271 c     <0 : arret des gestionnaires, mais le programme continue
 272 c====
 273 c
 274       if ( raison.eq.0 ) then
 275         stop
 276       elseif ( raison.gt.0 ) then
 277         call dmabor
 278       else
 279         nropas = 0
 280       endif
 281 c
 282       end