Télécharger detrui.eso

Retour à la liste

Numérotation des lignes :

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

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