src/tool/Utilitaire/utniqu.F

   1       subroutine utniqu ( coonoe,
   2      >                    hetnoe, arenoe, famnoe,
   3      >                    hetare, somare, filare,
   4      >                    np2are,
   5      >                    nintri,
   6      >                    arequa, hetqua, filqua,
   7      >                    ninqua,
   8      >                    indnoe, nouvno, nouvar, nouvtr, nouvqu,
   9      >                    option,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c    UTilitaire - creation de Noeuds Internes
  32 c    --                       -      -
  33 c                 apres decoupages de QUadrangles
  34 c                                     --
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . coonoe . es  .nouvno*3. coordonnees des noeuds                     .
  40 c . hetnoe . es  . nouvno . historique de l'etat des noeuds            .
  41 c . arenoe . es  . nouvno . arete liee a un nouveau noeud              .
  42 c . famnoe . es  . nouvno . caracteristiques des noeuds                .
  43 c . hetare . e   . nouvar . historique de l'etat des aretes            .
  44 c . somare . e   .2*nouvar. numeros des extremites d'arete             .
  45 c . filare . e   . nouvar . premiere fille des aretes                  .
  46 c . np2are . e   . nouvar . numero des noeuds p2 milieux d'aretes      .
  47 c . nintri . es  . nouvtr . noeud interne au triangle                  .
  48 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  49 c . hetqua . e   . nouvqu . historique de l'etat des quadrangles       .
  50 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  51 c . ninqua . es  . nouvqu . noeud interne au quadrangle                .
  52 c . indnoe . es  . 1      . indice du dernier noeud cree               .
  53 c . nouvno . e   . 1      . nombre total de noeuds a examiner          .
  54 c . nouvar . e   . 1      . nombre total d'aretes a examiner           .
  55 c . nouvtr . e   . 1      . nombre total de triangles a examiner       .
  56 c . option . e   . 1      . 0 : decoupage standard                     .
  57 c .        .     .        . 1 : decoupage de conformite                .
  58 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  59 c . langue . e   .    1   . langue des messages                        .
  60 c .        .     .        . 1 : francais, 2 : anglais                  .
  61 c . codret . es  .    1   . code de retour des modules                 .
  62 c .        .     .        . 0 : pas de probleme                        .
  63 c ______________________________________________________________________
  64 c
  65 c====
  66 c 0. declarations et dimensionnement
  67 c====
  68 c
  69 c 0.1. ==> generalites
  70 c
  71       implicit none
  72       save
  73 c
  74 #include "fractb.h"
  75 #include "fractc.h"
  76 c
  77 c 0.2. ==> communs
  78 c
  79 #include "envca1.h"
  80 c
  81 c 0.3. ==> arguments
  82 c
  83       integer indnoe, nouvno, nouvar, nouvtr, nouvqu
  84       integer hetnoe(nouvno), arenoe(nouvno), famnoe(nouvno)
  85       integer hetare(nouvar), somare(2,nouvar), filare(nouvar)
  86       integer np2are(nouvar)
  87       integer nintri(nouvtr)
  88       integer arequa(nouvqu,4), hetqua(nouvqu), filqua(nouvqu)
  89       integer ninqua(nouvqu)
  90       integer option
  91 c
  92       double precision coonoe(nouvno,sdim)
  93 c
  94       integer ulsort, langue, codret
  95 c
  96 c 0.4. ==> variables locales
  97 c
  98       integer iaux
  99       integer lequad, lefils
 100       integer a1, a2, a3, a4
 101       integer sa1a2, sa2a3, sa3a4, sa4a1
 102       integer n1, n2, n3, n4
 103       integer iaux1, iaux2, iaux3
 104       integer etan, etanp1
 105       integer lesomm
 106       integer numdec
 107       integer ai, aj, ak, al
 108       integer afij, afil
 109       integer saiaj, sajak, sakal, salai
 110       integer ni
 111 c
 112 #include "impr03.h"
 113 c ______________________________________________________________________
 114 c
 115 c====
 116 c    creation des noeuds internes aux nouveaux quadrangles
 117 c    on remarque que cette technique permet de garantir qu'un noeud
 118 c    interne a toujours un numero superieur a ceux des autres noeuds
 119 c    du quadrangle
 120 c====
 121 c
 122       do 11 , lequad = 1, nouvqu
 123 c
 124 cgn      write (ulsort,90015) 'Quad', lequad, ' d''etat',hetqua(lequad)
 125         etanp1 = mod(hetqua(lequad),100)
 126 c
 127 c====
 128 c 1. Ce quadrangle vient d'etre coupe en 4 : raffinement standard
 129 c====
 130 c
 131         if ( option.eq.0 .and. etanp1.eq.4 ) then
 132 c
 133           etan = (hetqua(lequad)-etanp1)/100
 134 cgn        write (ulsort,90002) 'etan', etan
 135 c
 136           if ( etan.ne.4 .and. etan.ne.99 ) then
 137 cgn        write (ulsort,90015) 'Quadrangle', lequad, ' coupe en 4'
 138 c
 139 c 1.1. ==> on recupere ses sommets
 140 c        voir cmrdqu pour la convention
 141 c                      sa4a1   a4   sa3a4
 142 c                          ._________.
 143 c                          .         .
 144 c                          .         .
 145 c                        a1.         .a3
 146 c                          .         .
 147 c                          ._________.
 148 c                      sa1a2   a2   sa2a3
 149 c
 150             a1 = arequa(lequad,1)
 151             a2 = arequa(lequad,2)
 152             a3 = arequa(lequad,3)
 153             a4 = arequa(lequad,4)
 154 c
 155             call utsoqu ( somare, a1, a2, a3, a4,
 156      >                    sa1a2, sa2a3, sa3a4, sa4a1 )
 157 cgn      write (ulsort,90002) 'sommets du pere',sa1a2, sa2a3, sa3a4, sa4a1
 158 c
 159 c 1.2. ==> Le noeud central
 160 c
 161              lesomm = ninqua(lequad)
 162 cgn      write (ulsort,90002) 'lesomm',lesomm
 163 c
 164 c 1.3. ==> les noeuds milieux des aretes
 165 c
 166             n1 = np2are(a1)
 167             n2 = np2are(a2)
 168             n3 = np2are(a3)
 169             n4 = np2are(a4)
 170 cgn      write (ulsort,90002) 'noeuds milieux ',n1, n2, n3, n4
 171 c
 172 c 1.2. ==> creation pour les fils
 173 c
 174             lefils = filqua(lequad)
 175 c
 176             do 12 , iaux = 0, 3
 177 c
 178               if ( iaux.eq.0 ) then
 179                 iaux1 = sa4a1
 180                 iaux2 = n4
 181                 iaux3 = n1
 182               elseif ( iaux.eq.1 ) then
 183                 iaux1 = sa1a2
 184                 iaux2 = n1
 185                 iaux3 = n2
 186               elseif ( iaux.eq.2 ) then
 187                 iaux1 = sa2a3
 188                 iaux2 = n2
 189                 iaux3 = n3
 190               else
 191                 iaux1 = sa3a4
 192                 iaux2 = n3
 193                 iaux3 = n4
 194               endif
 195 c
 196               indnoe = indnoe + 1
 197 cgn        write (ulsort,90002) '==> Creation du noeud', indnoe
 198 cgn        write (ulsort,90002) '    base sur', iaux1, iaux2, iaux3, lesomm
 199               ninqua(lefils+iaux) = indnoe
 200 c
 201               if ( sdim.eq.2 ) then
 202                 coonoe(indnoe,1) = unsqu *
 203      >          ( coonoe(iaux1,1) + coonoe(iaux2,1) +
 204      >            coonoe(iaux3,1) + coonoe(lesomm,1) )
 205                 coonoe(indnoe,2) = unsqu *
 206      >          ( coonoe(iaux1,2) + coonoe(iaux2,2) +
 207      >            coonoe(iaux3,2) + coonoe(lesomm,2) )
 208               else
 209                 coonoe(indnoe,1) = unsqu *
 210      >          ( coonoe(iaux1,1) + coonoe(iaux2,1) +
 211      >            coonoe(iaux3,1) + coonoe(lesomm,1) )
 212                 coonoe(indnoe,2) = unsqu *
 213      >          ( coonoe(iaux1,2) + coonoe(iaux2,2) +
 214      >            coonoe(iaux3,2) + coonoe(lesomm,2) )
 215                 coonoe(indnoe,3) = unsqu *
 216      >          ( coonoe(iaux1,3) + coonoe(iaux2,3) +
 217      >            coonoe(iaux3,3) + coonoe(lesomm,3) )
 218               endif
 219               hetnoe(indnoe) = 54
 220               famnoe(indnoe) = 1
 221               arenoe(indnoe) = 0
 222 c
 223    12       continue
 224 c
 225           endif
 226 c
 227 c====
 228 c 2. Ce quadrangle vient d'etre coupe en 3 triangles : conformite
 229 c====
 230 c
 231         elseif ( option.eq.1 .and.
 232      >           ( etanp1.ge.31 .and. etanp1.le.34 ) ) then
 233 c
 234 cgn      write (ulsort,90015) 'Quadrangle', lequad, ' coupe en 3'
 235 c
 236 c 2.1. ==> determination des aretes et des sommets, relativement
 237 c          au decoupage de l'arete
 238 c        voir cmcdqu pour la convention
 239 c                   S4=sa4a1   a4   sa3a4=S3
 240 c                          ._________.
 241 c                          .         .
 242 c                          .         .
 243 c                        a1.         .a3
 244 c                          .         .
 245 c                          ._________.
 246 c                   S1=sa1a2   a2   sa2a3=S2
 247 c
 248             a1 = arequa(lequad,1)
 249             a2 = arequa(lequad,2)
 250             a3 = arequa(lequad,3)
 251             a4 = arequa(lequad,4)
 252 c
 253             call utcoq3 ( hetare, somare, filare, a1, a2, a3, a4,
 254      >                    numdec, ai, aj, ak, al, afij, afil,
 255      >                    saiaj, sajak, sakal, salai, ni,
 256      >                    ulsort, langue, codret )
 257 cgn      write (ulsort,90002) 'numdec', numdec,etanp1
 258 cgn      write (ulsort,90002) 'ni', ni
 259 c
 260             call utsoqu ( somare, a1, a2, a3, a4,
 261      >                    sa1a2, sa2a3, sa3a4, sa4a1 )
 262 cgn      write (ulsort,90002) 'sommets du pere',sa1a2, sa2a3, sa3a4, sa4a1
 263 c
 264 c 2.3. ==> creation pour les trois fils
 265 c
 266             lefils = filqua(lequad)
 267 cgn      write (ulsort,90002) 'lefils', lefils
 268 c
 269             do 23 , iaux = 0, 2
 270 c
 271               if ( iaux.eq.0 ) then
 272                 iaux1 = sajak
 273                 iaux2 = sakal
 274               elseif ( iaux.eq.1 ) then
 275                 iaux1 = saiaj
 276                 iaux2 = sajak
 277               else
 278                 iaux1 = salai
 279                 iaux2 = sakal
 280               endif
 281               indnoe = indnoe + 1
 282 cgn        write (ulsort,90002) '==> Creation du noeud', indnoe
 283 cgn        write (ulsort,90002) '    base sur', iaux1, iaux2, ni
 284               nintri(-lefils+iaux) = indnoe
 285 c
 286               if ( sdim.eq.2 ) then
 287                 coonoe(indnoe,1) = unstr *
 288      >          ( coonoe(iaux1,1) + coonoe(iaux2,1) + coonoe(ni,1) )
 289                 coonoe(indnoe,2) = unstr *
 290      >          ( coonoe(iaux1,2) + coonoe(iaux2,2) + coonoe(ni,2) )
 291               else
 292                 coonoe(indnoe,1) = unstr *
 293      >          ( coonoe(iaux1,1) + coonoe(iaux2,1) + coonoe(ni,1) )
 294                 coonoe(indnoe,2) = unstr *
 295      >          ( coonoe(iaux1,2) + coonoe(iaux2,2) + coonoe(ni,2) )
 296                 coonoe(indnoe,3) = unstr *
 297      >          ( coonoe(iaux1,3) + coonoe(iaux2,3) + coonoe(ni,3) )
 298               endif
 299               hetnoe(indnoe) = 54
 300               famnoe(indnoe) = 1
 301               arenoe(indnoe) = 0
 302 c
 303    23       continue
 304 c
 305         endif
 306 c
 307    11 continue
 308 c
 309       end