Télécharger dmarq.eso

Retour à la liste

Numérotation des lignes :

dmarq
  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.  
  60. -INC PPARAM
  61. -INC CCOPTIO
  62. -INC CCREEL
  63. -INC CCGEOME
  64. *
  65. PARAMETER (NSEG=10)
  66. DIMENSION TRX(40),TRY(40),TRZ(40)
  67. DIMENSION CLTAB(15)
  68. LOGICAL ZPLEIN
  69. DATA CLTAB/11,8,15,12,5,6,14,8*7/
  70.  
  71. * Toutes les coordonnées Z sont nulles
  72. DO I=1,40
  73. TRZ(I) = 0
  74. ENDDO
  75.  
  76. AXE=IPTR1
  77. *PM SEGACT AXE
  78.  
  79. * DEFINITION DES TAILLES DE SYMBOLE
  80. IF (ZCARRE) THEN
  81. XNORME= 12 / (XSUP-XINF)
  82. ELSE
  83. XNORME= 16 / (XSUP-XINF)
  84. ENDIF
  85. YNORME= 11.3 / (YSUP-YINF)
  86. DX = (XSUP-XINF)/130*XTAIL
  87. DY = DX * XNORME/YNORME
  88.  
  89. * Pilotage du tracé des marqueurs
  90. * 'POIN','CROI','PLUS','ETOI','CARR','LOSA',
  91. * 'TRIA','TRIB','TRIL','TRIR','TRID','TRIU',
  92. * 'MOIN','BARR','ROND'
  93. GOTO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15),IMARQ
  94. *
  95. * POINT (en fait un petit triangle)
  96. * on annule la prise en compte de la taille.
  97. 1 DX=DX/10/XTAIL
  98. DY=DY/10/XTAIL
  99. TRX(1)=TX-DX
  100. TRY(1)=TY+DY
  101. TRX(2)=TX+DX
  102. TRY(2)=TY+DY
  103. TRX(3)=TX
  104. TRY(3)=TY-DY
  105. TRX(4)=TRX(1)
  106. TRY(4)=TRY(1)
  107. CALL POLRL (4,TRX,TRY,TRZ)
  108. GOTO 20
  109. * CROIX
  110. 2 TRX(1)=TX-DX
  111. TRY(1)=TY+DY
  112. TRX(2)=TX+DX
  113. TRY(2)=TY-DY
  114. CALL POLRL (2,TRX,TRY,TRZ)
  115. TRX(1)=TX+DX
  116. TRY(1)=TY+DY
  117. TRX(2)=TX-DX
  118. TRY(2)=TY-DY
  119. CALL POLRL (2,TRX,TRY,TRZ)
  120. GOTO 20
  121. * PLUS
  122. 3 TRX(1)=TX
  123. TRY(1)=TY+DY
  124. TRX(2)=TX
  125. TRY(2)=TY-DY
  126. CALL POLRL (2,TRX,TRY,TRZ)
  127. TRX(1)=TX-DX
  128. TRY(1)=TY
  129. TRX(2)=TX+DX
  130. TRY(2)=TY
  131. CALL POLRL (2,TRX,TRY,TRZ)
  132. GOTO 20
  133. * ETOILE
  134. 4 TRX(1)=TX-DX*0.71
  135. TRY(1)=TY+DY*0.71
  136. TRX(2)=TX+DX*0.71
  137. TRY(2)=TY-DY*0.71
  138. CALL POLRL (2,TRX,TRY,TRZ)
  139. TRX(1)=TX+DX*0.71
  140. TRY(1)=TY+DY*0.71
  141. TRX(2)=TX-DX*0.71
  142. TRY(2)=TY-DY*0.71
  143. CALL POLRL (2,TRX,TRY,TRZ)
  144. TRX(1)=TX
  145. TRY(1)=TY+DY
  146. TRX(2)=TX
  147. TRY(2)=TY-DY
  148. CALL POLRL (2,TRX,TRY,TRZ)
  149. TRX(1)=TX-DX
  150. TRY(1)=TY
  151. TRX(2)=TX+DX
  152. TRY(2)=TY
  153. CALL POLRL (2,TRX,TRY,TRZ)
  154. GOTO 20
  155. * CARRE
  156. 5 TRX(1)=TX-DX
  157. TRY(1)=TY+DY
  158. TRX(2)=TX+DX
  159. TRY(2)=TY+DY
  160. TRX(3)=TX+DX
  161. TRY(3)=TY-DY
  162. TRX(4)=TX-DX
  163. TRY(4)=TY-DY
  164. TRX(5)=TRX(1)
  165. TRY(5)=TRY(1)
  166. CALL POLRL (5,TRX,TRY,TRZ)
  167. IF (ZPLEIN) CALL TRFACE(5,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  168. GOTO 20
  169. * LOSANGE
  170. 6 TRX(1)=TX-DX
  171. TRY(1)=TY
  172. TRX(2)=TX
  173. TRY(2)=TY+DY
  174. TRX(3)=TX+DX
  175. TRY(3)=TY
  176. TRX(4)=TX
  177. TRY(4)=TY-DY
  178. TRX(5)=TRX(1)
  179. TRY(5)=TRY(1)
  180. CALL POLRL (5,TRX,TRY,TRZ)
  181. IF (ZPLEIN) CALL TRFACE(5,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  182. GOTO 20
  183. * TRIA ou TRID
  184. 11 CONTINUE
  185. 7 TRX(1)=TX-DX
  186. TRY(1)=TY+DY
  187. TRX(2)=TX+DX
  188. TRY(2)=TY+DY
  189. TRX(3)=TX
  190. TRY(3)=TY-DY
  191. TRX(4)=TRX(1)
  192. TRY(4)=TRY(1)
  193. CALL POLRL (4,TRX,TRY,TRZ)
  194. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  195. GOTO 20
  196. * TRIB ou TRIU
  197. 12 CONTINUE
  198. 8 TRX(1)=TX-DX
  199. TRY(1)=TY-DY
  200. TRX(2)=TX
  201. TRY(2)=TY+DY
  202. TRX(3)=TX+DX
  203. TRY(3)=TY-DY
  204. TRX(4)=TRX(1)
  205. TRY(4)=TRY(1)
  206. CALL POLRL (4,TRX,TRY,TRZ)
  207. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  208. GOTO 20
  209. * TRIL
  210. 9 TRX(1)=TX+DX
  211. TRY(1)=TY+DY
  212. TRX(2)=TX+DX
  213. TRY(2)=TY-DY
  214. TRX(3)=TX-DX
  215. TRY(3)=TY
  216. TRX(4)=TRX(1)
  217. TRY(4)=TRY(1)
  218. CALL POLRL (4,TRX,TRY,TRZ)
  219. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  220. GOTO 20
  221. * TRIR
  222. 10 TRX(1)=TX-DX
  223. TRY(1)=TY+DY
  224. TRX(2)=TX-DX
  225. TRY(2)=TY-DY
  226. TRX(3)=TX+DX
  227. TRY(3)=TY
  228. TRX(4)=TRX(1)
  229. TRY(4)=TRY(1)
  230. CALL POLRL (4,TRX,TRY,TRZ)
  231. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  232. GOTO 20
  233. * MOINS
  234. 13 TRX(1)=TX-DX
  235. TRY(1)=TY
  236. TRX(2)=TX+DX
  237. TRY(2)=TY
  238. CALL POLRL (2,TRX,TRY,TRZ)
  239. GOTO 20
  240. * BARRE
  241. 14 TRX(1)=TX
  242. TRY(1)=TY+DY
  243. TRX(2)=TX
  244. TRY(2)=TY-DY
  245. CALL POLRL (2,TRX,TRY,TRZ)
  246. GOTO 20
  247. * ROND
  248. * on exploite la symétrie du système
  249. 15 CONTINUE
  250. * on trace un paquet de 4 * NSEG segments et les triangles remplis éventuels
  251. DX1 = DX
  252. DY1 = 0.
  253. TETA = 0.
  254. DTETA = XPI / 2D0 / NSEG
  255. TRX(3)= TX
  256. TRY(3)= TY
  257. DO I=0,NSEG
  258. TETA = TETA + DTETA
  259. CS = COS(TETA)
  260. SN = (1D0 - CS*CS) ** .5D0
  261. DX2 = CS*DX
  262. DY2 = SN*DY
  263. TRX(1)= TX + DX1
  264. TRY(1)= TY + DY1
  265. TRX(2)= TX + DX2
  266. TRY(2)= TY + DY2
  267. CALL POLRL (2,TRX,TRY,TRZ)
  268. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  269. TRX(1)= TX - DX1
  270. TRX(2)= TX - DX2
  271. CALL POLRL (2,TRX,TRY,TRZ)
  272. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  273. TRY(1)= TY - DY1
  274. TRY(2)= TY - DY2
  275. CALL POLRL (2,TRX,TRY,TRZ)
  276. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  277. TRX(1)= TX + DX1
  278. TRX(2)= TX + DX2
  279. CALL POLRL (2,TRX,TRY,TRZ)
  280. IF (ZPLEIN) CALL TRFACE(3,TRX,TRY,TRZ,1.,ICOLPL,IEFF)
  281. DX1 = DX2
  282. DY1 = DY2
  283. ENDDO
  284.  
  285. 20 CONTINUE
  286. *PM SEGDES AXE
  287.  
  288. END
  289.  
  290.  
  291.  
  292.  
  293.  
  294.  
  295.  
  296.  
  297.  

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