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. -INC CCOPTIO
  22. C
  23. DIMENSION ICLET(50)
  24. 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,
  25. # 24*7/
  26. CALL LIROBJ ('MAILLAGE',MELEME,1,IRETOU)
  27. IF (IERR.NE.0) RETURN
  28. SEGACT MELEME
  29. SEGINI ,IPT1=MELEME
  30. IF (IPT1.LISOUS(/1).NE.0) THEN
  31. DO 10 I=1,IPT1.LISOUS(/1)
  32. IPT2=IPT1.LISOUS(I)
  33. SEGINI ,IPT3=IPT2
  34. IPT1.LISOUS(I)=IPT3
  35. IF (IPT3.ITYPEL.NE.0.AND.IPT3.ITYPEL.LE.50) THEN
  36. DO 15 J=1,IPT3.NUM(/2)
  37. 15 IPT3.ICOLOR(J)=ICLET(IPT3.ITYPEL)
  38. ENDIF
  39. SEGDES IPT3
  40. 10 CONTINUE
  41. ELSE
  42. IF (IPT1.ITYPEL.NE.0.AND.IPT1.ITYPEL.LE.50) THEN
  43. DO 20 I=1,IPT1.NUM(/2)
  44. 20 IPT1.ICOLOR(I)=ICLET(IPT1.ITYPEL)
  45. ENDIF
  46. ENDIF
  47. SEGDES MELEME,IPT1
  48. CALL ECROBJ('MAILLAGE',IPT1)
  49. RETURN
  50. END
  51.  
  52.  
  53.  
  54.  
  55.  

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