C DTRIGZ SOURCE PV 21/12/05 21:15:00 11207 SUBROUTINE DTRIGz(IRET,ktrace,msorse) C **** DESTRUCTION DE LA MATRICE SI ELLE EXISTE,DESTRUCTION DU CHAPEAU C **** MATRICE: ON DETRUIT TOUT IMPLICIT INTEGER(I-N) CHARACTER*4 MOMOT(1) character*6 msorse integer i,ico,idet,ipile,inc,iret,ktrace -INC PPARAM -INC CCOPTIO -INC COCOLL -INC SMRIGID -INC SMMATRI -INC SMELEME -INC TMCOLAC -INC TMVECRIG pointeur piles.LISPIL pointeur jcolac.ICOLAC pointeur jlisse.ILISSE pointeur jtlacc.ITLACC segment ladet(0) DATA MOMOT(1)/'ELEM'/ iun=1 CALL LIRMOT(MOMOT,1,IDET,0) MRIGID=IRET segini ladet * fabrication de la liste des matrices a detruire 1010 continue segact mrigid ladet(**)=mrigid if(jrdepp.ne.0) ladet(**)=jrdepp if(jrdepd.ne.0) ladet(**)=jrdepd if(jrelim.ne.0) ladet(**)=jrelim if(jrtot.ne.0) ladet(**)=jrtot if(jrgard.ne.0) ladet(**)=jrgard if (jrcond.ne.0) then mrigid=jrcond goto 1010 endif ** write(6,*) ' nb matrice a detruire ',ladet(/1) do 1000 ir=1,ladet(/1) mrigid=ladet(ir) SEGACT MRIGID IF(IIMPI.ne.0) WRITE(IOIMP,10) ICHOLE 10 FORMAT(' ON DETRUIT UNE RIGIDITE CHOLEVSKISE SI ICHOLE = 1', 1 I5) IF(ICHOLE.EQ.0) GOTO 2 C C **** DESTRUCTION DE LA MATRICE MMATRI=ICHOLE SEGACT MMATRI MDIAG=IDIAG if(ktrace.eq.mdiag) then ktrace=-ktrace msorse='MDIAG' endif SEGSUP MDIAG MELEME=IGEOMA IF(IPSAUV.NE.0) THEN ICOLAC = IPSAUV SEGACT ICOLAC ILISSE=ILISSG SEGACT ILISSE*MOD CALL TYPFIL('MAILLAGE',ICO) ITLACC = KCOLA(ICO) SEGACT ITLACC*MOD CALL AJOUN0(ITLACC,MELEME,ILISSE,iun) * SEGDES ITLACC,ILISSE * SEGDES ICOLAC ENDIF C Suppression du meleme des piles d'objets communiques if(piComm.gt.0) then piles=piComm segact piles call typfil('MAILLAGE',ico) do ipile=1,piles.proc(/1) jcolac= piles.proc(ipile) if(jcolac.ne.0) then segact jcolac jlisse=jcolac.ilissg segact jlisse*mod jtlacc=jcolac.kcola(ico) segact jtlacc*mod call ajoun0(jtlacc,MELEME,jlisse,iun) segdes jtlacc segdes jlisse segdes jcolac endif enddo segdes piles endif SEGSUP MELEME MINCPO=IINCPO if(ktrace.eq.mincpo) then ktrace=-ktrace msorse='MINCPO' endif SEGSUP MINCPO MIDUA=IIDUA if(ktrace.eq.midua) then ktrace=-ktrace msorse='MIDUA' endif SEGSUP MIDUA MHARK=IHARK if(ktrace.eq.mhark) then ktrace=-ktrace msorse='MHARK' endif SEGSUP MHARK MIMIK=IIMIK if(ktrace.eq.mimik) then ktrace=-ktrace msorse='MIMIK' endif SEGSUP MIMIK MDNOR=IDNORM if(ktrace.eq.mdnor) then ktrace=-ktrace msorse='MDNOR' endif SEGSUP MDNOR MILIGN=IILIGN SEGACT MILIGN INC=ILIGN(/1) DO 1 I=1,INC LIGN=ILIGN(I) if(ktrace.eq.lign) then ktrace=-ktrace msorse='LIGN' endif SEGSUP LIGN 1 CONTINUE if(ktrace.eq.milign) then ktrace=-ktrace msorse='MILIGN' endif SEGSUP MILIGN * la partie non symetrique eventuellement MILIGN=IILIGS *** write(6,*) 'iiligs dans dtrigz ',iiligs IF(milign.ne.0) then SEGACT MILIGN INC=ILIGN(/1) DO 6 I=1,INC LIGN=ILIGN(I) if(ktrace.eq.lign) then ktrace=-ktrace msorse='LIGN' endif SEGSUP LIGN 6 CONTINUE if(ktrace.eq.milign) then ktrace=-ktrace msorse='MILIGN' endif SEGSUP MILIGN endif if(ktrace.eq.mmatri) then ktrace=-ktrace msorse='MMATRI' endif SEGSUP MMATRI C C **** DESTRUCTION DU CHAPEAU 2 CONTINUE C CCCCCCCCCCCCC SI ON MIS DETRUIRE ELEM ON DETRUIT AUSSI LES RIGI C ELEMENTAIRES IF(IMGEO1.NE.0) THEN IMGEOD=IMGEO1 if(ktrace.eq.imgeo1) then ktrace=-ktrace msorse='IMGEOD' endif SEGSUP IMGEOD ENDIF IF(ivecri.ne.0) then mvecri=ivecri segsup mvecri if(ktrace.eq.ivecri) then ktrace=-ktrace msorse='IVECRI' endif ENDIF IF(IDET.EQ.1) CALL DERIGI(IRET,KTRACE,MSORSE) * si type temporaire, destruction du xmatri du descr et du meleme if (mtymat.eq.'TEMPORAI') then do iri=1,irigel(/2) meleme=irigel(1,iri) call ooove1(lret,meleme) if (lret.eq.2) segsup meleme ** descr=irigel(3,iri) ** call ooove1(lret,descr) ** if (lret.eq.2) segsup descr xmatri=irigel(4,iri) call ooove1(lret,xmatri) if (lret.eq.2) segsup xmatri enddo endif if(imlag.ne.0) then meleme=imlag * probleme avec imlag, mais de toute facon ce n'est normalement pas gros *** segsup meleme endif IF(IDET.EQ.0) THEN if(ktrace.eq.mrigid) then ktrace=-ktrace msorse='MRIGID' endif SEGSUP MRIGID ENDIF 1000 continue segsup ladet IRET=0 RETURN END