Télécharger dtrigz.eso

Retour à la liste

Numérotation des lignes :

dtrigz
  1. C DTRIGZ SOURCE PV090527 24/09/04 21:15:03 12002
  2. SUBROUTINE DTRIGz(IRET,ktrace,msorse)
  3. C **** DESTRUCTION DE LA MATRICE SI ELLE EXISTE,DESTRUCTION DU CHAPEAU
  4. C **** MATRICE: ON DETRUIT TOUT
  5. IMPLICIT INTEGER(I-N)
  6. CHARACTER*4 MOMOT(1)
  7. character*6 msorse
  8. integer i,ico,idet,ipile,inc,iret,ktrace
  9.  
  10. -INC PPARAM
  11. -INC CCOPTIO
  12. -INC COCOLL
  13. -INC SMRIGID
  14. -INC SMMATRI
  15. -INC SMELEME
  16. -INC TMCOLAC
  17. pointeur piles.LISPIL
  18. pointeur jcolac.ICOLAC
  19. pointeur jlisse.ILISSE
  20. pointeur jtlacc.ITLACC
  21. segment ladet(0)
  22. DATA MOMOT(1)/'ELEM'/
  23. iun=1
  24. CALL LIRMOT(MOMOT,1,IDET,0)
  25. MRIGID=IRET
  26. segini ladet
  27. * fabrication de la liste des matrices a detruire
  28. 1010 continue
  29. segact mrigid
  30. ladet(**)=mrigid
  31. if(jrdepp.ne.0) ladet(**)=jrdepp
  32. if(jrdepd.ne.0) ladet(**)=jrdepd
  33. if(jrelim.ne.0) ladet(**)=jrelim
  34. if(jrtot.ne.0) ladet(**)=jrtot
  35. if(jrgard.ne.0) ladet(**)=jrgard
  36. if (jrcond.ne.0) then
  37. mrigid=jrcond
  38. goto 1010
  39. endif
  40. ** write(6,*) ' nb matrice a detruire ',ladet(/1)
  41. do 1000 ir=1,ladet(/1)
  42. mrigid=ladet(ir)
  43. SEGACT MRIGID
  44. IF(IIMPI.ne.0) WRITE(IOIMP,10) ICHOLE
  45. 10 FORMAT(' ON DETRUIT UNE RIGIDITE CHOLEVSKISE SI ICHOLE = 1',
  46. 1 I5)
  47. IF(ICHOLE.EQ.0) GOTO 2
  48. C
  49. C **** DESTRUCTION DE LA MATRICE
  50. MMATRI=ICHOLE
  51. SEGACT MMATRI
  52. MDIAG=IDIAG
  53. if(ktrace.eq.mdiag) then
  54. ktrace=-ktrace
  55. msorse='MDIAG'
  56. endif
  57. SEGSUP MDIAG
  58. MELEME=IGEOMA
  59. IF(IPSAUV.NE.0) THEN
  60. ICOLAC = IPSAUV
  61. SEGACT ICOLAC
  62. ILISSE=ILISSG
  63. SEGACT ILISSE*MOD
  64. CALL TYPFIL('MAILLAGE',ICO)
  65. ITLACC = KCOLA(ICO)
  66. SEGACT ITLACC*MOD
  67. CALL AJOUN0(ITLACC,MELEME,ILISSE,iun)
  68. * SEGDES ITLACC,ILISSE
  69. * SEGDES ICOLAC
  70. ENDIF
  71. C Suppression du meleme des piles d'objets communiques
  72. if(piComm.gt.0) then
  73. piles=piComm
  74. segact piles
  75. call typfil('MAILLAGE',ico)
  76. do ipile=1,piles.proc(/1)
  77. jcolac= piles.proc(ipile)
  78. if(jcolac.ne.0) then
  79. segact jcolac
  80. jlisse=jcolac.ilissg
  81. segact jlisse*mod
  82. jtlacc=jcolac.kcola(ico)
  83. segact jtlacc*mod
  84. call ajoun0(jtlacc,MELEME,jlisse,iun)
  85. segdes jtlacc
  86. segdes jlisse
  87. segdes jcolac
  88. endif
  89. enddo
  90. segdes piles
  91. endif
  92. *** SEGSUP MELEME
  93. MINCPO=IINCPO
  94. if(ktrace.eq.mincpo) then
  95. ktrace=-ktrace
  96. msorse='MINCPO'
  97. endif
  98. SEGSUP MINCPO
  99. MIDUA=IIDUA
  100. if(ktrace.eq.midua) then
  101. ktrace=-ktrace
  102. msorse='MIDUA'
  103. endif
  104. SEGSUP MIDUA
  105. MHARK=IHARK
  106. if(ktrace.eq.mhark) then
  107. ktrace=-ktrace
  108. msorse='MHARK'
  109. endif
  110. SEGSUP MHARK
  111. MIMIK=IIMIK
  112. if(ktrace.eq.mimik) then
  113. ktrace=-ktrace
  114. msorse='MIMIK'
  115. endif
  116. SEGSUP MIMIK
  117. MDNOR=IDNORM
  118. if(ktrace.eq.mdnor) then
  119. ktrace=-ktrace
  120. msorse='MDNOR'
  121. endif
  122. SEGSUP MDNOR
  123. MILIGN=IILIGN
  124. SEGACT MILIGN
  125. INC=ILIGN(/1)
  126. DO 1 I=1,INC
  127. LIGN=ILIGN(I)
  128. if(ktrace.eq.lign) then
  129. ktrace=-ktrace
  130. msorse='LIGN'
  131. endif
  132. SEGSUP LIGN
  133. 1 CONTINUE
  134. if(ktrace.eq.milign) then
  135. ktrace=-ktrace
  136. msorse='MILIGN'
  137. endif
  138. SEGSUP MILIGN
  139. * la partie non symetrique eventuellement
  140. MILIGN=IILIGS
  141. *** write(6,*) 'iiligs dans dtrigz ',iiligs
  142. IF(milign.ne.0) then
  143. SEGACT MILIGN
  144. INC=ILIGN(/1)
  145. DO 6 I=1,INC
  146. LIGN=ILIGN(I)
  147. if(ktrace.eq.lign) then
  148. ktrace=-ktrace
  149. msorse='LIGN'
  150. endif
  151. SEGSUP LIGN
  152. 6 CONTINUE
  153. if(ktrace.eq.milign) then
  154. ktrace=-ktrace
  155. msorse='MILIGN'
  156. endif
  157. SEGSUP MILIGN
  158. endif
  159. if(ktrace.eq.mmatri) then
  160. ktrace=-ktrace
  161. msorse='MMATRI'
  162. endif
  163. SEGSUP MMATRI
  164. C
  165. C **** DESTRUCTION DU CHAPEAU
  166. 2 CONTINUE
  167. C
  168. CCCCCCCCCCCCC SI ON MIS DETRUIRE ELEM ON DETRUIT AUSSI LES RIGI
  169. C ELEMENTAIRES
  170. IF(IMGEO1.NE.0) THEN
  171. IMGEOD=IMGEO1
  172. if(ktrace.eq.imgeo1) then
  173. ktrace=-ktrace
  174. msorse='IMGEOD'
  175. endif
  176. SEGSUP IMGEOD
  177. ENDIF
  178. IF(ivecri.ne.0) then
  179. mvecri=ivecri
  180. segsup mvecri
  181. if(ktrace.eq.ivecri) then
  182. ktrace=-ktrace
  183. msorse='IVECRI'
  184. endif
  185. ENDIF
  186. IF(IDET.EQ.1) CALL DERIGI(IRET,KTRACE,MSORSE)
  187. * si type temporaire, destruction du xmatri du descr et du meleme
  188. if (mtymat.eq.'TEMPORAI') then
  189. do iri=1,irigel(/2)
  190. meleme=irigel(1,iri)
  191. call ooove1(lret,meleme)
  192. ** if (lret.eq.2) segsup meleme
  193. ** descr=irigel(3,iri)
  194. ** call ooove1(lret,descr)
  195. ** if (lret.eq.2) segsup descr
  196. xmatri=irigel(4,iri)
  197. call ooove1(lret,xmatri)
  198. *** if (lret.eq.2) segsup xmatri
  199. enddo
  200. endif
  201. if(imlag.ne.0) then
  202. meleme=imlag
  203. * probleme avec imlag, mais de toute facon ce n'est normalement pas gros
  204. *** segsup meleme
  205. endif
  206. ** IF(IDET.EQ.0) THEN
  207. if(ktrace.eq.mrigid) then
  208. ktrace=-ktrace
  209. msorse='MRIGID'
  210. endif
  211. nrigel=irigel(/2)
  212. segadj mrigid
  213. imgeo1=0
  214. ichole=0
  215. ivecri=0
  216. ** ENDIF
  217. 1000 continue
  218. segsup ladet
  219. IRET=0
  220. RETURN
  221. END
  222.  
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250.  
  251.  

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