Télécharger dmarq.eso

Retour à la liste

Numérotation des lignes :

  1. C DMARQ SOURCE BP208322 16/11/18 21:16:28 9177
  2. c SUBROUTINE DMARQ (IPTR1,TX,TY,IMARQ,IEPAI,XTAIL,ZPLEIN,ICOLPL)
  3. SUBROUTINE DMARQ (IPTR1,TX,TY,IMARQ,XTAIL,ZPLEIN,ICOLPL)
  4. *=============================================================
  5. *
  6. * Trace un marqueur à l'emplacement spécifié
  7. * Appelé par TRCUR et TREVOL
  8. *
  9. *=============================================================
  10. *
  11. * Modifications :
  12. *
  13. * 95/02/07 Loca
  14. * passer les legendes x et y de 12 à 20 caractères:
  15. * SEGMENT AXE disparait et est appelé en include: -INC TMAXE.
  16. *
  17. * 05 sept. 2007 Maugis
  18. * Maintien du segment AXE actif en modification
  19. * Mise du point en premier type de marqueur
  20. * Ajout de formes de marqueurs, dont 2 autres triangles TRIL et TRIR
  21. * pointant horizontalement, on garde pour compatibilité TRIA et TRIB,
  22. * qui peuvent maintenant être invoqués avec TRID et TRIU
  23. * respectivement.
  24. * Introduction d'une taille, d'une épaisseur et d'un remplissage de marqueur
  25. *
  26. * JCARDO 15/05/2012 : les triangles ne pouvaient pas etre remplis...
  27. * BP 19/06/2012 : on supprime IEPAI des arguments car inutilisé
  28. *
  29. *=============================================================
  30. *
  31. * Entrée :
  32. *
  33. * IPTR1 : POINTEUR SUR UN SEGMENT AXE (ACTIF)
  34. * X , Y : COORDONNEES OU PLACER LE CENTRE DE LA MARQUE
  35. * IMARQ : NUMERO DE LA MARQUE A PLACER (Cf. trevol.eso)
  36. * IEPAI : Facteur multiplicatif d'épaisseur
  37. * XTAIL : Facteur multiplicatif de taille
  38. * ZPLEIN: Indicateur de remplissage du marqueur
  39. * ICOLPL: Couleur du remplissage
  40. *
  41. *=============================================================
  42. *
  43. * TOUTES LES VARIABLES COMMENCANT PAR T SONT EN SIMPLE PRECISION !
  44. * pour compatibilité après les routines de tracé
  45. *
  46. * DX : DIMENSION DE LA BASE DE LA MARQUE SELON X
  47. * DY : DIMENSION DE LA MARQUE SELON Y
  48. * NSEG : nb de lignes nécessaires pour remplir la moitié supérieure
  49. * d'un marqueur de taille standard
  50. * KTAB : table de couleurs progressives (tirée de prtrac.eso)
  51. * CLTAB : table de correspondance entre les couleurs nommées (sauf DEFA)
  52. * et les couleurs de TRAISO, pb avec les BLANC, NOIR, ROSE
  53. *
  54. *=============================================================
  55.  
  56. IMPLICIT INTEGER(I-N)
  57. IMPLICIT REAL*8 (A-H,O-S,U-Y)
  58. -INC TMAXE
  59. -INC CCOPTIO
  60. -INC CCREEL
  61. -INC CCGEOME
  62. *
  63. PARAMETER (NSEG=10)
  64. DIMENSION TRX(40),TRY(40),TRZ(40)
  65. DIMENSION CLTAB(15)
  66. LOGICAL ZPLEIN
  67. DATA CLTAB/11,8,15,12,5,6,14,8*7/
  68.  
  69. * Toutes les coordonnées Z sont nulles
  70. DO I=1,40
  71. TRZ(I) = 0
  72. ENDDO
  73.  
  74. AXE=IPTR1
  75. *PM SEGACT AXE
  76.  
  77. * DEFINITION DES TAILLES DE SYMBOLE
  78. IF (ZCARRE) THEN
  79. XNORME= 12 / (XSUP-XINF)
  80. ELSE
  81. XNORME= 16 / (XSUP-XINF)
  82. ENDIF
  83. YNORME= 11.3 / (YSUP-YINF)
  84. DX = (XSUP-XINF)/130*XTAIL
  85. DY = DX * XNORME/YNORME
  86.  
  87. * Pilotage du tracé des marqueurs
  88. * 'POIN','CROI','PLUS','ETOI','CARR','LOSA',
  89. * 'TRIA','TRIB','TRIL','TRIR','TRID','TRIU',
  90. * 'MOIN','BARR','ROND'
  91. GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15),IMARQ
  92. *
  93. * POINT (en fait un petit triangle)
  94. * on annule la prise en compte de la taille.
  95. 1 DX=DX/10/XTAIL
  96. DY=DY/10/XTAIL
  97. TRX(1)=TX-DX
  98. TRY(1)=TY+DY
  99. TRX(2)=TX+DX
  100. TRY(2)=TY+DY
  101. TRX(3)=TX
  102. TRY(3)=TY-DY
  103. TRX(4)=TRX(1)
  104. TRY(4)=TRY(1)
  105. CALL POLRL (4,TRX,TRY,TRZ)
  106. GOTO 20
  107. * CROIX
  108. 2 TRX(1)=TX-DX
  109. TRY(1)=TY+DY
  110. TRX(2)=TX+DX
  111. TRY(2)=TY-DY
  112. CALL POLRL (2,TRX,TRY,TRZ)
  113. TRX(1)=TX+DX
  114. TRY(1)=TY+DY
  115. TRX(2)=TX-DX
  116. TRY(2)=TY-DY
  117. CALL POLRL (2,TRX,TRY,TRZ)
  118. GOTO 20
  119. * PLUS
  120. 3 TRX(1)=TX
  121. TRY(1)=TY+DY
  122. TRX(2)=TX
  123. TRY(2)=TY-DY
  124. CALL POLRL (2,TRX,TRY,TRZ)
  125. TRX(1)=TX-DX
  126. TRY(1)=TY
  127. TRX(2)=TX+DX
  128. TRY(2)=TY
  129. CALL POLRL (2,TRX,TRY,TRZ)
  130. GOTO 20
  131. * ETOILE
  132. 4 TRX(1)=TX-DX*0.71
  133. TRY(1)=TY+DY*0.71
  134. TRX(2)=TX+DX*0.71
  135. TRY(2)=TY-DY*0.71
  136. CALL POLRL (2,TRX,TRY,TRZ)
  137. TRX(1)=TX+DX*0.71
  138. TRY(1)=TY+DY*0.71
  139. TRX(2)=TX-DX*0.71
  140. TRY(2)=TY-DY*0.71
  141. CALL POLRL (2,TRX,TRY,TRZ)
  142. TRX(1)=TX
  143. TRY(1)=TY+DY
  144. TRX(2)=TX
  145. TRY(2)=TY-DY
  146. CALL POLRL (2,TRX,TRY,TRZ)
  147. TRX(1)=TX-DX
  148. TRY(1)=TY
  149. TRX(2)=TX+DX
  150. TRY(2)=TY
  151. CALL POLRL (2,TRX,TRY,TRZ)
  152. GOTO 20
  153. * CARRE
  154. 5 TRX(1)=TX-DX
  155. TRY(1)=TY+DY
  156. TRX(2)=TX+DX
  157. TRY(2)=TY+DY
  158. TRX(3)=TX+DX
  159. TRY(3)=TY-DY
  160. TRX(4)=TX-DX
  161. TRY(4)=TY-DY
  162. TRX(5)=TRX(1)
  163. TRY(5)=TRY(1)
  164. CALL POLRL (5,TRX,TRY,TRZ)
  165. IF (ZPLEIN) CALL TRFACE(5,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  166. GOTO 20
  167. * LOSANGE
  168. 6 TRX(1)=TX-DX
  169. TRY(1)=TY
  170. TRX(2)=TX
  171. TRY(2)=TY+DY
  172. TRX(3)=TX+DX
  173. TRY(3)=TY
  174. TRX(4)=TX
  175. TRY(4)=TY-DY
  176. TRX(5)=TRX(1)
  177. TRY(5)=TRY(1)
  178. CALL POLRL (5,TRX,TRY,TRZ)
  179. IF (ZPLEIN) CALL TRFACE(5,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  180. GOTO 20
  181. * TRIA ou TRID
  182. 11 CONTINUE
  183. 7 TRX(1)=TX-DX
  184. TRY(1)=TY+DY
  185. TRX(2)=TX+DX
  186. TRY(2)=TY+DY
  187. TRX(3)=TX
  188. TRY(3)=TY-DY
  189. TRX(4)=TRX(1)
  190. TRY(4)=TRY(1)
  191. CALL POLRL (4,TRX,TRY,TRZ)
  192. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  193. GOTO 20
  194. * TRIB ou TRIU
  195. 12 CONTINUE
  196. 8 TRX(1)=TX-DX
  197. TRY(1)=TY-DY
  198. TRX(2)=TX
  199. TRY(2)=TY+DY
  200. TRX(3)=TX+DX
  201. TRY(3)=TY-DY
  202. TRX(4)=TRX(1)
  203. TRY(4)=TRY(1)
  204. CALL POLRL (4,TRX,TRY,TRZ)
  205. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  206. GOTO 20
  207. * TRIL
  208. 9 TRX(1)=TX+DX
  209. TRY(1)=TY+DY
  210. TRX(2)=TX+DX
  211. TRY(2)=TY-DY
  212. TRX(3)=TX-DX
  213. TRY(3)=TY
  214. TRX(4)=TRX(1)
  215. TRY(4)=TRY(1)
  216. CALL POLRL (4,TRX,TRY,TRZ)
  217. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  218. GOTO 20
  219. * TRIR
  220. 10 TRX(1)=TX-DX
  221. TRY(1)=TY+DY
  222. TRX(2)=TX-DX
  223. TRY(2)=TY-DY
  224. TRX(3)=TX+DX
  225. TRY(3)=TY
  226. TRX(4)=TRX(1)
  227. TRY(4)=TRY(1)
  228. CALL POLRL (4,TRX,TRY,TRZ)
  229. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  230. GOTO 20
  231. * MOINS
  232. 13 TRX(1)=TX-DX
  233. TRY(1)=TY
  234. TRX(2)=TX+DX
  235. TRY(2)=TY
  236. CALL POLRL (2,TRX,TRY,TRZ)
  237. GOTO 20
  238. * BARRE
  239. 14 TRX(1)=TX
  240. TRY(1)=TY+DY
  241. TRX(2)=TX
  242. TRY(2)=TY-DY
  243. CALL POLRL (2,TRX,TRY,TRZ)
  244. GOTO 20
  245. * ROND
  246. * on exploite la symétrie du système
  247. 15 CONTINUE
  248. * on trace un paquet de 4 * NSEG segments et les triangles remplis éventuels
  249. DX1 = DX
  250. DY1 = 0.
  251. TETA = 0.
  252. DTETA = XPI / 2D0 / NSEG
  253. TRX(3)= TX
  254. TRY(3)= TY
  255. DO I=0,NSEG
  256. TETA = TETA + DTETA
  257. CS = COS(TETA)
  258. SN = (1D0 - CS*CS) ** .5D0
  259. DX2 = CS*DX
  260. DY2 = SN*DY
  261. TRX(1)= TX + DX1
  262. TRY(1)= TY + DY1
  263. TRX(2)= TX + DX2
  264. TRY(2)= TY + DY2
  265. CALL POLRL (2,TRX,TRY,TRZ)
  266. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  267. TRX(1)= TX - DX1
  268. TRX(2)= TX - DX2
  269. CALL POLRL (2,TRX,TRY,TRZ)
  270. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  271. TRY(1)= TY - DY1
  272. TRY(2)= TY - DY2
  273. CALL POLRL (2,TRX,TRY,TRZ)
  274. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  275. TRX(1)= TX + DX1
  276. TRX(2)= TX + DX2
  277. CALL POLRL (2,TRX,TRY,TRZ)
  278. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  279. DX1 = DX2
  280. DY1 = DY2
  281. ENDDO
  282.  
  283. 20 CONTINUE
  284. *PM SEGDES AXE
  285.  
  286. END
  287.  
  288.  
  289.  
  290.  
  291.  
  292.  
  293.  
  294.  
  295.  

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