Esope source files

   1 : C REFE      SOURCE    CHAT      05/01/13    02:47:59     5004           
   2 :       SUBROUTINE REFE
   3 : C***********************************************************************
   4 : C
   5 : C    Opérateur REFE
   6 : C    ______________
   7 : C
   8 : C
   9 : C    OBJET : Lister les objets maillages inclus au sens des noeuds dans
  10 : C    -----   un autre ou indiquer si un objet maillage est inclus dans
  11 : C            un autre.
  12 : C
  13 : C    SYNTAXE 1 : LOBI =  REFE OBJ2 ;
  14 : C    -------
  15 : C                LOBI : objet LISTMOTS contenant la liste
  16 : C
  17 : C
  18 : C    SYNTAXE 2 : LOGI = OBJ1 REFE OBJ2 ;
  19 : C    -------
  20 : C                LOGI : objet de type LOGIQUE prenant les valeurs VRAI
  21 : C                       ou FAUX suivant que OBJ1 est inclus ou non dans
  22 : C                       OBJ2
  23 : C
  24 : C***********************************************************************
  25 :       IMPLICIT INTEGER(I-N)
  26 :       IMPLICIT REAL*8 (A-H,O-Z)
  27 : C
  28 : -INC CCOPTIO
  29 : -INC SMELEME
  30 : -INC SMLMOTS
  31 : -INC SMCOORD
  32 : -INC SMLENTI
  33 : C
  34 :       SEGMENT IZTGN
  35 :               CHARACTER*8 NOML(0)
  36 :       ENDSEGMENT
  37 :       SEGMENT/IZTGP/(IPTL(0))
  38 :       SEGMENT TABOG
  39 :               CHARACTER*8 NOMOG(0)
  40 :       ENDSEGMENT
  41 :       SEGMENT TIBOG
  42 :               INTEGER NIMOG(0)
  43 :       ENDSEGMENT
  44 : C
  45 : C- Décodage des arguments et détermination de la syntaxe utilisée :
  46 : C-    CAS 1 : On fait la liste de tous les objets inclus dans obj1
  47 : C-    CAS 2 : On regarde si obj1 est inclus dans obj2
  48 : C
  48 :       CALL LIROBJ('MAILLAGE',MELEM1,1,IRETOU)
  49 :       IF (IRETOU.NE.1) RETURN
  49 :       CALL LIROBJ('MAILLAGE',MELEM2,0,IRETOU)
  50 :       IF (IRETOU.EQ.0) THEN
  51 :          IKAS   = 1
  52 :          MELEME = MELEM1
  53 :       ELSE
  54 :          IKAS   = 2
  55 :          MELEME = MELEM2
  56 :       ENDIF
  57 :       MELEM0 = MELEME
  58 : C
  59 : C- Initialisation du LISTENTI de travail indiquant si le point
  60 : C- numéro I est dans le maillage;
  61 : C-    LECT(I)<>0 : Le point numéro I est dans le MELEME 
  62 : C
  63 :       SEGACT MCOORD
  64 :       NBNOUV = XCOOR(/1)/(IDIM+1)
  65 :       JG     = NBNOUV
  66 :       SEGINI MLENTI
  67 :       SEGACT MELEME
  68 :       NBSOUS = LISOUS(/1)
  69 :       IF (NBSOUS.EQ.0) NBSOUS=1
  70 :       NPTD = 0
  71 :       DO 20 KS=1,NBSOUS
  72 :          IF (NBSOUS.EQ.1) THEN
  73 :             IPT1 = MELEME
  74 :          ELSE
  75 :             IPT1 = LISOUS(KS)
  76 :          ENDIF
  77 :          SEGACT IPT1
  78 :          NP  = IPT1.NUM(/1)
  79 :          NEL = IPT1.NUM(/2)
  80 :          DO 10 K=1,NEL
  81 :             DO 10 N=1,NP
  82 :                IF (LECT(IPT1.NUM(N,K)).EQ.0) THEN
  83 :                   NPTD                = NPTD + 1
  84 :                   LECT(IPT1.NUM(N,K)) = NPTD
  85 :                ENDIF
  86 :  10      CONTINUE
  87 :          IF (MELEME.NE.IPT1) SEGDES IPT1
  88 :  20   CONTINUE
  89 :       SEGDES MELEME
  90 : C
  91 : C- Liste des objets maillage à comparer à MELEM0
  92 : C
  93 :       IF (IKAS.EQ.1) THEN
  94 :          IZTGN = 0
  95 :          IZTGP = 0
  95 :          CALL LFILE('        ','MAILLAGE',IZTGN,IZTGP)
  96 :          IF (IERR.NE.0) THEN
  97 :             SEGSUP MLENTI
  98 :             RETURN
  99 :          ENDIF
 100 :          SEGACT IZTGN,IZTGP
 101 :       ELSE
 102 :          SEGINI IZTGN,IZTGP
 103 :          NOML(**) = 'INDEFINI'
 104 :          IPTL(**) = MELEM1
 105 :       ENDIF
 106 : C
 107 : C- Inclusion au sens des points des maillages de pointeur IPTL(L)
 108 : C- et de nom NOML(L) dans le maillage de pointeur MELEM0.
 109 : C
 110 :       SEGINI TABOG,TIBOG
 111 :       NL = IPTL(/1)
 112 :       DO 60 L=1,NL
 113 :          MELEME = IPTL(L)
 114 :          IPT1   = MELEME
 115 :          IF (MELEME.EQ.MELEM0) THEN
 116 :             NOMOG(**) = NOML(L)
 117 :             NIMOG(**) = IPTL(L)
 118 :          ELSE
 119 :             SEGACT MELEME
 120 :             NBSOUS = LISOUS(/1)
 121 :             IF (NBSOUS.EQ.0) NBSOUS=1
 122 :             DO 40 KS=1,NBSOUS
 123 :                IF (NBSOUS.EQ.1) THEN
 124 :                   IPT1 = MELEME
 125 :                ELSE
 126 :                   IPT1 = LISOUS(KS)
 127 :                ENDIF
 128 :                SEGACT IPT1
 129 :                NP  = IPT1.NUM(/1)
 130 :                NEL = IPT1.NUM(/2)
 131 :                DO 30 K=1,NEL
 132 :                   DO 30 I=1,NP
 133 :                      NU = LECT(IPT1.NUM(I,K))
 134 :                      IF (NU.EQ.0) GOTO 50
 135 :  30            CONTINUE
 136 :                SEGDES IPT1
 137 :  40         CONTINUE
 138 :             NOMOG(**) = NOML(L)
 139 :             NIMOG(**) = IPTL(L)
 140 :  50         CONTINUE
 141 :             SEGDES IPT1
 142 :             SEGDES MELEME
 143 :          ENDIF
 144 :  60   CONTINUE
 145 : C
 146 : C- Ecriture du résultat et ménage
 147 : C
 148 :       NBO = NIMOG(/1)
 149 :       IF (IKAS.EQ.1) THEN
 150 :          JGM = NOMOG(/2)
 151 :          JGN = 8
 152 :          SEGINI MLMOTS
 153 :          IF (JGM.EQ.0) THEN
 153 :             CALL ERREUR(-313)
 154 :          ELSE
 155 :             DO 70 I=1,JGM
 156 :                MOTS(I) = NOMOG(I)
 157 :  70         CONTINUE
 158 :          ENDIF
 159 :          SEGDES MLMOTS
 159 :          CALL ECROBJ('LISTMOTS',MLMOTS)
 160 :       ELSE
 161 :          IF (NBO.EQ.0) THEN
 161 :             CALL ECRLOG(.FALSE.)
 162 :          ELSE
 162 :             CALL ECRLOG(.TRUE.)
 163 :          ENDIF
 164 :       ENDIF
 165 :       SEGSUP IZTGN,IZTGP,TABOG,TIBOG,MLENTI
 166 :       RETURN                                                                
 167 :       END                          
 168 :  
 169 :