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    MB234859  26/09/01    21:15:06     12631          
  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.  1000 continue
  29.       SEGACT MRIGID
  30.       IF(IIMPI.EQ.1) WRITE(IOIMP,10) ICHOLE
  31.    10 FORMAT('ON DETRUIT UNE RIGIDITE CHOLEVSKISE SI ICHOLE = 1',I5)
  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(IRET.NE.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.  
  132.  
  133.  
  134.  

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