src/tool/AP_Conversion/pcfaa2.F

   1       subroutine pcfaa2 ( fahope, numfam, nromat, numboi,
   2      >                    cfaqua, lgpile, lapile,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c    aPres adaptation - Conversion - FAmilles pour ATHENA - Phase 2
  25 c     -                 -            --            -              -
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . fahope . e   .   1    . famille HOMARD du quadrangle pere          .
  31 c . numfam . e   .   1    . famille MED a associer a cette famille     .
  32 c . nromat . e   .   1    . numero du materiau de la boite             .
  33 c . numboi . e   .   1    . numero de la boite                         .
  34 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  35 c .        .     . nbfqua .   1 : famille MED                          .
  36 c .        .     .        .   2 : type de quadrangle                   .
  37 c .        .     .        .   3 : numero de surface de frontiere       .
  38 c .        .     .        .   4 : famille des aretes internes apres raf.
  39 c .        .     .        .   5 : famille des triangles de conformite  .
  40 c .        .     .        .   6 : famille de sf active/inactive        .
  41 c .        .     .        . + l : appartenance a l'equivalence l       .
  42 c . lgpile . es  .   1    . longueur de la pile                        .
  43 c . lapile .  a  .   *    . tableau de travail                         .
  44 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  45 c . langue . e   .    1   . langue des messages                        .
  46 c .        .     .        . 1 : francais, 2 : anglais                  .
  47 c . codret . es  .    1   . code de retour des modules                 .
  48 c .        .     .        . 0 : pas de probleme                        .
  49 c .        .     .        . 1 : probleme                               .
  50 c ______________________________________________________________________
  51 c
  52 c====
  53 c 0. declarations et dimensionnement
  54 c====
  55 c
  56 c 0.1. ==> generalites
  57 c
  58       implicit none
  59       save
  60 c
  61       character*6 nompro
  62       parameter ( nompro = 'PCFAA2' )
  63 c
  64 #include "nblang.h"
  65 #include "coftex.h"
  66 c
  67 c 0.2. ==> communs
  68 c
  69 #include "envex1.h"
  70 c
  71 #include "impr02.h"
  72 c
  73 #include "nbfami.h"
  74 #include "nbfamm.h"
  75 c
  76 #include "dicfen.h"
  77 c
  78 c 0.3. ==> arguments
  79 c
  80       integer fahope, numfam, nromat, numboi
  81 c
  82       integer cfaqua(nctfqu,*)
  83 c
  84       integer lgpile, lapile(*)
  85 c
  86       integer ulsort, langue, codret
  87 c
  88 c 0.4. ==> variables locales
  89 c
  90       integer iaux, jaux
  91 c
  92       integer nbmess
  93       parameter ( nbmess = 10 )
  94       character*80 texte(nblang,nbmess)
  95 c
  96 c 0.5. ==> initialisations
  97 c ______________________________________________________________________
  98 c
  99 c====
 100 c 1. initialisations
 101 c====
 102 c
 103 c 1.1. ==> messages
 104 c
 105 #include "impr01.h"
 106 c
 107 #ifdef _DEBUG_HOMARD_
 108       write (ulsort,texte(langue,1)) 'Entree', nompro
 109       call dmflsh (iaux)
 110 #endif
 111 c
 112       texte(1,4) = '(''Creation de la famille HOMARD numero : '',i8)'
 113       texte(1,5) = '(/,a14,'' : nombre de familles crees : '',i8)'
 114       texte(1,6) = '(''Ce nombre est superieur au maximum :'',i8)'
 115       texte(1,7) = '(''Modifier le programme UTINCG'',/)'
 116 c
 117       texte(2,4) = '(''Creation of HOMARD family # : '',i8)'
 118       texte(2,5) = '(/,a14,'' : number of created families : '',i8)'
 119       texte(2,6) = '(''This number is greater than maximum :'',i8)'
 120       texte(2,7) = '(''Modify UTINCG program.'',/)'
 121 c
 122       codret = 0
 123 c
 124 c====
 125 c 2. creation d'une nouvelle famille homard pour les quadrangles
 126 c====
 127 c
 128 c 2.1. ==> numero de cette famille
 129 c
 130       nbfqua = nbfqua + 1
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,4)) nbfqua
 134 #endif
 135 c
 136       if ( nbfqua.gt.nbfqum ) then
 137         write (ulsort,texte(langue,5)) mess14(langue,4,8), nbfqua
 138         write (ulsort,texte(langue,6)) nbfqum
 139         write (ulsort,texte(langue,7))
 140         codret = 1
 141       endif
 142 c
 143 c 2.2. ==> les caracteristiques : celles du pere, sauf la famille MED
 144 c
 145       if ( codret.eq.0 ) then
 146 c
 147       do 22 , iaux = 1 , nctfqu
 148         cfaqua(iaux,nbfqua) = cfaqua(iaux,fahope)
 149    22 continue
 150       cfaqua(cofamd,nbfqua) = numfam
 151 c
 152 #ifdef _DEBUG_HOMARD_
 153         write (ulsort,60030)
 154         write (ulsort,60031) nbfqua,
 155      >                       (cfaqua(jaux,nbfqua),jaux=1,ncffqu)
 156         write (ulsort,60032)
 157 60030 format(
 158      >/,5x,41('*'),
 159      >/,5x,'* Numero code  *   1   *   2   *    3   *',
 160      >/,5x,41('*'),
 161      >/,5x,'* Numero de la * Fami. * Type  * Fami. *',
 162      >/,5x,'*   famille    *  MED  *       * tria. *',
 163      >/,5x,41('*'))
 164 60031 format(
 165      >  5x,'*',  i8,'      *',i6,' *',i6,' *',i6,' *')
 166 60032 format(
 167      >  5x,41('*'),/)
 168 #endif
 169 c
 170       endif
 171 c
 172 c 2.3. ==> memorisation des caracteristiques dans la pile
 173 c
 174       if ( codret.eq.0 ) then
 175 c
 176       jaux = lgpile * (nctfqu+3)
 177       lgpile = lgpile + 1
 178 cgn      write(ulsort,*) '.. lgpile', lgpile
 179       lapile(jaux+1) = nbfqua
 180       lapile(jaux+2) = nromat
 181       lapile(jaux+3) = numboi
 182       do 23 , iaux = 1 , nctfqu
 183         lapile(jaux+3+iaux) = cfaqua(iaux,nbfqua)
 184    23 continue
 185 cgn      write(ulsort,1007) (lapile(iaux),iaux=1,lgpile * (nctfqu+3))
 186 cgn 1007 format(7i6)
 187 c
 188       endif
 189 c
 190 c====
 191 c 3. la fin
 192 c====
 193 c
 194       if ( codret.ne.0 ) then
 195 c
 196 #include "envex2.h"
 197 c
 198       write (ulsort,texte(langue,1)) 'Sortie', nompro
 199       write (ulsort,texte(langue,2)) codret
 200 c
 201       endif
 202 c
 203 #ifdef _DEBUG_HOMARD_
 204       write (ulsort,texte(langue,1)) 'Sortie', nompro
 205       call dmflsh (iaux)
 206 #endif
 207 c
 208       end