Télécharger extra6.eso

Retour à la liste

Numérotation des lignes :

extra6
  1. C EXTRA6 SOURCE SP204843 25/06/05 21:15:06 12270
  2. SUBROUTINE EXTRA6(IBOLL)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C
  6. C =====================================================================
  7. C
  8. C EXTRAIT UNE LISTE DE REELS ou autre D'UN OBJET EVOL
  9. C OU UNE COURBE (EVOL ELEMENTAIRE)
  10. C OU CERTAINS COUPLES
  11. C
  12. C APPELE PAR EXTRAI
  13. C
  14. C =====================================================================
  15. C
  16. C CREATION : 12/05/87
  17. C PROGRAMMEUR : GUILBAUD
  18. C Modification : PM 12/09/2007,
  19. C définition de la couleur et du type de l'évolution
  20. C extraite
  21. c BP 12/09/2013: erreur 1027 pour les EVOLUTIOns vides
  22. c BP 09/07/2014: ajout EXTR evol1 listent1
  23. C
  24. C =====================================================================
  25. C
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29. -INC SMEVOLL
  30. -INC SMTEXTE
  31. -INC SMLENTI
  32. -INC SMLMOTS
  33. -INC CCGEOME
  34. CHARACTER*72 LTEX
  35. CHARACTER*12 TI,ITEX,CHAR1,CHAR2
  36. CHARACTER*8 ITBLA,TYPRES
  37. CHARACTER*4 ICOUL
  38.  
  39. C
  40. C VERIF QUE L'EVOLUTION N'EST PAS VIDE
  41. C
  42. MEVOLL=IBOLL
  43. NBEV = IEVOLL(/1)
  44. if(NBEV.le.0) then
  45. MOTERR(1:8)='EVOLUTIO'
  46. C Une donnée de type %m1:8 est vide
  47. CALL ERREUR(1027)
  48. GOTO 80
  49. endif
  50. C
  51. C LECTURE DU TITRE DE LA PROGRESSION
  52. C
  53. TYPRES='LISTREEL'
  54. ITBLA=' '
  55. CALL QUETYP(ITBLA,0,IRETOU)
  56. IF(ITBLA.EQ.'MOT ') THEN
  57. C
  58. C ON VA LIRE UN MOT
  59. C
  60. CALL LIRCHA(TI,1,IRETOU)
  61.  
  62. C On extrait la couleur (ajout BP, 2015-03-12)
  63. IF(TI(:4).EQ.'COUL')THEN
  64. CALL LIRENT(K,0,IRETOU)
  65. * cas ou on precise la k^ieme courbe --> mot
  66. if (IRETOU.NE.0) then
  67. if(K.LE.0)THEN
  68. CALL ERREUR(352)
  69. RETURN
  70. ENDIF
  71. if(K.GT.IEVOLL(/1))THEN
  72. c Il n'y a pas %i1 courbes dans l'objet évolution
  73. INTERR(1)=K
  74. CALL ERREUR(351)
  75. RETURN
  76. ENDIF
  77. KEVOLL = IEVOLL(K)
  78. ICOUL=NCOUL(NUMEVX)
  79. CALL ECRCHA(ICOUL)
  80. RETURN
  81. * cas ou on ne precise pas la k^ieme courbe --> listmots
  82. else
  83. JGN=4
  84. JGM=IEVOLL(/1)
  85. segini,MLMOTS
  86. ILMOTS=MLMOTS
  87. DO 1 K=1,JGM
  88. KEVOLL = IEVOLL(K)
  89. ICOUL=NCOUL(NUMEVX)
  90. MOTS(K)=ICOUL
  91. 1 CONTINUE
  92. SEGDES MLMOTS
  93. CALL ECROBJ('LISTMOTS',ILMOTS)
  94. RETURN
  95. endif
  96. ENDIF
  97.  
  98. C On extrait la légende
  99. IF(TI(:4).EQ.'LEGE')THEN
  100. IF (IEVOLL(/1).EQ.1) K=1
  101. CALL LIRENT(K,0,IRETOU)
  102. if(K.LE.0)THEN
  103. CALL ERREUR(352)
  104. RETURN
  105. ENDIF
  106. if(K.GT.IEVOLL(/1))THEN
  107. c Il n'y a pas %i1 courbes dans l'objet évolution
  108. INTERR(1)=K
  109. CALL ERREUR(351)
  110. RETURN
  111. ENDIF
  112.  
  113. KEVOLL = IEVOLL(K)
  114. LTEX=KEVTEX
  115. CALL ECRCHA(LTEX)
  116. RETURN
  117. ENDIF
  118.  
  119. C On extrait la légende en X
  120. IF(TI(:4).EQ.'LEGX')THEN
  121. IF (IEVOLL(/1).EQ.1) K=1
  122. CALL LIRENT(K,0,IRETOU)
  123. if(K.LE.0)THEN
  124. CALL ERREUR(352)
  125. RETURN
  126. ENDIF
  127. if(K.GT.IEVOLL(/1))THEN
  128. c Il n'y a pas %i1 courbes dans l'objet évolution
  129. INTERR(1)=K
  130. CALL ERREUR(351)
  131. RETURN
  132. ENDIF
  133.  
  134. KEVOLL = IEVOLL(K)
  135. ITEX=NOMEVX
  136. CALL ECRCHA(ITEX)
  137. RETURN
  138. ENDIF
  139.  
  140. C On extrait la légende en Y
  141. IF(TI(:4).EQ.'LEGY')THEN
  142. IF (IEVOLL(/1).EQ.1) K=1
  143. CALL LIRENT(K,0,IRETOU)
  144. if(K.LE.0)THEN
  145. CALL ERREUR(352)
  146. RETURN
  147. ENDIF
  148. if(K.GT.IEVOLL(/1))THEN
  149. INTERR(1)=K
  150. CALL ERREUR(351)
  151. RETURN
  152. ENDIF
  153.  
  154. KEVOLL = IEVOLL(K)
  155. ITEX=NOMEVY
  156. CALL ECRCHA(ITEX)
  157. RETURN
  158. ENDIF
  159.  
  160. C On extrait le STYLe
  161. IF(TI(:4).EQ.'STYL')THEN
  162. IF (IEVOLL(/1).EQ.1) K=1
  163. CALL LIRENT(K,0,IRETOU)
  164. if(K.LE.0)THEN
  165. CALL ERREUR(352)
  166. RETURN
  167. ENDIF
  168. if(K.GT.IEVOLL(/1))THEN
  169. INTERR(1)=K
  170. CALL ERREUR(351)
  171. RETURN
  172. ENDIF
  173.  
  174. KEVOLL = IEVOLL(K)
  175. ICOUL = MOSTYL(LSTYL)
  176. CALL ECRCHA(ICOUL)
  177. RETURN
  178. ENDIF
  179.  
  180. C On extrait le MARQueur
  181. IF(TI(:4).EQ.'MARQ')THEN
  182. IF (IEVOLL(/1).EQ.1) K=1
  183. CALL LIRENT(K,0,IRETOU)
  184. if(K.LE.0)THEN
  185. CALL ERREUR(352)
  186. RETURN
  187. ENDIF
  188. if(K.GT.IEVOLL(/1))THEN
  189. INTERR(1)=K
  190. CALL ERREUR(351)
  191. RETURN
  192. ENDIF
  193.  
  194. KEVOLL = IEVOLL(K)
  195. ICOUL = MOMARQ(MMARQ)
  196. CALL ECRCHA(ICOUL)
  197. RETURN
  198. ENDIF
  199.  
  200. C On extrait la TAILle du marqueur
  201. IF(TI(:4).EQ.'TAIL')THEN
  202. IF (IEVOLL(/1).EQ.1) K=1
  203. CALL LIRENT(K,0,IRETOU)
  204. if(K.LE.0)THEN
  205. CALL ERREUR(352)
  206. RETURN
  207. ENDIF
  208. if(K.GT.IEVOLL(/1))THEN
  209. INTERR(1)=K
  210. CALL ERREUR(351)
  211. RETURN
  212. ENDIF
  213.  
  214. KEVOLL = IEVOLL(K)
  215. ICOUL = MOTAIL(KTAIL)
  216. CALL ECRCHA(ICOUL)
  217. RETURN
  218. ENDIF
  219.  
  220. IF (TI(:4).EQ.'ABSC'.OR.TI(:4).EQ.'ORDO'.OR.TI(:4).EQ.'COUR')
  221. & GOTO 25
  222. *
  223. IF (TI(:4).EQ.'PAS '.OR.TI(:4).EQ.'APRE'.OR.TI(:4).EQ.'AVAN'
  224. & .OR.TI(:4).EQ.'COMP') GOTO 26
  225. *
  226. ELSE
  227. C
  228. C ON LIT AUTRE CHOSE
  229. C
  230. CALL LIROBJ(ITBLA,MOT1,1,IRETOU)
  231. C On ne veut pas d'objet de type %m1:8
  232. MOTERR(1:8)=ITBLA
  233. CALL ERREUR(39)
  234. RETURN
  235. ENDIF
  236. C
  237. C RECHERCHE DE LA PROGRESSION
  238. C
  239. NBEV=IEVOLL(/1)
  240. DO J=1,NBEV
  241. KEVOLL=IEVOLL(J)
  242. ITEX=NOMEVX
  243. IRET=IPROGX
  244. IF(TI.EQ.ITEX) GOTO 30
  245. ITEX=NOMEVY
  246. IRET=IPROGY
  247. IF(TI.EQ.ITEX) GOTO 30
  248. ENDDO
  249.  
  250. C Il n'existe pas de liste ayant ce titre dans l'objet évolution
  251. CALL ERREUR(353)
  252. GOTO 80
  253. *
  254. * EXTRACTION DE CERTAINS COUPLES
  255. *
  256. 26 CONTINUE
  257. CALL TEVOLU(IBOLL,TI)
  258. RETURN
  259. *
  260. * AUTRE OPERATION
  261. *
  262. 25 CONTINUE
  263. C
  264. C ON A LU UN MOT-CLE
  265. C
  266. C
  267. C EXTRAIRE LES COURBES DE NOMS D'ABSCISSES OU D'ORDONNEES DONNES
  268. C
  269. CALL LIRCHA(ITEX,0,IRETOU)
  270. IF (IRETOU.NE.0.AND.TI(:4).EQ.'COUR') THEN
  271. NBEV=IEVOLL(/1)
  272. N=NBEV
  273. SEGINI,MEVOL1
  274. MEVOL1.ITYEVO=ITYEVO
  275. MEVOL1.IEVTEX=IEVTEX
  276. N=0
  277. DO IK=1,NBEV
  278. KEVOLL=MEVOLL.IEVOLL(IK)
  279. CHAR1=NOMEVX
  280. CHAR2=NOMEVY
  281. * write(6,*) 'CHAR1 =',CHAR1
  282. * write(6,*) 'CHAR2 =',CHAR2
  283. IF (ITEX(1:12).EQ.CHAR1.OR.ITEX(1:12).EQ.CHAR2) THEN
  284. N=N+1
  285. MEVOL1.IEVOLL(N)=KEVOLL
  286. ENDIF
  287. ENDDO
  288. * write(6,*) 'N =',N
  289. IF (N.NE.0) THEN
  290. SEGADJ,MEVOL1
  291. IRET=MEVOL1
  292. CALL ACTOBJ('EVOLUTIO',IRET,1)
  293. CALL ECROBJ('EVOLUTIO',IRET)
  294. ELSE
  295. CALL ERREUR(353)
  296. ENDIF
  297. GOTO 80
  298. ENDIF
  299. C
  300. C EXTRAIRE LES COURBES DEPUIS UN LISTENTI
  301. C
  302. CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU)
  303. IF (IRETOU.NE.0.AND.TI(:4).EQ.'COUR') THEN
  304. NBEV=IEVOLL(/1)
  305. SEGACT,MLENTI
  306. JG=LECT(/1)
  307. N=JG
  308. SEGINI,MEVOL1
  309. MEVOL1.ITYEVO=ITYEVO
  310. MEVOL1.IEVTEX=IEVTEX
  311. N=0
  312. DO J=1,JG
  313. IK=LECT(J)
  314. IF(IK.GT.NBEV) THEN
  315. INTERR(1)=IK
  316. CALL ERREUR(351)
  317. GOTO 80
  318. ELSEIF(IK.LE.0) THEN
  319. CALL ERREUR(352)
  320. GOTO 80
  321. ENDIF
  322. N=N+1
  323. MEVOL1.IEVOLL(N)= IEVOLL(IK)
  324. ENDDO
  325. IRET=MEVOL1
  326. CALL ACTOBJ('EVOLUTIO',IRET,1)
  327. CALL ECROBJ('EVOLUTIO',IRET)
  328. GOTO 80
  329. ENDIF
  330. C
  331. C EXTRAIRE LA COURBE(S) J
  332. C
  333. CALL LIRENT(J,0,IRETOU)
  334. IF(IRETOU.EQ.0) THEN
  335. J=1
  336. ELSE
  337. IF(J.GT.IEVOLL(/1)) THEN
  338. * Il n'y a pas %i1 courbes dans l'objet évolution
  339. INTERR(1)=J
  340. CALL ERREUR(351)
  341. GOTO 80
  342. ENDIF
  343. IF(J.LE.0) THEN
  344. C Numéro de la courbe négatif ou nul
  345. CALL ERREUR(352)
  346. GOTO 80
  347. ENDIF
  348. ENDIF
  349.  
  350. KEVOLL=IEVOLL(J)
  351. IF(TI(:4).EQ.'COUR') THEN
  352. N=1
  353. SEGINI MEVOL1
  354. MEVOL1.IEVTEX = KEVTEX
  355. MEVOL1.ITYEVO = 'REEL'
  356. MEVOL1.IEVOLL(1)= KEVOLL
  357. IRET=MEVOL1
  358. CALL ACTOBJ('EVOLUTIO',IRET,1)
  359. CALL ECROBJ('EVOLUTIO',IRET)
  360. GOTO 80
  361. ENDIF
  362.  
  363. C
  364. C EXTRAIRE LES LISTES D'ABSCISSES (DEFAUT) OU D'ORDONNEES
  365. C
  366. IRET =IPROGX
  367. TYPRES=TYPX
  368. IF(TI(:4).EQ.'ORDO') THEN
  369. IRET = IPROGY
  370. TYPRES= TYPY
  371. ENDIF
  372.  
  373. 30 CONTINUE
  374. CALL ACTOBJ(TYPRES,IRET,1)
  375. CALL ECROBJ(TYPRES,IRET)
  376.  
  377. 80 CONTINUE
  378. RETURN
  379.  
  380. END
  381.  
  382.  
  383.  
  384.  

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