src/tool/Utilitaire/utbica.F

   1       subroutine utbica ( commen,
   2      >                    ulsort, langue, codret )
   3 c ______________________________________________________________________
   4 c
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c
  23 c    UTilitaire - BIlan du maillage de CAlcul
  24 c    --           --                   --
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . commen . e   . ch80   . commentaire a ecrire en tete               .
  30 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  31 c . langue . e   .    1   . langue des messages                        .
  32 c .        .     .        . 1 : francais, 2 : anglais                  .
  33 c . codret .  s  .    1   . code de retour des modules                 .
  34 c .        .     .        . 0 : pas de probleme                        .
  35 c .        .     .        . 1 : probleme                               .
  36 c .____________________________________________________________________.
  37 c
  38 c====
  39 c 0. declarations et dimensionnement
  40 c====
  41 c
  42 c 0.1. ==> generalites
  43 c
  44       implicit none
  45       save
  46 c
  47       character*6 nompro
  48       parameter ( nompro = 'UTBICA' )
  49 c
  50 #include "nblang.h"
  51 c
  52 c 0.2. ==> communs
  53 c
  54 #include "nbutil.h"
  55 #include "impr02.h"
  56 c
  57 c 0.3. ==> arguments
  58 c
  59       integer ulsort, langue, codret
  60 c
  61       character*(*) commen
  62 c
  63 c 0.4. ==> variables locales
  64 c
  65       integer iaux, jaux, kaux
  66       integer tabaux(0:7)
  67 c
  68       character*50 texte1
  69 c
  70       integer nbmess
  71       parameter (nbmess = 10 )
  72       character*80 texte(nblang,nbmess)
  73 c ______________________________________________________________________
  74 c
  75 c====
  76 c 1. messages
  77 c====
  78 c
  79 #include "impr01.h"
  80 c
  81 #ifdef _DEBUG_HOMARD_
  82       write (ulsort,texte(langue,1)) 'Entree', nompro
  83       call dmflsh (iaux)
  84 #endif
  85 c
  86       texte(1,4) =
  87      > '(5x,''Le maillage de calcul comporte '',i10,'' mailles.'')'
  88       texte(1,5) = '(5x,''Ils sont repartis en :'')'
  89       texte(1,6) =
  90      > '(5x,''Le maillage de calcul est forme de'',i10,1x,a)'
  91 c
  92       texte(2,4) =
  93      > '(5x,''The computationnal mesh contains '',i10,'' meshes.'')'
  94       texte(2,5) = '(5x,''They are spread over :'')'
  95       texte(2,6) =
  96      > '(5x,''The computationnal mesh is made of'',i10,1x,a)'
  97 c
  98  1000 format (5x,'. ',a14,' :',i10)
  99 c
 100       codret = 0
 101 c
 102 c====
 103 c 2. ecriture
 104 c====
 105 c
 106 c 2.1. ==> ecriture des generalites
 107 c
 108       texte1 = '                                                  '
 109       iaux = min(50,len(commen))
 110       if ( iaux.gt.0 ) then
 111          texte1(1:iaux) = commen(1:iaux)
 112       endif
 113       write (ulsort,21000) texte1
 114 21000 format(//,5x,a50,/)
 115 c
 116 c 2.2. ==> ecriture des caracteristiques du maillage de calcul
 117 c
 118       tabaux(0) = nbmapo
 119       tabaux(1) = nbsegm
 120       tabaux(2) = nbtria
 121       tabaux(3) = nbtetr
 122       tabaux(4) = nbquad
 123       tabaux(5) = nbpyra
 124       tabaux(6) = nbhexa
 125       tabaux(7) = nbpent
 126 c
 127       jaux = 0
 128       do 221 , iaux = 0 , 7
 129         if ( tabaux(iaux).gt.0 ) then
 130           jaux = jaux + 1
 131           kaux = iaux
 132         endif
 133   221 continue
 134 c
 135       if ( jaux.gt.1 ) then
 136 c
 137         write (ulsort,texte(langue,4)) nbelem
 138         write (ulsort,texte(langue,5))
 139         do 222 , iaux = 0 , 7
 140           if ( tabaux(iaux).gt.0 ) then
 141             write (ulsort,1000) mess14(langue,3,iaux), tabaux(iaux)
 142           endif
 143   222   continue
 144 c
 145       else
 146 c
 147         write (ulsort,texte(langue,6)) tabaux(kaux),
 148      >                                 mess14(langue,3,kaux)
 149 c
 150       endif
 151 c
 152       end