Télécharger enleve.eso

Retour à la liste

Numérotation des lignes :

  1. C ENLEVE SOURCE CB215821 17/06/06 21:15:00 9450
  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 ENLEV7 (IPMOD1,IPMOD2)
  146. IF (IERR .NE. 0) RETURN
  147. CALL ECROBJ ('MMODEL',IPMOD2)
  148. RETURN
  149.  
  150.  
  151. C +---------------------------------------------------------------+
  152. C | O B J E T 1 D E T Y P E C H A R G E M E N T |
  153. C +---------------------------------------------------------------+
  154. 300 CONTINUE
  155. CALL LIROBJ('CHARGEME',MCHARG,1,IRETOU)
  156. IF (IERR .NE. 0) RETURN
  157. CALL LIRCHA(CMOMOT,1,IRETOU)
  158. IF (IERR .NE. 0) RETURN
  159. segini,MCHAR1=MCHARG
  160. N=0
  161. segact mcharg
  162. do IU=1,KCHARG(/1)
  163. if(CHANOM(iu).ne.CMOMOT) then
  164. n=n+1
  165. mchar1.kcharg(n)=kcharg(iu)
  166. mchar1.chanat(n)=chanat(iu)
  167. mchar1.chanom(n)=chanom(iu)
  168. mchar1.chamob(n)=chamob(iu)
  169. mchar1.chalie(n)=chalie(iu)
  170. endif
  171. enddo
  172. segadj mchar1
  173. segdes mchar1,mcharg
  174. call ecrobj('CHARGEME',mchar1)
  175. return
  176.  
  177.  
  178. C +---------------------------------------------------------------+
  179. C | O B J E T 1 D E T Y P E C H P O I N T |
  180. C +---------------------------------------------------------------+
  181. 400 CONTINUE
  182. CALL LIROBJ('CHPOINT',IPCHP,1,IRETOU)
  183. IF (IERR .NE. 0) RETURN
  184. CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  185. IF (IERR .NE. 0) RETURN
  186.  
  187. IF(IRETOU.NE.0) THEN
  188. CALL ENLEV5(IPCHP,MLMOTS,IPOIN2)
  189. IF (IERR .NE. 0) RETURN
  190.  
  191. ELSE
  192. JGN = 4
  193. JGM = 10
  194. INCJGM = 10
  195. SEGINI,MLMOTS
  196. IB = 0
  197. 401 CALL LIRCHA(CMOMOT,0,IRETOU)
  198. IF(IRETOU.EQ.0) GOTO 402
  199. IB=IB+1
  200. IF (IB .GT. JGM) THEN
  201. JGM = JGM + INCJGM
  202. INCJGM = INCJGM * 2
  203. SEGADJ,MLMOTS
  204. ENDIF
  205. MLMOTS.MOTS(IB)=CMOMOT
  206. GOTO 401
  207.  
  208. 402 CONTINUE
  209. IF(IB .EQ. 0) THEN
  210. CALL ERREUR(6)
  211. RETURN
  212.  
  213. ELSEIF(IB .NE. JGM)THEN
  214. JGM = IB
  215. SEGADJ,MLMOTS
  216. ENDIF
  217.  
  218. CALL ENLEV5(IPCHP,MLMOTS,IPOIN2)
  219. IF (IERR .NE. 0) RETURN
  220. SEGSUP MLMOTS
  221. ENDIF
  222.  
  223. CALL ECROBJ ('CHPOINT',IPOIN2)
  224. RETURN
  225.  
  226.  
  227. C +---------------------------------------------------------------+
  228. C | O B J E T 1 D E T Y P E L I S T x x x x |
  229. C +---------------------------------------------------------------+
  230. 500 CONTINUE
  231. C IPOS<>0 => on autorise IPOIN2 à contenir un LISTENTI
  232. IPOS=1
  233. CALL LIRE01 (IPOIN1,IPOS,IPOIN2)
  234. IF (IERR.NE.0) RETURN
  235. C
  236. C Si plusieurs indices sont donnes, on trie par ordre croissant
  237. C et on supprime les eventuels doublons
  238. IF (IPOS.LT.0) THEN
  239. MLENT2=IPOIN2
  240. SEGACT,MLENT2
  241. JG = MLENT2.LECT(/1)
  242. IF (JG.NE.0) THEN
  243. SEGINI,MLENT1=MLENT2
  244. IORDRE=0
  245. CALL ORDON2(MLENT1,.TRUE.,.FALSE.,IORDRE)
  246. SEGACT,MLENT1
  247. SEGINI,MLENTI
  248. LECT(1) = MLENT1.LECT(1)
  249. LL = 1
  250. IF (JG.GT.1) THEN
  251. M1 = LECT(1)
  252. DO JJ = 2, JG
  253. M2 = MLENT1.LECT(JJ)
  254. IF (M1.NE.M2) THEN
  255. LL = LL+1
  256. LECT(LL) = M2
  257. M1 = M2
  258. ENDIF
  259. ENDDO
  260. ENDIF
  261. JG = LL
  262. SEGADJ,MLENTI
  263. IPOIN2=MLENTI
  264. SEGSUP,MLENT1
  265. ENDIF
  266. SEGDES,MLENT2
  267. ENDIF
  268.  
  269. C ENLEVER DES INDICES D'UN LISTREEL
  270. IF (ABS(IPOS).EQ.1) THEN
  271. CALL ENLEV1 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  272. IF (IERR .NE. 0) RETURN
  273. CALL ECROBJ ('LISTREEL',IPOIN3)
  274.  
  275. C ENLEVER DES INDICES D'UN LISTENTI
  276. ELSEIF (ABS(IPOS).EQ.2) THEN
  277. CALL ENLEV2 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  278. IF (IERR .NE. 0) RETURN
  279. CALL ECROBJ ('LISTENTI',IPOIN3)
  280.  
  281. C ENLEVER DES INDICES D'UN LISTMOTS
  282. ELSEIF (ABS(IPOS).EQ.3) THEN
  283. CALL ENLEV3 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  284. IF (IERR .NE. 0) RETURN
  285. CALL ECROBJ ('LISTMOTS',IPOIN3)
  286.  
  287. C ENLEVER DES INDICES D'UN LISTCHPO
  288. ELSEIF (ABS(IPOS).EQ.4) THEN
  289. CALL ENLEV4 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  290. IF (IERR .NE. 0) RETURN
  291. CALL ECROBJ ('LISTCHPO',IPOIN3)
  292.  
  293. ELSE
  294. MOTERR(1:8) = 'ENLEVER '
  295. CALL ERREUR(196)
  296. RETURN
  297. ENDIF
  298. IF (IPOS.LT.0) SEGSUP,MLENTI
  299. RETURN
  300.  
  301.  
  302. C +---------------------------------------------------------------+
  303. C | O B J E T 1 D E T Y P E MCHAML |
  304. C +---------------------------------------------------------------+
  305. C 600 CONTINUE
  306. C CALL LIROBJ('MCHAML',IPMCH,1,IRETOU)
  307. C IF (IERR .NE. 0) RETURN
  308. C CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  309. C IF (IERR .NE. 0) RETURN
  310. C
  311. C IF(IRETOU.NE.0) THEN
  312. C CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)
  313. C IF (IERR .NE. 0) RETURN
  314. C
  315. C ELSE
  316. C JGN = 4
  317. C JGM = 10
  318. C INCJGM = 10
  319. C SEGINI,MLMOTS
  320. C IB = 0
  321. C 601 CALL LIRCHA(CMOMOT,0,IRETOU)
  322. C IF(IRETOU.EQ.0) GOTO 602
  323. C IB=IB+1
  324. C IF (IB .GT. JGM) THEN
  325. C JGM = JGM + INCJGM
  326. C INCJGM = INCJGM * 2
  327. C SEGADJ,MLMOTS
  328. C ENDIF
  329. C MLMOTS.MOTS(IB)=CMOMOT
  330. C GOTO 601
  331. C
  332. C 602 CONTINUE
  333. C IF(IB .EQ. 0) THEN
  334. C CALL ERREUR(6)
  335. C RETURN
  336. C
  337. C ELSEIF(IB .NE. JGM)THEN
  338. C JGM = IB
  339. C SEGADJ,MLMOTS
  340. C ENDIF
  341. C
  342. C CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)
  343. C IF (IERR .NE. 0) RETURN
  344. C SEGSUP MLMOTS
  345. C ENDIF
  346. C
  347. C CALL ECROBJ ('MCHAML',IPOIN2)
  348.  
  349. RETURN
  350. END
  351.  
  352.  
  353.  
  354.  

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