src/tool/AP_Conversion/pcsrho.F

   1       subroutine pcsrho ( nbfop1, nbfop2, numnp1, numnp2,
   2      >                    deraff, option,
   3      >                    hetnoe, ancnoe,
   4      >                    nnoeho, nnoeca,
   5      >                    nbvapr, listpr, prfcan, profho,
   6      >                    vap1ec, vap2ec,
   7      >                    vap1ho, vap2ho,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    aPres adaptation - Conversion de Solution - Renumerotation vers
  30 c     -                 -             -          -
  31 c                                                HOMARD
  32 c ______________________________________________________________________
  33 c                                                --
  34 c    Remarque : on suppose qu'il y a une valeur de solution aussi
  35 c               sur les eventuels noeuds isoles.
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . nbfop1 . e   .    1   . nombre de fonctions P1                     .
  41 c . nbfop2 . e   .    1   . nombre de fonctions P2                     .
  42 c . numnp1 . e   .    1   . nombre de noeuds de la fonction si P1      .
  43 c . numnp2 . e   .    1   . nombre de noeuds de la fonction si P2      .
  44 c . deraff . e   .    1   . vrai, s'il y a eu du deraffinement en      .
  45 c .        .     .        . passant de l'iteration n a n+1 ; faux sinon.
  46 c . option . e   .    1   . option du traitement                       .
  47 c .        .     .        . -1 : Pas de changement dans le maillage    .
  48 c .        .     .        .  0 : Adaptation complete                   .
  49 c .        .     .        .  1 : Modification de degre                 .
  50 c . hetnoe . e   . nbnoto . historique de l'etat des noeuds            .
  51 c . ancnoe . e   . nbnoto . ancien numero de noeud si deraffinement    .
  52 c . nnoeho . e   . renoac . numero des noeuds en entre pour homard     .
  53 c . nnoeca . e   . renoto . numero des noeuds du code de calcul        .
  54 c . nbvapr . e   .   1    . nombre de valeurs du profil                .
  55 c .        .     .        . -1, si pas de profil                       .
  56 c . listpr . e   .   *    . liste des numeros de noeuds ou la fonction .
  57 c .        .     .        . est definie.                               .
  58 c . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  59 c .        .     .        . 0 : l'entite est absente du profil         .
  60 c .        .     .        . i : l'entite est au rang i dans le profil  .
  61 c . profho . es  . nbnoto . pour chaque noeud en numerotation homard : .
  62 c .        .     .        . 0 : le noeud est absent du profil          .
  63 c .        .     .        . 1 : le noeud est present dans le profil    .
  64 c . vap1ec . e   . nbfop1*. variables p1 en entree pour le calcul      .
  65 c .        .     . numnp1 .                                            .
  66 c . vap2ec . e   . nbfop2*. variables p2 en entree pour le calcul      .
  67 c .        .     . numnp2 .                                            .
  68 c . vap1ho .  s  . nbfop1*. variables p1 numerotation homard           .
  69 c .        .     . nbnoto .                                            .
  70 c . vap2ho .  s  . nbfop2*. variables p2 numerotation homard           .
  71 c .        .     . nbnoto .                                            .
  72 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  73 c . langue . e   .    1   . langue des messages                        .
  74 c .        .     .        . 1 : francais, 2 : anglais                  .
  75 c . codret . es  .    1   . code de retour des modules                 .
  76 c .        .     .        . 0 : pas de probleme                        .
  77 c .        .     .        . 1 : probleme                               .
  78 c ______________________________________________________________________
  79 c
  80 c====
  81 c 0. declarations et dimensionnement
  82 c====
  83 c
  84 c 0.1. ==> generalites
  85 c
  86       implicit none
  87       save
  88 c
  89       character*6 nompro
  90       parameter ( nompro = 'PCSRHO' )
  91 c
  92 #include "nblang.h"
  93 c
  94 c 0.2. ==> communs
  95 c
  96 #include "envex1.h"
  97 c
  98 #include "nomber.h"
  99 #include "nombsr.h"
 100 #include "nombno.h"
 101 c
 102 c 0.3. ==> arguments
 103 c
 104       integer nbfop1, nbfop2
 105       integer numnp1, numnp2
 106       integer option
 107 c
 108       integer nbvapr, listpr(*)
 109 c
 110       integer hetnoe(nbnoto), ancnoe(nbnoto)
 111       integer prfcan(*), profho(rsnoto)
 112       integer nnoeho(renoac), nnoeca(renoto)
 113 c
 114       double precision vap1ec(nbfop1,renoto), vap2ec(nbfop2,renoto)
 115       double precision vap1ho(nbfop1,*), vap2ho(nbfop2,*)
 116 c
 117       logical deraff
 118 c
 119       integer ulsort, langue, codret
 120 c
 121 c 0.4. ==> variables locales
 122 c
 123       integer nuv, lenoeu
 124       integer iaux
 125 c
 126       integer nbmess
 127       parameter ( nbmess = 120 )
 128       character*80 texte(nblang,nbmess)
 129 c
 130 c 0.5. ==> initialisations
 131 c ______________________________________________________________________
 132 c
 133 c====
 134 c 1. initialisations
 135 c====
 136 c
 137 c 1.1. ==> messages
 138 c
 139 #include "impr01.h"
 140 #include "impr03.h"
 141 c
 142 #ifdef _DEBUG_HOMARD_
 143       write (ulsort,texte(langue,1)) 'Entree', nompro
 144       call dmflsh (iaux)
 145 #endif
 146 c
 147       texte(1,4) = '(''Situation impossible ?'')'
 148 c
 149       texte(2,4) = '(''Impossible situation ?'')'
 150 c
 151       codret = 0
 152 c
 153 #ifdef _DEBUG_HOMARD_
 154       write (ulsort,90002) 'option', option
 155       write (ulsort,90002) 'numnp1', numnp1
 156       write (ulsort,90002) 'numnp2', numnp2
 157       write (ulsort,90002) 'nbnoto', nbnoto
 158       write (ulsort,90002) 'nbfop1', nbfop1
 159       write (ulsort,90002) 'nbfop2', nbfop2
 160       write (ulsort,90002) 'nbvapr', nbvapr
 161       write (ulsort,90002) 'reno1i', reno1i
 162       write (ulsort,90002) 'renoto', renoto
 163       write (ulsort,90002) 'etats',(hetnoe(iaux),iaux=1,4)
 164 #endif
 165 c
 166 c====
 167 c 2. Cas :
 168 c    - d'adaptation complete
 169 c    - maillage inchange ou uniquement du raffinement
 170 c    Dans ce cas, chaque noeud en entree de HOMARD est encore un noeud
 171 c    en sortie. Le numero d'un noeud dans HOMARD reste inchange.
 172 c    Il suffit de translater les numeros :
 173 c     Numero dans le calcul en entree  <--->  Numero HOMARD
 174 c                lenoeu                <--->  nnoeho(lenoeu)
 175 c====
 176 c
 177       if ( .not.deraff .and. option.le.0 ) then
 178 cgn        write (ulsort,90002) 'sans deraffinement'
 179 c
 180 c 2.1. ==> valeurs p1
 181 c
 182         do 21, nuv = 1, nbfop1
 183 c
 184 c 2.1.1. ==> sans profil : on a des valeurs sur tous les noeuds
 185 c
 186           if ( nbvapr.le.0 ) then
 187 cgn        write (ulsort,90002) 'sans profil'
 188 c
 189             do 211 , lenoeu = 1 , numnp1
 190 cgn        write (ulsort,90002) 'lenoeu', lenoeu, nnoeho(lenoeu)
 191 cgn        write(*,90004) 'vap1ec(nuv,lenoeu)', vap1ec(nuv,lenoeu)
 192               vap1ho(nuv,nnoeho(lenoeu)) = vap1ec(nuv,lenoeu)
 193               profho(lenoeu) = 1
 194   211       continue
 195 c
 196           else
 197 c
 198 c 2.1.2. ==> avec profil : on a des valeurs sur les noeuds de listpr
 199 c
 200 cgn        write (ulsort,90002) 'profil, nbvapr', nbvapr
 201             do 212 , iaux = 1 , nbvapr
 202 cgn          print 1789,nuv,' --- ',iaux,vap1ec(nuv,iaux),listpr(iaux),
 203 cgn     <nnoeho(listpr(iaux))
 204               vap1ho(nuv,nnoeho(listpr(iaux))) = vap1ec(nuv,iaux)
 205               profho(nnoeho(listpr(iaux))) = 1
 206   212       continue
 207 c
 208           endif
 209 c
 210    21   continue
 211 c
 212 c 2.2. ==> valeurs p2
 213 c
 214         do 22, nuv = 1, nbfop2
 215 c
 216 c 2.2.1. ==> sans profil : on a des valeurs sur tous les noeuds
 217 c
 218           if ( nbvapr.le.0 ) then
 219 cgn        write (ulsort,90002) 'sans profil'
 220 c
 221             do 221 , lenoeu = 1 , numnp2
 222               vap2ho(nuv,nnoeho(lenoeu)) = vap2ec(nuv,lenoeu)
 223               profho(lenoeu) = 1
 224   221       continue
 225 c
 226           else
 227 c
 228 c 2.2.2. ==> avec profil : on a des valeurs sur les noeuds de listpr
 229 c
 230 cgn        write (ulsort,90002) 'profil, nbvapr', nbvapr
 231             do 222 , iaux = 1 , nbvapr
 232 cgn          print 1789,nuv,' --- ',iaux,vap2ec(nuv,iaux),listpr(iaux),
 233 cgn     <nnoeho(listpr(iaux))
 234               vap2ho(nuv,nnoeho(listpr(iaux))) = vap2ec(nuv,iaux)
 235               profho(nnoeho(listpr(iaux))) = 1
 236   222       continue
 237 c
 238           endif
 239 c
 240    22   continue
 241 c
 242 c====
 243 c 3. Cas :
 244 c    - d'adaptation complete
 245 c    - avec du deraffinement
 246 c    Dans ce cas, il ne faut reporter les valeurs que pour les noeuds
 247 c    qui existent encore. La translation est alors :
 248 c
 249 c         Numero dans le   <--->   Numero HOMARD <---> Numero HOMARD
 250 c        calcul en entree           en entree            en sortie
 251 c   nnoeca(ancnoe(lenoeu)) <--->  ancnoe(lenoeu) <--->    lenoeu
 252 c
 253 c====
 254 c
 255       elseif ( option.le.0 ) then
 256 cgn        write (ulsort,90002) 'avec deraffinement'
 257 c
 258 c 3.1. ==> valeurs p1
 259 c          - un noeud isole a pour etat 0, invariable.
 260 c          - un noeud d'une maille ignoree a pour etat 7, invariable.
 261 c          - un noeud support de maille-point a pour etat 3 ou 33.
 262 c          - un noeud P1 a pour etat 1.
 263 c            s'il existait avant, son etat valait :
 264 c                   . 1, il n'a pas change ;
 265 c                   . 2, il etait P2 et a change suite a deraffinement,
 266 c                        mais une fonction P1 n'avait pas de valeur ici.
 267 c Sont donc concernes les noeuds d'historique 0, 3, 7, 11 ou 33
 268 c
 269 c 3.1.1. ==> sans profil : on a des valeurs sur tous les noeuds
 270 c
 271         if ( nbvapr.le.0 ) then
 272 cgn        write (ulsort,90002) 'sans profil'
 273 c
 274           do 311, nuv = 1, nbfop1
 275             do 3111, lenoeu = 1, nbnoto
 276 cgn        write (ulsort,90002) 'lenoeu', lenoeu, hetnoe(lenoeu)
 277               if ( hetnoe(lenoeu).eq.0  .or.
 278      >             hetnoe(lenoeu).eq.3  .or.
 279      >             hetnoe(lenoeu).eq.11 .or.
 280      >             hetnoe(lenoeu).eq.33 .or.
 281      >             hetnoe(lenoeu).eq.7  .or.
 282      >             hetnoe(lenoeu).eq.77 ) then
 283 cgn      write(*,90004) 'vap1ec(nuv,nnoeca(ancnoe(lenoeu)))',
 284 cgn     >                vap1ec(nuv,nnoeca(ancnoe(lenoeu)))
 285                 vap1ho(nuv,lenoeu) = vap1ec(nuv,nnoeca(ancnoe(lenoeu)))
 286                 profho(lenoeu) = 1
 287               endif
 288  3111       continue
 289   311     continue
 290 c
 291         else
 292 c
 293 c 3.1.2. ==> avec profil : on a des valeurs sur les noeuds de listpr
 294 c
 295 cgn        write (ulsort,90002) 'profil, nbvapr', nbvapr
 296           do 312, nuv = 1, nbfop1
 297             do 3121, lenoeu = 1, nbnoto
 298               if ( hetnoe(lenoeu).eq.0  .or.
 299      >             hetnoe(lenoeu).eq.3  .or.
 300      >             hetnoe(lenoeu).eq.11 .or.
 301      >             hetnoe(lenoeu).eq.33 .or.
 302      >             hetnoe(lenoeu).eq.7  .or.
 303      >             hetnoe(lenoeu).eq.77 ) then
 304                 iaux = prfcan(nnoeca(ancnoe(lenoeu)))
 305                 if ( iaux.gt.0 ) then
 306                   vap1ho(nuv,lenoeu) = vap1ec(nuv,iaux)
 307                   profho(lenoeu) = 1
 308                 endif
 309               endif
 310  3121       continue
 311   312     continue
 312 c
 313         endif
 314 c
 315 c 3.2. ==> valeurs p2
 316 c          - un noeud isole a pour etat 0, invariable.
 317 c          - un noeud d'une maille ignoree a pour etat 7, invariable.
 318 c          - un noeud support de maille-point a pour etat 3 ou 33.
 319 c          - un noeud P1 ou P2 a pour etat 1. ou 2
 320 c            s'il existait avant, son etat valait :
 321 c                   . 1, il etait P1 ;
 322 c                   . 2, il etait P2.
 323 c Sont donc concernes les noeuds d'historique 0, 3, 11, 12, 21, 2 ou 33.
 324 c
 325 c 3.2.1. ==> sans profil : on a des valeurs sur tous les noeuds
 326 c
 327         if ( nbvapr.le.0 ) then
 328 cgn        write (ulsort,90002) 'sans profil'
 329 c
 330           do 321, nuv = 1, nbfop2
 331             do 3211, lenoeu = 1, nbnoto
 332               if ( hetnoe(lenoeu).eq.0  .or.
 333      >             hetnoe(lenoeu).eq.3  .or.
 334      >             hetnoe(lenoeu).eq.11 .or.
 335      >             hetnoe(lenoeu).eq.12 .or.
 336      >             hetnoe(lenoeu).eq.21 .or.
 337      >             hetnoe(lenoeu).eq.22 .or.
 338      >             hetnoe(lenoeu).eq.33 .or.
 339      >             hetnoe(lenoeu).eq.7  .or.
 340      >             hetnoe(lenoeu).eq.77 ) then
 341                 vap2ho(nuv,lenoeu) = vap2ec(nuv,nnoeca(ancnoe(lenoeu)))
 342                 profho(lenoeu) = 1
 343               endif
 344  3211       continue
 345   321     continue
 346 c
 347         else
 348 c
 349 c 3.2.2. ==> avec profil : on a des valeurs sur les noeuds de listpr
 350 c
 351 cgn        write (ulsort,90002) 'profil, nbvapr', nbvapr
 352           do 322, nuv = 1, nbfop2
 353             do 3221, lenoeu = 1, nbnoto
 354               if ( hetnoe(lenoeu).eq.0  .or.
 355      >             hetnoe(lenoeu).eq.3  .or.
 356      >             hetnoe(lenoeu).eq.11 .or.
 357      >             hetnoe(lenoeu).eq.12 .or.
 358      >             hetnoe(lenoeu).eq.21 .or.
 359      >             hetnoe(lenoeu).eq.22 .or.
 360      >             hetnoe(lenoeu).eq.33 .or.
 361      >             hetnoe(lenoeu).eq.7  .or.
 362      >             hetnoe(lenoeu).eq.77 ) then
 363                 iaux = prfcan(nnoeca(ancnoe(lenoeu)))
 364                 if ( iaux.gt.0 ) then
 365                   vap2ho(nuv,lenoeu) = vap2ec(nuv,iaux)
 366                   profho(lenoeu) = 1
 367                 endif
 368               endif
 369  3221       continue
 370   322     continue
 371 c
 372         endif
 373 c
 374 c====
 375 c 4. Cas :
 376 c    - modification de degre
 377 c      En fait c'est seulement du passage de P2 a P1
 378 c    Dans ce cas, il ne faut reporter les valeurs que pour les noeuds
 379 c    qui existent encore. La translation est alors :
 380 c
 381 c         Numero dans le   <--->   Numero HOMARD <---> Numero HOMARD
 382 c        calcul en entree           en entree            en sortie
 383 c   nnoeca(ancnoe(lenoeu)) <--->  ancnoe(lenoeu) <--->    lenoeu
 384 c
 385 c====
 386 c
 387       elseif ( option.eq.1 ) then
 388 cgn        write (ulsort,90002) 'modification de degre'
 389 c
 390 c 4.1. ==> passage de degre 2 a degre 1
 391 c
 392         if ( nbfop1.ne.0 ) then
 393 c
 394 c          - un noeud isole a pour etat 0, invariable.
 395 c          - un noeud support de maille-point a pour etat 3.
 396 c          - un noeud d'une maille ignoree a pour etat 7, invariable.
 397 c          - un noeud P1 a pour etat 1.
 398 c Sont donc concernes les noeuds d'historique 0, 1, 3
 399 c
 400 c 4.1.1. ==> sans profil : on a des valeurs sur tous les noeuds
 401 c
 402           if ( nbvapr.le.0 ) then
 403 cgn          write (ulsort,90002) 'sans profil'
 404 c
 405             do 411, nuv = 1, nbfop1
 406               do 4111, lenoeu = 1, nbnoto
 407 cgn          write (ulsort,90002) 'lenoeu', lenoeu, hetnoe(lenoeu),
 408 cgn     >                  ancnoe(lenoeu), nnoeca(ancnoe(lenoeu))
 409                 if ( hetnoe(lenoeu).eq.0 .or.
 410      >               hetnoe(lenoeu).eq.1 .or.
 411      >               hetnoe(lenoeu).eq.3 .or.
 412      >               hetnoe(lenoeu).eq.7 ) then
 413 cgn        write (ulsort,90002) 'lenoeu', lenoeu, ancnoe(lenoeu)
 414 cgn      write(*,90004) 'vap1ec(nuv,nnoeca(ancnoe(lenoeu)))',
 415 cgn     >                vap1ec(nuv,nnoeca(ancnoe(lenoeu)))
 416                   vap1ho(nuv,lenoeu)=vap1ec(nuv,nnoeca(ancnoe(lenoeu)))
 417                   profho(lenoeu) = 1
 418                 endif
 419  4111         continue
 420   411       continue
 421 c
 422           else
 423 c
 424 c 4.1.2. ==> avec profil : on a des valeurs sur les noeuds de listpr
 425 c
 426 cgn        write (ulsort,90002) 'profil, nbvapr', nbvapr
 427             do 412, nuv = 1, nbfop1
 428               do 4121, lenoeu = 1, nbnoto
 429                 if ( hetnoe(lenoeu).eq.0 .or.
 430      >               hetnoe(lenoeu).eq.1 .or.
 431      >               hetnoe(lenoeu).eq.3 .or.
 432      >               hetnoe(lenoeu).eq.7 ) then
 433                   iaux = prfcan(nnoeca(ancnoe(lenoeu)))
 434                   if ( iaux.gt.0 ) then
 435                     vap1ho(nuv,lenoeu) = vap1ec(nuv,iaux)
 436                     profho(lenoeu) = 1
 437                   endif
 438                 endif
 439  4121         continue
 440   412       continue
 441 c
 442           endif
 443 c
 444 c 4.2. ==> passage de degre 1 a degre 2
 445 c
 446         elseif ( nbfop2.ne.0 ) then
 447 c
 448 c          - un noeud isole a pour etat 0, invariable.
 449 c          - un noeud support de maille-point a pour etat 3.
 450 c          - un noeud d'une maille ignoree a pour etat 7, invariable.
 451 c          - un noeud P1 a pour etat 1.
 452 c          - un noeud P2 a pour etat 2.
 453 c Sont donc concernes les noeuds d'historique 0, 1, 3
 454 c
 455 c 4.2.1. ==> sans profil : on a des valeurs sur tous les noeuds
 456 c
 457           if ( nbvapr.le.0 ) then
 458 cgn          write (ulsort,90002) 'sans profil'
 459 c
 460             do 421, nuv = 1, nbfop2
 461               do 4211, lenoeu = 1, nbnoto
 462 cgn          write (ulsort,90002) 'lenoeu', lenoeu, hetnoe(lenoeu)
 463                 if ( hetnoe(lenoeu).eq.0 .or.
 464      >               hetnoe(lenoeu).eq.1 .or.
 465      >               hetnoe(lenoeu).eq.3 .or.
 466      >               hetnoe(lenoeu).eq.7 ) then
 467 cgn        write (ulsort,90002) 'lenoeu', lenoeu, nnoeca(lenoeu)
 468 cgn      write(*,90004) 'vap2ec(nuv,nnoeca(lenoeu))',
 469 cgn     >                vap2ec(nuv,nnoeca(lenoeu))
 470                   vap2ho(nuv,lenoeu)=vap2ec(nuv,nnoeca(lenoeu))
 471                   profho(lenoeu) = 1
 472                 endif
 473  4211         continue
 474   421       continue
 475 c
 476           else
 477 c
 478 c 4.2.2. ==> avec profil : on a des valeurs sur les noeuds de listpr
 479 c
 480 cgn        write (ulsort,90002) 'profil, nbvapr', nbvapr
 481             do 422, nuv = 1, nbfop2
 482               do 4221, lenoeu = 1, nbnoto
 483                 if ( hetnoe(lenoeu).eq.0 .or.
 484      >               hetnoe(lenoeu).eq.1 .or.
 485      >               hetnoe(lenoeu).eq.3 ) then
 486                   iaux = prfcan(nnoeca(ancnoe(lenoeu)))
 487                   if ( iaux.gt.0 ) then
 488                     vap2ho(nuv,lenoeu) = vap2ec(nuv,iaux)
 489                     profho(lenoeu) = 1
 490                   endif
 491                 endif
 492  4221         continue
 493   422       continue
 494 c
 495           endif
 496 c
 497 c 4.3. ==> erreur
 498 c
 499         else
 500 c
 501           codret = 43
 502 c
 503         endif
 504 c
 505 c====
 506 c 5. Cas inconnu
 507 c====
 508 c
 509       else
 510 c
 511         codret = 5
 512 c
 513       endif
 514 c
 515 c====
 516 c 6. la fin
 517 c====
 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