Télécharger enleve.eso

Retour à la liste

Numérotation des lignes :

  1. C ENLEVE SOURCE CB215821 18/01/29 21:15:08 9715
  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. ELSE
  266. MLENTI = 0
  267. ENDIF
  268. SEGDES,MLENT2
  269. ENDIF
  270.  
  271. C ENLEVER DES INDICES D'UN LISTREEL
  272. IF (ABS(IPOS).EQ.1) THEN
  273. CALL ENLEV1 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  274. IF (IERR .NE. 0) RETURN
  275. CALL ECROBJ ('LISTREEL',IPOIN3)
  276.  
  277. C ENLEVER DES INDICES D'UN LISTENTI
  278. ELSEIF (ABS(IPOS).EQ.2) THEN
  279. CALL ENLEV2 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  280. IF (IERR .NE. 0) RETURN
  281. CALL ECROBJ ('LISTENTI',IPOIN3)
  282.  
  283. C ENLEVER DES INDICES D'UN LISTMOTS
  284. ELSEIF (ABS(IPOS).EQ.3) THEN
  285. CALL ENLEV3 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  286. IF (IERR .NE. 0) RETURN
  287. CALL ECROBJ ('LISTMOTS',IPOIN3)
  288.  
  289. C ENLEVER DES INDICES D'UN LISTCHPO
  290. ELSEIF (ABS(IPOS).EQ.4) THEN
  291. CALL ENLEV4 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  292. IF (IERR .NE. 0) RETURN
  293. CALL ECROBJ ('LISTCHPO',IPOIN3)
  294.  
  295. ELSE
  296. MOTERR(1:8) = 'ENLEVER '
  297. CALL ERREUR(196)
  298. RETURN
  299. ENDIF
  300. IF (IPOS.LT.0 .AND. MLENTI.NE.0) SEGSUP,MLENTI
  301. RETURN
  302.  
  303.  
  304. C +---------------------------------------------------------------+
  305. C | O B J E T 1 D E T Y P E MCHAML |
  306. C +---------------------------------------------------------------+
  307. C 600 CONTINUE
  308. C CALL LIROBJ('MCHAML',IPMCH,1,IRETOU)
  309. C IF (IERR .NE. 0) RETURN
  310. C CALL LIROBJ('LISTMOTS',MLMOTS,0,IRETOU)
  311. C IF (IERR .NE. 0) RETURN
  312. C
  313. C IF(IRETOU.NE.0) THEN
  314. C CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)
  315. C IF (IERR .NE. 0) RETURN
  316. C
  317. C ELSE
  318. C JGN = 4
  319. C JGM = 10
  320. C INCJGM = 10
  321. C SEGINI,MLMOTS
  322. C IB = 0
  323. C 601 CALL LIRCHA(CMOMOT,0,IRETOU)
  324. C IF(IRETOU.EQ.0) GOTO 602
  325. C IB=IB+1
  326. C IF (IB .GT. JGM) THEN
  327. C JGM = JGM + INCJGM
  328. C INCJGM = INCJGM * 2
  329. C SEGADJ,MLMOTS
  330. C ENDIF
  331. C MLMOTS.MOTS(IB)=CMOMOT
  332. C GOTO 601
  333. C
  334. C 602 CONTINUE
  335. C IF(IB .EQ. 0) THEN
  336. C CALL ERREUR(6)
  337. C RETURN
  338. C
  339. C ELSEIF(IB .NE. JGM)THEN
  340. C JGM = IB
  341. C SEGADJ,MLMOTS
  342. C ENDIF
  343. C
  344. C CALL ENLEV8(IPMCH,MLMOTS,IPOIN2)
  345. C IF (IERR .NE. 0) RETURN
  346. C SEGSUP MLMOTS
  347. C ENDIF
  348. C
  349. C CALL ECROBJ ('MCHAML',IPOIN2)
  350. C RETURN
  351. END
  352.  
  353.  
  354.  

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