Télécharger enleve.eso

Retour à la liste

Numérotation des lignes :

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

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