src/tool/AP_Conversion/pcs1ar.F

   1       subroutine pcs1ar ( nbfop1, profho,
   2      >                    hetare, somare, filare,
   3      >                    vap1ho )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c    aPres adaptation - Conversion de Solution -
  25 c     -                 -             -
  26 c    interpolation p1 sur les noeuds lors du decoupage des ARetes
  27 c                   -                                      --
  28 c remarque : pcs1ar et pcsmar sont des clones
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . nbfop1 . e   .    1   . nombre de fonctions P1                     .
  34 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  35 c .        .     .        . 0 : l'entite est absente du profil         .
  36 c .        .     .        . 1 : l'entite est presente dans le profil   .
  37 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  38 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  39 c . filare . e   . nbarto . premiere fille des aretes                  .
  40 c . vap1ho . es  . nbfop1*. variables p1 numerotation homard           .
  41 c .        .     . nbnoto .                                            .
  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 "nombar.h"
  58 #include "nombno.h"
  59 c
  60 c 0.3. ==> arguments
  61 c
  62       integer nbfop1
  63       integer profho(nbnoto)
  64       integer hetare(nbarto), somare(2,nbarto), filare(nbarto)
  65 c
  66       double precision vap1ho(nbfop1,*)
  67 c
  68 c 0.4. ==> variables locales
  69 c
  70       integer larete, nuv, s1, s2, sm
  71 c
  72 cgn      double precision TTT(2)
  73 cgn      integer lglist
  74 cgn      parameter ( lglist = 15)
  75 cgn      integer listno(lglist)
  76 c ______________________________________________________________________
  77 c
  78 c====
  79 c 1. interpolation p1 pour les aretes qui viennent d'etre decoupees
  80 c====
  81 c
  82 cgn      listno( 1) = 16358
  83 cgn      listno( 2) = 14604
  84 cgn      listno( 3) = 16395
  85 cgn      listno( 4) = 17054
  86 cgn      listno( 5) = 16394
  87 cgn      listno( 6) = 17072
  88 cgn      listno( 7) = 22390
  89 cgn      listno( 8) = 22395
  90 cgn      listno( 9) = 22414
  91 cgn      listno(10) = 22393
  92 cgn      listno(11) = 22418
  93 cgn      listno(12) = 22415
  94 cgn      listno(13) = 22417
  95 cgn      listno(14) = 25003
  96 cgn      listno(15) = 25006
  97 cgn      ttt(1) = 1.d4
  98 cgn      ttt(2) = -1.d4
  99 cgn          print *,'Avant passage dans PCS1AR'
 100 cgn      do 888 , nuv=1,6
 101 cgn        s1 = listno(nuv)
 102 cgn        print 1786,s1,vap1ho(nbfop1,s1)
 103 cgn        ttt(1)=min(ttt(1),vap1ho(nbfop1,s1))
 104 cgn        ttt(2)=max(ttt(2),vap1ho(nbfop1,s1))
 105 cgn 888  continue
 106 cgn      print *,'minimum sur les 6 noeuds ',ttt(1)
 107 cgn      print *,'maximum sur les 6 noeuds ',ttt(2)
 108 cgn          write(*,*) 'nbfop1 =', nbfop1
 109 c
 110       if ( nbfop1.ne.0 ) then
 111 c
 112       do 1000, larete = 1, nbarto
 113 c
 114 cgn      if ( larete.eq.34918 .or. larete.eq.32464 ) then
 115 cgn      print 1789,larete,hetare(larete)
 116 cgn      print 1788,somare(1,larete),somare(2,larete)
 117 cgn      endif
 118 cgn 1789 format('Arete ',i6,' ==> etat = ',i3)
 119 cgn 1788 format('Sommet 1 : ',i6,' ; Sommet 2 : ',i6)
 120 cgn 1787 format('Sommet milieu : ',i6)
 121 cgn 1786 format('Valeur sur le sommet ',i6,' : ',g14.5)
 122 c
 123         if ( hetare(larete).eq.2 ) then
 124 c
 125 c         recuperation des sommets de l'arete
 126 c
 127           s1 = somare(1,larete)
 128           s2 = somare(2,larete)
 129 cgn          write(*,1784) s1, profho(s1)
 130 cgn          write(*,1784) s2, profho(s2)
 131 cgn 1784 format('Noeud',i3,' :',i2)
 132 c
 133           if ( profho(s1).eq.1 .and. profho(s2).eq.1 ) then
 134 c
 135 c           recuperation du nouveau noeud sommet
 136 c
 137             sm = somare(2,filare(larete))
 138             profho(sm) = 1
 139 cgn          write(*,1784) sm, profho(sm)
 140 cgn      if ( larete.eq.34918 .or. larete.eq.32464 ) then
 141 cgn      print 1787,sm
 142 cgn      print 1786,s1,vap1ho(nbfop1,s1)
 143 cgn      print 1786,s2,vap1ho(nbfop1,s2)
 144 cgn      endif
 145 c
 146 c           interpolation : interpolee (ui,i=1,2) = 1/2 (u1+u2)
 147 c
 148             do 11, nuv = 1, nbfop1
 149 c
 150               vap1ho(nuv,sm) = unsde
 151      >                       * ( vap1ho(nuv,s1) + vap1ho(nuv,s2) )
 152 c
 153    11       continue
 154 c
 155           endif
 156 c
 157         endif
 158 c
 159  1000 continue
 160 cgn      print 1786,22414,vap1ho(nbfop1,22414)
 161 cgn      print 1786,22390,vap1ho(nbfop1,22390)
 162 cgn      ttt(1) = 1.d4
 163 cgn      ttt(2) = -1.d4
 164 cgn          print *,'Apres passage dans PCS1AR'
 165 cgn      do 889 , nuv=1,13
 166 cgn        s1 = listno(nuv)
 167 cgn        print 1786,s1,vap1ho(nbfop1,s1)
 168 cgn        ttt(1)=min(ttt(1),vap1ho(nbfop1,s1))
 169 cgn        ttt(2)=max(ttt(2),vap1ho(nbfop1,s1))
 170 cgn 889  continue
 171 cgn      print *,'minimum sur les 13 noeuds ',ttt(1)
 172 cgn      print *,'maximum sur les 13 noeuds ',ttt(2)
 173 c
 174       endif
 175 c
 176       end