src/tool/AP_Conversion/pcceq3.F

   1       subroutine pcceq3 ( cfanoe, famnoe, nnosho, nnosca,
   2      >                    cfampo, fammpo, nmpsho, nmpsca,
   3      >                    cfaare, famare, narsho, narsca,
   4      >                    cfatri, famtri, ntrsho, ntrsca,
   5      >                    cfaqua, famqua, nqusho, nqusca,
   6      >                    typele,
   7      >                    noehom, mpohom, arehom, trihom, quahom,
   8      >                    eqpntr,
   9      >                    eqnoeu, eqmapo, eqaret, eqtria, eqquad,
  10      >                    nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn,
  11      >                    ulsort, langue, codret )
  12 c ______________________________________________________________________
  13 c
  14 c                             H O M A R D
  15 c
  16 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  17 c
  18 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  19 c aupres des huissiers de justice Simart et Lavoir a Clamart
  20 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  21 c aupres des huissiers de justice
  22 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  23 c
  24 c    HOMARD est une marque deposee d'Electricite de France
  25 c
  26 c Copyright EDF 1996
  27 c Copyright EDF 1998
  28 c Copyright EDF 2002
  29 c Copyright EDF 2020
  30 c ______________________________________________________________________
  31 c
  32 c    aPres adaptation - Conversion - Creation des EQuivalences - phase 3
  33 c     -                 -            -            --                   -
  34 c ______________________________________________________________________
  35 c
  36 c    remarque : on trie les mailles en ne prenant que celles qui
  37 c               sont vraiment des elements : cela se reconnait en
  38 c               utilisant les codes lies au type des elements.
  39 c
  40 c    remarque : il vaut mieux que la boucle sur les entites soit a
  41 c               l'interieur car elle sera toujours plus longue que
  42 c               celle sur les equivalences, d'ou une meilleure
  43 c               vectorisation
  44 c ______________________________________________________________________
  45 c .        .     .        .                                            .
  46 c .  nom   . e/s . taille .           description                      .
  47 c .____________________________________________________________________.
  48 c . cfanoe . e   . nctfno*. codes des familles des noeuds              .
  49 c .        .     . nbnoto .   1 : famille MED                          .
  50 c .        .     .        . + l : appartenance a l'equivalence l       .
  51 c . famnoe . e   . nbnoto . famille des aretes                         .
  52 c . nnosho . e   . rsnoto . numero des noeuds dans HOMARD              .
  53 c . nnosca . e   . rsnoto . numero des noeuds dans le code de calcul   .
  54 c . cfampo . e   . nctfmp*. codes des familles des mailles-points      .
  55 c .        .     . nbfmpo .   1 : famille MED                          .
  56 c .        .     .        .   2 : type de maille-point                 .
  57 c .        .     .        .   3 : famille des sommets                  .
  58 c .        .     .        . + l : appartenance a l'equivalence l       .
  59 c . fammpo . e   . nbmpto . famille des mailles-points                 .
  60 c . nmpsho . e   . rsmpac . numero des mailles-points dans HOMARD      .
  61 c . nmpsca . e   . rsmpto . numero des mailles-points du calcul        .
  62 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  63 c .        .     . nbfare .   1 : famille MED                          .
  64 c .        .     .        .   2 : type de segment                      .
  65 c .        .     .        .   3 : orientation                          .
  66 c .        .     .        .   4 : famille d'orientation inverse        .
  67 c .        .     .        .   5 : numero de ligne de frontiere         .
  68 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  69 c .        .     .        . <= 0 si non concernee                      .
  70 c .        .     .        .   6 : famille frontiere active/inactive    .
  71 c .        .     .        .   7 : numero de surface de frontiere       .
  72 c .        .     .        . + l : appartenance a l'equivalence l       .
  73 c . famare . e   . nbarto . famille des aretes                         .
  74 c . narsho . e   . rsarac . numero des aretes dans HOMARD              .
  75 c . narsca . e   . rsarto . numero des aretes du calcul                .
  76 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  77 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  78 c .        .     . nbftri .   1 : famille MED                          .
  79 c .        .     .        .   2 : type de triangle                     .
  80 c .        .     .        .   3 : numero de surface de frontiere       .
  81 c .        .     .        .   4 : famille des aretes internes apres raf.
  82 c .        .     .        . + l : appartenance a l'equivalence l       .
  83 c . famtri . e   . nbtrto . famille des triangles                      .
  84 c . ntrsho . e   . rstrac . numero des triangles dans HOMARD           .
  85 c . ntrsca . e   . rstrto . numero des triangles du calcul             .
  86 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  87 c .        .     . nbfqua .   1 : famille MED                          .
  88 c .        .     .        .   2 : type de quadrangle                   .
  89 c .        .     .        .   3 : numero de surface de frontiere       .
  90 c .        .     .        .   4 : famille des aretes internes apres raf.
  91 c .        .     .        .   5 : famille des triangles de conformite  .
  92 c .        .     .        .   6 : famille de sf active/inactive        .
  93 c .        .     .        . + l : appartenance a l'equivalence l       .
  94 c . famqua .     . nbquto . famille des quadrangles                    .
  95 c . nqusho . e   . rsquac . numero des quadrangles dans HOMARD         .
  96 c . nqusca . e   . rsquto . numero des quadrangles du calcul           .
  97 c . typele . e   . nbelem . type des elements                          .
  98 c . noehom . e   . nbnoto . liste etendue des homologues par noeuds    .
  99 c . mpohom . e   . nbmpto . liste etendue des homologues par ma.pts    .
 100 c . arehom . e   . nbarto . liste etendue des homologues par aretes    .
 101 c . trihom . e   . nbtrto . ensemble des triangles homologues          .
 102 c . quahom . e   . nbquto . ensemble des quadrangles homologues        .
 103 c . eqpntr .  s  .5*nbequi. 5i-4 : nombre de paires de noeuds pour     .
 104 c .        .     .        .        l'equivalence i                     .
 105 c .        .     .        . 5i-3 : idem pour les mailles-points        .
 106 c .        .     .        . 5i-2 : idem pour les aretes                .
 107 c .        .     .        . 5i-1 : idem pour les triangles             .
 108 c .        .     .        . 5i   : idem pour les quadrangles           .
 109 c . eqnoeu .  s  .2*nbeqno. liste des paires de noeuds equivalents avec.
 110 c .        .     .        . la convention : eqnoeu(i)<-->eqnoeu(i+1)   .
 111 c . eqmapo .  s  .2*nbeqmp. idem pour les mailles-points               .
 112 c . eqaret .  s  .2*nbeqar. idem pour les aretes                       .
 113 c . eqtria .  s  .2*nbeqtr. idem pour les triangles                    .
 114 c . eqquad .  s  .2*nbeqqu. idem pour les quadrangles                  .
 115 c . nbeqno .  s  .    1   . nombre total de noeuds dans les equivalen. .
 116 c . nbeqmp .  s  .    1   . nombre total de mailles-points dans les eq..
 117 c . nbeqar .  s  .    1   . nombre total d'aretes dans les eq.         .
 118 c . nbeqtr .  s  .    1   . nombre total de triangles dans les eq.     .
 119 c . nbeqqu .  s  .    1   . nombre total de quadrangles dans les eq.   .
 120 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 121 c . langue . e   .    1   . langue des messages                        .
 122 c .        .     .        . 1 : francais, 2 : anglais                  .
 123 c . codret . es  .    1   . code de retour des modules                 .
 124 c .        .     .        . 0 : pas de probleme                        .
 125 c .        .     .        . 1 : probleme                               .
 126 c ______________________________________________________________________
 127 c
 128 c====
 129 c 0. declarations et dimensionnement
 130 c====
 131 c
 132 c 0.1. ==> generalites
 133 c
 134       implicit none
 135       save
 136 c
 137       character*6 nompro
 138       parameter ( nompro = 'PCCEQ3' )
 139 c
 140 #include "nblang.h"
 141 c
 142 c 0.2. ==> communs
 143 c
 144 #include "envex1.h"
 145 c
 146 #include "nombno.h"
 147 #include "nbfami.h"
 148 #include "nombmp.h"
 149 #include "nombar.h"
 150 #include "nombtr.h"
 151 #include "nombqu.h"
 152 #include "nombsr.h"
 153 #include "nbutil.h"
 154 #include "dicfen.h"
 155 #include "refert.h"
 156 c
 157 c 0.3. ==> arguments
 158 c
 159       integer nqusca(rsquto), nqusho(rsquac)
 160       integer ntrsca(rstrto), ntrsho(rstrac)
 161       integer nmpsca(rsmpto), nmpsho(rsmpac)
 162       integer narsca(rsarto), narsho(rsarac)
 163       integer nnosca(rsnoto), nnosho(rsnoac)
 164       integer typele(nbelem)
 165 c
 166       integer cfanoe(nctfno,nbfnoe), famnoe(nbnoto)
 167       integer cfampo(nctfmp,nbfmpo), fammpo(nbmpto)
 168       integer cfaare(nctfar,nbfare), famare(nbarto)
 169       integer cfatri(nctftr,nbftri), famtri(nbtrto)
 170       integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
 171       integer noehom(nbnoto), mpohom(nbmpto)
 172       integer arehom(nbarto), trihom(nbtrto)
 173       integer quahom(nbquto)
 174 c
 175       integer eqpntr(5*nbequi)
 176       integer eqnoeu(2*nbeqno), eqmapo(2*nbeqmp)
 177       integer eqaret(2*nbeqar), eqtria(2*nbeqtr)
 178       integer eqquad(2*nbeqqu)
 179       integer nbeqnn, nbeqmn, nbeqan, nbeqtn, nbeqqn
 180 c
 181       integer ulsort, langue, codret
 182 c
 183 c 0.4. ==> variables locales
 184 c
 185       integer iaux, jaux, ideb, ifin
 186 c
 187       integer nbmess
 188       parameter ( nbmess = 10 )
 189       character*80 texte(nblang,nbmess)
 190 c
 191 c 0.5. ==> initialisations
 192 c ______________________________________________________________________
 193 c
 194 c====
 195 c 1. initialisations
 196 c====
 197 c
 198 c 1.1. ==> messages
 199 c
 200 #include "impr01.h"
 201 c
 202 #ifdef _DEBUG_HOMARD_
 203       write (ulsort,texte(langue,1)) 'Entree', nompro
 204       call dmflsh (iaux)
 205 #endif
 206 c
 207       codret = 0
 208 c
 209 c====
 210 c 2. a priori, aucune entite n'appartient a une equivalence
 211 c====
 212 c
 213       ideb = 1
 214       ifin = 5*nbequi
 215       do 21 , iaux = ideb , ifin
 216         eqpntr(iaux) = 0
 217    21 continue
 218 c
 219 #ifdef _DEBUG_HOMARD_
 220       write (ulsort,*) 'nbnoto = ', nbnoto
 221       write (ulsort,*) 'nbmapo = ', nbmapo
 222       write (ulsort,*) 'nbsegm = ', nbsegm
 223       write (ulsort,*) 'nbtria = ', nbtria
 224       write (ulsort,*) 'nbquad = ', nbquad
 225 #endif
 226 c
 227 c====
 228 c 3. Les noeuds
 229 c====
 230 #ifdef _DEBUG_HOMARD_
 231       write (ulsort,*) '3. Les noeuds ; codret = ', codret
 232 #endif
 233 c
 234       if ( nbeqno.ne.0 ) then
 235 c
 236         iaux = -1
 237 c
 238 #ifdef _DEBUG_HOMARD_
 239       write (ulsort,texte(langue,3)) 'PCCEQ4_no', nompro
 240 #endif
 241         call pcceq4 ( iaux,
 242      >                nbnoto, nctfno, nbfnoe, ncffno, ncefno,
 243      >                nbeqno, jaux, jaux, jaux, rsnoto,
 244      >                noehom, cfanoe, famnoe, nnosho, nnosca,
 245      >                typele,
 246      >                eqpntr, eqnoeu, nbeqnn,
 247      >                ulsort, langue, codret )
 248 c
 249       endif
 250 c
 251 c====
 252 c 4. Les mailles-points
 253 c====
 254 #ifdef _DEBUG_HOMARD_
 255       write (ulsort,*) '4. Les mailles-points ; codret = ', codret
 256 #endif
 257 c
 258       if ( nbeqmp.ne.0 ) then
 259 c
 260         iaux = 0
 261         jaux = nbtetr + nbtria + nbquad + nbsegm
 262 c
 263 #ifdef _DEBUG_HOMARD_
 264       write (ulsort,texte(langue,3)) 'PCCEQ4_mp', nompro
 265 #endif
 266         call pcceq4 ( iaux,
 267      >                nbmpto, nctfmp, nbfmpo, ncffmp, ncefmp,
 268      >                nbeqmp, jaux, tyhmpo, tyhmpo, nbelem,
 269      >                mpohom, cfampo, fammpo, nmpsho, nmpsca,
 270      >                typele,
 271      >                eqpntr, eqmapo, nbeqmn,
 272      >                ulsort, langue, codret )
 273 c
 274       endif
 275 c
 276 c====
 277 c 5. Les aretes
 278 c====
 279 #ifdef _DEBUG_HOMARD_
 280       write (ulsort,*) '5. Les aretes ; codret = ', codret
 281 #endif
 282 c
 283       if ( nbeqar.ne.0 ) then
 284 c
 285         iaux = 1
 286         jaux = nbtetr + nbtria
 287 c
 288 #ifdef _DEBUG_HOMARD_
 289       write (ulsort,texte(langue,3)) 'PCCEQ4_ar', nompro
 290 #endif
 291         call pcceq4 ( iaux,
 292      >                nbarto, nctfar, nbfare, ncffar, ncefar,
 293      >                nbeqar, jaux, tyhse1, tyhse2, nbelem,
 294      >                arehom, cfaare, famare, narsho, narsca,
 295      >                typele,
 296      >                eqpntr, eqaret, nbeqan,
 297      >                ulsort, langue, codret )
 298 c
 299       endif
 300 c
 301 c====
 302 c 6. Les triangles
 303 c====
 304 #ifdef _DEBUG_HOMARD_
 305       write (ulsort,*) '6. Les triangles ; codret = ', codret
 306 #endif
 307 c
 308       if ( nbeqtr.ne.0 ) then
 309 c
 310         iaux = 2
 311         jaux = nbtetr
 312 c
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,texte(langue,3)) 'PCCEQ4_tr', nompro
 315 #endif
 316         call pcceq4 ( iaux,
 317      >                nbtrto, nctftr, nbftri, ncfftr, nceftr,
 318      >                nbeqtr, jaux, tyhtr1, tyhtr2, nbelem,
 319      >                trihom, cfatri, famtri, ntrsho, ntrsca,
 320      >                typele,
 321      >                eqpntr, eqtria, nbeqtn,
 322      >                ulsort, langue, codret )
 323 c
 324       endif
 325 c
 326 c====
 327 c 7. Les quadrangles : tri selon les equivalences
 328 c====
 329 #ifdef _DEBUG_HOMARD_
 330       write (ulsort,*) '7. Les quadrangles ; codret = ', codret
 331 #endif
 332 c
 333       if ( nbeqqu.ne.0 ) then
 334 c
 335         iaux = 4
 336         jaux = nbtetr + nbtria + nbsegm + nbmpto
 337 c
 338 #ifdef _DEBUG_HOMARD_
 339       write (ulsort,texte(langue,3)) 'PCCEQ4_qu', nompro
 340 #endif
 341         call pcceq4 ( iaux,
 342      >                nbquto, nctfqu, nbfqua, ncffqu, ncefqu,
 343      >                nbeqqu, jaux, tyhqu1, tyhqu2, nbelem,
 344      >                quahom, cfaqua, famqua, nqusho, nqusca,
 345      >                typele,
 346      >                eqpntr, eqquad, nbeqqn,
 347      >                ulsort, langue, codret )
 348 c
 349       endif
 350 c
 351 c====
 352 c 8. la fin
 353 c====
 354 c
 355       if ( codret.ne.0 ) then
 356 c
 357 #include "envex2.h"
 358 c
 359       write (ulsort,texte(langue,1)) 'Sortie', nompro
 360       write (ulsort,texte(langue,2)) codret
 361 c
 362       endif
 363 c
 364 #ifdef _DEBUG_HOMARD_
 365       write (ulsort,texte(langue,1)) 'Sortie', nompro
 366       call dmflsh (iaux)
 367 #endif
 368 c
 369       end