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. -INC CCOPTIO
  94. -INC SMLENTI
  95. -INC SMLMOTS
  96. -INC SMCHARG
  97. C
  98. CHARACTER*(4) CMOMOT
  99. CHARACTER*8 CTYP
  100.  
  101. PARAMETER (NBTYP=8)
  102. CHARACTER*8 TYPOK(NBTYP)
  103.  
  104. DATA TYPOK /'TABLE ','MMODEL ','CHARGEME','CHPOINT ',
  105. & 'LISTREEL','LISTENTI','LISTMOTS','LISTCHPO'/
  106.  
  107. CALL QUETYP(CTYP,0,IRETOU)
  108. IF (IRETOU.EQ.0) THEN
  109. CALL ERREUR(533)
  110. RETURN
  111. ENDIF
  112.  
  113. C Recherche de la position dans le DATA
  114. CALL PLACE(TYPOK,NBTYP,IPLACE,CTYP)
  115. IF (IERR .NE. 0) RETURN
  116.  
  117. IF (IPLACE .EQ. 0) THEN
  118. CALL ERREUR(34)
  119. RETURN
  120. ENDIF
  121.  
  122. GOTO(100,200,300,400,500,500,500,500),IPLACE
  123.  
  124.  
  125. C +---------------------------------------------------------------+
  126. C | O B J E T 1 D E T Y P E T A B L E |
  127. C +---------------------------------------------------------------+
  128. C (A LAISSER EN PREMIERE POSITION DANS CE SOUS-PROGRAMME)
  129.  
  130. 100 CONTINUE
  131. CALL LIROBJ ('TABLE',IPTABL,1,IRETOU)
  132. IF (IERR .NE. 0) RETURN
  133. CALL ENLEV6 (IPTABL,IPTAB2)
  134. IF (IERR .NE. 0) RETURN
  135. CALL ECROBJ ('TABLE',IPTAB2)
  136. RETURN
  137.  
  138.  
  139. C +---------------------------------------------------------------+
  140. C | O B J E T 1 D E T Y P E M M O D E L |
  141. C +---------------------------------------------------------------+
  142. 200 CONTINUE
  143. CALL LIROBJ ('MMODEL ',IPMOD1,1,IRETOU)
  144. IF (IERR .NE. 0) RETURN
  145. CALL ACTOBJ ('MMODEL ',IPMOD1,1)
  146. CALL ENLEV7 (IPMOD1,IPMOD2)
  147. IF (IERR .NE. 0) RETURN
  148. CALL ACTOBJ ('MMODEL ',IPMOD2,1)
  149. CALL ECROBJ ('MMODEL ',IPMOD2)
  150. RETURN
  151.  
  152.  
  153. C +---------------------------------------------------------------+
  154. C | O B J E T 1 D E T Y P E C H A R G E M E N T |
  155. C +---------------------------------------------------------------+
  156. 300 CONTINUE
  157. CALL LIROBJ('CHARGEME',MCHARG,1,IRETOU)
  158. IF (IERR .NE. 0) RETURN
  159. CALL ACTOBJ('CHARGEME',MCHARG,1)
  160. CALL LIRCHA(CMOMOT,1,IRETOU)
  161. IF (IERR .NE. 0) RETURN
  162. segini,MCHAR1=MCHARG
  163. N=0
  164. segact mcharg
  165. do IU=1,KCHARG(/1)
  166. if(CHANOM(iu).ne.CMOMOT) then
  167. n=n+1
  168. mchar1.kcharg(n)=kcharg(iu)
  169. mchar1.chanat(n)=chanat(iu)
  170. mchar1.chanom(n)=chanom(iu)
  171. mchar1.chamob(n)=chamob(iu)
  172. mchar1.chalie(n)=chalie(iu)
  173. endif
  174. enddo
  175. segadj mchar1
  176. call actobj('CHARGEME',mchar1,1)
  177. call ecrobj('CHARGEME',mchar1)
  178. return
  179.  
  180.  
  181. C +---------------------------------------------------------------+
  182. C | O B J E T 1 D E T Y P E C H P O I N T |
  183. C +---------------------------------------------------------------+
  184. 400 CONTINUE
  185. CALL LIROBJ('CHPOINT ',IPCHP,1,IRETOU)
  186. IF (IERR .NE. 0) RETURN
  187. CALL ACTOBJ('CHPOINT ',IPCHP,1)
  188. CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  189. IF (IERR .NE. 0) RETURN
  190.  
  191. IF(IRETOU.NE.0) THEN
  192. CALL ACTOBJ('LISTMOTS',MLMOTS,1)
  193. CALL ENLEV5(IPCHP,MLMOTS,IPOIN2)
  194. IF (IERR .NE. 0) RETURN
  195.  
  196. ELSE
  197. JGN = 4
  198. JGM = 10
  199. INCJGM = 10
  200. SEGINI,MLMOTS
  201. IB = 0
  202. 401 CALL LIRCHA(CMOMOT,0,IRETOU)
  203. IF(IRETOU.EQ.0) GOTO 402
  204. IB=IB+1
  205. IF (IB .GT. JGM) THEN
  206. JGM = JGM + INCJGM
  207. INCJGM = INCJGM * 2
  208. SEGADJ,MLMOTS
  209. ENDIF
  210. MLMOTS.MOTS(IB)=CMOMOT
  211. GOTO 401
  212.  
  213. 402 CONTINUE
  214. IF(IB .EQ. 0) THEN
  215. CALL ERREUR(6)
  216. RETURN
  217.  
  218. ELSEIF(IB .NE. JGM)THEN
  219. JGM = IB
  220. SEGADJ,MLMOTS
  221. ENDIF
  222.  
  223. CALL ENLEV5(IPCHP,MLMOTS,IPOIN2)
  224. IF (IERR .NE. 0) RETURN
  225. SEGSUP MLMOTS
  226. ENDIF
  227.  
  228. CALL ACTOBJ ('CHPOINT ',IPOIN2,1)
  229. CALL ECROBJ ('CHPOINT ',IPOIN2)
  230. RETURN
  231.  
  232.  
  233. C +---------------------------------------------------------------+
  234. C | O B J E T 1 D E T Y P E L I S T x x x x |
  235. C +---------------------------------------------------------------+
  236. 500 CONTINUE
  237. C IPOS<>0 => on autorise IPOIN2 à contenir un LISTENTI
  238. IPOS=1
  239. CALL LIRE01 (IPOIN1,IPOS,IPOIN2)
  240. IF (IERR.NE.0) RETURN
  241. C
  242. C Si plusieurs indices sont donnes, on trie par ordre croissant
  243. C et on supprime les eventuels doublons
  244. IF (IPOS.LT.0) THEN
  245. MLENT2=IPOIN2
  246. SEGACT,MLENT2
  247. JG = MLENT2.LECT(/1)
  248. IF (JG.NE.0) THEN
  249. SEGINI,MLENT1=MLENT2
  250. IORDRE=0
  251. CALL ORDON2(MLENT1,.TRUE.,.FALSE.,IORDRE)
  252. SEGACT,MLENT1
  253. SEGINI,MLENTI
  254. LECT(1) = MLENT1.LECT(1)
  255. LL = 1
  256. IF (JG.GT.1) THEN
  257. M1 = LECT(1)
  258. DO JJ = 2, JG
  259. M2 = MLENT1.LECT(JJ)
  260. IF (M1.NE.M2) THEN
  261. LL = LL+1
  262. LECT(LL) = M2
  263. M1 = M2
  264. ENDIF
  265. ENDDO
  266. ENDIF
  267. JG = LL
  268. SEGADJ,MLENTI
  269. IPOIN2=MLENTI
  270. SEGSUP,MLENT1
  271. ELSE
  272. MLENTI = 0
  273. ENDIF
  274. ENDIF
  275.  
  276. C ENLEVER DES INDICES D'UN LISTREEL
  277. IF (ABS(IPOS).EQ.1) THEN
  278. CALL ENLEV1 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  279. IF (IERR .NE. 0) RETURN
  280. CALL ACTOBJ ('LISTREEL',IPOIN3,1)
  281. CALL ECROBJ ('LISTREEL',IPOIN3)
  282.  
  283. C ENLEVER DES INDICES D'UN LISTENTI
  284. ELSEIF (ABS(IPOS).EQ.2) THEN
  285. CALL ENLEV2 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  286. IF (IERR .NE. 0) RETURN
  287. CALL ACTOBJ ('LISTENTI',IPOIN3,1)
  288. CALL ECROBJ ('LISTENTI',IPOIN3)
  289.  
  290. C ENLEVER DES INDICES D'UN LISTMOTS
  291. ELSEIF (ABS(IPOS).EQ.3) THEN
  292. CALL ENLEV3 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  293. IF (IERR .NE. 0) RETURN
  294. CALL ACTOBJ ('LISTMOTS',IPOIN3,1)
  295. CALL ECROBJ ('LISTMOTS',IPOIN3)
  296.  
  297. C ENLEVER DES INDICES D'UN LISTCHPO
  298. ELSEIF (ABS(IPOS).EQ.4) THEN
  299. CALL ENLEV4 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  300. IF (IERR .NE. 0) RETURN
  301. CALL ACTOBJ ('LISTCHPO',IPOIN3,1)
  302. CALL ECROBJ ('LISTCHPO',IPOIN3)
  303.  
  304. ELSE
  305. MOTERR(1:8) = 'ENLEVER '
  306. CALL ERREUR(196)
  307. RETURN
  308. ENDIF
  309. IF (IPOS.LT.0 .AND. MLENTI.NE.0) SEGSUP,MLENTI
  310. RETURN
  311.  
  312.  
  313. C +---------------------------------------------------------------+
  314. C | O B J E T 1 D E T Y P E MCHAML |
  315. C +---------------------------------------------------------------+
  316. C 600 CONTINUE
  317. C CALL LIROBJ('MCHAML',IPMCH,1,IRETOU)
  318. C IF (IERR .NE. 0) RETURN
  319. C CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  320. C IF (IERR .NE. 0) RETURN
  321. C
  322. C IF(IRETOU.NE.0) THEN
  323. C CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)
  324. C IF (IERR .NE. 0) RETURN
  325. C
  326. C ELSE
  327. C JGN = 4
  328. C JGM = 10
  329. C INCJGM = 10
  330. C SEGINI,MLMOTS
  331. C IB = 0
  332. C 601 CALL LIRCHA(CMOMOT,0,IRETOU)
  333. C IF(IRETOU.EQ.0) GOTO 602
  334. C IB=IB+1
  335. C IF (IB .GT. JGM) THEN
  336. C JGM = JGM + INCJGM
  337. C INCJGM = INCJGM * 2
  338. C SEGADJ,MLMOTS
  339. C ENDIF
  340. C MLMOTS.MOTS(IB)=CMOMOT
  341. C GOTO 601
  342. C
  343. C 602 CONTINUE
  344. C IF(IB .EQ. 0) THEN
  345. C CALL ERREUR(6)
  346. C RETURN
  347. C
  348. C ELSEIF(IB .NE. JGM)THEN
  349. C JGM = IB
  350. C SEGADJ,MLMOTS
  351. C ENDIF
  352. C
  353. C CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)
  354. C IF (IERR .NE. 0) RETURN
  355. C SEGSUP MLMOTS
  356. C ENDIF
  357. C
  358. C CALL ECROBJ ('MCHAML',IPOIN2)
  359. C RETURN
  360. END
  361.  
  362.  
  363.  
  364.  

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