1 : C CHLEHA SOURCE PV 13/04/16 21:15:11 7765 2 : * 3 : * appele dans menage: elimination des meleme dupliques 4 : * 5 : subroutine chleha(ifonc,mele,mels,itab) 6 : -INC SMELEME 7 : data ih1,ih2,ih3/0,0,0/ 8 : save ih1,ih2,ih3,nbmelr 9 : segment itab(0) 10 : segment ih1(nbmel) 11 : segment ih2(nbmel) 12 : segment ih3(nbmel) 13 : * 14 : * ifonc = 1 initialisation des structures 15 : if (ifonc.eq.1) then 16 : nbmel=100 17 : segini ih1,ih2,ih3 18 : nbmelr=0 19 : return 20 : * ifonc = 2 suppression des structures 21 : elseif (ifonc.eq.2) then 22 : if (ih1.ne.0) segsup ih1,ih2,ih3 23 : ih1=0 24 : ih2=0 25 : ih3=0 26 : return 27 : endif 28 : * test si fontion activee 29 : mels = 0 30 : if (ih1.eq.0) then 31 : return 32 : endif 33 : * 34 : * mise a jour des hashcodes des segments de itab 35 : * 36 : if (nbmel.lt.itab(/1)) then 37 : nbmel = itab(/1)+100 38 : segadj ih1,ih2,ih3 39 : endif 40 : * write (6,*) ' nbmelr itab ',nbmelr,itab(/1) 41 : do 10 iel=nbmelr+1,itab(/1) 42 : meleme=itab(iel) 43 : if (meleme.eq.0) goto 10 44 : segact meleme 45 : * ne tester que les supports des chpts 46 : if (num(/1).ne.1) goto 10 47 : do i=lisous(/1) 48 : do il=1,num(/2) 49 : do in=1,num(/1) 50 : ipos=in+num(/1)*(il-1) 51 : if (mod(ipos,3).eq.0) ih1(iel) = ih1(iel)+num(in,il) 52 : if (mod(ipos,3).eq.1) ih2(iel) = ih2(iel)+num(in,il) 53 : if (mod(ipos,3).eq.2) ih3(iel) = ih3(iel)+num(in,il) 54 : enddo 55 : enddo 56 : 10 continue 57 : nbmelr = itab(/1) 58 : * 59 : * verication identite avec mele 60 : * 61 : mels = 0 62 : meleme = mele 63 : segact meleme 64 : if (num(/1).ne.1) goto 150 65 : mh1=0 66 : mh2=0 67 : mh3=0 68 : do il=1,num(/2) 69 : do in=1,num(/1) 70 : ipos=in+num(/1)*(il-1) 71 : if (mod(ipos,3).eq.0) mh1 = mh1+num(in,il) 72 : if (mod(ipos,3).eq.1) mh2 = mh2+num(in,il) 73 : if (mod(ipos,3).eq.2) mh3 = mh3+num(in,il) 74 : enddo 75 : enddo 76 : * write (6,*) ' mh1 mh2 mh3 ',mh1,mh2,mh3 77 : * 78 : do 100 i = 1,nbmelr 79 : if (mele.eq.itab(i)) goto 150 80 : if (mh1.ne.ih1(i)) goto 100 81 : if (mh2.ne.ih2(i)) goto 100 82 : if (mh3.ne.ih3(i)) goto 100 83 : * hash identiques verification complete 84 : ipt1 = itab(i) 85 : segact ipt1 86 : if (itypel.ne.ipt1.itypel) goto 100 87 : if (lisous(/1).ne.ipt1.lisous(/1)) goto 100 88 : do j=1,lisous(/1) 89 : if (lisous(j).ne.ipt1.lisous(j)) goto 100 90 : enddo 91 : if (lisref(/1).ne.ipt1.lisref(/1)) goto 100 92 : do j=1,lisref(/1) 93 : if (lisref(j).ne.ipt1.lisref(j)) goto 100 94 : enddo 95 : if (lisref(/1).ne.ipt1.lisref(/1)) goto 100 96 : * do j=1,lisref(/1) 97 : * if (lisref(j).ne.ipt1.lisref(j)) goto 100 98 : * enddo 99 : if (icolor(/1).ne.ipt1.icolor(/1)) goto 100 100 : do j=1,icolor(/1) 101 : if (icolor(j).ne.ipt1.icolor(j)) goto 100 102 : enddo 103 : if (num(/1).ne.ipt1.num(/1)) goto 100 104 : if (num(/2).ne.ipt1.num(/2)) goto 100 105 : do k=1,num(/2) 106 : do j=1,num(/1) 107 : if (num(j,k).ne.ipt1.num(j,k)) goto 100 108 : enddo 109 : enddo 110 : ** write (6,*) ' maillages identiques trouves',mele,itab(i), 111 : ** > num(/1),num(/2) 112 : 113 : 114 : * maillages identiques! 115 : mels = itab(i) 116 : goto 150 117 : 100 continue 118 : 150 continue 119 : return 120 : end 121 : 122 :
© Cast3M 2003 - All rights reserved.
Disclaimer