Télécharger la plaquette Cast3M


fr en

Télécharger dtsupz.eso

Retour à la liste

Numérotation des lignes : 

dtsupz

  1. C DTSUPZ    SOURCE    PV        21/01/21    21:15:15     10862          
  2.                SUBROUTINE DTSUPz(IRET,ktrace,msorse)
  3. C  **** DESTRUCTION APPROXIMATIVE D'UN SUPER-ELEMENT
  4.       IMPLICIT INTEGER(I-N)
  5.       character*6 msorse                                                                        MSUPER=IRET
  6.       integer i, iaux, ico, inc, ipile, iret, ktrace
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC COCOLL
  11. -INC SMSUPER
  12. -INC SMELEME
  13. -INC SMMATRI
  14. -INC TMCOLAC
  15.  
  16.       pointeur piles.LISPIL
  17.       pointeur jcolac.ICOLAC
  18.       pointeur jlisse.ILISSE
  19.       pointeur jtlacc.ITLACC
  20.       iun=1
  21.       MSUPER=IRET
  22.       SEGACT MSUPER
  23. C
  24.       IAUX=MRIGTO
  25.       CALL DTRIGZ(IAUX,ktrace,msorse)
  26. C
  27.       IAUX=MSURAI
  28.       CALL DTRIGZ(IAUX,ktrace,msorse)
  29. C
  30.       MELEME=MSUPEL
  31.       if( ktrace.eq.meleme) then
  32.         ktrace=-ktrace
  33.         msorse='MELEME'
  34.       endif
  35.       SEGSUP MELEME
  36.          IF(IPSAUV.NE.0) THEN
  37.          ICOLAC = IPSAUV
  38.          SEGACT ICOLAC
  39.          ILISSE=ILISSG
  40.          SEGACT ILISSE*MOD
  41.          CALL TYPFIL('MAILLAGE',ICO)
  42.          ITLACC = KCOLA(ICO)
  43.          SEGACT ITLACC*MOD
  44.          CALL AJOUN0(ITLACC,MELEME,ILISSE,iun)
  45.          CALL TYPFIL('RIGIDITE',ICO)
  46.          ITLACC = KCOLA(ICO)
  47.          SEGACT ITLACC*MOD
  48.          IAUX=MSURAI
  49.          CALL AJOUN0(ITLACC,IAUX,ILISSE,iun)
  50.          IAUX=MRIGTO
  51.          CALL AJOUN0(ITLACC,IAUX,ILISSE,iun)
  52.          SEGDES ITLACC
  53.          SEGDES ICOLAC,ILISSE
  54.          ENDIF
  55. C        Suppression des piles d'objets communiques
  56.          if(piComm.gt.0) then
  57.             piles=piComm
  58.             segact piles
  59.             call typfil('MAILLAGE',ico)
  60.             do ipile=1,piles.proc(/1)
  61.                jcolac= piles.proc(ipile)
  62.                if(jcolac.ne.0) then
  63.                   segact jcolac
  64.                   jlisse=jcolac.ilissg
  65.                   segact jlisse*mod
  66.                   jtlacc=jcolac.kcola(ico)
  67.                   segact jtlacc*mod
  68.                   call ajoun0(jtlacc,MELEME,jlisse,iun)
  69.                   segdes jtlacc
  70.                endif
  71.             enddo
  72.             call typfil('RIGIDITE',ico)
  73.             do ipile=1,piles.proc(/1)
  74.                jcolac= piles.proc(ipile)
  75.                if(jcolac.ne.0) then
  76.                   jlisse=jcolac.ilissg
  77.                   jtlacc=jcolac.kcola(ico)
  78.                   segact jtlacc*mod
  79.                   iaux=MSURAI
  80.                   call ajoun0(jtlacc,IAUX,jlisse,iun)
  81.                   iaux=MRIGTO
  82.                   call ajoun0(jtlacc,IAUX,jlisse,iun)
  83.                   segdes jtlacc
  84.                   segdes jlisse
  85.                   segdes jcolac
  86.                endif
  87.             enddo
  88.             segdes piles
  89.          endif
  90. C
  91.       MMATRI=MCROUT
  92.       SEGACT MMATRI
  93.       MDIAG=IDIAG
  94.       if( ktrace.eq.mdiag) then
  95.         ktrace=-ktrace
  96.         msorse='MDNOR'
  97.       endif
  98.       SEGSUP MDIAG
  99.       MELEME=IGEOMA
  100.       if( ktrace.eq.meleme) then
  101.         ktrace=-ktrace
  102.         msorse='MELEME'
  103.       endif
  104.       SEGSUP MELEME
  105.       IF(IPSAUV.NE.0) THEN
  106.          ICOLAC = IPSAUV
  107.          SEGACT ICOLAC
  108.          ILISSE=ILISSG
  109.          SEGACT ILISSE*MOD
  110.          CALL TYPFIL('MAILLAGE',ICO)
  111.          ITLACC = KCOLA(ICO)
  112.          SEGACT ITLACC*MOD
  113.          CALL AJOUN0(ITLACC,MELEME,ILISSE,iun)
  114.          SEGDES ITLACC
  115.          SEGDES ICOLAC,ILISSE
  116.       ENDIF
  117. C     Suppression du meleme des piles d'objets communiques
  118.       if(piComm.gt.0) then
  119.          piles=piComm
  120.          segact piles
  121.          call typfil('MAILLAGE',ico)
  122.          do ipile=1,piles.proc(/1)
  123.             jcolac= piles.proc(ipile)
  124.             if(jcolac.ne.0) then
  125.                segact jcolac
  126.                jlisse=jcolac.ilissg
  127.                segact jlisse*mod
  128.                jtlacc=jcolac.kcola(ico)
  129.                segact jtlacc*mod
  130.                call ajoun0(jtlacc,MELEME,jlisse,iun)
  131.                segdes jtlacc
  132.                segdes jlisse
  133.                segdes jcolac
  134.             endif
  135.          enddo
  136.          segdes piles
  137.       endif
  138.       MINCPO=IINCPO
  139.       if( ktrace.eq.mincpo) then
  140.         ktrace=-ktrace
  141.         msorse='MINCPO'
  142.       endif
  143.       SEGSUP MINCPO
  144.       MIDUA=IIDUA
  145.       if( ktrace.eq.midua) then
  146.         ktrace=-ktrace
  147.         msorse='MIDUA'
  148.       endif
  149.       SEGSUP MIDUA
  150.       MHARK=IHARK
  151.       if( ktrace.eq.mhark) then
  152.         ktrace=-ktrace
  153.         msorse='MHARK'
  154.       endif
  155.       SEGSUP MHARK
  156.       MIMIK=IIMIK
  157.       if( ktrace.eq.mimik) then
  158.         ktrace=-ktrace
  159.         msorse='MIMIK'
  160.       endif
  161.       SEGSUP MIMIK
  162.       MDNOR=IDNORM
  163.       if( ktrace.eq.mdnor) then
  164.         ktrace=-ktrace
  165.         msorse='MDNOR'
  166.       endif
  167.       SEGSUP MDNOR
  168.       MILIGN=IILIGN
  169.       SEGACT MILIGN
  170.       INC=ILIGN(/1)
  171.       DO 1 I=1,INC
  172.       LIGN=ILIGN(I)
  173.       if( ktrace.eq.lign) then
  174.         ktrace=-ktrace
  175.         msorse='LIGN'
  176.       endif
  177.       SEGSUP LIGN
  178.  1    CONTINUE
  179.       if( ktrace.eq.milign) then
  180.         ktrace=-ktrace
  181.         msorse='MILIGN'
  182.       endif
  183.       SEGSUP MILIGN
  184.       if( ktrace.eq.mmatri) then
  185.         ktrace=-ktrace
  186.         msorse='MMATRI'
  187.       endif
  188.       SEGSUP MMATRI
  189.       IF(IPSAUV.NE.0) THEN
  190.          ICOLAC = IPSAUV
  191.          SEGACT ICOLAC
  192.          ILISSE=ILISSG
  193.          SEGACT ILISSE*MOD
  194.          CALL TYPFIL('IMATRI  ',ICO)
  195.          ITLACC = KCOLA(ICO)
  196.          SEGACT ITLACC*MOD
  197.          CALL AJOUN0(ITLACC,MMATRI,ILISSE,iun)
  198.          SEGDES ITLACC
  199.          SEGDES ICOLAC,ILISSE
  200.       ENDIF
  201. C     Suppression du meleme des piles d'objets communiques
  202.       if(piComm.gt.0) then
  203.          piles=piComm
  204.          segact piles
  205.          call typfil('IMATRI  ',ico)
  206.          do ipile=1,piles.proc(/1)
  207.             jcolac= piles.proc(ipile)
  208.             if(jcolac.ne.0) then
  209.                segact jcolac
  210.                jlisse=jcolac.ilissg
  211.                segact jlisse*mod
  212.                jtlacc=jcolac.kcola(ico)
  213.                segact jtlacc*mod
  214.                call ajoun0(jtlacc,MMATRI,jlisse,iun)
  215.                segdes jtlacc
  216.                segdes jlisse
  217.                segdes jcolac
  218.             endif
  219.          enddo
  220.          segdes piles
  221.       endif
  222. C
  223.       if( ktrace.eq.msuper) then
  224.         ktrace=-ktrace
  225.         msorse='MSUPER'
  226.       endif
  227.       SEGSUP MSUPER
  228.       RETURN
  229.       END
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250.  
  251.  
  252.  

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