src/tool/Utilitaire/utmfv1.F

   1       subroutine utmfv1 ( typenh, nbvoto, nbvoco,
   2      >                    filvol, fvpyte,
   3      >                    pertet, perpyr,
   4      >                    pthepe, pphepe,
   5      >                    ulsort, langue, codret)
   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 - passage de Mere a Fille pour les Volumes - 1
  27 c    --                      -      -              -         -
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . typenh . e   .   1    . code des entites                           .
  33 c .        .     .        .   6 : hexaedres                            .
  34 c .        .     .        .   7 : pentaedres                           .
  35 c . nbvoto . e   .   1    . nombre total de volumes concernes          .
  36 c . nbvoco . e   .   1    . nombre de volumes decoupes en conformite   .
  37 c . filvol . es  . nbvoto . fils des volumes                           .
  38 c . fvpyte . e   .2*nbvoco. fvpyte(1,j) = numero de la 1ere pyramide   .
  39 c .        .     .        . fille du volume k tel que filvol(k) =-j    .
  40 c .        .     .        . fvpyte(2,j) = numero du 1er tetraedre      .
  41 c .        .     .        . fils du volume k tel que filvol(k) = -j    .
  42 c . pertet . e   . nbteto . pere des tetraedres                        .
  43 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  44 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  45 c . perpyr . e   . nbpyto . pere des pyramides                         .
  46 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  47 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  48 c . pthepe . es  .    *   . si i <= nbheco : numero de l'hexaedre      .
  49 c .        .     .        . si non : numero du pentaedre               .
  50 c . pphepe . es  .    *   . si i <= nbheco : numero de l'hexaedre      .
  51 c .        .     .        . si non : numero du pentaedre               .
  52 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  53 c . langue . e   .    1   . langue des messages                        .
  54 c .        .     .        . 1 : francais, 2 : anglais                  .
  55 c . codret . es  .    1   . code de retour des modules                 .
  56 c .        .     .        . 0 : pas de probleme                        .
  57 c .        .     .        . 1 : probleme                               .
  58 c ______________________________________________________________________
  59 c
  60 c====
  61 c 0. declarations et dimensionnement
  62 c====
  63 c
  64 c 0.1. ==> generalites
  65 c
  66       implicit none
  67       save
  68 c
  69       character*6 nompro
  70       parameter ( nompro = 'UTMFV1' )
  71 c
  72 #include "nblang.h"
  73 c
  74 c 0.2. ==> communs
  75 c
  76 #include "envex1.h"
  77 c
  78 #include "nombte.h"
  79 #include "nombpy.h"
  80 #include "impr02.h"
  81 c
  82 c 0.3. ==> arguments
  83 c
  84       integer typenh, nbvoto, nbvoco
  85       integer filvol(nbvoto)
  86       integer fvpyte(2,nbvoco)
  87       integer pertet(nbteto)
  88       integer perpyr(nbpyto)
  89       integer pthepe(*)
  90       integer pphepe(*)
  91 c
  92       integer ulsort, langue, codret
  93 c
  94 c 0.4. ==> variables locales
  95 c
  96       integer iaux
  97       integer indic1, indic2
  98       integer lapyra, letetr
  99 c
 100       integer nbmess
 101       parameter ( nbmess = 10 )
 102       character*80 texte(nblang,nbmess)
 103 c
 104 c 0.5. ==> initialisations
 105 c ______________________________________________________________________
 106 c
 107 c====
 108 c 1. messages
 109 c====
 110 c
 111 #include "impr01.h"
 112 c
 113 #ifdef _DEBUG_HOMARD_
 114       write (ulsort,texte(langue,1)) 'Entree', nompro
 115       call dmflsh (iaux)
 116 #endif
 117 c
 118       texte(1,4) = '(''. Reperage des filles des '',a)'
 119       texte(1,5) =
 120      >'(''.. Nombre de '',a,'' decoupes en conformite :'',i10)'
 121       texte(1,6) = '(''Probleme de parentes pour les '',a)'
 122       texte(1,7) = '(''Indice du pere de '',a,i10,'' :'',i10))'
 123       texte(1,8) = '(''Incoherence.''))'
 124       texte(1,9) = '(''. Reperage des filles du'',i6,''-ieme '',a)'
 125 c
 126       texte(2,4) = '(''. Son arrays from father arrays for '',a)'
 127       texte(2,5) =
 128      >'(''.. Number of '',a,'' cut for conformal reasons :'',i10)'
 129       texte(2,6) = '(''Problems with the parents of the '',a)'
 130       texte(2,7) =
 131      > '(''Index for the father of '',a,'',i10,'' is '',i10))'
 132       texte(2,8) = '(''Incoherence.''))'
 133       texte(2,9) = '(''. Search for the sons of'',i6,''-th '',a)'
 134 c
 135 #include "impr03.h"
 136 c
 137       codret = 0
 138 c
 139 #ifdef _DEBUG_HOMARD_
 140       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 141       write (ulsort,texte(langue,5)) mess14(langue,3,typenh), nbvoco
 142 #endif
 143 c
 144 c====
 145 c 2. parcours des volumes concernes
 146 c====
 147 c
 148       do 21 , iaux = 1 , nbvoco
 149 c
 150         if ( codret.eq.0 ) then
 151 c
 152 #ifdef _DEBUG_HOMARD_
 153       write (ulsort,texte(langue,9)) iaux, mess14(langue,1,typenh)
 154 #endif
 155 c
 156 c 2.1. ==> Examen par les pyramides
 157 c
 158         lapyra = fvpyte(1,iaux)
 159         if ( lapyra.gt.0 ) then
 160           indic1 = -perpyr(lapyra)
 161           if ( indic1.eq.0 ) then
 162             codret = 1
 163           endif
 164         else
 165           indic1 = 0
 166         endif
 167 c
 168 c 2.2. ==> Examen par les tetraedres
 169 c
 170         letetr = fvpyte(2,iaux)
 171         if ( letetr.gt.0 ) then
 172           indic2 = -pertet(letetr)
 173           if ( indic2.eq.0 ) then
 174             codret = 2
 175           endif
 176         else
 177           indic2 = 0
 178         endif
 179 c
 180 c 2.3. ==> Controle et affectation
 181 c
 182 #ifdef _DEBUG_HOMARD_
 183         write (ulsort,texte(langue,7)) mess14(langue,1,5),lapyra, indic1
 184         write (ulsort,texte(langue,7)) mess14(langue,1,3),letetr, indic2
 185 #endif
 186         if ( indic1.ne.0 .and. indic2.ne.0 ) then
 187           if ( indic1.ne.indic2 ) then
 188             codret = 3
 189           endif
 190         endif
 191 c
 192         if ( codret.eq.0 ) then
 193           if ( indic1.ne.0 ) then
 194             filvol(pphepe(indic1)) = -iaux
 195           else
 196             filvol(pthepe(indic2)) = -iaux
 197           endif
 198         endif
 199 c
 200         endif
 201 c
 202    21 continue
 203 c
 204 c====
 205 c 3. la fin
 206 c====
 207 c
 208       if ( codret.ne.0 ) then
 209 c
 210 #include "envex2.h"
 211 c
 212       write (ulsort,texte(langue,1)) 'Sortie', nompro
 213       write (ulsort,texte(langue,2)) codret
 214       if ( codret.eq.1 ) then
 215         write (ulsort,texte(langue,6)) mess14(langue,3,5)
 216       elseif ( codret.eq.2 ) then
 217         write (ulsort,texte(langue,6)) mess14(langue,3,3)
 218       elseif ( codret.eq.3 ) then
 219         write (ulsort,texte(langue,7)) mess14(langue,1,5),lapyra, indic1
 220         write (ulsort,texte(langue,7)) mess14(langue,1,3),letetr, indic2
 221         write (ulsort,texte(langue,8))
 222       endif
 223 c
 224       endif
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,texte(langue,1)) 'Sortie', nompro
 228       call dmflsh (iaux)
 229 #endif
 230 c
 231       end