src/tool/AP_Conversion/pcs3tr.F

   1       subroutine pcs3tr ( letria, prfcan,
   2      >                    somare, hettri, aretri,
   3      >                    nbanar, anfiar,
   4      >                    nareca,
   5      >                    afaire, typdec, etan, orient )
   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 p0 sur les aretes - phase 3
  29 c                                            -
  30 c    decoupage des TRiangles
  31 c                  --
  32 c ______________________________________________________________________
  33 c remarque : pcs0tr et pcs3tr sont des clones
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . letria . e   .    1   . triangle a examiner                        .
  39 c . prfcan . e   .   *    . En numero du calcul a l'iteration n :      .
  40 c .        .     .        . 0 : l'entite est absente du profil         .
  41 c .        .     .        . i : l'entite est au rang i dans le profil  .
  42 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  43 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  44 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  45 c . nareca . e   .   *    . nro des aretes dans le calcul en entree    .
  46 c . afaire .  s  .    1   . vrai si l'interpolation est a faire        .
  47 c . typdec .  s  .    1   . type de decoupage                          .
  48 c . etan   .  s  .    1   . ETAt du triangle a l'iteration N           .
  49 c . orient .  s  .    3   . orientation relative des aretes            .
  50 c ______________________________________________________________________
  51 c
  52 c====
  53 c 0. declarations et dimensionnement
  54 c====
  55 c
  56 c 0.1. ==> generalites
  57 c
  58       implicit none
  59       save
  60 c
  61 c 0.2. ==> communs
  62 c
  63 #include "nombtr.h"
  64 #include "nomber.h"
  65 c
  66 c 0.3. ==> arguments
  67 c
  68       integer letria
  69       integer prfcan(*)
  70       integer somare(2,*)
  71       integer hettri(nbtrto), aretri(nbtrto,3)
  72       integer typdec, etan
  73       integer nareca(rearto)
  74       integer nbanar, anfiar(nbanar)
  75       integer orient(3)
  76 c
  77       logical afaire
  78 c
  79 c 0.4. ==> variables locales
  80 c
  81       integer iaux, jaux, kaux
  82       integer lafill, lapfil
  83       integer listar(12), nbaret
  84 c
  85 c     etanp1 = ETAt du triangle a l'iteration N+1
  86 c
  87       integer etanp1
  88 c
  89 c 0.5. ==> initialisations
  90 c
  91 #include "impr03.h"
  92 c ______________________________________________________________________
  93 c
  94 c====
  95 c 1. Quel decoupage
  96 c====
  97 c
  98       etanp1 = mod(hettri(letria),10)
  99       etan   = (hettri(letria)-etanp1) / 10
 100 c
 101 cgn      write(1,90002) 'etan/etanp1', etan, etanp1
 102 c
 103 c     type de decoupage
 104 c          4 : en 4 standard
 105 c          6, 7, 8 : en 4 avec basculement de l'arete typdec-5
 106 c          1, 2, 3 : en 2 selon l'arete typdec
 107 c
 108       if ( ( etanp1.eq.4 ) .and.
 109      >     ( etan.eq.0 .or. etan.eq.1 .or.
 110      >       etan.eq.2 .or. etan.eq.3 ) ) then
 111         typdec = 4
 112 c
 113       elseif (
 114      >     ( etanp1.eq.6 .or. etanp1.eq.7 .or. etanp1.eq.8 ) .and.
 115      >     ( etan.eq.0 .or. etan.eq.1 .or.
 116      >       etan.eq.2 .or. etan.eq.3 ) ) then
 117         typdec = etanp1
 118 c
 119       elseif ( etanp1.eq.1 .or. etanp1.eq.2 .or. etanp1.eq.3 ) then
 120         typdec = etanp1
 121 c
 122       else
 123         typdec = 0
 124 c
 125       endif
 126 cgn      write(1,*) 'typdec',typdec
 127 c
 128 c====
 129 c 2. On verifie que le champ est present :
 130 c    . sur toutes les aretes du triangle, s'il etait actif
 131 c    . sur les aretes non coupee et sur les filles de l'arete coupee,
 132 c      s'il etait coupe en 2
 133 c====
 134 c
 135       if ( typdec.ne.0 ) then
 136 c
 137         afaire = .true.
 138 cgn        write(1,*) 'etan',etan
 139 c
 140         if ( etan.ne.5 ) then
 141 c
 142         nbaret = 0
 143         do 311  , iaux = 1 , 3
 144 c
 145 cgn        write(1,*) aretri(letria,iaux),nareca(aretri(letria,iaux))
 146           if ( iaux.eq.etan .or. etan.eq.4 ) then
 147             do 3111  , jaux = 0 , 1
 148               lafill = anfiar(aretri(letria,iaux)) + jaux
 149 cgn        write(1,*) '. lafill', lafill
 150               if ( anfiar(lafill).eq.0 ) then
 151                 nbaret = nbaret + 1
 152                 listar(nbaret) = nareca(lafill)
 153               else
 154                 do 31111  , kaux = 0 , 1
 155                   lapfil = anfiar(lafill) + kaux
 156 cgn        write(1,*) '.. lapfil', lapfil
 157                   nbaret = nbaret + 1
 158                   listar(nbaret) = nareca(lapfil)
 159 31111           continue
 160               endif
 161  3111       continue
 162           else
 163             nbaret = nbaret + 1
 164             listar(nbaret) = nareca(aretri(letria,iaux))
 165           endif
 166 c
 167   311   continue
 168 c
 169 cgn        write(1,*) 'listar :',(listar(iaux) , iaux = 1 , nbaret)
 170         do 312  , iaux = 1 , nbaret
 171 c
 172           if ( listar(iaux).eq.0 ) then
 173             afaire = .false.
 174             goto 32
 175           elseif ( prfcan(listar(iaux)).eq.0 ) then
 176             afaire = .false.
 177             goto 32
 178           endif
 179 c
 180   312   continue
 181 c
 182    32   continue
 183 c
 184         endif
 185 c
 186       else
 187 c
 188         afaire = .false.
 189 c
 190       endif
 191 cgn          write(1,*) 'afaire',afaire
 192 c
 193 c====
 194 c 3. Si c'est a faire, on recupere l'orientation relative des aretes
 195 c    dans le triangle
 196 c====
 197 c
 198       if ( afaire ) then
 199 c
 200         call utorat ( somare,
 201      >            aretri(letria,1), aretri(letria,2), aretri(letria,3),
 202      >            orient(1), orient(2), orient(3) )
 203 c
 204       endif
 205 c
 206       end