src/tool/AV_Conversion/vccfnc.F

   1       subroutine vccfnc ( nbfare, cfaare,
   2      >                    nbfqua, cfaqua,
   3      >                    nbftri, cfatri,
   4      >                    faminf, famsup,
   5      >                    nbfme0, numfam, nomfam,
   6      >                    grfmpo, grfmta, grfmtb,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c    aVant adaptation - Creation des Familles - Non Conforme
  29 c                       -            -          -   -
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . nbfare . es  .   1    . nombre de familles d'aretes                .
  35 c . cfaare . es  . nctfar*. codes des familles des aretes              .
  36 c .        .     . nbfare .   1 : famille MED                          .
  37 c .        .     .        .   2 : type de segment                      .
  38 c .        .     .        .   3 : orientation                          .
  39 c .        .     .        .   4 : famille d'orientation inverse        .
  40 c .        .     .        .   5 : numero de ligne de frontiere         .
  41 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  42 c .        .     .        . <= 0 si non concernee                      .
  43 c .        .     .        .   6 : famille frontiere active/inactive    .
  44 c .        .     .        .   7 : numero de surface de frontiere       .
  45 c .        .     .        . + l : appartenance a l'equivalence l       .
  46 c . nbfqua . e   .   1    . nombre de familles de quadrangles          .
  47 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  48 c .        .     . nbfqua .   1 : famille MED                          .
  49 c .        .     .        .   2 : type de quadrangle                   .
  50 c .        .     .        .   3 : numero de surface de frontiere       .
  51 c .        .     .        .   4 : famille des aretes internes apres raf.
  52 c .        .     .        .   5 : famille des triangles de conformite  .
  53 c .        .     .        .   6 : famille de sf active/inactive        .
  54 c .        .     .        . + l : appartenance a l'equivalence l       .
  55 c . nbftri . e   .   1    . nombre de familles de triangles            .
  56 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  57 c .        .     . nbftrm .   1 : famille MED                          .
  58 c .        .     .        .   2 : type de triangle                     .
  59 c .        .     .        .   3 : numero de surface de frontiere       .
  60 c .        .     .        .   4 : famille des aretes internes apres raf.
  61 c .        .     .        . + l : appartenance a l'equivalence l       .
  62 c . faminf . e   .   1    . famille med des quad de la face inferieure .
  63 c . famsup . e   .   1    . famille med des quad de la face superieure .
  64 c . nbfme0 . e   .   1    . nombre initial de familles med             .
  65 c . numfam . es  . nbfmed . numero des familles                        .
  66 c . nomfam . es  .10nbfmed. nom des familles                           .
  67 c . grfmpo .  s  .nbfmed+1. pointeur des groupes des familles          .
  68 c . grfmta .  s  .10ngrouc. taille des groupes des familles            .
  69 c . grfmtb .  s  .10ngrouc. table des groupes des familles             .
  70 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  71 c . langue . e   .    1   . langue des messages                        .
  72 c .        .     .        . 1 : francais, 2 : anglais                  .
  73 c . codret . es  .    1   . code de retour des modules                 .
  74 c .        .     .        . 0 : pas de probleme                        .
  75 c .        .     .        . 1 : probleme                               .
  76 c ______________________________________________________________________
  77 c
  78 c====
  79 c 0. declarations et dimensionnement
  80 c====
  81 c
  82 c 0.1. ==> generalites
  83 c
  84       implicit none
  85       save
  86 c
  87       character*6 nompro
  88       parameter ( nompro = 'VCCFNC' )
  89 c
  90 #include "nblang.h"
  91 #include "consts.h"
  92 c
  93 #include "cofaar.h"
  94 #include "coftfq.h"
  95 #include "cofatq.h"
  96 #include "coftex.h"
  97 c
  98 #include "meddc0.h"
  99 c
 100 c 0.2. ==> communs
 101 c
 102 #include "envex1.h"
 103 #include "envca1.h"
 104 c
 105 #include "nbutil.h"
 106 #include "nbfamm.h"
 107 #include "dicfen.h"
 108 #include "impr02.h"
 109 c
 110 c 0.3. ==> arguments
 111 c
 112       integer nbfare
 113       integer cfaare(nctfar,nbfarm)
 114       integer nbfqua
 115       integer cfaqua(nctfqu,nbfqum)
 116       integer nbftri
 117       integer cfatri(nctftr,nbftrm)
 118 c
 119       integer faminf, famsup
 120       integer nbfme0
 121       integer numfam(nbfmed)
 122       integer grfmpo(0:nbfmed)
 123       integer grfmta(10*ngrouc)
 124 c
 125       character*8 nomfam(10,nbfmed)
 126       character*8 grfmtb(10*ngrouc)
 127 c
 128       integer ulsort, langue, codret
 129 c
 130 c 0.4. ==> variables locales
 131 c
 132       integer iaux, jaux, kaux
 133       integer nufamd(3)
 134 c
 135       character*8 saux08
 136 c
 137       integer nbmess
 138       parameter ( nbmess = 10 )
 139       character*80 texte(nblang,nbmess)
 140 c
 141 c 0.5. ==> initialisations
 142 c ______________________________________________________________________
 143 c
 144 c====
 145 c 1. initialisations
 146 c====
 147 c
 148 #include "impr01.h"
 149 c
 150 #ifdef _DEBUG_HOMARD_
 151       write (ulsort,texte(langue,1)) 'Entree', nompro
 152       call dmflsh (iaux)
 153 #endif
 154 c
 155       texte(1,4) = '(a14,'' : nombre de familles HOMARD : '',i8)'
 156       texte(1,5) = '(''Ce nombre est superieur au maximum :'',i8)'
 157       texte(1,6) = '(''Modifier le programme UTINCG'')'
 158       texte(1,7) = '(''. Famille MED supplementaire'',i2,'' :'',i6)'
 159       texte(1,8) = '(/,a14,'' : ajout de la famille MED'',i8)'
 160       texte(1,9) = '(''Aucun type n''''a ete trouve pour les '',a)'
 161 c
 162       texte(2,4) = '(a14,'' : number of HOMARD families:'',i8)'
 163       texte(2,5) = '(''This number is greater than maximum:'',i8)'
 164       texte(2,6) = '(''Modify UTINCG program.'')'
 165       texte(2,7) = '(''. Additional MED family #'',i2,'':'',i6)'
 166       texte(2,8) = '(/,a14,'' : addition of MED family #'',i8)'
 167       texte(2,9) = '(''No type was found for the '',a)'
 168 c
 169 #include "impr03.h"
 170 c
 171       codret = 0
 172 c
 173 #ifdef _DEBUG_HOMARD_
 174       write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare
 175       if ( nbtria.ne.0 ) then
 176         write (ulsort,texte(langue,4)) mess14(langue,4,2), nbftri
 177       endif
 178       if ( nbquad.ne.0 ) then
 179         write (ulsort,texte(langue,4)) mess14(langue,4,4), nbfqua
 180       endif
 181       write (ulsort,*) ' '
 182 #endif
 183 c
 184 c====
 185 c 2. On recherche trois nouveaux numeros de famille MED
 186 c====
 187 c 2.1. ==> on cherche le minimum entre tous les numeros de familles MED
 188 c          deja existant et ceux des faces inf/sup
 189 c
 190       iaux = min (faminf, famsup)
 191 c
 192       do 21 , jaux = 1 , nbfmed-3
 193 c
 194         iaux = min (iaux,numfam(jaux))
 195 c
 196    21 continue
 197 c
 198       nufamd(1) = iaux - 1
 199       nufamd(2) = iaux - 2
 200       nufamd(3) = iaux - 3
 201 c
 202 #ifdef _DEBUG_HOMARD_
 203       write (ulsort,texte(langue,7)) 1, nufamd(1)
 204       write (ulsort,texte(langue,7)) 2, nufamd(2)
 205       write (ulsort,texte(langue,7)) 3, nufamd(3)
 206 #endif
 207 c
 208 c====
 209 c 3. On ajoute deux nouvelles familles d'aretes
 210 c====
 211 c
 212 #ifdef _DEBUG_HOMARD_
 213       write (ulsort,90002) '3. Ajout fam. aretes ; codret', codret
 214 #endif
 215 c
 216 c 3.1. ==> a priori, aucune caracteristique particuliere
 217 c
 218       do 31 , iaux = 1 , nctfar
 219         cfaare(iaux,nbfare+1) = 0
 220         cfaare(iaux,nbfare+2) = 0
 221    31 continue
 222 c
 223 c 3.2. ==> La famille MED
 224 c
 225       cfaare(cofamd,nbfare+1) = nufamd(1)
 226       cfaare(cofamd,nbfare+2) = nufamd(1)
 227 c
 228 c 3.3. ==> le type des elements est le meme que celui d'une
 229 c          autre famille
 230 c          si aucun n'est trouve, on l'impose
 231 c
 232       kaux = 0
 233 c
 234       do 33 , iaux = 1 , nbfare
 235 c
 236         if ( cfaare(cotyel,iaux).ne.0 ) then
 237           kaux = cfaare(cotyel,iaux)
 238           goto 330
 239         endif
 240 c
 241    33 continue
 242 c
 243 #ifdef _DEBUG_HOMARD_
 244       write (ulsort,texte(langue,9)) mess14(langue,3,1)
 245 #endif
 246 c
 247       if ( degre.eq.1 ) then
 248         kaux = edseg2
 249       else
 250         kaux = edseg3
 251       endif
 252 c
 253   330 continue
 254 c
 255 #ifdef _DEBUG_HOMARD_
 256       write (ulsort,90002) 'Type des '//mess14(langue,3,1), kaux
 257 #endif
 258 c
 259       cfaare(cotyel,nbfare+1) = kaux
 260       cfaare(cotyel,nbfare+2) = kaux
 261 c
 262 c 3.4. ==> les orientations
 263 c
 264       cfaare(coorfa,nbfare+1) = 1
 265       cfaare(coorfa,nbfare+2) = -1
 266 c
 267       cfaare(cofifa,nbfare+1) = nbfare+2
 268       cfaare(cofifa,nbfare+2) = nbfare+1
 269 c
 270 c 3.5. ==> total des familles
 271 c
 272       nbfare = nbfare + 2
 273 c
 274 #ifdef _DEBUG_HOMARD_
 275       write (ulsort,texte(langue,8)) mess14(langue,4,1), nufamd(1)
 276       write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare
 277 #endif
 278 c
 279       if ( nbfare.gt.nbfarm ) then
 280         write (ulsort,texte(langue,4)) mess14(langue,4,1), nbfare
 281         write (ulsort,texte(langue,5)) nbfarm
 282         write (ulsort,texte(langue,6))
 283         codret = 1
 284       endif
 285 c
 286 c====
 287 c 4. On ajoute une nouvelle famille de quadrangles
 288 c====
 289 c
 290 #ifdef _DEBUG_HOMARD_
 291       write (ulsort,90002) '4. Ajout fam. quadrangles ; codret', codret
 292 #endif
 293 c
 294       if ( nbquad.ne.0 .or. nbhexa.ne.0 .or. nbpent.ne.0 ) then
 295 c
 296 c 4.1. ==> a priori, aucune caracteristique particuliere
 297 c
 298       do 41 , iaux = 1 , nctfqu
 299         cfaqua(iaux,nbfqua+1) = 0
 300    41 continue
 301 c
 302 c 4.2. ==> La famille MED
 303 c
 304       cfaqua(cofamd,nbfqua+1) = nufamd(2)
 305 c
 306 c 4.3. ==> le type des elements est le meme que celui d'une
 307 c          autre famille
 308 c          si aucun n'est trouve, on l'impose
 309 c
 310       kaux = 0
 311 c
 312       do 43 , iaux = 1 , nbfqua
 313 c
 314         if ( cfaqua(cotyel,iaux).ne.0 ) then
 315           kaux = cfaqua(cotyel,iaux)
 316           goto 430
 317         endif
 318 c
 319    43 continue
 320 c
 321 #ifdef _DEBUG_HOMARD_
 322       write (ulsort,texte(langue,9)) mess14(langue,3,4)
 323 #endif
 324 c
 325       if ( degre.eq.1 ) then
 326         kaux = edqua4
 327       else
 328         kaux = edqua8
 329       endif
 330 c
 331   430 continue
 332 c
 333 #ifdef _DEBUG_HOMARD_
 334       write (ulsort,90002) 'Type des '//mess14(langue,3,4), kaux
 335 #endif
 336 c
 337       cfaqua(cotyel,nbfqua+1) = kaux
 338 c
 339 c 4.4. ==>  la famille des aretes tracees : la famille libre
 340 c
 341       cfaqua(cofafa,nbfqua+1) = 1
 342 c
 343 c 4.5. ==> total des familles
 344 c
 345       nbfqua = nbfqua + 1
 346 c
 347 #ifdef _DEBUG_HOMARD_
 348       write (ulsort,texte(langue,8)) mess14(langue,4,4), nufamd(2)
 349       write (ulsort,texte(langue,4)) mess14(langue,4,4), nbfqua
 350 #endif
 351 c
 352       if ( nbfqua.gt.nbfqum ) then
 353         write (ulsort,texte(langue,4)) mess14(langue,4,4), nbfqua
 354         write (ulsort,texte(langue,5)) nbfqum
 355         write (ulsort,texte(langue,6))
 356         codret = 1
 357       endif
 358 c
 359       endif
 360 c
 361 c====
 362 c 5. On ajoute une nouvelle famille de triangles
 363 c====
 364 c
 365 #ifdef _DEBUG_HOMARD_
 366       write (ulsort,90002) '5. Ajout fam. triangles; codret', codret
 367 #endif
 368 c
 369       if ( nbtria.ne.0 .or. nbtetr.ne.0 .or. nbpent.ne.0 ) then
 370 c
 371 c 5.1. ==> a priori, aucune caracteristique particuliere
 372 c
 373       do 51 , iaux = 1 , nctftr
 374         cfatri(iaux,nbftri+1) = 0
 375    51 continue
 376 c
 377 c 5.2. ==> La famille MED
 378 c
 379       cfatri(cofamd,nbftri+1) = nufamd(3)
 380 c
 381 c 5.3. ==> le type des elements est le meme que celui d'une
 382 c          autre famille
 383 c          si aucun n'est trouve, on l'impose
 384 c
 385       kaux = 0
 386 c
 387       do 53 , iaux = 1 , nbftri
 388 c
 389         if ( cfatri(cotyel,iaux).ne.0 ) then
 390           kaux = cfatri(cotyel,iaux)
 391           goto 530
 392         endif
 393 c
 394    53 continue
 395 c
 396 #ifdef _DEBUG_HOMARD_
 397       write (ulsort,texte(langue,9)) mess14(langue,3,2)
 398 #endif
 399 c
 400       if ( degre.eq.1 ) then
 401         kaux = edtri3
 402       else
 403         kaux = edtri6
 404       endif
 405 c
 406   530 continue
 407 c
 408 #ifdef _DEBUG_HOMARD_
 409       write (ulsort,90002) 'Type des '//mess14(langue,3,2), kaux
 410 #endif
 411 c
 412       cfatri(cotyel,nbftri+1) = kaux
 413 c
 414 c 5.4. ==> la famille des aretes tracees : la famille libre
 415 c
 416       cfatri(cofafa,nbftri+1) = 1
 417 c
 418 c 5.5. ==> total des familles
 419 c
 420       nbftri = nbftri + 1
 421 c
 422 #ifdef _DEBUG_HOMARD_
 423       write (ulsort,texte(langue,8)) mess14(langue,4,2), nufamd(3)
 424       write (ulsort,texte(langue,4)) mess14(langue,4,2), nbftri
 425 #endif
 426 c
 427       if ( nbftri.gt.nbftrm ) then
 428         write (ulsort,texte(langue,4)) mess14(langue,4,2), nbftri
 429         write (ulsort,texte(langue,5)) nbftrm
 430         write (ulsort,texte(langue,6))
 431         codret = 1
 432       endif
 433 c
 434       endif
 435 c
 436 c====
 437 c 6. modification des structures des familles MED
 438 c====
 439 c
 440 #ifdef _DEBUG_HOMARD_
 441       write (ulsort,90002) '6. modification ; codret', codret
 442 #endif
 443 c
 444       if ( codret.eq.0 ) then
 445 c
 446       do 61 , iaux = 1 , 3
 447 c
 448         if ( codret.eq.0 ) then
 449 c
 450         jaux = nbfme0+iaux
 451 c
 452         do 611 , kaux = 1 , 10
 453           nomfam(kaux,jaux) = blan08
 454   611   continue
 455 c
 456         numfam(jaux) = nufamd(iaux)
 457         call utench ( nufamd(iaux), '_', kaux, saux08,
 458      >                ulsort, langue, codret )
 459 c                         12345678
 460         nomfam(1,jaux) = 'HOMARD__'
 461         nomfam(2,jaux)(1:kaux) = saux08(1:kaux)
 462 c
 463 c       un groupe dont le nom est 'HOMARD', mais que l'on astreint a
 464 c       une longueur totale de 80 caracteres pour etre coherent avec MED
 465 c
 466         grfmpo(jaux) = grfmpo(jaux-1) + 10
 467         do 610 , kaux = grfmpo(jaux-1)+1 , grfmpo(jaux)
 468           grfmta(kaux) = 8
 469           grfmtb(kaux) = blan08
 470   610   continue
 471 c                                   12345678
 472         grfmtb(grfmpo(jaux-1)+1) = 'HOMARD  '
 473 c
 474         endif
 475 c
 476    61 continue
 477 c
 478       endif
 479 c
 480 c====
 481 c 7. la fin
 482 c====
 483 c
 484       if ( codret.ne.0 ) then
 485 c
 486 #include "envex2.h"
 487 c
 488       write (ulsort,texte(langue,1)) 'Sortie', nompro
 489       write (ulsort,texte(langue,2)) codret
 490 c
 491       endif
 492 c
 493 #ifdef _DEBUG_HOMARD_
 494       write (ulsort,texte(langue,1)) 'Sortie', nompro
 495       call dmflsh (iaux)
 496 #endif
 497 c
 498       end