1 : C DTSUPZ SOURCE PV 11/03/08 21:15:29 6888 2 : SUBROUTINE DTSUPz(IRET,ktrace,msorse) 3 : C **** DESTRUCTION APPROXIMATIVE D'UN SUPER-ELEMENT 4 : IMPLICIT INTEGER(I-N) 5 : -INC SMSUPER 6 : -INC SMELEME 7 : -INC SMMATRI 8 : -INC CCOPTIO 9 : -INC TMCOLAC 10 : character*6 msorse MSUPER=IRET 11 : MSUPER=IRET 12 : SEGACT MSUPER 13 : C 14 : IAUX=MRIGTO 14 : CALL DTRIGZ(IAUX,ktrace,msorse) 15 : C 16 : IAUX=MSURAI 16 : CALL DTRIGZ(IAUX,ktrace,msorse) 17 : C 18 : MELEME=MSUPEL 19 : if( ktrace.eq.meleme) then 20 : ktrace=-ktrace 21 : msorse='MELEME' 22 : endif 23 : SEGSUP MELEME 24 : IF(IPSAUV.NE.0) THEN 25 : ICOLAC = IPSAUV 26 : SEGACT ICOLAC 27 : ILISSE=ILISSG 28 : SEGACT ILISSE*MOD 28 : CALL TYPFIL('MAILLAGE',ICO) 29 : ITLACC = KCOLA(ICO) 30 : SEGACT ITLACC*MOD 30 : CALL AJOUN0(ITLACC,MELEME,ILISSE,1) 30 : CALL TYPFIL('RIGIDITE',ICO) 31 : ITLACC = KCOLA(ICO) 32 : SEGACT ITLACC*MOD 33 : IAUX=MSURAI 33 : CALL AJOUN0(ITLACC,IAUX,ILISSE,1) 34 : IAUX=MRIGTO 34 : CALL AJOUN0(ITLACC,IAUX,ILISSE,1) 35 : SEGDES ITLACC 36 : SEGDES ICOLAC,ILISSE 37 : ENDIF 38 : C 39 : MMATRI=MCROUT 40 : SEGACT MMATRI 41 : MDIAG=IDIAG 42 : if( ktrace.eq.mdiag) then 43 : ktrace=-ktrace 44 : msorse='MDNOR' 45 : endif 46 : SEGSUP MDIAG 47 : MELEME=IGEOMA 48 : if( ktrace.eq.meleme) then 49 : ktrace=-ktrace 50 : msorse='MELEME' 51 : endif 52 : SEGSUP MELEME 53 : IF(IPSAUV.NE.0) THEN 54 : ICOLAC = IPSAUV 55 : SEGACT ICOLAC 56 : ILISSE=ILISSG 57 : SEGACT ILISSE*MOD 57 : CALL TYPFIL('MAILLAGE',ICO) 58 : ITLACC = KCOLA(ICO) 59 : SEGACT ITLACC*MOD 59 : CALL AJOUN0(ITLACC,MELEME,ILISSE,1) 60 : SEGDES ITLACC 61 : SEGDES ICOLAC,ILISSE 62 : ENDIF 63 : MINCPO=IINCPO 64 : if( ktrace.eq.mincpo) then 65 : ktrace=-ktrace 66 : msorse='MINCPO' 67 : endif 68 : SEGSUP MINCPO 69 : MIDUA=IIDUA 70 : if( ktrace.eq.midua) then 71 : ktrace=-ktrace 72 : msorse='MIDUA' 73 : endif 74 : SEGSUP MIDUA 75 : MHARK=IHARK 76 : if( ktrace.eq.mhark) then 77 : ktrace=-ktrace 78 : msorse='MHARK' 79 : endif 80 : SEGSUP MHARK 81 : MIMIK=IIMIK 82 : if( ktrace.eq.mimik) then 83 : ktrace=-ktrace 84 : msorse='MIMIK' 85 : endif 86 : SEGSUP MIMIK 87 : MDNOR=IDNORM 88 : if( ktrace.eq.mdnor) then 89 : ktrace=-ktrace 90 : msorse='MDNOR' 91 : endif 92 : SEGSUP MDNOR 93 : MILIGN=IILIGN 94 : SEGACT MILIGN 95 : INC=ILIGN(/1) 96 : DO 1 I=1,INC 97 : LIGN=ILIGN(I) 98 : if( ktrace.eq.lign) then 99 : ktrace=-ktrace 100 : msorse='LIGN' 101 : endif 102 : SEGSUP LIGN 103 : 1 CONTINUE 104 : if( ktrace.eq.milign) then 105 : ktrace=-ktrace 106 : msorse='MILIGN' 107 : endif 108 : SEGSUP MILIGN 109 : if( ktrace.eq.mmatri) then 110 : ktrace=-ktrace 111 : msorse='MMATRI' 112 : endif 113 : SEGSUP MMATRI 114 : IF(IPSAUV.NE.0) THEN 115 : ICOLAC = IPSAUV 116 : SEGACT ICOLAC 117 : ILISSE=ILISSG 118 : SEGACT ILISSE*MOD 118 : CALL TYPFIL('IMATRI ',ICO) 119 : ITLACC = KCOLA(ICO) 120 : SEGACT ITLACC*MOD 120 : CALL AJOUN0(ITLACC,MMATRI,ILISSE,1) 121 : SEGDES ITLACC 122 : SEGDES ICOLAC,ILISSE 123 : ENDIF 124 : C 125 : if( ktrace.eq.msuper) then 126 : ktrace=-ktrace 127 : msorse='MSUPER' 128 : endif 129 : SEGSUP MSUPER 130 : RETURN 131 : END 132 : 133 : 134 : 135 : 136 : 137 : 138 : 139 : 140 : 141 : 142 : 143 : 144 : 145 :
© Cast3M 2003 - All rights reserved.
Disclaimer