Télécharger dtrigz.eso

Retour à la liste

Numérotation des lignes :

  1. C DTRIGZ SOURCE PV 16/11/26 21:15:39 9205
  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. DATA MOMOT(1)/'ELEM'/
  20. CALL LIRMOT(MOMOT,1,IDET,0)
  21. MRIGID=IRET
  22. SEGACT MRIGID
  23. IF(IIMPI.EQ.1) WRITE(IOIMP,10) ICHOLE
  24. 10 FORMAT(' ON DETRUIT UNE RIGIDITE CHOLEVSKISE SI ICHOLE = 1',
  25. 1 I5)
  26. IF(ICHOLE.EQ.0) GOTO 2
  27. C
  28. C **** DESTRUCTION DE LA MATRICE
  29. MMATRI=ICHOLE
  30. SEGACT MMATRI
  31. MDIAG=IDIAG
  32. if(ktrace.eq.mdiag) then
  33. ktrace=-ktrace
  34. msorse='MDIAG'
  35. endif
  36. SEGSUP MDIAG
  37. MELEME=IGEOMA
  38. IF(IPSAUV.NE.0) THEN
  39. ICOLAC = IPSAUV
  40. SEGACT ICOLAC
  41. ILISSE=ILISSG
  42. SEGACT ILISSE*MOD
  43. CALL TYPFIL('MAILLAGE',ICO)
  44. ITLACC = KCOLA(ICO)
  45. SEGACT ITLACC*MOD
  46. CALL AJOUN0(ITLACC,MELEME,ILISSE,1)
  47. * SEGDES ITLACC,ILISSE
  48. * SEGDES ICOLAC
  49. ENDIF
  50. C Suppression du meleme des piles d'objets communiques
  51. if(piComm.gt.0) then
  52. piles=piComm
  53. segact piles
  54. call typfil('MAILLAGE',ico)
  55. do ipile=1,piles.proc(/1)
  56. jcolac= piles.proc(ipile)
  57. if(jcolac.ne.0) then
  58. segact jcolac
  59. jlisse=jcolac.ilissg
  60. segact jlisse*mod
  61. jtlacc=jcolac.kcola(ico)
  62. segact jtlacc*mod
  63. call ajoun0(jtlacc,MELEME,jlisse,1)
  64. segdes jtlacc
  65. segdes jlisse
  66. segdes jcolac
  67. endif
  68. enddo
  69. segdes piles
  70. endif
  71. SEGSUP MELEME
  72. MINCPO=IINCPO
  73. if(ktrace.eq.mincpo) then
  74. ktrace=-ktrace
  75. msorse='MINCPO'
  76. endif
  77. SEGSUP MINCPO
  78. MIDUA=IIDUA
  79. if(ktrace.eq.midua) then
  80. ktrace=-ktrace
  81. msorse='MIDUA'
  82. endif
  83. SEGSUP MIDUA
  84. MHARK=IHARK
  85. if(ktrace.eq.mhark) then
  86. ktrace=-ktrace
  87. msorse='MHARK'
  88. endif
  89. SEGSUP MHARK
  90. MIMIK=IIMIK
  91. if(ktrace.eq.mimik) then
  92. ktrace=-ktrace
  93. msorse='MIMIK'
  94. endif
  95. SEGSUP MIMIK
  96. MDNOR=IDNORM
  97. if(ktrace.eq.mdnor) then
  98. ktrace=-ktrace
  99. msorse='MDNOR'
  100. endif
  101. SEGSUP MDNOR
  102. MILIGN=IILIGN
  103. SEGACT MILIGN
  104. INC=ILIGN(/1)
  105. DO 1 I=1,INC
  106. LIGN=ILIGN(I)
  107. if(ktrace.eq.lign) then
  108. ktrace=-ktrace
  109. msorse='LIGN'
  110. endif
  111. SEGSUP LIGN
  112. 1 CONTINUE
  113. if(ktrace.eq.milign) then
  114. ktrace=-ktrace
  115. msorse='MILIGN'
  116. endif
  117. SEGSUP MILIGN
  118. if(ktrace.eq.mmatri) then
  119. ktrace=-ktrace
  120. msorse='MMATRI'
  121. endif
  122. SEGSUP MMATRI
  123. C
  124. C **** DESTRUCTION DU CHAPEAU
  125. 2 CONTINUE
  126. C
  127. CCCCCCCCCCCCC SI ON MIS DETRUIRE ELEM ON DETRUIT AUSSI LES RIGI
  128. C ELEMENTAIRES
  129. IF(IMGEO1.NE.0) THEN
  130. IMGEOD=IMGEO1
  131. if(ktrace.eq.imgeo1) then
  132. ktrace=-ktrace
  133. msorse='IMGEOD'
  134. endif
  135. SEGSUP IMGEOD
  136. ENDIF
  137. IF(ivecri.ne.0) then
  138. mvecri=ivecri
  139. segsup mvecri
  140. if(ktrace.eq.ivecri) then
  141. ktrace=-ktrace
  142. msorse='IVECRI'
  143. endif
  144. ENDIF
  145. IF(IDET.EQ.1) CALL DERIGI(IRET,KTRACE,MSORSE)
  146. IF(IDET.EQ.0) THEN
  147. if(ktrace.eq.mrigid) then
  148. ktrace=-ktrace
  149. msorse='MRIGID'
  150. endif
  151. SEGSUP MRIGID
  152. ENDIF
  153. IRET=0
  154. RETURN
  155. END
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  

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