src/tool/Suivi_Frontiere/sfcaf2.F

   1       subroutine sfcaf2 ( suifro, ulgrfr,
   2      >                    nbfrdi, geocoo, abscur,
   3      >                    numnoe, lignoe, abscno,
   4      >                    typlig, somseg, seglig,
   5      >                    nbfran, casfre,
   6      >                    unst2x, epsid2,
   7      >                    coonoe,
   8      >                    noehom,
   9      >                    hetare, somare, filare,
  10      >                    np2are, cfaare, famare,
  11      >                    facare, posifa,
  12      >                    hettri, aretri, filtri,
  13      >                    voltri,
  14      >                    hetqua, arequa, filqua,
  15      >                    cfaqua, famqua,
  16      >                    volqua,
  17      >                    lgetco, taetco,
  18      >                    ulsort, langue, codret)
  19 c ______________________________________________________________________
  20 c                             H O M A R D
  21 c
  22 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  23 c
  24 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  25 c aupres des huissiers de justice Simart et Lavoir a Clamart
  26 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  27 c aupres des huissiers de justice
  28 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  29 c
  30 c    HOMARD est une marque deposee d'Electricite de France
  31 c
  32 c Copyright EDF 1996
  33 c Copyright EDF 1998
  34 c Copyright EDF 2002
  35 c Copyright EDF 2020
  36 c ______________________________________________________________________
  37 c
  38 c   Suivi de Frontiere : CAlcul des nouvelles Frontieres - 2
  39 c   --                   --                   -            -
  40 c ______________________________________________________________________
  41 c .        .     .        .                                            .
  42 c .  nom   . e/s . taille .           description                      .
  43 c .____________________________________________________________________.
  44 c . suifro . e   .   1    . 1 : pas de suivi de frontiere              .
  45 c .        .     .        . 2x : frontiere discrete                    .
  46 c .        .     .        . 3x : frontiere analytique                  .
  47 c .        .     .        . 5x : frontiere cao                         .
  48 c . ulgrfr . e   .   *    . unite logique des groupes frontieres CAO   .
  49 c . nbfrdi . e   .   1    . nombre de frontieres discretes             .
  50 c . geocoo . e   .sfnbso**. coordonnees des sommets de la frontiere    .
  51 c . abscur . e   . sfnbse . abscisse curviligne des somm des segments  .
  52 c . numnoe . e   . mcnvnf . liste des noeuds de calcul sur le bord     .
  53 c . lignoe . e   . mcnvnf . liste lignes pour ces noeuds               .
  54 c . abscno . e   . mcnvnf . abscisse curviligne de ces noeuds          .
  55 c . typlig . e   . sfnbli . type de la ligne                           .
  56 c .        .     .        . 0 : ligne ouverte, a 2 extremites          .
  57 c .        .     .        . 1 : ligne fermee                           .
  58 c . somseg . e   . sfnbse . liste des sommets des lignes separees par  .
  59 c                           des 0                                      .
  60 c . seglig . e   .0:sfnbli. pointeur dans le tableau somseg : les      .
  61 c .        .     .        . segments de la ligne i sont aux places de  .
  62 c .        .     .        . seglig(i-1)+1 a seglig(i)-1 inclus         .
  63 c . nbfran . e   .   1    . nombre de frontieres analytiques           .
  64 c . casfre . e   .13nbfran. caracteristiques des frontieres analytiques.
  65 c .        .     .        . 1 : 1., si cylindre                        .
  66 c .        .     .        .     2., si sphere                          .
  67 c .        .     .        .     3., si cone par  origine, axe et angle .
  68 c .        .     .        .     4., si cone par 2 centres et 2 rayons  .
  69 c .        .     .        .     5., si tore                            .
  70 c .        .     .        . de 2 a 13 :                                .
  71 c .        .     .        . . cylindre : 2,3,4 : xcentr, ycentr, zcentr.
  72 c .        .     .        .              5,6,7 : xaxe, yaxe, zaxe      .
  73 c .        .     .        .              8 :     rayon                 .
  74 c .        .     .        . . sphere   : 2,3,4 : xcentr, ycentr, zcentr.
  75 c .        .     .        .              8 :     rayon                 .
  76 c .        .     .        . . cone     : 2,3,4 : xcentr, ycentr, zcentr.
  77 c .        .     .        .              5,6,7 : xaxe, yaxe, zaxe      .
  78 c .        .     .        .              13 :    angle en degre        .
  79 c .        .     .        . . cone 2   : 2,3,4 : xcentr, ycentr, zcentr.
  80 c .        .     .        .              5,6,7 : xaxe, yaxe, zaxe      .
  81 c .        .     .        .              8 :     rayon                 .
  82 c .        .     .        .              9,10,11:xcent2, ycent2, zcent2.
  83 c .        .     .        .              12 :    rayon2                .
  84 c .        .     .        .              13 :    angle en radian       .
  85 c .        .     .        . . tore     : 2,3,4 : xcentr, ycentr, zcentr.
  86 c .        .     .        .              5,6,7 : xaxe, yaxe, zaxe      .
  87 c .        .     .        .              8 :     rayon de revolution   .
  88 c .        .     .        .              12 :    rayon primaire        .
  89 c . unst2x . e   .   1    . inverse de la taille maximale au carre     .
  90 c . epsid2 . e   .   1    . precision relative pour carre de distance  .
  91 c . coonoe . es  . nbnoto . coordonnees des noeuds                     .
  92 c .        .     . *sdim  .                                            .
  93 c . noehom . e   . nbnoto . ensemble des noeuds homologues             .
  94 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  95 c . somare . es  .2*nbarto. numeros des extremites d'arete             .
  96 c . filare . e   . nbarto . premiere fille des aretes                  .
  97 c . np2are . e   . nbarto . noeud milieux des aretes                   .
  98 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  99 c .        .     . nbfare .   1 : famille MED                          .
 100 c .        .     .        .   2 : type de segment                      .
 101 c .        .     .        .   3 : orientation                          .
 102 c .        .     .        .   3 : famille d'orientation inverse        .
 103 c .        .     .        .   5 : numero de ligne de frontiere         .
 104 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
 105 c .        .     .        . <= 0 si non concernee                      .
 106 c .        .     .        .   6 : famille frontiere active/inactive    .
 107 c .        .     .        .   7 : numero de surface de frontiere       .
 108 c .        .     .        . + l : appartenance a l'equivalence l       .
 109 c . famare . es  . nbarto . famille des aretes                         .
 110 c . facare . es  . nbfaar . liste des faces contenant une arete        .
 111 c . posifa . e   . nbarto . pointeur sur tableau facare                .
 112 c . hettri . es  . nbtrto . historique de l'etat des triangles         .
 113 c . aretri . es  .nbtrto*3. numeros des 3 aretes des triangles         .
 114 c . filtri . e   . nbtrto . premier fils des triangles                 .
 115 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
 116 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
 117 c .        .     .        .   0 : pas de voisin                        .
 118 c .        .     .        . j>0 : tetraedre j                          .
 119 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
 120 c . hetqua . es  . nbquto . historique de l'etat des quadrangles       .
 121 c . arequa . es  .nbquto*4. numeros des 3 aretes des quadrangles       .
 122 c . filqua . e   . nbquto . premier fils des quadrangles               .
 123 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
 124 c .        .     . nbfqua .   1 : famille MED                          .
 125 c .        .     .        .   2 : type de quadrangle                   .
 126 c .        .     .        .   3 : numero de surface de frontiere       .
 127 c .        .     .        .   4 : famille des aretes internes apres raf.
 128 c .        .     .        .   5 : famille des triangles de conformite  .
 129 c .        .     .        .   6 : famille de sf active/inactive        .
 130 c .        .     .        . + l : appartenance a l'equivalence l       .
 131 c . famqua . e   . nbquto . famille des quadrangles                    .
 132 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
 133 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
 134 c .        .     .        .   0 : pas de voisin                        .
 135 c .        .     .        . j>0 : hexaedre j                           .
 136 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
 137 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
 138 c . taetco . e   . lgetco . tableau de l'etat courant                  .
 139 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 140 c . langue . e   .    1   . langue des messages                        .
 141 c .        .     .        . 1 : francais, 2 : anglais                  .
 142 c . codret . es  .    1   . code de retour des modules                 .
 143 c .        .     .        . 0 : pas de probleme                        .
 144 c .        .     .        . x : probleme                               .
 145 c ______________________________________________________________________
 146 c
 147 c====
 148 c 0. declarations et dimensionnement
 149 c====
 150 c
 151 c 0.1. ==> generalites
 152 c
 153       implicit none
 154       save
 155 c
 156       character*6 nompro
 157       parameter ( nompro = 'SFCAF2' )
 158 c
 159 #include "nblang.h"
 160 #include "cofaar.h"
 161 #include "cofatq.h"
 162 c
 163 c 0.2. ==> communs
 164 c
 165 #include "envex1.h"
 166 c
 167 #include "envca1.h"
 168 #include "front1.h"
 169 #include "front2.h"
 170 #include "dicfen.h"
 171 #include "nbfami.h"
 172 #include "nombno.h"
 173 #include "nombar.h"
 174 #include "nombqu.h"
 175 #include "nombtr.h"
 176 #include "impr02.h"
 177 c
 178 c 0.3. ==> arguments
 179 c
 180       integer suifro
 181       integer ulgrfr(*)
 182       integer nbfrdi
 183       integer numnoe(mcnvnf), lignoe(mcnvnf)
 184       integer typlig(sfnbli), somseg(sfnbse), seglig(0:sfnbli)
 185       integer nbfran
 186       integer noehom(nbnoto)
 187       integer hetare(nbarto), somare(2,nbarto), filare(nbarto)
 188       integer np2are(nbarto)
 189       integer posifa(0:nbarto), facare(nbfaar)
 190       integer cfaare(nctfar,nbfare), famare(nbarto)
 191       integer hettri(nbtrto), aretri(nbtrto,3), filtri(nbtrto)
 192       integer voltri(2,nbtrto)
 193       integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
 194       integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
 195       integer volqua(2,nbquto)
 196 c
 197       double precision unst2x, epsid2
 198       double precision casfre(13,nbfran)
 199       double precision geocoo(sfnbso,sdim)
 200       double precision abscur(sfnbse)
 201       double precision coonoe(nbnoto,sdim)
 202       double precision abscno(mcnvnf)
 203 c
 204       integer lgetco
 205       integer taetco(lgetco)
 206 c
 207       integer ulsort, langue, codret
 208 c
 209 c 0.4. ==> variables locales
 210 c
 211       integer nretap, nrsset
 212       integer iaux, jaux, kaux
 213 c
 214       integer lenoeu, larete, lequad
 215       integer numfro, numlig, numsur
 216       integer nbsomm, noeud(2), laret1(2), lesegm
 217       integer etan, etanp1
 218       integer sa1a2, sa2a3, sa3a4, sa4a1
 219 c
 220       double precision coopro(3)
 221 c
 222       character*6 saux
 223 c
 224       integer nbmess
 225       parameter ( nbmess = 20 )
 226       character*80 texte(nblang,nbmess)
 227 c
 228 c 0.5. ==> initialisations
 229 c
 230 #ifdef _DEBUG_HOMARD_
 231       integer glop
 232       data glop /0/
 233 #endif
 234 c ______________________________________________________________________
 235 c
 236 c====
 237 c 1. messages
 238 c====
 239 c
 240       codret = 0
 241 c
 242 #include "impr01.h"
 243 c
 244 #ifdef _DEBUG_HOMARD_
 245       write (ulsort,texte(langue,1)) 'Entree', nompro
 246       call dmflsh (iaux)
 247 #endif
 248 c
 249       texte(1,4) = '(/,a6,'' SUIVI DES FRONTIERES'')'
 250       texte(1,5) = '(27(''=''),/)'
 251       texte(1,6) = '(''Nombre de frontieres discretes   :'',i8)'
 252       texte(1,7) = '(''Nombre de frontieres analytiques :'',i8)'
 253       texte(1,8) =
 254      > '(/,''. Examen du '',a,i10,'' (frontiere numero'',i8,'')'')'
 255       texte(1,9) = '(''... '',a,i10,'' a deplacer'')'
 256       texte(1,10) = '(''... Il est entre les '',a,i10,'' et'',i10)'
 257       texte(1,11) =
 258      > '(''. Type de frontiere analytique inconnu :'',i10)'
 259 c
 260       texte(2,4) = '(/,a6,'' BOUNDARY FITTING'')'
 261       texte(2,5) = '(23(''=''),/)'
 262       texte(2,6) = '(''Number of discrete boundaries  :'',i8)'
 263       texte(2,7) = '(''Number of analytical boundaries:'',i8)'
 264       texte(2,8) =
 265      >'(/,''. Examination of '',a,'' #'',i10,'' (boundary #'',i8,'')'')'
 266       texte(2,9) = '(''... '',a,'' #'',i10,'' to move'')'
 267       texte(2,10) =
 268      > '(''... It is between '',a,'' #'',i10,'' and #'',i10)'
 269       texte(2,11) =
 270      > '(''. Unknown analytical boundary type:'',i10)'
 271 c
 272 #include "impr03.h"
 273 c
 274 c 1.4. ==> le numero de sous-etape
 275 c
 276       if ( mod(suifro,5).ne.0 ) then
 277 c
 278       nretap = taetco(1)
 279       nrsset = taetco(2) + 1
 280       taetco(2) = nrsset
 281 c
 282       call utcvne ( nretap, nrsset, saux, iaux, codret )
 283 c
 284       endif
 285 c
 286 c 1.5. ==> le titre
 287 c
 288       if ( mod(suifro,5).ne.0 ) then
 289 c
 290       write (ulsort,texte(langue,4)) saux
 291       write (ulsort,texte(langue,5))
 292 c
 293       endif
 294 c
 295 #ifdef _DEBUG_HOMARD_
 296       write (ulsort,90002) 'suifro',suifro
 297       write (ulsort,texte(langue,6)) nbfrdi
 298       write (ulsort,texte(langue,7)) nbfran
 299 #endif
 300 c
 301 c====
 302 c 2. boucle sur les noeuds homologues
 303 c    attention : rien pour le moment
 304 c====
 305 c
 306 #ifdef _DEBUG_HOMARD_
 307       write (ulsort,90002) '2. boucle homologues ; codret', codret
 308 #endif
 309 c
 310 c====
 311 c 3. boucle sur les aretes
 312 c    On ne s'interesse qu'aux aretes qui viennent d'etre decoupees
 313 c    et qui font partie d'une frontiere reconnue
 314 c====
 315 c
 316 #ifdef _DEBUG_HOMARD_
 317       write (ulsort,90002) '3. boucle aretes ; codret', codret
 318       write (ulsort,90002) 'nbarto', nbarto
 319       write (ulsort,90002) 'cosfli', cosfli
 320       write (ulsort,90002) 'cosfsa', cosfsa
 321 #endif
 322 c
 323       do 31 , larete = 1 , nbarto
 324 c
 325         if ( codret.eq.0 ) then
 326 #ifdef _DEBUG_HOMARD_
 327           if ( larete.eq.-2793 .or. larete.eq.-3534 ) then
 328             glop = 1
 329           else
 330             glop = 0
 331           endif
 332 #endif
 333 c
 334         if ( hetare(larete).eq.2 ) then
 335 c
 336           numlig = cfaare(cosfli,famare(larete))
 337           numsur = cfaare(cosfsa,famare(larete))
 338           numfro = max(numlig,numsur)
 339 c
 340           if ( numfro.gt.0 ) then
 341 #ifdef _DEBUG_HOMARD_
 342         if ( glop.gt.0 ) then
 343       write (ulsort,texte(langue,8)) mess14(langue,1,1), larete, numfro
 344         endif
 345 #endif
 346 c
 347 c 3.1. ==> reperage des noeuds a bouger
 348 c
 349             if ( typsfr.le.2 ) then
 350 c
 351 c 3.1. ==> typsfr = 1 : on est en en degre 1 ; on doit bouger le nouveau
 352 c                       noeud P1 cree sur cette arete.
 353 c          typsfr = 2 : on est en degre 2 et les noeuds P2 sont au
 354 c                       milieu des noeuds P1 ; on doit bouger le
 355 c                       noeud P2 de l'arete qui est devenu P1
 356 c          A chaque fois, c'est la seconde extremite d'une des filles
 357 c          de l'arete.
 358 c
 359               nbsomm = 1
 360               laret1(1) = larete
 361               noeud (1) = somare(2,filare(larete))
 362 c
 363 c 3.2. ==> typsfr = 3 : on est en degre 2 et les noeuds P2 sont sur la
 364 c                       frontiere ; on doit bouger les 2 noeuds P2
 365 c                       crees sur chacune des filles de cette arete
 366 c
 367             else
 368 c
 369               nbsomm = 2
 370               laret1(1) = filare(larete)
 371               noeud (1) = np2are(filare(larete))
 372               laret1(2) = filare(larete)+1
 373               noeud (2) = np2are(filare(larete)+1)
 374 c
 375             endif
 376 c
 377 c 3.2. ==> Deplacement des noeuds
 378 c
 379             do 32 , iaux = 1 , nbsomm
 380 c
 381 c 3.2.1. ==> Memorisation des coordonnees initiales
 382 c
 383               if ( codret.eq.0 ) then
 384 c
 385               lenoeu = noeud (iaux)
 386               do 321 , jaux = 1 , sdim
 387                 coopro(jaux) = coonoe(lenoeu,jaux)
 388   321         continue
 389 c
 390 #ifdef _DEBUG_HOMARD_
 391         if ( glop.gt.0 ) then
 392               lesegm = laret1(iaux)
 393         write (ulsort,texte(langue,8)) mess14(langue,1,1),
 394      >                                 lesegm, numfro
 395         write (ulsort,texte(langue,9)) mess14(langue,2,-1), lenoeu
 396         write (ulsort,90004) 'coo',(coonoe(lenoeu,jaux),jaux=1,sdim)
 397         endif
 398 #endif
 399 c
 400               endif
 401 c
 402 c 3.2.2. ==> Frontiere CAO
 403 c            jaux et kaux sont les 2 noeuds voisins de lenoeu
 404 c
 405               if ( mod(suifro,5).eq.0 ) then
 406 c
 407                 if ( codret.eq.0 ) then
 408 c
 409                 lesegm = laret1(iaux)
 410                 jaux = somare(1,lesegm)
 411                 kaux = somare(2,lesegm)
 412 #ifdef _DEBUG_HOMARD_
 413         write (ulsort,texte(langue,10)) mess14(langue,3,-1), jaux, kaux
 414                 write (ulsort,90002) 'frontiere', numfro
 415 #endif
 416                 write (ulgrfr(numfro),91010) lenoeu, jaux, kaux
 417 c
 418                 endif
 419 c
 420 c 3.2.3. ==> Frontiere discrete
 421 c            jaux et kaux sont les 2 noeuds voisins de lenoeu
 422 c
 423               elseif ( numfro.le.nbfrdi ) then
 424 c
 425                 if ( codret.eq.0 ) then
 426 c
 427                 lesegm = laret1(iaux)
 428                 jaux = somare(1,lesegm)
 429                 kaux = somare(2,lesegm)
 430 #ifdef _DEBUG_HOMARD_
 431         write (ulsort,texte(langue,10)) mess14(langue,3,-1), jaux, kaux
 432 #endif
 433 c
 434 #ifdef _DEBUG_HOMARD_
 435       write (ulsort,texte(langue,3)) 'SFSLIN', nompro
 436 #endif
 437                 call sfslin ( lenoeu, jaux, kaux,
 438      >                        numfro, unst2x, epsid2,
 439      >                        geocoo, abscur,
 440      >                        numnoe, lignoe, abscno,
 441      >                        typlig, somseg, seglig,
 442      >                        coopro,
 443      >                        ulsort, langue, codret)
 444 c
 445                 endif
 446 c
 447 c 3.2.4. ==> Frontiere analytique
 448 c
 449               else
 450 c
 451                 if ( codret.eq.0 ) then
 452 c
 453                 kaux = numfro - nbfrdi
 454 cc
 455                 jaux = nint(casfre(1,kaux))
 456 c
 457 c 3.2.3.1. ==> Cylindre
 458 c
 459                 if ( jaux.eq.1 ) then
 460 c
 461 #ifdef _DEBUG_HOMARD_
 462       write (ulsort,texte(langue,3)) 'SFFA01', nompro
 463 #endif
 464                   call sffa01 ( nbnoto, coopro,
 465      >                          lenoeu,
 466      >                          coonoe,
 467      >                          casfre(2,kaux), casfre(5,kaux),
 468      >                          casfre(8,kaux),
 469      >                          ulsort, langue, codret)
 470 c
 471 c 3.2.3.2. ==> Sphere
 472 c
 473                 elseif ( jaux.eq.2 ) then
 474 c
 475 #ifdef _DEBUG_HOMARD_
 476       write (ulsort,texte(langue,3)) 'SFFA02', nompro
 477 #endif
 478                   call sffa02 ( nbnoto, coopro,
 479      >                          lenoeu,
 480      >                          coonoe,
 481      >                          casfre(2,kaux), casfre(8,kaux),
 482      >                          ulsort, langue, codret)
 483 c
 484 c 3.2.3.3./4. ==> Cone
 485 c
 486                 elseif ( jaux.eq.3 .or. jaux.eq.4 ) then
 487 c
 488 #ifdef _DEBUG_HOMARD_
 489       write (ulsort,texte(langue,3)) 'SFFA03', nompro
 490 #endif
 491                   call sffa03 ( nbnoto, coopro,
 492      >                          lenoeu,
 493      >                          coonoe,
 494      >                          casfre(2,kaux), casfre(5,kaux),
 495      >                          casfre(13,kaux),
 496      >                          ulsort, langue, codret)
 497 c
 498 c 3.2.3.5. ==> Tore
 499 c
 500                 elseif ( jaux.eq.5 ) then
 501 c
 502 #ifdef _DEBUG_HOMARD_
 503       write (ulsort,texte(langue,3)) 'SFFA05', nompro
 504 #endif
 505                   call sffa05 ( nbnoto, coopro,
 506      >                          lenoeu,
 507      >                          coonoe,
 508      >                          casfre(2,kaux), casfre(5,kaux),
 509      >                          casfre(8,kaux), casfre(12,kaux),
 510      >                          ulsort, langue, codret)
 511 c
 512 c 3.2.3.n. ==> Inconnu
 513 c
 514                 else
 515 c
 516                   write (ulsort,texte(langue,8)) mess14(langue,1,1),
 517      >                                           laret1(iaux), kaux
 518                   write (ulsort,texte(langue,11)) jaux
 519                   codret = 322
 520 c
 521                 endif
 522 c
 523               endif
 524 c
 525               endif
 526 c
 527 c 3.2.4. ==> On realise le changement de coordonnees
 528 c
 529               if ( mod(suifro,5).ne.0 ) then
 530 c
 531               if ( codret.eq.0 ) then
 532 c
 533 #ifdef _DEBUG_HOMARD_
 534         if ( glop.gt.0 ) then
 535 32490 format(9x,'X',19x,'Y',19x,'Z')
 536         write (ulsort,32490)
 537         write (ulsort,90004) 'ancien ',(coonoe(lenoeu,jaux),jaux=1,sdim)
 538         write (ulsort,90004) 'nouveau',(coopro(jaux),jaux=1,sdim)
 539         endif
 540 #endif
 541               do 324 , jaux = 1 , sdim
 542                 coonoe(lenoeu,jaux) = coopro(jaux)
 543   324         continue
 544 c
 545               endif
 546 c
 547               endif
 548 c
 549    32       continue
 550 c
 551           endif
 552 c
 553         endif
 554 c
 555         endif
 556 c
 557    31 continue
 558 c
 559 c====
 560 c 4. boucle sur les quadrangles
 561 c    On ne s'interesse qu'aux quadrangles
 562 c    . qui viennent d'etre decoupes soit car ils etaient actifs, soit
 563 c      car ils etaient coupes en 3 triangles
 564 c    . qui font partie d'une frontiere reconnue
 565 c====
 566 c
 567 #ifdef _DEBUG_HOMARD_
 568       write (ulsort,90002) '4. boucle quadrangles ; codret', codret
 569 #endif
 570 c
 571       do 41 , lequad = 1 , nbquto
 572 c
 573         if ( codret.eq.0 ) then
 574 c
 575 #ifdef _DEBUG_HOMARD_
 576           if ( lequad.eq.-9 .or. lequad.eq.-10 ) then
 577             glop = 1
 578           else
 579             glop = 0
 580           endif
 581 #endif
 582 c
 583         numfro = cfaqua(cosfsu,famqua(lequad))
 584 c
 585         if ( numfro.gt.0 ) then
 586 #ifdef _DEBUG_HOMARD_
 587       write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad, numfro
 588 #endif
 589 c
 590         etanp1 = mod(hetqua(lequad),100)
 591 cgn        write (ulsort,90002) 'etanp1', etanp1
 592 c
 593         if ( ( etanp1.eq.4 ) .or.
 594      >       ( etanp1.ge.41 .and. etanp1.le.44) ) then
 595 c
 596           etan = (hetqua(lequad)-etanp1) / 100
 597 c
 598           if ( etan.eq.0 .or. ( etan.ge.31 .and. etan.le.34 ) ) then
 599 c
 600 c 4.1. ==> reperage des noeuds a bouger
 601 c
 602             if ( typsfr.le.2 ) then
 603 c
 604 c 4.1. ==> typsfr = 1 : on est en en degre 1 ; on doit bouger le nouveau
 605 c                       noeud P1 cree au centre du quadrangle
 606 c          typsfr = 2 : on est en degre 2 et les noeuds P2 sont au
 607 c                       milieu des noeuds P1 ; on doit bouger le
 608 c                       nouveau noeud P1 cree au centre du quadrangle
 609 c          ce noeud central est la seconde extremite de la 2eme ou 3eme
 610 c          arete de l'un quelconque des quadrangles fils (cf. cmrdqu)
 611 c
 612               nbsomm = 1
 613               iaux = lequad
 614               call utnmqu ( iaux, jaux,
 615      >                      somare, arequa, filqua )
 616               noeud (1) = jaux
 617 c
 618 c 4.2. ==> typsfr = 3 : on est en degre 2 et les noeuds P2 sont sur la
 619 c                       frontiere ;
 620 c                       A faire
 621 c
 622             else
 623 c
 624               codret = 42
 625 c
 626             endif
 627 c
 628 c 4.2. ==> Deplacement des noeuds
 629 c
 630             do 42 , iaux = 1 , nbsomm
 631 c
 632 c 4.2.1. ==> Memorisation des coordonnees initiales
 633 c
 634               if ( codret.eq.0 ) then
 635 c
 636               lenoeu = noeud (iaux)
 637               do 421 , jaux = 1 , sdim
 638                 coopro(jaux) = coonoe(lenoeu,jaux)
 639   421         continue
 640 c
 641 #ifdef _DEBUG_HOMARD_
 642         write (ulsort,texte(langue,9)) mess14(langue,2,-1), lenoeu
 643 #endif
 644 c
 645               endif
 646 c
 647 c 4.2.2. ==> Frontiere CAO
 648 c
 649               if ( mod(suifro,5).eq.0 ) then
 650 c
 651 #ifdef _DEBUG_HOMARD_
 652         write (ulsort,90002) 'surface numfro',numfro
 653 #endif
 654 c
 655                 call utsoqu ( somare,
 656      >                        arequa(lequad,1), arequa(lequad,2),
 657      >                        arequa(lequad,3), arequa(lequad,4),
 658      >                        sa1a2, sa2a3, sa3a4, sa4a1 )
 659 c
 660                 write (ulgrfr(numfro),91010) lenoeu,
 661      >                                     sa1a2, sa2a3, sa3a4, sa4a1
 662 c
 663 c 4.2.3. ==> Frontiere analytique
 664 c
 665               else
 666 c
 667                 if ( codret.eq.0 ) then
 668 c
 669                 kaux = numfro - nbfrdi
 670                 jaux = nint(casfre(1,kaux))
 671 c
 672 c 4.2.3.1. ==> Cylindre
 673 c
 674                 if ( jaux.eq.1 ) then
 675 c
 676 #ifdef _DEBUG_HOMARD_
 677       write (ulsort,texte(langue,3)) 'SFFA01', nompro
 678 #endif
 679                   call sffa01 ( nbnoto, coopro,
 680      >                          lenoeu,
 681      >                          coonoe,
 682      >                          casfre(2,kaux), casfre(5,kaux),
 683      >                          casfre(8,kaux),
 684      >                          ulsort, langue, codret)
 685 c
 686 c 4.2.3.2. ==> Sphere
 687 c
 688                 elseif ( jaux.eq.2 ) then
 689 c
 690 #ifdef _DEBUG_HOMARD_
 691       write (ulsort,texte(langue,3)) 'SFFA02', nompro
 692 #endif
 693                   call sffa02 ( nbnoto, coopro,
 694      >                          lenoeu,
 695      >                          coonoe,
 696      >                          casfre(2,kaux), casfre(8,kaux),
 697      >                          ulsort, langue, codret)
 698 c
 699 c 4.2.3.n. ==> Inconnu
 700 c
 701                 else
 702 c
 703                   write (ulsort,texte(langue,11)) jaux
 704                   codret = 422
 705 c
 706                 endif
 707 c
 708                 endif
 709 c
 710               endif
 711 c
 712 c 4.2.4. ==> On realise le changement de coordonnees
 713 c
 714               if ( codret.eq.0 ) then
 715 #ifdef _DEBUG_HOMARD_
 716         if ( glop.gt.0 ) then
 717 42490 format(9x,'X',19x,'Y',19x,'Z')
 718         write (ulsort,42490)
 719         write (ulsort,90004) 'ancien ',(coonoe(lenoeu,jaux),jaux=1,sdim)
 720         write (ulsort,90004) 'nouveau',(coopro(jaux),jaux=1,sdim)
 721         endif
 722 #endif
 723 c
 724               do 424 , jaux = 1 , sdim
 725                 coonoe(lenoeu,jaux) = coopro(jaux)
 726   424         continue
 727 c
 728               endif
 729 c
 730    42       continue
 731 c
 732           endif
 733 c
 734         endif
 735 c
 736         endif
 737 c
 738         endif
 739 c
 740    41 continue
 741 c
 742 c====
 743 c 5. La fin
 744 c====
 745 c
 746       if ( codret.ne.0 ) then
 747 c
 748 #include "envex2.h"
 749 c
 750       write (ulsort,texte(langue,1)) 'Sortie', nompro
 751       write (ulsort,texte(langue,2)) codret
 752 c
 753       endif
 754 c
 755 #ifdef _DEBUG_HOMARD_
 756       write (ulsort,texte(langue,1)) 'Sortie', nompro
 757       call dmflsh (iaux)
 758 #endif
 759 c
 760       end