src/tool/Gestion_MTU/guferm.F

   1       subroutine guferm ( fichie, lfichi, nuroul, 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  Gestionnaire des Unites logiques - FERMeture d'une unite logique
  23 c  -                -                 ----
  24 c ______________________________________________________________________
  25 c .        .     .        .                                            .
  26 c .  nom   . e/s . taille .           description                      .
  27 c .____________________________________________________________________.
  28 c . fichie . e   . ch<200 . nom du fichier a fermer                    .
  29 c . lfichi . e   .    1   . longueur du nom du fichier a fermer        .
  30 c . nuroul . e   .    1   . numero de l'unite logique a fermer         .
  31 c . codret .  s  .    1   . 0  : tout va bien                          .
  32 c .        .     .        . non nul : probleme                         .
  33 c ______________________________________________________________________
  34 c
  35 c====
  36 c 0. declarations et dimensionnement
  37 c====
  38 c
  39 c 0.1. ==> generalites
  40 c
  41       implicit none
  42       save
  43 c
  44       character*6 nompro
  45       parameter ( nompro = 'GUFERM' )
  46 c
  47 #include "genbla.h"
  48 c
  49 #include "gunbul.h"
  50 c
  51 c 0.2. ==> communs
  52 c
  53 c 0.3. ==> arguments
  54 c
  55       integer lfichi, nuroul, codret
  56 c
  57       character*(*) fichie
  58 c
  59 c 0.4. ==> variables locales
  60 c
  61 #include "gulggt.h"
  62 c
  63       integer guimp, raison
  64       integer iaux, code, statfi, l200
  65       integer gunmbr(lgunmb)
  66       integer statut(mbmxul), lnomfi(mbmxul)
  67       integer ulsort, langue
  68       integer typarr
  69 c
  70       character*200 ficloc, nomfic(mbmxul)
  71 c
  72       integer iindef
  73       double precision rindef
  74       character*8 sindef
  75 c
  76       integer nbmess
  77       parameter ( nbmess = 3 )
  78       character*80 texte(nblang,nbmess)
  79 c
  80 c 0.5. ==> initialisations
  81 c
  82 c ______________________________________________________________________
  83 c
  84 c===
  85 c 1. recuperation de l'information
  86 c===
  87 c
  88 #include "impr01.h"
  89 c
  90       code = 1
  91       call gutabl ( code, gunmbr, statut, nomfic, lnomfi )
  92 c
  93       ulsort = gunmbr(16)
  94       langue = gunmbr(17)
  95       typarr = gunmbr(18)
  96 c
  97 #ifdef _DEBUG_HOMARD_
  98       write (ulsort,texte(langue,1)) 'Entree', nompro
  99       call dmflsh (iaux)
 100 #endif
 101 c
 102 c====
 103 c 2. fermeture
 104 c====
 105 c
 106       codret = 0
 107 c
 108       if (nuroul.gt.0 .and. nuroul.le.mbmxul) then
 109         statfi = statut(nuroul)
 110       else
 111         statfi = 0
 112       endif
 113 c
 114       l200 = -1
 115 c
 116 c 2.1. ==> fermeture proprement dite
 117 c
 118       if ( statfi.ge.3 .and. statfi.le.4 ) then
 119 c
 120         close ( unit=nuroul, err=2100, iostat=codret )
 121         goto 2101
 122  2100   continue
 123         if ( codret.eq.0 ) then
 124           codret = -1
 125         endif
 126  2101   continue
 127 c
 128       else
 129 c
 130         write (ulsort,texte(langue,1)) 'Sortie', nompro
 131         l200 = max(0, min( 200, lfichi, len(fichie) ) )
 132         if (l200.gt.0) then
 133           ficloc(1:l200) = fichie(1:l200)
 134         endif
 135         do 210 iaux = l200 + 1, 200
 136           ficloc(iaux:iaux) = ' '
 137   210   continue
 138         write (ulsort,21000) nuroul, ficloc
 139         if ( typarr.eq.0 ) then
 140           guimp = 1
 141           raison = 1
 142           call gustop ( nompro, ulsort, guimp, raison )
 143         else
 144           codret = 3
 145         endif
 146 c
 147       endif
 148 c
 149       if (codret.ne.0.and.l200.lt.0) then
 150         write (ulsort,texte(langue,1)) 'Sortie', nompro
 151         l200 = max(0, min( 200, lfichi, len(fichie) ) )
 152         if (l200.gt.0) then
 153           ficloc(1:l200) = fichie(1:l200)
 154         endif
 155         do 211 iaux = l200 + 1, 200
 156           ficloc(iaux:iaux) = ' '
 157   211   continue
 158         write(ulsort,22000) nuroul, ficloc
 159         if ( typarr.eq.0 ) then
 160           guimp = 1
 161           raison = 1
 162           call gustop ( nompro, ulsort, guimp, raison )
 163         endif
 164       endif
 165 c
 166 c 2.2. ==> inscription dans les listes
 167 c
 168       if ( codret.eq.0 ) then
 169 c
 170         statut(nuroul) = 0
 171 c
 172         call dmindf ( iindef, rindef, sindef )
 173 c
 174         do 22 , iaux = 1 , 25
 175            nomfic(nuroul)(8*(iaux-1)+1:8*iaux) = sindef
 176    22   continue
 177 c
 178         lnomfi(nuroul) = iindef
 179 c
 180       endif
 181 c
 182 c===
 183 c 3. archivage de l'information
 184 c===
 185 c
 186 c     (9): nb actuel d'unites ouvertes form/sequ
 187 c     (10): nb actuel d'unites ouvertes bina/sequ
 188 c     (11): nb actuel d'unites ouvertes form/dire
 189 c     (12): nb actuel d'unites ouvertes form/dire
 190 c
 191       if ( codret.eq.0 ) then
 192 c
 193         gunmbr(statfi+6) = gunmbr(statfi+6) - 1
 194 c
 195         code = 0
 196         call gutabl ( code, gunmbr, statut, nomfic, lnomfi )
 197 c
 198       endif
 199 c
 200 c====
 201 c 4. formats
 202 c====
 203 c
 204 21000 format(
 205      >/,'Erreur lors de la fermeture de l''unite ',i2,
 206      >/,'Fichier :',
 207      >/,a200,
 208      >/,'Ce fichier n''a jamais ete ouvert ...',//)
 209 c
 210 22000 format(
 211      >/,'Erreur lors de la fermeture de l''unite ',i2,
 212      >/,'Fichier :',
 213      >/,a200,//)
 214 c
 215       end