src/tool/HOMARD_00/hoavcv.F

   1       subroutine hoavcv ( codret )
   2 c ______________________________________________________________________
   3 c
   4 c                             H O M A R D
   5 c
   6 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   7 c
   8 c Version originale enregistree le 18 juin 1996 sous le numero 96036
   9 c aupres des huissiers de justice Simart et Lavoir a Clamart
  10 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  11 c aupres des huissiers de justice
  12 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  13 c
  14 c    HOMARD est une marque deposee d'Electricite de France
  15 c
  16 c Copyright EDF 1996
  17 c Copyright EDF 1998
  18 c Copyright EDF 2002
  19 c Copyright EDF 2020
  20 c ______________________________________________________________________
  21 c
  22 c       HOMARD : interface AVant adaptation : ConVersions
  23 c       --                 --                 -  -
  24 c ______________________________________________________________________
  25 c .        .     .        .                                            .
  26 c .  nom   . e/s . taille .           description                      .
  27 c .____________________________________________________________________.
  28 c . codret . es  .    1   . code de retour des modules                 .
  29 c .        .     .        . en entree = celui du module d'avant        .
  30 c .        .     .        . en sortie = celui du module en cours       .
  31 c .        .     .        . 0 : pas de probleme                        .
  32 c .        .     .        . 1 : manque de temps cpu                    .
  33 c .        .     .        . 2x : probleme dans les memoires            .
  34 c .        .     .        . 3x : probleme dans les fichiers            .
  35 c .        .     .        . 5 : mauvaises options                      .
  36 c .        .     .        . 7 : problemes dans les noms d'objet        .
  37 c ______________________________________________________________________
  38 c
  39 c====
  40 c 0. declarations et dimensionnement
  41 c====
  42 c
  43 c 0.1. ==> generalites
  44 c
  45       implicit none
  46       save
  47 c
  48       character*6 nompro
  49       parameter ( nompro = 'HOAVCV' )
  50 c
  51 #include "motcle.h"
  52 #include "nblang.h"
  53 c
  54 c 0.2. ==> communs
  55 c
  56 #include "envex1.h"
  57 #include "envca2.h"
  58 c
  59 #include "gmenti.h"
  60 #include "gmreel.h"
  61 #include "gmstri.h"
  62 #include "cndoad.h"
  63 c
  64 c 0.3. ==> arguments
  65 c
  66       integer codret
  67 c
  68 c 0.4. ==> variables locales
  69 c
  70       integer ulsort, langue, codava
  71       integer adopti, lgopti
  72       integer adoptr, lgoptr
  73       integer adopts, lgopts
  74       integer adetco, lgetco
  75       integer nrsect, nrssse
  76       integer nretap, nrsset
  77       integer iaux
  78 c
  79       character*6 saux
  80       character*8 action
  81       character*8 typobs, nohman, nocman, nosvmn
  82 c
  83       integer nbmess
  84       parameter ( nbmess = 20 )
  85       character*80 texte(nblang,nbmess)
  86 c
  87       character*50 commen(nblang)
  88 c
  89 c 0.5. ==> initialisations
  90 c ______________________________________________________________________
  91 c
  92 c====
  93 c 1. les initialisations
  94 c====
  95 c
  96       codava = codret
  97 c
  98 c=======================================================================
  99       if ( codava.eq.0 ) then
 100 c=======================================================================
 101 c
 102 #ifdef _DEBUG_HOMARD_
 103       call gmprsx (nompro, nndoad )
 104       call gmprsx (nompro, nndoad//'.OptEnt' )
 105       call gmprsx (nompro, nndoad//'.OptRee' )
 106       call gmprsx (nompro, nndoad//'.OptCar' )
 107       call gmprsx (nompro, nndoad//'.EtatCour' )
 108 #endif
 109 c
 110 c 1.2. ==> le numero d'unite logique de la liste standard
 111 c
 112       call utulls ( ulsort, codret )
 113 c
 114 c 1.3. ==> la langue des messages
 115 c
 116       if ( codret.eq.0 ) then
 117 c
 118       call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret )
 119       if ( codret.eq.0 ) then
 120         langue = imem(adopti)
 121       else
 122         langue = 1
 123         codret = 2
 124       endif
 125 c
 126       endif
 127 c
 128 c 1.4. ==> l'etat courant
 129 c
 130       if ( codret.eq.0 ) then
 131 c
 132       call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret )
 133       if ( codret.eq.0 ) then
 134         nretap = imem(adetco) + 1
 135         imem(adetco) = nretap
 136         nrsset = -1
 137         imem(adetco+1) = nrsset
 138         nrsect = imem(adetco+2) + 10
 139         imem(adetco+2) = nrsect
 140         nrssse = nrsect
 141         imem(adetco+3) = nrssse
 142       else
 143         nretap = -1
 144         nrsset = -1
 145         nrsect = 200
 146         nrssse = nrsect
 147         codret = 2
 148       endif
 149 c
 150       endif
 151 c
 152 c 1.4. ==> le debut des mesures de temps
 153 c
 154       call gtdems (nrsect)
 155 c
 156 c 1.5. ==> les messages
 157 c
 158 #include "impr01.h"
 159 c
 160 #ifdef _DEBUG_HOMARD_
 161       write (ulsort,texte(langue,1)) 'Entree', nompro
 162       call dmflsh (iaux)
 163 #endif
 164 c
 165       texte(1,4) =
 166      > '(//,a6,'//
 167      >''' C O N V E R S I O N S   A V A N T   A D A P T A T I O N'')'
 168       texte(1,5) = '(62(''=''),/)'
 169 c
 170       texte(2,4) =
 171      > '(//,a6,'//
 172      >''' C O N V E R S I O N S   B E F O R E   A D A P T A T I O N'')'
 173       texte(2,5) = '(64(''=''),/)'
 174 c
 175 #include "impr03.h"
 176 c
 177 c 1.6. ==> le titre
 178 c
 179       if ( codret.eq.0 ) then
 180 c
 181       call utcvne ( nretap, nrsset, saux, iaux, codret )
 182 c
 183       write (ulsort,texte(langue,4)) saux
 184       write (ulsort,texte(langue,5))
 185 c
 186       nrsset = 0
 187       imem(adetco+1) = nrsset
 188 c
 189       endif
 190 c
 191 c 1.7. ==> les options reelles
 192 c
 193       call gmadoj ( nndoad//'.OptRee', adoptr, lgoptr, codret )
 194       if ( codret.ne.0 ) then
 195         codret = 2
 196       endif
 197 c
 198 c 1.8. ==> les noms d'objets a conserver
 199 c
 200       if ( codret.eq.0 ) then
 201         call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret )
 202         if ( codret.ne.0 ) then
 203           codret = 2
 204         endif
 205       endif
 206 c
 207 c 1.9. ==> la date courante
 208 c
 209       call utdhlg ( ladate, langue )
 210 c
 211 c====
 212 c 2. conversion du maillage
 213 c====
 214 #ifdef _DEBUG_HOMARD_
 215       write (ulsort,90002) '2. conversion ; codret', codret
 216 #endif
 217 c
 218       if ( codret.eq.0 ) then
 219 c
 220       imem(adetco+3) = imem(adetco+3) + 1
 221 c
 222       nrssse = imem(adetco+3)
 223       call gtdems (nrssse)
 224 c
 225 c 2.1. ==> prealable pour le suivi de frontiere
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,90002) '2.2. prealable frontiere ; codret', codret
 228 #endif
 229 c
 230       if ( ( ( mod(imem(adopti+28),2).eq.0 ) .and.
 231      >       ( imem(adopti+28).lt.0 ) )  .or.
 232      >     ( ( mod(imem(adopti+28),5).eq.0 ) .and.
 233      >       ( imem(adopti+9).eq.0 ) ) ) then
 234 c
 235         if ( codret.eq.0 ) then
 236 c
 237 #ifdef _DEBUG_HOMARD_
 238       write (ulsort,texte(langue,3)) 'SFDEFG', nompro
 239 #endif
 240 c
 241         call sfdefg ( imem(adopti+28),
 242      >                smem(adopts), smem(adopts+15), smem(adopts+16),
 243      >                ulsort, langue, codret)
 244 c
 245         endif
 246 c
 247       endif
 248 c
 249       if ( imem(adopti+20).eq.1 ) then
 250 c
 251 c 2.2. ==> prealable pour le cas saturne/neptune 2D
 252 #ifdef _DEBUG_HOMARD_
 253       write (ulsort,90002) '2.2. prealable sat/nep ; codret', codret
 254 #endif
 255 c
 256         if ( imem(adopti+10).eq.26 .or.
 257      >       imem(adopti+10).eq.46 ) then
 258 c
 259           if ( codret.eq.0 ) then
 260 c
 261 #ifdef _DEBUG_HOMARD_
 262       write (ulsort,texte(langue,3)) 'VCMS2D', nompro
 263 #endif
 264 c
 265           call vcms2d ( lgopti, imem(adopti), lgopts, smem(adopts),
 266      >                  lgetco, imem(adetco),
 267      >                  ulsort, langue, codret )
 268 c
 269           endif
 270 c
 271         endif
 272 c
 273 c 2.3. ==> conversion vraie
 274 #ifdef _DEBUG_HOMARD_
 275       write (ulsort,90002) '2.3. conversion ; codret', codret
 276 #endif
 277 c
 278         if ( codret.eq.0 ) then
 279 c
 280 #ifdef _DEBUG_HOMARD_
 281       write (ulsort,texte(langue,3)) 'VCMAIL', nompro
 282 #endif
 283         call vcmail ( lgopti, imem(adopti), lgopts, smem(adopts),
 284      >                lgetco, imem(adetco),
 285      >                ulsort, langue, codret )
 286 c
 287         endif
 288 c
 289         endif
 290 c
 291       endif
 292 c
 293 c====
 294 c 3. Le cas extrude, non saturne, non neptune
 295 c====
 296 #ifdef _DEBUG_HOMARD_
 297       write (ulsort,90002) '3. cas extrude ; codret', codret
 298 #endif
 299 c
 300       if ( imem(adopti+38).ne.0 .and.
 301      >     imem(adopti+10).ne.26 .and.
 302      >     imem(adopti+10).ne.46 ) then
 303 c
 304 c 3.1. ==> Conversion complete
 305 c
 306         if ( imem(adopti+20).eq.1 ) then
 307 c
 308           if ( codret.eq.0 ) then
 309 c
 310 #ifdef _DEBUG_HOMARD_
 311       write (ulsort,texte(langue,3)) 'VCMEXT', nompro
 312 #endif
 313 c
 314           call vcmext ( lgopti, imem(adopti), lgopts, smem(adopts),
 315      >                  lgetco, imem(adetco),
 316      >                  ulsort, langue, codret )
 317 c
 318           endif
 319 c
 320 c 3.2. ==> Conversion partielle
 321 c
 322         else
 323 c
 324           if ( codret.eq.0 ) then
 325 c
 326 #ifdef _DEBUG_HOMARD_
 327       write (ulsort,texte(langue,3)) 'VCMEXA', nompro
 328 #endif
 329 c
 330           call vcmexa ( lgopti, imem(adopti), lgopts, smem(adopts),
 331      >                  lgetco, imem(adetco),
 332      >                  ulsort, langue, codret )
 333 c
 334           endif
 335 c
 336         endif
 337 c
 338       endif
 339 c
 340 c====
 341 c 4. s'il y a conversion de solution, on cree une structure de
 342 c    memorisation du maillage n
 343 c====
 344 c
 345       if ( imem(adopti+20).eq.1.and. imem(adopti+27).eq.1 ) then
 346 c
 347         if ( codret.eq.0 ) then
 348 c
 349         nohman = smem(adopts+2)
 350 c
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,texte(langue,3)) 'UTSVMN', nompro
 353 #endif
 354         call utsvmn ( nohman, nosvmn,
 355      >                ulsort, langue, codret )
 356 c
 357         endif
 358 c
 359         if ( codret.eq.0 ) then
 360 c
 361         smem(adopts+13) = nosvmn
 362 c
 363         endif
 364 c
 365       endif
 366 c
 367 c====
 368 c 5. Informations sur le maillage
 369 c====
 370 #ifdef _DEBUG_HOMARD_
 371       write (ulsort,90002) '5. Informations ; codret', codret
 372 #endif
 373 c 5.1. ==> analyse du maillage
 374 #ifdef _DEBUG_HOMARD_
 375       write (ulsort,90002) '5.1. analyse ; codret', codret
 376 #endif
 377 c
 378       if ( imem(adopti+20).eq.1 ) then
 379 c
 380         if ( codret.eq.0 ) then
 381 c
 382         commen(1) = 'Maillage converti au format HOMARD                '
 383         commen(2) = 'Mesh converted to the HOMARD format               '
 384 c
 385 #ifdef _DEBUG_HOMARD_
 386         call utbica ( commen(langue),
 387      >                ulsort, langue, codret )
 388 #endif
 389 c
 390         endif
 391 c
 392         call gtfims (nrssse)
 393 c
 394       else
 395 c
 396         commen(1) = 'Maillage lu au format HOMARD                      '
 397         commen(2) = 'Mesh read with HOMARD format                      '
 398 c
 399       endif
 400 c
 401 c 5.2. ==> Nom du maillage au format HOMARD
 402 #ifdef _DEBUG_HOMARD_
 403       write (ulsort,90002) '5.2. nom du maillage ; codret', codret
 404 #endif
 405 c
 406       if ( codret.eq.0 ) then
 407 c
 408       typobs = mchman
 409       iaux = 1
 410       call utosno ( typobs, nohman, iaux, ulsort, langue, codret )
 411 c
 412       endif
 413 c
 414 c====
 415 c 6. Prise en compte eventuelle du suivi de frontiere
 416 c====
 417 c
 418 #ifdef _DEBUG_HOMARD_
 419       write (ulsort,90002) '6. frontiere ; codret', codret
 420 #endif
 421 c
 422       if ( codret.eq.0 ) then
 423 c
 424       imem(adetco+3) = imem(adetco+3) + 1
 425       nrssse = imem(adetco+3)
 426 c
 427       if ( mod(imem(adopti+28),2).eq.0 .or.
 428      >     mod(imem(adopti+28),3).eq.0 .or.
 429      >     mod(imem(adopti+28),5).eq.0 ) then
 430 c
 431         call gtdems (nrssse)
 432 c
 433 #ifdef _DEBUG_HOMARD_
 434       write (ulsort,texte(langue,3)) 'SFCOIN', nompro
 435 #endif
 436         call sfcoin ( nohman,
 437      >                lgopti, imem(adopti), lgopts, smem(adopts),
 438      >                lgetco, imem(adetco),
 439      >                ulsort, langue, codret )
 440 c
 441         call gtfims (nrssse)
 442 c
 443       endif
 444 c
 445       endif
 446 c
 447 c====
 448 c 7. analyse du maillage
 449 c====
 450 c
 451 #ifdef _DEBUG_HOMARD_
 452       write (ulsort,90002) '7. analyse du maillage ; codret', codret
 453 #endif
 454 c
 455       if ( codret.eq.0 ) then
 456 c
 457       imem(adetco+3) = imem(adetco+3) + 1
 458       nrssse = imem(adetco+3)
 459 c
 460       call gtdems (nrssse)
 461 c
 462       if ( codret.eq.0 ) then
 463 c
 464       action = smem(adopts+29)
 465       if ( action.eq.'homa    ' ) then
 466         action = 'avad'
 467       endif
 468 #ifdef _DEBUG_HOMARD_
 469       write (ulsort,texte(langue,3)) 'UTBILM', nompro
 470 #endif
 471       call utbilm ( nohman, commen(langue), imem(adopti+2), action,
 472      >              lgetco, imem(adetco),
 473      >              ulsort, langue, codret )
 474       endif
 475 c
 476       call gtfims (nrssse)
 477 c
 478       endif
 479 c
 480 c====
 481 c 8. Filtrages de l'adaptation
 482 c====
 483 c
 484 #ifdef _DEBUG_HOMARD_
 485       write (ulsort,90002) '8. filtrage ; codret', codret
 486 #endif
 487 c
 488       if ( codret.eq.0 ) then
 489 c
 490       imem(adetco+3) = imem(adetco+3) + 1
 491 c
 492       if ( imem(adopti+18).gt.0 .or.
 493      >     rmem(adoptr+2).gt.0.d0 ) then
 494 c
 495 #ifdef _DEBUG_HOMARD_
 496       write (ulsort,texte(langue,3)) 'VCFIAD', nompro
 497 #endif
 498         call vcfiad ( lgopti, imem(adopti), lgoptr, rmem(adoptr),
 499      >                lgopts, smem(adopts),
 500      >                lgetco, imem(adetco),
 501      >                ulsort, langue, codret )
 502 c
 503       endif
 504 c
 505       endif
 506 c
 507 c====
 508 c 9. conversion eventuelle de l'indicateur d'erreur
 509 c===
 510 c
 511 #ifdef _DEBUG_HOMARD_
 512       write (ulsort,90002) '9. indicateur erreur ; codret', codret
 513 #endif
 514 c
 515       if ( imem(adopti+26).eq.1 ) then
 516 c
 517 c 9.1. ==> lecture
 518 c
 519         if ( codret.eq.0 ) then
 520 c
 521         imem(adetco+3) = imem(adetco+3) + 1
 522 c
 523 #ifdef _DEBUG_HOMARD_
 524       write (ulsort,texte(langue,3)) 'HOAVLI', nompro
 525 #endif
 526         call hoavli ( lgopti, imem(adopti), lgoptr, rmem(adoptr),
 527      >                lgopts, smem(adopts),
 528      >                lgetco, imem(adetco),
 529      >                ulsort, langue, codret )
 530 c
 531         endif
 532 c
 533 c 9.2. ==> prealable pour le cas extrude
 534 c
 535         if ( codret.eq.0 ) then
 536 c
 537         if ( imem(adopti+38).ne.0 ) then
 538 c
 539 #ifdef _DEBUG_HOMARD_
 540       write (ulsort,texte(langue,3)) 'UTSEXT', nompro
 541 #endif
 542           iaux = 1
 543           call utsext ( smem(adopts+6), iaux, imem(adopti+10),
 544      >                  lgetco, imem(adetco),
 545      >                  ulsort, langue, codret )
 546 c
 547         endif
 548 c
 549         endif
 550 c
 551 c 9.3. ==> conversion vraie
 552 c
 553         if ( codret.eq.0 ) then
 554 c
 555         imem(adetco+3) = imem(adetco+3) + 1
 556 c
 557         nrssse = imem(adetco+3)
 558         call gtdems (nrssse)
 559 c
 560 #ifdef _DEBUG_HOMARD_
 561       write (ulsort,texte(langue,3)) 'VCINDI', nompro
 562 #endif
 563         call vcindi ( lgopti, imem(adopti), lgopts, smem(adopts),
 564      >                lgetco, imem(adetco),
 565      >                ulsort, langue, codret )
 566 c
 567         call gtfims (nrssse)
 568 #ifdef _DEBUG_HOMARD_
 569         call gmprsx (nompro,smem(adopts+7))
 570 cgn        call gmprsx (nompro,smem(adopts+7)//'.Quadr')
 571 cgn        call gmprsx (nompro,smem(adopts+7)//'.Quadr.Support')
 572 cgn        call gmprsx (nompro,smem(adopts+7)//'.Quadr.ValeursR')
 573 #endif
 574 c
 575         endif
 576 c
 577       endif
 578 c
 579 c====
 580 c 10. menage des structures liees au calcul
 581 c====
 582 c
 583 #ifdef _DEBUG_HOMARD_
 584       write (ulsort,90002) '10. menage ; codret', codret
 585 #endif
 586 c
 587       if ( imem(adopti+20).eq.1 ) then
 588 c
 589       if ( codret.eq.0 ) then
 590 c
 591 #ifdef _DEBUG_HOMARD_
 592       write (ulsort,texte(langue,3)) 'GMSGOJ', nompro
 593 #endif
 594         nocman = smem(adopts)
 595         call gmsgoj ( nocman, codret )
 596 c
 597       endif
 598 c
 599       endif
 600 c
 601 c====
 602 c 11. la fin
 603 c====
 604 c
 605 #ifdef _DEBUG_HOMARD_
 606       write (ulsort,90002) '11. la fin ; codret', codret
 607 #endif
 608 c
 609 c 11.1. ==> message si erreur
 610 c
 611       if ( codret.ne.0 ) then
 612 c
 613 #include "envex2.h"
 614 c
 615       write (ulsort,texte(langue,1)) 'Sortie', nompro
 616       write (ulsort,texte(langue,2)) codret
 617 c
 618       endif
 619 c
 620 c 11.2. ==> fin des mesures de temps de la section
 621 c
 622       call gtfims (nrsect)
 623 c
 624 #ifdef _DEBUG_HOMARD_
 625       write (ulsort,texte(langue,1)) 'Sortie', nompro
 626       call dmflsh (iaux)
 627 #endif
 628 c
 629 c=======================================================================
 630       endif
 631 c=======================================================================
 632 c
 633       end