Télécharger dtrigi.eso

Retour à la liste

Numérotation des lignes :

dtrigi
  1. C DTRIGI SOURCE PV090527 24/09/04 21:15:02 12002
  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.  
  10. -INC PPARAM
  11. -INC CCOPTIO
  12. -INC COCOLL
  13. -INC SMRIGID
  14. -INC SMMATRI
  15. -INC SMELEME
  16. -INC TMCOLAC
  17.  
  18. pointeur piles.LISPIL
  19. pointeur jcolac.ICOLAC
  20. pointeur jlisse.ILISSE
  21. pointeur jtlacc.ITLACC
  22. pointeur pile.ITLACC
  23. DATA MOMOT(1)/'ELEM'/
  24. iun=1
  25. CALL LIRMOT(MOMOT,1,IDET,0)
  26. MRIGID=IRET
  27. IF(IIMPI.EQ.1) WRITE(IOIMP,10) ICHOLE
  28. 10 FORMAT(' ON DETRUIT UNE RIGIDITE CHOLEVSKISE SI ICHOLE = 1',
  29. 1 I5)
  30. 1000 continue
  31. SEGACT MRIGID
  32. IF(ICHOLE.EQ.0) GOTO 2
  33. C
  34. C **** DESTRUCTION DE LA MATRICE
  35. MMATRI=ICHOLE
  36. SEGACT MMATRI
  37. MDIAG=IDIAG
  38. SEGSUP MDIAG
  39. MELEME=IGEOMA
  40. IF(IPSAUV.NE.0) THEN
  41. ICOLAC = IPSAUV
  42. SEGACT ICOLAC
  43. ILISSE=ILISSG
  44. SEGACT ILISSE*MOD
  45. CALL TYPFIL('MAILLAGE',ICO)
  46. ITLACC = KCOLA(ICO)
  47. SEGACT ITLACC*MOD
  48. CALL AJOUN0(ITLACC,MELEME,ILISSE,iun)
  49. * SEGDES ITLACC,ILISSE
  50. * SEGDES ICOLAC
  51. ENDIF
  52. C Suppression du meleme 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,iun)
  66. segdes jtlacc
  67. segdes jlisse
  68. segdes jcolac
  69. endif
  70. enddo
  71. segdes piles
  72. endif
  73. *** SEGSUP MELEME
  74. MINCPO=IINCPO
  75. SEGSUP MINCPO
  76. MIDUA=IIDUA
  77. SEGSUP MIDUA
  78. MHARK=IHARK
  79. SEGSUP MHARK
  80. MIMIK=IIMIK
  81. SEGSUP MIMIK
  82. MDNOR=IDNORM
  83. SEGSUP MDNOR
  84. MILIGN=IILIGN
  85. SEGACT MILIGN
  86. INC=ILIGN(/1)
  87. DO 1 I=1,INC
  88. LIGN=ILIGN(I)
  89. SEGSUP LIGN
  90. 1 CONTINUE
  91. SEGSUP MILIGN
  92. SEGSUP MMATRI
  93. C
  94. C **** DESTRUCTION DU CHAPEAU
  95. 2 CONTINUE
  96. C
  97. CCCCCCCCCCCCC SI ON MIS DETRUIRE ELEM ON DETRUIT AUSSI LES RIGI
  98. C ELEMENTAIRES
  99. IF(IMGEO1.NE.0) THEN
  100. IMGEOD=IMGEO1
  101. SEGSUP IMGEOD
  102. ENDIF
  103. IF(IVECRI.NE.0) then
  104. MVECRI=IVECRI
  105. segsup MVECRI
  106. endif
  107. IF(IDET.EQ.1) THEN
  108. ktrace = -1
  109. CALL DERIGI(IRET,ktrace,msorse)
  110. ENDIF
  111. mrigt=jrcond
  112. ** IF(IDET.EQ.0) then
  113. nrigel=irigel(/2)
  114. segadj mrigid
  115. imgeo1=0
  116. ICHOLE=0
  117. ivecri=0
  118. ** endif
  119. mrigid=mrigt
  120. if(mrigid.ne.0) goto 1000
  121. IRET=0
  122. RETURN
  123. END
  124.  
  125.  
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  

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