Esope source files

   1 : C COLOR     SOURCE    CHAT      07/10/29    21:16:26     5940           
   2 : c=======================================================================
   3 : c
   4 : c ce module permet de changer la couleur d'un objet donné.
   5 : c      maillage ou evolution
   6 : c
   7 : c=======================================================================
   8 : c
   9 :       SUBROUTINE COLOR
  10 : c
  11 : c=======================================================================
  12 :       IMPLICIT INTEGER(I-N)
  13 : -INC SMELEME
  14 : -INC CCGEOME
  15 : -INC CCOPTIO
  16 : -INC SMEVOLL
  17 : c
  17 :       CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  18 :       IF (ICOUL.EQ.0) ICOUL=IDCOUL+1
  19 :       ICOUL=ICOUL-1
  20 : c
  20 :       CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
  21 :       IF (IERR.NE.0) RETURN
  22 : c
  23 :       IF (IRETOU .EQ. 1 ) THEN
  24 : c
  25 : c    cas d'un objet de type maillage
  26 : c
  27 :         SEGACT MELEME
  28 :         NBSOUS=LISOUS(/1)
  29 :         NBREF=LISREF(/1)
  30 :         NBNN=NUM(/1)
  31 :         NBELEM=NUM(/2)
  32 :         SEGINI ,IPT1=MELEME
  33 :         ISAUV=IPT1
  34 :         IF (NBREF.EQ.0) GOTO16
  35 : c
  36 :         DO 10 I=1,NBREF
  37 :          IPT3=LISREF(I)
  38 :          SEGINI ,IPT2=IPT3
  39 :          IPT5=IPT2
  40 :          DO 13 K=1,MAX(1,IPT2.LISOUS(/1))
  41 :            IF (IPT2.LISOUS(/1).NE.0) THEN
  42 :             IPT4=IPT2.LISOUS(K)
  43 :             SEGINI ,IPT5=IPT4
  44 :             IPT2.LISOUS(K)=IPT5
  45 :            ENDIF
  46 :            DO 11 J=1,IPT5.NUM(/2)
  47 :  11        IPT5.ICOLOR(J)=ICOUL
  48 :            IF (IPT2.LISOUS(/1).NE.0) SEGDES IPT5
  49 :  13      CONTINUE
  50 :  14      IPT1.LISREF(I)=IPT2
  51 :          SEGDES IPT2
  52 :  10    CONTINUE
  53 : c
  54 :  16    IF (NBELEM.NE.0) THEN
  55 :          DO 20 I=1,NBELEM
  56 :               IPT1.ICOLOR(I)=ICOUL
  57 :  20      CONTINUE
  58 :        ENDIF
  59 :        IF (NBSOUS.EQ.0) GOTO 41
  60 : c
  61 : c  cas d'objets geometriques constitues de plusieurs objets geometriques
  62 : c  elementaires
  63 : c
  64 :         NBS=NBSOUS
  65 :         DO 40 I=1,NBS
  66 :               IPT2=LISOUS(I)
  67 :               SEGACT IPT2
  68 :               NBSOUS=IPT2.LISOUS(/1)
  69 :               NBREF=IPT2.LISREF(/1)
  70 :               NBNN=IPT2.NUM(/1)
  71 :               NBELEM=IPT2.NUM(/2)
  72 :               SEGINI ,IPT3=IPT2
  73 :               DO 35 J=1,NBELEM
  74 :                         IPT3.ICOLOR(J)=ICOUL
  75 :  35           CONTINUE
  76 :               IPT1.LISOUS(I)=IPT3
  77 :               SEGDES IPT2,IPT3
  78 :  40      CONTINUE
  79 : c
  80 : c    ecriture du maillage résultat
  81 : c
  82 :  41      SEGDES MELEME,IPT1
  82 :          CALL ECROBJ ('MAILLAGE',ISAUV)
  83 : c
  84 :        ELSE
  85 : c
  86 : c     cas d'un objet evolution
  87 : c
  87 :           CALL LIROBJ('EVOLUTIO',MEVOLL,1,IRETOU)
  88 :           IF (IERR .NE. 0) RETURN
  89 :           SEGACT MEVOLL
  90 : c
  91 :           SEGINI,MEVOL1=MEVOLL
  92 :           DO 50 I=1,(MEVOL1.IEVOLL(/1))
  93 :             KEVOLL=IEVOLL(I)
  94 :             SEGINI,KEVOL1=KEVOLL
  95 :             MEVOL1.IEVOLL(I)=KEVOL1
  96 :             KEVOL1.NUMEVX = ICOUL 
  97 :             SEGDES KEVOL1
  98 :  50       CONTINUE
  99 :           SEGDES MEVOL1,MEVOLL
  99 :          CALL ECROBJ ('EVOLUTIO',MEVOL1)
 100 :       ENDIF          
 101 :       RETURN
 102 :       END
 103 :  
 104 :  
 105 :  
 106 :  
 107 :  
 108 :  
 109 :  
 110 :  
 111 :