Télécharger extra6.eso

Retour à la liste

Numérotation des lignes :

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

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