src/tool/Decision/dedera.F

   1       subroutine dedera ( nomail,
   2      >                    lgopti, taopti, lgopts, taopts,
   3      >                    lgetco, taetco,
   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 traitement des DEcisions - DERAffinement
  26 c                --          ----
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  32 c . lgopti . e   .   1    . longueur du tableau des options            .
  33 c . taopti . e   . lgopti . tableau des options                        .
  34 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  35 c . taopts . e   . lgopts . tableau des options caracteres             .
  36 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  37 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  38 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  39 c . langue . e   .    1   . langue des messages                        .
  40 c .        .     .        . 1 : francais, 2 : anglais                  .
  41 c . codret . es  .    1   . code de retour des modules                 .
  42 c .        .     .        . 0 : pas de probleme                        .
  43 c .        .     .        . 5 : mauvais type de code de calcul associe .
  44 c ______________________________________________________________________
  45 c
  46 c====
  47 c 0. declarations et dimensionnement
  48 c====
  49 c
  50 c 0.1. ==> generalites
  51 c
  52       implicit none
  53       save
  54 c
  55       character*6 nompro
  56       parameter ( nompro = 'DEDERA' )
  57 c
  58 #include "nblang.h"
  59 c
  60 c 0.2. ==> communs
  61 c
  62 #include "envex1.h"
  63 c
  64 #include "gmenti.h"
  65 c
  66 #include "envca1.h"
  67 #include "nombtr.h"
  68 #include "nombqu.h"
  69 c
  70 c 0.3. ==> arguments
  71 c
  72       character*8 nomail
  73 c
  74       integer lgopti
  75       integer taopti(lgopti)
  76 c
  77       integer lgopts
  78       character*8 taopts(lgopts)
  79 c
  80       integer lgetco
  81       integer taetco(lgetco)
  82 c
  83       integer ulsort, langue, codret
  84 c
  85 c 0.4. ==> variables locales
  86 c
  87       integer codava
  88       integer nrosec
  89       integer nretap, nrsset
  90       integer iaux
  91 c
  92       integer phetar, psomar, pfilar, pmerar
  93       integer phettr, paretr, pfiltr, ppertr, pnivtr
  94       integer phetqu, parequ, pfilqu, pperqu, pnivqu
  95       integer phette, ptrite
  96       integer phethe, pquahe, pcoquh
  97       integer phetpy, pfacpy, pcofay
  98       integer phetpe, pfacpe, pcofap
  99       integer pposif, pfacar
 100       integer advotr, advoqu, adpptr, adppqu
 101       integer pdecfa, pdecar
 102       integer adhoar, adhotr, adhoqu
 103       integer ptrav3
 104 c
 105       character*6 saux
 106       character*8 ntrav3
 107 c
 108       logical prem
 109 c
 110 #ifdef _DEBUG_HOMARD_
 111       character*6 nompra
 112 #endif
 113 c
 114       integer nbmess
 115       parameter ( nbmess = 10 )
 116       character*80 texte(nblang,nbmess)
 117 c
 118 c 0.5. ==> initialisations
 119 c
 120       data prem / .true. /
 121 c ______________________________________________________________________
 122 c
 123 c====
 124 c 1. messages
 125 c====
 126 c
 127 #include "impr01.h"
 128 c
 129 #ifdef _DEBUG_HOMARD_
 130       write (ulsort,texte(langue,1)) 'Entree', nompro
 131       call dmflsh (iaux)
 132 #endif
 133 c
 134 #include "impr03.h"
 135 c
 136       codava = codret
 137 c
 138 c=======================================================================
 139       if ( codava.eq.0 ) then
 140 c=======================================================================
 141 c
 142 c 1.1. ==> le debut des mesures de temps
 143 c
 144       if ( prem ) then
 145         nrosec = taetco(4)
 146       endif
 147       call gtdems (nrosec)
 148 c
 149 c 1.3. ==> les messages
 150 c
 151       texte(1,4) = '(/,a6,'' DECISIONS POUR LE DERAFFINEMENT'')'
 152       texte(1,5) = '(38(''=''),/)'
 153 c
 154       texte(2,4) = '(/,a6,'' UNREFINEMENT DECISIONS'')'
 155       texte(2,5) = '(29(''=''),/)'
 156 c
 157 c 1.4. ==> le numero de sous-etape
 158 c
 159       nretap = taetco(1)
 160       nrsset = taetco(2) + 1
 161       taetco(2) = nrsset
 162 c
 163       call utcvne ( nretap, nrsset, saux, iaux, codret )
 164 c
 165 c 1.5. ==> le titre
 166 c
 167       write (ulsort,texte(langue,4)) saux
 168       write (ulsort,texte(langue,5))
 169 c
 170 c====
 171 c 2. recuperation des pointeurs, initialisations
 172 c====
 173 c
 174       if ( codret.eq.0 ) then
 175 c
 176 #ifdef _DEBUG_HOMARD_
 177       write (ulsort,texte(langue,3)) 'DEARD0', nompro
 178 #endif
 179       call deard0 ( nomail, taopts(11), taopts(12), ntrav3,
 180      >              phetar, psomar, pfilar, pmerar,
 181      >              phettr, paretr, pfiltr, ppertr, pnivtr,
 182      >              phetqu, parequ, pfilqu, pperqu, pnivqu,
 183      >              phette, ptrite,
 184      >              phethe, pquahe, pcoquh,
 185      >              phetpy, pfacpy, pcofay,
 186      >              phetpe, pfacpe, pcofap,
 187      >              pposif, pfacar,
 188      >              advotr, advoqu, adpptr, adppqu,
 189      >              pdecfa, pdecar,
 190      >              adhoar, adhotr, adhoqu,
 191      >              ptrav3,
 192      >              ulsort, langue, codret )
 193 c
 194       endif
 195 c
 196 c====
 197 c 3. mise en coherence des decisions pour le deraffinement
 198 c====
 199 #ifdef _DEBUG_HOMARD_
 200       write(ulsort,90002) '3. coherence ; codret', codret
 201 #endif
 202 c
 203 #ifdef _DEBUG_HOMARD_
 204       if ( codret.eq.0 ) then
 205       write (ulsort,texte(langue,3)) 'DELIST avant dedini', nompro
 206 c
 207       nompra = 'dedini'
 208       iaux = 1
 209       call delist ( nomail, nompra, iaux,
 210      >              lgopts, taopts,
 211      >              ulsort, langue, codret )
 212 c
 213       endif
 214 #endif
 215 c
 216       if ( codret.eq.0 ) then
 217 c
 218 #ifdef _DEBUG_HOMARD_
 219       write (ulsort,texte(langue,3)) 'DEDINI', nompro
 220 #endif
 221       call dedini
 222      >        ( homolo,
 223      >          imem(pdecar), imem(pdecfa),
 224      >          imem(pposif), imem(pfacar),
 225      >          imem(adhoar),
 226      >          imem(phettr), imem(paretr), imem(pfiltr), imem(pnivtr),
 227      >          imem(phetqu), imem(parequ), imem(pfilqu), imem(pnivqu),
 228      >          ulsort, langue, codret )
 229 c
 230       endif
 231 c
 232 #ifdef _DEBUG_HOMARD_
 233       if ( codret.eq.0 ) then
 234 c
 235       write (ulsort,texte(langue,3)) 'DELIST apres dedini', nompro
 236       nompra = 'dedini'
 237       iaux = 2
 238       call delist ( nomail, nompra, iaux,
 239      >              lgopts, taopts,
 240      >              ulsort, langue, codret )
 241 c
 242       endif
 243 #endif
 244 c
 245 c====
 246 c 4. contamination du deraffinement
 247 c====
 248 #ifdef _DEBUG_HOMARD_
 249       write(ulsort,90002) '4. contamination ; codret', codret
 250 #endif
 251 c
 252 #ifdef _DEBUG_HOMARD_
 253       if ( codret.eq.0 ) then
 254 c
 255       write (ulsort,texte(langue,3)) 'DELIST avant dedcon', nompro
 256       nompra = 'dedcon'
 257       iaux = 1
 258       call delist ( nomail, nompra, iaux,
 259      >              lgopts, taopts,
 260      >              ulsort, langue, codret )
 261 c
 262       endif
 263 #endif
 264 c
 265       if ( codret.eq.0 ) then
 266 c
 267 #ifdef _DEBUG_HOMARD_
 268       write (ulsort,texte(langue,3)) 'DEDCON', nompro
 269 #endif
 270       call dedcon
 271      >        ( taopti(30), homolo,
 272      >          imem(pdecar), imem(pdecfa),
 273      >          imem(pposif), imem(pfacar),
 274      >          imem(phetar), imem(pmerar), imem(adhoar),
 275      >          imem(phettr), imem(paretr), imem(pnivtr),
 276      >          imem(phetqu), imem(parequ), imem(pnivqu),
 277      >          imem(ptrav3),
 278      >          ulsort, langue, codret )
 279 c
 280       endif
 281 c
 282 #ifdef _DEBUG_HOMARD_
 283       if ( codret.eq.0 ) then
 284 c
 285       write (ulsort,texte(langue,3)) 'DELIST apres dedcon', nompro
 286       nompra = 'dedcon'
 287       iaux = 2
 288       call delist ( nomail, nompra, iaux,
 289      >              lgopts, taopts,
 290      >              ulsort, langue, codret )
 291 c
 292       endif
 293 #endif
 294 c
 295 c====
 296 c 5. decompte des decisions
 297 c====
 298 #ifdef _DEBUG_HOMARD_
 299       write(ulsort,90002) '5. decompte des decisions ; codret', codret
 300 #endif
 301 c
 302       if ( codret.eq.0 ) then
 303 c
 304 #ifdef _DEBUG_HOMARD_
 305       write (ulsort,texte(langue,3)) 'DECPTE', nompro
 306 #endif
 307       call decpte ( taopti(31), taopti(32),
 308      >              imem(pdecar), imem(pdecfa),
 309      >              imem(phettr), imem(phetqu),
 310      >              imem(ptrite), imem(phette),
 311      >              imem(pquahe), imem(phethe),
 312      >              imem(pfacpy), imem(phetpy),
 313      >              imem(pfacpe), imem(phetpe),
 314      >              ulsort, langue, codret )
 315 c
 316       endif
 317 c
 318 c====
 319 c 6. desallocations des tableaux de travail
 320 c====
 321 #ifdef _DEBUG_HOMARD_
 322       write(ulsort,90002) '6. desallocations ; codret', codret
 323 #endif
 324 c
 325       if ( codret.eq.0 ) then
 326 c
 327       call gmlboj ( ntrav3 , codret )
 328 c
 329       endif
 330 c
 331 c====
 332 c 7. verification des decisions s'il existe des homologues
 333 c====
 334 #ifdef _DEBUG_HOMARD_
 335       write(ulsort,90002) '7. verification homologue ; codret', codret
 336 #endif
 337 c
 338 c 7.1. ==> sur les aretes
 339 c
 340       if ( homolo.ge.2 ) then
 341 c
 342       if ( codret.eq.0 ) then
 343 c
 344 #ifdef _DEBUG_HOMARD_
 345       write (ulsort,texte(langue,3)) 'DEHOVA', nompro
 346 #endif
 347       call dehova ( imem(adhoar), imem(pdecar),
 348      >              nompro, 1,
 349      >              ulsort, langue, codret )
 350 c
 351       endif
 352 c
 353       endif
 354 c
 355 c 7.2. ==> sur les triangles
 356 c
 357       if ( homolo.ge.3 .and. nbtrto.ne.0 ) then
 358 c
 359       if ( codret.eq.0 ) then
 360 c
 361 #ifdef _DEBUG_HOMARD_
 362       write (ulsort,texte(langue,3)) 'DEHOVF', nompro
 363 #endif
 364       iaux = 2
 365       call dehovf ( iaux,
 366      >              nbtrto, imem(adhotr), imem(pdecfa),
 367      >              nompro, 1,
 368      >              ulsort, langue, codret )
 369 c
 370       endif
 371 c
 372       endif
 373 c
 374 c 7.3. ==> sur les quadrangles
 375 c
 376       if ( homolo.ge.3 .and. nbquto.ne.0 ) then
 377 c
 378       if ( codret.eq.0 ) then
 379 c
 380 #ifdef _DEBUG_HOMARD_
 381       write (ulsort,texte(langue,3)) 'DEHOVF', nompro
 382 #endif
 383       iaux = 4
 384       call dehovf ( iaux,
 385      >              nbquto, imem(adhoqu), imem(pdecfa),
 386      >              nompro, 1,
 387      >              ulsort, langue, codret )
 388 c
 389       endif
 390 c
 391       endif
 392 c
 393 c====
 394 c 8. la fin
 395 c====
 396 c
 397 c 8.1. ==> message si erreur
 398 c
 399       if ( codret.ne.0 ) then
 400 c
 401 #include "envex2.h"
 402 c
 403       write (ulsort,texte(langue,1)) 'Sortie', nompro
 404       write (ulsort,texte(langue,2)) codret
 405 c
 406       endif
 407 c
 408 c 8.2. ==> fin des mesures de temps de la section
 409 c
 410       call gtfims (nrosec)
 411 c
 412 #ifdef _DEBUG_HOMARD_
 413       write (ulsort,texte(langue,1)) 'Sortie', nompro
 414       call dmflsh (iaux)
 415 #endif
 416 c
 417       prem = .false.
 418 c
 419 c=======================================================================
 420       endif
 421 c=======================================================================
 422 c
 423       end