1 : C COMAIL SOURCE PV 09/03/12 21:17:20 6325 2 : SUBROUTINE COMAIL(iq1,iq2,ielin,ielout,icorre) 3 : * pour 2 meleme de meme type construit un melval en allant piocher 4 : * dans le melval initial si les elements sont les memes 5 : * 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL*8(A-H,O-Z) 8 : -INC CCOPTIO 9 : -INC SMELEME 10 : -INC SMCHAML 11 : -INC SMLENTI 12 : -INC SMCOORD 13 : 14 : segment ipos(xcoor(/1)/(idim+1)+1) 15 : segment ind(mm) 16 : segment icorre 17 : integer mel2(nmel1),icor(nmel1),idej 18 : endsegment 19 : logical iperm 20 : * 21 : * 22 : meleme=iq1 23 : ipt1=iq2 24 : ielout=0 25 : nbsous1 = ipt1.lisous(/1) 26 : nbnn = num(/1) 27 : nbnn1 = ipt1.num(/1) 28 : if (nbsous1.ne.0.OR.nbnn1.ne.nbnn) then 29 : * pas normal 30 : moterr(1:8) ='COMAIL' 31 : interr(1) = 1 31 : call erreur(-329) 32 : return 33 : endif 34 : do iou=1,idej 35 : if(ipt1.eq.mel2(iou)) then 36 : if(icor(iou).eq.0) then 37 : return 38 : else 39 : mlenti=icor(iou) 40 : segact mlenti 41 : go to 100 42 : endif 43 : endif 44 : enddo 45 : * on dimensionne au nombre d elements du meleme 46 : jg= num(/2) 47 : segini mlenti 48 : * travail preparatoire 49 : segini ipos 50 : np=ipos(/1)-1 51 : do 10 i=1,num(/2) 52 : do 11 j=1,num(/1) 53 : ia=num(j,i) 54 : ipos(ia)=ipos(ia)+1 55 : 11 continue 56 : 10 continue 57 : * on initialise ipos 58 : do 13 i=2,np 59 : ipos(i)=ipos(i-1)+ipos(i) 60 : 13 continue 61 : ipos(np+1)=ipos(np) 62 : * remplissage de ind 63 : mm=ipos(np) 64 : segini ind 65 : do 20 i=1,num(/2) 66 : do 21 j=1,num(/1) 67 : ia=num(j,i) 68 : ide=ipos(ia) 69 : ind(ide)=i 70 : ipos(ia)=ipos(ia)-1 71 : 21 continue 72 : 20 continue 73 : * fin du travail preparatoire 74 : 75 : C on fabrique le mlenti de correspondance 76 : ibon=0 77 : do 15 iel1=1,ipt1.num(/2) 78 : ia= ipt1.num(1,iel1) 79 : ideb=ipos(ia)+1 80 : ifin=ipos(ia+1) 81 : if(ifin.lt.ideb) go to 15 82 : do 16 ie=ideb,ifin 83 : iel=ind(ie) 84 : do inn=1,nbnn 85 : if(num(inn,iel).ne.ipt1.num(inn,iel1))go to 16 86 : enddo 87 : ibon=1 88 : lect(iel)=iel1 89 : go to 15 90 : 16 continue 91 : 15 continue 92 : segsup ind,ipos 93 : idej=idej+1 94 : if(idej.gt.mel2(/1)) then 95 : nmel1=mel2(/1)+50 96 : segadj icorre 97 : endif 98 : mel2(idej)=ipt1 99 : if(ibon.eq.0) then 100 : return 101 : endif 102 : icor(idej)=mlenti 103 : 100 continue 104 : melva1 = ielin 105 : segact melva1 106 : n1ptel = melva1.velche(/1) 107 : n1el = num(/2) 108 : n2ptel = melva1.ielche(/1) 109 : n2el = num(/2) 110 : segini melval 111 : 112 : do ielem=1,num(/2) 113 : iel1=lect(ielem) 114 : if (n2ptel.eq.0.and.n2el.eq.0) then 115 : do iptel = 1, n1ptel 116 : velche(iptel,ielem) = melva1.velche(iptel,iel1) 117 : enddo 118 : elseif (n1ptel.eq.0.and.n1el.eq.0) then 119 : do iptel = 1,n2ptel 120 : ielche(iptel,ielem) = melva1.ielche(iptel,iel1) 121 : enddo 122 : endif 123 : enddo 124 : segdes melval,melva1 125 : ielout=melval 126 : RETURN 127 : END 128 : 129 : 130 : 131 : 132 :
© Cast3M 2003 - All rights reserved.
Disclaimer