src/tool/AV_Conversion/vccfcf.F

   1       subroutine vccfcf ( typdep, nctfde, nbfdem, nbfdep,
   2      >                    typfin, nctffi, nbffim, nbffin, ncfffi,
   3      >                    cofafd,
   4      >                    cfadep, cfafin,
   5      >                    eddep1, edfin1,
   6      >                    eddep2, edfin2,
   7      >                    eddep3, edfin3,
   8      >                    tabaux,
   9      >                    ulsort, langue, codret )
  10 c ______________________________________________________________________
  11 c
  12 c                             H O M A R D
  13 c
  14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  15 c
  16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  17 c aupres des huissiers de justice Simart et Lavoir a Clamart
  18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  19 c aupres des huissiers de justice
  20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  21 c
  22 c    HOMARD est une marque deposee d'Electricite de France
  23 c
  24 c Copyright EDF 1996
  25 c Copyright EDF 1998
  26 c Copyright EDF 2002
  27 c Copyright EDF 2020
  28 c ______________________________________________________________________
  29 c
  30 c    aVant adaptation - Creation des Familles
  31 c                       -            -
  32 c                     - gestion de la ConFormite
  33 c                                     -  -
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . typdep . e   .   1    . type de l'entite de depart                 .
  39 c . nctfde . e   .   1    . nombre de codes pour les familles de depart.
  40 c . nbfdem . e   .   1    . nombre de familles de depart au maximum    .
  41 c . nbfdep . e   .   1    . nombre de familles de depart               .
  42 c . typfin . e   .   1    . type de l'entite finale                    .
  43 c . nctffi . e   .   1    . nombre de codes pour les familles finales  .
  44 c . nbffim . e   .   1    . nombre de familles finales au maximum      .
  45 c . nbffin . e   .   1    . nombre de familles finales                 .
  46 c . ncfffi . e   .   1    . nombre fige de carac. de familles finales  .
  47 c . cofafd . e   .   1    . code depart contenant la famille d'arrivee .
  48 c . cfadep . e   . nctfde*. codes des familles des depart              .
  49 c .        .     . nbfdep .   1 : famille MED                          .
  50 c .        .     .        .   2 : type                                 .
  51 c .        .     .        . si quadrangle :                            .
  52 c .        .     .        .   3 : numero de surface de frontiere       .
  53 c .        .     .        .   4 : famille des aretes internes apres raf.
  54 c .        .     .        .   5 : famille des triangles de conformite  .
  55 c .        .     .        .   6 : famille de sf active/inactive        .
  56 c .        .     .        . + l : appartenance a l'equivalence l       .
  57 c .        .     .        . si hexaedre ou pentaedre :                 .
  58 c .        .     .        .   3 : famille des tetraedres de conformite .
  59 c .        .     .        .   4 : famille des pyramides de conformite  .
  60 c . cfafin . e   . nctffi*. codes des familles finales                 .
  61 c .        .     . nbffim .   1 : famille MED                          .
  62 c .        .     .        .   2 : type                                 .
  63 c .        .     .        . si triangle :                              .
  64 c .        .     .        .   3 : numero de surface de frontiere       .
  65 c .        .     .        .   4 : famille des aretes internes apres raf.
  66 c .        .     .        . + l : appartenance a l'equivalence l       .
  67 c .        .     .        . si tetraedre ou pyramide :                 .
  68 c . eddep1 . e   .   1    . type med numero 1 au depart                .
  69 c . edfin1 . e   .   1    . type med numero 1 au final                 .
  70 c . eddep2 . e   .   1    . type med numero 2 au depart                .
  71 c . edfin2 . e   .   1    . type med numero 2 au final                 .
  72 c . eddep3 . e   .   1    . type med numero 3 au depart                .
  73 c . edfin3 . e   .   1    . type med numero 3 au final                 .
  74 c . tabaux .  a  . nctffi . tableau auxiliaire                         .
  75 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  76 c . langue . e   .    1   . langue des messages                        .
  77 c .        .     .        . 1 : francais, 2 : anglais                  .
  78 c . codret . es  .    1   . code de retour des modules                 .
  79 c .        .     .        . 0 : pas de probleme                        .
  80 c .        .     .        . 1 : probleme                               .
  81 c ______________________________________________________________________
  82 c
  83 c====
  84 c 0. declarations et dimensionnement
  85 c====
  86 c
  87 c 0.1. ==> generalites
  88 c
  89       implicit none
  90       save
  91 c
  92       character*6 nompro
  93       parameter ( nompro = 'VCCFCF' )
  94 c
  95 #include "nblang.h"
  96 c
  97 #include "coftex.h"
  98 #include "cofatq.h"
  99 c
 100 c 0.2. ==> communs
 101 c
 102 #include "envex1.h"
 103 c
 104 #include "impr02.h"
 105 c
 106 c 0.3. ==> arguments
 107 c
 108       integer typdep, nctfde, nbfdem, nbfdep
 109       integer typfin, nctffi, nbffim, nbffin, ncfffi
 110       integer cofafd
 111       integer cfadep(nctfde,nbfdem)
 112       integer cfafin(nctffi,nbffim)
 113       integer eddep1, edfin1
 114       integer eddep2, edfin2
 115       integer eddep3, edfin3
 116       integer tabaux(nctffi)
 117 c
 118       integer ulsort, langue, codret
 119 c
 120 c 0.4. ==> variables locales
 121 c
 122       integer iaux, jaux
 123       integer nufdep, nucode
 124 c
 125       integer nbmess
 126       parameter ( nbmess = 10 )
 127       character*80 texte(nblang,nbmess)
 128 c
 129 c 0.5. ==> initialisations
 130 c ______________________________________________________________________
 131 c
 132 c====
 133 c 1. initialisations
 134 c====
 135 c
 136 #include "impr01.h"
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139       write (ulsort,texte(langue,1)) 'Entree', nompro
 140       call dmflsh (iaux)
 141 #endif
 142 c
 143       texte(1,4) = '(a14,'' : nombre de familles :'',i8)'
 144       texte(1,5) = '(''. Creation de la famille '',i8,/)'
 145       texte(1,6) = '(''Ce nombre est superieur au maximum :'',i8)'
 146       texte(1,7) = '(''Modifier les programmes UTINCG et/ou VCCFAM'')'
 147 c
 148       texte(2,4) = '(a14,'' : number of families :'',i8)'
 149       texte(2,5) = '(''. Creation of family '',i8,/)'
 150       texte(2,6) = '(''This number is greater than maximum:'',i8)'
 151       texte(2,7) = '(''Modify the programs UTINCG and/or VCCFAM'')'
 152 c
 153       codret = 0
 154 c
 155 #include "impr03.h"
 156 c
 157 #ifdef _DEBUG_HOMARD_
 158       write (ulsort,texte(langue,4)) mess14(langue,4,typdep), nbfdep
 159       write (ulsort,texte(langue,4)) mess14(langue,4,typfin), nbffin
 160 #endif
 161 c
 162 c====
 163 c 2. La famille libre de depart est liee a la famille libre d'arrivee
 164 c====
 165 c
 166       cfadep(cofafd,1) = 1
 167 c
 168 c====
 169 c 3. Creation des familles finales a partir de celles de depart
 170 c====
 171 c
 172 cgn      write (ulsort,90002)'cofamd, cotyel',cofamd,cotyel
 173 cgn      write (ulsort,90002)'nctfde',nctfde
 174 cgn      write (ulsort,90002)'ncfffi, nctffi',ncfffi,nctffi
 175 cgn      write (ulsort,90002)'nbffin initial',nbffin
 176 cgn      write (ulsort,1788)
 177 cgn      do 3333 , iaux = 1,nbffin
 178 cgn      write (ulsort,90012)'famille ',iaux,
 179 cgn     >(cfafin(nucode,iaux),nucode=1,nctffi)
 180 cgn 3333 continue
 181 cgn 1788  format('                MED type surf ar.su')
 182 c
 183 cgn      write (ulsort,90002)'... eddep1, edfin1', eddep1, edfin1
 184 cgn      write (ulsort,90002)'... eddep2, edfin2', eddep2, edfin2
 185 cgn      write (ulsort,90002)'... eddep3, edfin3', eddep3, edfin3
 186       do 30 , nufdep = 2 , nbfdep
 187 c
 188 cgn        write (ulsort,*) ' '
 189 cgn        write (ulsort,1788)
 190 cgn        write (ulsort,90012)'famille ',nufdep,
 191 cgn     >(cfadep(nucode,nufdep),nucode=1,nctfde)
 192 c
 193 c 3.1. ==> Etablissement des futurs codes dans tabaux
 194 c 3.1.1. ==> La famille MED doit etre la meme
 195 c
 196         tabaux(cofamd) = cfadep(cofamd,nufdep)
 197 c
 198 c 3.1.2. ==> definition du type d'element
 199 c
 200 cgn        write (ulsort,90002)'typel depart', cfadep(cotyel,nufdep)
 201         if ( cfadep(cotyel,nufdep).eq.eddep1 ) then
 202           tabaux(cotyel) = edfin1
 203         elseif ( cfadep(cotyel,nufdep).eq.eddep2 ) then
 204           tabaux(cotyel) = edfin2
 205         elseif ( cfadep(cotyel,nufdep).eq.eddep3 ) then
 206           tabaux(cotyel) = edfin3
 207         else
 208           tabaux(cotyel) = 0
 209         endif
 210 cgn        write (ulsort,90002)'typel arrivee', tabaux(cotyel)
 211 c
 212 c 3.1.3. ==> Surfaces frontieres
 213 c
 214 cgn       write (ulsort,90002)'... cosfsu depart', cfadep(cosfsu,nufdep)
 215 cgn       write (ulsort,90002)'... cofafa depart', cfadep(cofafa,nufdep)
 216         if ( typdep.eq.4 ) then
 217           tabaux(cosfsu) = cfadep(cosfsu,nufdep)
 218           tabaux(cofafa) = cfadep(cofafa,nufdep)
 219         endif
 220 c
 221 c 3.1.4. ==> Les groupes et equivalences doivent etre les memes
 222 c            le decalage est de 2 (cf. UTINCG/UTECF0)
 223 c
 224         do 314, nucode = ncfffi+1, nctffi
 225           tabaux(nucode) = cfadep(nucode+2,nufdep)
 226   314   continue
 227 c
 228 cgn          write (ulsort,1788)
 229 cgn          write (ulsort,90012)'tabaux a',315,
 230 cgn     >                       (tabaux(nucode),nucode=1,nctffi)
 231 c
 232 c 3.2. ==> Existe-t-il une famille finale avec ces caracteristiques ?
 233 c          Dans les nbffin familles deja definies, recherche d'une
 234 c          dont les codes sont les memes.
 235 c            Si on l'a, on note son numero (jaux) et on continue (33).
 236 c            Si aucune ne correspond, on en cree une nouvelle.
 237 c
 238         do 32 , iaux = 1 , nbffin
 239 cgn          write (ulsort,90002)'. Famille', iaux
 240           do 321 , nucode = 1, nctffi
 241 cgn          write (ulsort,90012)'.. code',nucode,
 242 cgn     > cfafin(nucode,iaux),tabaux(nucode)
 243             if ( cfafin(nucode,iaux).ne.tabaux(nucode) ) then
 244               goto 32
 245             endif
 246   321     continue
 247           jaux = iaux
 248 cgn          write (ulsort,90002)'ok Famille ', iaux
 249           goto 33
 250    32   continue
 251 c
 252         nbffin = nbffin + 1
 253 cgn        write (ulsort,*)'Creation de la famille ', nbffin
 254 c
 255 #ifdef _DEBUG_HOMARD_
 256         write (ulsort,texte(langue,5)) nbffin
 257 #endif
 258         do 322, nucode = 1, nctffi
 259           cfafin(nucode,nbffin) = tabaux(nucode)
 260   322   continue
 261         jaux = nbffin
 262 cgn        write (ulsort,1788)
 263 cgn        do 3221 , iaux = 1,nbffin
 264 cgn        write (ulsort,90012)'famille ',iaux,
 265 cgn     >  (cfafin(nucode,iaux),nucode=1,nctffi)
 266 cgn 3221 continue
 267 c
 268 c 3.3. ==> memorisation du type de famille finale
 269 c
 270    33   continue
 271 c
 272 cgn        write (ulsort,*)'Stockage de ', jaux,
 273 cgn     >   ' dans la famille de depart',nufdep
 274         cfadep(cofafd,nufdep) = jaux
 275 c
 276    30 continue
 277 c
 278 c====
 279 c 4. Controle
 280 c====
 281 c
 282 #ifdef _DEBUG_HOMARD_
 283       write (ulsort,texte(langue,4)) mess14(langue,4,typfin), nbffin
 284 #endif
 285 c
 286       if ( nbffin.gt.nbffim ) then
 287         write (ulsort,texte(langue,4)) mess14(langue,4,typfin), nbffin
 288         write (ulsort,texte(langue,6)) nbffim
 289         write (ulsort,texte(langue,7))
 290         codret = 1
 291       endif
 292 c
 293 c====
 294 c 5. La fin
 295 c====
 296 c
 297       if ( codret.ne.0 ) then
 298 c
 299 #include "envex2.h"
 300 c
 301       write (ulsort,texte(langue,1)) 'Sortie', nompro
 302       write (ulsort,texte(langue,2)) codret
 303 c
 304       endif
 305 c
 306 #ifdef _DEBUG_HOMARD_
 307       write (ulsort,texte(langue,1)) 'Sortie', nompro
 308       call dmflsh (iaux)
 309 #endif
 310 c
 311       end