Télécharger color.eso

Retour à la liste

Numérotation des lignes :

  1. C COLOR SOURCE BP208322 16/11/18 21:15:35 9177
  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. IF (IPT2.LISOUS(/1).NE.0) SEGDES IPT5
  73. 13 CONTINUE
  74. 14 IPT1.LISREF(I)=IPT2
  75. SEGDES IPT2
  76. 10 CONTINUE
  77. 16 IF (NBELEM.NE.0) THEN
  78. DO 20 I=1,NBELEM
  79. IPT1.ICOLOR(I)=ICOUL
  80. 20 CONTINUE
  81. ENDIF
  82. c cas d'objets geometriques constitues de plusieurs objets
  83. c geometriques elementaires
  84. IF (NBSOUS.EQ.0) GOTO 41
  85. NBS=NBSOUS
  86. DO 40 I=1,NBS
  87. IPT2=LISOUS(I)
  88. SEGACT IPT2
  89. NBSOUS=IPT2.LISOUS(/1)
  90. NBREF=IPT2.LISREF(/1)
  91. NBNN=IPT2.NUM(/1)
  92. NBELEM=IPT2.NUM(/2)
  93. SEGINI ,IPT3=IPT2
  94. DO 35 J=1,NBELEM
  95. IPT3.ICOLOR(J)=ICOUL
  96. 35 CONTINUE
  97. IPT1.LISOUS(I)=IPT3
  98. SEGDES IPT2,IPT3
  99. 40 CONTINUE
  100. c ecriture du maillage resultat et sortie
  101. 41 SEGDES MELEME,IPT1
  102. CALL ECROBJ ('MAILLAGE',ISAUV)
  103. GOTO 99
  104. ENDIF
  105. c
  106. c Cas 2 : objet de type evolution
  107. CALL LIROBJ('EVOLUTIO',MEVOLL,0,IRETOU)
  108. IF (IERR.NE.0) RETURN
  109. IF (IRETOU.EQ.1) THEN
  110. SEGACT MEVOLL
  111. SEGINI,MEVOL1=MEVOLL
  112. c si l'on a donne un LISTMOTS, verification de sa dimension
  113. IF (ILMOT.EQ.1) THEN
  114. NEVO=MEVOLL.IEVOLL(/1)
  115. IF (NMOTS.NE.NEVO) THEN
  116. MOTERR(1:8)='LISTMOTS'
  117. INTERR(1)=NEVO
  118. CALL ERREUR(1018)
  119. ENDIF
  120. ENDIF
  121. c changement de couleur de toutes les evolutions elementaires
  122. DO 50 I=1,MEVOL1.IEVOLL(/1)
  123. KEVOLL=IEVOLL(I)
  124. SEGINI,KEVOL1=KEVOLL
  125. MEVOL1.IEVOLL(I)=KEVOL1
  126. c determination de la couleur si donnee d'un LISTMOTS
  127. IF (ILMOT.EQ.1) THEN
  128. CALL ECRCHA(MLMOTS.MOTS(I))
  129. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,1)
  130. c on verifie meme que cette couleur est correcte
  131. IF (ICOUL.EQ.0) THEN
  132. MOTERR(1:4)=MLMOTS.MOTS(I)
  133. CALL ERREUR(197)
  134. ENDIF
  135. ICOUL=ICOUL-1
  136. ENDIF
  137. KEVOL1.NUMEVX=ICOUL
  138. SEGDES KEVOL1
  139. 50 CONTINUE
  140. c ecriture de l'evolution resultat et sortie
  141. SEGDES MEVOL1,MEVOLL
  142. IF (ILMOT.EQ.1) SEGDES MLMOTS
  143. CALL ECROBJ ('EVOLUTIO',MEVOL1)
  144. GOTO 99
  145. ENDIF
  146. c
  147. c Cas 3 : objet de type deformee
  148. CALL LIROBJ('DEFORME ',MDEFOR,0,IRETOU)
  149. IF (IERR.NE.0) RETURN
  150. IF (IRETOU.EQ.1) THEN
  151. SEGACT MDEFOR
  152. SEGINI,MDEFO1=MDEFOR
  153. c si l'on a donne un LISTMOTS, verification de sa dimension
  154. IF (ILMOT.EQ.1) THEN
  155. NDEF=MDEFOR.JCOUL(/1)
  156. IF (NMOTS.NE.NDEF) THEN
  157. MOTERR(1:8)='LISTMOTS'
  158. INTERR(1)=NDEF
  159. CALL ERREUR(1018)
  160. ENDIF
  161. ENDIF
  162. c changement de couleur de toutes les deformees
  163. DO I=1,MDEFO1.JCOUL(/1)
  164. c determination de la couleur si donnee d'un LISTMOTS
  165. IF (ILMOT.EQ.1) THEN
  166. CALL ECRCHA(MLMOTS.MOTS(I))
  167. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,1)
  168. c on verifie meme que cette couleur est correcte
  169. IF (ICOUL.EQ.0) THEN
  170. MOTERR(1:4)=MLMOTS.MOTS(I)
  171. CALL ERREUR(197)
  172. ENDIF
  173. ICOUL=ICOUL-1
  174. ENDIF
  175. MDEFO1.JCOUL(I)=ICOUL
  176. ENDDO
  177. c ecriture de la deformee resultat et sortie
  178. SEGDES MDEFO1,MDEFOR
  179. IF (ILMOT.EQ.1) SEGDES MLMOTS
  180. CALL ECROBJ ('DEFORME ',MDEFO1)
  181. GOTO 99
  182. ENDIF
  183. c
  184. c Cas 4 : objet de type vecteur
  185. CALL LIROBJ('VECTEUR ',MVECTE,0,IRETOU)
  186. IF (IERR.NE.0) RETURN
  187. IF (IRETOU.EQ.1) THEN
  188. SEGACT MVECTE
  189. SEGINI,MVECT1=MVECTE
  190. c si l'on a donne un LISTMOTS, verification de sa dimension
  191. IF (ILMOT.EQ.1) THEN
  192. NVEC=MVECTE.NOCOUL(/1)
  193. IF (NMOTS.NE.NVEC) THEN
  194. MOTERR(1:8)='LISTMOTS'
  195. INTERR(1)=NVEC
  196. CALL ERREUR(1018)
  197. ENDIF
  198. ENDIF
  199. c changement de couleur de touts les vecteurs
  200. DO I=1,MVECT1.NOCOUL(/1)
  201. c determination de la couleur si donnee d'un LISTMOTS
  202. IF (ILMOT.EQ.1) THEN
  203. CALL ECRCHA(MLMOTS.MOTS(I))
  204. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,1)
  205. c on verifie meme que cette couleur est correcte
  206. IF (ICOUL.EQ.0) THEN
  207. MOTERR(1:4)=MLMOTS.MOTS(I)
  208. CALL ERREUR(197)
  209. ENDIF
  210. ICOUL=ICOUL-1
  211. ENDIF
  212. MVECT1.NOCOUL(I)=ICOUL
  213. ENDDO
  214. c ecriture du vecteur resultat et sortie
  215. SEGDES MVECT1,MVECTE
  216. IF (ILMOT.EQ.1) SEGDES MLMOTS
  217. CALL ECROBJ ('VECTEUR ',MVECT1)
  218. GOTO 99
  219. ENDIF
  220. c
  221. c Si l'on passe ici, c'est que l'on a pas trouve d'objets du type
  222. c attendu
  223. CALL ERREUR(21)
  224. c Fin du programme
  225. 99 CONTINUE
  226. RETURN
  227. END
  228.  
  229.  
  230.  
  231.  
  232.  

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