src/tool/Utilitaire/utcoq5.F

   1       subroutine utcoq5 ( hetare, somare, filare, a1, a2, a3, a4,
   2      >                    numdec, ai, aj, ak, al,
   3      >                    aifj, aifl, ni,
   4      >                    ajfi, ajfk, nj,
   5      >                    saiaj, sajak, sakal, salai,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   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 - decoupage de COnformite d'un Quadrangle
  28 c    --                        --              -
  29 c                           en 3 quadrangles
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . hetare . e   . nbaret . historique de l'etat des aretes            .
  35 c . somare . e   .2*nbaret. numeros des extremites d'arete             .
  36 c . filare . e   . nbaret . premiere fille des aretes                  .
  37 c .a1,..,a4. e   . 1      . les numeros d'arete du quadrangle          .
  38 c . numdec .  s  . 1      . numero local de l'arete decoupee           .
  39 c .   ai   .  s  . 1      . l'arete du quadrangle qui est decoupee     .
  40 c .aj,ak,al.  s  . 1      . les 3 autres aretes dans l'ordre oriente   .
  41 c .  aifj  .  s  . 1      . fille de ai allant vers saiaj              .
  42 c .  aifl  .  s  . 1      . fille de ai allant vers salai              .
  43 c .   ni   .  s  . 1      . milieu de l'arete ai                       .
  44 c .  ajfi  .  s  . 1      . fille de aj allant vers saiaj              .
  45 c .  ajfk  .  s  . 1      . fille de aj allant vers sajak              .
  46 c .   nj   .  s  . 1      . milieu de l'arete aj                       .
  47 c . saiaj  .  s  . 1      . sommet commun aux aretes i et j            .
  48 c . sajak  .  s  . 1      . sommet commun aux aretes j et k            .
  49 c . sakal  .  s  . 1      . sommet commun aux aretes k et l            .
  50 c . salai  .  s  . 1      . sommet commun aux aretes l et i            .
  51 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  52 c . langue . e   .    1   . langue des messages                        .
  53 c .        .     .        . 1 : francais, 2 : anglais                  .
  54 c . codret . es  .    1   . code de retour des modules                 .
  55 c .        .     .        . 0 : pas de probleme                        .
  56 c ______________________________________________________________________
  57 c
  58 c       saiaj         aifj       ai/ni       aifl         salai
  59 c           ._____________________________________________.
  60 c           .                      .                      .
  61 c           .                      .                      .
  62 c           .                      .                      .
  63 c           .                      .anin0                 .
  64 c      ajfi .         nq1          .                      .
  65 c           .                      .                      .
  66 c           .                      .                      .
  67 c           .                      .                      .
  68 c           .        anjn0         .                      .
  69 c     aj/nj .----------------------.n0         nq3        . al
  70 c           .                        .                    .
  71 c           .                          .                  .
  72 c           .                            .                .
  73 c           .                              .              .
  74 c      ajfk .           nq2                  .            .
  75 c           .                           ankln0 .          .
  76 c           .                                    .        .
  77 c           .                                      .      .
  78 c           .                                        .    .
  79 c           ._____________________________________________.
  80 c       sajak                     ak                      sakal
  81 c
  82 c====
  83 c 0. declarations et dimensionnement
  84 c====
  85 c
  86 c 0.1. ==> generalites
  87 c
  88       implicit none
  89       save
  90 c
  91       character*6 nompro
  92       parameter ( nompro = 'UTCOQ5' )
  93 c
  94 #include "nblang.h"
  95 c
  96 c 0.2. ==> communs
  97 c
  98 #include "envex1.h"
  99 c
 100 #include "ope1a4.h"
 101 c
 102 c 0.3. ==> arguments
 103 c
 104       integer hetare(*), somare(2,*), filare(*)
 105       integer numdec
 106       integer a1, a2, a3, a4
 107       integer ai, aj, ak, al
 108       integer aifj, aifl, ni
 109       integer ajfi, ajfk, nj
 110       integer saiaj, sajak, sakal, salai
 111 c
 112       integer ulsort, langue, codret
 113 c
 114 c 0.4. ==> variables locales
 115 c
 116       integer arete(4)
 117       integer iaux, jaux, kaux
 118 c
 119       integer nbmess
 120       parameter ( nbmess = 10 )
 121       character*80 texte(nblang,nbmess)
 122 c 0.5. ==> initialisations
 123 c ______________________________________________________________________
 124 c
 125 c====
 126 c 1. messages
 127 c====
 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,10) ='(''Impossible de trouver l''''arete coupee.''))'
 137 c
 138       texte(2,10) ='(''Cut edge cannot be found.'')'
 139 c
 140       codret = 0
 141 c
 142 c====
 143 c 2. recherche du numero local de la premiere arete coupee
 144 c====
 145 c
 146       arete(1) = a1
 147       arete(2) = a2
 148       arete(3) = a3
 149       arete(4) = a4
 150 cgn      write(ulsort,*) a1,hetare(a1)
 151 cgn      write(ulsort,*) a2,hetare(a2)
 152 cgn      write(ulsort,*) a3,hetare(a3)
 153 cgn      write(ulsort,*) a4,hetare(a4)
 154 c
 155       jaux = 0
 156       kaux = 0
 157       do 20 , iaux = 1 , 4
 158         if ( mod(hetare(arete(iaux)),10).eq.2 ) then
 159           if ( jaux.eq.0 ) then
 160             jaux = iaux
 161           else
 162             kaux = iaux
 163           endif
 164         endif
 165   20  continue
 166 c
 167 cgn      write (ulsort,*) jaux, kaux
 168       if ( kaux.eq.0 ) then
 169         write (ulsort,texte(langue,10))
 170         codret = 1
 171       elseif ( jaux.eq.1 .and. kaux.eq.4 ) then
 172         numdec = 4
 173       else
 174         numdec = jaux
 175       endif
 176 c
 177 c====
 178 c 3. les numeros globaux des noeuds et des aretes
 179 c====
 180 c
 181       if ( codret.eq.0 ) then
 182 c
 183 c 3.1. ==> la premiere arete coupee
 184 c
 185       ai = arete(numdec)
 186 c
 187 c 3.2. ==> les autres aretes sont dans le meme ordre de rotation
 188 c
 189       iaux = per1a4(1,numdec)
 190       aj = arete(iaux)
 191 c
 192       iaux = per1a4(1,iaux)
 193       ak = arete(iaux)
 194 c
 195       iaux = per1a4(1,iaux)
 196       al = arete(iaux)
 197 c
 198 c 3.3. ==> les sommets du quadrangle
 199 c
 200       call utsoqu ( somare, ai, aj, ak, al,
 201      >              saiaj, sajak, sakal, salai )
 202 c
 203 c 3.4. ==> le decoupage de l'arete ai
 204 c
 205       iaux = filare(ai)
 206       if ( somare(1,iaux).eq.saiaj ) then
 207         aifj = iaux
 208         aifl = iaux + 1
 209       else
 210         aifj = iaux + 1
 211         aifl = iaux
 212       endif
 213 c
 214       ni = somare(2,aifj)
 215 c
 216 c 3.5. ==> le decoupage de l'arete aj
 217 c
 218       iaux = filare(aj)
 219       if ( somare(1,iaux).eq.saiaj ) then
 220         ajfi = iaux
 221         ajfk = iaux + 1
 222       else
 223         ajfi = iaux + 1
 224         ajfk = iaux
 225       endif
 226 c
 227       nj = somare(2,ajfi)
 228 c
 229       endif
 230 c
 231 c====
 232 c 4. la fin
 233 c====
 234 c
 235       if ( codret.ne.0 ) then
 236 c
 237 #include "envex2.h"
 238 c
 239       write (ulsort,texte(langue,1)) 'Sortie', nompro
 240       write (ulsort,texte(langue,2)) codret
 241 c
 242       endif
 243 c
 244 #ifdef _DEBUG_HOMARD_
 245       write (ulsort,texte(langue,1)) 'Sortie', nompro
 246       call dmflsh (iaux)
 247 #endif
 248 c
 249       end