Télécharger dtsolz.eso

Retour à la liste

Numérotation des lignes :

  1. C DTSOLZ SOURCE PV 17/12/05 21:16:00 9646
  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.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC COCOLL
  32. -INC SMSOLUT
  33. -INC SMELEME
  34. -INC SMTABLE
  35. -INC SMLREEL
  36. -INC TMCOLAC
  37.  
  38. pointeur piles.LISPIL
  39. pointeur jcolac.ICOLAC
  40. pointeur jlisse.ILISSE
  41. pointeur jtlacc.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. if(ktrace.eq.msolut) then
  71. ktrace=-ktrace
  72. msorse='MSOLUT'
  73. endif
  74. SEGDES MSOLUT
  75. GOTO 1000
  76. 200 NIPO=MSOLIS(/1)
  77. MSOLRE=MSOLIS(1)
  78. IF(MSOLRE.NE.0) SEGSUP MSOLRE
  79. MSOLEN=MSOLIS(2)
  80. IF(MSOLEN.NE.0) SEGSUP MSOLEN
  81. MELEME=MSOLIS(3)
  82. IF(MELEME.NE.0.AND.ITYS.EQ.1) THEN
  83. if(ktrace.eq.meleme) then
  84. ktrace=-ktrace
  85. msorse='MELEME'
  86. endif
  87. SEGSUP MELEME
  88. IF(IPSAUV.NE.0) THEN
  89. ICOLAC = IPSAUV
  90. SEGACT ICOLAC
  91. ILISSE=ILISSG
  92. SEGACT ILISSE*MOD
  93. CALL TYPFIL('MAILLAGE',ICO)
  94. ITLACC = KCOLA(ICO)
  95. SEGACT ITLACC*MOD
  96. CALL AJOUN0(ITLACC,MELEME,ILISSE,1)
  97. SEGDES ITLACC,ILISSE
  98. SEGDES ICOLAC
  99. ENDIF
  100. C Suppression du meleme des piles d'objets communiques
  101. if(piComm.gt.0) then
  102. piles=piComm
  103. segact piles
  104. call typfil('MAILLAGE',ico)
  105. do ipile=1,piles.proc(/1)
  106. jcolac= piles.proc(ipile)
  107. if(jcolac.ne.0) then
  108. segact jcolac
  109. jlisse=jcolac.ilissg
  110. segact jlisse*mod
  111. jtlacc=jcolac.kcola(ico)
  112. segact jtlacc*mod
  113. call ajoun0(jtlacc,MELEME,jlisse,1)
  114. segdes jtlacc
  115. segdes jlisse
  116. segdes jcolac
  117. endif
  118. enddo
  119. segdes piles
  120. endif
  121. ENDIF
  122. MSOLEN=MSOLIS(4)
  123. IF(MSOLEN.NE.0) THEN
  124. SEGACT MSOLEN
  125. N=ISOLEN(/1)
  126. IF(N.NE.0) THEN
  127. DO 210 NN=1,N
  128. MMODE=ISOLEN(NN)
  129. if(ktrace.eq.mmode) then
  130. ktrace=-ktrace
  131. msorse='MMODE'
  132. endif
  133. SEGSUP MMODE
  134. 210 CONTINUE
  135. ENDIF
  136. if(ktrace.eq.msolen) then
  137. ktrace=-ktrace
  138. msorse='MSOLEN'
  139. endif
  140. SEGSUP MSOLEN
  141. ENDIF
  142. DO 230 NIP=5,NIPO
  143. MSOLEN=MSOLIS(NIP)
  144. IF(MSOLEN.NE.0) THEN
  145. SEGACT MSOLEN
  146. N=ISOLEN(/1)
  147. IF(N.NE.0) THEN
  148. KSOLIT=MSOLIT(NIP)
  149. DO 220 NN=1,N
  150. IRETT=ISOLEN(NN)
  151. IF(IRETT.NE.0) THEN
  152. IF(KSOLIT.EQ.2) THEN
  153. CALL DTCHPO(IRETT)
  154. IF(IPSAUV.NE.0) THEN
  155. ICOLAC = IPSAUV
  156. SEGACT ICOLAC
  157. ILISSE=ILISSG
  158. SEGACT ILISSE*MOD
  159. CALL TYPFIL('CHPOINT',ICOCH)
  160. ITLACC = KCOLA(ICOCH)
  161. SEGACT ITLACC*MOD
  162. CALL AJOUN0(ITLACC,IRETT,ILISSE,1)
  163. SEGDES ITLACC
  164. ENDIF
  165. C Suppression du CHPOINT des piles d'objets communiques
  166. if(piComm.gt.0) then
  167. piles=piComm
  168. segact piles
  169. call typfil('CHPOINT',ico)
  170. do ipile=1,piles.proc(/1)
  171. jcolac= piles.proc(ipile)
  172. if(jcolac.ne.0) then
  173. segact jcolac
  174. jlisse=jcolac.ilissg
  175. segact jlisse*mod
  176. jtlacc=jcolac.kcola(ico)
  177. segact jtlacc*mod
  178. call ajoun0(jtlacc,IRETT,jlisse,1)
  179. segdes jtlacc
  180. segdes jlisse
  181. segdes jcolac
  182. endif
  183. enddo
  184. segdes piles
  185. endif
  186. ENDIF
  187. IF(KSOLIT.EQ.5) THEN
  188. CALL DTCHAz(IRETT,ktrace,msorse)
  189. IF(IPSAUV.NE.0) THEN
  190. ICOLAC = IPSAUV
  191. SEGACT ICOLAC
  192. ILISSE=ILISSG
  193. SEGACT ILISSE*MOD
  194. CALL TYPFIL('MCHAML ',ICOCH)
  195. ITLACC = KCOLA(ICOCH)
  196. SEGACT ITLACC*MOD
  197. CALL AJOUN0(ITLACC,IRETT,ILISSE,1)
  198. SEGDES ITLACC
  199. ENDIF
  200. C Suppression du MCHAML des piles d'objets communiques
  201. if(piComm.gt.0) then
  202. piles=piComm
  203. segact piles
  204. call typfil('MCHAML ',ico)
  205. do ipile=1,piles.proc(/1)
  206. jcolac= piles.proc(ipile)
  207. if(jcolac.ne.0) then
  208. segact jcolac
  209. jlisse=jcolac.ilissg
  210. segact jlisse*mod
  211. jtlacc=jcolac.kcola(ico)
  212. segact jtlacc*mod
  213. call ajoun0(jtlacc,IRETT,jlisse,1)
  214. segdes jtlacc
  215. segdes jlisse
  216. segdes jcolac
  217. endif
  218. enddo
  219. segdes piles
  220. endif
  221. ENDIF
  222. IF ( MSOLIT.EQ.10 ) THEN
  223. KMEL1 = MSOLIS(3)
  224. IF ( NIP.EQ.11 ) THEN
  225. CALL ACCTAB(IRRET,'MAILLAGE',
  226. * IVALI,XVALI,ICHARI,LOGII,KMEL1,
  227. * 'TABLE ',
  228. * IVALR,XVALR,ICHARR,LOGIR,ITABR)
  229. CALL ACCTAB(ITABR,'MOT ',
  230. * IVALI,XVALI,MROTS ,LOGII,KMEL1,
  231. * 'LISTREEL',
  232. * IVALR,XVALR,ICHARR,LOGIR,IROTS)
  233. MLREEL = IROTS
  234. if(ktrace.eq.mlreel) then
  235. ktrace=-ktrace
  236. msorse='MLREEL'
  237. endif
  238. SEGSUP MLREEL
  239. CALL ACCTAB(ITABR,'MOT ',
  240. * IVALI,XVALI,MROTP ,LOGII,KMEL1,
  241. * 'LISTREEL',
  242. * IVALR,XVALR,ICHARR,LOGIR,IROTP)
  243. MLREEL = IROTP
  244. if(ktrace.eq.mlreel) then
  245. ktrace=-ktrace
  246. msorse='MLREEL'
  247. endif
  248. SEGSUP MLREEL
  249. CALL ACCTAB(ITABR,'MOT ',
  250. * IVALI,XVALI,MROTD ,LOGII,KMEL1,
  251. * 'LISTREEL',
  252. * IVALR,XVALR,ICHARR,LOGIR,IROTD)
  253. MLREEL = IROTD
  254. if(ktrace.eq.mlreel) then
  255. ktrace=-ktrace
  256. msorse='MLREEL'
  257. endif
  258. SEGSUP MLREEL
  259. MTABLE = ITABR
  260. if(ktrace.eq.mtable) then
  261. ktrace=-ktrace
  262. msorse='MTABLE'
  263. endif
  264. SEGSUP MTABLE
  265. ITABR = 0
  266. CONTINUE
  267. MTABLE = IRRET
  268. if(ktrace.eq.mtable) then
  269. ktrace=-ktrace
  270. msorse='MTABLE'
  271. endif
  272. SEGSUP MTABLE
  273. IF(IPSAUV.NE.0) THEN
  274. ICOLAC = IPSAUV
  275. SEGACT ICOLAC
  276. ILISSE=ILISSG
  277. SEGACT ILISSE*MOD
  278. CALL TYPFIL('LISTREEL',ICOLR)
  279. ITLACC = KCOLA(ICOLR)
  280. SEGACT ITLACC*MOD
  281. CALL AJOUN0(ITLACC,IROTD,ILISSE,1)
  282. CALL AJOUN0(ITLACC,IROTP,ILISSE,1)
  283. CALL AJOUN0(ITLACC,IROTS,ILISSE,1)
  284. SEGDES ITLACC
  285. CALL TYPFIL('TABLE ',ICOTB)
  286. ITLACC = KCOLA(ICOTB)
  287. SEGACT ITLACC*MOD
  288. CALL AJOUN0(ITLACC,ITABR,ILISSE,1)
  289. CALL AJOUN0(ITLACC,IRRET,ILISSE,1)
  290. SEGDES ITLACC
  291. SEGDES ICOLAC,ILISSE
  292. ENDIF
  293. C Suppression du list reel et table des piles d'objets communiques
  294. if(piComm.gt.0) then
  295. piles=piComm
  296. segact piles
  297. call typfil('LISTREEL',ico)
  298. do ipile=1,piles.proc(/1)
  299. jcolac= piles.proc(ipile)
  300. if(jcolac.ne.0) then
  301. segact jcolac
  302. jlisse=jcolac.ilissg
  303. segact jlisse*mod
  304. jtlacc=jcolac.kcola(ico)
  305. segact jtlacc*mod
  306. call ajoun0(jtlacc,IROTD,jlisse,1)
  307. call ajoun0(jtlacc,IROTP,jlisse,1)
  308. call ajoun0(jtlacc,IROTS,jlisse,1)
  309. segdes jtlacc
  310. endif
  311. enddo
  312. call typfil('TABLE ',ico)
  313. do ipile=1,piles.proc(/1)
  314. jcolac= piles.proc(ipile)
  315. if(jcolac.ne.0) then
  316. jlisse=jcolac.ilissg
  317. jtlacc=jcolac.kcola(ico)
  318. segact jtlacc*mod
  319. call ajoun0(jtlacc,ITABR,jlisse,1)
  320. call ajoun0(jtlacc,IRRET,jlisse,1)
  321. segdes jtlacc
  322. segdes jlisse
  323. segdes jcolac
  324. endif
  325. enddo
  326. segdes piles
  327. endif
  328. IRRET = 0
  329. ELSE IF ( NIP.EQ.12 ) THEN
  330. CALL ACCTAB(IRRET,'MAILLAGE',
  331. * IVALI,XVALI,ICHARI,LOGII,KMEL1,
  332. * 'TABLE ',
  333. * IVALR,XVALR,ICHARR,LOGIR,ITABR)
  334. CALL ACCTAB(ITABR,'MOT ',
  335. * IVALI,XVALI,MTRAS ,LOGII,KMEL1,
  336. * 'LISTREEL',
  337. * IVALR,XVALR,ICHARR,LOGIR,ITRAS)
  338. MLREEL = ITRAS
  339. if(ktrace.eq.mlreel) then
  340. ktrace=-ktrace
  341. msorse='MLREEL'
  342. endif
  343. SEGSUP MLREEL
  344. CALL ACCTAB(ITABR,'MOT ',
  345. * IVALI,XVALI,MTRAP ,LOGII,KMEL1,
  346. * 'LISTREEL',
  347. * IVALR,XVALR,ICHARR,LOGIR,ITRAP)
  348. MLREEL = ITRAP
  349. if(ktrace.eq.mlreel) then
  350. ktrace=-ktrace
  351. msorse='MLREEL'
  352. endif
  353. SEGSUP MLREEL
  354. CALL ACCTAB(ITABR,'MOT ',
  355. * IVALI,XVALI,MTRAD ,LOGII,KMEL1,
  356. * 'LISTREEL',
  357. * IVALR,XVALR,ICHARR,LOGIR,ITRAD)
  358. MLREEL = ITRAD
  359. if(ktrace.eq.mlreel) then
  360. ktrace=-ktrace
  361. msorse='MLREEL'
  362. endif
  363. SEGSUP MLREEL
  364. MTABLE = ITABR
  365. if(ktrace.eq.mtable) then
  366. ktrace=-ktrace
  367. msorse='MTABLE'
  368. endif
  369. SEGSUP MTABLE
  370. CONTINUE
  371. MTABLE = IRRET
  372. if(ktrace.eq.mtable) then
  373. ktrace=-ktrace
  374. msorse='MTABLE'
  375. endif
  376. SEGSUP MTABLE
  377. IF(IPSAUV.NE.0) THEN
  378. ICOLAC = IPSAUV
  379. SEGACT ICOLAC
  380. ILISSE=ILISSG
  381. SEGACT ILISSE*MOD
  382. ITLACC = KCOLA(ICOLR)
  383. SEGACT ITLACC*MOD
  384. CALL AJOUN0(ITLACC,ITRAD,ILISSE,1)
  385. CALL AJOUN0(ITLACC,ITRAP,ILISSE,1)
  386. CALL AJOUN0(ITLACC,ITRAS,ILISSE,1)
  387. SEGDES ITLACC
  388. ITLACC = KCOLA(ICOTB)
  389. SEGACT ITLACC*MOD
  390. CALL AJOUN0(ITLACC,ITABR,ILISSE,1)
  391. CALL AJOUN0(ITLACC,IRRET,ILISSE,1)
  392. SEGDES ITLACC
  393. SEGDES ICOLAC,ILISSE
  394. ENDIF
  395. C Suppression du list reel et table des piles d'objets communiques
  396. if(piComm.gt.0) then
  397. piles=piComm
  398. segact piles
  399. call typfil('LISTREEL',ico)
  400. do ipile=1,piles.proc(/1)
  401. jcolac= piles.proc(ipile)
  402. if(jcolac.ne.0) then
  403. segact jcolac
  404. jlisse=jcolac.ilissg
  405. segact jlisse*mod
  406. jtlacc=jcolac.kcola(ico)
  407. segact jtlacc*mod
  408. call ajoun0(jtlacc,ITRAD,jlisse,1)
  409. call ajoun0(jtlacc,ITRAP,jlisse,1)
  410. call ajoun0(jtlacc,ITRAS,jlisse,1)
  411. segdes jtlacc
  412. endif
  413. enddo
  414. call typfil('TABLE ',ico)
  415. do ipile=1,piles.proc(/1)
  416. jcolac= piles.proc(ipile)
  417. if(jcolac.ne.0) then
  418. jlisse=jcolac.ilissg
  419. jtlacc=jcolac.kcola(ico)
  420. segact jtlacc*mod
  421. call ajoun0(jtlacc,ITABR,jlisse,1)
  422. call ajoun0(jtlacc,IRRET,jlisse,1)
  423. segdes jtlacc
  424. segdes jlisse
  425. segdes jcolac
  426. endif
  427. enddo
  428. segdes piles
  429. endif
  430. ITABR = 0
  431. IRRET = 0
  432. ENDIF
  433. ENDIF
  434. ENDIF
  435. 220 CONTINUE
  436. ENDIF
  437. if(ktrace.eq.msolen) then
  438. ktrace=-ktrace
  439. msorse='MSOLEN'
  440. endif
  441. SEGSUP MSOLEN
  442. ENDIF
  443. 230 CONTINUE
  444. 1000 CONTINUE
  445. RETURN
  446. END
  447.  
  448.  
  449.  
  450.  
  451.  
  452.  
  453.  
  454.  

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