Télécharger la plaquette Cast3M


fr en

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

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