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

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