src/tool/AV_Conversion/vccfam.F

   1       subroutine vccfam ( typenh,
   2      >                    nbento, nctfen, nbfenm,
   3      >                    codext, cfaent, tbaux1, tbaux2,
   4      >                    fament, nbfent,
   5      >                    nctfe1, nbfen1, cfaen1,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    aVant adaptation - Creation des FAMilles
  28 c                       -            ---
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . typenh . e   .    1   . variantes                                  .
  34 c .        .     .        .  -1 : noeuds                               .
  35 c .        .     .        .   0 : mailles-points                       .
  36 c .        .     .        .   1 : aretes                               .
  37 c .        .     .        .   2 : triangles                            .
  38 c .        .     .        .   3 : tetraedres                           .
  39 c .        .     .        .   4 : quadrangles                          .
  40 c .        .     .        .   5 : pyramides                            .
  41 c .        .     .        .   6 : hexaedres                            .
  42 c .        .     .        .   7 : pentaedres                           .
  43 c . nbento . e   .    1   . nombre d'entites total                     .
  44 c . nctfen . e   .    1   . nombre total de caracteristiques           .
  45 c . nbfenm . e   .    1   . nombre maximum de familles                 .
  46 c . codext . e   . nbento*. codes externes des entites                 .
  47 c .        .     . nctfen .                                            .
  48 c . cfaent .  s  . nctfen*. codes des familles des entites             .
  49 c .        .     . nbfent .                                            .
  50 c .tbaux1,2.  t  .    *   . tableaux auxiliaires                       .
  51 c . fament .  s  . nbento . famille des entites                        .
  52 c . nbfent .  s  .   1    . nombre de familles d'entites               .
  53 c . nctfe1 . e   .    1   . nombre total de caracteristiques annexes   .
  54 c . nbfen1 . e   .    1   . nombre maximum de familles annexes         .
  55 c . cfaen1 . e   . nctfe1*. codes des familles des entites annexes     .
  56 c .        .     . nbfen1 .                                            .
  57 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  58 c . langue . e   .    1   . langue des messages                        .
  59 c .        .     .        . 1 : francais, 2 : anglais                  .
  60 c . codret . es  .    1   . code de retour des modules                 .
  61 c .        .     .        . 0 : pas de probleme                        .
  62 c .        .     .        . 1 : probleme                               .
  63 c ______________________________________________________________________
  64 c
  65 c====
  66 c 0. declarations et dimensionnement
  67 c====
  68 c
  69 c 0.1. ==> generalites
  70 c
  71       implicit none
  72       save
  73 c
  74       character*6 nompro
  75       parameter ( nompro = 'VCCFAM' )
  76 c
  77 #include "nblang.h"
  78 c
  79 #include "cofamp.h"
  80 #include "cofaar.h"
  81 #include "cofina.h"
  82 #include "cofatq.h"
  83 #include "coftex.h"
  84 c
  85 c 0.2. ==> communs
  86 c
  87 #include "envex1.h"
  88 c
  89 #include "impr02.h"
  90 c
  91 c 0.3. ==> arguments
  92 c
  93       integer typenh
  94       integer nbento, nctfen, nbfenm
  95       integer codext(nbento,nctfen)
  96       integer cfaent(nctfen,nbfenm)
  97       integer fament(nbento)
  98       integer tbaux1(*), tbaux2(*)
  99       integer nctfe1, nbfen1
 100       integer cfaen1(nctfe1,nbfen1)
 101       integer nbfent
 102       integer ulsort, langue, codret
 103 c
 104 c 0.4. ==> variables locales
 105 c
 106       integer iaux, jaux, kaux
 107       integer lafami, famien
 108       integer entite, nucode, nufami
 109       integer nbfar1, nbfar2, nbfar3, nbfar4, nbfar5
 110 c
 111       integer nbmess
 112       parameter ( nbmess = 10 )
 113       character*80 texte(nblang,nbmess)
 114 c
 115 c 0.5. ==> initialisations
 116 c ______________________________________________________________________
 117 c
 118 c====
 119 c 1. initialisations
 120 c====
 121 c
 122 #include "impr01.h"
 123 c
 124 #ifdef _DEBUG_HOMARD_
 125       write (ulsort,texte(langue,1)) 'Entree', nompro
 126       call dmflsh (iaux)
 127 #endif
 128 c
 129       texte(1,4) = '(a14,'' : nombre de familles creees : '',i8,/)'
 130       texte(1,5) = '(a14,'' : creation de la famille '',i8,/)'
 131       texte(1,6) = '(''Ce nombre est superieur au maximum :'',i8)'
 132       texte(1,7) = '(''Modifier les programmes UTINCG et/ou VCCFAM'')'
 133 c
 134       texte(2,4) = '(a14,'' : number of created families: '',i8,/)'
 135       texte(2,5) = '(a14,'' : creation of the family '',i8,/)'
 136       texte(2,6) = '(''This number is greater than maximum:'',i8)'
 137       texte(2,7) = '(''Modify the programs UTINCG and/or VCCFAM'')'
 138 c
 139 #include "impr03.h"
 140 c
 141       codret = 0
 142 c
 143 #ifdef _DEBUG_HOMARD_
 144       write (ulsort,90002) 'typenh', typenh
 145       write (ulsort,90002) 'nbento', nbento
 146       write (ulsort,90002) 'nctfen', nctfen
 147       write (ulsort,90002) 'nbfenm', nbfenm
 148 #endif
 149 c
 150 c====
 151 c 1. initialisations
 152 c====
 153 c 1.1. ==> on initialise tous les codes des familles :
 154 c
 155       do 11, nucode = 1, nctfen
 156         do 10, nufami = 1, nbfenm
 157           cfaent(nucode,nufami) = 0
 158    10   continue
 159    11 continue
 160 c
 161 c 1.2. ==> on cree la premiere famille, dite 'famille libre' :
 162 c 1.2.1. ==> le compteur
 163 c
 164       nbfent = 1
 165 c
 166 c 1.2.2. ==> pour les aretes, on gere les orientations inverses de
 167 c            cette famille libre : c'est elle-meme car aucune
 168 c            orientation n'est definie
 169 c
 170       if ( typenh.eq.1 ) then
 171 c
 172         cfaent(cofifa,nbfent) = 1
 173         cfaent(cosfin,nbfent) = 0
 174 c
 175       endif
 176 c
 177 c 1.2.3. ==> Pour une face, la famille des aretes qui seront tracees
 178 c            dessus au cours du raffinement est la famille
 179 c            libre par defaut
 180 c
 181       if ( typenh.eq.2 .or. typenh.eq.4 ) then
 182 c
 183         cfaent(cofafa,nbfent) = 1
 184 c
 185       endif
 186 c
 187 c====
 188 c 2. creation des autres familles
 189 c====
 190 c
 191       do 20 , entite = 1, nbento
 192 c
 193 c 2.1. ==> ajout conditionne
 194 c 2.1.1. ==> pour une maille-point, on ajoute le code de la famille du
 195 c            noeud sous-jacent
 196 c
 197         if ( typenh.eq.0 ) then
 198 c
 199           codext(entite,cofaso) = tbaux2(tbaux1(entite))
 200 c
 201 c 2.1.2. ==> Pour une face, numero de famille des aretes qui seront
 202 c            tracees dessus au cours du raffinement
 203 c            . Par defaut, c'est la famille libre
 204 c            . Pour une surface, prise en compte du suivi de frontiere
 205 c              on cherche la famille des aretes :
 206 c              . non elements du calcul (i.e. type = 0)
 207 c              . tracees sur la meme surface que la face en cours
 208 c
 209         elseif ( typenh.eq.2 .or. typenh.eq.4 ) then
 210 c
 211           jaux = 1
 212           kaux = codext(entite,cosfsu)
 213           if ( kaux.ne.0 ) then
 214             do 212 , iaux = 1 , nbfen1
 215               if ( cfaen1(cotyel,iaux).eq.0 ) then
 216                 if ( cfaen1(cosfsa,iaux).eq.kaux ) then
 217                   jaux = iaux
 218                 endif
 219               endif
 220   212       continue
 221           endif
 222           codext(entite,cofafa) = jaux
 223 c
 224         endif
 225 c
 226 c 2.2. ==> on recherche si une famille avec les memes codes existe deja
 227 c          . si oui, on stocke son numero pour l'entite en cours.
 228 c          . si non, on cree une famille avec les codes de l'entite
 229 c
 230         famien = 0
 231  2200   continue
 232 c
 233 c 2.2.1. ==> Comparaison des codes de la famille 'famien' et
 234 c            de ceux de l'entite en cours
 235 c
 236           famien = famien + 1
 237 c
 238 #ifdef _DEBUG_HOMARD_
 239           write (ulsort,90002) '. examen de la famille famien', famien
 240 #endif
 241 c
 242           if ( famien.le.nbfent ) then
 243 c
 244             nucode = 0
 245  2210       continue
 246               nucode = nucode + 1
 247 c
 248 c             - dans le cas des aretes, on saute les codes :
 249 c                   . de l'orientation inverse
 250 c                   . de la frontiere inactive
 251 c
 252               if ( typenh.eq.1 ) then
 253                 if ( nucode.eq.cofifa .or. nucode.eq.cosfin ) then
 254                   goto 2210
 255                 endif
 256 c
 257 c             - dans le cas des quadrangles, on saute les codes :
 258 c                   . de la frontiere inactive
 259 c
 260               elseif ( typenh.eq.4 ) then
 261                 if ( nucode.eq.cosfin ) then
 262                   goto 2210
 263                 endif
 264               endif
 265 c
 266               if ( nucode.le.nctfen ) then
 267                 if ( codext(entite,nucode).eq.
 268      >               cfaent(nucode,famien) ) then
 269 c                 le code est le meme : on passe au suivant
 270                   goto 2210
 271                 else
 272 c                 le code est different : on passe a la famille suivante
 273                   goto 2200
 274                 endif
 275               else
 276 c               tous les codes sont les memes : la famille existe deja
 277                 lafami = famien
 278               endif
 279 c
 280           else
 281 c
 282 c 2.2.2. ==> la famille n'existe pas encore : on la cree
 283 c
 284             nbfent = nbfent + 1
 285             lafami = nbfent
 286 #ifdef _DEBUG_HOMARD_
 287           write (ulsort,texte(langue,5)) mess14(langue,4,typenh), lafami
 288 #endif
 289             do 222, nucode = 1, nctfen
 290               cfaent(nucode,nbfent) = codext(entite,nucode)
 291   222       continue
 292 c
 293 c 2.2.3. ==> Cas particulier des aretes :
 294 c            a. prise en compte de l'orientation : il faut la famille
 295 c               d'orientation inverse
 296 c            b. prise en compte du suivi de frontiere
 297 c               si l'arete est concernee par le suivi de frontiere, il
 298 c               faut creer egalement la famille inactive, ie celle pour
 299 c               laquelle le suivi de frontiere est inactif : toutes les
 300 c               caracteristiques sont les memes a l'exception du numero
 301 c               de ligne/surface que l'on met negatif. On memorise
 302 c               l'association entre les deux familles dans la case
 303 c               cosfin
 304 c
 305             if ( typenh.eq.1 ) then
 306 c
 307 c 2.2.3.1. ==> l'arete n'a pas d'orientation : la famille
 308 c              d'orientation inverse est elle meme (cofifa)
 309 c
 310               if ( codext(entite,coorfa).eq.0 ) then
 311 c
 312                 cfaent(cofifa,nbfent) = nbfent
 313 c
 314 c 2.2.3.1.1. ==> l'arete est concernee par une surface de sf
 315 c
 316                 if ( codext(entite,cosfsa).ne.0 ) then
 317 c
 318                   nbfar1 = nbfent + 1
 319 c
 320                   do 2231, nucode = 1, nctfen
 321                     cfaent(nucode,nbfar1) = codext(entite,nucode)
 322  2231             continue
 323 c
 324                   cfaent(coorfa,nbfar1) = 0
 325 c
 326                   cfaent(cofifa,nbfar1) = nbfar1
 327 c
 328                   cfaent(cosfin,nbfent) = nbfar1
 329                   cfaent(cosfin,nbfar1) = nbfent
 330 c
 331                   cfaent(cosfsa,nbfar1) = - codext(entite,cosfsa)
 332 c
 333                   nbfent = nbfar1
 334 c
 335 c 2.2.3.1.2. ==> l'arete est concernee par une ligne de sf
 336 c                remarque : cela ne devrait jamais arriver car si une
 337 c                           arete est sur une ligne de SF c'est qu'elle
 338 c                           est un element du calcul, donc avec une
 339 c                           orientation
 340 c
 341                 elseif ( codext(entite,cosfli).ne.0 ) then
 342 c
 343                   codret = 22312
 344 c
 345                 endif
 346 c
 347 c 2.2.3.2. ==> l'arete possede une orientation : on cree la famille
 348 c              d'orientation inverse : toutes les
 349 c              caracteristiques sont les memes a l'exception du code
 350 c              d'orientation, coorfa. On memorise l'association entre
 351 c              les deux familles dans la case cofifa
 352 c
 353               else
 354 c
 355 c 2.2.3.2.1. ==> la famille n'est pas liee a une frontiere
 356 c
 357                 if ( codext(entite,cosfli).eq.0 .and.
 358      >               codext(entite,cosfsa).eq.0 ) then
 359 c
 360                   cfaent(cosfin,nbfent) = 0
 361 c
 362                   cfaent(cofifa,nbfent) = nbfent + 1
 363                   nbfent = nbfent + 1
 364                   do 2232, nucode = 1, nctfen
 365                     cfaent(nucode,nbfent) = codext(entite,nucode)
 366  2232             continue
 367                   cfaent(coorfa,nbfent) = - codext(entite,coorfa)
 368                   cfaent(cofifa,nbfent) = nbfent - 1
 369                   cfaent(cosfin,nbfent) = 0
 370 c
 371 c 2.2.3.2.2. ==> l'arete est concernee par une ligne de sf
 372 c
 373                 elseif ( codext(entite,cosfli).ne.0 ) then
 374 c
 375                   nbfar1 = nbfent + 1
 376                   nbfar2 = nbfar1 + 1
 377                   nbfar3 = nbfar2 + 1
 378 c
 379                   do 2233, nucode = 1, nctfen
 380                     cfaent(nucode,nbfar1) = codext(entite,nucode)
 381                     cfaent(nucode,nbfar2) = codext(entite,nucode)
 382                     cfaent(nucode,nbfar3) = codext(entite,nucode)
 383  2233             continue
 384 c
 385                   cfaent(coorfa,nbfar1) = - codext(entite,coorfa)
 386                   cfaent(coorfa,nbfar3) = - codext(entite,coorfa)
 387 c
 388                   cfaent(cofifa,nbfent) = nbfar1
 389                   cfaent(cofifa,nbfar1) = nbfent
 390                   cfaent(cofifa,nbfar2) = nbfar3
 391                   cfaent(cofifa,nbfar3) = nbfar2
 392 c
 393                   cfaent(cosfli,nbfar2) = - codext(entite,cosfli)
 394                   cfaent(cosfli,nbfar3) = - codext(entite,cosfli)
 395 c
 396                   cfaent(cosfin,nbfent) = nbfar2
 397                   cfaent(cosfin,nbfar1) = nbfar3
 398                   cfaent(cosfin,nbfar2) = nbfent
 399                   cfaent(cosfin,nbfar3) = nbfar1
 400 c
 401                   nbfent = nbfar3
 402 c
 403 c 2.2.3.2.3. ==> l'arete est concernee par une surface de sf
 404 c
 405                 elseif ( codext(entite,cosfsa).ne.0 ) then
 406 c
 407                   nbfar1 = nbfent + 1
 408                   nbfar2 = nbfar1 + 1
 409                   nbfar3 = nbfar2 + 1
 410                   nbfar4 = nbfar3 + 1
 411                   nbfar5 = nbfar4 + 1
 412 c
 413                   do 2234, nucode = 1, nctfen
 414                     cfaent(nucode,nbfar1) = codext(entite,nucode)
 415                     cfaent(nucode,nbfar2) = codext(entite,nucode)
 416                     cfaent(nucode,nbfar3) = codext(entite,nucode)
 417                     cfaent(nucode,nbfar4) = codext(entite,nucode)
 418                     cfaent(nucode,nbfar5) = codext(entite,nucode)
 419  2234             continue
 420 c
 421                   cfaent(cofamd,nbfar4) = 0
 422                   cfaent(cofamd,nbfar5) = 0
 423 c
 424                   cfaent(cotyel,nbfar4) = 0
 425                   cfaent(cotyel,nbfar5) = 0
 426 c
 427                   cfaent(coorfa,nbfar1) = - codext(entite,coorfa)
 428                   cfaent(coorfa,nbfar3) = - codext(entite,coorfa)
 429                   cfaent(coorfa,nbfar4) = 0
 430                   cfaent(coorfa,nbfar5) = 0
 431 c
 432                   cfaent(cofifa,nbfent) = nbfar1
 433                   cfaent(cofifa,nbfar1) = nbfent
 434                   cfaent(cofifa,nbfar2) = nbfar3
 435                   cfaent(cofifa,nbfar3) = nbfar2
 436                   cfaent(cofifa,nbfar4) = nbfar4
 437                   cfaent(cofifa,nbfar5) = nbfar5
 438 c
 439                   cfaent(cosfsa,nbfar2) = - codext(entite,cosfsa)
 440                   cfaent(cosfsa,nbfar3) = - codext(entite,cosfsa)
 441                   cfaent(cosfsa,nbfar5) = - codext(entite,cosfsa)
 442 c
 443                   cfaent(cosfin,nbfent) = nbfar2
 444                   cfaent(cosfin,nbfar1) = nbfar3
 445                   cfaent(cosfin,nbfar2) = nbfent
 446                   cfaent(cosfin,nbfar3) = nbfar1
 447                   cfaent(cosfin,nbfar4) = nbfar5
 448                   cfaent(cosfin,nbfar5) = nbfar4
 449 c
 450                   nbfent = nbfar5
 451 c
 452                 else
 453 c
 454                   codret = 2232
 455 c
 456                 endif
 457 c
 458               endif
 459 c
 460 c 2.2.4. ==> Cas particulier des quadrangles pour le suivi de frontiere
 461 c               si le quadrangle est concerne par le suivi de frontiere,
 462 c               il faut creer egalement la famille inactive, ie celle
 463 c               pour laquelle le suivi de frontiere est inactif : toutes
 464 c               les caracteristiques sont les memes a l'exception du
 465 c               numero de surface que l'on met negatif. On memorise
 466 c               l'association entre les deux familles dans la case
 467 c               cosfin
 468 c
 469             elseif ( typenh.eq.4 ) then
 470 c
 471 c 2.2.4.1. ==> le quadrangle est concerne par le suivi de frontiere
 472 c
 473               if ( codext(entite,cosfsu).ne.0 ) then
 474 c
 475                 nbfar1 = nbfent + 1
 476 c
 477                 do 2241, nucode = 1, nctfen
 478                   cfaent(nucode,nbfar1) = codext(entite,nucode)
 479  2241           continue
 480 c
 481                 cfaent(cosfin,nbfent) = nbfar1
 482                 cfaent(cosfin,nbfar1) = nbfent
 483                 cfaent(cosfsu,nbfar1) = -cfaent(cosfsu,nbfent)
 484 c
 485                 nbfent = nbfar1
 486 c
 487               endif
 488 c
 489             endif
 490 c
 491           endif
 492 c
 493 c 2.3. ==> on affecte le numero de famille a l'entite
 494 c
 495         fament(entite) = lafami
 496 c
 497    20 continue
 498 c
 499 c 2.4. ==> controle
 500 c
 501 #ifdef _DEBUG_HOMARD_
 502       write (ulsort,texte(langue,4)) mess14(langue,4,typenh), nbfent
 503 #endif
 504 c
 505       if ( nbfent.gt.nbfenm ) then
 506 #ifdef _DEBUG_HOMARD_
 507         write (ulsort,90002) 'nbento', nbento
 508         write (ulsort,90002) 'nctfen', nctfen
 509         write (ulsort,90002) 'nbfenm', nbfenm
 510 #endif
 511         write (ulsort,texte(langue,4)) mess14(langue,4,typenh), nbfent
 512         write (ulsort,texte(langue,6)) nbfenm
 513         write (ulsort,texte(langue,7)) nompro
 514         codret = 1
 515       endif
 516 c
 517 c====
 518 c 3. la fin
 519 c====
 520 c
 521       if ( codret.ne.0 ) then
 522 c
 523 #include "envex2.h"
 524 c
 525       write (ulsort,texte(langue,1)) 'Sortie', nompro
 526       write (ulsort,texte(langue,2)) codret
 527 c
 528       endif
 529 c
 530 #ifdef _DEBUG_HOMARD_
 531       write (ulsort,texte(langue,1)) 'Sortie', nompro
 532       call dmflsh (iaux)
 533 #endif
 534 c
 535       end