Télécharger extra6.eso

Retour à la liste

Numérotation des lignes :

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

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