src/tool/Utilitaire/utaurq.F

   1       subroutine utaurq ( modhom, eleinc,
   2      >                    nocman,
   3      >                    nbelig,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    UTilitaire - AUtorisation de Raffinement des Quadrangles
  26 c    --           --              -               -
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . modhom . e   .    1   . mode de fonctionnement de homard           .
  32 c .        .     .        . -5 : executable du suivi de frontiere      .
  33 c .        .     .        . -4 : exec. de l'interface apres adaptation .
  34 c .        .     .        . -3 : exec. de l'interface avant adaptation .
  35 c .        .     .        . -2 : executable de l'information           .
  36 c .        .     .        . -1 : executable de l'adaptation            .
  37 c .        .     .        .  0 : executable autre                      .
  38 c .        .     .        .  1 : homard pur                            .
  39 c .        .     .        .  2 : information                           .
  40 c .        .     .        .  3 : modification de maillage sans adaptati.
  41 c .        .     .        .  4 : interpolation de la solution          .
  42 c . eleinc . e   .   1    . elements incompatibles                     .
  43 c .        .     .        . 0 : on bloque s'il y en a                  .
  44 c .        .     .        . 1 : on les ignore s'il y en a              .
  45 c . nocman . e   . char*8 . nom de l'objet maillage calcul iteration n .
  46 c . nbelig .  s  .    1   . nombre d'elements elimines                 .
  47 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  48 c . langue . e   .    1   . langue des messages                        .
  49 c .        .     .        . 1 : francais, 2 : anglais                  .
  50 c . codret . es  .    1   . code de retour des modules                 .
  51 c .        .     .        . 0 : pas de probleme                        .
  52 c .        .     .        . 2 : presence de quadrangles                .
  53 c ______________________________________________________________________
  54 c
  55 c====
  56 c 0. declarations et dimensionnement
  57 c====
  58 c
  59 c 0.1. ==> generalites
  60 c
  61       implicit none
  62       save
  63 c
  64       character*6 nompro
  65       parameter ( nompro = 'UTAURQ' )
  66 c
  67 #include "nblang.h"
  68 #include "motcle.h"
  69 c
  70 c 0.2. ==> communs
  71 c
  72 #include "envex1.h"
  73 c
  74 #include "gmenti.h"
  75 #include "impr02.h"
  76 c
  77 c 0.3. ==> arguments
  78 c
  79       integer modhom, eleinc
  80       integer nbelig
  81 c
  82       character*8 nocman
  83 c
  84       integer ulsort, langue, codret
  85 c
  86 c 0.4. ==> variables locales
  87 c
  88       integer iaux
  89       integer adnomb
  90       integer sdimca, mdimca
  91       integer degre, mailet, maconf, homolo, hierar, nbnomb
  92       integer nbpyra
  93 c
  94       character*7 saux07
  95       character*8 ncinfo, ncnoeu, nccono, nccode
  96       character*8 nccoex, ncfami
  97       character*8 ncequi, ncfron, ncnomb
  98 c
  99       integer nbmess
 100       parameter ( nbmess = 10 )
 101       character*80 texte(nblang,nbmess)
 102 c ______________________________________________________________________
 103 c
 104 c====
 105 c 1. a priori, tout va bien
 106 c====
 107 c
 108 #include "impr01.h"
 109 c
 110 #ifdef _DEBUG_HOMARD_
 111       write (ulsort,texte(langue,1)) 'Entree', nompro
 112       call dmflsh (iaux)
 113 #endif
 114 c
 115       codret = 0
 116 c
 117       texte(1,4) = '(/,''Maillage de calcul : '',a)'
 118       texte(1,5) = '(''Mode HOMARD :'',i3)'
 119       texte(1,6) = '(''Ce maillage comporte'',i8,1x,a)'
 120       texte(1,7) = '(''Elimination de'',i8,1x,a)'
 121       texte(1,8) =
 122      > '(5x,''Nombre de '',a,'' a '',a,'' :'',i8)'
 123       texte(1,9) =
 124      > '(''Cela est incompatible avec ce raffinement.'',/)'
 125       texte(1,10) ='(/,''On '',a,'' les mailles incompatibles.'')'
 126 c
 127       texte(2,4) = '(/,''Calculation mesh : '',a)'
 128       texte(2,5) = '(''HOMARD mode :'',i3)'
 129       texte(2,6) = '(''This mesh contains'',i8,1x,a)'
 130       texte(2,7) = '(''Elimination of'',i8,1x,a)'
 131       texte(2,8) = '(5x,''Number of '',a,'' '',a,'' :'',i8)'
 132       texte(2,9) = '(''It is forbidden with this refinement.'')'
 133       texte(2,10) ='(/,''Incompatible meshes are '',a)'
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,texte(langue,5)) modhom
 137       if ( eleinc.eq.0 ) then
 138         write (ulsort,texte(langue,10)) 'bloque'
 139       else
 140         write (ulsort,texte(langue,10)) 'ignore'
 141       endif
 142 #endif
 143 c
 144 c====
 145 c 2. Recherche du nombre de pyramides
 146 c====
 147 c
 148 #ifdef _DEBUG_HOMARD_
 149       write (ulsort,texte(langue,3)) 'UTNOMC', nompro
 150 #endif
 151       call utnomc ( nocman,
 152      >              sdimca, mdimca,
 153      >               degre, mailet, maconf, homolo, hierar,
 154      >              nbnomb,
 155      >              ncinfo, ncnoeu, nccono, nccode,
 156      >              nccoex, ncfami,
 157      >              ncequi, ncfron, ncnomb,
 158      >              ulsort, langue, codret)
 159 c
 160       if ( codret.eq.0 ) then
 161 c
 162       call gmadoj ( ncnomb, adnomb, iaux, codret )
 163 c
 164       endif
 165 c
 166       if ( codret.eq.0 ) then
 167 c
 168       nbpyra = imem(adnomb+19)
 169 c
 170       endif
 171 c
 172 c====
 173 c 3. determination du nombre de mailles a eliminer
 174 c====
 175 c
 176 #ifdef _DEBUG_HOMARD_
 177       write (ulsort,*) '3. determination ; codret = ', codret
 178 #endif
 179 c
 180       if ( codret.eq.0 ) then
 181 c
 182 #ifdef _DEBUG_HOMARD_
 183       write (ulsort,texte(langue,6)) nbpyra, mess14(langue,3,5)
 184 #endif
 185 c
 186       if ( modhom.eq.1 .or. modhom.eq.-1 ) then
 187         nbelig = nbpyra
 188       else
 189         nbelig = 0
 190       endif
 191 c
 192       endif
 193 c
 194 c====
 195 c 4. diagnostic
 196 c====
 197 c
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,*) '4. diagnostic ; codret = ', codret
 200 #endif
 201 c
 202       if ( codret.eq.0 ) then
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,texte(langue,7)) nbelig, mess14(langue,3,5)
 206 #endif
 207 c
 208       if ( nbelig.ne.0 ) then
 209 c
 210 c 4.1. ==> messages
 211 c
 212         if ( eleinc.eq.0 ) then
 213           saux07 = 'bloquer'
 214         else
 215           saux07 = 'ignorer'
 216         endif
 217 c
 218         write (ulsort,texte(langue,8))mess14(langue,3,5),saux07,nbelig
 219         write (ulsort,*) ' '
 220 c
 221 c 4.2. ==> Si on bloque en presence de telles mailles
 222 c
 223         if ( eleinc.eq.0 ) then
 224 c
 225 #ifdef _DEBUG_HOMARD_
 226           write (ulsort,texte(langue,4)) nocman
 227 #endif
 228           write (ulsort,texte(langue,9))
 229           codret = 2
 230 c
 231         endif
 232 c
 233       endif
 234 c
 235       endif
 236 c
 237 c===
 238 c 5. la fin
 239 c===
 240 c
 241       if ( codret.ne.0 ) then
 242 c
 243 #include "envex2.h"
 244 c
 245       write (ulsort,texte(langue,1)) 'Sortie', nompro
 246       write (ulsort,texte(langue,2)) codret
 247 c
 248       endif
 249 c
 250 #ifdef _DEBUG_HOMARD_
 251       write (ulsort,texte(langue,1)) 'Sortie', nompro
 252       call dmflsh (iaux)
 253 #endif
 254 c
 255       end