Télécharger la plaquette Cast3M


fr en

Télécharger dtrigz.eso

Retour à la liste

Numérotation des lignes : 

dtrigz

  1. C DTRIGZ    SOURCE    PV        21/12/05    21:15:00     11207          
  2.                SUBROUTINE DTRIGz(IRET,ktrace,msorse)
  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,ipile,inc,iret,ktrace
  9.  
  10. -INC PPARAM
  11. -INC CCOPTIO
  12. -INC COCOLL
  13. -INC SMRIGID
  14. -INC SMMATRI
  15. -INC SMELEME
  16. -INC TMCOLAC
  18.       pointeur piles.LISPIL
  19.       pointeur jcolac.ICOLAC
  20.       pointeur jlisse.ILISSE
  21.       pointeur jtlacc.ITLACC
  22.       segment  ladet(0)
  23.       DATA MOMOT(1)/'ELEM'/
  24.       iun=1
  25.       CALL LIRMOT(MOMOT,1,IDET,0)
  26.       MRIGID=IRET
  27.       segini ladet
  28. *  fabrication de la liste des matrices a detruire
  29.  1010 continue
  30.       segact mrigid
  31.       ladet(**)=mrigid
  32.       if(jrdepp.ne.0) ladet(**)=jrdepp
  33.       if(jrdepd.ne.0) ladet(**)=jrdepd
  34.       if(jrelim.ne.0) ladet(**)=jrelim
  35.       if(jrtot.ne.0) ladet(**)=jrtot
  36.       if(jrgard.ne.0) ladet(**)=jrgard
  37.       if (jrcond.ne.0) then
  38.         mrigid=jrcond
  39.         goto 1010
  40.       endif
  41. **    write(6,*) ' nb matrice a detruire ',ladet(/1)
  42.       do 1000 ir=1,ladet(/1)
  43.       mrigid=ladet(ir)
  44.       SEGACT MRIGID
  45.       IF(IIMPI.ne.0) WRITE(IOIMP,10) ICHOLE
  46.    10 FORMAT('  ON DETRUIT UNE RIGIDITE CHOLEVSKISE SI ICHOLE = 1',
  47.      1 I5)
  48.       IF(ICHOLE.EQ.0) GOTO 2
  49. C
  50. C  **** DESTRUCTION DE LA MATRICE
  51.       MMATRI=ICHOLE
  52.       SEGACT MMATRI
  53.       MDIAG=IDIAG
  54.       if(ktrace.eq.mdiag) then
  55.         ktrace=-ktrace
  56.         msorse='MDIAG'
  57.       endif
  58.       SEGSUP MDIAG
  59.       MELEME=IGEOMA
  60.       IF(IPSAUV.NE.0) THEN
  61.          ICOLAC = IPSAUV
  62.          SEGACT ICOLAC
  63.          ILISSE=ILISSG
  64.          SEGACT ILISSE*MOD
  65.          CALL TYPFIL('MAILLAGE',ICO)
  66.          ITLACC = KCOLA(ICO)
  67.          SEGACT ITLACC*MOD
  68.          CALL AJOUN0(ITLACC,MELEME,ILISSE,iun)
  69. *        SEGDES ITLACC,ILISSE
  70. *        SEGDES ICOLAC
  71.       ENDIF
  72. C        Suppression du meleme des piles d'objets communiques
  73.       if(piComm.gt.0) then
  74.          piles=piComm
  75.          segact piles
  76.          call typfil('MAILLAGE',ico)
  77.          do ipile=1,piles.proc(/1)
  78.          jcolac= piles.proc(ipile)
  79.          if(jcolac.ne.0) then
  80.             segact jcolac
  81.             jlisse=jcolac.ilissg
  82.             segact jlisse*mod
  83.             jtlacc=jcolac.kcola(ico)
  84.             segact jtlacc*mod
  85.             call ajoun0(jtlacc,MELEME,jlisse,iun)
  86.             segdes jtlacc
  87.             segdes jlisse
  88.             segdes jcolac
  89.          endif
  90.          enddo
  91.          segdes piles
  92.       endif
  93.       SEGSUP MELEME
  94.       MINCPO=IINCPO
  95.       if(ktrace.eq.mincpo) then
  96.         ktrace=-ktrace
  97.         msorse='MINCPO'
  98.       endif
  99.       SEGSUP MINCPO
  100.       MIDUA=IIDUA
  101.       if(ktrace.eq.midua) then
  102.         ktrace=-ktrace
  103.         msorse='MIDUA'
  104.       endif
  105.       SEGSUP MIDUA
  106.       MHARK=IHARK
  107.       if(ktrace.eq.mhark) then
  108.         ktrace=-ktrace
  109.         msorse='MHARK'
  110.       endif
  111.       SEGSUP MHARK
  112.       MIMIK=IIMIK
  113.       if(ktrace.eq.mimik) then
  114.         ktrace=-ktrace
  115.         msorse='MIMIK'
  116.       endif
  117.       SEGSUP MIMIK
  118.       MDNOR=IDNORM
  119.       if(ktrace.eq.mdnor) then
  120.         ktrace=-ktrace
  121.         msorse='MDNOR'
  122.       endif
  123.       SEGSUP MDNOR
  124.       MILIGN=IILIGN
  125.       SEGACT MILIGN
  126.       INC=ILIGN(/1)
  127.       DO 1 I=1,INC
  128.       LIGN=ILIGN(I)
  129.       if(ktrace.eq.lign) then
  130.         ktrace=-ktrace
  131.         msorse='LIGN'
  132.       endif
  133.       SEGSUP LIGN
  134.  1    CONTINUE
  135.       if(ktrace.eq.milign)  then
  136.         ktrace=-ktrace
  137.         msorse='MILIGN'
  138.       endif
  139.       SEGSUP MILIGN
  140. *  la partie non symetrique eventuellement
  141.       MILIGN=IILIGS
  142. ***   write(6,*) 'iiligs dans dtrigz ',iiligs
  143.       IF(milign.ne.0) then
  144.       SEGACT MILIGN
  145.       INC=ILIGN(/1)
  146.       DO 6 I=1,INC
  147.       LIGN=ILIGN(I)
  148.       if(ktrace.eq.lign) then
  149.         ktrace=-ktrace
  150.         msorse='LIGN'
  151.       endif
  152.       SEGSUP LIGN
  153.  6    CONTINUE
  154.       if(ktrace.eq.milign)  then
  155.         ktrace=-ktrace
  156.         msorse='MILIGN'
  157.       endif
  158.       SEGSUP MILIGN
  159.       endif
  160.       if(ktrace.eq.mmatri) then
  161.         ktrace=-ktrace
  162.         msorse='MMATRI'
  163.       endif
  164.       SEGSUP MMATRI
  165. C
  166. C  **** DESTRUCTION DU CHAPEAU
  167.  2    CONTINUE
  168. C
  169. CCCCCCCCCCCCC  SI ON MIS DETRUIRE ELEM ON DETRUIT AUSSI LES RIGI
  170. C              ELEMENTAIRES
  171.       IF(IMGEO1.NE.0) THEN
  172.               IMGEOD=IMGEO1
  173.               if(ktrace.eq.imgeo1) then
  174.                 ktrace=-ktrace
  175.                 msorse='IMGEOD'
  176.               endif
  177.               SEGSUP IMGEOD
  178.       ENDIF
  179.       IF(ivecri.ne.0) then
  180.             mvecri=ivecri
  181.             segsup mvecri
  182.             if(ktrace.eq.ivecri) then
  183.                 ktrace=-ktrace
  184.                 msorse='IVECRI'
  185.             endif
  186.       ENDIF
  187.       IF(IDET.EQ.1) CALL DERIGI(IRET,KTRACE,MSORSE)
  188. *  si type temporaire, destruction du xmatri du descr et du meleme
  189.       if (mtymat.eq.'TEMPORAI') then
  190.         do iri=1,irigel(/2)
  191.          meleme=irigel(1,iri)
  192.          call ooove1(lret,meleme)
  193.          if (lret.eq.2) segsup meleme
  194. **       descr=irigel(3,iri)
  195. **       call ooove1(lret,descr)
  196. **       if (lret.eq.2) segsup descr
  197.          xmatri=irigel(4,iri)
  198.          call ooove1(lret,xmatri)
  199.          if (lret.eq.2) segsup xmatri
  200.         enddo
  201.       endif
  202.       if(imlag.ne.0) then
  203.         meleme=imlag
  204. *  probleme avec imlag, mais de toute facon ce n'est normalement pas gros
  205. ***     segsup meleme
  206.       endif
  207.       IF(IDET.EQ.0) THEN
  208.         if(ktrace.eq.mrigid) then
  209.           ktrace=-ktrace
  210.           msorse='MRIGID'
  211.         endif
  212.         SEGSUP MRIGID
  213.       ENDIF
  214.  1000 continue
  215.       segsup ladet
  216.       IRET=0
  217.       RETURN
  218.       END
  219.  
  220.  
  221.  
  222.  
  223.  
  224.  
  225.  
  226.  
  227.  
  228.  
  229.  
  230.  
  231.  
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  
  239.  
  240.  
  241.  
  242.  
  243.  
  244.  
  245.  
  246.  

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