src/tool/Utilitaire/utafqu.F

   1       subroutine utafqu ( somare, filare, a1, a2, a3, a4,
   2      >                    as1n1, as2n1,
   3      >                    as2n2, as3n2,
   4      >                    as3n3, as4n3,
   5      >                    as4n4, as1n4 )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c    UTilitaire - Aretes Filles - QUadrangle
  27 c    --           -      -        --
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . somare . e   .2*nbaret. numeros des extremites d'arete             .
  33 c . filare . e   . nbaret . premiere fille des aretes                  .
  34 c .a1,..,a4. e   . 1      . les numeros des aretes du quadrangle       .
  35 c . asinj  .  s  . 1      . arete entre le sommet i et le milieu de    .
  36 c .        .     .        . l'arete j du triangle                      .
  37 c ______________________________________________________________________
  38 c
  39 c====
  40 c 0. declarations et dimensionnement
  41 c====
  42 c
  43 c 0.1. ==> generalites
  44 c
  45       implicit none
  46       save
  47 c
  48 c 0.2. ==> communs
  49 c
  50 c 0.3. ==> arguments
  51 c
  52       integer somare(2,*), filare(*)
  53       integer a1, a2, a3, a4
  54       integer as1n1, as2n1
  55       integer as2n2, as3n2
  56       integer as3n3, as4n3
  57       integer as4n4, as1n4
  58 c
  59 c 0.4. ==> variables locales
  60 c
  61       integer s1, s2, s3, s4
  62       integer iaux
  63 c
  64 c====
  65 c 1. on cherche les numeros des sommets du quadrangle defini par ses
  66 c====
  67 c
  68 cgn10000 format('arete a',i1,' :',i2,' de',i3,' a',i3)
  69 cgn20000 format('sommet S',i1,' :',i3)
  70 cgn      write(1,10000) 1, a1, somare(1,a1), somare(2,a1)
  71 cgn      write(1,10000) 2, a2, somare(1,a2), somare(2,a2)
  72 cgn      write(1,10000) 3, a3, somare(1,a3), somare(2,a3)
  73 cgn      write(1,10000) 4, a4, somare(1,a4), somare(2,a4)
  74       call utsoqu ( somare, a1, a2, a3, a4,
  75      >              s2, s3, s4, s1 )
  76 cgn      write(1,20000) 1, s1
  77 cgn      write(1,20000) 2, s2
  78 cgn      write(1,20000) 3, s3
  79 cgn      write(1,20000) 4, s4
  80 c
  81 c====
  82 c 2. Filles des aretes
  83 c    On s'appuie sur le fait que le second noeud des aretes filles
  84 c    de ak est, par construction, le noeud au milieu de ak.
  85 c    Donc le premier est l'un des 2 noeuds de ak.
  86 c====
  87 c
  88 cgn30000 format('arete ',a5,' :',i3,' de',i3,' a',i3)
  89       iaux = filare(a1)
  90       if ( somare(1,iaux).eq.s1 ) then
  91         as1n1 = iaux
  92         as2n1 = iaux + 1
  93       else
  94         as1n1 = iaux + 1
  95         as2n1 = iaux
  96       endif
  97 cgn      write(1,30000) 'as2n1', as2n1, somare(1,as2n1), somare(2,as2n1)
  98 cgn      write(1,30000) 'as3n1', as3n1, somare(1,as3n1), somare(2,as3n1)
  99 c
 100       iaux = filare(a2)
 101       if ( somare(1,iaux).eq.s2 ) then
 102         as2n2 = iaux
 103         as3n2 = iaux + 1
 104       else
 105         as2n2 = iaux + 1
 106         as3n2 = iaux
 107       endif
 108 cgn      write(1,30000) 'as1n2', as1n2, somare(1,as1n2), somare(2,as1n2)
 109 cgn      write(1,30000) 'as3n2', as3n2, somare(1,as3n2), somare(2,as3n2)
 110 c
 111       iaux = filare(a3)
 112       if ( somare(1,iaux).eq.s3 ) then
 113         as3n3 = iaux
 114         as4n3 = iaux + 1
 115       else
 116         as3n3 = iaux + 1
 117         as4n3 = iaux
 118       endif
 119 cgn      write(1,30000) 'as1n3', as1n3, somare(1,as1n3), somare(2,as1n3)
 120 cgn      write(1,30000) 'as2n3', as2n3, somare(1,as2n3), somare(2,as2n3)
 121 c
 122       iaux = filare(a4)
 123       if ( somare(1,iaux).eq.s4 ) then
 124         as4n4 = iaux
 125         as1n4 = iaux + 1
 126       else
 127         as4n4 = iaux + 1
 128         as1n4 = iaux
 129       endif
 130 cgn      write(1,30000) 'as1n3', as1n3, somare(1,as1n3), somare(2,as1n3)
 131 cgn      write(1,30000) 'as2n3', as2n3, somare(1,as2n3), somare(2,as2n3)
 132 c
 133       end