Télécharger dtsupz.eso

Retour à la liste

Numérotation des lignes :

  1. C DTSUPZ SOURCE PV 16/11/26 21:15:42 9205
  2. SUBROUTINE DTSUPz(IRET,ktrace,msorse)
  3. C **** DESTRUCTION APPROXIMATIVE D'UN SUPER-ELEMENT
  4. IMPLICIT INTEGER(I-N)
  5. character*6 msorse MSUPER=IRET
  6. integer i, iaux, ico, inc, ipile, iret, ktrace
  7. -INC CCOPTIO
  8. -INC COCOLL
  9. -INC SMSUPER
  10. -INC SMELEME
  11. -INC SMMATRI
  12. -INC TMCOLAC
  13.  
  14. pointeur piles.LISPIL
  15. pointeur jcolac.ICOLAC
  16. pointeur jlisse.ILISSE
  17. pointeur jtlacc.ITLACC
  18. MSUPER=IRET
  19. SEGACT MSUPER
  20. C
  21. IAUX=MRIGTO
  22. CALL DTRIGZ(IAUX,ktrace,msorse)
  23. C
  24. IAUX=MSURAI
  25. CALL DTRIGZ(IAUX,ktrace,msorse)
  26. C
  27. MELEME=MSUPEL
  28. if( ktrace.eq.meleme) then
  29. ktrace=-ktrace
  30. msorse='MELEME'
  31. endif
  32. SEGSUP MELEME
  33. IF(IPSAUV.NE.0) THEN
  34. ICOLAC = IPSAUV
  35. SEGACT ICOLAC
  36. ILISSE=ILISSG
  37. SEGACT ILISSE*MOD
  38. CALL TYPFIL('MAILLAGE',ICO)
  39. ITLACC = KCOLA(ICO)
  40. SEGACT ITLACC*MOD
  41. CALL AJOUN0(ITLACC,MELEME,ILISSE,1)
  42. CALL TYPFIL('RIGIDITE',ICO)
  43. ITLACC = KCOLA(ICO)
  44. SEGACT ITLACC*MOD
  45. IAUX=MSURAI
  46. CALL AJOUN0(ITLACC,IAUX,ILISSE,1)
  47. IAUX=MRIGTO
  48. CALL AJOUN0(ITLACC,IAUX,ILISSE,1)
  49. SEGDES ITLACC
  50. SEGDES ICOLAC,ILISSE
  51. ENDIF
  52. C Suppression des piles d'objets communiques
  53. if(piComm.gt.0) then
  54. piles=piComm
  55. segact piles
  56. call typfil('MAILLAGE',ico)
  57. do ipile=1,piles.proc(/1)
  58. jcolac= piles.proc(ipile)
  59. if(jcolac.ne.0) then
  60. segact jcolac
  61. jlisse=jcolac.ilissg
  62. segact jlisse*mod
  63. jtlacc=jcolac.kcola(ico)
  64. segact jtlacc*mod
  65. call ajoun0(jtlacc,MELEME,jlisse,1)
  66. segdes jtlacc
  67. endif
  68. enddo
  69. call typfil('RIGIDITE',ico)
  70. do ipile=1,piles.proc(/1)
  71. jcolac= piles.proc(ipile)
  72. if(jcolac.ne.0) then
  73. jlisse=jcolac.ilissg
  74. jtlacc=jcolac.kcola(ico)
  75. segact jtlacc*mod
  76. iaux=MSURAI
  77. call ajoun0(jtlacc,IAUX,jlisse,1)
  78. iaux=MRIGTO
  79. call ajoun0(jtlacc,IAUX,jlisse,1)
  80. segdes jtlacc
  81. segdes jlisse
  82. segdes jcolac
  83. endif
  84. enddo
  85. segdes piles
  86. endif
  87. C
  88. MMATRI=MCROUT
  89. SEGACT MMATRI
  90. MDIAG=IDIAG
  91. if( ktrace.eq.mdiag) then
  92. ktrace=-ktrace
  93. msorse='MDNOR'
  94. endif
  95. SEGSUP MDIAG
  96. MELEME=IGEOMA
  97. if( ktrace.eq.meleme) then
  98. ktrace=-ktrace
  99. msorse='MELEME'
  100. endif
  101. SEGSUP MELEME
  102. IF(IPSAUV.NE.0) THEN
  103. ICOLAC = IPSAUV
  104. SEGACT ICOLAC
  105. ILISSE=ILISSG
  106. SEGACT ILISSE*MOD
  107. CALL TYPFIL('MAILLAGE',ICO)
  108. ITLACC = KCOLA(ICO)
  109. SEGACT ITLACC*MOD
  110. CALL AJOUN0(ITLACC,MELEME,ILISSE,1)
  111. SEGDES ITLACC
  112. SEGDES ICOLAC,ILISSE
  113. ENDIF
  114. C Suppression du meleme des piles d'objets communiques
  115. if(piComm.gt.0) then
  116. piles=piComm
  117. segact piles
  118. call typfil('MAILLAGE',ico)
  119. do ipile=1,piles.proc(/1)
  120. jcolac= piles.proc(ipile)
  121. if(jcolac.ne.0) then
  122. segact jcolac
  123. jlisse=jcolac.ilissg
  124. segact jlisse*mod
  125. jtlacc=jcolac.kcola(ico)
  126. segact jtlacc*mod
  127. call ajoun0(jtlacc,MELEME,jlisse,1)
  128. segdes jtlacc
  129. segdes jlisse
  130. segdes jcolac
  131. endif
  132. enddo
  133. segdes piles
  134. endif
  135. MINCPO=IINCPO
  136. if( ktrace.eq.mincpo) then
  137. ktrace=-ktrace
  138. msorse='MINCPO'
  139. endif
  140. SEGSUP MINCPO
  141. MIDUA=IIDUA
  142. if( ktrace.eq.midua) then
  143. ktrace=-ktrace
  144. msorse='MIDUA'
  145. endif
  146. SEGSUP MIDUA
  147. MHARK=IHARK
  148. if( ktrace.eq.mhark) then
  149. ktrace=-ktrace
  150. msorse='MHARK'
  151. endif
  152. SEGSUP MHARK
  153. MIMIK=IIMIK
  154. if( ktrace.eq.mimik) then
  155. ktrace=-ktrace
  156. msorse='MIMIK'
  157. endif
  158. SEGSUP MIMIK
  159. MDNOR=IDNORM
  160. if( ktrace.eq.mdnor) then
  161. ktrace=-ktrace
  162. msorse='MDNOR'
  163. endif
  164. SEGSUP MDNOR
  165. MILIGN=IILIGN
  166. SEGACT MILIGN
  167. INC=ILIGN(/1)
  168. DO 1 I=1,INC
  169. LIGN=ILIGN(I)
  170. if( ktrace.eq.lign) then
  171. ktrace=-ktrace
  172. msorse='LIGN'
  173. endif
  174. SEGSUP LIGN
  175. 1 CONTINUE
  176. if( ktrace.eq.milign) then
  177. ktrace=-ktrace
  178. msorse='MILIGN'
  179. endif
  180. SEGSUP MILIGN
  181. if( ktrace.eq.mmatri) then
  182. ktrace=-ktrace
  183. msorse='MMATRI'
  184. endif
  185. SEGSUP MMATRI
  186. IF(IPSAUV.NE.0) THEN
  187. ICOLAC = IPSAUV
  188. SEGACT ICOLAC
  189. ILISSE=ILISSG
  190. SEGACT ILISSE*MOD
  191. CALL TYPFIL('IMATRI ',ICO)
  192. ITLACC = KCOLA(ICO)
  193. SEGACT ITLACC*MOD
  194. CALL AJOUN0(ITLACC,MMATRI,ILISSE,1)
  195. SEGDES ITLACC
  196. SEGDES ICOLAC,ILISSE
  197. ENDIF
  198. C Suppression du meleme des piles d'objets communiques
  199. if(piComm.gt.0) then
  200. piles=piComm
  201. segact piles
  202. call typfil('IMATRI ',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,MMATRI,jlisse,1)
  212. segdes jtlacc
  213. segdes jlisse
  214. segdes jcolac
  215. endif
  216. enddo
  217. segdes piles
  218. endif
  219. C
  220. if( ktrace.eq.msuper) then
  221. ktrace=-ktrace
  222. msorse='MSUPER'
  223. endif
  224. SEGSUP MSUPER
  225. RETURN
  226. END
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  

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