Télécharger dtrigz.eso

Retour à la liste

Numérotation des lignes :

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

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