Télécharger dtsolz.eso

Retour à la liste

Numérotation des lignes :

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

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