src/tool/AP_Conversion/pcfaat.F

   1       subroutine pcfaat ( typcca,
   2      >                    nhsupe, nhsups, nhqufa,
   3      >                    hetare, somare,
   4      >                    hettri, aretri,
   5      >                    hetqua, arequa,
   6      >                    perqua, nivqua,
   7      >                    povoso, voisom,
   8      >                    posifa, facare,
   9      >                    famare, cfaare,
  10      >                    famtri, cfatri,
  11      >                    famqua, pcfaqu,
  12      >                    ulsort, langue, codret )
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  20 c aupres des huissiers de justice Simart et Lavoir a Clamart
  21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  22 c aupres des huissiers de justice
  23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c
  33 c    aPres adaptation - Conversion - FAmilles pour ATHENA
  34 c     -                 -            --            --
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . typcca . e   .   1    . type du code de calcul                     .
  40 c . nhsupe . es  . char8  . informations supplementaires entieres      .
  41 c . nhsups . es  . char8  . informations supplementaires caracteres 8  .
  42 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  43 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  44 c . nhqufa . e   . char8  . nom de l'objet des familles de quadrangles .
  45 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  46 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  47 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  48 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  49 c . povoso . e   .0:nbnoto. pointeur des voisins par noeud             .
  50 c . voisom . e   . nvosom . aretes voisines de chaque noeud            .
  51 c . posifa . e   .0:nbarto. pointeur sur tableau facare                .
  52 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  53 c . famare . e   . nbarto . famille des aretes                         .
  54 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  55 c .        .     . nbfare .   1 : famille MED                          .
  56 c .        .     .        .   2 : type de segment                      .
  57 c .        .     .        .   3 : orientation                          .
  58 c .        .     .        .   4 : famille d'orientation inverse        .
  59 c .        .     .        .   5 : numero de ligne de frontiere         .
  60 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  61 c .        .     .        . <= 0 si non concernee                      .
  62 c .        .     .        .   6 : famille frontiere active/inactive    .
  63 c .        .     .        .   7 : numero de surface de frontiere       .
  64 c .        .     .        . + l : appartenance a l'equivalence l       .
  65 c . famtri . e   . nbtrto . famille des triangles                      .
  66 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  67 c .        .     . nbftri .   1 : famille MED                          .
  68 c .        .     .        .   2 : type de triangle                     .
  69 c .        .     .        .   3 : numero de surface de frontiere       .
  70 c .        .     .        .   4 : famille des aretes internes apres raf.
  71 c .        .     .        . + l : appartenance a l'equivalence l       .
  72 c . famqua . es  . nbquto . famille des quadrangles                    .
  73 c . pcfaqu . es  .    1   . adresse des codes des familles de quad.    .
  74 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  75 c . langue . e   .    1   . langue des messages                        .
  76 c .        .     .        . 1 : francais, 2 : anglais                  .
  77 c . codret . es  .    1   . code de retour des modules                 .
  78 c .        .     .        . 0 : pas de probleme                        .
  79 c .        .     .        . 1 : probleme                               .
  80 c ______________________________________________________________________
  81 c
  82 c====
  83 c 0. declarations et dimensionnement
  84 c====
  85 c
  86 c 0.1. ==> generalites
  87 c
  88       implicit none
  89       save
  90 c
  91       character*6 nompro
  92       parameter ( nompro = 'PCFAAT' )
  93 c
  94 #include "nblang.h"
  95 c
  96 c 0.2. ==> communs
  97 c
  98 #include "envex1.h"
  99 c
 100 #include "gmenti.h"
 101 #include "gmstri.h"
 102 c
 103 #include "nbutil.h"
 104 #include "nbfami.h"
 105 #include "nbfamm.h"
 106 #include "nombno.h"
 107 #include "nombar.h"
 108 #include "nombtr.h"
 109 #include "nombqu.h"
 110 c
 111 #include "dicfen.h"
 112 c
 113 #include "impr02.h"
 114 c
 115 c 0.3. ==> arguments
 116 c
 117       integer typcca
 118 c
 119       integer hetare(nbarto), somare(2,nbarto)
 120       integer hettri(nbtrto), aretri(nbtrto,3)
 121       integer hetqua(nbquto), arequa(nbquto,4)
 122       integer perqua(nbquto), nivqua(nbquto)
 123       integer povoso(0:nbnoto), voisom(*)
 124       integer posifa(0:nbarto), facare(nbfaar)
 125 c
 126       integer famare(nbarto), cfaare(nctfar,nbfare)
 127       integer famtri(nbtrto), cfatri(nctftr,nbftri)
 128       integer famqua(nbquto)
 129       integer pcfaqu
 130 c
 131       character*8 nhsupe, nhsups, nhqufa
 132 c
 133       integer ulsort, langue, codret
 134 c
 135 c 0.4. ==> variables locales
 136 c
 137       integer iaux, jaux
 138       integer codre0
 139       integer codre1, codre2, codre3, codre4, codre5
 140       integer codre6
 141       integer ptrav1, ptrav2, ptrav3, ptrav4, ptrav5
 142       integer ptra15, ptra16
 143       integer ptrae3, ptrae4, ptrae9, ptras4, ptras5
 144       integer adsue3, adsue4, adsue9, adsus4, adsus9
 145 c
 146       integer un
 147       integer nbblqu
 148       integer nattrc, nbattr, nbfold, nbfn00, nbfnew, nbfq00
 149 c
 150       character*8 ntrav1, ntrav2, ntrav3, ntrav4, ntrav5
 151       character*8 ntra15, ntra16
 152       character*8 ntrae3, ntrae4, ntrae9, ntras4, ntras9
 153 c
 154       integer nbmess
 155       parameter ( nbmess = 10 )
 156       character*80 texte(nblang,nbmess)
 157 c
 158 c 0.5. ==> initialisations
 159 c ______________________________________________________________________
 160 c
 161 c====
 162 c 1. initialisations
 163 c====
 164 c
 165 c 1.1. ==> messages
 166 c
 167 #include "impr01.h"
 168 c
 169 #ifdef _DEBUG_HOMARD_
 170       write (ulsort,texte(langue,1)) 'Entree', nompro
 171       call dmflsh (iaux)
 172 #endif
 173 c
 174       texte(1,4) = '(''Traitement specifique a ATHENA'')'
 175       texte(1,5) = '(i6,'' blocs de '',a,/)'
 176       texte(1,10) = '(''Type du code de calcul (typcca) :'',i5)'
 177 c
 178       texte(2,4) = '(''Specific treatment to ATHENA'')'
 179       texte(2,5) = '(i6,'' blocks of '',a,/)'
 180       texte(2,10) = '(''Type of calculation code (typcca) :'',i5)'
 181 c
 182 #ifdef _DEBUG_HOMARD_
 183       write (ulsort,texte(langue,10)) typcca
 184 #endif
 185 c
 186       if ( typcca.eq.16 ) then
 187         codret = 0
 188       else
 189         codret = 1
 190         write (ulsort,texte(langue,10)) typcca
 191         write (ulsort,texte(langue,4))
 192       endif
 193 c
 194       un = 1
 195 c
 196 c====
 197 c 2. tableaux de travail
 198 c====
 199 #ifdef _DEBUG_HOMARD_
 200       write (ulsort,*) '2. tableaux de travail ; codret = ', codret
 201 #endif
 202 c
 203       if ( codret.eq.0 ) then
 204 c
 205       call gmalot ( ntrav1, 'entier  ', nbquto, ptrav1, codre1 )
 206       call gmalot ( ntrav2, 'entier  ', nbnoto, ptrav2, codre2 )
 207       call gmalot ( ntrav3, 'entier  ', nbarto, ptrav3, codre3 )
 208       iaux = nbquto + nbtrto + 1
 209       call gmalot ( ntrav4, 'entier  ', iaux, ptrav4, codre4 )
 210       iaux = nbquto + 1
 211       call gmalot ( ntrav5, 'entier  ', iaux, ptrav5, codre5 )
 212 c
 213       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 214       codret = max ( abs(codre0), codret,
 215      >               codre1, codre2, codre3, codre4, codre5 )
 216 c
 217       call gmalot ( ntra15, 'entier  ', nbarto, ptra15, codre1 )
 218       call gmalot ( ntra16, 'entier  ', nbarto, ptra16, codre2 )
 219 c
 220       codre0 = min ( codre1, codre2 )
 221       codret = max ( abs(codre0), codret,
 222      >               codre1, codre2 )
 223 c
 224       endif
 225 c
 226 c====
 227 c 3. recherche des blocs
 228 c====
 229 #ifdef _DEBUG_HOMARD_
 230       write (ulsort,*) '3. recherche des blocs ; codret = ', codret
 231 #endif
 232 c
 233       if ( codret.eq.0 ) then
 234 c
 235 c       on examine toutes les faces
 236 c
 237       jaux = nbquto + nbtrto
 238       do 42 , iaux = 0, jaux
 239         imem(ptrav4+iaux) = 1
 240    42 continue
 241       imem(ptrav4+nbquto) = 0
 242       iaux = 0
 243       jaux = 0
 244       call utb11c ( nbblqu, iaux, imem(ptrav4),
 245      >              hetare, somare,
 246      >              hettri, aretri,
 247      >              hetqua, arequa,
 248      >              povoso, voisom,
 249      >              posifa, facare,
 250      >              famare, cfaare,
 251      >              famtri, cfatri,
 252      >              famqua, imem(pcfaqu),
 253      >              imem(ptrav1), imem(ptrav2), imem(ptrav3),
 254      >              imem(ptra15), imem(ptra16),
 255      >              imem(ptrav5),
 256      >              jaux, ulsort, langue, codret )
 257 c
 258 #ifdef _DEBUG_HOMARD_
 259 10000 format(3x,20i4)
 260 10001 format(4x,80('-'))
 261       write(ulsort,*) 'Fin etape 3 avec codret = ', codret
 262       write(ulsort,texte(langue,5)) nbblqu, mess14(langue,3,4)
 263       write(ulsort,10000) (iaux,iaux=1,min(20,nbquto))
 264       write(ulsort,10001)
 265       write(ulsort,10000) (imem(ptrav5+iaux),iaux=0,min(20,nbquto-1))
 266       write(ulsort,10000) (imem(pcfaqu+iaux),iaux=0,nctfqu*nbfqua-1)
 267       write(ulsort,10000) (famqua(iaux),iaux=1,min(20,nbquto))
 268 #endif
 269 c
 270       endif
 271 c
 272       if ( codret.eq.0 ) then
 273 c
 274       call gmlboj ( ntrav2, codret )
 275 c
 276       endif
 277 c
 278 c====
 279 c 4. Gestion des tableaux
 280 c====
 281 c
 282 #ifdef _DEBUG_HOMARD_
 283       write (ulsort,*) '4. Gestion des tableaux ; codret = ', codret
 284 #endif
 285 c
 286       nbattr = 4
 287 c
 288 c 4.1. ==> Description actuelle des attributs
 289 c
 290 c      nhsupe//'.Tab3' : Pointeur dans la table des attributs
 291 c      nhsupe//'.Tab4' : Table des attributs
 292 c      nhsupe//'.Tab5' : Pointeur dans la table des groupes
 293 c      nhsupe//'.Tab6' : Taille des noms des groupes
 294 c      nhsupe//'.Tab9' : Numero des familles MED
 295 c      nhsups//'.Tab2' : Noms des groupes (char*80)
 296 c      nhsups//'.Tab4' : Noms des familles MED (char*64)
 297 c      nhsups//'.Tab9' : Descriptions des attributs (char*200)
 298 c
 299 #ifdef _DEBUG_HOMARD_
 300       call gmprsx (nompro, nhsupe )
 301       call gmprsx (nompro, nhsupe//'.Tab3' )
 302       call gmprsx (nompro, nhsupe//'.Tab4' )
 303       call gmprsx (nompro, nhsupe//'.Tab9' )
 304       call gmprsx (nompro, nhsups )
 305       call gmprsx (nompro, nhsups//'.Tab4' )
 306       call gmprsx (nompro, nhsups//'.Tab9' )
 307 #endif
 308 c
 309       if ( codret.eq.0 ) then
 310 c
 311       call gmadoj ( nhsupe//'.Tab3', adsue3, iaux, codre1 )
 312       call gmadoj ( nhsupe//'.Tab4', adsue4, iaux, codre2 )
 313       call gmadoj ( nhsupe//'.Tab9', adsue9, iaux, codre3 )
 314       call gmadoj ( nhsups//'.Tab4', adsus4, iaux, codre4 )
 315       call gmadoj ( nhsups//'.Tab9', adsus9, iaux, codre5 )
 316 c
 317       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 318       codret = max ( abs(codre0), codret,
 319      >               codre1, codre2, codre3, codre4, codre5 )
 320 c
 321       endif
 322 c
 323 c 4.2. ==> Caracteristiques des familles MED
 324 c
 325       nbfn00 = nbblqu*nbfmed
 326       nbfq00 = nbfqum
 327 c
 328       if ( codret.eq.0 ) then
 329 c
 330       iaux = nbfn00 + 1
 331       call gmalot ( ntrae3, 'entier  ', iaux, ptrae3, codre1 )
 332       iaux = nbattr * (nbfn00-1)
 333       call gmalot ( ntrae4, 'entier  ', iaux, ptrae4, codre2 )
 334       call gmalot ( ntrae9, 'entier  ', nbfn00, ptrae9, codre3 )
 335       iaux = 10 * nbfn00
 336       call gmalot ( ntras4, 'chaine  ', iaux, ptras4, codre4 )
 337       iaux = 25 * nbattr * (nbfn00-1)
 338       call gmalot ( ntras9, 'chaine  ', iaux, ptras5, codre5 )
 339 c
 340       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 341       codret = max ( abs(codre0), codret,
 342      >               codre1, codre2, codre3, codre4, codre5 )
 343 c
 344       call gmmod ( nhqufa//'.Codes', pcfaqu,
 345      >             nctfqu, nctfqu, nbfqua, nbfq00, codre1 )
 346       iaux = nbfn00 * (nctfqu+3)
 347       call gmalot ( ntrav2, 'entier  ', iaux, ptrav2, codre2 )
 348 c
 349       codre0 = min ( codre1, codre2 )
 350       codret = max ( abs(codre0), codret,
 351      >               codre1, codre2 )
 352 c
 353       endif
 354 c
 355 c====
 356 c 5. Creation des familles
 357 c====
 358 c
 359 #ifdef _DEBUG_HOMARD_
 360       write (ulsort,*) '5. Creation des familles ; codret = ', codret
 361 #endif
 362 c
 363       if ( codret.eq.0 ) then
 364 c
 365 #ifdef _DEBUG_HOMARD_
 366       write (ulsort,texte(langue,3)) 'PCFAA1', nompro
 367 #endif
 368       nbfold = nbfmed
 369       call pcfaa1 ( nbblqu,
 370      >              nbattr, nbfold, nbfn00, nbfnew, nbfq00,
 371      >              perqua, nivqua,
 372      >              famqua, imem(pcfaqu),
 373      >              imem(adsue3), imem(ptrae3),
 374      >              imem(adsue4), imem(ptrae4),
 375      >              imem(adsue9), imem(ptrae9),
 376      >              smem(adsus4), smem(ptras4),
 377      >              smem(adsus9), smem(ptras5),
 378      >              imem(ptrav5), imem(ptrav2),
 379      >              ulsort, langue, codret )
 380 c
 381       endif
 382 c
 383 c====
 384 c 6. Gestion des tableaux
 385 c====
 386 c
 387 #ifdef _DEBUG_HOMARD_
 388       write (ulsort,*) '6. Gestion des tableaux ; codret = ', codret
 389 #endif
 390 c
 391 #ifdef _DEBUG_HOMARD_
 392       call gmprsx (nompro, ntrae3 )
 393       call gmprsx (nompro, ntrae4 )
 394       call gmprsx (nompro, ntrae9 )
 395       call gmprsx (nompro, ntras4 )
 396       call gmprsx (nompro, ntras9 )
 397 #endif
 398 c
 399 c 6.1. ==> Redimensionnement des tableaux lies aux attributs
 400 c
 401       if ( codret.eq.0 ) then
 402 c
 403       nbfmed = nbfnew
 404       nattrc = nbattr*(nbfmed-1)
 405 c
 406       iaux = nbfn00 + 1
 407       jaux = nbfmed + 1
 408       call gmmod ( ntrae3, ptrae3, iaux, jaux, un, un, codre1 )
 409       call gmmod ( ntrae4, ptrae4,
 410      >             nbattr, nbattr, nbfn00-1, nbfmed-1, codre2 )
 411       call gmmod ( ntrae9, ptrae9, nbfn00, nbfmed, un, un, codre3 )
 412       iaux = 4
 413       call gmmod ( ntras4, ptras4, iaux, iaux, nbfn00, nbfmed, codre4 )
 414       iaux = nbattr * 25
 415       call gmmod ( ntras9, ptras5,
 416      >             iaux, iaux, nbfn00-1, nbfmed-1, codre5 )
 417       call gmmod ( nhqufa//'.Codes', pcfaqu,
 418      >             nctfqu, nctfqu, nbfq00, nbfqua, codre6 )
 419 c
 420       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 421      >               codre6 )
 422       codret = max ( abs(codre0), codret,
 423      >               codre1, codre2, codre3, codre4, codre5,
 424      >               codre6 )
 425 c
 426 #ifdef _DEBUG_HOMARD_
 427       call gmprsx (nompro, ntrae3 )
 428       call gmprsx (nompro, ntrae4 )
 429       call gmprsx (nompro, ntrae9 )
 430       call gmprsx (nompro, ntras4 )
 431       call gmprsx (nompro, ntras9 )
 432 #endif
 433 c
 434       endif
 435 c
 436 c 6.2. ==> Remplacement dans la structure generale des tableaux
 437 c          lies aux attributs
 438 c
 439       if ( codret.eq.0 ) then
 440 c
 441       call gmcpoj ( ntrae3, nhsupe//'.Tab3', codre1 )
 442       call gmcpoj ( ntrae4, nhsupe//'.Tab4', codre2 )
 443       call gmcpoj ( ntrae9, nhsupe//'.Tab9', codre3 )
 444       call gmcpoj ( ntras4, nhsups//'.Tab4', codre4 )
 445       call gmcpoj ( ntras9, nhsups//'.Tab9', codre5 )
 446 c
 447       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 448       codret = max ( abs(codre0), codret,
 449      >               codre1, codre2, codre3, codre4, codre5 )
 450 c
 451       call gmecat ( nhsupe, 3, nbfmed+1, codre1 )
 452       call gmecat ( nhsupe, 4, nattrc, codre2 )
 453       iaux = 25 * nattrc
 454       call gmecat ( nhsups, 9, iaux, codre3 )
 455       call gmecat ( nhsupe, 9, nbfmed, codre4 )
 456       iaux = 4*nbfmed
 457       call gmecat ( nhsups, 4, iaux, codre5 )
 458 c
 459       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 460       codret = max ( abs(codre0), codret,
 461      >               codre1, codre2, codre3, codre4, codre5 )
 462 c
 463 #ifdef _DEBUG_HOMARD_
 464       call gmprsx (nompro, nhsupe )
 465       call gmprsx (nompro, nhsupe//'.Tab3' )
 466       call gmprsx (nompro, nhsupe//'.Tab4' )
 467       call gmprsx (nompro, nhsupe//'.Tab9' )
 468       call gmprsx (nompro, nhsups )
 469       call gmprsx (nompro, nhsups//'.Tab4' )
 470       call gmprsx (nompro, nhsups//'.Tab9' )
 471 #endif
 472 c
 473       endif
 474 c
 475 c 6.3. ==> Menage
 476 c
 477       if ( codret.eq.0 ) then
 478 c
 479       call gmlboj ( ntrav1, codre1 )
 480       call gmlboj ( ntrav2, codre2 )
 481       call gmlboj ( ntrav3, codre3 )
 482       call gmlboj ( ntrav4, codre4 )
 483       call gmlboj ( ntrav5, codre5 )
 484 c
 485       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 486       codret = max ( abs(codre0), codret,
 487      >               codre1, codre2, codre3, codre4, codre5 )
 488 c
 489       call gmlboj ( ntra15, codre1 )
 490       call gmlboj ( ntra16, codre2 )
 491 c
 492       codre0 = min ( codre1, codre2 )
 493       codret = max ( abs(codre0), codret,
 494      >               codre1, codre2 )
 495 c
 496       call gmlboj ( ntrae3, codre1 )
 497       call gmlboj ( ntrae4, codre2 )
 498       call gmlboj ( ntrae9, codre3 )
 499       call gmlboj ( ntras4, codre4 )
 500       call gmlboj ( ntras9, codre5 )
 501 c
 502       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 503       codret = max ( abs(codre0), codret,
 504      >               codre1, codre2, codre3, codre4, codre5 )
 505 c
 506       endif
 507 c
 508 c====
 509 c 7. la fin
 510 c====
 511 c
 512 #ifdef _DEBUG_HOMARD_
 513 70000 format(3x,20i4)
 514       write(ulsort,*) 'Etape 7 avec codret = ', codret
 515       write(ulsort,70000) (imem(pcfaqu+iaux),iaux=0,nctfqu*nbfqua-1)
 516       write(ulsort,70000) (famqua(iaux),iaux=1,min(20,nbquto))
 517 #endif
 518 c
 519       if ( codret.ne.0 ) then
 520 c
 521 #include "envex2.h"
 522 c
 523       write (ulsort,texte(langue,1)) 'Sortie', nompro
 524       write (ulsort,texte(langue,2)) codret
 525 c
 526       endif
 527 c
 528 #ifdef _DEBUG_HOMARD_
 529       write (ulsort,texte(langue,1)) 'Sortie', nompro
 530       call dmflsh (iaux)
 531 #endif
 532 c
 533       end