src/tool/Suivi_Frontiere/sffa02.F

   1       subroutine sffa02 ( nouvno, coopro,
   2      >                    lenoeu,
   3      >                    coonoe,
   4      >                    censph, raysph,
   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 02 - sphere
  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 . e   .  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 . censph . e   .  sdim  . centre de la sphere                        .
  37 c . raycyl . e   .    1   . rayon de la sphere                         .
  38 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  39 c . langue . e   .    1   . langue des messages                        .
  40 c .        .     .        . 1 : francais, 2 : anglais                  .
  41 c . codret . es  .    1   . code de retour des modules                 .
  42 c .        .     .        . 0 : pas de probleme                        .
  43 c .        .     .        . x : probleme                               .
  44 c ______________________________________________________________________
  45 c
  46 c====
  47 c 0. declarations et dimensionnement
  48 c====
  49 c
  50 c 0.1. ==> generalites
  51 c
  52       implicit none
  53       save
  54 c
  55       character*6 nompro
  56       parameter ( nompro = 'SFFA02' )
  57 c
  58 #include "nblang.h"
  59 c
  60 c 0.2. ==> communs
  61 c
  62 #include "envex1.h"
  63 #include "envca1.h"
  64 c
  65 c 0.3. ==> arguments
  66 c
  67       integer lenoeu
  68       integer nouvno
  69 c
  70       double precision coonoe(nouvno,sdim)
  71       double precision coopro(sdim)
  72       double precision censph(sdim), raysph
  73 c
  74       integer ulsort, langue, codret
  75 c
  76 c 0.4. ==> variables locales
  77 c
  78       integer iaux
  79 c
  80       double precision vectcm(3)
  81       double precision daux
  82 c
  83       integer nbmess
  84       parameter ( nbmess = 10 )
  85       character*80 texte(nblang,nbmess)
  86 c
  87 c 0.5. ==> initialisations
  88 c ______________________________________________________________________
  89 c
  90 c====
  91 c 1. initialisations
  92 c====
  93 c
  94 #include "impr01.h"
  95 c
  96 #ifdef _DEBUG_HOMARD_
  97       write (ulsort,texte(langue,1)) 'Entree', nompro
  98       call dmflsh (iaux)
  99 #endif
 100 c
 101 c 1.1. ==> messages
 102 c
 103       texte(1,4) = '(''Centre de la sphere :'',3g15.8)'
 104       texte(1,5) = '(''Rayon de la sphere  :'',g15.8)'
 105       texte(1,7) = '(''Noeud '',i8,'' :'',3g15.8)'
 106       texte(1,8) = '(''Coordonnees initiales :'',3g15.8)'
 107       texte(1,9) = '(''Coordonnees projetees :'',3g15.8)'
 108 c
 109       texte(2,4) = '(''Centre of the sphere:'',3g15.8)'
 110       texte(2,5) = '(''Radius of the sphere:'',g15.8)'
 111       texte(2,7) = '(''Node '',i8,'' :'',3g15.8)'
 112       texte(2,8) = '(''Initial coordonnates:'',3g15.8)'
 113       texte(2,9) = '(''Moved coordonnates  :'',3g15.8)'
 114 c
 115  1001 format(a,' :',3g15.8)
 116 c
 117 #ifdef _DEBUG_HOMARD_
 118       write (ulsort,texte(langue,4)) (censph(iaux), iaux = 1 , sdim)
 119       write (ulsort,texte(langue,5)) raysph
 120 #endif
 121 c
 122 c 1.2. ==> Tout va bien a priori
 123 c
 124       codret = 0
 125 c
 126 c====
 127 c 2. Projection
 128 c====
 129 c 2.1. ==> Vecteur CM
 130 c
 131 #ifdef _DEBUG_HOMARD_
 132       write (ulsort,texte(langue,7))
 133      >    lenoeu,(coonoe(lenoeu,iaux),iaux=1,sdim)
 134 #endif
 135 c
 136       do 21 , iaux = 1 , sdim
 137         vectcm(iaux) = coonoe(lenoeu,iaux) - censph(iaux)
 138    21 continue
 139 cgn      write (ulsort,1001) 'vectCM',(vectcm(iaux),iaux=1,sdim)
 140 c
 141 c 2.2. ==> Rayon pour le point M avant projection
 142 c
 143       daux = 0.d0
 144       do 22 , iaux = 1 , sdim
 145         daux = daux + vectcm(iaux)*vectcm(iaux)
 146    22 continue
 147       daux = sqrt(daux)
 148 cgn      write (ulsort,1001) 'DM',daux
 149 c
 150 c 2.3. ==> Vecteur CP = (Rayon cylindre/dist(CM)) * Vecteur CM
 151 c
 152       daux = raysph / daux
 153       do 23 , iaux = 1 , sdim
 154         vectcm(iaux) = daux *vectcm(iaux)
 155    23 continue
 156 cgn      write (ulsort,1001) 'vectCP',(vectcm(iaux),iaux=1,sdim)
 157 c
 158 c 2.4. ==> Coordonnees projetees : OmegaP = OmegaC + CP
 159 c
 160       do 24 , iaux = 1 , sdim
 161         coopro(iaux) = censph(iaux) + vectcm(iaux)
 162    24 continue
 163 #ifdef _DEBUG_HOMARD_
 164       write (ulsort,texte(langue,8)) (coonoe(lenoeu,iaux),iaux=1,sdim)
 165       write (ulsort,texte(langue,9)) (coopro(iaux), iaux = 1 , sdim)
 166 #endif
 167       daux = 0.d0
 168       do 222 , iaux = 1 , sdim
 169         daux = daux + (coopro(iaux)-censph(iaux))**2
 170   222 continue
 171       daux = sqrt(daux)
 172 cgn      write (ulsort,1001) 'DM',daux
 173 c
 174 c====
 175 c 3. la fin
 176 c====
 177 c
 178       if ( codret.ne.0 ) then
 179 c
 180 #include "envex2.h"
 181 c
 182       write (ulsort,texte(langue,1)) 'Sortie', nompro
 183       write (ulsort,texte(langue,2)) codret
 184 c
 185       endif
 186 c
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,texte(langue,1)) 'Sortie', nompro
 189       call dmflsh (iaux)
 190 #endif
 191 c
 192       end