1 : C PROBAS SOURCE CHAT 09/10/09 21:21:54 6519 2 : SUBROUTINE PROBAS(IRIIN,itmod,IRIOUT) 3 : IMPLICIT REAL*8(a-h,o-z) 4 : IMPLICIT INTEGER(I-N) 5 : CHARACTER*4 motinc,motddl 6 : -INC SMCOORD 7 : -INC CCOPTIO 8 : -INC SMTABLE 9 : -INC SMRIGID 10 : -INC SMELEME 11 : segment icpr(xcoor(/1)/(idim + 1)) 12 : 13 : MRIGID = IRIIN 14 : mtable = itmod 15 : segact mtable 16 : im1 = mlotab 17 : ima = mlotab - 1 18 : * pour chaque noeud implique dans une liason on fait intervenir toutes 19 : * les solutions statiques associées 20 : * 21 : * on les recense donc 22 : segini icpr 23 : do im = 1,ima 23 : CALL ACCTAB(ITMOD,'ENTIER',IM,X0,' ',.true.,IP0, 24 : & 'TABLE',I1,X1,' ',.true.,ITAB2) 24 : CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_LIAISON',.true.,IP0, 25 : & 'POINT',I1,X1,' ',.true.,IPL1) 26 : icpr(ipl1) = icpr(ipl1) + 1 27 : enddo 28 : 29 : KRIGEL = 0 30 : segact mrigid 31 : nrigel = irigel(/2) 32 : nrige = irigel(/1) 33 : segini ri1 34 : ri1.mtymat = mtymat 35 : nrige0 = nrigel 36 : 37 : kige = 0 38 : nrigel = kige 39 : segini ri2 40 : ri2.mtymat = mtymat 41 : 42 : DO ire = 1,nrige0 43 : meleme = irigel (1,ire) 44 : segact meleme 45 : if (itypel.ne.22) then 45 : call erreur(977) 46 : return 47 : endif 48 : nbelem = num(/2) 49 : nbele0 = nbelem 50 : descr = irigel(3,ire) 51 : segact descr 52 : nligrp0 = noelep(/1) 53 : nligrd0 = noeled(/1) 54 : nligrp = nligrp0 55 : nligrd = nligrp 56 : segini des1 57 : des1.lisinc(1) = 'LX' 58 : des1.lisdua(1) = 'FLX' 59 : des1.noelep(1) = 1 60 : des1.noeled(1) = 1 61 : do ig =2,nligrp 62 : des1.lisinc(ig) = 'BETA' 63 : des1.lisdua(ig) = 'FBET' 64 : des1.noelep(ig) = ig 65 : des1.noeled(ig) = ig 66 : enddo 67 : segini,des2=des1 68 : 69 : nbnn = nligrp0 70 : nbsous = 0 71 : nbref = 0 72 : segini ipt2 73 : ipt2.itypel = itypel 74 : nbelem = 1 75 : segini ipt1 76 : ipt1.itypel = itypel 77 : ri1.coerig(ire) = coerig(ire) 78 : kele = 0 79 : 80 : DO iele = 1,nbele0 81 : 82 : * le premier point correspond aux multiplicateurs 82 : CALL CREPO1 (ZERO, ZERO, ZERO, IPTS) 83 : ipt1.num(1,1) = ipts 84 : koel = 1 85 : do igrp = 2,nligrp0 86 : jno = noelep(igrp) 87 : motinc = lisinc(igrp) 88 : IP1 = num(jno,iele) 89 : do im = 1,ima 89 : CALL ACCTAB(ITMOD,'ENTIER',IM,X0,' ',.true.,IP0, 90 : & 'TABLE',I1,X1,' ',.true.,ITAB2) 90 : CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_LIAISON',.true.,IP0, 91 : & 'POINT',I1,X1,' ',.true.,IPL1) 91 : CALL ACCTAB(ITAB2,'MOT',I0,X0,'DDL_LIAISON',.true.,IP0, 92 : & 'MOT',I1,X1,motddl,.true.,I1) 93 : if (motinc.eq.motddl.and.IPL1.eq.IP1) then 93 : CALL ACCTAB(ITAB2,'MOT',I0,X0,'POINT_REPERE',.true.,IP0, 94 : & 'POINT',I1,X1,' ',.true.,IPTS) 95 : ipt1.num(igrp,1) = ipts 96 : koel = koel + 1 97 : goto 16 98 : endif 99 : enddo 100 : c point-liaison et ddl non trouvés 101 : ipt1.num(igrp,1) = ip1 102 : des2.lisinc(igrp) = lisinc(igrp) 103 : des2.lisdua(igrp) = lisdua(igrp) 104 : des2.noelep(igrp) = noelep(igrp) 105 : des2.noeled(igrp) = noeled(igrp) 106 : * 107 : 16 continue 108 : enddo 109 : * 110 : c creation d'un irigel 111 : if (koel.ne.nligrp0) then 111 : c call erreur(978) 112 : c return 113 : kige = kige + 1 114 : nrigel = kige 115 : segadj ri2 116 : segini,ipt3=ipt1 117 : segini,des3=des2 118 : RI2.IRIGEL(1,kige) = IPT3 119 : RI2.IRIGEL(3,kige) = DES3 120 : RI2.IRIGEL(4,kige) = irigel(4,ire) 121 : RI2.IRIGEL(2,kige) = 0 122 : RI2.IRIGEL(5,kige) = irigel(5,ire) 123 : RI2.IRIGEL(6,kige) = irigel(6,ire) 124 : ri2.coerig(kige) = coerig(ire) 125 : do ig =2,nligrp 126 : des2.lisinc(ig) = 'BETA' 127 : des2.lisdua(ig) = 'FBET' 128 : des2.noelep(ig) = ig 129 : des2.noeled(ig) = ig 130 : enddo 131 : else 132 : * toutes les inconnues sont des BETA 133 : kele = kele + 1 134 : do ig = 1,nligrp0 135 : ipt2.num(ig,kele) = ipt1.num(ig,1) 136 : enddo 137 : endif 138 : ENDDO 139 : 140 : nbelem = kele 141 : if (nbelem.gt.0) then 142 : segadj ipt2 143 : krigel = krigel + 1 144 : RI1.IRIGEL(1,krigel) = IPT2 145 : RI1.IRIGEL(3,krigel) = DES1 146 : RI1.IRIGEL(4,krigel) = irigel(4,ire) 147 : RI1.IRIGEL(2,krigel) = 0 148 : RI1.IRIGEL(5,krigel) = irigel(5,ire) 149 : RI1.IRIGEL(6,krigel) = irigel(6,ire) 150 : segdes des1, ipt2 151 : else 152 : segsup des1, ipt2 153 : endif 154 : segsup ipt1 155 : ENDDO 156 : 157 : iriout = 0 158 : nrigel = krigel 159 : segadj ri1 160 : c write(6,*) 'ri1', ri1.irigel(/2), ' ri2',ri2.irigel(/2) 161 : segdes mrigid,ri1,mtable,ri2 162 : if (kige.eq.0) segsup ri2 163 : if (krigel.eq.0) segsup ri1 164 : if (kige.gt.0.and.krigel.gt.0) then 165 : c write(6,*) 'fus', ri1,ri2,kige,krigel 165 : call fusrig(ri1,ri2,iriout) 166 : segsup ri1, ri2 167 : return 168 : endif 169 : if (kige.gt.0) iriout = ri2 170 : if (krigel.gt.0) iriout = ri1 170 : if (iriout.eq.0) call erreur(-5) 171 : return 172 : END 173 : 174 : 175 : 176 :
© Cast3M 2003 - All rights reserved.
Disclaimer