Télécharger color.eso

Retour à la liste

Numérotation des lignes :

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

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