1 : C KRES6 SOURCE GOUNAND 11/10/07 21:15:54 7149 2 : SUBROUTINE KRES6(MRIGID,KSMBR,LDMULT, 3 : $ MRIGIC,KSMBRC,KSMBR1) 4 : * SUBROUTINE KRES6(MRIGID,KSMBR,IDEPE, 5 : * $ MRIGIC,KSMBRC,KSMBR0,KSMBR1) 6 : IMPLICIT REAL*8 (A-H,O-Z) 7 : IMPLICIT INTEGER (I-N) 8 : C*********************************************************************** 9 : C NOM : KRES6 10 : C DESCRIPTION : Effectue la condensation des relations 11 : C Repris de resou.eso 12 : C 13 : C 14 : C LANGAGE : ESOPE 15 : C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF) 16 : C mél : gounand@semt2.smts.cea.fr 17 : C*********************************************************************** 18 : C VERSION : v1, 15/06/2011, version initiale 19 : C HISTORIQUE : v1, 15/06/2011, création 20 : C HISTORIQUE : 21 : C HISTORIQUE : 22 : C*********************************************************************** 23 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 24 : C en cas de modification de ce sous-programme afin de faciliter 25 : C la maintenance ! 26 : C*********************************************************************** 27 : -INC CCOPTIO 28 : -INC SMRIGID 29 : -INC SMCHPOI 30 : -INC SMELEME 31 : * 32 : * Logique indiquant si on dualise les multiplicateurs de Lagrange 33 : LOGICAL LDMULT 34 : * 35 : NOUNIL=0 36 : NOEN=1 37 : IPOIRI=MRIGID 38 : * verification pas de blocage en double 38 : call verlag(ipoiri) 39 : if (ierr.ne.0) return 40 : * y a t il des matrices de relations non unilaterales 41 : ipoir0 = ipoiri 42 : mrigid=ipoiri 42 : C call prrigi(ipoiri,1) 43 : segact mrigid 44 : nrige= irigel(/1) 45 : idepe=0 46 : nbr = irigel(/2) 47 : do 1000 irig = 1,nbr 48 : meleme=irigel(1,irig) 49 : segact meleme 50 : if ((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22) 51 : > idepe=idepe+1 52 : if (irigel(6,irig).ne.0) iunil=1 53 : segdes meleme 54 : 1000 continue 55 : * idepe=0 56 : lagdua=0 57 : if(idepe.ne.0) then 58 : C on va separer les raideurs 59 : * write (6,*) ' nounil jrcond iunil idepe vaut ',nounil,jrcond, 60 : * $ iunil, idepe 61 : if (jrcond.eq.0) then 62 : if (ldmult) then 62 : call separm(mrigid,ri1,ri2,nounil,lagdua) 63 : else 63 : call separm(mrigid,ri1,ri2,nounil,-1) 64 : endif 65 : * if (lagdua.ne.0) then 66 : * write(6,*) ' resou apres separm -- lagdua' 66 : * call ecmail(lagdua) 67 : * else 68 : * write(6,*) ' resou apres separm -- lagdua=0' 69 : * endif 70 : * write(6,*) ' resou apres separm -- ri2' 70 : * call prrigi(ri2,1) 71 : * write(6,*) ' resou apres separm -- ri1' 71 : * call prrigi ( ri1,1) 72 : * write(6,*) ' fin impression ri1' 73 : segact mrigid*mod 74 : jrelim=ri1 75 : jrgard=ri2 76 : imlag=lagdua 76 : call fusrig(ri1,ri2,ipoir0) 77 : jrtot=ipoir0 78 : else 79 : ri1=jrelim 80 : ri2=jrgard 81 : ipoir0=jrtot 82 : lagdua=imlag 83 : ipt1=lagdua 84 : if (ipt1.ne.0) segact ipt1 85 : endif 86 : C 87 : * mrigid matrice complete 88 : * ri1 dependance 89 : * ri2 les autres matrices 90 : * ri6 matrice de transfert 91 : * ri3 matrice reduite 92 : * ri5 matrice de transfert transposee 93 : C 94 : C on va proceder a la condensation rigidite puis forces 95 : if(jrcond.eq.0) then 95 : CALL DEPEN3(RI1,RI6) 96 : * write (6,*) ' resou apres depen3 --- ri6 ' 96 : * call prrigi(ri6,1) 96 : call scnd2 (ri2,ri6,ri3) 97 : * write (6,*) ' ' 98 : * write (6,*) ' ' 99 : * write (6,*) ' resou apres scnd2--- ri3 ' 100 : * write (6,*) ' ' 100 : * call prrigi(ri3,1) 101 : segact ri3 102 : if(ierr.ne.0) then 103 : segsup ri1,ri2,ri6 104 : return 105 : endif 106 : 107 : segact mrigid*mod 108 : jrcond=ri3 109 : JRDEPP=RI6 110 : C dualisation de la (les) matrice(s) de dependance 110 : call dual00(ri6,ri5) 111 : * write(6,*) ' apres dual0 -- ri5' 111 : * call prrigi( ri5,1) 112 : jrdepd=ri5 113 : ipoiri = ri3 114 : else 115 : ipoiri= jrcond 116 : RI6 = JRDEPP 117 : ri5 = jrdepd 118 : endif 119 : * test si ri3 est vide 120 : ri3=jrcond 121 : segact ri3 122 : * write (6,*) ' dans resou ri3.irigel(/2) ',ri3.irigel(/2) 123 : if (ri3.irigel(/2).eq.0) imtvid=1 124 : C 125 : segdes ri1,ri2,mrigid 126 : mrigic=ipoiri 127 : C maintenant les seconds membres 128 : C write(6,*) ' ipoiri jrdepp jrdepd',ipoiri,ri6,ri5 128 : C call prrigi(ri3) 128 : C call prrigi(ri5) 129 : * en cas de contacts on ne dualise pas . Ce sera fait dans unilater 130 : ifrot=0 131 : MRIGID=IPOIRI 132 : SEGACT MRIGID*MOD 133 : DO I=1,IRIGEL(/2) 134 : IF(IRIGEL(6,I).ne.0) ifrot=1 135 : enddo 136 : if (nounil.eq.1) ifrot=0 137 : * if (ifrot.eq.0) write (6,*) ' resou non unilateral ' 138 : * if (ifrot.eq.1) write (6,*) ' resou unilateral pas de dualisation' 139 : if (lagdua.ne.0) then 140 : ipt8=lagdua 141 : segact ipt8 141 : * call ecmail(lagdua,0) 142 : endif 143 : * 144 : ichp2=ksmbr 145 : * ksmbr0=ichp2 146 : * transferer les valeurs imposees des relations sur les inconnues (à éliminer 147 : C ) 148 : * write (6,*) ' valeurs imposees ichp2' 148 : * call ecchpo(ichp2,0) 148 : call transr(ichp2,ri1,ichp3) 148 : * call prrigi(ri1) 149 : * write (6,*) ' apres transfert ichp3' 149 : * call ecchpo(ichp3,0) 150 : ksmbr1=ichp3 150 : call mucpri(ichp3,ri2,ichp4) 151 : * write (6,*) ' apres mucpri ichp4 ' 151 : * call ecchpo(ichp4,0) 152 : * ri2 est deja dualise. Il faut donc dedualiser ichp4 152 : call dbbcd(ichp4,lagdua) 153 : * write (6,*) ' apres dbbcd ichp4 ' 153 : * call ecchpo(ichp4,0) 153 : call adchpo(ichp2,ichp4,ichp1,1.D0,-1.0D0) 153 : call dtchpo(ichp4) 154 : * write (6,*) ' apres adchpo ichp1' 154 : * call ecchpo(ichp1,0) 154 : call mucpri(ichp1,ri5,ichp2) 155 : * write (6,*) ' impression de ri5 ' 155 : * call prrigi(ri5,1) 156 : * write (6,*) ' apres mucpri ichp2' 156 : * call ecchpo(ichp2,0) 157 : C mchpo1=ichp1 158 : C segact mchpo1 159 : C write(6,*) 'reso mchpo1 jattri(1)',mchpo1.jattri(1) 160 : C segdes mchpo1 161 : C 162 : mchpo2= ichp1 163 : segact mchpo2*mod 164 : mchpo2.jattri(1)=2 165 : mchpo2= ichp2 166 : segact mchpo2*mod 167 : mchpo2.jattri(1)=2 168 : C write(6,*) 'reso mchpo2 jattri(1)',mchpo2.jattri(1) 169 : segdes mchpo2 170 : C 170 : call fuchpo (ichp1,ichp2,ichp3) 170 : * call dtchpo(ichp1) 170 : call dtchpo(ichp2) 171 : ksmbrc=ichp3 172 : * vecteur a resoudre 173 : * write (6,*) ' le vecteur ' 173 : * call ecchpo(ichp3,0) 174 : * dualisation des mult de lagrange 174 : if (lagdua.ne.0.and.ifrot.eq.0) call dbbch(ichp3,lagdua) 175 : * matrice 176 : * write (6,*) ' la matrice ' 176 : * call prrigi(ipoiri) 177 : noid = 1 178 : else 179 : mrigic=mrigid 180 : ksmbrc=ksmbr 181 : ksmbr1=0 182 : endif 183 : 184 : 185 : 186 : RETURN 187 : * 188 : * End of subroutine KRES6 189 : * 190 : END 191 : 192 : 193 : 194 :
© Cast3M 2003 - All rights reserved.
Disclaimer