src/tool/AV_Conversion/vcme30.F

   1       subroutine vcme30 ( numfam,
   2      >                    nbfar0,
   3      >                    nofaar, cofaar,
   4      >                    nbfnoe, cfanoe,
   5      >                    nbfare, cfaare,
   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    aVant adaptation - Conversion de Maillage Extrude - phase 30
  28 c     -                 -             -        -               --
  29 c Determine les familles pour le lien face avant / face perpendiculaire
  30 c au cours de l'extrusion des noeuds
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . numfam . es  .    1   . numero de la derniere famille traitee      .
  36 c . nbfar0 . e   .  1     . nombre de familles pour le dimensionnement .
  37 c . nofaar . e   .  1     . nombre d'origine de familles d'aretes      .
  38 c . cofaar . e   . ncffar*. codes d'origine des familles d'aretes      .
  39 c .        .     . nofaar .                                            .
  40 c . nbfnoe .  e  .  1     . nombre de familles de noeuds enregistrees  .
  41 c . cfanoe . e   . nctfno*. codes des familles des noeuds              .
  42 c .        .     . nbfnoe .   1 : famille MED                          .
  43 c .        .     .        . si extrusion :                             .
  44 c .        .     .        .   2 : famille du noeud extrude             .
  45 c .        .     .        .   3 : famille de l'arete perpendiculaire   .
  46 c .        .     .        .   4 : position du noeud                    .
  47 c .        .     .        . si equivalence :                           .
  48 c .        .     .        . + l : appartenance a l'equivalence l       .
  49 c . nbfare .  es .  1     . nombre de familles d'aretes enregistrees   .
  50 c . cfaare .  es . nctfar*. codes des familles des aretes              .
  51 c .        .     . nbfare .   1 : famille MED                          .
  52 c .        .     .        .   2 : type de segment                      .
  53 c .        .     .        .   3 : orientation                          .
  54 c .        .     .        .   4 : famille d'orientation inverse        .
  55 c .        .     .        .   5 : numero de ligne de frontiere         .
  56 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  57 c .        .     .        . <= 0 si non concernee                      .
  58 c .        .     .        .   6 : famille frontiere active/inactive    .
  59 c .        .     .        .   7 : numero de surface de frontiere       .
  60 c .        .     .        . si extrusion :                             .
  61 c .        .     .        .   8 : famille de l'arete extrudee          .
  62 c .        .     .        .   9 : famille du quadrangle perpendiculaire.
  63 c .        .     .        .  10 : position de l'arete                  .
  64 c .        .     .        . si equivalence :                           .
  65 c .        .     .        . + l : appartenance a l'equivalence l       .
  66 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  67 c . langue . e   .    1   . langue des messages                        .
  68 c .        .     .        . 1 : francais, 2 : anglais                  .
  69 c . codret . e   .    1   . code de retour des modules                 .
  70 c .        .     .        . 0 : pas de probleme                        .
  71 c .        .     .        . 1 : probleme                               .
  72 c ______________________________________________________________________
  73 c
  74 c====
  75 c 0. declarations et dimensionnement
  76 c====
  77 c
  78 c 0.1. ==> generalites
  79 c
  80       implicit none
  81       save
  82 c
  83       character*6 nompro
  84       parameter ( nompro = 'VCME30' )
  85 c
  86 #include "nblang.h"
  87 #include "cofaar.h"
  88 #include "cofexn.h"
  89 #include "cofexa.h"
  90 c
  91 c 0.2. ==> communs
  92 c
  93 #include "envex1.h"
  94 #include "dicfen.h"
  95 c
  96 #include "impr02.h"
  97 c
  98 c 0.3. ==> arguments
  99 c
 100       integer numfam
 101       integer nbfar0
 102       integer nofaar, cofaar(ncffar,nofaar)
 103       integer nbfnoe, cfanoe(nctfno,nbfnoe)
 104       integer nbfare, cfaare(nctfar,nbfar0)
 105 c
 106       integer ulsort, langue, codret
 107 c
 108 c 0.4. ==> variables locales
 109 c
 110       integer iaux, jaux
 111       integer lafami, famdeb, famarx
 112       integer caract(100)
 113       integer nufaex
 114 c
 115       integer nbmess
 116       parameter ( nbmess = 10 )
 117       character*80 texte(nblang,nbmess)
 118 c
 119 c 0.5. ==> initialisations
 120 c ______________________________________________________________________
 121 c
 122 c====
 123 c 1. messages
 124 c====
 125 c
 126 #include "impr01.h"
 127 c
 128 #ifdef _DEBUG_HOMARD_
 129       write (ulsort,texte(langue,1)) 'Entree', nompro
 130       call dmflsh (iaux)
 131 #endif
 132 c
 133 #include "impr03.h"
 134 c
 135       texte(1,4) = '(''Familles d''''extrusion des '',a)'
 136 c
 137       texte(2,4) = '(''Description of families of extruded '',a)'
 138 c
 139 #ifdef _DEBUG_HOMARD_
 140       write (ulsort,texte(langue,4)) mess14(langue,3,1)
 141       write (ulsort,90002) 'numfam', numfam
 142       write (ulsort,90002) 'nctfno', nctfno
 143       write (ulsort,90002) 'cofxnx', cofxnx
 144       write (ulsort,90002) 'nctfar', nctfar
 145       write (ulsort,90002) 'ncffar', ncffar
 146       write (ulsort,90002) 'ncffar', ncffar
 147       write (ulsort,90002) 'nofaar', nofaar
 148       write (ulsort,90002) 'nbfar0', nbfar0
 149       write (ulsort,90002) 'nbfnoe', nbfnoe
 150 #endif
 151 c
 152 #ifdef _DEBUG_HOMARD_
 153       write (ulsort,*) 'Codes des familles des ',mess14(langue,3,1)
 154       do 5991 , iaux = 1 , nofaar
 155         write(ulsort,90012) 'Famille originale 3D', iaux,
 156      >                      (cofaar(jaux,iaux),jaux=1,ncffar)
 157  5991 continue
 158       do 5992 , iaux = 1 , nbfare
 159         write(ulsort,90022) 'Famille', iaux,
 160      >                      (cfaare(jaux,iaux),jaux=1,nctfar)
 161  5992 continue
 162       write (ulsort,*) 'Codes des familles des ',mess14(langue,3,-1)
 163       do 5993 , iaux = 1 , nbfnoe
 164         write(ulsort,90022) 'Famille', iaux,
 165      >                      (cfanoe(jaux,iaux),jaux=1,nctfno)
 166  5993 continue
 167 #endif
 168 c
 169       codret = 0
 170 c
 171 c====
 172 c 2. Parcours des familles de la face avant
 173 c====
 174 #ifdef _DEBUG_HOMARD_
 175       write (ulsort,90002) '2. parcours ; codret', codret
 176 #endif
 177 c
 178       famdeb = numfam + 1
 179       do 20 , lafami = famdeb, nbfnoe
 180 c
 181         famarx = cfanoe(cofxnx,lafami)
 182         if ( famarx.ne.0 ) then
 183 cgn      write (ulsort,90012)
 184 cgn     > '. Famille de '//mess14(langue,1,-1), lafami
 185 cgn      write (ulsort,90012)
 186 cgn     > '. Famille de '//mess14(langue,1,1), famarx
 187 c
 188 c 2.1. ==> On veut une famille d'aretes :
 189 c          . qui a les caracteristiques de celle du maillage 3D pour :
 190 c          . les valeurs pour l'extrusion sont nulles
 191 c          . la position doit etre perpendiculaire
 192 c
 193 c 2.1.1. ==> Les caracteristiques d'origine de la famille
 194 c
 195           do 211 , iaux = 1 , ncffar
 196             caract(iaux) = cofaar(iaux,famarx)
 197   211     continue
 198 c
 199 c 2.1.2. ==> On complete par les proprietes de l'extrusion bidon
 200 c
 201           do 212 , iaux = ncffar+1 , nctfar
 202             caract(iaux) = 0
 203   212     continue
 204 c
 205 c 2.1.3. ==> L'entite est perpendiculaire
 206 c
 207           caract(cofxap) = 2
 208 cgn      write (ulsort,90005) 'Caract.',(caract(iaux),iaux=1,nctfar)
 209 c
 210 c 2.2. ==> Recherche d'une situation analogue dans les familles,
 211 c
 212           do 221 , iaux = 1 , nbfare
 213 c
 214             do 2211 , jaux = 1 , ncffar
 215               if ( cfaare(jaux,iaux).ne.caract(jaux) ) then
 216                 goto 221
 217               endif
 218  2211       continue
 219 c
 220             nufaex = iaux
 221 cgn            write (ulsort,90002) '.. Correspond a la famille', nufaex
 222             goto 24
 223 c
 224   221     continue
 225 c
 226 c 2.3. ==> Creation d'une nouvelle famille
 227 c 2.3.1. ==> S'il n'y a plus de places, on sort et on recommencera
 228 c            pour cette famille
 229 c
 230           if ( nbfare.ge.nbfar0-1 ) then
 231 c
 232             numfam = lafami - 1
 233             nbfare = -nbfare
 234             goto 2999
 235 c
 236 c 2.3.2. ==> Creation
 237 c
 238           else
 239 c
 240 c 2.3.2.1. ==> La famille avec les memes caracteristiques
 241 c
 242             nbfare = nbfare + 1
 243 cgn         write (ulsort,90002) '.. Creation de la famille', nbfare
 244 cgn         write (ulsort,90005) '.. avec',(caract(iaux),iaux=1,nctfar)
 245             do 2321 , iaux = 1 , nctfar
 246               cfaare(iaux,nbfare) = caract(iaux)
 247  2321       continue
 248             nufaex = nbfare
 249 c
 250 c 2.3.2.2. ==> La famille avec l'orientation inverse
 251 c
 252             if ( cfaare(coorfa,nbfare).ne.0 ) then
 253 c
 254               nbfare = nbfare + 1
 255 cgn         write (ulsort,90015) '.. Creation de la famille', nbfare,
 256 cgn     >                        ' d''orientation opposee'
 257 c
 258               do 2322 , iaux = 1 , nctfar
 259                 cfaare(iaux,nbfare) = caract(iaux)
 260  2322         continue
 261               cfaare(coorfa,nbfare) = -cfaare(coorfa,nbfare-1)
 262               cfaare(cofifa,nbfare  ) = nbfare-1
 263               cfaare(cofifa,nbfare-1) = nbfare
 264 c
 265             else
 266 c
 267               cfaare(cofifa,nbfare) = nbfare
 268 c
 269             endif
 270 c
 271           endif
 272 c
 273 c 2.4. ==> Enregistrement de la nouvelle famille pour la famille
 274 c
 275    24     continue
 276 c
 277           cfanoe(cofxnx,lafami) = nufaex
 278 c
 279         endif
 280 c
 281    20 continue
 282 c
 283  2999 continue
 284 c
 285 #ifdef _DEBUG_HOMARD_
 286       write (ulsort,90002) 'A la sortie de '//nompro//', nbfare', nbfare
 287       write (ulsort,*) 'Codes des familles des ',mess14(langue,3,1)
 288       do 6992 , iaux = 1 , abs(nbfare)
 289         write(ulsort,90022) 'Famille', iaux,
 290      >                      (cfaare(jaux,iaux),jaux=1,nctfar)
 291  6992 continue
 292 #endif
 293 c
 294 c====
 295 c 3. la fin
 296 c====
 297 c
 298       if ( codret.ne.0 ) then
 299 c
 300 #include "envex2.h"
 301 c
 302       write (ulsort,texte(langue,1)) 'Sortie', nompro
 303       write (ulsort,texte(langue,2)) codret
 304 c
 305       endif
 306 c
 307 #ifdef _DEBUG_HOMARD_
 308       write (ulsort,texte(langue,1)) 'Sortie', nompro
 309       call dmflsh (iaux)
 310 #endif
 311 c
 312       end