src/tool/Utilitaire/utcorn.F

   1       subroutine utcorn ( lenoeu, lequad, larete,
   2      >                    coonoe,
   3      >                    somare, filare,
   4      >                    cfaare, famare,
   5      >                    arequa, filqua,
   6      >                    cfaqua, famqua,
   7      >                    ulsort, langue, codret)
   8 c ______________________________________________________________________
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c   UTilitaire - COntroles - Reprise d'un Noeud
  28 c   --           --          -            -
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . lenoeu . e   .   1    . noeud dont les coordonnees sont a changer  .
  34 c . lequad . e   .   1    . quadrangle dont lenoeu est centre (si >0)  .
  35 c . larete . e   .   1    . arete dont lenoeu est centre (si >0)       .
  36 c . coonoe . es  . nbnoto . coordonnees des noeuds                     .
  37 c .        .     . *sdim  .                                            .
  38 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  39 c . filare . e   . nbarto . premiere fille des aretes                  .
  40 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  41 c .        .     . nbfare .   1 : famille MED                          .
  42 c .        .     .        .   2 : type de segment                      .
  43 c .        .     .        .   3 : orientation                          .
  44 c .        .     .        .   4 : famille d'orientation inverse        .
  45 c .        .     .        .   5 : numero de ligne de frontiere         .
  46 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  47 c .        .     .        . <= 0 si non concernee                      .
  48 c .        .     .        .   6 : famille frontiere active/inactive    .
  49 c .        .     .        .   7 : numero de surface de frontiere       .
  50 c .        .     .        . + l : appartenance a l'equivalence l       .
  51 c . famare . es  . nbarto . famille des aretes                         .
  52 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  53 c . filqua . e   . nbquto . premier fils des quadrangles               .
  54 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  55 c .        .     . nbfqua .   1 : famille MED                          .
  56 c .        .     .        .   2 : type de quadrangle                   .
  57 c .        .     .        .   3 : numero de surface de frontiere       .
  58 c .        .     .        .   4 : famille des aretes internes apres raf.
  59 c .        .     .        .   5 : famille des triangles de conformite  .
  60 c .        .     .        .   6 : famille de sf active/inactive        .
  61 c .        .     .        . + l : appartenance a l'equivalence l       .
  62 c . famqua . e   . nbquto . famille des quadrangles                    .
  63 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  64 c . langue . e   .    1   . langue des messages                        .
  65 c .        .     .        . 1 : francais, 2 : anglais                  .
  66 c . codret . es  .    1   . code de retour des modules                 .
  67 c .        .     .        . 0 : pas de probleme                        .
  68 c .        .     .        . x : probleme                               .
  69 c ______________________________________________________________________
  70 c
  71 c====
  72 c 0. declarations et dimensionnement
  73 c====
  74 c
  75 c 0.1. ==> generalites
  76 c
  77       implicit none
  78       save
  79 c
  80       character*6 nompro
  81       parameter ( nompro = 'UTCORN' )
  82 c
  83 #include "nblang.h"
  84 #include "cofina.h"
  85 c
  86 c 0.2. ==> communs
  87 c
  88 #include "envex1.h"
  89 c
  90 #include "envca1.h"
  91 #include "dicfen.h"
  92 #include "nbfami.h"
  93 #include "nombno.h"
  94 #include "nombar.h"
  95 #include "nombqu.h"
  96 #include "impr02.h"
  97 c
  98 c 0.3. ==> arguments
  99 c
 100       integer lenoeu, lequad, larete
 101       integer somare(2,nbarto), filare(nbarto)
 102       integer cfaare(nctfar,nbfare), famare(nbarto)
 103       integer arequa(nbquto,4), filqua(nbquto)
 104       integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
 105 c
 106       double precision coonoe(nbnoto,sdim)
 107 c
 108       integer ulsort, langue, codret
 109 c
 110 c 0.4. ==> variables locales
 111 c
 112       integer iaux, jaux
 113 c
 114       integer noeud1, noeud2, noeud3, noeud4
 115 c
 116       integer nbmess
 117       parameter ( nbmess = 10 )
 118       character*80 texte(nblang,nbmess)
 119 c
 120 c 0.5. ==> initialisations
 121 c ______________________________________________________________________
 122 c
 123 c====
 124 c 1. initialisations
 125 c====
 126 c
 127 c 1.1. ==> les messages
 128 c
 129 #include "impr01.h"
 130 c
 131 #ifdef _DEBUG_HOMARD_
 132       write (ulsort,texte(langue,1)) 'Entree', nompro
 133       call dmflsh (iaux)
 134 #endif
 135 c
 136       texte(1,7) = '(''... Reprise du '',a,i10)'
 137       texte(1,8) = '(''... Au milieu du '',a,i10)'
 138 c
 139       texte(2,7) = '(''... Correction of '',a,i10)'
 140       texte(2,8) = '(''... Center of '',a,i10)'
 141 c
 142       codret = 0
 143 c
 144 #ifdef _DEBUG_HOMARD_
 145       write (ulsort,texte(langue,7)) mess14(langue,1,-1), lenoeu
 146 #endif
 147 c
 148 c====
 149 c 2. Noeud au milieu d'un quadrangle
 150 c====
 151 #ifdef _DEBUG_HOMARD_
 152       write (ulsort,*) '2. Noeud quadrangle ; codret = ', codret
 153 #endif
 154 c
 155       if ( lequad.gt.0 ) then
 156 c
 157 #ifdef _DEBUG_HOMARD_
 158       write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad
 159 #endif
 160 c
 161 c 2.1. ==> Retour au milieu
 162 c
 163         call utsoqu ( somare, arequa(lequad,1), arequa(lequad,2),
 164      >                arequa(lequad,3), arequa(lequad,4),
 165      >                noeud1, noeud2, noeud3, noeud4 )
 166 c
 167         do 21 , iaux = 1 , sdim
 168           coonoe(lenoeu,iaux) =
 169      >           0.25d0*(coonoe(noeud1,iaux)+coonoe(noeud2,iaux)
 170      >                  +coonoe(noeud3,iaux)+coonoe(noeud4,iaux))
 171    21 continue
 172 c
 173 c 2.2. ==> Le quadrangle ne doit plus etre considere en sf, ni ses fils
 174 c
 175         jaux = cfaqua(cosfin,famqua(lequad))
 176         famqua(lequad) = jaux
 177         do 22 , iaux = 0 , 3
 178           jaux = cfaqua(cosfin,famqua(filqua(lequad)+iaux))
 179           famqua(filqua(lequad)+iaux) = jaux
 180    22    continue
 181 c
 182       endif
 183 c
 184 c====
 185 c 3. Noeud au milieu d'une arete
 186 c====
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,*) '3. Noeud arete ; codret = ', codret
 189 #endif
 190 c
 191       if ( larete.gt.0 ) then
 192 c
 193 #ifdef _DEBUG_HOMARD_
 194       write (ulsort,texte(langue,8)) mess14(langue,1,1), larete
 195 #endif
 196 c
 197 c 3.1. ==> Retour au milieu
 198 c
 199         noeud1 = somare(1,larete)
 200         noeud2 = somare(2,larete)
 201         do 31 , iaux = 1 , sdim
 202           coonoe(lenoeu,iaux) =
 203      >                  0.5d0*(coonoe(noeud1,iaux)+coonoe(noeud2,iaux))
 204    31   continue
 205 c
 206 c 3.2. ==> L'arete ne doit plus etre consideree en sf ni ses filles
 207 c
 208         jaux = cfaare(cosfin,famare(larete))
 209         famare(larete) = jaux
 210         do 32 , iaux = 0 , 1
 211           jaux = cfaare(cosfin,famare(filare(larete)+iaux))
 212           famare(filare(larete)+iaux) = jaux
 213    32   continue
 214 c
 215       endif
 216 c
 217 c====
 218 c 4. La fin
 219 c====
 220 c
 221       if ( codret.ne.0 ) then
 222 c
 223 #include "envex2.h"
 224 c
 225       write (ulsort,texte(langue,1)) 'Sortie', nompro
 226       write (ulsort,texte(langue,2)) codret
 227 c
 228       endif
 229 c
 230 #ifdef _DEBUG_HOMARD_
 231       write (ulsort,texte(langue,1)) 'Sortie', nompro
 232       call dmflsh (iaux)
 233 #endif
 234 c
 235       end