1 : C DTRIGZ SOURCE CHAT 09/10/09 21:17:24 6519 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 : -INC SMRIGID 7 : -INC SMMATRI 8 : -INC SMELEME 9 : -INC CCOPTIO 10 : -INC TMCOLAC 11 : -INC TMVECRIG 12 : CHARACTER*4 MOMOT(1) 13 : character*6 msorse 14 : DATA MOMOT(1)/'ELEM'/ 14 : CALL LIRMOT(MOMOT,1,IDET,0) 15 : MRIGID=IRET 16 : SEGACT MRIGID 17 : IF(IIMPI.EQ.1) WRITE(IOIMP,10) ICHOLE 18 : 10 FORMAT(' ON DETRUIT UNE RIGIDITE CHOLEVSKISE SI ICHOLE = 1', 19 : 1 I5) 20 : IF(ICHOLE.EQ.0) GOTO 2 21 : C 22 : C **** DESTRUCTION DE LA MATRICE 23 : MMATRI=ICHOLE 24 : SEGACT MMATRI 25 : MDIAG=IDIAG 26 : if(ktrace.eq.mdiag) then 27 : ktrace=-ktrace 28 : msorse='MDIAG' 29 : endif 30 : SEGSUP MDIAG 31 : MELEME=IGEOMA 32 : IF(IPSAUV.NE.0) THEN 33 : ICOLAC = IPSAUV 34 : SEGACT ICOLAC 35 : ILISSE=ILISSG 36 : SEGACT ILISSE*MOD 36 : CALL TYPFIL('MAILLAGE',ICO) 37 : ITLACC = KCOLA(ICO) 38 : SEGACT ITLACC*MOD 38 : CALL AJOUN0(ITLACC,MELEME,ILISSE,1) 39 : * SEGDES ITLACC,ILISSE 40 : * SEGDES ICOLAC 41 : ENDIF 42 : SEGSUP MELEME 43 : MINCPO=IINCPO 44 : if(ktrace.eq.mincpo) then 45 : ktrace=-ktrace 46 : msorse='MINCPO' 47 : endif 48 : SEGSUP MINCPO 49 : MIDUA=IIDUA 50 : if(ktrace.eq.midua) then 51 : ktrace=-ktrace 52 : msorse='MIDUA' 53 : endif 54 : SEGSUP MIDUA 55 : MHARK=IHARK 56 : if(ktrace.eq.mhark) then 57 : ktrace=-ktrace 58 : msorse='MHARK' 59 : endif 60 : SEGSUP MHARK 61 : MIMIK=IIMIK 62 : if(ktrace.eq.mimik) then 63 : ktrace=-ktrace 64 : msorse='MIMIK' 65 : endif 66 : SEGSUP MIMIK 67 : MDNOR=IDNORM 68 : if(ktrace.eq.mdnor) then 69 : ktrace=-ktrace 70 : msorse='MDNOR' 71 : endif 72 : SEGSUP MDNOR 73 : MILIGN=IILIGN 74 : SEGACT MILIGN 75 : INC=ILIGN(/1) 76 : DO 1 I=1,INC 77 : LIGN=ILIGN(I) 78 : if(ktrace.eq.lign) then 79 : ktrace=-ktrace 80 : msorse='LIGN' 81 : endif 82 : SEGSUP LIGN 83 : 1 CONTINUE 84 : if(ktrace.eq.milign) then 85 : ktrace=-ktrace 86 : msorse='MILIGN' 87 : endif 88 : SEGSUP MILIGN 89 : if(ktrace.eq.mmatri) then 90 : ktrace=-ktrace 91 : msorse='MMATRI' 92 : endif 93 : SEGSUP MMATRI 94 : C 95 : C **** DESTRUCTION DU CHAPEAU 96 : 2 CONTINUE 97 : C 98 : CCCCCCCCCCCCC SI ON MIS DETRUIRE ELEM ON DETRUIT AUSSI LES RIGI 99 : C ELEMENTAIRES 100 : IF(IMGEO1.NE.0) THEN 101 : IMGEOD=IMGEO1 102 : if(ktrace.eq.imgeo1) then 103 : ktrace=-ktrace 104 : msorse='IMGEOD' 105 : endif 106 : SEGSUP IMGEOD 107 : ENDIF 108 : IF(ivecri.ne.0) then 109 : mvecri=ivecri 110 : segsup mvecri 111 : if(ktrace.eq.ivecri) then 112 : ktrace=-ktrace 113 : msorse='IVECRI' 114 : endif 115 : ENDIF 115 : IF(IDET.EQ.1) CALL DERIGI(IRET,KTRACE,MSORSE) 116 : IF(IDET.EQ.0) THEN 117 : if(ktrace.eq.mrigid) then 118 : ktrace=-ktrace 119 : msorse='MRIGID' 120 : endif 121 : SEGSUP MRIGID 122 : ENDIF 123 : IRET=0 124 : RETURN 125 : END 126 : 127 : 128 : 129 : 130 : 131 : 132 : 133 : 134 : 135 : 136 : 137 : 138 : 139 : 140 : 141 :
© Cast3M 2003 - All rights reserved.
Disclaimer