src/tool/AP_Conversion/pcs1qu.F

   1       subroutine pcs1qu ( nbfop1, profho,
   2      >                    somare,
   3      >                    hetqua, arequa, filqua,
   4      >                    vap1ho )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    aPres adaptation - Conversion de Solution -
  26 c     -                 -             -
  27 c    interpolation p1 sur les noeuds lors du decoupage des QUadrangles
  28 c                   -                                      --
  29 c remarque : on devrait optimiser cela car si le quadrangle etait dans
  30 c            un etat de decoupage avec presence de noeud central, on
  31 c            recalcule une valeur qui est deja presente
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . nbfop1 . e   .    1   . nombre de fonctions P1                     .
  37 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  38 c .        .     .        . 0 : l'entite est absente du profil         .
  39 c .        .     .        . 1 : l'entite est presente dans le profil   .
  40 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  41 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  42 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  43 c . filqua . e   . nbquto . premier fils des quadrangles               .
  44 c . vap1ho . es  . nbfop1*. variables p1 numerotation homard           .
  45 c .        .     . nbnoto .                                            .
  46 c ______________________________________________________________________
  47 c
  48 c====
  49 c 0. declarations et dimensionnement
  50 c====
  51 c
  52 c 0.1. ==> generalites
  53 c
  54       implicit none
  55       save
  56 c
  57 #include "fractc.h"
  58 c
  59 c 0.2. ==> communs
  60 c
  61 #include "nombar.h"
  62 #include "nombno.h"
  63 #include "nombqu.h"
  64 c
  65 c 0.3. ==> arguments
  66 c
  67       integer nbfop1
  68       integer profho(nbnoto)
  69       integer somare(2,nbarto)
  70       integer hetqua(nbquto), arequa(nbquto,4), filqua(nbquto)
  71 c
  72       double precision vap1ho(nbfop1,*)
  73 c
  74 c 0.4. ==> variables locales
  75 c
  76       integer lequad
  77       integer a1, a2, a3, a4
  78       integer sa1a2, sa2a3, sa3a4, sa4a1
  79       integer sm, nuv
  80       integer iaux
  81 c
  82 cgn      double precision TTT(2)
  83 cgn      integer lglist
  84 cgn      parameter ( lglist = 15)
  85 cgn      integer listno(lglist)
  86 c ______________________________________________________________________
  87 c
  88 c====
  89 c 1. interpolation p1 pour les quadrangles qui viennent d'etre decoupes
  90 c    on a une valeur a mettre sur le noeud central. Ce noeud est
  91 c    au barycentre des 4 sommets du quadrangle pere. Donc on prend la
  92 c    moyenne de la fonction sur ces 4 noeuds.
  93 c====
  94 cgn      listno( 1) = 16358
  95 cgn      listno( 2) = 14604
  96 cgn      listno( 3) = 16395
  97 cgn      listno( 4) = 17054
  98 cgn      listno( 5) = 16394
  99 cgn      listno( 6) = 17072
 100 cgn      listno( 7) = 22390
 101 cgn      listno( 8) = 22395
 102 cgn      listno( 9) = 22414
 103 cgn      listno(10) = 22393
 104 cgn      listno(11) = 22418
 105 cgn      listno(12) = 22415
 106 cgn      listno(13) = 22417
 107 cgn      listno(14) = 25003
 108 cgn      listno(15) = 25006
 109 cgn      ttt(1) = 1.d4
 110 cgn      ttt(2) = -1.d4
 111 cgn          print *,'Avant passage dans PCS1QU'
 112 cgn      do 888 , nuv=1,13
 113 cgn        sm = listno(nuv)
 114 cgn        print 1786,sm,vap1ho(nbfop1,sm)
 115 cgn        ttt(1)=min(ttt(1),vap1ho(nbfop1,sm))
 116 cgn        ttt(2)=max(ttt(2),vap1ho(nbfop1,sm))
 117 cgn 888  continue
 118 cgn      print *,'minimum sur les 13 noeuds ',ttt(1)
 119 cgn      print *,'maximum sur les 13 noeuds ',ttt(2)
 120 c
 121       if ( nbfop1.ne.0 ) then
 122 c
 123       do 10 , lequad = 1, nbquto
 124 c
 125 cgn      if ( lequad.eq.17127 .or. lequad.eq.17198 ) then
 126 cgn      print 1789,lequad,hetqua(lequad)
 127 cgn      print 1788,arequa(lequad,1),arequa(lequad,2),
 128 cgn     >arequa(lequad,3),arequa(lequad,4)
 129 cgn      endif
 130 cgn 1789 format('Quadrangle ',i6,' ==> etat = ',i3)
 131 cgn 1788 format('Arete 1 : ',i6,' ; Arete 2 : ',i6,
 132 cgn     > ,' ; Arete 3 : ',i6,' ; Arete 4 : ',i6)
 133 cgn 1787 format('Sommet milieu : ',i6)
 134 cgn 1786 format('Valeur sur le sommet ',i6,' : ',g14.5)
 135 c
 136         iaux = mod(hetqua(lequad),100)
 137         if ( iaux.eq.4 .or. ( iaux.ge.41 .and. iaux.le.44 ) ) then
 138 c
 139 c         les aretes et les sommets du quadrangle
 140 c
 141           a1 = arequa(lequad,1)
 142           a2 = arequa(lequad,2)
 143           a3 = arequa(lequad,3)
 144           a4 = arequa(lequad,4)
 145 c
 146           call utsoqu ( somare, a1, a2, a3, a4,
 147      >                  sa1a2, sa2a3, sa3a4, sa4a1 )
 148 c
 149 c         tous les noeuds doivent etre dans le profil
 150 c
 151           if ( profho(sa1a2).eq.1 .and. profho(sa2a3).eq.1 .and.
 152      >         profho(sa3a4).eq.1 .and. profho(sa4a1).eq.1 ) then
 153 c
 154 c           recherche du noeud central
 155 c
 156             iaux = lequad
 157             call utnmqu ( iaux, sm,
 158      >                    somare, arequa, filqua )
 159 c
 160 c           le noeud central est a ajouter dans le profil
 161 c
 162             profho(sm) = 1
 163 c
 164 cgn      if ( lequad.eq.17127 .or. lequad.eq.17198 ) then
 165 cgn      print 1787,sm
 166 cgn      print 1786,sa1a2,vap1ho(nbfop1,sa1a2)
 167 cgn      print 1786,sa2a3,vap1ho(nbfop1,sa2a3)
 168 cgn      print 1786,sa3a4,vap1ho(nbfop1,sa3a4)
 169 cgn      print 1786,sa4a1,vap1ho(nbfop1,sa4a1)
 170 cgn      endif
 171 c
 172 c           interpolation = 1/4 (u1+u2+u3+u4)
 173 c
 174             do 101 , nuv = 1, nbfop1
 175 c
 176               vap1ho(nuv,sm) = unsqu * ( vap1ho(nuv,sa1a2)
 177      >                                 + vap1ho(nuv,sa2a3)
 178      >                                +  vap1ho(nuv,sa3a4)
 179      >                                +  vap1ho(nuv,sa4a1) )
 180 c
 181   101       continue
 182 c
 183           endif
 184 c
 185         endif
 186 c
 187    10 continue
 188 c
 189 cgn      print 1786,25003,vap1ho(nbfop1,25003)
 190 cgn      print 1786,25006,vap1ho(nbfop1,25006)
 191 cgn      ttt(1) = 1.d4
 192 cgn      ttt(2) = -1.d4
 193 cgn          print *,'Apres passage dans PCS1QU'
 194 cgn      do 889 , nuv=1,15
 195 cgn        sm = listno(nuv)
 196 cgn        print 1786,sm,vap1ho(nbfop1,sm)
 197 cgn        ttt(1)=min(ttt(1),vap1ho(nbfop1,sm))
 198 cgn        ttt(2)=max(ttt(2),vap1ho(nbfop1,sm))
 199 cgn 889  continue
 200 cgn      print *,'minimum sur les 15 noeuds ',ttt(1)
 201 cgn      print *,'maximum sur les 15 noeuds ',ttt(2)
 202 c
 203       endif
 204 c
 205       end