src/tool/AV_Conversion/vcmare.F

   1       subroutine vcmare ( areele, somare, np2are,
   2      >                    hetare, filare, merare,
   3      >                    coexar, arenoe, insoar,
   4      >                    nnosho, nnosca, narsho,
   5      >                    narsca, fameel, noeele,
   6      >                    typele, povoso, voisom,
   7      >                    preare,
   8      >                    arsref, dearef, dejavu,
   9      >                    trav2a,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c    aVant adaptation - Conversion de Maillage - AREtes
  32 c     -                 -             -          ---
  33 c ______________________________________________________________________
  34 c
  35 c but : etablit la table de connectivite des mailles par arete
  36 c       initialisation des tableaux lies aux aretes
  37 c       Si l'estimation nbar00 est trop petite, on retourne une
  38 c       valeur negative pour nbarto.
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . areele .  s  . nbelem . aretes des elements                        .
  44 c .        .     .*nbmaae .                                            .
  45 c . somare .  s  .2*nbar00. numeros des extremites d'arete             .
  46 c . np2are .  s  . nbar00 . noeud milieux des aretes                   .
  47 c . hetare .  s  . rbar00 . historique de l'etat des aretes            .
  48 c . filare .  s  . rbar00 . premiere fille des aretes                  .
  49 c . merare .  s  . rbar00 . mere des aretes                            .
  50 c . coexar .  s  . nbar00*. codes externes sur les aretes              .
  51 c .        .     . nctfar .   1 : famille MED                          .
  52 c .        .     .        .   2 : type de segment                      .
  53 c . arenoe . es  . nbnoto . 0 pour un sommet, le numero de l'arete pour.
  54 c .        .     .        . un noeud milieu                            .
  55 c . insoar .  s  . nbar00 . information sur les sommets des aretes     .
  56 c .        .     .        .  0 : ses deux sommets appartiennent        .
  57 c .        .     .        .      exclusivement a un element soumis a   .
  58 c .        .     .        .      l'adaptation                          .
  59 c .        .     .        . -1 : son 1er sommet appartient a un element.
  60 c .        .     .        .      ignore                                .
  61 c .        .     .        .      le 2nd sommet appartient exclusivement.
  62 c .        .     .        .      a un element soumis a l'adaptation    .
  63 c .        .     .        . -2 : son 2nd sommet appartient a un element.
  64 c .        .     .        .      ignore                                .
  65 c .        .     .        .      le 1er sommet appartient exclusivement.
  66 c .        .     .        .      a un element soumis a l'adaptation
  67 c .        .     .        .  2 : ses deux sommets appartiennent a un   .
  68 c .        .     .        .      element ignore                        .
  69 c . nnosho . e   . rsnoac . numero des noeuds dans HOMARD              .
  70 c . nnosca . e   . rsnoto . numero des noeuds dans le calcul           .
  71 c . narsho .  s  . rsarac . numero des aretes dans HOMARD              .
  72 c . narsca .  s  . rbar00 . numero des aretes du calcul                .
  73 c . fameel . e   . nbelem . famille med des elements                   .
  74 c . noeele . e   . nbelem . noeuds des elements                        .
  75 c .        .     .*nbmane .                                            .
  76 c . typele . e   . nbelem . type des elements pour le code de calcul   .
  77 c . povoso . e   .0:nbnoto. pointeur des voisins par sommet            .
  78 c . voisom . e   . nvosom . voisins des sommets en stockage morse      .
  79 c . preare .  a  . nbnoto . premiere arete partant d'un sommet         .
  80 c . arsref . e   .0:tehmax. numero local de l'arete reliee a un sommet .
  81 c .        .     . *10*3  . 1er champ : type de l'element de reference .
  82 c .        .     .        . 2e champ : numero local du sommet concerne .
  83 c .        .     .        . 3e champ : rang de l'arete envisagee       .
  84 c . dearef . e   .0:tehmax. description des aretes par les numeros     .
  85 c .        .     .  *6*3  . locaux des noeuds sans se preoccuper       .
  86 c .        .     .        . d'orientation                              .
  87 c .        .     .        .1er champ : type de l'element de reference  .
  88 c .        .     .        .2e champ : numero local de l'arete envisagee.
  89 c .        .     .        .3e champ : 1 et 2 pour chaque extremite,    .
  90 c .        .     .        .           3 pour le milieu                 .
  91 c . dejavu .  a  . rbar00 . controle des doublons                      .
  92 c . trav2a . e   . nbnoto . tableau de travail numero 2                .
  93 c .        .     .        . 1, pour un noeud appartenant a au moins un .
  94 c .        .     .        .    element ignore
  95 c .        .     .        . 0, sinon
  96 c .        .     .        . Il servira dans vcmare                     .
  97 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  98 c . langue . e   .    1   . langue des messages                        .
  99 c .        .     .        . 1 : francais, 2 : anglais                  .
 100 c . codret . es  .    1   . code de retour des modules                 .
 101 c .        .     .        . 0 : pas de probleme                        .
 102 c .        .     .        . 2313 : maille double                       .
 103 c .        .     .        . 232 : noeud bizarre                        .
 104 c ______________________________________________________________________
 105 c
 106 c====
 107 c 0. declarations et dimensionnement
 108 c====
 109 c
 110 c 0.1. ==> generalites
 111 c
 112       implicit none
 113       save
 114 c
 115       character*6 nompro
 116       parameter ( nompro = 'VCMARE' )
 117 c
 118 #include "coftex.h"
 119 #include "referx.h"
 120 c
 121 #include "nblang.h"
 122 c
 123 c 0.2. ==> communs
 124 c
 125 #include "envex1.h"
 126 c
 127 #include "dicfen.h"
 128 #include "envca1.h"
 129 #include "nbutil.h"
 130 #include "nombno.h"
 131 #include "refere.h"
 132 #include "refert.h"
 133 #include "nombar.h"
 134 #include "nombsr.h"
 135 #include "nomest.h"
 136 #include "rftmed.h"
 137 #include "impr02.h"
 138 c
 139 c 0.3. ==> arguments
 140 c
 141       integer areele(nbelem,nbmaae)
 142       integer somare(2,nbar00)
 143       integer np2are(nbar00)
 144       integer nnosho(rsnoac), nnosca(rsnoto)
 145       integer narsho(rsarac), narsca(rbar00)
 146       integer hetare(nbar00), filare(nbar00), insoar(nbar00)
 147       integer merare(nbar00)
 148       integer coexar(nbar00,nctfar)
 149       integer arenoe(nbnoto)
 150       integer fameel(nbelem), noeele(nbelem,nbmane), typele(nbelem)
 151       integer arsref(0:tehmax,10,3), dearef(0:tehmax,12,3)
 152       integer voisom(nvosom), povoso(0:nbnoto), preare(nbnoto)
 153       integer dejavu(nbar00)
 154       integer trav2a(rsnoto)
 155 c
 156       integer ulsort, langue, codret
 157 c
 158 c 0.4. ==> variables locales
 159 c
 160       integer iaux
 161       integer poinde, poinfi, point, nucode
 162       integer mloc, n, nbas, nbnd, nloc, mglo, sommet, milieu
 163       integer aloc, ar, larete, nuar, elem, typhom
 164 #ifdef _DEBUG_HOMARD_
 165       integer glop
 166 #endif
 167 c
 168       integer nbmess
 169       parameter ( nbmess = 20 )
 170       character*80 texte(nblang,nbmess)
 171 c
 172 c 0.5. ==> initialisations
 173 c ______________________________________________________________________
 174 c
 175 c====
 176 c 1. preliminaires
 177 c====
 178 c
 179 c 1.1. ==> messages
 180 c
 181 #include "impr01.h"
 182 c
 183 #ifdef _DEBUG_HOMARD_
 184       write (ulsort,texte(langue,1)) 'Entree', nompro
 185       call dmflsh (iaux)
 186 #endif
 187 c
 188       texte(1,4) = '(/,''Les deux elements suivants sont doubles :'')'
 189       texte(1,5) = '(''Numero dans le calcul   : '',i10)'
 190       texte(1,6) = '(''Famille MED : '',i4,'' ; type : '',i4)'
 191       texte(1,7) =
 192      >'(''  Ses noeuds (numerotation du calcul) : '',/,10i10)'
 193       texte(1,8) =
 194      >'(''  Ses noeuds (numerotation HOMARD) : '',/,10i10)'
 195       texte(1,9) = '(''Le noeud'',i10,'' apparait plusieurs fois.'')'
 196       texte(1,10) =
 197      >'(''. Element voisin (numero du calcul)'',i10,'' ('',a,'')'')'
 198       texte(1,11) = '(''Estimation du nombre d''''aretes :'',i10)'
 199       texte(1,12) = '(''Ce nombre est trop petit.'')'
 200 c
 201       texte(2,4) = '(/,''The following two elements are double:'')'
 202       texte(2,5) = '(''# in calculation    : '',i10)'
 203       texte(2,6) = '(''MED family : '',i4,'' ; type : '',i4)'
 204       texte(2,7) =
 205      > '(''  Its nodes (with calculation #) : '',/,10i10)'
 206       texte(2,8) =
 207      > '(''  Its nodes (with HOMARD #) : '',/,10i10)'
 208       texte(2,9) = '(''Node'',i10,'' is present several times.'')'
 209       texte(2,10) =
 210      >'(''. Neighbour element (calculation #)'',i10,'' ('',a,'')'')'
 211       texte(2,11) = '(''Estimation of the number of edges:'',i10)'
 212       texte(2,12) = '(''This number is too low.'')'
 213 c
 214 #include "impr03.h"
 215 c
 216 c 1.2. ==> mise a zero
 217 c
 218       codret = 0
 219 c
 220       do 11 , sommet = 1 , nbnoto
 221         preare(sommet) = 0
 222         arenoe(sommet) = 0
 223    11 continue
 224 c
 225       do 12 , larete = 1 , rsarac
 226         narsho(larete) = 0
 227    12 continue
 228 c
 229       do 13 , nucode = 1 , nctfar
 230         do 131 , larete = 1 , nbar00
 231           coexar(larete,nucode) = 0
 232   131   continue
 233    13 continue
 234 c
 235       do 14 , larete = 1 , rbar00
 236         dejavu(larete) = 0
 237    14 continue
 238 c
 239       nbarto = 0
 240 c
 241 c====
 242 c 2. on passe en revue chaque sommet
 243 c     remarque : l'exploration se fait dans la numerotation HOMARD
 244 c     ses elements voisins sont dans le tableau voisom, aux places
 245 c     comprises entre povoso(somm-1)+1 et povoso(somm), somm etant le
 246 c     numero dans le calcul correspondant au numero sommet dans
 247 c     homard
 248 c     remarque : si on ne tenait pas compte de certains elements, les
 249 c     quadrangles par exemple, cela est automatiquement traite avec
 250 c     les tableaux povoso/voisom.
 251 c====
 252 c
 253 #ifdef _DEBUG_HOMARD_
 254       write (ulsort,90002) '2. chaque sommet ; codret', codret
 255 #endif
 256 c
 257       do 21 , sommet = 1 , nbnoto
 258 c
 259 #ifdef _DEBUG_HOMARD_
 260         if ( sommet.le.0 ) then
 261           glop = 1
 262         else
 263           glop = 0
 264         endif
 265 #endif
 266 #ifdef _DEBUG_HOMARD_
 267         if ( glop.ne.0 ) then
 268         write (ulsort,*) ' '
 269         write (ulsort,90002) mess14(langue,2,-1), sommet
 270         endif
 271 #endif
 272 c
 273         poinde = povoso(nnosca(sommet)-1) + 1
 274         poinfi = povoso(nnosca(sommet))
 275
 276 cgn        write(ulsort,90002) 'pointeur debut et fin', poinde, poinfi
 277 c
 278         do 22 , point = poinde , poinfi
 279 c
 280 c 2.1. ==> caracterisation de l'element
 281 c         elem : son numero global
 282 c         typhom : son type dans HOMARD
 283 c         nbnd : son nombre de noeuds
 284 c
 285           elem = voisom(point)
 286           typhom = medtrf(typele(elem))
 287           nbnd = nbnref(typhom,1)
 288 #ifdef _DEBUG_HOMARD_
 289         if ( glop.ne.0 ) then
 290         iaux = typhom + mod(typhom,2)
 291         iaux = iaux / 2
 292         write (ulsort,texte(langue,10)) elem, mess14(langue,1,iaux)
 293         write (ulsort,texte(langue,7)) (noeele(elem,n),n=1,nbnd)
 294         write (ulsort,texte(langue,8)) (nnosho(noeele(elem,n)),n=1,nbnd)
 295         endif
 296 #endif
 297 c
 298 c 2.2. ==> recherche de nloc, numero local du sommet en cours d'examen
 299 c          vis-a-vis de la description de l'element de reference
 300 c
 301           do 221 , n = 1 , nbnd
 302             if ( sommet.eq.nnosho(noeele(elem,n)) ) then
 303               nloc = n
 304               goto 2211
 305             endif
 306   221     continue
 307  2211     continue
 308 #ifdef _DEBUG_HOMARD_
 309         if ( glop.ne.0 ) then
 310             write(*,*) '. pour no =',sommet, ', nloc =',nloc
 311         endif
 312 #endif
 313 c
 314 c 2.3. ==> on explore toutes les aretes qui partent de ce sommet de
 315 c         numero local nloc
 316 c         nbas : le nombre d'aretes qui partent de chaque sommet
 317 c         aloc : numero local de la a-eme arete envisagee
 318 c         mloc : numero local de l'autre extremite
 319 c         mglo : numero global de l'autre extremite, dans la
 320 c                numerotation homard
 321 c
 322           nbas = nasref(typhom)
 323 c  ATTENTION : verrue pour le  dernier noeud de la pyramide
 324 c
 325           if ( typhom.eq.tyhpy1 .or. typhom.eq.tyhpy2 ) then
 326             if ( nloc.eq.5 ) then
 327               nbas = nbas + 1
 328             endif
 329           endif
 330 c
 331           do 223 , iaux = 1 , nbas
 332 c
 333             aloc = arsref(typhom,nloc,iaux)
 334 #ifdef _DEBUG_HOMARD_
 335         if ( glop.ne.0 ) then
 336             write(*,*) '.. iaux =',iaux,', aloc =',aloc
 337         endif
 338 #endif
 339             if ( dearef(typhom,aloc,1).eq.nloc ) then
 340               mloc = dearef(typhom,aloc,2)
 341             else
 342               mloc = dearef(typhom,aloc,1)
 343             endif
 344             mglo = nnosho(noeele(elem,mloc))
 345 #ifdef _DEBUG_HOMARD_
 346         if ( glop.ne.0 ) then
 347             write(*,*) '.. mglo =',mglo
 348         endif
 349 #endif
 350 c
 351 c 2.3.1. ==> . si la seconde extremite a un numero global plus grand que
 352 c            le sommet en cours d'examen, il faut chercher si l'arete
 353 c            de sommet vers somm2 a deja ete cree.
 354 c            la recherche de cette arete ne se fait pas parmi toutes les
 355 c            aretes deja creees, mais seulement parmi celles qui partent
 356 c            du sommet en cours. la premiere d'entre elles, si elle
 357 c            existe, est numerotee nuar=preare(sommet). Ce sont les
 358 c            dernieres aretes qui viennent d'etre creees, donc la
 359 c            recherche est rapide car elle ne porte que sur quelques
 360 c            aretes : au pire toutes celles partant du sommet en cours.
 361 c            . si la seconde extremite a un numero global egal a celui
 362 c            du sommet en cours d'examen, c'est qu'il y a un probleme
 363 c            dans le maillage de depart.
 364 c            . si la seconde extremite a un numero global plus petit que
 365 c            le sommet en cours d'examen, rien n'est a faire, car le
 366 c            traitement a deja ete fait lors de l'exploration de mglo.
 367 c
 368             if ( sommet.lt.mglo ) then
 369 c
 370 c 2.3.1.1. ==> recherche d'une eventuelle arete qui aurait deja ete
 371 c              creee entre sommet et mglo
 372 c
 373               larete = 0
 374               nuar = preare(sommet)
 375               if ( nuar.ne.0 ) then
 376                 do 2231 , ar = nuar , nbarto
 377                   if ( somare(2,ar).eq.mglo ) then
 378                     larete = ar
 379                     goto 2232
 380                   endif
 381  2231           continue
 382               endif
 383  2232         continue
 384 c
 385 c 2.3.1.2. ==> Lorsque l'arete n'a pas ete trouvee, il faut la creer ;
 386 c              . elle est definie par ses deux extremites ;
 387 c              . on memorise le noeud milieu si on est en degre 2 ;
 388 c              . si l'arete n'est pas un element au sens du code de
 389 c                calcul, la caracteristique est nulle et il n'y a pas
 390 c                de probleme pour la renumerotation.
 391 c              Si aucune arete ne partait deja du sommet, on la
 392 c              memorise dans preare
 393 c              remarque : il ne faut pas oublier de tenir compte d'une
 394 c              eventuelle renumerotation des noeuds ; c'est fait
 395 c              auparavant pour les deux extremites, sommet et mglo, et
 396 c              il faut le faire pour le milieu eventuel.
 397 c
 398               if ( larete.eq.0 ) then
 399                 nbarto = nbarto + 1
 400                 if ( nbarto.gt.nbar00 ) then
 401                   nbarto = - nbarto
 402                   goto 29
 403                 endif
 404                 larete = nbarto
 405                 somare(1,larete) = sommet
 406                 somare(2,larete) = mglo
 407 #ifdef _DEBUG_HOMARD_
 408         if ( glop.ne.0 ) then
 409           write(*,*) '... Creation de l''arete de ', sommet,' a ',mglo
 410           write(*,*) '... Elle a pour numero',larete
 411         endif
 412 #endif
 413                 if ( degre.eq.2 ) then
 414                   milieu = nnosho(noeele(elem,dearef(typhom,aloc,3)))
 415 #ifdef _DEBUG_HOMARD_
 416         if ( glop.ne.0 ) then
 417              write(*,*) '... Noeud milieu',milieu
 418         endif
 419 #endif
 420                   np2are(larete) = milieu
 421                   arenoe(milieu) = larete
 422                 endif
 423                 if ( typhom.ne.tyhse1 .and. typhom.ne.tyhse2 ) then
 424                   coexar(larete,cofamd) = 0
 425                   coexar(larete,cotyel) = 0
 426                   if ( rbar00.ne.0 ) then
 427                     narsca(larete) = 0
 428                   endif
 429                 endif
 430                 if ( preare(sommet).eq.0 ) then
 431                   preare(sommet) = larete
 432                 endif
 433               endif
 434 c
 435 c 2.3.1.3. ==> si l'arete est un element au sens du calcul, il faut
 436 c              se souvenir de son type (linear beam, tapered beam, ...)
 437 c              et de sa famille MED.
 438 c              attention : il faut se poser la question a chaque fois,
 439 c              car l'arete a pu etre definie auparavant comme un cote
 440 c              de face et donc aura ete mise avec des caracteristiques
 441 c              nulles.
 442 c              en revanche, si on y est deja passe pour un autre
 443 c              element, il y a malaise : c'est un element double !
 444 c
 445               if ( typhom.eq.tyhse1 .or. typhom.eq.tyhse2 ) then
 446 c
 447                 if ( dejavu(larete).ne.0 .and.
 448      >               dejavu(larete).ne.elem ) then
 449 c
 450                   write(ulsort,texte(langue,4))
 451                   write(ulsort,texte(langue,5)) elem
 452                   write(ulsort,texte(langue,6)) fameel(elem),
 453      >                                          typele(elem)
 454                   write(ulsort,texte(langue,7))
 455      >                              (noeele(elem,n),n=1,nbnd)
 456                   write(ulsort,texte(langue,8))
 457      >                              (nnosho(noeele(elem,n)),n=1,nbnd)
 458                   write(ulsort,texte(langue,5)) dejavu(larete)
 459                   write(ulsort,texte(langue,6)) fameel(dejavu(larete)),
 460      >                                          typele(dejavu(larete))
 461                   write(ulsort,texte(langue,8))
 462      >                              (noeele(dejavu(larete),n),n=1,nbnd)
 463                   write(ulsort,texte(langue,7))
 464      >                       (nnosho(noeele(dejavu(larete),n)),n=1,nbnd)
 465                   codret = 2313
 466 c
 467                 else
 468 c
 469                   coexar(larete,cofamd) = fameel(elem)
 470                   coexar(larete,cotyel) = typele(elem)
 471                   narsho(elem) = larete
 472                   narsca(larete) = elem
 473                   dejavu(larete) = elem
 474 c
 475                 endif
 476 c
 477               endif
 478 c
 479 c 2.3.1.4. ==> on stocke le numero de l'arete dans la connectivite
 480 c              descendante de l'element
 481 c
 482 ccc         write(*,*) 'elem =',elem,', aloc =',aloc,', larete =',larete
 483               areele(elem,aloc) = larete
 484 c
 485 c 2.3.2. ==> probleme car le noeud apparait plusieurs fois
 486 c
 487             elseif ( sommet.eq.mglo ) then
 488 c
 489               write (ulsort,90002) mess14(langue,2,13), elem
 490               write(ulsort,texte(langue,9)) sommet
 491               write(ulsort,texte(langue,7)) (noeele(elem,n),n=1,nbnd)
 492               write(ulsort,texte(langue,7))
 493      >                  (nnosho(noeele(elem,n)),n=1,nbnd)
 494               write(ulsort,*) ' '
 495               codret = 232
 496               goto 22
 497 c
 498             endif
 499 c
 500   223     continue
 501 c
 502    22   continue
 503 c
 504    21 continue
 505 c
 506    29 continue
 507 c
 508 c====
 509 c 3. consequences
 510 c====
 511 #ifdef _DEBUG_HOMARD_
 512       write (ulsort,90002) '3. consequences ; codret', codret
 513 #endif
 514 c
 515       if ( codret.eq.0 ) then
 516 c
 517 #ifdef _DEBUG_HOMARD_
 518       write (ulsort,90002) 'nbarto', nbarto
 519 #endif
 520 c
 521 c 3.1. ==> initialisations :
 522 c
 523 c     . on suppose que l'on part d'un macro-maillage
 524 c     . la premiere caracteristique a ete initialisee, les autres sont
 525 c       initialisees a 0
 526 c     . l'etat vaut 0
 527 c     . il n'y a ni fille, ni mere
 528 c
 529       nbarac = nbarto
 530       nbarma = nbarto
 531       nbarpe = nbarto
 532       nbarde = 0
 533       nbart2 = 0
 534       nbarq2 = 0
 535       nbarq3 = 0
 536       nbarq5 = 0
 537       nbarin = 0
 538 c
 539       do 32 , larete = 1 , nbarto
 540         hetare(larete) = 0
 541         filare(larete) = 0
 542         merare(larete) = 0
 543    32 continue
 544 c
 545 c 3.2. ==> nombres propres a la renumerotation des aretes
 546 c
 547       if ( rbar00 .ne. 0 ) then
 548         rsarto = nbarto
 549       else
 550         rsarto = 0
 551       endif
 552 c
 553       endif
 554 c
 555 c====
 556 c 4. Quand des elements sont ignores :
 557 c     informations supplementaires sur les aretes
 558 c            2 : ses deux sommets appartiennent a un element ignore
 559 c           -1 : son 1er sommet appartient a un element ignore
 560 c                le 2nd appartient exclusivement a un element soumis
 561 c                a adaptation
 562 c           -2 : son 2nd sommet appartient a un element ignore
 563 c                le 1er appartient exclusivement a un element soumis
 564 c                a adaptation
 565 c            0 : ses deux sommets appartiennent exclusivement a un
 566 c                element soumis a l'adaptation
 567 c====
 568 #ifdef _DEBUG_HOMARD_
 569       write (ulsort,90002) '4. ignores ; codret', codret
 570 #endif
 571 c
 572       if ( codret.eq.0 ) then
 573 c
 574       if ( nbelig.ne.0 ) then
 575 c
 576         do 41 , larete = 1 , nbarto
 577 c
 578           if ( trav2a(nnosca(somare(1,larete))).eq.1 ) then
 579             if ( trav2a(nnosca(somare(2,larete))).eq.1 ) then
 580               insoar(larete) = 2
 581             else
 582               insoar(larete) = -1
 583             endif
 584           elseif ( trav2a(nnosca(somare(2,larete))).eq.1 ) then
 585             insoar(larete) = -2
 586           else
 587             insoar(larete) = 0
 588           endif
 589 cgn          print 1789,larete,nnosca(somare(1,larete)),
 590 cgn     >        nnosca(somare(2,larete)),insoar(larete)
 591 cgn 1789  format(4i5)
 592 c
 593    41   continue
 594 c
 595       endif
 596 c
 597       endif
 598 c
 599 #ifdef _DEBUG_HOMARD_
 600       if ( nbarto.lt.0 ) then
 601         write (ulsort,texte(langue,11)) nbar00
 602         write (ulsort,texte(langue,12))
 603       endif
 604 #endif
 605 c
 606 c====
 607 c 5. la fin
 608 c====
 609 c
 610       if ( codret.ne.0 ) then
 611 c
 612 #include "envex2.h"
 613 c
 614       write (ulsort,texte(langue,1)) 'Sortie', nompro
 615       write (ulsort,texte(langue,2)) codret
 616 c
 617       endif
 618 c
 619 #ifdef _DEBUG_HOMARD_
 620       write (ulsort,texte(langue,1)) 'Sortie', nompro
 621       call dmflsh (iaux)
 622 #endif
 623 c
 624       end