src/tool/Gestion_MTU/gmcpgp.F

   1       subroutine gmcpgp ( nom1, nom2, 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     copier le graphe de l'objet 'nom1' simple ou structure
  23 c     a la place du graphe de l'objet 'nom2' :
  24 c     - si nom1 est un objet simple on ecrit simplement cet
  25 c       objet
  26 c     - l'ancien graphe de nom2 est supprime, un nouveau graphe
  27 c       est cree avec des noms nouveaux (sauf la racine) pour
  28 c       recevoir le graphe de nom2
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . nom1   . e   . char(*). nom etendu source                          .
  34 c . nom2   . e   .char(*) . nom etendu destinataire                    .
  35 c . codret .  s  . ent    . code retour de l'operation                 .
  36 c .        .     .        .  0 : OK                                    .
  37 c .        .     .        . -1 : 'nom1' invalide ou non alloue         .
  38 c .        .     .        . -2 : objets destinataire et source ne sont .
  39 c .        .     .        .      pas de meme type                      .
  40 c .        .     .        . -3 : nom etendu invalide                   .
  41 c .        .     .        . -4 : premier caractere interdit            .
  42 c .        .     .        . -5 : dimensionnement insuffisant           .
  43 c ______________________________________________________________________
  44 c
  45 c====
  46 c 0. declarations et dimensionnement
  47 c====
  48 c
  49 c 0.1. ==> generalites
  50 c
  51       implicit none
  52       save
  53       character*6 nompro
  54       parameter ( nompro = 'GMCPGP' )
  55 c
  56 c
  57 #include "genbla.h"
  58 c
  59 c 0.2. ==> communs
  60 c
  61 #include "gminds.h"
  62 c
  63 #include "gmcoer.h"
  64 #include "gmimpr.h"
  65 #include "gmlang.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       integer       codret
  70       character*(*) nom1, nom2
  71 c
  72 c 0.4. ==> variables locales
  73 c
  74 #include "gmixjx.h"
  75 c
  76       integer iaux, jaux
  77       integer       i,nbj,ide1,ioa1,ity1,ide2,isup,igrp
  78       integer impopt, nbchem,j,nj1,i2,iadr,long1,jc,ieco,iato
  79       integer lgchem(ix)
  80 c
  81       integer nrotab
  82       character*8   chemin(ix,jx), objet
  83       character*8   obrep1,obter1,chter1,racine
  84       character*8   obrep2,obter2,chter2
  85       character*8   obj1(nbjx), obj2(nbjx)
  86       character*8   letype
  87       character*90  chaine
  88       character*40  mess
  89 c
  90       integer nbmess
  91       parameter ( nbmess = 20 )
  92       character*80 texte(nblang,nbmess)
  93 c
  94 c
  95 c 0.5. ==> initialisations
  96 c ______________________________________________________________________
  97 c
  98 c====
  99 c 1. messages
 100 c====
 101 c
 102 #include "impr01.h"
 103 c
 104 #ifdef _DEBUG_HOMARD_
 105       write (ulsort,texte(langue,1)) 'Entree', nompro
 106       call dmflsh (iaux)
 107 #endif
 108 c
 109       texte(1,20) = '(1x,''Copie du graphe de l''''objet '',a8)'
 110       texte(1,4) = '(1x,''a la place du graphe de l''''objet '',a8)'
 111       texte(1,11) = '(1x,''Le premier objet est invalide.'')'
 112       texte(1,12) = '(1x,''Les deux objets ne sont pas de meme type.'')'
 113       texte(1,13) = '(1x,''Le second objet est invalide.'')'
 114       texte(1,14) = '(1x,''Premier caractere du 2nd nom interdit.'')'
 115       texte(1,15) = '(1x,''Dimensionnement insuffisant.'')'
 116 c
 117       texte(2,20) = '(1x,''Copy of the graph of the object '',a8)'
 118       texte(2,4) = '(1x,''to the graph of the object '',a8)'
 119       texte(2,11) = '(1x,''The first object is not valid.'')'
 120       texte(2,12) = '(1x,''The types of 2 objects are different.'')'
 121       texte(2,13) = '(1x,''The second object is not valid.'')'
 122       texte(2,14) = '(1x,''1st character of 2nd name is forbidden.'')'
 123       texte(2,15) = '(1x,''Lack of central memory.'')'
 124 c
 125 c 1.  initialisation
 126 c
 127       do 10 i = 1, nbjx
 128          obj1(i) = sindef
 129          obj2(i) = sindef
 130    10 continue
 131       nbj = 0
 132 c
 133 c 2.  ecrire d'abord l'objet 'nom1'
 134 c
 135       call gmcpoj (nom1,nom2,codret)
 136       if (codret.lt.0) then
 137         goto 91
 138       endif
 139 c
 140 c     si objet simple : fini
 141 c
 142       call gbdnoe(nom1,obrep1,obter1,chter1,ide1)
 143       call gbobal(obter1,ity1,ioa1)
 144       if (ioa1.eq.2) then
 145         goto 91
 146       endif
 147 c
 148 c 3.  supprimer le graphe de l'objet 'nom2' s'il existe
 149 c
 150       if (nom2.eq.sindef) then
 151          codret = -3
 152          goto 91
 153       endif
 154       call gbdnoe(nom2,obrep2,obter2,chter2,ide2)
 155       call gasgmc(obter2,isup)
 156       if ((isup.ne.0).and.(isup.ne.-5)) then
 157          mess = ' gmcpgp -> gasgmc -> codret : '
 158          write(mess(29:30),'(i2)') isup
 159          write(ulsort,*) mess
 160          call ugstop('gmcpgp',ulsort,1,1,1)
 161       endif
 162       racine = obter2
 163 c
 164 c 4   construction du graphe de 'nom1'
 165 c
 166 #ifdef _DEBUG_HOMARD_
 167       impopt = 1
 168 #else
 169       impopt = 0
 170 #endif
 171 c
 172       iaux = ix
 173       jaux = jx
 174       call gagpmc(obter1,iaux,jaux,chemin,lgchem,nbchem,impopt,igrp)
 175       if (igrp.lt.0) then
 176          mess = ' gmcpgp -> gagpmc -> codret : '
 177          write(mess(29:30),'(i2)') igrp
 178          write(ulsort,*) mess
 179         call ugstop('gmcpgp',ulsort,1,1,1)
 180       endif
 181 c
 182 c 5.  ecrire le graphe de 'nom1'
 183 c
 184       do 50 i = 1, nbchem
 185          do 51 j = 3 , jx , 2
 186             if ( (chemin(i,j)(1:1).eq.'*') .or.
 187      >           (chemin(i,j)(1:1).eq.'=') .or.
 188      >           (chemin(i,j)(1:1).eq.'+') .or.
 189      >           (chemin(i,j)(1:1).eq.'-') .or.
 190      >           (chemin(i,j)(1:1).eq.'<')      ) then
 191               nj1 = j-1
 192               goto 20
 193             endif
 194    51    continue
 195          codret = -5
 196          goto 91
 197 c
 198    20    continue
 199          i2  = 8
 200          chaine(1:i2) = racine
 201 c
 202          do 40 j = 2, nj1, 2
 203 c
 204             chaine = chaine(1:i2)//'.'//chemin(i,j-1)
 205             i2     = i2+9
 206             objet  = chemin(i,j)
 207 c
 208             if (objet.eq.sindef) then
 209               goto 40
 210             else if (chemin(i,j+1)(1:1).eq.'=') then
 211               goto 40
 212             endif
 213             if (chemin(i,j+1)(1:1).eq.'*') then
 214                call gbcara(objet,nrotab,iadr,long1,letype)
 215                if (coergm.ne.0) then
 216                  goto 40
 217                endif
 218             endif
 219 c
 220 c           recherche si objet est deja ecrit
 221 c
 222             do 41 jc = 1, nbj
 223                if (obj1(jc).eq.objet) then
 224                  jaux = jc
 225                  goto 30
 226                endif
 227    41       continue
 228 c
 229 c           si l'objet n'est pas ecrit : on l'ecrit
 230 c
 231             call gmcpoj (objet,chaine(1:i2),ieco)
 232             if (ieco.lt.0) then
 233                mess = ' gmcpgp -> gmcpoj -> codret : '
 234                write(mess(29:30),'(i2)') ieco
 235                write(ulsort,*) mess
 236                call ugstop('gmcpgp',ulsort,1,1,1)
 237             endif
 238 c
 239 c           mise a jour des tableaux obj1 et obj2
 240 c
 241             call gbdnoe(chaine(1:i2),obrep2,obter2,chter2,ide2)
 242             nbj = nbj+1
 243             obj1(nbj) = objet
 244             obj2(nbj) = obter2
 245             goto 40
 246 c
 247 c           si l'objet est deja ecrit et si champ destinataire
 248 c           est vide : y attacher l'objet disque deja ecrit
 249 c
 250    30       continue
 251             call gmatoj(chaine(1:i2),obj2(jaux),iato)
 252             if ((iato.ne.0).and.(iato.ne.-1)) then
 253                mess = ' gmcpgp -> gmatoj -> codret : '
 254                write(mess(29:30),'(i2)') iato
 255                write(ulsort,*) mess
 256                call ugstop('gmcpgp',ulsort,1,1,1)
 257             endif
 258 c
 259    40    continue
 260 c
 261    50 continue
 262 c
 263       codret = 0
 264 c
 265 c====
 266 c 9. gestion des erreurs
 267 c====
 268 c
 269    91 continue
 270 c
 271       if ( codret.ne.0 ) then
 272 c
 273          iaux = 10+abs(codret)
 274 c
 275          write (ulsort,90000)
 276         write (ulsort,texte(langue,1)) 'Sortie', nompro
 277          write (ulsort,texte(langue,20)) nom1
 278          write (ulsort,texte(langue,4)) nom2
 279          write (ulsort,texte(langue,iaux))
 280          write (ulsort,90000)
 281 c
 282       endif
 283 c
 284 90000 format (1x,70('='))
 285 c
 286       end