Télécharger dtsolu.eso

Retour à la liste

Numérotation des lignes :

  1. C DTSOLU SOURCE PV 16/11/26 21:15:40 9205
  2.  
  3. SUBROUTINE DTSOLU(IRET)
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8(A-H,O-Z)
  7.  
  8. character*19 mrota , mrotp
  9. character*24 mrots
  10. character*22 mtran , mtrap
  11. character*27 mtras
  12. character*1 ichari,mrotd,mtrad,icharr
  13. logical logii,logir
  14. integer ico, icoch, icolr, icotb
  15. integer ipile, iret, irett, irret
  16. integer irotd, irotp, irots
  17. integer itabr, itrad, itrap, itras
  18. integer itys, ivali, ivalr, kmel1, ksolit
  19. integer n, nip, nipo, nn
  20. real*8 xvali, xvalr
  21. C
  22. C =====================================================================
  23. C = DESTRUCTION D'UN OBJET SOLUTION =
  24. C = =
  25. C = CREATION 06/01/86 =
  26. C = PROGRAMMEUR GUILBAUD =
  27. C =====================================================================
  28. C
  29. -INC CCOPTIO
  30. -INC COCOLL
  31. -INC SMSOLUT
  32. -INC SMELEME
  33. -INC SMTABLE
  34. -INC SMLREEL
  35. -INC TMCOLAC
  36.  
  37. pointeur piles.LISPIL
  38. pointeur jcolac.ICOLAC
  39. pointeur jlisse.ILISSE
  40. pointeur jtlacc.ITLACC
  41. pointeur pile.ITLACC
  42. *
  43. DATA MROTA/'ROTATION D ENSEMBLE'/
  44. DATA MROTP/'VITESSE DE ROTATION'/
  45. DATA MROTS/'ACCELERATION DE ROTATION'/
  46. DATA MTRAN/'TRANSLATION D ENSEMBLE'/
  47. DATA MTRAP/'VITESSE DE TRANSLATION'/
  48. DATA MTRAS/'ACCELERATION DE TRANSLATION'/
  49. *
  50. MSOLUT=IRET
  51. irret=0
  52. SEGACT MSOLUT
  53. ITYS=0
  54. IF(ITYSOL.NE.'MODE ') GO TO 101
  55. ITYS=1
  56. GO TO 200
  57. 101 CONTINUE
  58. IF(ITYSOL.NE.'SOLUSTAT'.AND.ITYSOL.NE.'PSEUMODE') GO TO 102
  59. ITYS=2
  60. GOTO 200
  61. 102 CONTINUE
  62. IF(ITYSOL.NE.'DYNAMIQU') GOTO 103
  63. ITYS=3
  64. GO TO 200
  65. 103 MOTERR(1:8)='SOLUTION'
  66. MOTERR(9:16)=ITYSOL
  67. CALL ERREUR(66)
  68. C L OPERATEUR DETRUIRE NE FONCTIONNE PAS POUR UN OBJET SOLUTION
  69. C COMPORTANT CE SOUS-TYPE
  70. SEGDES MSOLUT
  71. GOTO 1000
  72. 200 NIPO=MSOLIS(/1)
  73. MSOLRE=MSOLIS(1)
  74. IF(MSOLRE.NE.0) SEGSUP MSOLRE
  75. MSOLEN=MSOLIS(2)
  76. IF(MSOLEN.NE.0) SEGSUP MSOLEN
  77. MELEME=MSOLIS(3)
  78. IF(MELEME.NE.0.AND.ITYS.EQ.1) THEN
  79. SEGSUP MELEME
  80. IF(IPSAUV.NE.0) THEN
  81. ICOLAC = IPSAUV
  82. SEGACT ICOLAC
  83. ILISSE=ILISSG
  84. SEGACT ILISSE*MOD
  85. CALL TYPFIL('MAILLAGE',ICO)
  86. ITLACC = KCOLA(ICO)
  87. SEGACT ITLACC*MOD
  88. CALL AJOUN0(ITLACC,MELEME,ILISSE,1)
  89. SEGDES ITLACC,ILISSE
  90. SEGDES ICOLAC
  91. ENDIF
  92. C Suppression du meleme des piles d'objets communiques
  93. if(piComm.gt.0) then
  94. piles=piComm
  95. segact piles
  96. call typfil('MAILLAGE',ico)
  97. do ipile=1,piles.proc(/1)
  98. jcolac= piles.proc(ipile)
  99. if(jcolac.ne.0) then
  100. segact jcolac
  101. jlisse=jcolac.ilissg
  102. segact jlisse*mod
  103. jtlacc=jcolac.kcola(ico)
  104. segact jtlacc*mod
  105. call ajoun0(jtlacc,MELEME,jlisse,1)
  106. segdes jtlacc
  107. segdes jlisse
  108. segdes jcolac
  109. endif
  110. enddo
  111. segdes piles
  112. endif
  113. ENDIF
  114. MSOLEN=MSOLIS(4)
  115. IF(MSOLEN.NE.0) THEN
  116. SEGACT MSOLEN
  117. N=ISOLEN(/1)
  118. IF(N.NE.0) THEN
  119. DO 210 NN=1,N
  120. MMODE=ISOLEN(NN)
  121. SEGSUP MMODE
  122. 210 CONTINUE
  123. ENDIF
  124. SEGSUP MSOLEN
  125. ENDIF
  126. DO 230 NIP=5,NIPO
  127. MSOLEN=MSOLIS(NIP)
  128. IF(MSOLEN.NE.0) THEN
  129. SEGACT MSOLEN
  130. N=ISOLEN(/1)
  131. IF(N.NE.0) THEN
  132. KSOLIT=MSOLIT(NIP)
  133. DO 220 NN=1,N
  134. IRETT=ISOLEN(NN)
  135. IF(IRETT.NE.0) THEN
  136. IF(KSOLIT.EQ.2) THEN
  137. CALL DTCHPO(IRETT)
  138. IF(IPSAUV.NE.0) THEN
  139. ICOLAC = IPSAUV
  140. SEGACT ICOLAC
  141. ILISSE=ILISSG
  142. SEGACT ILISSE*MOD
  143. CALL TYPFIL('CHPOINT',ICOCH)
  144. ITLACC = KCOLA(ICOCH)
  145. SEGACT ITLACC*MOD
  146. CALL AJOUN0(ITLACC,IRETT,ILISSE,1)
  147. SEGDES ITLACC
  148. ENDIF
  149. C Suppression du CHPOINT des piles d'objets communiques
  150. if(piComm.gt.0) then
  151. piles=piComm
  152. segact piles
  153. call typfil('CHPOINT',ico)
  154. do ipile=1,piles.proc(/1)
  155. jcolac= piles.proc(ipile)
  156. if(jcolac.ne.0) then
  157. segact jcolac
  158. jlisse=jcolac.ilissg
  159. segact jlisse*mod
  160. jtlacc=jcolac.kcola(ico)
  161. segact jtlacc*mod
  162. call ajoun0(jtlacc,IRETT,jlisse,1)
  163. segdes jtlacc
  164. segdes jlisse
  165. segdes jcolac
  166. endif
  167. enddo
  168. segdes piles
  169. endif
  170. ENDIF
  171. IF(KSOLIT.EQ.5) THEN
  172. CALL DTCHAM(IRETT)
  173. IF(IPSAUV.NE.0) THEN
  174. ICOLAC = IPSAUV
  175. SEGACT ICOLAC
  176. ILISSE=ILISSG
  177. SEGACT ILISSE*MOD
  178. CALL TYPFIL('MCHAML ',ICOCH)
  179. ITLACC = KCOLA(ICOCH)
  180. SEGACT ITLACC*MOD
  181. CALL AJOUN0(ITLACC,IRETT,ILISSE,1)
  182. SEGDES ITLACC
  183. ENDIF
  184. C Suppression du MCHAML des piles d'objets communiques
  185. if(piComm.gt.0) then
  186. piles=piComm
  187. segact piles
  188. call typfil('MCHAML ',ico)
  189. do ipile=1,piles.proc(/1)
  190. jcolac= piles.proc(ipile)
  191. if(jcolac.ne.0) then
  192. segact jcolac
  193. jlisse=jcolac.ilissg
  194. segact jlisse*mod
  195. jtlacc=jcolac.kcola(ico)
  196. segact jtlacc*mod
  197. call ajoun0(jtlacc,IRETT,jlisse,1)
  198. segdes jtlacc
  199. segdes jlisse
  200. segdes jcolac
  201. endif
  202. enddo
  203. segdes piles
  204. endif
  205. ENDIF
  206. IF ( MSOLIT.EQ.10 ) THEN
  207. KMEL1 = MSOLIS(3)
  208. IF ( NIP.EQ.11 ) THEN
  209. CALL ACCTAB(IRRET,'MAILLAGE',
  210. * IVALI,XVALI,ICHARI,LOGII,KMEL1,
  211. * 'TABLE ',
  212. * IVALR,XVALR,ICHARR,LOGIR,ITABR)
  213. CALL ACCTAB(ITABR,'MOT ',
  214. * IVALI,XVALI,MROTS ,LOGII,KMEL1,
  215. * 'LISTREEL',
  216. * IVALR,XVALR,ICHARR,LOGIR,IROTS)
  217. MLREEL = IROTS
  218. SEGSUP MLREEL
  219. CALL ACCTAB(ITABR,'MOT ',
  220. * IVALI,XVALI,MROTP ,LOGII,KMEL1,
  221. * 'LISTREEL',
  222. * IVALR,XVALR,ICHARR,LOGIR,IROTP)
  223. MLREEL = IROTP
  224. SEGSUP MLREEL
  225. CALL ACCTAB(ITABR,'MOT ',
  226. * IVALI,XVALI,MROTD ,LOGII,KMEL1,
  227. * 'LISTREEL',
  228. * IVALR,XVALR,ICHARR,LOGIR,IROTD)
  229. MLREEL = IROTD
  230. SEGSUP MLREEL
  231. MTABLE = ITABR
  232. SEGSUP MTABLE
  233. ITABR = 0
  234. CONTINUE
  235. MTABLE = IRRET
  236. SEGSUP MTABLE
  237. IF(IPSAUV.NE.0) THEN
  238. ICOLAC = IPSAUV
  239. SEGACT ICOLAC
  240. ILISSE=ILISSG
  241. SEGACT ILISSE*MOD
  242. CALL TYPFIL('LISTREEL',ICOLR)
  243. ITLACC = KCOLA(ICOLR)
  244. SEGACT ITLACC*MOD
  245. CALL AJOUN0(ITLACC,IROTD,ILISSE,1)
  246. CALL AJOUN0(ITLACC,IROTP,ILISSE,1)
  247. CALL AJOUN0(ITLACC,IROTS,ILISSE,1)
  248. SEGDES ITLACC
  249. CALL TYPFIL('TABLE ',ICOTB)
  250. ITLACC = KCOLA(ICOTB)
  251. SEGACT ITLACC*MOD
  252. CALL AJOUN0(ITLACC,ITABR,ILISSE,1)
  253. CALL AJOUN0(ITLACC,IRRET,ILISSE,1)
  254. SEGDES ITLACC
  255. SEGDES ICOLAC,ILISSE
  256. ENDIF
  257. C Suppression du list reel et table des piles d'objets communiques
  258. if(piComm.gt.0) then
  259. piles=piComm
  260. segact piles
  261. call typfil('LISTREEL',ico)
  262. do ipile=1,piles.proc(/1)
  263. jcolac= piles.proc(ipile)
  264. if(jcolac.ne.0) then
  265. segact jcolac
  266. jlisse=jcolac.ilissg
  267. segact jlisse*mod
  268. jtlacc=jcolac.kcola(ico)
  269. segact jtlacc*mod
  270. call ajoun0(jtlacc,IROTD,jlisse,1)
  271. call ajoun0(jtlacc,IROTP,jlisse,1)
  272. call ajoun0(jtlacc,IROTS,jlisse,1)
  273. segdes jtlacc
  274. endif
  275. enddo
  276. call typfil('TABLE ',ico)
  277. do ipile=1,piles.proc(/1)
  278. jcolac= piles.proc(ipile)
  279. if(jcolac.ne.0) then
  280. jlisse=jcolac.ilissg
  281. jtlacc=jcolac.kcola(ico)
  282. segact jtlacc*mod
  283. call ajoun0(jtlacc,ITABR,jlisse,1)
  284. call ajoun0(jtlacc,IRRET,jlisse,1)
  285. segdes jtlacc
  286. segdes jlisse
  287. segdes jcolac
  288. endif
  289. enddo
  290. segdes piles
  291. endif
  292. IRRET = 0
  293. ELSE IF ( NIP.EQ.12 ) THEN
  294. CALL ACCTAB(IRRET,'MAILLAGE',
  295. * IVALI,XVALI,ICHARI,LOGII,KMEL1,
  296. * 'TABLE ',
  297. * IVALR,XVALR,ICHARR,LOGIR,ITABR)
  298. CALL ACCTAB(ITABR,'MOT ',
  299. * IVALI,XVALI,MTRAS ,LOGII,KMEL1,
  300. * 'LISTREEL',
  301. * IVALR,XVALR,ICHARR,LOGIR,ITRAS)
  302. MLREEL = ITRAS
  303. SEGSUP MLREEL
  304. CALL ACCTAB(ITABR,'MOT ',
  305. * IVALI,XVALI,MTRAP ,LOGII,KMEL1,
  306. * 'LISTREEL',
  307. * IVALR,XVALR,ICHARR,LOGIR,ITRAP)
  308. MLREEL = ITRAP
  309. SEGSUP MLREEL
  310. CALL ACCTAB(ITABR,'MOT ',
  311. * IVALI,XVALI,MTRAD ,LOGII,KMEL1,
  312. * 'LISTREEL',
  313. * IVALR,XVALR,ICHARR,LOGIR,ITRAD)
  314. MLREEL = ITRAD
  315. SEGSUP MLREEL
  316. MTABLE = ITABR
  317. SEGSUP MTABLE
  318. CONTINUE
  319. MTABLE = IRRET
  320. SEGSUP MTABLE
  321. IF(IPSAUV.NE.0) THEN
  322. ICOLAC = IPSAUV
  323. SEGACT ICOLAC
  324. ILISSE=ILISSG
  325. SEGACT ILISSE*MOD
  326. ITLACC = KCOLA(ICOLR)
  327. SEGACT ITLACC*MOD
  328. CALL AJOUN0(ITLACC,ITRAD,ILISSE,1)
  329. CALL AJOUN0(ITLACC,ITRAP,ILISSE,1)
  330. CALL AJOUN0(ITLACC,ITRAS,ILISSE,1)
  331. SEGDES ITLACC
  332. ITLACC = KCOLA(ICOTB)
  333. SEGACT ITLACC*MOD
  334. CALL AJOUN0(ITLACC,ITABR,ILISSE,1)
  335. CALL AJOUN0(ITLACC,IRRET,ILISSE,1)
  336. SEGDES ITLACC
  337. SEGDES ICOLAC,ILISSE
  338. ENDIF
  339. C Suppression du list reel et table des piles d'objets communiques
  340. if(piComm.gt.0) then
  341. piles=piComm
  342. segact piles
  343. call typfil('LISTREEL',ico)
  344. do ipile=1,piles.proc(/1)
  345. jcolac= piles.proc(ipile)
  346. if(jcolac.ne.0) then
  347. segact jcolac
  348. jlisse=jcolac.ilissg
  349. segact jlisse*mod
  350. jtlacc=jcolac.kcola(ico)
  351. segact jtlacc*mod
  352. call ajoun0(jtlacc,ITRAD,jlisse,1)
  353. call ajoun0(jtlacc,ITRAP,jlisse,1)
  354. call ajoun0(jtlacc,ITRAS,jlisse,1)
  355. segdes jtlacc
  356. endif
  357. enddo
  358. call typfil('TABLE ',ico)
  359. do ipile=1,piles.proc(/1)
  360. jcolac= piles.proc(ipile)
  361. if(jcolac.ne.0) then
  362. jlisse=jcolac.ilissg
  363. jtlacc=jcolac.kcola(ico)
  364. segact jtlacc*mod
  365. call ajoun0(jtlacc,ITABR,jlisse,1)
  366. call ajoun0(jtlacc,IRRET,jlisse,1)
  367. segdes jtlacc
  368. segdes jlisse
  369. segdes jcolac
  370. endif
  371. enddo
  372. segdes piles
  373. endif
  374. ITABR = 0
  375. IRRET = 0
  376. ENDIF
  377. ENDIF
  378. ENDIF
  379. 220 CONTINUE
  380. ENDIF
  381. SEGSUP MSOLEN
  382. ENDIF
  383. 230 CONTINUE
  384. 1000 CONTINUE
  385.  
  386. RETURN
  387. END
  388.  
  389.  
  390.  
  391.  
  392.  
  393.  

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