src/tool/ES_Xfig/pppma5.F

   1       subroutine pppma5 ( dedans, wn,
   2      >                    nbnfa, vfa1, vfa2, vfa3, vfa4,
   3      >                    nbnfb, vfb1, vfb2, vfb3, vfb4,
   4      >                    ulsort, langue, codret )
   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     Post-Processeur - Preparation du MAillage - phase 4
  26 c     -    -            -              --               -
  27 c ______________________________________________________________________
  28 c
  29 c    On cherche a savoir si un point de la face B est dans la face A
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . dedans .  s  .   1    . vrai : un point de la face A est dans la   .
  35 c .        .     .        .        face B                              .
  36 c .        .     .        . faux : aucun point commun                  .
  37 c . wn     .   s .   2    . coordonnees du point inclus                .
  38 c . nbnfa  . e   .   1    . nombre de noeuds de la face A              .
  39 c . vfa1   . e   .   3    . coordonnees du sommet 1 de la face A       .
  40 c . vfa2   . e   .   3    . coordonnees du sommet 2 de la face A       .
  41 c . vfa3   . e   .   3    . coordonnees du sommet 3 de la face A       .
  42 c . vfa4   . e   .   3    . coordonnees du sommet 4 de la face A       .
  43 c . nbnfb  . e   .   1    . nombre de noeuds de la face B             .
  44 c . vfb1   . e   .   3    . coordonnees du sommet 1 de la face B       .
  45 c . vfb2   . e   .   3    . coordonnees du sommet 2 de la face B       .
  46 c . vfb3   . e   .   3    . coordonnees du sommet 3 de la face B       .
  47 c . vfb4   . e   .   3    . coordonnees du sommet 4 de la face B       .
  48 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  49 c . langue . e   .    1   . langue des messages                        .
  50 c .        .     .        . 1 : francais, 2 : anglais                  .
  51 c . codret .  s  .    1   . code de retour des modules                 .
  52 c .        .     .        . 0 : pas de 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       character*6 nompro
  65       parameter ( nompro = 'PPPMA5' )
  66 c
  67 #include "nblang.h"
  68 c
  69 c 0.2. ==> communs
  70 c
  71 #include "envex1.h"
  72 c
  73 c 0.3. ==> arguments
  74 c
  75       integer nbnfa, nbnfb
  76 c
  77       logical dedans
  78 c
  79       double precision wn(2)
  80       double precision vfa1(3), vfa2(3), vfa3(3), vfa4(3)
  81       double precision vfb1(3), vfb2(3), vfb3(3), vfb4(3)
  82 c
  83       integer ulsort, langue, codret
  84 c
  85 c 0.4. ==> variables locales
  86 c
  87       integer nbnx, nbny
  88       parameter ( nbnx = 30 , nbny = 30 )
  89       integer iaux, jaux
  90       integer jdeb, jfin
  91       integer typbor
  92 c
  93       double precision daux1, daux2
  94 c
  95       integer nbmess
  96       parameter ( nbmess = 10 )
  97       character*80 texte(nblang,nbmess)
  98 c
  99 c 0.5. ==> initialisations
 100 c
 101 c_______________________________________________________________________
 102 c
 103 c====
 104 c 1. prealables
 105 c====
 106 c
 107 #include "impr01.h"
 108 c
 109 #ifdef _DEBUG_HOMARD_
 110       write (ulsort,texte(langue,1)) 'Entree', nompro
 111       call dmflsh (iaux)
 112 #endif
 113 c
 114       codret = 0
 115 c
 116       typbor = 0
 117 c
 118  1796 format(a,6f12.5)
 119  1797 format(i5,' *',6f12.5)
 120  1798 format(i4,' :',i5,' *',3i4,' *',6f12.5)
 121  1799 format(i4,' :',i5,' *',4i4,' *',6f12.5)
 122 c
 123 c====
 124 c 2. Un sommet de la face B est-il dans la face A?
 125 c====
 126 c
 127       do 21 , iaux = 1 , nbnfb
 128 c
 129         if ( iaux.eq.1 ) then
 130           wn(1) = vfb1(1)
 131           wn(2) = vfb1(2)
 132         elseif ( iaux.eq.2 ) then
 133           wn(1) = vfb2(1)
 134           wn(2) = vfb2(2)
 135         elseif ( iaux.eq.3 ) then
 136           wn(1) = vfb3(1)
 137           wn(2) = vfb3(2)
 138         elseif ( iaux.eq.4 ) then
 139           wn(1) = vfb4(1)
 140           wn(2) = vfb4(2)
 141         endif
 142 c
 143         if ( nbnfa.eq.3 ) then
 144           call uttrn2 ( dedans, vfa1, vfa2, vfa3, wn, typbor )
 145         else
 146           call utqun2 ( dedans, vfa1, vfa2, vfa3, vfa4, wn, typbor )
 147         endif
 148 c
 149         if ( dedans ) then
 150 cgn          print * ,'....... Le',iaux,'-eme sommet est dedans'
 151           goto 44
 152         endif
 153 c
 154    21 continue
 155 c
 156 c====
 157 c 3. Un point interieur a la face B est-il dans la face A ?
 158 c    On cree des points par les methodes de maillages
 159 c    Evidemment il y a des trous, mais bon ...
 160 c====
 161 c 3.1 ==> La face B est un triangle
 162 c
 163       if ( nbnfb.eq.3 ) then
 164 c
 165         jfin = nbny-1
 166         do 31 , iaux = 1 ,  nbnx
 167 c
 168           daux1 = dble(iaux-1) / dble(nbnx-1)
 169           if ( iaux.eq.1 .or. iaux.eq.nbnx ) then
 170             jdeb = 2
 171           else
 172             jdeb = 1
 173           endif
 174 c
 175           do 311 , jaux = jdeb, jfin
 176 c
 177             daux2 = dble(jaux-1) / dble(nbny-1)
 178             call uttfi1 ( daux1, daux2, vfb1, vfb2, vfb3, wn )
 179 c
 180             if ( nbnfa.eq.3 ) then
 181               call uttrn2 ( dedans, vfa1, vfa2, vfa3, wn, typbor )
 182             else
 183               call utqun2 ( dedans, vfa1, vfa2, vfa3, vfa4, wn, typbor )
 184             endif
 185 c
 186             if ( dedans ) then
 187 cgn              print * ,'....... Un point interieur est dedans'
 188               goto 44
 189             endif
 190 c
 191   311     continue
 192 c
 193   31    continue
 194 c
 195 c 32. ==> La face B est un quadrangle
 196 c
 197       else
 198 c
 199         do 32 , iaux = 1 ,  nbnx
 200 c
 201           daux1 = dble(iaux-1) / dble(nbnx-1)
 202           if ( iaux.eq.1 .or. iaux.eq.nbnx ) then
 203             jdeb = 2
 204             jfin = nbny-1
 205           else
 206             jdeb = 1
 207             jfin = nbny
 208           endif
 209 c
 210           do 321 , jaux = jdeb, jfin
 211 c
 212             daux2 = dble(jaux-1) / dble(nbny-1)
 213             call uttfi2 ( daux1, daux2, vfb1, vfb2, vfb3, vfb4, wn )
 214 c
 215             if ( nbnfa.eq.3 ) then
 216               call uttrn2 ( dedans, vfa1, vfa2, vfa3, wn, typbor )
 217             else
 218               call utqun2 ( dedans, vfa1, vfa2, vfa3, vfa4, wn, typbor )
 219             endif
 220 c
 221             if ( dedans ) then
 222 cgn              print * ,'....... Un point interieur est dedans'
 223               goto 44
 224             endif
 225 c
 226   321     continue
 227 c
 228    32   continue
 229 c
 230       endif
 231 c
 232 c====
 233 c 4. OK ... ou pas
 234 c====
 235 c
 236    44 continue
 237 c
 238 c====
 239 c 5. la fin
 240 c====
 241 c
 242       if ( codret.ne.0 ) then
 243 c
 244 #include "envex2.h"
 245 c
 246       write (ulsort,texte(langue,1)) 'Sortie', nompro
 247       write (ulsort,texte(langue,2)) codret
 248 c
 249       endif
 250 c
 251 #ifdef _DEBUG_HOMARD_
 252       write (ulsort,texte(langue,1)) 'Sortie', nompro
 253       call dmflsh (iaux)
 254 #endif
 255 c
 256       end