Télécharger enleve.eso

Retour à la liste

Numérotation des lignes :

  1. C ENLEVE SOURCE CB215821 17/04/20 21:15:09 9406
  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
  54. C MODE DE FONCTIONNEMENT:
  55. C -----------------------
  56. C
  57. C APPEL D'UN SOUS-PROGRAMME DISTINCT SELON LE TYPE OBJET1 :
  58. C LISTREEL => ENLEV1
  59. C LISTENTI => ENLEV2
  60. C LISTMOTS => ENLEV3
  61. C LISTCHPO => ENLEV4
  62. C CHPOINT => ENLEV5
  63. C TABLE => ENLEV6
  64. C CHARGEMENT => traite en interne dans cette subroutine
  65. C MMODEL => ENLEV7
  66. C
  67. C
  68. C AUTEUR, DATE DE CREATION:
  69. C -------------------------
  70. C
  71. C PASCAL MANIGOT 5 DECEMBRE 1984
  72. C DATE DE MODIFICATION 22 JANVIER 88
  73. C P.M. 21/06/88: REINTRODUCTION DES TABLES.
  74. C JCARDO 9/12/14 : INDIC1 type LISTENTI pour OBJET1 type LISTxxxx
  75. C M.B. xx/06/16 : INDIC1 type MOT pour OBJET1 type MMODEL
  76. C
  77. C
  78. C LANGAGE:
  79. C --------
  80. C
  81. C FORTRAN77
  82. C
  83. C***********************************************************************
  84. C
  85. -INC CCOPTIO
  86. -INC SMLENTI
  87. -INC SMCHARG
  88. SEGMENT MSWMIL
  89. CHARACTER*(4) MOTDDL(IA)
  90. ENDSEGMENT
  91. C
  92. CHARACTER*(4) CMOMOT
  93. CHARACTER*8 CTYP
  94.  
  95. CALL QUETYP(CTYP,0,IRETOU)
  96. IF (IRETOU.EQ.0) THEN
  97. CALL ERREUR(533)
  98. RETURN
  99. ENDIF
  100. C
  101. C
  102. C +---------------------------------------------------------------+
  103. C | O B J E T 1 D E T Y P E T A B L E |
  104. C +---------------------------------------------------------------+
  105. C (A LAISSER EN PREMIERE POSITION DANS CE SOUS-PROGRAMME)
  106. C
  107. IF (CTYP.EQ.'TABLE') THEN
  108. CALL LIROBJ ('TABLE',IPTABL,0,IRETOU)
  109. IF (IRETOU .NE. 0) THEN
  110. CALL ENLEV6 (IPTABL,IPTAB2)
  111. IF (IERR .NE. 0) RETURN
  112. CALL ECROBJ ('TABLE',IPTAB2)
  113. RETURN
  114. END IF
  115. C
  116. C +---------------------------------------------------------------+
  117. C | O B J E T 1 D E T Y P E M M O D E L |
  118. C +---------------------------------------------------------------+
  119. C
  120. ELSE IF (CTYP.EQ.'MMODEL') THEN
  121. CALL LIROBJ ('MMODEL',IPMOD1,0,IRETOU)
  122. IF (IRETOU .NE. 0) THEN
  123. CALL ENLEV7 (IPMOD1,IPMOD2)
  124. IF (IERR .NE. 0) RETURN
  125. CALL ECROBJ ('MMODEL',IPMOD2)
  126. RETURN
  127. END IF
  128. C
  129. C
  130. C +---------------------------------------------------------------+
  131. C | O B J E T 1 D E T Y P E C H A R G E M E N T |
  132. C +---------------------------------------------------------------+
  133. C
  134. ELSE IF (CTYP.EQ.'CHARGEME') THEN
  135. CALL LIROBJ('CHARGEME',MCHARG,0,IRETOU)
  136. IF(IRETOU .NE. 0) THEN
  137. CALL LIRCHA(CMOMOT,1,IRETOU)
  138. IF(IERR.NE.0)RETURN
  139. segini,MCHAR1=MCHARG
  140. N=0
  141. segact mcharg
  142. do IU=1,KCHARG(/1)
  143. if(CHANOM(iu).ne.CMOMOT) then
  144. n=n+1
  145. mchar1.kcharg(n)=kcharg(iu)
  146. mchar1.chanat(n)=chanat(iu)
  147. mchar1.chanom(n)=chanom(iu)
  148. mchar1.chamob(n)=chamob(iu)
  149. mchar1.chalie(n)=chalie(iu)
  150. endif
  151. enddo
  152. segadj mchar1
  153. segdes mchar1,mcharg
  154. call ecrobj('CHARGEME',mchar1)
  155. return
  156. ENDIF
  157. C
  158. C
  159. C +---------------------------------------------------------------+
  160. C | O B J E T 1 D E T Y P E C H P O I N T |
  161. C +---------------------------------------------------------------+
  162. C
  163. ELSE IF (CTYP.EQ.'CHPOINT') THEN
  164. CALL LIROBJ('CHPOINT',IPCHP,0,IRETOU)
  165. IF(IRETOU.NE.0) THEN
  166. CALL LIROBJ('LISTMOTS',MSWMIL,0,IRETOU)
  167. IF(IRETOU.NE.0) THEN
  168. CALL ENLEV5(IPCHP,MSWMIL,IPOIN2)
  169. IF (IERR .NE. 0) RETURN
  170. CALL ECROBJ ('CHPOINT',IPOIN2)
  171. RETURN
  172. ELSE
  173. IA=0
  174. SEGINI MSWMIL
  175. 40 CALL LIRCHA(CMOMOT,0,IRETOU)
  176. IF(IRETOU.EQ.0) GO TO 41
  177. IA=IA+1
  178. SEGADJ MSWMIL
  179. MOTDDL(IA)=CMOMOT
  180. GO TO 40
  181. 41 CONTINUE
  182. IF(IA.EQ.0) THEN
  183. CALL ERREUR(6)
  184. RETURN
  185. ENDIF
  186. CALL ENLEV5(IPCHP,MSWMIL,IPOIN2)
  187. SEGSUP MSWMIL
  188. IF (IERR .NE. 0) RETURN
  189. CALL ECROBJ ('CHPOINT',IPOIN2)
  190. RETURN
  191. ENDIF
  192. ENDIF
  193. C
  194. C
  195. C +---------------------------------------------------------------+
  196. C | O B J E T 1 D E T Y P E L I S T x x x x |
  197. C +---------------------------------------------------------------+
  198. C
  199. ELSE IF (CTYP(1:4).EQ.'LIST') THEN
  200. C IPOS<>0 => on autorise IPOIN2 à contenir un LISTENTI
  201. IPOS=1
  202. CALL LIRE01 (IPOIN1,IPOS,IPOIN2)
  203. IF (IERR.NE.0) RETURN
  204. C
  205. C Si plusieurs indices sont donnes, on trie par ordre croissant
  206. C et on supprime les eventuels doublons
  207. IF (IPOS.LT.0) THEN
  208. MLENT2=IPOIN2
  209. SEGACT,MLENT2
  210. JG = MLENT2.LECT(/1)
  211. IF (JG.NE.0) THEN
  212. SEGINI,MLENT1=MLENT2
  213. IORDRE=0
  214. CALL ORDON2(MLENT1,.TRUE.,.FALSE.,IORDRE)
  215. SEGACT MLENT1
  216. SEGINI MLENTI
  217. LECT(1) = MLENT1.LECT(1)
  218. LL = 1
  219. IF (JG.GT.1) THEN
  220. M1 = LECT(1)
  221. DO JJ = 2, JG
  222. M2 = MLENT1.LECT(JJ)
  223. IF (M1.NE.M2) THEN
  224. LL = LL+1
  225. LECT(LL) = M2
  226. M1 = M2
  227. ENDIF
  228. ENDDO
  229. ENDIF
  230. JG = LL
  231. SEGADJ,MLENTI
  232. IPOIN2=MLENTI
  233. SEGSUP,MLENT1
  234. ENDIF
  235. SEGDES,MLENT2
  236. ENDIF
  237.  
  238. C ENLEVER DES INDICES D'UN LISTREEL
  239. IF (ABS(IPOS).EQ.1) THEN
  240. CALL ENLEV1 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  241. IF (IERR .NE. 0) RETURN
  242. CALL ECROBJ ('LISTREEL',IPOIN3)
  243.  
  244. C ENLEVER DES INDICES D'UN LISTENTI
  245. ELSEIF (ABS(IPOS).EQ.2) THEN
  246. CALL ENLEV2 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  247. IF (IERR .NE. 0) RETURN
  248. CALL ECROBJ ('LISTENTI',IPOIN3)
  249.  
  250. C ENLEVER DES INDICES D'UN LISTMOTS
  251. ELSEIF (ABS(IPOS).EQ.3) THEN
  252. CALL ENLEV3 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  253. IF (IERR .NE. 0) RETURN
  254. CALL ECROBJ ('LISTMOTS',IPOIN3)
  255.  
  256. C ENLEVER DES INDICES D'UN LISTCHPO
  257. ELSEIF (ABS(IPOS).EQ.4) THEN
  258. CALL ENLEV4 (IPOIN1,IPOIN2,IPOIN3,IPOS)
  259. IF (IERR .NE. 0) RETURN
  260. CALL ECROBJ ('LISTCHPO',IPOIN3)
  261.  
  262. ELSE
  263. MOTERR(1:8) = 'ENLEVER '
  264. CALL ERREUR(196)
  265. RETURN
  266. ENDIF
  267. IF (IPOS.LT.0) SEGSUP,MLENTI
  268.  
  269. ELSE
  270. CALL ERREUR(34)
  271. RETURN
  272. ENDIF
  273.  
  274. C RETURN
  275. END
  276.  
  277.  

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