Télécharger enleve.eso

Retour à la liste

Numérotation des lignes :

  1. C ENLEVE SOURCE CB215821 20/07/29 21:15:22 10668
  2. SUBROUTINE ENLEVE
  3.  
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. C***********************************************************************
  7. C
  8. C E N L E V E
  9. C -----------
  10. C
  11. C SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "ENLEVER"
  12. C
  13. C FONCTION:
  14. C ---------
  15. C
  16. C ENLEVER UN ELEMENT D'UN OBJET (QUAND CELA A UN SENS).
  17. C
  18. C
  19. C PHRASE D'APPEL (EN GIBIANE):
  20. C ----------------------------
  21. C
  22. C OBJET2 = ENLEVER OBJET1 (MOT_CLE) INDIC1 ;
  23. C
  24. C
  25. C OPERANDES ET RESULTATS:
  26. C -----------------------
  27. C
  28. C +----------------+----------------+----------------+----------------+
  29. C | OBJET1 | MOT_CLE | INDIC1 | OBJET2 |
  30. C +================+================+================+================+
  31. C | LISTREEL | AUCUN | ENTIER | LISTREEL |
  32. C | LISTREEL | AUCUN | LISTENTI | LISTREEL |
  33. C +----------------+----------------+----------------+----------------+
  34. C | LISTENTI | AUCUN | ENTIER | LISTENTI |
  35. C | LISTENTI | AUCUN | LISTENTI | LISTENTI |
  36. C +----------------+----------------+----------------+----------------+
  37. C | LISTMOTS | AUCUN | ENTIER | LISTMOTS |
  38. C | LISTMOTS | AUCUN | LISTENTI | LISTMOTS |
  39. C +----------------+----------------+----------------+----------------+
  40. C | LISTCHPO | AUCUN | ENTIER | LISTCHPO |
  41. C | LISTCHPO | AUCUN | LISTENTI | LISTCHPO |
  42. C +----------------+----------------+----------------+----------------+
  43. C | CHPOINT | AUCUN | MOT | CHPOINT |
  44. C | CHPOINT | AUCUN | LISTMOTS | CHPOINT |
  45. C +----------------+----------------+----------------+----------------+
  46. C | TABLE | AUCUN | (quelconque) | TABLE |
  47. C +----------------+----------------+----------------+----------------+
  48. C | CHARGEME | AUCUN | MOT | CHARGEMENT |
  49. C +----------------+----------------+----------------+----------------+
  50. C | MMODEL | 'FORM' | MOT | MMODEL |
  51. C | MMODEL | 'COMP' | MOT | MMODEL |
  52. C +----------------+----------------+----------------+----------------+
  53. C
  54. C Fonction non acceptee
  55. C +----------------+----------------+----------------+----------------+
  56. C | MCHAML | AUCUN | MOT | MCHAML |
  57. C | MCHAML | AUCUN | LISTMOTS | MCHAML |
  58. C +----------------+----------------+----------------+----------------+
  59. C
  60. C
  61. C MODE DE FONCTIONNEMENT:
  62. C -----------------------
  63. C
  64. C APPEL D'UN SOUS-PROGRAMME DISTINCT SELON LE TYPE OBJET1 :
  65. C LISTREEL => ENLEV1
  66. C LISTENTI => ENLEV2
  67. C LISTMOTS => ENLEV3
  68. C LISTCHPO => ENLEV4
  69. C CHPOINT => ENLEV5
  70. C TABLE => ENLEV6
  71. C CHARGEMENT => traite en interne dans cette subroutine
  72. C MMODEL => ENLEV7
  73. C MCHAML => ENLEV8
  74. C
  75. C
  76. C AUTEUR, DATE DE CREATION:
  77. C -------------------------
  78. C
  79. C PASCAL MANIGOT 5 DECEMBRE 1984
  80. C DATE DE MODIFICATION 22 JANVIER 88
  81. C P.M. 21/06/88 : REINTRODUCTION DES TABLES
  82. C JCARDO 9/12/14 : INDIC1 type LISTENTI pour OBJET1 type LISTxxxx
  83. C M.B. xx/06/16 : INDIC1 type MOT pour OBJET1 type MMODEL
  84. C C.B. 30/05/17 : Prise en compte des MCHAML
  85. C
  86. C
  87. C LANGAGE:
  88. C --------
  89. C
  90. C FORTRAN77
  91. C
  92. C***********************************************************************
  93. C
  94.  
  95. -INC PPARAM
  96. -INC CCOPTIO
  97. -INC SMLENTI
  98. -INC SMLMOTS
  99. -INC SMCHARG
  100. C
  101. CHARACTER*(4) CMOMOT
  102. CHARACTER*8 CTYP
  103.  
  104. PARAMETER (NBTYP=8)
  105. CHARACTER*8 TYPOK(NBTYP)
  106.  
  107. DATA TYPOK /'TABLE ','MMODEL ','CHARGEME','CHPOINT ',
  108. & 'LISTREEL','LISTENTI','LISTMOTS','LISTCHPO'/
  109.  
  110. CALL QUETYP(CTYP,0,IRETOU)
  111. IF (IRETOU.EQ.0) THEN
  112. CALL ERREUR(533)
  113. RETURN
  114. ENDIF
  115.  
  116. C Recherche de la position dans le DATA
  117. CALL PLACE(TYPOK,NBTYP,IPLACE,CTYP)
  118. IF (IERR .NE. 0) RETURN
  119.  
  120. IF (IPLACE .EQ. 0) THEN
  121. CALL ERREUR(34)
  122. RETURN
  123. ENDIF
  124.  
  125. GOTO(100,200,300,400,500,500,500,500),IPLACE
  126.  
  127.  
  128. C +---------------------------------------------------------------+
  129. C | O B J E T 1 D E T Y P E T A B L E |
  130. C +---------------------------------------------------------------+
  131. C (A LAISSER EN PREMIERE POSITION DANS CE SOUS-PROGRAMME)
  132.  
  133. 100 CONTINUE
  134. CALL LIROBJ ('TABLE',IPTABL,1,IRETOU)
  135. IF (IERR .NE. 0) RETURN
  136. CALL ENLEV6 (IPTABL,IPTAB2)
  137. IF (IERR .NE. 0) RETURN
  138. CALL ECROBJ ('TABLE',IPTAB2)
  139. RETURN
  140.  
  141.  
  142. C +---------------------------------------------------------------+
  143. C | O B J E T 1 D E T Y P E M M O D E L |
  144. C +---------------------------------------------------------------+
  145. 200 CONTINUE
  146. CALL LIROBJ ('MMODEL ',IPMOD1,1,IRETOU)
  147. IF (IERR .NE. 0) RETURN
  148. CALL ACTOBJ ('MMODEL ',IPMOD1,1)
  149. CALL ENLEV7 (IPMOD1,IPMOD2)
  150. IF (IERR .NE. 0) RETURN
  151. CALL ACTOBJ ('MMODEL ',IPMOD2,1)
  152. CALL ECROBJ ('MMODEL ',IPMOD2)
  153. RETURN
  154.  
  155.  
  156. C +---------------------------------------------------------------+
  157. C | O B J E T 1 D E T Y P E C H A R G E M E N T |
  158. C +---------------------------------------------------------------+
  159. 300 CONTINUE
  160. CALL LIROBJ('CHARGEME',MCHARG,1,IRETOU)
  161. IF (IERR .NE. 0) RETURN
  162. CALL ACTOBJ('CHARGEME',MCHARG,1)
  163. CALL LIRCHA(CMOMOT,1,IRETOU)
  164. IF (IERR .NE. 0) RETURN
  165. segini,MCHAR1=MCHARG
  166. N=0
  167. segact mcharg
  168. do IU=1,KCHARG(/1)
  169. if(CHANOM(iu).ne.CMOMOT) then
  170. n=n+1
  171. mchar1.kcharg(n)=kcharg(iu)
  172. mchar1.chanat(n)=chanat(iu)
  173. mchar1.chanom(n)=chanom(iu)
  174. mchar1.chamob(n)=chamob(iu)
  175. mchar1.chalie(n)=chalie(iu)
  176. endif
  177. enddo
  178. segadj mchar1
  179. call actobj('CHARGEME',mchar1,1)
  180. call ecrobj('CHARGEME',mchar1)
  181. return
  182.  
  183.  
  184. C +---------------------------------------------------------------+
  185. C | O B J E T 1 D E T Y P E C H P O I N T |
  186. C +---------------------------------------------------------------+
  187. 400 CONTINUE
  188. CALL LIROBJ('CHPOINT ',IPCHP,1,IRETOU)
  189. IF (IERR .NE. 0) RETURN
  190. CALL ACTOBJ('CHPOINT ',IPCHP,1)
  191. CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  192. IF (IERR .NE. 0) RETURN
  193.  
  194. IF(IRETOU.NE.0) THEN
  195. CALL ACTOBJ('LISTMOTS',MLMOTS,1)
  196. CALL ENLEV5(IPCHP,MLMOTS,IPOIN2)
  197. IF (IERR .NE. 0) RETURN
  198.  
  199. ELSE
  200. JGN = 4
  201. JGM = 10
  202. INCJGM = 10
  203. SEGINI,MLMOTS
  204. IB = 0
  205. 401 CALL LIRCHA(CMOMOT,0,IRETOU)
  206. IF(IRETOU.EQ.0) GOTO 402
  207. IB=IB+1
  208. IF (IB .GT. JGM) THEN
  209. JGM = JGM + INCJGM
  210. INCJGM = INCJGM * 2
  211. SEGADJ,MLMOTS
  212. ENDIF
  213. MLMOTS.MOTS(IB)=CMOMOT
  214. GOTO 401
  215.  
  216. 402 CONTINUE
  217. IF(IB .EQ. 0) THEN
  218. CALL ERREUR(6)
  219. RETURN
  220.  
  221. ELSEIF(IB .NE. JGM)THEN
  222. JGM = IB
  223. SEGADJ,MLMOTS
  224. ENDIF
  225.  
  226. CALL ENLEV5(IPCHP,MLMOTS,IPOIN2)
  227. IF (IERR .NE. 0) RETURN
  228. SEGSUP MLMOTS
  229. ENDIF
  230.  
  231. CALL ACTOBJ ('CHPOINT ',IPOIN2,1)
  232. CALL ECROBJ ('CHPOINT ',IPOIN2)
  233. RETURN
  234.  
  235.  
  236. C +---------------------------------------------------------------+
  237. C | O B J E T 1 D E T Y P E L I S T x x x x |
  238. C +---------------------------------------------------------------+
  239. 500 CONTINUE
  240. C IPOS<>0 => on autorise IPOIN2 à contenir un LISTENTI
  241. IPOS=1
  242. CALL LIRE01 (IPOIN1,IPOS,IPOIN2)
  243. IF (IERR.NE.0) RETURN
  244. C
  245. C Si plusieurs indices sont donnes, on trie par ordre croissant
  246. C et on supprime les eventuels doublons
  247. IF (IPOS.LT.0) THEN
  248. MLENT2=IPOIN2
  249. SEGACT,MLENT2
  250. JG = MLENT2.LECT(/1)
  251. IF (JG.NE.0) THEN
  252. SEGINI,MLENT1=MLENT2
  253. IORDRE=0
  254. CALL ORDON2(MLENT1,.TRUE.,.FALSE.,IORDRE)
  255. SEGACT,MLENT1
  256. SEGINI,MLENTI
  257. LECT(1) = MLENT1.LECT(1)
  258. LL = 1
  259. IF (JG.GT.1) THEN
  260. M1 = LECT(1)
  261. DO JJ = 2, JG
  262. M2 = MLENT1.LECT(JJ)
  263. IF (M1.NE.M2) THEN
  264. LL = LL+1
  265. LECT(LL) = M2
  266. M1 = M2
  267. ENDIF
  268. ENDDO
  269. ENDIF
  270. JG = LL
  271. SEGADJ,MLENTI
  272. IPOIN2=MLENTI
  273. SEGSUP,MLENT1
  274. ELSE
  275. MLENTI = 0
  276. ENDIF
  277. ENDIF
  278.  
  279. C ENLEVER DES INDICES D'UN LISTREEL
  280. IF (ABS(IPOS).EQ.1) THEN
  281. CALL ENLEV1 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  282. IF (IERR .NE. 0) RETURN
  283. CALL ACTOBJ ('LISTREEL',IPOIN3,1)
  284. CALL ECROBJ ('LISTREEL',IPOIN3)
  285.  
  286. C ENLEVER DES INDICES D'UN LISTENTI
  287. ELSEIF (ABS(IPOS).EQ.2) THEN
  288. CALL ENLEV2 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  289. IF (IERR .NE. 0) RETURN
  290. CALL ACTOBJ ('LISTENTI',IPOIN3,1)
  291. CALL ECROBJ ('LISTENTI',IPOIN3)
  292.  
  293. C ENLEVER DES INDICES D'UN LISTMOTS
  294. ELSEIF (ABS(IPOS).EQ.3) THEN
  295. CALL ENLEV3 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  296. IF (IERR .NE. 0) RETURN
  297. CALL ACTOBJ ('LISTMOTS',IPOIN3,1)
  298. CALL ECROBJ ('LISTMOTS',IPOIN3)
  299.  
  300. C ENLEVER DES INDICES D'UN LISTCHPO
  301. ELSEIF (ABS(IPOS).EQ.4) THEN
  302. CALL ENLEV4 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  303. IF (IERR .NE. 0) RETURN
  304. CALL ACTOBJ ('LISTCHPO',IPOIN3,1)
  305. CALL ECROBJ ('LISTCHPO',IPOIN3)
  306.  
  307. ELSE
  308. MOTERR(1:8) = 'ENLEVER '
  309. CALL ERREUR(196)
  310. RETURN
  311. ENDIF
  312. IF (IPOS.LT.0 .AND. MLENTI.NE.0) SEGSUP,MLENTI
  313. RETURN
  314.  
  315.  
  316. C +---------------------------------------------------------------+
  317. C | O B J E T 1 D E T Y P E MCHAML |
  318. C +---------------------------------------------------------------+
  319. C 600 CONTINUE
  320. C CALL LIROBJ('MCHAML',IPMCH,1,IRETOU)
  321. C IF (IERR .NE. 0) RETURN
  322. C CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  323. C IF (IERR .NE. 0) RETURN
  324. C
  325. C IF(IRETOU.NE.0) THEN
  326. C CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)
  327. C IF (IERR .NE. 0) RETURN
  328. C
  329. C ELSE
  330. C JGN = 4
  331. C JGM = 10
  332. C INCJGM = 10
  333. C SEGINI,MLMOTS
  334. C IB = 0
  335. C 601 CALL LIRCHA(CMOMOT,0,IRETOU)
  336. C IF(IRETOU.EQ.0) GOTO 602
  337. C IB=IB+1
  338. C IF (IB .GT. JGM) THEN
  339. C JGM = JGM + INCJGM
  340. C INCJGM = INCJGM * 2
  341. C SEGADJ,MLMOTS
  342. C ENDIF
  343. C MLMOTS.MOTS(IB)=CMOMOT
  344. C GOTO 601
  345. C
  346. C 602 CONTINUE
  347. C IF(IB .EQ. 0) THEN
  348. C CALL ERREUR(6)
  349. C RETURN
  350. C
  351. C ELSEIF(IB .NE. JGM)THEN
  352. C JGM = IB
  353. C SEGADJ,MLMOTS
  354. C ENDIF
  355. C
  356. C CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)
  357. C IF (IERR .NE. 0) RETURN
  358. C SEGSUP MLMOTS
  359. C ENDIF
  360. C
  361. C CALL ECROBJ ('MCHAML',IPOIN2)
  362. C RETURN
  363. END
  364.  
  365.  
  366.  
  367.  
  368.  

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