src/tool/Utilitaire/uthonh.F

   1       subroutine uthonh ( noehom, arehom,
   2      >                    homtri, quahom,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c    UTilitaire - HOmologues - Nombres pour HOMARD
  25 c    --           --           -            -
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . noehom . e   . nbnoto . liste etendue des homologues par noeuds    .
  31 c . arehom . e   . nbarto . liste etendue des homologues par aretes    .
  32 c . homtri . e   . nbtrto . ensemble des triangles homologues          .
  33 c . quahom . e   . nbquto . ensemble des quadrangles homologues        .
  34 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  35 c . langue . e   .    1   . langue des messages                        .
  36 c .        .     .        . 1 : francais, 2 : anglais                  .
  37 c . codret . es  .    1   . code de retour des modules                 .
  38 c .        .     .        . 0 : pas de probleme                        .
  39 c .        .     .        . 1 : probleme                               .
  40 c ______________________________________________________________________
  41 c
  42 c====
  43 c 0. declarations et dimensionnement
  44 c====
  45 c
  46 c 0.1. ==> generalites
  47 c
  48       implicit none
  49       save
  50 c
  51       character*6 nompro
  52       parameter ( nompro = 'UTHONH' )
  53 c
  54 #include "nblang.h"
  55 c
  56 c 0.2. ==> communs
  57 c
  58 #include "envex1.h"
  59 c
  60 #include "nombno.h"
  61 #include "nombar.h"
  62 #include "nombtr.h"
  63 #include "nombqu.h"
  64 #include "envca1.h"
  65 #include "impr02.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       integer noehom(nbnoto), arehom(nbarto)
  70       integer homtri(nbtrto), quahom(nbquto)
  71       integer ulsort, langue, codret
  72 c
  73 c 0.4. ==> variables locales
  74 c
  75       integer iaux
  76 c
  77       integer nbmess
  78       parameter ( nbmess = 10 )
  79       character*80 texte(nblang,nbmess)
  80 c
  81 c 0.5. ==> initialisations
  82 c ______________________________________________________________________
  83 c
  84 c====
  85 c 1. initialisations
  86 c====
  87 c
  88 c 1.1. ==> messages
  89 c
  90 #include "impr01.h"
  91 c
  92 #ifdef _DEBUG_HOMARD_
  93       write (ulsort,texte(langue,1)) 'Entree', nompro
  94       call dmflsh (iaux)
  95 #endif
  96 c
  97       texte(1,10) = '(/,''Decompte des equivalences sur les '',a)'
  98       texte(1,4) = '(''--> Ce nombre doit etre pair !'')'
  99       texte(1,5) =
 100      > '(8x,''. Nombre de paires                            :'',i10)'
 101 c
 102       texte(2,10) = '(/,''Description of equivalences over '',a)'
 103       texte(2,4) = '(''--> This number should be even !'')'
 104       texte(2,5) =
 105      > '(8x,''. Number of pairs                             :'',i10)'
 106 c
 107       codret = 0
 108 c
 109 c====
 110 c 2. decompte du nombre de paires de noeuds homologues
 111 c    il faut noter les cas ou un noeud est homologue de lui-meme
 112 c====
 113 c
 114       if ( codret.eq.0 ) then
 115 c
 116 #ifdef _DEBUG_HOMARD_
 117       write (ulsort,texte(langue,10)) mess14(langue,3,-1)
 118 #endif
 119 c
 120       nbpnho = 0
 121 c
 122       do 21 , iaux = 1 , nbnoto
 123         if ( noehom(iaux).eq.iaux ) then
 124           nbpnho = nbpnho + 2
 125         elseif ( noehom(iaux).ne.0 ) then
 126           nbpnho = nbpnho + 1
 127         endif
 128    21 continue
 129 c
 130       if ( mod(nbpnho,2).eq.0 ) then
 131         nbpnho = nbpnho / 2
 132 #ifdef _DEBUG_HOMARD_
 133         write (ulsort,texte(langue,5)) nbpnho
 134 #endif
 135       else
 136         write (ulsort,texte(langue,5)) nbpnho
 137         write (ulsort,texte(langue,4))
 138         codret = 21
 139       endif
 140 c
 141       endif
 142 c
 143 c====
 144 c 3. decompte du nombre de paires de noeuds homologues
 145 c    il faut noter les cas ou une arete est homologue d'elle-meme
 146 c====
 147 c
 148       if ( codret.eq.0 ) then
 149 c
 150       nbpaho = 0
 151 c
 152       if ( homolo.ge.2 ) then
 153 c
 154 #ifdef _DEBUG_HOMARD_
 155         write (ulsort,texte(langue,10)) mess14(langue,3,1)
 156 #endif
 157 c
 158         do 31 , iaux = 1 , nbarto
 159           if ( abs(arehom(iaux)).eq.iaux ) then
 160             nbpaho = nbpaho + 2
 161           elseif ( arehom(iaux).ne.0 ) then
 162             nbpaho = nbpaho + 1
 163           endif
 164    31   continue
 165 c
 166         if ( mod(nbpaho,2).eq.0 ) then
 167           nbpaho = nbpaho / 2
 168 #ifdef _DEBUG_HOMARD_
 169           write (ulsort,texte(langue,5)) nbpaho
 170 #endif
 171         else
 172           write (ulsort,texte(langue,5)) nbpaho
 173           write (ulsort,texte(langue,4))
 174           codret = 31
 175         endif
 176 c
 177       endif
 178 c
 179       endif
 180 c
 181 c====
 182 c 4. decompte du nombre de paires de triangles homologues
 183 c====
 184 c
 185       if ( codret.eq.0 ) then
 186 c
 187       nbptho = 0
 188 c
 189       if ( homolo.ge.3 .and. nbtrto.ne.0 ) then
 190 c
 191 #ifdef _DEBUG_HOMARD_
 192         write (ulsort,texte(langue,10)) mess14(langue,3,2)
 193 #endif
 194 c
 195         do 41 , iaux = 1 , nbtrto
 196           if ( homtri(iaux).ne.0 ) then
 197             nbptho = nbptho + 1
 198           endif
 199    41   continue
 200 c
 201         if ( mod(nbptho,2).eq.0 ) then
 202           nbptho = nbptho / 2
 203 #ifdef _DEBUG_HOMARD_
 204           write (ulsort,texte(langue,5)) nbptho
 205 #endif
 206         else
 207           write (ulsort,texte(langue,5)) nbptho
 208           write (ulsort,texte(langue,4))
 209           codret = 41
 210         endif
 211 c
 212       endif
 213 c
 214       endif
 215 c
 216 c====
 217 c 5. decompte du nombre de paires de quadrangles homologues
 218 c====
 219 c
 220       if ( codret.eq.0 ) then
 221 c
 222       nbpqho = 0
 223 c
 224       if ( homolo.ge.3 .and. nbquto.ne.0 ) then
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227         write (ulsort,texte(langue,10)) mess14(langue,3,4)
 228 #endif
 229 c
 230         do 51 , iaux = 1 , nbquto
 231           if ( quahom(iaux).ne.0 ) then
 232              nbpqho = nbpqho + 1
 233           endif
 234    51   continue
 235 c
 236          if ( mod(nbpqho,2).eq.0 ) then
 237           nbpqho = nbpqho / 2
 238 #ifdef _DEBUG_HOMARD_
 239           write (ulsort,texte(langue,5)) nbpqho
 240 #endif
 241         else
 242           write (ulsort,texte(langue,5)) nbpqho
 243           write (ulsort,texte(langue,4))
 244           codret = 51
 245         endif
 246 c
 247       endif
 248 c
 249       endif
 250 c
 251 c====
 252 c 6. la fin
 253 c====
 254 c
 255       if ( codret.ne.0 ) then
 256 c
 257 #include "envex2.h"
 258 c
 259       write (ulsort,texte(langue,1)) 'Sortie', nompro
 260       write (ulsort,texte(langue,2)) codret
 261 c
 262       endif
 263 c
 264 #ifdef _DEBUG_HOMARD_
 265       write (ulsort,texte(langue,1)) 'Sortie', nompro
 266       call dmflsh (iaux)
 267 #endif
 268 c
 269       end