src/tool/Utilitaire/utsen2.F

   1       subroutine utsen2 ( memeco,
   2      >                    coose1, coose2, coo1, coo2, choix )
   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    UTilitaire - SEgment - Noeud - dimension 2
  24 c    --           --        -                 -
  25 c ______________________________________________________________________
  26 c
  27 c teste si les deux noeuds de coordonnees coo1 et coo2 sont du meme cote
  28 c par rapport au segment delimite par les sommets de coordonnees
  29 c coose1, coose2
  30 c programme en dimension 2
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . memeco .  s  . 1      . vrai ou faux selon que les noeuds sont du  .
  36 c .        .     .        . meme cote du segment ou non                .
  37 c . coose1 . e   .   2    . coordonnees du sommet 1 du segment         .
  38 c . coose2 . e   .   2    . coordonnees du sommet 2 du segment         .
  39 c . coo1   . e   .   2    . coordonnees du premier noeud               .
  40 c . coo2   . e   .   2    . coordonnees du second noeud                .
  41 c . choix  . e   .   1    . 1, si on accepte un noeud sur le segment   .
  42 c .        .     .        . 0, si on rejette un noeud sur le segment   .
  43 c .____________________________________________________________________.
  44 c
  45 c====
  46 c 0. declarations et dimensionnement
  47 c====
  48 c
  49 c 0.1. ==> generalites
  50 c
  51       implicit none
  52       save
  53 c
  54 cgn      character*6 nompro
  55 cgn      parameter ( nompro = 'UTSEN2' )
  56 c
  57 c 0.2. ==> communs
  58 c
  59 #include "precis.h"
  60 c
  61 c 0.3. ==> arguments
  62 c
  63       integer choix
  64 c
  65       double precision coose1(2), coose2(2), coo1(2), coo2(2)
  66 c
  67       logical memeco
  68 c
  69 c 0.4. ==> variables locales
  70 c
  71       double precision pvect1, pvect2
  72       double precision daux1
  73
  74 c 0.5. ==> initialisations
  75 c ______________________________________________________________________
  76 c
  77 c====
  78 c 1. initialisations
  79 c====
  80 c     pour analyser les cas ou le noeud est sur le segment, on utilise
  81 c     deux versions du test selon la demande.
  82 c     si on exclut le segment, il faut tester strictement positif
  83 c     si on l'accepte, on tolere une egalite a zero.
  84 c
  85       if ( choix.eq.0 ) then
  86         daux1 = epsima
  87       else
  88         daux1 = -epsima
  89       endif
  90 c
  91 c====
  92 c 2. Controle
  93 c    On compare les directions des produits vectoriels entre le
  94 c    vecteur directeur du segment et le vecteur entre un sommet et
  95 c    le noeud a tester.
  96 c    Pour pouvoir pieger les cas ou le noeud est sur le segment, on
  97 c    teste le caractere strictement positif ou positif du produit
  98 c    scalaire selon la demande.
  99 c====
 100 cgn 1000 format('. ',a,' :',3g13.5)
 101 cgn      write (1,1000) 'coose1 ', coose1(1), coose1(2)
 102 cgn      write (1,1000) 'coose2 ', coose2(1), coose2(2)
 103 cgn      write (1,1000) 'coo1', coo1(1), coo1(2)
 104 cgn      write (1,1000) 'coo2', coo2(1), coo2(2)
 105 c
 106 c 2.1. ==>  pvect1 represente la composante z du produit
 107 c           vectoriel s1s2 x s1n1
 108 c
 109       pvect1 = (coose2(1)-coose1(1)) * (coo1(2)-coose1(2))
 110      >       - (coose2(2)-coose1(2)) * (coo1(1)-coose1(1))
 111 c
 112 c 2.2. ==>  represente la composante z du produit
 113 c           vectoriel s1s2 x s1n2
 114 c
 115       pvect2 = (coose2(1)-coose1(1)) * (coo2(2)-coose1(2))
 116      >       - (coose2(2)-coose1(2)) * (coo2(1)-coose1(1))
 117 c
 118 cgn      write (1,1000) 'pvect1', pvect1
 119 cgn      write (1,1000) 'pvect2', pvect2
 120       if ( pvect1*pvect2.lt.daux1 ) then
 121         memeco = .false.
 122       else
 123         memeco = .true.
 124       endif
 125 c
 126       end