src/tool/AP_Conversion/pcs2h3.F

   1       subroutine pcs2h3 ( nbfop2, profho, vap2ho,
   2      >                    somare, np2are,
   3      >                    listso, listno,
   4      >                    nbarhi, areint,
   5      >                    ulsort, langue, codret )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c    aPres adaptation - Conversion de Solution -
  27 c     -                 -             -
  28 c    interpolation p2/iso-p2 sur les noeuds - decoupage Hexaedres - 3
  29 c                   -                                   -           -
  30 c    Du centre aux sommets (selon 2 ou 3 aretes)
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . nbfop2 . e   .    1   . nombre de fonctions P2                     .
  36 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  37 c .        .     .        . 0 : l'entite est absente du profil         .
  38 c .        .     .        . 1 : l'entite est presente dans le profil   .
  39 c . vap2ho . es  . nbfop2*. variables p2 numerotation homard           .
  40 c .        .     . nbnoto .                                            .
  41 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  42 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  43 c . listso . e   .    8   . Liste des sommets ordonnes de l'hexaedre   .
  44 c . listno . e   .   12   . Liste des noeuds ordonnees de l'hexaedre   .
  45 c . nbarhi . e   .   1    . nombre d'aretes internes                   .
  46 c . areint . e   .   *    . numeros globaux des aretes internes        .
  47 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  48 c . langue . e   .    1   . langue des messages                        .
  49 c .        .     .        . 1 : francais, 2 : anglais                  .
  50 c . codret . es  .    1   . code de retour des modules                 .
  51 c .        .     .        . 0 : pas de probleme                        .
  52 c .        .     .        . 1 : probleme                               .
  53 c ______________________________________________________________________
  54 c
  55 c====
  56 c 0. declarations et dimensionnement
  57 c====
  58 c
  59 c 0.1. ==> generalites
  60 c
  61       implicit none
  62       save
  63 c
  64 #include "fracti.h"
  65 #include "fractj.h"
  66 c
  67       character*6 nompro
  68       parameter ( nompro = 'PCS2H3' )
  69 c
  70 #include "nblang.h"
  71 c
  72 c 0.2. ==> communs
  73 c
  74 #include "envex1.h"
  75 c
  76 #include "nombar.h"
  77 c
  78 c 0.3. ==> arguments
  79 c
  80       integer nbfop2
  81       integer profho(*)
  82       integer somare(2,nbarto), np2are(nbarto)
  83       integer listso(8), listno(12)
  84       integer nbarhi, areint(nbarhi)
  85 c
  86       double precision vap2ho(nbfop2,*)
  87 c
  88       integer ulsort, langue, codret
  89 c
  90 c 0.4. ==> variables locales
  91 c
  92       integer iaux
  93 cgn      integer jaux
  94       integer nusomm, larete
  95       integer listns(20)
  96       integer sm, nuv
  97       integer iaux1, iaux2, iaux3, iaux4, iaux5, iaux6
  98 c
  99       integer nbmess
 100       parameter ( nbmess = 100 )
 101       character*80 texte(nblang,nbmess)
 102 c
 103 c ______________________________________________________________________
 104 c
 105 #include "impr01.h"
 106 c
 107 #include "impr03.h"
 108 c
 109 cgn        write (ulsort,texte(langue,1)) 'Entree', nompro
 110 #ifdef _DEBUG_HOMARD_
 111       write (ulsort,90002) 'listso', listso
 112       write (ulsort,90002) 'listno  1-8', (listno(iaux),iaux=1,8)
 113       write (ulsort,90002) 'listno 9-12', (listno(iaux),iaux=9,12)
 114 #endif
 115 c
 116 c    On passe en revue tous les sommets
 117 c    Ils sont parcourus dans l'ordre de leur numerotation de reference
 118 c
 119       do 10 , nusomm = 1 , 8
 120 cgn      write(6,*) 'Dans pcs2h3, nusomm =',nusomm
 121 c
 122 c====
 123 c 1. Le sommet dont on part et ses plus proches voisins
 124 c====
 125 c
 126       iaux1 = nusomm
 127       if ( nusomm.eq.1 ) then
 128         iaux2 = 2
 129         iaux3 = 4
 130         iaux4 = 6
 131       elseif ( nusomm.eq.2 ) then
 132         iaux2 = 1
 133         iaux3 = 3
 134         iaux4 = 5
 135       elseif ( nusomm.eq.3 ) then
 136         iaux2 = 2
 137         iaux3 = 4
 138         iaux4 = 8
 139       elseif ( nusomm.eq.4 ) then
 140         iaux2 = 1
 141         iaux3 = 3
 142         iaux4 = 7
 143       elseif ( nusomm.eq.5 ) then
 144         iaux2 = 2
 145         iaux3 = 6
 146         iaux4 = 8
 147       elseif ( nusomm.eq.6 ) then
 148         iaux2 = 1
 149         iaux3 = 5
 150         iaux4 = 7
 151       elseif ( nusomm.eq.7 ) then
 152         iaux2 = 4
 153         iaux3 = 6
 154         iaux4 = 8
 155       else
 156         iaux2 = 3
 157         iaux3 = 5
 158         iaux4 = 7
 159       endif
 160 c
 161       listns(1) = listso(iaux1)
 162       listns(2) = listso(iaux2)
 163       listns(3) = listso(iaux3)
 164       listns(4) = listso(iaux4)
 165 c
 166 c====
 167 c 2. Le sommet oppose et ses plus proches voisins
 168 c====
 169 c
 170       iaux1 = 9-nusomm
 171       if ( nusomm.eq.1 ) then
 172         iaux2 = 3
 173         iaux3 = 5
 174         iaux4 = 7
 175       elseif ( nusomm.eq.2 ) then
 176         iaux2 = 4
 177         iaux3 = 6
 178         iaux4 = 8
 179       elseif ( nusomm.eq.3 ) then
 180         iaux2 = 1
 181         iaux3 = 5
 182         iaux4 = 7
 183       elseif ( nusomm.eq.4 ) then
 184         iaux2 = 2
 185         iaux3 = 6
 186         iaux4 = 8
 187       elseif ( nusomm.eq.5 ) then
 188         iaux2 = 1
 189         iaux3 = 3
 190         iaux4 = 7
 191       elseif ( nusomm.eq.6 ) then
 192         iaux2 = 2
 193         iaux3 = 4
 194         iaux4 = 8
 195       elseif ( nusomm.eq.7 ) then
 196         iaux2 = 1
 197         iaux3 = 3
 198         iaux4 = 5
 199       else
 200         iaux2 = 2
 201         iaux3 = 4
 202         iaux4 = 6
 203       endif
 204 c
 205       listns(8) = listso(iaux1)
 206       listns(5) = listso(iaux2)
 207       listns(6) = listso(iaux3)
 208       listns(7) = listso(iaux4)
 209 c
 210 c====
 211 c 3. Les noeuds milieux les plus proches
 212 c====
 213 c
 214       if ( nusomm.eq.1 ) then
 215         iaux1 = 1
 216         iaux2 = 2
 217         iaux3 = 5
 218       elseif ( nusomm.eq.2 ) then
 219         iaux1 = 1
 220         iaux2 = 3
 221         iaux3 = 6
 222       elseif ( nusomm.eq.3 ) then
 223         iaux1 = 3
 224         iaux2 = 4
 225         iaux3 = 8
 226       elseif ( nusomm.eq.4 ) then
 227         iaux1 = 2
 228         iaux2 = 4
 229         iaux3 = 7
 230       elseif ( nusomm.eq.5 ) then
 231         iaux1 = 6
 232         iaux2 = 9
 233         iaux3 = 11
 234       elseif ( nusomm.eq.6 ) then
 235         iaux1 = 5
 236         iaux2 = 9
 237         iaux3 = 10
 238       elseif ( nusomm.eq.7 ) then
 239         iaux1 = 7
 240         iaux2 = 10
 241         iaux3 = 12
 242       else
 243         iaux1 = 8
 244         iaux2 = 11
 245         iaux3 = 12
 246       endif
 247 c
 248       listns( 9) = listno(iaux1)
 249       listns(10) = listno(iaux2)
 250       listns(11) = listno(iaux3)
 251 c
 252 c====
 253 c 4. Les noeuds milieux intermediaires
 254 c====
 255 c
 256       if ( nusomm.eq.1 .or. nusomm.eq.8 ) then
 257         iaux1 = 3
 258         iaux2 = 6
 259         iaux3 = 9
 260         iaux4 = 10
 261         iaux5 = 7
 262         iaux6 = 4
 263       elseif ( nusomm.eq.2 .or. nusomm.eq.7 ) then
 264         iaux1 = 2
 265         iaux2 = 4
 266         iaux3 = 8
 267         iaux4 = 11
 268         iaux5 = 9
 269         iaux6 = 5
 270       elseif ( nusomm.eq.3 .or. nusomm.eq.6) then
 271         iaux1 = 1
 272         iaux2 = 2
 273         iaux3 = 7
 274         iaux4 = 12
 275         iaux5 = 11
 276         iaux6 = 6
 277       else
 278         iaux1 = 1
 279         iaux2 = 3
 280         iaux3 = 8
 281         iaux4 = 12
 282         iaux5 = 10
 283         iaux6 = 5
 284       endif
 285 c
 286       listns(12) = listno(iaux1)
 287       listns(13) = listno(iaux2)
 288       listns(14) = listno(iaux3)
 289       listns(15) = listno(iaux4)
 290       listns(16) = listno(iaux5)
 291       listns(17) = listno(iaux6)
 292 c
 293 c====
 294 c 5. Les noeuds milieux les plus eloignes
 295 c====
 296 c
 297       if ( nusomm.eq.1 ) then
 298         iaux1 = 8
 299         iaux2 = 11
 300         iaux3 = 12
 301       elseif ( nusomm.eq.2 ) then
 302         iaux1 = 7
 303         iaux2 = 10
 304         iaux3 = 12
 305       elseif ( nusomm.eq.3 ) then
 306         iaux1 = 5
 307         iaux2 = 9
 308         iaux3 = 10
 309       elseif ( nusomm.eq.4 ) then
 310         iaux1 = 6
 311         iaux2 = 9
 312         iaux3 = 11
 313       elseif ( nusomm.eq.5 ) then
 314         iaux1 = 2
 315         iaux2 = 4
 316         iaux3 = 7
 317       elseif ( nusomm.eq.6 ) then
 318         iaux1 = 3
 319         iaux2 = 4
 320         iaux3 = 8
 321       elseif ( nusomm.eq.7 ) then
 322         iaux1 = 1
 323         iaux2 = 3
 324         iaux3 = 6
 325       else
 326         iaux1 = 1
 327         iaux2 = 2
 328         iaux3 = 5
 329       endif
 330 c
 331       listns(18) = listno(iaux1)
 332       listns(19) = listno(iaux2)
 333       listns(20) = listno(iaux3)
 334 c
 335 c====
 336 c 6. L'arete concernee : celle des aretes internes qui demarrent
 337 c    sur le sommet en cours
 338 c====
 339 c
 340       do 62 , iaux = 1 , nbarhi
 341         larete = areint(iaux)
 342         if ( somare(1,larete).eq.listns(1) ) then
 343           sm = np2are(larete)
 344           goto 620
 345         endif
 346   62  continue
 347       write(ulsort,*) nompro//' - aucune arete interne ne correspond ?'
 348       codret = 62
 349 c
 350   620 continue
 351 c
 352 c====
 353 c 7. Interpolation
 354 c====
 355 c
 356       if ( codret.eq.0 ) then
 357 c
 358       profho(sm) = 1
 359 c
 360       do 71, nuv = 1 , nbfop2
 361 cgn          do 711 , jaux =1 ,20
 362 cgn        write(*,90014) listns(jaux), vap2ho(nuv,listns(jaux))
 363 cgn  711 continue
 364 c
 365         vap2ho(nuv,sm) = - v7s128 * ( vap2ho(nuv,listns(1))
 366      >                              + vap2ho(nuv,listns(2))
 367      >                              + vap2ho(nuv,listns(3))
 368      >                              + vap2ho(nuv,listns(4)) )
 369      >                   - qzs128 * ( vap2ho(nuv,listns(5))
 370      >                              + vap2ho(nuv,listns(6))
 371      >                              + vap2ho(nuv,listns(7)) )
 372      >                   - ses128 *   vap2ho(nuv,listns(8))
 373      >                   + v7st64 * ( vap2ho(nuv,listns(9))
 374      >                              + vap2ho(nuv,listns(10))
 375      >                              + vap2ho(nuv,listns(11)) )
 376      >                   + nfst64 * ( vap2ho(nuv,listns(12))
 377      >                              + vap2ho(nuv,listns(13))
 378      >                              + vap2ho(nuv,listns(14))
 379      >                              + vap2ho(nuv,listns(15))
 380      >                              + vap2ho(nuv,listns(16))
 381      >                              + vap2ho(nuv,listns(17)) )
 382      >                   + trst64 * ( vap2ho(nuv,listns(18))
 383      >                              + vap2ho(nuv,listns(19))
 384      >                              + vap2ho(nuv,listns(20)) )
 385 c
 386 cgn        write(*,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm)
 387    71 continue
 388 c
 389       endif
 390 c
 391    10 continue
 392 c
 393 c====
 394 c 8. La fin
 395 c====
 396 c
 397       if ( codret.ne.0 ) then
 398 c
 399 #include "envex2.h"
 400 c
 401       write (ulsort,texte(langue,1)) 'Sortie', nompro
 402       write (ulsort,texte(langue,2)) codret
 403 c
 404       endif
 405 c
 406 #ifdef _DEBUG_HOMARD_
 407       write (ulsort,texte(langue,1)) 'Sortie', nompro
 408       call dmflsh (iaux)
 409 #endif
 410 c
 411       end