Télécharger dtrigi.eso

Retour à la liste

Numérotation des lignes :

  1. C DTRIGI SOURCE PV 19/02/25 21:15:44 10121
  2. SUBROUTINE DTRIGI(IRET)
  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, inc, ipile, iret
  9. -INC CCOPTIO
  10. -INC COCOLL
  11. -INC SMRIGID
  12. -INC SMMATRI
  13. -INC SMELEME
  14. -INC TMCOLAC
  15.  
  16. pointeur piles.LISPIL
  17. pointeur jcolac.ICOLAC
  18. pointeur jlisse.ILISSE
  19. pointeur jtlacc.ITLACC
  20. pointeur pile.ITLACC
  21. DATA MOMOT(1)/'ELEM'/
  22. CALL LIRMOT(MOMOT,1,IDET,0)
  23. MRIGID=IRET
  24. IF(IIMPI.EQ.1) WRITE(IOIMP,10) ICHOLE
  25. 10 FORMAT(' ON DETRUIT UNE RIGIDITE CHOLEVSKISE SI ICHOLE = 1',
  26. 1 I5)
  27. 1000 continue
  28. SEGACT MRIGID
  29. IF(ICHOLE.EQ.0) GOTO 2
  30. C
  31. C **** DESTRUCTION DE LA MATRICE
  32. MMATRI=ICHOLE
  33. SEGACT MMATRI
  34. MDIAG=IDIAG
  35. SEGSUP MDIAG
  36. MELEME=IGEOMA
  37. IF(IPSAUV.NE.0) THEN
  38. ICOLAC = IPSAUV
  39. SEGACT ICOLAC
  40. ILISSE=ILISSG
  41. SEGACT ILISSE*MOD
  42. CALL TYPFIL('MAILLAGE',ICO)
  43. ITLACC = KCOLA(ICO)
  44. SEGACT ITLACC*MOD
  45. CALL AJOUN0(ITLACC,MELEME,ILISSE,1)
  46. * SEGDES ITLACC,ILISSE
  47. * SEGDES ICOLAC
  48. ENDIF
  49. C Suppression du meleme des piles d'objets communiques
  50. if(piComm.gt.0) then
  51. piles=piComm
  52. segact piles
  53. call typfil('MAILLAGE',ico)
  54. do ipile=1,piles.proc(/1)
  55. jcolac= piles.proc(ipile)
  56. if(jcolac.ne.0) then
  57. segact jcolac
  58. jlisse=jcolac.ilissg
  59. segact jlisse*mod
  60. jtlacc=jcolac.kcola(ico)
  61. segact jtlacc*mod
  62. call ajoun0(jtlacc,MELEME,jlisse,1)
  63. segdes jtlacc
  64. segdes jlisse
  65. segdes jcolac
  66. endif
  67. enddo
  68. segdes piles
  69. endif
  70. SEGSUP MELEME
  71. MINCPO=IINCPO
  72. SEGSUP MINCPO
  73. MIDUA=IIDUA
  74. SEGSUP MIDUA
  75. MHARK=IHARK
  76. SEGSUP MHARK
  77. MIMIK=IIMIK
  78. SEGSUP MIMIK
  79. MDNOR=IDNORM
  80. SEGSUP MDNOR
  81. MILIGN=IILIGN
  82. SEGACT MILIGN
  83. INC=ILIGN(/1)
  84. DO 1 I=1,INC
  85. LIGN=ILIGN(I)
  86. SEGSUP LIGN
  87. 1 CONTINUE
  88. SEGSUP MILIGN
  89. SEGSUP MMATRI
  90. C
  91. C **** DESTRUCTION DU CHAPEAU
  92. 2 CONTINUE
  93. C
  94. CCCCCCCCCCCCC SI ON MIS DETRUIRE ELEM ON DETRUIT AUSSI LES RIGI
  95. C ELEMENTAIRES
  96. IF(IMGEO1.NE.0) THEN
  97. IMGEOD=IMGEO1
  98. SEGSUP IMGEOD
  99. ENDIF
  100. IF(IVECRI.NE.0) then
  101. MVECRI=IVECRI
  102. segsup MVECRI
  103. endif
  104. IF(IDET.EQ.1) THEN
  105. ktrace = -1
  106. CALL DERIGI(IRET,ktrace,msorse)
  107. ENDIF
  108. mrigt=jrcond
  109. IF(IDET.EQ.0) SEGSUP MRIGID
  110. mrigid=mrigt
  111. if(mrigid.ne.0) goto 1000
  112. IRET=0
  113. RETURN
  114. END
  115.  
  116.  
  117.  
  118.  

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