src/tool/Suivi_Frontiere/sffa03.F

   1       subroutine sffa03 ( nouvno, coopro,
   2      >                    lenoeu,
   3      >                    coonoe,
   4      >                    oricon, axecon, angcon,
   5      >                    ulsort, langue, codret )
   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   Suivi de Frontiere - Frontiere Analytique - type 03 - cone
  26 c   -        -           -         -                 --
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nouvno . e   .    1   . dernier numero de noeud cree               .
  32 c . coopro .   s .  sdim  . nouvelles coordonnees du noeud             .
  33 c . lenoeu . e   .    1   . noeud en cours d'examen                    .
  34 c . coonoe . e   . nouvno . coordonnees des noeuds                     .
  35 c .        .     . *sdim  .                                            .
  36 c . oricon . e   .  sdim  . origine de l'axe du cone                   .
  37 c . axecon . e   .  sdim  . axe du cone                                .
  38 c . angcon . e   .    1   . angle du cone en radian                    .
  39 c . oricon . e   .  sdim  . origine de l'axe du cone               .
  40 c . langue . e   .    1   . langue des messages                        .
  41 c .        .     .        . 1 : francais, 2 : anglais                  .
  42 c . codret . es  .    1   . code de retour des modules                 .
  43 c .        .     .        . 0 : pas de probleme                        .
  44 c .        .     .        . x : probleme                               .
  45 c ______________________________________________________________________
  46 c
  47 c====
  48 c 0. declarations et dimensionnement
  49 c====
  50 c
  51 c 0.1. ==> generalites
  52 c
  53       implicit none
  54       save
  55 c
  56       character*6 nompro
  57       parameter ( nompro = 'SFFA03' )
  58 c
  59 #include "nblang.h"
  60 #include "consta.h"
  61 c
  62 c 0.2. ==> communs
  63 c
  64 #include "envex1.h"
  65 #include "envca1.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       integer lenoeu
  70       integer nouvno
  71 c
  72       double precision coonoe(nouvno,sdim)
  73       double precision coopro(sdim)
  74       double precision oricon(sdim), axecon(sdim), angcon
  75 c
  76       integer ulsort, langue, codret
  77 c
  78 c 0.4. ==> variables locales
  79 c
  80       integer iaux
  81 c
  82       double precision vectoa(3)
  83       double precision daux1(3)
  84       double precision daux
  85       double precision rayon
  86 c
  87       integer nbmess
  88       parameter ( nbmess = 10 )
  89       character*80 texte(nblang,nbmess)
  90 c
  91 c 0.5. ==> initialisations
  92 c ______________________________________________________________________
  93 c
  94 c====
  95 c 1. initialisations
  96 c====
  97 c
  98 #include "impr01.h"
  99 c
 100 #ifdef _DEBUG_HOMARD_
 101       write (ulsort,texte(langue,1)) 'Entree', nompro
 102       call dmflsh (iaux)
 103 #endif
 104 c
 105 c 1.1. ==> messages
 106 c
 107       texte(1,4) = '(''Axe du cone     :'',3g16.9)'
 108       texte(1,5) = '(''Origine du cone :'',3g16.9)'
 109       texte(1,6) = '(''Angle du cone   :'',g16.9)'
 110       texte(1,7) = '(''Noeud '',i8,'' :'',3g16.9)'
 111       texte(1,8) = '(''Coordonnees initiales :'',3g16.9)'
 112       texte(1,9) = '(''Coordonnees projetees :'',3g16.9)'
 113 c
 114       texte(2,4) = '(''Axis of the cone  :'',3g16.9)'
 115       texte(2,5) = '(''Origin of the cone:'',3g16.9)'
 116       texte(2,6) = '(''Radius of the cone:'',g16.9)'
 117       texte(2,7) = '(''Node '',i8,'' :'',3g16.9)'
 118       texte(2,8) = '(''Initial coordonnates:'',3g16.9)'
 119       texte(2,9) = '(''Moved coordonnates  :'',3g16.9)'
 120 c
 121 cgn 1001 format(a,' :',3g16.9)
 122 c
 123 #ifdef _DEBUG_HOMARD_
 124       write (ulsort,texte(langue,4)) (axecon(iaux), iaux = 1 , sdim)
 125       write (ulsort,texte(langue,5)) (oricon(iaux), iaux = 1 , sdim)
 126       write (ulsort,texte(langue,6)) angcon*180.d0/pi
 127 #endif
 128 #ifdef _DEBUG_HOMARD_
 129       write (ulsort,texte(langue,7))
 130      > lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim)
 131 #endif
 132 c
 133 c 1.2. ==> Tout va bien a priori
 134 c
 135       codret = 0
 136 c
 137 c====
 138 c 2. Projection
 139 c====
 140 c 2.1. ==> daux = produit scalaire de OM avec l'axe
 141 c          daux = OM * axe = ( OmegaM - OmegaO ) * axe
 142 c
 143 c                             x  M
 144 c                          .  .
 145 c                       .     .
 146 c                    .        .
 147 c                 .           .
 148 c              .              .
 149 c       O   .                 . A
 150 c     ---x--------------------x------------------
 151 c        <-------------------->
 152 c              daux
 153 c
 154 cgn      write (ulsort,1001) 'vectcm',
 155 cgn     >((coonoe(lenoeu,iaux)-oricon(iaux)),iaux=1,sdim)
 156       daux = 0.d0
 157       do 21 , iaux = 1 , sdim
 158         daux = daux
 159      >       + (coonoe(lenoeu,iaux)-oricon(iaux)) * axecon(iaux)
 160    21 continue
 161 cgn      write (ulsort,1001) 'daux',daux
 162 c
 163 c 2.2. ==> Vecteur OA = daux * vect(axe)
 164 c
 165       do 22 , iaux = 1 , sdim
 166         vectoa(iaux) = daux * axecon(iaux)
 167    22 continue
 168 cgn      write (ulsort,1001) 'vectoa',(vectoa(iaux),iaux=1,sdim)
 169 c
 170 c 2.3. ==> Vecteur AM = OM - OA = ( OmegaM - OmegaO ) - OA
 171 c
 172       do 23 , iaux = 1 , sdim
 173         daux1(iaux) = coonoe(lenoeu,iaux)
 174      >              - oricon(iaux)
 175      >              - vectoa(iaux)
 176    23 continue
 177 cgn      write (ulsort,1001) 'vectAM',(daux1(iaux),iaux=1,sdim)
 178 c
 179 c 2.4. ==> Rayon du cone = tangente(angle)*OA
 180 c
 181       daux = 0.d0
 182       do 24 , iaux = 1 , sdim
 183         daux = daux + vectoa(iaux)**2
 184    24 continue
 185       rayon = tan(angcon)*sqrt(daux)
 186 c
 187 c 2.5. ==> Rayon pour le point M avant projection
 188 c
 189       daux = 0.d0
 190       do 25 , iaux = 1 , sdim
 191         daux = daux + daux1(iaux)*daux1(iaux)
 192    25 continue
 193       daux = sqrt(daux)
 194 cgn      write (ulsort,1001) 'AM',daux
 195 c
 196 c 2.6. ==> Vecteur AP = (Rayon cone/dist(AM)) * Vecteur AM
 197 c
 198       daux = rayon / daux
 199       do 26 , iaux = 1 , sdim
 200         daux1(iaux) = daux *daux1(iaux)
 201    26 continue
 202 cgn      write (ulsort,1001) 'vectAP',(daux1(iaux),iaux=1,sdim)
 203 c
 204 c 2.7. ==> Coordonnees projetees : OmegaP = OmegaC + CD + DP
 205 c
 206       do 27 , iaux = 1 , sdim
 207         coopro(iaux) = oricon(iaux) + vectoa(iaux) + daux1(iaux)
 208    27 continue
 209 #ifdef _DEBUG_HOMARD_
 210       write (ulsort,texte(langue,9)) (coopro(iaux), iaux = 1 , sdim)
 211 #endif
 212 c
 213 c====
 214 c 3. la fin
 215 c====
 216 c
 217       if ( codret.ne.0 ) then
 218 c
 219 #include "envex2.h"
 220 c
 221       write (ulsort,texte(langue,1)) 'Sortie', nompro
 222       write (ulsort,texte(langue,2)) codret
 223 c
 224       endif
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,texte(langue,1)) 'Sortie', nompro
 228       call dmflsh (iaux)
 229 #endif
 230 c
 231       end