Télécharger detrui.eso

Retour à la liste

Numérotation des lignes :

  1. C DETRUI SOURCE JC220346 18/12/04 21:15:12 9991
  2. SUBROUTINE DETRUI
  3. C
  4. C **** OPERATEUR DETR : DETRUIT UN OBJET DE TYPE SUIVANT:
  5. C **** CHPOINT,RIGIDITE,MCHAML,LISTREEL,LISTENTI,LISTMOTS,SOLUTION,
  6. C **** EVOLUTIO,ELEMENT,ATTACHE
  7. C
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8(A-H,O-Z)
  10. character*(8) icara,typobj,charre
  11. integer i,ico, icoo, id1, id2, idet, ii, iins, im
  12. integer ind, iob, ipile, irat, iret, ireti, iretou
  13. integer ith, ithh, ival, ivalre, ktrace, ml
  14. integer nbelem,nbnn, nbref, nbsou, nbsous
  15. real*8 xvalre
  16. logical logr1
  17. character*4 motout(2)
  18. character*6 msorse
  19. save ktrace
  20.  
  21. -INC CCOPTIO
  22. -INC CCNOYAU
  23. -INC COCOLL
  24. -INC CCASSIS
  25. -INC SMCOORD
  26. -INC SMELEME
  27. -INC SMLREEL
  28. -INC SMLENTI
  29. -INC SMLMOTS
  30. -INC TMCOLAC
  31. -INC SMTABLE
  32.  
  33. character*(LONOM) icarb
  34.  
  35. pointeur piles.LISPIL
  36. pointeur jcolac.ICOLAC
  37. pointeur jlisse.ILISSE
  38. pointeur jtlacc.ITLACC
  39.  
  40. data KTRACE /-1/
  41. DATA MOTOUT/'TOUT','TRAC'/
  42.  
  43. icara=' '
  44. call lirabj(ICARA,iob,1,iretou)
  45. IF(IRETOU.EQ.0) THEN
  46. CALL ERREUR (533)
  47. RETURN
  48. ENDIF
  49. call refus
  50. ith=0
  51. ith=oothrd
  52. if(ith.ne.0) then
  53. call erreur (1010)
  54. return
  55. endif
  56. * verif que l'objet n'est pas dans les queues d'execution
  57. if (NBESC.NE.0) then
  58. do ithh=1,nbesc
  59. idet=0
  60. mesins= mescl(ithh)
  61. segact mesins*(mod,ecr=1)
  62. do iins=1,nbins
  63. mescla=lismes(iins)
  64. if (mescla.ne.0) then
  65. segact mescla
  66. do im=1,100
  67. if (.not.esoplu(im)) then
  68. if (esopva(im).eq.iob.and.esopty(im).eq.icara)
  69. > idet=nbins-iins+1
  70. endif
  71. enddo
  72. segdes mescla
  73. else
  74. write(6,*) ' mescla nul iins nbins ithh',iins,nbins,ithh
  75. endif
  76. enddo
  77. if (idet.ne.0) then
  78. * objet en queue d'execution. On attend
  79. 20 if(nbins.ge.idet) then
  80. ** write(6,*)'on attend la fin de l''assistant nbins',ithh,nbins
  81. segdes mesins*record
  82. segact mesins*(mod,ecr=1)
  83. go to 20
  84. endif
  85. endif
  86. segdes mesins*record
  87. enddo
  88. * blocage des assistants en fin d'instruction
  89. mestra=imestr
  90. segact mestra*mod
  91. segdes mestra
  92. endif
  93. * plus rien en attente d'execution. on peut detruire
  94. call ooohor(0,ith)
  95. icarb=' '
  96. ICOO=0
  97. IF(IPSAUV.NE.0) THEN
  98. ICOLAC=IPSAUV
  99. SEGACT ICOLAC
  100. ILISSE=ILISSG
  101. SEGACT ILISSE*MOD
  102. ENDIF
  103. C Activation des piles de communication si elles existent
  104. if(piComm.gt.0) then
  105. piles=piComm
  106. segact piles
  107. do ipile=1,piles.proc(/1)
  108. jcolac= piles.proc(ipile)
  109. if(jcolac.ne.0) then
  110. segact jcolac
  111. jlisse=jcolac.ilissg
  112. segact jlisse*mod
  113. endif
  114. enddo
  115. endif
  116.  
  117. CALL LIRTAB('ESCLAVE',mtable,0,iretou)
  118. if( iretou.ne.0) then
  119. * tc on prefere ne rien faire!
  120. if(iretou.gt.0) goto 10000
  121. call quenom (icarb)
  122. call typfil ( 'TABLE' ,ICOO)
  123. typobj=' '
  124. segact mtable
  125. ml=mlotab
  126. ind=mtabii(2)
  127. call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,typobj,
  128. > ivalre,xvalre,charre,logr1,id1)
  129. if (ierr.ne.0) goto 10000
  130. * if (typobj.eq.'CHPOINT'.or.typobj.eq.'MCHAML')then
  131. if (typobj.eq.'MCHAML')then
  132. do i=2,ml
  133. segact mtable
  134. ind=mtabii(i)
  135. call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  136. > typobj,ivalre,xvalre,charre,logr1,id2)
  137. if (ierr.ne.0) goto 10000
  138. * if (typobj.eq.'CHPOINT') call fuchpo(id1,id2,iretou)
  139. if (typobj.eq.'MCHAML') call dtchaZ (id2,ktrace,msorse)
  140. enddo
  141. endif
  142. GOTO 5000
  143. endif
  144. CALL LIRMOT(MOTOUT(2),1,ival,0)
  145. if(ival.eq.1) then
  146. call lirent (ival,1,iretou)
  147. if( ierr.ne.0) goto 10000
  148. ktrace=ival
  149. goto 10000
  150. endif
  151. CALL LIROBJ('CHPOINT',IRET,0,IRETOU)
  152. IF (IRETOU.EQ.1) THEN
  153. IRETI=IRET
  154. CALL TYPFIL('CHPOINT ',ICOO)
  155. if(ith.eq.0) CALL QUENOM (ICARB)
  156. CALL DTCHPZ(IRET,ktrace,msorse)
  157. GO TO 5000
  158. ENDIF
  159. CALL LIROBJ('MCHAML ',IRET,0,IRETOU)
  160. IF (IRETOU.EQ.1) THEN
  161. IRETI=IRET
  162. CALL TYPFIL('MCHAML ',ICOO)
  163. if(ith.eq.0) CALL QUENOM (ICARB)
  164. CALL DTCHAZ(IRET,KTRACE,msorse)
  165. GO TO 5000
  166. ENDIF
  167. CALL LIROBJ('RIGIDITE',IRET,0,IRETOU)
  168. IF (IRETOU.EQ.1) THEN
  169. IRETI=IRET
  170. CALL TYPFIL('RIGIDITE',ICOO)
  171. if(ith.eq.0) CALL QUENOM (ICARB)
  172. CALL DTRIGZ(IRET,KTRACE,msorse)
  173. GO TO 5000
  174. ENDIF
  175. CALL LIROBJ('LISTREEL',IRET,0,IRETOU)
  176. IF (IRETOU.EQ.1) THEN
  177. IRETI=IRET
  178. CALL TYPFIL('LISTREEL',ICOO)
  179. if(ith.eq.0) CALL QUENOM (ICARB)
  180. MLREEL=IRET
  181. msorse='MLREEL'
  182. IF(ktrace.eq.mlreel) ktrace=-ktrace
  183. SEGSUP MLREEL
  184. GO TO 5000
  185. ENDIF
  186. CALL LIROBJ('LISTENTI',IRET,0,IRETOU)
  187. IF (IRETOU.EQ.1) THEN
  188. IRETI=IRET
  189. CALL TYPFIL('LISTENTI',ICOO)
  190. if(ith.eq.0) CALL QUENOM (ICARB)
  191. MLENTI=IRET
  192. msorse='MLENTI'
  193. if(ktrace.eq.mlenti) ktrace=-ktrace
  194. SEGSUP MLENTI
  195. GO TO 5000
  196. ENDIF
  197. CALL LIROBJ('LISTMOTS',IRET,0,IRETOU)
  198. IF (IRETOU.EQ.1) THEN
  199. IRETI=IRET
  200. CALL TYPFIL('LISTMOTS',ICOO)
  201. if(ith.eq.0) CALL QUENOM (ICARB)
  202. MLMOTS=IRET
  203. msorse='MLMOTS'
  204. if(ktrace.eq.mlmots) ktrace=-ktrace
  205. SEGSUP MLMOTS
  206. GO TO 5000
  207. ENDIF
  208. CALL LIROBJ('SOLUTION',IRET,0,IRETOU)
  209. IF (IRETOU.EQ.1) THEN
  210. IRETI=IRET
  211. CALL TYPFIL('SOLUTION',ICOO)
  212. if(ith.eq.0) CALL QUENOM (ICARB)
  213. CALL DTSOLZ(IRET,KTRACE,msorse)
  214. GO TO 5000
  215. ENDIF
  216. CALL LIROBJ('EVOLUTIO',IRET,0,IRETOU)
  217. IF (IRETOU.EQ.1) THEN
  218. CALL TYPFIL('EVOLUTIO',ICOO)
  219. if(ith.eq.0) CALL QUENOM (ICARB)
  220. CALL LIRMOT(MOTOUT,1,IRAT,0)
  221. CALL DTEVOZ(IRET,IRAT,KTRACE,msorse)
  222. GO TO 5000
  223. ENDIF
  224. CALL LIROBJ('MAILLAGE',IRET,0,IRETOU)
  225. IF (IRETOU.EQ.1) THEN
  226. IRETI=IRET
  227. CALL TYPFIL('MAILLAGE',ICOO)
  228. if(ith.eq.0) CALL QUENOM (ICARB)
  229. MELEME=IRET
  230. CALL LIRMOT(MOTOUT,1,IRAT,0)
  231. SEGACT MELEME*MOD
  232. IF(IRAT.EQ.1) THEN
  233. NBSOU=LISOUS(/1)
  234. IF(NBSOU.GT.0) THEN
  235. IF(IPSAUV.NE.0) THEN
  236. ICOLAC = IPSAUV
  237. CALL TYPFIL('MAILLAGE',ICO)
  238. ITLACC = KCOLA(ICO)
  239. SEGACT ITLACC*MOD
  240. ENDIF
  241. if(piComm.gt.0) then
  242. CALL TYPFIL('MAILLAGE',ICO)
  243. do ipile=1,piles.proc(/1)
  244. jcolac= piles.proc(ipile)
  245. if(jcolac.ne.0) then
  246. jlisse=jcolac.ilissg
  247. jtlacc=jcolac.kcola(ico)
  248. segact jtlacc*mod
  249. endif
  250. enddo
  251. endif
  252.  
  253. DO 1080 I=1,LISOUS(/1)
  254. IPT1=LISOUS(I)
  255. msorse='MELEME'
  256. if( ktrace.eq.ipt1) ktrace=-ktrace
  257. SEGSUP IPT1
  258. IF(IPSAUV.NE.0) then
  259. CALL AJOUN0(ITLACC,IPT1,ILISSE,1)
  260. segdes ITLACC
  261. endif
  262. C Suppression du maillage des piles d'objets communiques
  263. if(piComm.gt.0) then
  264. do ipile=1,piles.proc(/1)
  265. jcolac= piles.proc(ipile)
  266. if(jcolac.ne.0) then
  267. jlisse=jcolac.ilissg
  268. jtlacc=jcolac.kcola(ico)
  269. call ajoun0(jtlacc,IPT1,jlisse,1)
  270. segdes jtlacc
  271. endif
  272. enddo
  273. endif
  274. 1080 CONTINUE
  275. IF(IPSAUV.NE.0) THEN
  276. SEGDES ITLACC
  277. ENDIF
  278. if(piComm.gt.0) then
  279. do ipile=1,piles.proc(/1)
  280. jcolac= piles.proc(ipile)
  281. if(jcolac.ne.0) then
  282. jlisse=jcolac.ilissg
  283. jtlacc=jcolac.kcola(ico)
  284. segdes jtlacc
  285. endif
  286. enddo
  287. endif
  288.  
  289. ENDIF
  290. ENDIF
  291. NBNN=0
  292. NBELEM=0
  293. NBREF=0
  294. NBSOUS=0
  295. ITYPEL=0
  296. SEGADJ MELEME
  297. GO TO 5000
  298. ENDIF
  299. CALL LIROBJ('CONFIGUR',IRET,0,IRETOU)
  300. IF (IRETOU.EQ.1) THEN
  301. IRETI=IRET
  302. CALL TYPFIL('CONFIGUR',ICOO)
  303. if(ith.eq.0) CALL QUENOM (ICARB)
  304. II=MCOORD
  305. MCOORD=IRET
  306. IF(IRET.EQ.II) goto 10000
  307. * SEGSUP MCOORD
  308. segdes mcoord
  309. MCOORD=II
  310. GO TO 5000
  311. ENDIF
  312. CALL LIROBJ('ATTACHE ',IRET,0,IRETOU)
  313. IF (IRETOU.EQ.1) THEN
  314. IRETI=IRET
  315. CALL TYPFIL('ATTACHE ',ICOO)
  316. if(ith.eq.0) CALL QUENOM (ICARB)
  317. CALL DTMATZ(IRET,KTRACE,msorse)
  318. GO TO 5000
  319. ENDIF
  320. CALL LIROBJ('SUPERELE',IRET,0,IRETOU)
  321. IF (IRETOU.EQ.1) THEN
  322. IRETI=IRET
  323. CALL TYPFIL('SUPERELE',ICOO)
  324. if(ith.eq.0) CALL QUENOM (ICARB)
  325. CALL DTSUPZ(IRET,KTRACE,msorse)
  326. GO TO 5000
  327. ENDIF
  328. MOTERR(1:8)=ICARA
  329. CALL ERREUR(168)
  330. C L OPERATEUR DETRUIRE NE FONCTIONNE PAS POUR UN OBJET DE CE TYPE
  331. goto 10000
  332. 5000 CONTINUE
  333. IF(ith.eq.0.and.ICARB.NE.' ')
  334. > CALL NOMOBJ('ANNULE ',ICARB,0)
  335. IF( IPSAUV.NE.0) THEN
  336. IF(ICOO.NE.0) THEN
  337. ITLACC = KCOLA(ICOO)
  338. SEGACT ITLACC*MOD
  339. CALL AJOUN0(ITLACC,IRETI,ILISSE,1)
  340. SEGDES ITLACC
  341. ENDIF
  342. ENDIF
  343. C Desactivation des piles de communication si elles existent
  344. if(piComm.gt.0) then
  345. if(icoo.ne.0) then
  346. do ipile=1,piles.proc(/1)
  347. jcolac= piles.proc(ipile)
  348. if(jcolac.ne.0) then
  349. jlisse=jcolac.ilissg
  350. jtlacc=jcolac.kcola(icoo)
  351. segact jtlacc*mod
  352. call ajoun0(jtlacc,ireti,jlisse,1)
  353. segdes jtlacc
  354. endif
  355. enddo
  356. endif
  357. endif
  358. if(ktrace.le.-2) then
  359. ktrace = abs(ktrace)
  360. interr(1)=ktrace
  361. moterr(1:8)=icara
  362. moterr(9:14)=msorse
  363. call erreur (1011)
  364. CALL ANABAC
  365. endif
  366. * liberer les assistants
  367. 10000 continue
  368. IF( IPSAUV.NE.0) THEN
  369. SEGDES ILISSE
  370. SEGDES ICOLAC
  371. ENDIF
  372. C Desactivation des piles de communication si elles existent
  373. if(piComm.gt.0) then
  374. do ipile=1,piles.proc(/1)
  375. jcolac= piles.proc(ipile)
  376. if(jcolac.ne.0) then
  377. jlisse=jcolac.ilissg
  378. segdes jlisse
  379. segdes jcolac
  380. endif
  381. enddo
  382. segdes piles
  383. endif
  384. return
  385. END
  386.  
  387.  
  388.  
  389.  
  390.  
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  

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