src/tool/Gestion_MTU/gmcpoj.F

   1       subroutine gmcpoj (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 l'objet 'nom1' a la place de l'objet 'nom2'
  23 c     'nom1' et 'nom2' doivent etre de meme type
  24 c     s'ils sont de type structure : on copie les attributs
  25 c     s'ils sont de type simple    : on copie le contenu
  26 c
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nom1   . e   . char(*). nom etendu source                          .
  32 c . nom2   . e   .char(*) . nom etendu destinataire                    .
  33 c . codret .  s  . ent    . code retour de l'operation                 .
  34 c .        .     .        .  0 : OK                                    .
  35 c .        .     .        . -1 : 'nom1' invalide ou non alloue         .
  36 c .        .     .        . -2 : objets destinataire et source ne sont .
  37 c .        .     .        .      pas de meme type                      .
  38 c .        .     .        . -3 : nom etendu invalide                   .
  39 c .        .     .        . -4 : premier caractere interdit            .
  40 c ______________________________________________________________________
  41 c
  42 c====
  43 c 0. declarations et dimensionnement
  44 c====
  45 c
  46 c 0.1. ==> generalites
  47 c
  48       implicit none
  49       save
  50 c
  51 #include "gmmatc.h"
  52 c
  53 c 0.2. ==> communs
  54 c
  55 #include "gmtori.h"
  56 #include "gmtoai.h"
  57 #include "gmtors.h"
  58 #include "gmtoas.h"
  59 #include "gmenti.h"
  60 #include "gmreel.h"
  61 #include "gmstri.h"
  62 c
  63 #include "gmimpr.h"
  64 #include "gmcoer.h"
  65 c
  66 c 0.3. ==> arguments
  67 c
  68       integer       codret
  69       character*(*) nom1,nom2
  70 c
  71 c 0.4. ==> variables locales
  72 c
  73       logical detlg0
  74 c
  75       character*8   obrep1,obter1,chter1
  76       character*8   obrep2,obter2,chter2
  77       character*8   letype
  78       character*8   typ1
  79       character*40  mess
  80 c
  81       integer ide1,ioa1,ity1,ide2,ioa2,ity2
  82       integer ial2,irt2,iob1,ity,nba,iob2,ia,iat1,iat2
  83       integer long1,iad1,long2,iad2,il,llres
  84       integer nrotab
  85 c
  86 c 1.  decodage du nom etendu 'nom1'
  87 c
  88       codret = 0
  89       call gbdnoe(nom1,obrep1,obter1,chter1,ide1)
  90 c
  91       if ((ide1.lt.0).or.(ide1.eq.1).or.(ide1.eq.2)) then
  92 c
  93 c        'nom1' invalide ou non alloue
  94 c
  95         codret = -1
  96         goto 9999
  97 c
  98       else
  99 c
 100 c        ide1 = 0 ou 3
 101 c
 102         call gbobal(obter1,ity1,ioa1)
 103 c
 104         if (ioa1.eq.0) then
 105           codret = -1
 106           goto 9999
 107         endif
 108 c
 109       endif
 110 c
 111 c 2.  copie de obter1
 112 c
 113       if (ioa1.eq.1) then
 114 c
 115 c 2.1.   obter1 est un objet structure (alloue)
 116 c
 117 c        decodage de nom2
 118 c
 119         typ1 = nomtyp(ity1)
 120         call gbdnoe(nom2,obrep2,obter2,chter2,ide2)
 121         if (ide2.lt.0) then
 122           codret = -3
 123           goto 9999
 124         else if (ide2.eq.0) then
 125           call gbobal(obter2,ity2,ioa2)
 126           if (ioa2.eq.0) then
 127             call gmaloj(obter2,typ1,0,ial2,irt2)
 128             if (irt2.eq.-3) then
 129               codret = -2
 130               goto 9999
 131             endif
 132             if (irt2.eq.-7) then
 133               codret = -4
 134               goto 9999
 135             endif
 136             if ((irt2.ne.0).and.(irt2.ne.-5)) then
 137               mess = ' gmcpoj -> gmaloj -> codret : '
 138               write(mess(29:30),'(i2)') irt2
 139               write(ulsort,*) mess
 140               call ugstop('gmcpoj',ulsort,1,1,1)
 141             endif
 142             ity2 = ity1
 143           endif
 144         else
 145           if (ide2.ne.3) then
 146             call gmaloj(nom2,typ1,0,ial2,irt2)
 147             if (irt2.eq.-3) then
 148               codret = -2
 149               goto 9999
 150             endif
 151             if (irt2.eq.-7) then
 152               codret = -4
 153               goto 9999
 154             endif
 155             if ((irt2.ne.0).and.(irt2.ne.-5)) then
 156               mess = ' gmcpoj -> gmaloj -> codret : '
 157               write(mess(29:30),'(i2)') irt2
 158               write(ulsort,*) mess
 159               call ugstop('gmcpoj',ulsort,1,1,1)
 160             endif
 161             ity2 = ity1
 162           endif
 163           call gbdnoe(nom2,obrep2,obter2,chter2,ide2)
 164           call gbobal(obter2,ity2,ioa2)
 165         endif
 166 c
 167         if (ity1.ne.ity2) then
 168           codret = -2
 169           goto 9999
 170         endif
 171 c
 172         do 10 , iob1 = 1,iptobj-1
 173           if (nomobj(iob1).eq.obter1) then
 174             goto 11
 175           endif
 176    10   continue
 177         codret = -1
 178         goto 9999
 179 c
 180    11   continue
 181         ity = typobj(iob1)
 182         nba = nbratt(ity)
 183 c
 184         do 12 , iob2 = 1,iptobj-1
 185           if (nomobj(iob2).eq.obter2) then
 186             goto 13
 187           endif
 188    12   continue
 189         codret = -3
 190         goto 9999
 191 c
 192    13   continue
 193         do 14 , ia = 1,nba
 194           iat1 = adrdsa(iob1)+ia-1
 195           iat2 = adrdsa(iob2)+ia-1
 196           valatt(iat2) = valatt(iat1)
 197    14   continue
 198 c
 199       else if (ioa1.eq.2) then
 200 c
 201 c 2.2.   obter1 est un objet simple (alloue)
 202 c
 203         call gbcara(obter1,nrotab,iad1,long1,letype)
 204 c
 205         typ1 = nomtyb(-ity1)
 206 c
 207 c        decodage de nom2
 208 c
 209         call gbdnoe(nom2,obrep2,obter2,chter2,ide2)
 210         if (ide2.lt.0) then
 211           codret = -3
 212           goto 9999
 213         else if (ide2.eq.0) then
 214           call gbobal(obter2,ity2,ioa2)
 215           if (ioa2.eq.0) then
 216             call gmaloj(obter2,typ1,long1,ial2,irt2)
 217             if (irt2.eq.-3) then
 218               codret = -2
 219               goto 9999
 220             endif
 221             if (irt2.eq.-7) then
 222               codret = -4
 223               goto 9999
 224             endif
 225             if ((irt2.ne.0).and.(irt2.ne.-5)) then
 226               mess = ' gmcpoj -> gmaloj -> codret : '
 227               write(mess(29:30),'(i2)') irt2
 228               write(ulsort,*) mess
 229               call ugstop('gmcpoj',ulsort,1,1,1)
 230             endif
 231             ity2 = ity1
 232           endif
 233         else
 234           if (ide2.ne.3) then
 235             call gmaloj(nom2,typ1,long1,ial2,irt2)
 236             if (irt2.eq.-3) then
 237               codret = -2
 238               goto 9999
 239             endif
 240             if (irt2.eq.-7) then
 241               codret = -4
 242               goto 9999
 243             endif
 244             if ((irt2.ne.0).and.(irt2.ne.-5)) then
 245               mess = ' gmcpoj -> gmaloj -> codret : '
 246               write(mess(29:30),'(i2)') irt2
 247               write(ulsort,*) mess
 248               call ugstop('gmcpoj',ulsort,1,1,1)
 249             endif
 250             ity2 = ity1
 251           endif
 252           call gbdnoe(nom2,obrep2,obter2,chter2,ide2)
 253           call gbobal(obter2,ity2,ioa2)
 254         endif
 255 c
 256         if (ity1.ne.ity2) then
 257            codret = -2
 258            goto 9999
 259         endif
 260 c
 261         call gbcara(obter2,nrotab,iad2,long2,letype)
 262 c
 263         if (long1.gt.long2) then
 264 c
 265           call gmdesa(obter2)
 266           if ( coergm.ne.0 ) then
 267             codret = coergm
 268             goto 9999
 269           endif
 270 c
 271           if (ity1.eq.-1) then
 272             call gmaloi(obter2,iad2,long1)
 273           else if (ity1.eq.-2) then
 274             call gmalor(obter2,iad2,long1)
 275           else if (ity1.eq.-3) then
 276             call gmalos(obter2,iad2,long1)
 277           endif
 278         endif
 279 c
 280         if (typ1.eq.nomtyb(1)) then
 281           do 21 , il = 1,long1
 282             imem(iad2+il-1) = imem(iad1+il-1)
 283    21     continue
 284         else if (typ1.eq.nomtyb(2)) then
 285           do 22 , il = 1,long1
 286             rmem(iad2+il-1) = rmem(iad1+il-1)
 287    22     continue
 288         else if (typ1.eq.nomtyb(3)) then
 289           do 23 , il = 1,long1
 290             smem(iad2+il-1) = smem(iad1+il-1)
 291    23     continue
 292         endif
 293 c
 294         if (long1.lt.long2) then
 295           llres = long2-long1
 296           detlg0 = .false.
 297           if (ity1.eq.-1) then
 298             call gmdesi(obter2,llres,detlg0)
 299           else if (ity1.eq.-2) then
 300             call gmdesr(obter2,llres,detlg0)
 301           else if (ity1.eq.-3) then
 302             call gmdess(obter2,llres,detlg0)
 303           endif
 304         endif
 305       endif
 306 c
 307  9999 continue
 308 c
 309       end