Télécharger detrui.eso

Retour à la liste

Numérotation des lignes :

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

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