Sources Esope | Cast3M

refe
C REFE      SOURCE    PV        20/03/30    21:23:48     10567          
      SUBROUTINE REFE
C***********************************************************************
C
C    Opérateur REFE
C    ______________
C
C
C    OBJET : Lister les objets maillages inclus au sens des noeuds dans
C    -----   un autre ou indiquer si un objet maillage est inclus dans
C            un autre.
C
C    SYNTAXE 1 : LOBI =  REFE OBJ2 ;
C    -------
C                LOBI : objet LISTMOTS contenant la liste
C
C
C    SYNTAXE 2 : LOGI = OBJ1 REFE OBJ2 ;
C    -------
C                LOGI : objet de type LOGIQUE prenant les valeurs VRAI
C                       ou FAUX suivant que OBJ1 est inclus ou non dans
C                       OBJ2
C
C***********************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC CCNOYAU
-INC SMELEME
-INC SMLMOTS
-INC SMCOORD
-INC SMLENTI
C
      SEGMENT IZTGN
              CHARACTER*(LONOM) NOML(0)
      ENDSEGMENT
      SEGMENT/IZTGP/(IPTL(0))
      SEGMENT TABOG
              CHARACTER*(LONOM) NOMOG(0)
      ENDSEGMENT
      SEGMENT TIBOG
              INTEGER NIMOG(0)
      ENDSEGMENT
C
C- Décodage des arguments et détermination de la syntaxe utilisée :
C-    CAS 1 : On fait la liste de tous les objets inclus dans obj1
C-    CAS 2 : On regarde si obj1 est inclus dans obj2
C
      CALL LIROBJ('MAILLAGE',MELEM1,1,IRETOU)
      IF (IRETOU.NE.1) RETURN
      CALL LIROBJ('MAILLAGE',MELEM2,0,IRETOU)
      IF (IRETOU.EQ.0) THEN
         IKAS   = 1
         MELEME = MELEM1
      ELSE
         IKAS   = 2
         MELEME = MELEM2
      ENDIF
      MELEM0 = MELEME
C
C- Initialisation du LISTENTI de travail indiquant si le point
C- numéro I est dans le maillage;
C-    LECT(I)&lt;>0 : Le point numéro I est dans le MELEME
C
      SEGACT MCOORD
      NBNOUV = nbpts
      JG     = NBNOUV
      SEGINI MLENTI
      SEGACT MELEME
      NBSOUS = LISOUS(/1)
      IF (NBSOUS.EQ.0) NBSOUS=1
      NPTD = 0
      DO 20 KS=1,NBSOUS
         IF (NBSOUS.EQ.1) THEN
            IPT1 = MELEME
         ELSE
            IPT1 = LISOUS(KS)
         ENDIF
         SEGACT IPT1
         NP  = IPT1.NUM(/1)
         NEL = IPT1.NUM(/2)
         DO 10 K=1,NEL
            DO 10 N=1,NP
               IF (LECT(IPT1.NUM(N,K)).EQ.0) THEN
                  NPTD                = NPTD + 1
                  LECT(IPT1.NUM(N,K)) = NPTD
               ENDIF
 10      CONTINUE
 20   CONTINUE
C
C- Liste des objets maillage à comparer à MELEM0
C
      IF (IKAS.EQ.1) THEN
         IZTGN = 0
         IZTGP = 0
         CALL LFILE('        ','MAILLAGE',IZTGN,IZTGP)
         IF (IERR.NE.0) THEN
            SEGSUP MLENTI
            RETURN
         ENDIF
         SEGACT IZTGN,IZTGP
      ELSE
         SEGINI IZTGN,IZTGP
         NOML(**) = 'INDEFINI'
         IPTL(**) = MELEM1
      ENDIF
C
C- Inclusion au sens des points des maillages de pointeur IPTL(L)
C- et de nom NOML(L) dans le maillage de pointeur MELEM0.
C
      SEGINI TABOG,TIBOG
      NL = IPTL(/1)
      DO 60 L=1,NL
         MELEME = IPTL(L)
         IPT1   = MELEME
         IF (MELEME.EQ.MELEM0) THEN
            NOMOG(**) = NOML(L)
            NIMOG(**) = IPTL(L)
         ELSE
            SEGACT MELEME
            NBSOUS = LISOUS(/1)
            IF (NBSOUS.EQ.0) NBSOUS=1
            DO 40 KS=1,NBSOUS
               IF (NBSOUS.EQ.1) THEN
                  IPT1 = MELEME
               ELSE
                  IPT1 = LISOUS(KS)
               ENDIF
               SEGACT IPT1
               NP  = IPT1.NUM(/1)
               NEL = IPT1.NUM(/2)
               DO 30 K=1,NEL
                  DO 30 I=1,NP
                     NU = LECT(IPT1.NUM(I,K))
                     IF (NU.EQ.0) GOTO 50
 30            CONTINUE
 40         CONTINUE
            NOMOG(**) = NOML(L)
            NIMOG(**) = IPTL(L)
 50         CONTINUE
         ENDIF
 60   CONTINUE
C
C- Ecriture du résultat et ménage
C
      NBO = NIMOG(/1)
      IF (IKAS.EQ.1) THEN
         JGM = NOMOG(/2)
         JGN = 8
         SEGINI MLMOTS
         IF (JGM.EQ.0) THEN
            CALL ERREUR(-313)
         ELSE
            DO 70 I=1,JGM
               MOTS(I) = NOMOG(I)
 70         CONTINUE
         ENDIF
         SEGACT,MLMOTS
         CALL ECROBJ('LISTMOTS',MLMOTS)
      ELSE
         IF (NBO.EQ.0) THEN
            CALL ECRLOG(.FALSE.)
         ELSE
            CALL ECRLOG(.TRUE.)
         ENDIF
      ENDIF
      SEGSUP IZTGN,IZTGP,TABOG,TIBOG,MLENTI
      END