Télécharger la plaquette Cast3M


fr en

Télécharger color.eso

Retour à la liste

Numérotation des lignes : 

color

  1. C COLOR     SOURCE    PASCAL    20/08/07    21:15:06     10687          
  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.  
  14. -INC PPARAM
  15. -INC CCOPTIO
  16. -INC SMELEME
  17. -INC CCGEOME
  18. -INC SMEVOLL
  19. -INC SMDEFOR
  20. -INC SMVECTE
  21. -INC SMLMOTS
  22.       character*8 motloc
  23. c
  24. c (fdp) Le 03 / 03 / 2015
  25. c       - Gestion des objets de type DEFORME
  26. c       - Gestion des objets de type VECTEUR
  27. c       - Possibilite de mettre un LISTMOTS pour les objets de type
  28. c         EVOLUTIO et DEFORME
  29. c
  30. c
  31. c     Acquisition de la couleur a affecter grace a un MOT ou un LISTMOTS
  32.       ILMOT=0
  33.       CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  34.       IF (IERR.NE.0) RETURN
  35. c     Cas ou l'on donne un LISTMOT
  36.       IF (IRETOU.EQ.1) THEN
  37.         ILMOT=1
  38.         SEGACT MLMOTS
  39.         NMOTS=MLMOTS.MOTS(/2)
  40.       ELSE
  41.         CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  42.         IF (IERR.NE.0) RETURN
  43.         IF (ICOUL.EQ.0) THEN
  44.           CALL LIRENT(ICOUL,0,IRETOU)
  45.           IF (IERR.NE.0) RETURN
  46.           IF (IRETOU.EQ.0) THEN
  47.             ICOUL = IDCOUL+1
  48.           ELSE
  49.             IF (ICOUL.LE.0) ICOUL=IDCOUL+1
  50.             ICOUL = MOD(ICOUL-1,NBCOUL)+1
  51. c           write(6,*) 'ICOUL =',ICOUL
  52.           ENDIF
  53.         ENDIF
  54.         ICOUL=ICOUL-1
  55.       ENDIF
  56. c
  57. c     Cas 1 : objet de type maillage
  58.       CALL LIROBJ('MAILLAGE',MELEME,0,IRETOU)
  59.       IF (IERR.NE.0) RETURN
  60.       IF (IRETOU.EQ.1) THEN
  61. c       on n'accepte pas de changer la couleur avec un LISTMOT
  62.         IF (ILMOT.EQ.1) THEN
  63.           MOTERR(1:8)='LISTMOT'
  64.           CALL ERREUR(39)
  65.         ENDIF
  66.         SEGACT MELEME
  67.         NBSOUS=LISOUS(/1)
  68.         NBREF=LISREF(/1)
  69.         NBNN=NUM(/1)
  70.         NBELEM=NUM(/2)
  71.         SEGINI ,IPT1=MELEME
  72.         ISAUV=IPT1
  73.         IF (NBREF.EQ.0) GOTO 16
  74.         DO 10 I=1,NBREF
  75.           IPT3=LISREF(I)
  76.           SEGINI ,IPT2=IPT3
  77.           IPT5=IPT2
  78.           DO 13 K=1,MAX(1,IPT2.LISOUS(/1))
  79.             IF (IPT2.LISOUS(/1).NE.0) THEN
  80.               IPT4=IPT2.LISOUS(K)
  81.               SEGINI ,IPT5=IPT4
  82.               IPT2.LISOUS(K)=IPT5
  83.             ENDIF
  84.             DO J=1,IPT5.NUM(/2)
  85.               IPT5.ICOLOR(J)=ICOUL
  86.             enddo
  87.  13       CONTINUE
  88.  14       IPT1.LISREF(I)=IPT2
  89.  10     CONTINUE
  90.  16     IF (NBELEM.NE.0) THEN
  91.           DO 20 I=1,NBELEM
  92.             IPT1.ICOLOR(I)=ICOUL
  93.  20       CONTINUE
  94.         ENDIF
  95. c       cas d'objets geometriques constitues de plusieurs objets
  96. c       geometriques elementaires
  97.         IF (NBSOUS.EQ.0) GOTO 41
  98.         NBS=NBSOUS
  99.         DO 40 I=1,NBS
  100.           IPT2=LISOUS(I)
  101.           SEGACT IPT2
  102.           NBSOUS=IPT2.LISOUS(/1)
  103.           NBREF=IPT2.LISREF(/1)
  104.           NBNN=IPT2.NUM(/1)
  105.           NBELEM=IPT2.NUM(/2)
  106.           SEGINI ,IPT3=IPT2
  107.           DO 35 J=1,NBELEM
  108.             IPT3.ICOLOR(J)=ICOUL
  109.  35       CONTINUE
  110.           IPT1.LISOUS(I)=IPT3
  111.  40     CONTINUE
  112. c       ecriture du maillage resultat et sortie
  113.  41     CONTINUE
  114.         CALL ECROBJ ('MAILLAGE',ISAUV)
  115.         GOTO 99
  116.       ENDIF
  117. c
  118. c     Cas 2 : objet de type evolution
  119.       CALL LIROBJ('EVOLUTIO',MEVOLL,0,IRETOU)
  120.       IF (IERR.NE.0) RETURN
  121.       IF (IRETOU.EQ.1) THEN
  122.         SEGACT MEVOLL
  123.         SEGINI,MEVOL1=MEVOLL
  124. c       si l'on a donne un LISTMOTS, verification de sa dimension
  125.         IF (ILMOT.EQ.1) THEN
  126.           NEVO=MEVOLL.IEVOLL(/1)
  127.           IF (NMOTS.NE.NEVO) THEN
  128.             MOTERR(1:8)='LISTMOTS'
  129.             INTERR(1)=NEVO
  130.             CALL ERREUR(1018)
  131.           ENDIF
  132.         ENDIF
  133. c       changement de couleur de toutes les evolutions elementaires
  134.         DO 50 I=1,MEVOL1.IEVOLL(/1)
  135.           KEVOLL=IEVOLL(I)
  136.           SEGINI,KEVOL1=KEVOLL
  137.           MEVOL1.IEVOLL(I)=KEVOL1
  138. c         determination de la couleur si donnee d'un LISTMOTS
  139.           IF (ILMOT.EQ.1) THEN
  140.             motloc=mlmots.mots(i)
  141.             CALL ECRCHA(MOTloc)
  142.             CALL LIRMOT(NCOUL,NBCOUL,ICOUL,1)
  143. c           on verifie meme que cette couleur est correcte
  144.             IF (ICOUL.EQ.0) THEN
  145.               MOTERR(1:4)=MLMOTS.MOTS(I)
  146.               CALL ERREUR(197)
  147.             ENDIF
  148.             ICOUL=ICOUL-1
  149.           ENDIF
  150.           KEVOL1.NUMEVX=ICOUL
  151.  50     CONTINUE
  152. c       ecriture de l'evolution resultat et sortie
  153.         CALL ECROBJ ('EVOLUTIO',MEVOL1)
  154.         GOTO 99
  155.       ENDIF
  156. c
  157. c     Cas 3 : objet de type deformee
  158.       CALL LIROBJ('DEFORME ',MDEFOR,0,IRETOU)
  159.       IF (IERR.NE.0) RETURN
  160.       IF (IRETOU.EQ.1) THEN
  161.         SEGACT MDEFOR
  162.         SEGINI,MDEFO1=MDEFOR
  163. c       si l'on a donne un LISTMOTS, verification de sa dimension
  164.         IF (ILMOT.EQ.1) THEN
  165.           NDEF=MDEFOR.JCOUL(/1)
  166.           IF (NMOTS.NE.NDEF) THEN
  167.             MOTERR(1:8)='LISTMOTS'
  168.             INTERR(1)=NDEF
  169.             CALL ERREUR(1018)
  170.           ENDIF
  171.         ENDIF
  172. c       changement de couleur de toutes les deformees
  173.         DO I=1,MDEFO1.JCOUL(/1)
  174. c         determination de la couleur si donnee d'un LISTMOTS
  175.           IF (ILMOT.EQ.1) THEN
  176.             motloc=mlmots.mots(i)
  177.             CALL ECRCHA(Motloc)
  178.             CALL LIRMOT(NCOUL,NBCOUL,ICOUL,1)
  179. c           on verifie meme que cette couleur est correcte
  180.             IF (ICOUL.EQ.0) THEN
  181.               MOTERR(1:4)=MLMOTS.MOTS(I)
  182.               CALL ERREUR(197)
  183.             ENDIF
  184.             ICOUL=ICOUL-1
  185.           ENDIF
  186.           MDEFO1.JCOUL(I)=ICOUL
  187.         ENDDO
  188. c       ecriture de la deformee resultat et sortie
  189.         SEGACT MDEFO1
  190.         CALL ECROBJ ('DEFORME ',MDEFO1)
  191.         GOTO 99
  192.       ENDIF
  193. c
  194. c     Cas 4 : objet de type vecteur
  195.       CALL LIROBJ('VECTEUR ',MVECTE,0,IRETOU)
  196.       IF (IERR.NE.0) RETURN
  197.       IF (IRETOU.EQ.1) THEN
  198.         SEGACT MVECTE
  199.         SEGINI,MVECT1=MVECTE
  200. c       si l'on a donne un LISTMOTS, verification de sa dimension
  201.         IF (ILMOT.EQ.1) THEN
  202.           NVEC=MVECTE.NOCOUL(/1)
  203.           IF (NMOTS.NE.NVEC) THEN
  204.             MOTERR(1:8)='LISTMOTS'
  205.             INTERR(1)=NVEC
  206.             CALL ERREUR(1018)
  207.           ENDIF
  208.         ENDIF
  209. c       changement de couleur de touts les vecteurs
  210.         DO I=1,MVECT1.NOCOUL(/1)
  211. c         determination de la couleur si donnee d'un LISTMOTS
  212.           IF (ILMOT.EQ.1) THEN
  213.             motloc=mlmots.mots(i)
  214.             CALL ECRCHA(Motloc)
  215.             CALL LIRMOT(NCOUL,NBCOUL,ICOUL,1)
  216. c           on verifie meme que cette couleur est correcte
  217.             IF (ICOUL.EQ.0) THEN
  218.               MOTERR(1:4)=MLMOTS.MOTS(I)
  219.               CALL ERREUR(197)
  220.             ENDIF
  221.             ICOUL=ICOUL-1
  222.           ENDIF
  223.           MVECT1.NOCOUL(I)=ICOUL
  224.         ENDDO
  225. c       ecriture du vecteur resultat et sortie
  226.         SEGACT,MVECT1
  227.         CALL ECROBJ ('VECTEUR ',MVECT1)
  228.         GOTO 99
  229.       ENDIF
  230. c
  231. c     Si l'on passe ici, c'est que l'on a pas trouve d'objets du type
  232. c     attendu
  233.       CALL ERREUR(21)
  234. c     Fin du programme
  235.  99   CONTINUE
  236.       END
  237.  
  238.  
  239.  
  240.  
  241.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales