src/tool/AP_Conversion/pcsiar.F

   1       subroutine pcsiar ( nbfop2, profho, vap2ho,
   2      >                    hetare, somare, np2are, filare )
   3 c ______________________________________________________________________
   4 c
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c
  23 c    aPres adaptation - Conversion de Solution -
  24 c     -                 -             -
  25 c    interpolation iso-p2 sur les noeuds lors du decoupage des ARetes
  26 c                  -                                           --
  27 c remarque : pcs2ar et pcsiar sont des clones
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . nbfop2 . e   .    1   . nombre de fonctions P2                     .
  33 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  34 c .        .     .        . 0 : l'entite est absente du profil         .
  35 c .        .     .        . 1 : l'entite est presente dans le profil   .
  36 c . vap2ho . es  . nbfop2*. variables iso-p2 numerotation homard       .
  37 c .        .     . nbnoto .                                            .
  38 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  39 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  40 c . filare . e   . nbarto . premiere fille des aretes                  .
  41 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  42 c ______________________________________________________________________
  43 c
  44 c====
  45 c 0. declarations et dimensionnement
  46 c====
  47 c
  48 c 0.1. ==> generalites
  49 c
  50       implicit none
  51       save
  52 c
  53 #include "fracta.h"
  54 c
  55 c 0.2. ==> communs
  56 c
  57 #include "nombno.h"
  58 #include "nombar.h"
  59 c
  60 c 0.3. ==> arguments
  61 c
  62       integer nbfop2
  63       integer profho(nbnoto)
  64       integer hetare(nbarto), somare(2,nbarto), np2are(nbarto)
  65       integer filare(nbarto)
  66 c
  67       double precision vap2ho(nbfop2,*)
  68 c
  69 c 0.4. ==> variables locales
  70 c
  71       integer larete, a1, a2, sm, s1, s2, m1, m2, nuv
  72 c ______________________________________________________________________
  73 c
  74 c====
  75 c 1. interpolation pour les aretes qui viennent d'etre decoupees
  76 c====
  77 c
  78       do 10 , larete = 1, nbarto
  79 c
  80         if ( hetare(larete).eq.2 ) then
  81 c
  82 c         recuperation des aretes filles
  83 c
  84           a1 = filare(larete)
  85           a2 = a1 + 1
  86 c
  87 c         recuperation des sommets de l'arete
  88 c
  89           s1 = somare(1,larete)
  90           s2 = somare(2,larete)
  91 c
  92 c         recuperation du nouveau noeud sommet
  93 c
  94           sm = np2are(larete)
  95 c
  96           if ( profho(s1).eq.1 .and. profho(s2).eq.1 .and.
  97      >         profho(sm).eq.1 ) then
  98 c
  99 c         recuperation des nouveaux noeuds milieux
 100 c
 101             m1 = np2are(a1)
 102             m2 = np2are(a2)
 103             profho(m1) = 1
 104             profho(m2) = 1
 105 c
 106 c         interpolation p1 : interpolee (ui,i=1,2) = 1/2 (u1+u2)
 107 c
 108             do 11, nuv = 1, nbfop2
 109 c
 110               vap2ho(nuv,m1) =
 111      >        unsde * ( vap2ho(nuv,s1) + vap2ho(nuv,sm) )
 112               vap2ho(nuv,m2) =
 113      >        unsde * ( vap2ho(nuv,s2) + vap2ho(nuv,sm) )
 114 c
 115    11       continue
 116 c
 117           endif
 118 c
 119         endif
 120 c
 121    10 continue
 122 c
 123       end