src/tool/Decision/dehomo.F

   1       subroutine dehomo ( nomail,
   2      >                    lgopti, taopti, lgopts, taopts,
   3      >                    lgetco, taetco,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c traitement des DEcisions - HOMOlogues
  26 c                --          ----
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  32 c . lgopti . e   .   1    . longueur du tableau des options            .
  33 c . taopti . e   . lgopti . tableau des options                        .
  34 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  35 c . taopts . e   . lgopts . tableau des options caracteres             .
  36 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  37 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  38 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  39 c . langue . e   .    1   . langue des messages                        .
  40 c .        .     .        . 1 : francais, 2 : anglais                  .
  41 c . codret . es  .    1   . code de retour des modules                 .
  42 c .        .     .        . 0 : pas de probleme                        .
  43 c .        .     .        . sinon : erreur                             .
  44 c ______________________________________________________________________
  45 c
  46 c====
  47 c 0. declarations et dimensionnement
  48 c====
  49 c
  50 c 0.1. ==> generalites
  51 c
  52       implicit none
  53       save
  54 c
  55       character*6 nompro
  56       parameter ( nompro = 'DEHOMO' )
  57 c
  58 #include "nblang.h"
  59 c
  60 c 0.2. ==> communs
  61 c
  62 #include "envex1.h"
  63 c
  64 #include "gmenti.h"
  65 c
  66 #include "envca1.h"
  67 #include "nombtr.h"
  68 #include "nombqu.h"
  69 c
  70 c 0.3. ==> arguments
  71 c
  72       character*8 nomail
  73 c
  74       integer lgopti
  75       integer taopti(lgopti)
  76 c
  77       integer lgopts
  78       character*8 taopts(lgopts)
  79 c
  80       integer lgetco
  81       integer taetco(lgetco)
  82 c
  83       integer ulsort, langue, codret
  84 c
  85 c 0.4. ==> variables locales
  86 c
  87       integer codava
  88       integer nretap, nrsset
  89       integer iaux
  90       integer jaux
  91 c
  92       integer phetar, psomar
  93       integer phettr, paretr
  94       integer phetqu, parequ
  95 c
  96       integer pdecar, pdecfa
  97       integer adhoar, adhotr, adhoqu
  98 c
  99       integer codre0
 100       integer codre1, codre2
 101 c
 102       character*6 saux
 103       character*8 ntrav1, ntrav2
 104       character*8 norenu
 105       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 106       character*8 nhtetr, nhhexa, nhpyra, nhpent
 107       character*8 nhelig
 108       character*8 nhvois, nhsupe, nhsups
 109 c
 110       integer nbmess
 111       parameter ( nbmess = 10 )
 112       character*80 texte(nblang,nbmess)
 113 c
 114 c 0.5. ==> initialisations
 115 c ______________________________________________________________________
 116 c
 117 c====
 118 c 1. messages
 119 c====
 120 c
 121 #include "impr01.h"
 122 c
 123 #ifdef _DEBUG_HOMARD_
 124       write (ulsort,texte(langue,1)) 'Entree', nompro
 125       call dmflsh (iaux)
 126 #endif
 127 c
 128       codava = codret
 129 c
 130 c=======================================================================
 131       if ( codava.eq.0 ) then
 132 c=======================================================================
 133 c
 134 c 1.0. ==> structure generale
 135 c
 136       if ( codret.eq.0 ) then
 137 c
 138       call utnomh ( nomail,
 139      >                sdim,   mdim,
 140      >               degre, maconf, homolo, hierar,
 141      >              rafdef, nbmane, typcca, typsfr, maextr,
 142      >              mailet,
 143      >              norenu,
 144      >              nhnoeu, nhmapo, nharet,
 145      >              nhtria, nhquad,
 146      >              nhtetr, nhhexa, nhpyra, nhpent,
 147      >              nhelig,
 148      >              nhvois, nhsupe, nhsups,
 149      >              ulsort, langue, codret)
 150 c
 151       endif
 152 c
 153 c=======================================================================
 154       if ( homolo.ge.2 ) then
 155 c=======================================================================
 156 c
 157 c 1.3. ==> les messages
 158 c
 159       texte(1,4) = '(/,a6,'' PRISE EN COMPTE DES HOMOLOGUES'')'
 160       texte(1,5) = '(37(''=''),/)'
 161 c
 162       texte(2,4) = '(/,a6,'' HOMOLOGOUS INFLUENCE'')'
 163       texte(2,5) = '(28(''=''),/)'
 164 c
 165 c 1.4. ==> le numero de sous-etape
 166 c
 167       nretap = taetco(1)
 168       nrsset = taetco(2) + 1
 169       taetco(2) = nrsset
 170 c
 171       call utcvne ( nretap, nrsset, saux, iaux, codret )
 172 c
 173 c 1.5. ==> le titre
 174 c
 175       write (ulsort,texte(langue,4)) saux
 176       write (ulsort,texte(langue,5))
 177 c
 178 #ifdef _DEBUG_HOMARD_
 179       if ( codret.eq.0 ) then
 180 c
 181       write (ulsort,texte(langue,3)) 'DELIST en entree de ', nompro
 182       iaux = 1
 183       call delist ( nomail, nompro, iaux,
 184      >              lgopts, taopts,
 185      >              ulsort, langue, codret )
 186 c
 187       endif
 188 #endif
 189 c
 190 c====
 191 c 2. recuperation des pointeurs
 192 c====
 193 c
 194       if ( codret.eq.0 ) then
 195 c
 196       iaux = 2
 197       if ( homolo.ge.2 ) then
 198         iaux = iaux*29
 199       endif
 200 #ifdef _DEBUG_HOMARD_
 201       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 202 #endif
 203       call utad02 ( iaux, nharet,
 204      >              phetar, psomar,   jaux,   jaux,
 205      >                jaux,   jaux,   jaux,
 206      >                jaux,   jaux,   jaux,
 207      >                jaux, adhoar,   jaux,
 208      >              ulsort, langue, codret )
 209 c
 210       if ( nbtrto.ne.0 ) then
 211 c
 212         iaux = 2
 213         if ( homolo.ge.3 ) then
 214           iaux = iaux*29
 215         endif
 216 #ifdef _DEBUG_HOMARD_
 217       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 218 #endif
 219         call utad02 ( iaux, nhtria,
 220      >                phettr, paretr,   jaux,   jaux,
 221      >                  jaux,   jaux,   jaux,
 222      >                  jaux,   jaux,   jaux,
 223      >                  jaux, adhotr,   jaux,
 224      >                ulsort, langue, codret )
 225 c
 226       endif
 227 c
 228       if ( nbquto.ne.0 ) then
 229 c
 230         iaux = 2
 231         if ( homolo.ge.3 ) then
 232           iaux = iaux*29
 233         endif
 234 #ifdef _DEBUG_HOMARD_
 235       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 236 #endif
 237         call utad02 ( iaux, nhquad,
 238      >                phetqu, parequ,   jaux,   jaux,
 239      >                  jaux,   jaux,   jaux,
 240      >                  jaux,   jaux,   jaux,
 241      >                  jaux, adhoqu,   jaux,
 242      >                ulsort, langue, codret )
 243 c
 244       endif
 245 c
 246       ntrav1 = taopts(11)
 247       call gmadoj ( ntrav1, pdecar, iaux, codre1 )
 248       ntrav2 = taopts(12)
 249       call gmadoj ( ntrav2, pdecfa, iaux, codre2 )
 250 c
 251       codre0 = min ( codre1, codre2 )
 252       codret = max ( abs(codre0), codret,
 253      >               codre1, codre2 )
 254 c
 255       endif
 256 c
 257 c====
 258 c 3. influence des homologues
 259 c====
 260 c
 261       if ( codret.eq.0 ) then
 262 c
 263 #ifdef _DEBUG_HOMARD_
 264       write (ulsort,texte(langue,3)) 'DEHOM1', nompro
 265 #endif
 266       call dehom1 ( taopti(31), taopti(32),
 267      >              imem(phetar),
 268      >              imem(phettr), imem(paretr),
 269      >              imem(phetqu), imem(parequ),
 270      >              imem(adhoar), imem(adhotr), imem(adhoqu),
 271      >              imem(pdecar), imem(pdecfa),
 272      >              ulsort, langue, codret )
 273 c
 274       endif
 275 c
 276 c====
 277 c 4. verification
 278 c====
 279 c
 280 c 4.1. ==> sur les aretes
 281 c
 282       if ( homolo.ge.2 ) then
 283 c
 284       if ( codret.eq.0 ) then
 285 c
 286 #ifdef _DEBUG_HOMARD_
 287       write (ulsort,texte(langue,3)) 'DEHOVA', nompro
 288 #endif
 289       call dehova ( imem(adhoar), imem(pdecar),
 290      >              nompro, 1,
 291      >              ulsort, langue, codret )
 292 c
 293       endif
 294 c
 295       endif
 296 c
 297 c 4.2. ==> sur les triangles
 298 c
 299       if ( homolo.ge.3 .and. nbtrto.ne.0 ) then
 300 c
 301       if ( codret.eq.0 ) then
 302 c
 303 #ifdef _DEBUG_HOMARD_
 304       write (ulsort,texte(langue,3)) 'DEHOVF', nompro
 305 #endif
 306       iaux = 2
 307       call dehovf ( iaux,
 308      >              nbtrto, imem(adhotr), imem(pdecfa),
 309      >              nompro, 1,
 310      >              ulsort, langue, codret )
 311 c
 312       endif
 313 c
 314       endif
 315 c
 316 c 4.3. ==> sur les quadrangles
 317 c
 318       if ( homolo.ge.3 .and. nbquto.ne.0 ) then
 319 c
 320       if ( codret.eq.0 ) then
 321 c
 322 #ifdef _DEBUG_HOMARD_
 323       write (ulsort,texte(langue,3)) 'DEHOVF', nompro
 324 #endif
 325       iaux = 4
 326       call dehovf ( iaux,
 327      >              nbquto, imem(adhoqu), imem(pdecfa),
 328      >              nompro, 1,
 329      >              ulsort, langue, codret )
 330 c
 331       endif
 332 c
 333       endif
 334 c
 335 c====
 336 c 5. la fin
 337 c====
 338 c
 339       if ( codret.ne.0 ) then
 340 c
 341 #include "envex2.h"
 342 c
 343       write (ulsort,texte(langue,1)) 'Sortie', nompro
 344       write (ulsort,texte(langue,2)) codret
 345 c
 346       endif
 347 c
 348 #ifdef _DEBUG_HOMARD_
 349       if ( codret.eq.0 ) then
 350 c
 351       write (ulsort,texte(langue,3)) 'DELIST', nompro
 352       iaux = 2
 353       call delist ( nomail, nompro, iaux,
 354      >              lgopts, taopts,
 355      >              ulsort, langue, codret )
 356 c
 357       endif
 358 #endif
 359 c
 360 #ifdef _DEBUG_HOMARD_
 361       write (ulsort,texte(langue,1)) 'Sortie', nompro
 362       call dmflsh (iaux)
 363 #endif
 364 c
 365 c=======================================================================
 366       endif
 367 c=======================================================================
 368 c
 369 c=======================================================================
 370       endif
 371 c=======================================================================
 372 c
 373       end