Télécharger afcoul.eso

Retour à la liste

Numérotation des lignes :

  1. C AFCOUL SOURCE CHAT 05/01/12 21:19:17 5004
  2. C=======================================================================
  3. C
  4. C CE MODULE PERMET D'AFFECTER UNE COULEUR SPECIFIQUE POUR CHAQUE
  5. C SOUS-OBJET D'UN ELEMENT DONNE.
  6. C
  7. C BLEU : SEG2,TRI3,CUB8,TET4,LIA3
  8. C ROUGE : QUA4,PRI6,PYR5,RAC2,LIA4
  9. C ROSE : SEG3,TRI6,CU20,TE10,LIA6
  10. C VERT : QUA8,PR15,PY13,RAC3,LIA8
  11. C TURQUOISE : TRI4,QUA5
  12. C JAUNE : TRI7,QUA9
  13. C BLANC : MULT
  14. C=======================================================================
  15. C
  16. SUBROUTINE AFCOUL
  17. C
  18. C=======================================================================
  19. IMPLICIT INTEGER(I-N)
  20. -INC SMELEME
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. C
  25. DIMENSION ICLET(50)
  26. DATA ICLET/70,1,3,1,5,3,6,2,5,4,6,2,4,3,3,4,4,1,2,3,4,7,1,3,2,4,
  27. # 24*7/
  28. CALL LIROBJ ('MAILLAGE',MELEME,1,IRETOU)
  29. IF (IERR.NE.0) RETURN
  30. SEGACT MELEME
  31. SEGINI ,IPT1=MELEME
  32. IF (IPT1.LISOUS(/1).NE.0) THEN
  33. DO 10 I=1,IPT1.LISOUS(/1)
  34. IPT2=IPT1.LISOUS(I)
  35. SEGINI ,IPT3=IPT2
  36. IPT1.LISOUS(I)=IPT3
  37. IF (IPT3.ITYPEL.NE.0.AND.IPT3.ITYPEL.LE.50) THEN
  38. DO 15 J=1,IPT3.NUM(/2)
  39. 15 IPT3.ICOLOR(J)=ICLET(IPT3.ITYPEL)
  40. ENDIF
  41. SEGDES IPT3
  42. 10 CONTINUE
  43. ELSE
  44. IF (IPT1.ITYPEL.NE.0.AND.IPT1.ITYPEL.LE.50) THEN
  45. DO 20 I=1,IPT1.NUM(/2)
  46. 20 IPT1.ICOLOR(I)=ICLET(IPT1.ITYPEL)
  47. ENDIF
  48. ENDIF
  49. SEGDES MELEME,IPT1
  50. CALL ECROBJ('MAILLAGE',IPT1)
  51. RETURN
  52. END
  53.  
  54.  
  55.  
  56.  
  57.  

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