src/tool/Utilitaire/utmfar.F

   1       subroutine utmfar ( nomail,
   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 - passage de Mere a Fille pour les ARetes
  24 c    --                      -      -              --
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . nomail . e   . char8  . nom de l'objet maillage homard             .
  30 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  31 c . langue . e   .    1   . langue des messages                        .
  32 c .        .     .        . 1 : francais, 2 : anglais                  .
  33 c . codret . es  .    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 = 'UTMFAR' )
  49 c
  50 #include "nblang.h"
  51 c
  52 c 0.2. ==> communs
  53 c
  54 #include "envex1.h"
  55 c
  56 c 0.3. ==> arguments
  57 c
  58       character*8 nomail
  59 c
  60       integer ulsort, langue, codret
  61 c
  62 c 0.4. ==> variables locales
  63 c
  64       integer iaux
  65       integer degre
  66       integer codre1, codre2
  67       integer codre0
  68 c
  69       character*8 nhenti(2)
  70 c
  71       integer nbmess
  72       parameter ( nbmess = 10 )
  73       character*80 texte(nblang,nbmess)
  74 c
  75 c 0.5. ==> initialisations
  76 c ______________________________________________________________________
  77 c
  78 c====
  79 c 1. messages
  80 c====
  81 c
  82 #include "impr01.h"
  83 c
  84 #ifdef _DEBUG_HOMARD_
  85       write (ulsort,texte(langue,1)) 'Entree', nompro
  86       call dmflsh (iaux)
  87 #endif
  88 c
  89       texte(1,4) =
  90      > '(5x,''Reperage des filles a partir des meres pour les aretes'')'
  91 c
  92       texte(2,4) = '(5x,''Son arrays from father arrays for edges'')'
  93 c
  94 #include "impr03.h"
  95 c
  96 #ifdef _DEBUG_HOMARD_
  97       write (ulsort,texte(langue,4))
  98 #endif
  99 c
 100 c====
 101 c 2. recuperation des donnees du maillage d'entree
 102 c====
 103 #ifdef _DEBUG_HOMARD_
 104       call gmprsx (nompro, nomail//'.Arete')
 105 #endif
 106 c
 107       call gmliat ( nomail, 3, degre, codre1 )
 108       if ( degre.eq.1 ) then
 109         call gmnomc ( nomail//'.Arete.HOM_Se02' , nhenti(1), codre2 )
 110       else
 111         call gmnomc ( nomail//'.Arete.HOM_Se03' , nhenti(1), codre2 )
 112       endif
 113 c
 114       codre0 = min ( codre1, codre2 )
 115       codret = max ( abs(codre0), codret,
 116      >               codre1, codre2 )
 117 c
 118 c====
 119 c 3. Appel du programme generique
 120 c====
 121 c
 122 #ifdef _DEBUG_HOMARD_
 123       write (ulsort,90002) '3. Programme generique ; codret', codret
 124 #endif
 125       if ( codret.eq.0 ) then
 126 c
 127       iaux = 0
 128 #ifdef _DEBUG_HOMARD_
 129       write (ulsort,texte(langue,3)) 'UTMFEN', nompro
 130 #endif
 131       call utmfen ( nhenti(1), nhenti(2), iaux,
 132      >              ulsort, langue, codret )
 133 c
 134       endif
 135 c
 136 c====
 137 c 4. la fin
 138 c====
 139 c
 140       if ( codret.ne.0 ) then
 141 c
 142 #include "envex2.h"
 143 c
 144       write (ulsort,texte(langue,1)) 'Sortie', nompro
 145       write (ulsort,texte(langue,2)) codret
 146 c
 147       endif
 148 c
 149 #ifdef _DEBUG_HOMARD_
 150       write (ulsort,texte(langue,1)) 'Sortie', nompro
 151       call dmflsh (iaux)
 152 #endif
 153 c
 154       end