src/tool/HOMARD_00/hoapcv.F

   1       subroutine hoapcv ( 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 APres 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 .        .     .        . 6 : 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 = 'HOAPCV' )
  50 c
  51 #include "motcle.h"
  52 #include "nblang.h"
  53 c
  54 c 0.2. ==> communs
  55 c
  56 #include "envex1.h"
  57 c
  58 #include "gmenti.h"
  59 #include "gmreel.h"
  60 #include "gmstri.h"
  61 #include "cndoad.h"
  62 c
  63 c 0.3. ==> arguments
  64 c
  65       integer codret
  66 c
  67 c 0.4. ==> variables locales
  68 c
  69       integer ulsort, langue, codava
  70       integer adopti, lgopti
  71       integer adoptr, lgoptr
  72       integer adopts, lgopts
  73       integer adetco, lgetco
  74       integer nrsect, nrssse
  75       integer nretap, nrsset
  76       integer iaux
  77 c
  78       character*6 saux
  79       character*8 action
  80       character*8 typobs, nohmap
  81 c
  82       integer nbmess
  83       parameter ( nbmess = 10 )
  84       character*80 texte(nblang,nbmess)
  85 c
  86       character*50 commen(nblang)
  87 c
  88 c 0.5. ==> initialisations
  89 c ______________________________________________________________________
  90 c
  91 c====
  92 c 1. les initialisations
  93 c====
  94 c
  95       codava = codret
  96 c
  97 c=======================================================================
  98       if ( codava.eq.0 ) then
  99 c=======================================================================
 100 c
 101 #ifdef _DEBUG_HOMARD_
 102       call gmprsx (nompro, nndoad )
 103       call gmprsx (nompro, nndoad//'.OptEnt' )
 104       call gmprsx (nompro, nndoad//'.OptRee' )
 105       call gmprsx (nompro, nndoad//'.OptCar' )
 106       call gmprsx (nompro, nndoad//'.EtatCour' )
 107 #endif
 108 c
 109 c 1.2. ==> le numero d'unite logique de la liste standard
 110 c
 111       call utulls ( ulsort, codret )
 112 c
 113 c 1.3. ==> la langue des messages
 114 c
 115       if ( codret.eq.0 ) then
 116 c
 117       call gmadoj ( nndoad//'.OptEnt', adopti, lgopti, codret )
 118       if ( codret.eq.0 ) then
 119         langue = imem(adopti)
 120       else
 121         langue = 1
 122         codret = 2
 123       endif
 124 c
 125       endif
 126 c
 127 c 1.4. ==> l'etat courant
 128 c
 129       if ( codret.eq.0 ) then
 130 c
 131       call gmadoj ( nndoad//'.EtatCour', adetco, lgetco, codret )
 132       if ( codret.eq.0 ) then
 133         nretap = imem(adetco) + 1
 134         imem(adetco) = nretap
 135         nrsset = -1
 136         imem(adetco+1) = nrsset
 137         nrsect = imem(adetco+2) + 10
 138         imem(adetco+2) = nrsect
 139         nrssse = nrsect
 140         imem(adetco+3) = nrssse
 141       else
 142         nretap = -1
 143         nrsset = -1
 144         nrsect = 200
 145         nrssse = nrsect
 146         codret = 2
 147       endif
 148 c
 149       endif
 150 c
 151 c 1.4. ==> le debut des mesures de temps
 152 c
 153       call gtdems (nrsect)
 154 c
 155 c 1.5. ==> les messages
 156 c
 157 #include "impr01.h"
 158 c
 159 #ifdef _DEBUG_HOMARD_
 160       write (ulsort,texte(langue,1)) 'Entree', nompro
 161       call dmflsh (iaux)
 162 #endif
 163 c
 164       texte(1,4) =
 165      > '(//,a6,'//
 166      >''' C O N V E R S I O N S   A P R E S   A D A P T A T I O N'')'
 167       texte(1,5) = '(62(''=''),/)'
 168 c
 169       texte(2,4) =
 170      > '(//,a6,'//
 171      >''' C O N V E R S I O N S   A F T E R   A D A P T A T I O N'')'
 172       texte(2,5) = '(62(''=''),/)'
 173 c
 174 c 1.6. ==> le titre
 175 c
 176       if ( codret.eq.0 ) then
 177 c
 178       call utcvne ( nretap, nrsset, saux, iaux, codret )
 179 c
 180       write (ulsort,texte(langue,4)) saux
 181       write (ulsort,texte(langue,5))
 182 c
 183       nrsset = 0
 184       imem(adetco+1) = nrsset
 185 c
 186       endif
 187 c
 188 c 1.7. ==> les options reelles
 189 c
 190       call gmadoj ( nndoad//'.OptRee', adoptr, lgoptr, codret )
 191       if ( codret.ne.0 ) then
 192         codret = 2
 193       endif
 194 c
 195 c 1.8. ==> les noms d'objets a conserver
 196 c
 197       if ( codret.eq.0 ) then
 198         call gmadoj ( nndoad//'.OptCar', adopts, lgopts, codret )
 199         if ( codret.ne.0 ) then
 200           codret = 2
 201         endif
 202       endif
 203 c
 204 #include "impr03.h"
 205 c
 206 c====
 207 c 2. compactage des tableaux
 208 c====
 209 #ifdef _DEBUG_HOMARD_
 210       write (ulsort,90002) '2. compactage tableaux ; codret', codret
 211 #endif
 212 c
 213       if ( imem(adopti+21).eq.1 .or. imem(adopti+27).eq.1 ) then
 214 c
 215       if ( codret.eq.0 ) then
 216 c
 217 #ifdef _DEBUG_HOMARD_
 218       write (ulsort,texte(langue,3)) 'UTCOMP', nompro
 219 #endif
 220 c
 221       call utcomp (ulsort, langue, codret)
 222 c
 223       endif
 224 c
 225       endif
 226 c
 227 c====
 228 c 3. conversion eventuelle du maillage
 229 c====
 230 #ifdef _DEBUG_HOMARD_
 231       write (ulsort,90002) '3. conversion maillage ; codret', codret
 232 #endif
 233 c
 234       if ( codret.eq.0 ) then
 235 c
 236       imem(adetco+3) = imem(adetco+3) + 1
 237 c
 238       if ( imem(adopti+21).eq.1 ) then
 239 c
 240 #ifdef _DEBUG_HOMARD_
 241       write (ulsort,90002) 'imem(adopti+38)', imem(adopti+38)
 242       write (ulsort,90002) 'imem(adopti+10)', imem(adopti+10)
 243 #endif
 244 c
 245         nrssse = imem(adetco+3)
 246         call gtdems (nrssse)
 247 c
 248 c 3.1. ==> le cas extrude, non saturne, non neptune
 249 c
 250         if ( imem(adopti+38).ne.0 .and.
 251      >       imem(adopti+10).ne.26 .and.
 252      >       imem(adopti+10).ne.46 ) then
 253 c
 254           if ( codret.eq.0 ) then
 255 c
 256 #ifdef _DEBUG_HOMARD_
 257       write (ulsort,texte(langue,3)) 'PCMEXT', nompro
 258 #endif
 259           call pcmext ( lgopti, imem(adopti),
 260      >                  lgetco, imem(adetco),
 261      >                  ulsort, langue, codret )
 262 c
 263          endif
 264 c
 265         endif
 266 c
 267 c 3.2. ==> conversion vers le format externe
 268 c
 269         if ( codret.eq.0 ) then
 270 c
 271 #ifdef _DEBUG_HOMARD_
 272       write (ulsort,texte(langue,3)) 'PCMAIL', nompro
 273 #endif
 274 c
 275         call pcmail ( lgopti, imem(adopti), lgopts, smem(adopts),
 276      >                lgetco, imem(adetco),
 277      >                ulsort, langue, codret )
 278 c
 279         endif
 280 c
 281 c 3.2. ==> modification pour le cas non conforme
 282 c          ou saturne/neptune 2D
 283 c
 284 #ifdef _DEBUG_HOMARD_
 285       write (ulsort,90002) 'imem(adopti+29)', imem(adopti+29)
 286       write (ulsort,90002) 'imem(adopti+10)', imem(adopti+10)
 287 #endif
 288 c
 289         if ( imem(adopti+29).eq.-2 .or.
 290      >       imem(adopti+29).eq.1 .or.
 291      >       imem(adopti+29).eq.2 .or.
 292      >       imem(adopti+29).eq.3 .or.
 293      >       imem(adopti+10).eq.26 .or.
 294      >       imem(adopti+10).eq.46 ) then
 295 c
 296           if ( codret.eq.0 ) then
 297 c
 298 #ifdef _DEBUG_HOMARD_
 299       write (ulsort,texte(langue,3)) 'PCMANC', nompro
 300 #endif
 301           call pcmanc ( lgopti, imem(adopti), lgoptr, rmem(adoptr),
 302      >                  lgopts, smem(adopts),
 303      >                  lgetco, imem(adetco),
 304      >                  ulsort, langue, codret )
 305 c
 306           endif
 307 c
 308         endif
 309 c
 310         call gtfims (nrssse)
 311 c
 312       endif
 313 c
 314       endif
 315 c
 316 c====
 317 c 4. conversion eventuelle d'une solution
 318 c====
 319 c
 320 c 4.1. ==> lecture
 321 c          si aucune solution n'est presente, hoapls modifiera
 322 c          l'indicateur de conversion, imem(adopti+27).
 323 #ifdef _DEBUG_HOMARD_
 324       write (ulsort,90002) '4.1. lecture solution ; codret', codret
 325       write (ulsort,90002) 'imem(adopti+27)', imem(adopti+27)
 326       write (ulsort,90002) 'imem(adopti+38)', imem(adopti+38)
 327 #endif
 328 c
 329       if ( codret.eq.0 ) then
 330 c
 331       imem(adetco+3) = imem(adetco+3) + 1
 332 c
 333       if ( imem(adopti+27).eq.1 ) then
 334 c
 335 #ifdef _DEBUG_HOMARD_
 336       write (ulsort,texte(langue,3)) 'HOAPLS', nompro
 337 #endif
 338 c
 339         call hoapls ( lgopti, imem(adopti), lgopts, smem(adopts),
 340      >                lgetco, imem(adetco),
 341      >                ulsort, langue, codret )
 342 c
 343       endif
 344 c
 345       endif
 346 c
 347 c 4.2. ==> conversion
 348 #ifdef _DEBUG_HOMARD_
 349       write (ulsort,90002) '4.2. conversion solution ; codret', codret
 350 #endif
 351 c
 352       if ( codret.eq.0 ) then
 353 c
 354       imem(adetco+3) = imem(adetco+3) + 1
 355 c
 356       if ( imem(adopti+27).eq.1 ) then
 357 c
 358         nrssse = imem(adetco+3)
 359         call gtdems (nrssse)
 360 c
 361 c 4.2.1 ==> pour le cas extrude, passage du 3D au 2D
 362 c
 363         if ( codret.eq.0 ) then
 364 c
 365         if ( imem(adopti+38).ne.0 ) then
 366 c
 367 #ifdef _DEBUG_HOMARD_
 368       write (ulsort,texte(langue,3)) 'UTSEXT', nompro
 369 #endif
 370           iaux = 1
 371           call utsext ( smem(adopts+8), iaux, imem(adopti+10),
 372      >                  lgetco, imem(adetco),
 373      >                  ulsort, langue, codret )
 374 c
 375         endif
 376 c
 377         endif
 378 c
 379 c 4.2.2. ==> conversion vraie
 380 c
 381         if ( codret.eq.0 ) then
 382 c
 383 #ifdef _DEBUG_HOMARD_
 384       write (ulsort,texte(langue,3)) 'PCSOLU', nompro
 385 #endif
 386 c
 387         call pcsolu ( lgopti, imem(adopti), lgopts, smem(adopts),
 388      >                lgetco, imem(adetco),
 389      >                ulsort, langue, codret )
 390 c
 391         endif
 392 c
 393 c 4.2.3 ==> pour le cas extrude, passage du 2D au 3D
 394 c
 395         if ( codret.eq.0 ) then
 396 c
 397         if ( imem(adopti+38).ne.0 ) then
 398 c
 399 #ifdef _DEBUG_HOMARD_
 400       write (ulsort,texte(langue,3)) 'UTSEXT', nompro
 401 #endif
 402           iaux = 2
 403           call utsext ( smem(adopts+9), iaux, imem(adopti+10),
 404      >                  lgetco, imem(adetco),
 405      >                  ulsort, langue, codret )
 406 c
 407         endif
 408 c
 409         endif
 410 c
 411         call gtfims (nrssse)
 412 c
 413       endif
 414 c
 415       endif
 416 c
 417 c
 418 c====
 419 c 5. analyse du maillage converti
 420 c    Il faut le faire seulement ici car certaines conversions
 421 c    modifient les familles
 422 c====
 423 #ifdef _DEBUG_HOMARD_
 424       write (ulsort,90002) '5. analyse ; codret', codret
 425 #endif
 426 c
 427       if ( codret.eq.0 ) then
 428 c
 429       imem(adetco+3) = imem(adetco+3) + 1
 430       nrssse = imem(adetco+3)
 431 c
 432       call gtdems (nrssse)
 433 c
 434       if ( codret.eq.0 ) then
 435         typobs = mchmap
 436         iaux = 0
 437         call utosno ( typobs, nohmap, iaux, ulsort, langue, codret )
 438       endif
 439 c
 440       if ( imem(adopti+3).eq.3 ) then
 441         commen(1) = 'Maillage apres modification                       '
 442         commen(2) = 'Mesh after modification                           '
 443       elseif ( imem(adopti+21).eq.1 ) then
 444         commen(1) = 'Maillage apres adaptation                         '
 445         commen(2) = 'Mesh after adaptation                             '
 446       else
 447         commen(1) = 'Maillage                                          '
 448         commen(2) = 'Maillage                                          '
 449       endif
 450 c
 451       if ( codret.eq.0 ) then
 452 c
 453       action = smem(adopts+29)
 454       if ( action.eq.'homa    ' ) then
 455         action = 'apad'
 456       endif
 457 #ifdef _DEBUG_HOMARD_
 458       write (ulsort,texte(langue,3)) 'UTBILM', nompro
 459 #endif
 460       call utbilm ( nohmap, commen(langue), imem(adopti+2), action,
 461      >              lgetco, imem(adetco),
 462      >              ulsort, langue, codret )
 463       endif
 464 c
 465       call gtfims (nrssse)
 466 c
 467       endif
 468 c
 469 c====
 470 c 7. la fin
 471 c====
 472 c
 473 c 7.1. ==> message si erreur
 474 c
 475       if ( codret.ne.0 ) then
 476 c
 477 #include "envex2.h"
 478 c
 479       write (ulsort,texte(langue,1)) 'Sortie', nompro
 480       write (ulsort,texte(langue,2)) codret
 481 c
 482       endif
 483 c
 484 c 7.2. ==> fin des mesures de temps de la section
 485 c
 486       call gtfims (nrsect)
 487 c
 488 #ifdef _DEBUG_HOMARD_
 489       write (ulsort,texte(langue,1)) 'Sortie', nompro
 490       call dmflsh (iaux)
 491 #endif
 492 c
 493 c=======================================================================
 494       endif
 495 c=======================================================================
 496 c
 497       end