1 : C XTY1 SOURCE CHAT 05/01/13 04:15:43 5004 2 : subroutine xty1(mchpot,ich2,mlmotx,mlmoty,xret) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : -INC CCOPTIO 6 : -INC SMCHPOI 7 : -INC SMLMOTS 8 : -INC SMELEME 9 : -INC SMCOORD 10 : segment itrav 11 : * izon : num de zone dans 2 chp d'un point 12 : * ipos : num de pt dans zone d'un point 13 : * 14 : integer izon(nbpts),ipos(nbpts) 15 : * 16 : * nbop : nb de terme dans produit 1-zonei 2-zonej 17 : * 18 : integer nbop(nbz1,nbz2) 19 : * 20 : * icpos1 icpos2 : num composante zone a traiter 21 : * 22 : integer icpos1(nbopma,nbz1,nbz2),icpos2(nbopma,nbz1,nbz2) 23 : * 24 : endsegment 25 : * 26 : xret=0.d0 27 : * 28 : * creation de itrav 29 : * 30 : nbpts=xcoor(/1)/(idim+1) 31 : mlmot1=mlmotx 32 : segact mlmot1 33 : nbopma=mlmot1.mots(/2) 34 : mlmot2=mlmoty 35 : segact mlmot2 35 : if (nbopma.ne.mlmot2.mots(/2)) call erreur(217) 36 : if (ierr.ne.0) return 37 : mchpo1=mchpot 38 : segact mchpo1 39 : nbz1=mchpo1.ipchp(/1) 40 : mchpo2=ich2 41 : segact mchpo2 42 : nbz2=mchpo2.ipchp(/1) 43 : segini itrav 44 : * 45 : * remplissage de itrav a partir du deuxieme champ 46 : * 47 : do 10 isoupo=1,nbz2 48 : msoup2=mchpo2.ipchp(isoupo) 49 : segact msoup2 50 : mpova2=msoup2.ipoval 51 : segact mpova2 52 : ipt2=msoup2.igeoc 53 : segact ipt2 54 : do 15 iel=1,ipt2.num(/2) 55 : ip=ipt2.num(1,iel) 56 : izon(ip)=isoupo 57 : ipos(ip)=iel 58 : 15 continue 59 : 10 continue 60 : * 61 : * travail effectif : boucle su r le premier chpoint 62 : * on fabriquera au vol les nbop icpos1 et icpos2 si necessaire 63 : * 64 : do 20 isoupo=1,nbz1 65 : msoup1=mchpo1.ipchp(isoupo) 66 : segact msoup1 67 : mpova1=msoup1.ipoval 68 : segact mpova1 69 : ipt1=msoup1.igeoc 70 : segact ipt1 71 : ieldin=1 72 : 100 continue 73 : do 110 ieldeb=ieldin,ipt1.num(/2) 74 : izocou=izon(ipt1.num(1,ieldeb)) 75 : if(izocou.ne.0) goto 115 76 : 110 continue 77 : goto 20 78 : 115 continue 79 : msoup2=mchpo2.ipchp(izocou) 80 : if (nbop(isoupo,izocou).eq.0) then 81 : do 30 im=1,nbopma 82 : do 35 ic1=1,msoup1.nocomp(/2) 83 : if (mlmot1.mots(im).eq.msoup1.nocomp(ic1)) goto 40 84 : 35 continue 85 : goto 30 86 : 40 continue 87 : do 45 ic2=1,msoup2.nocomp(/2) 88 : if (msoup1.noharm(ic1).ne.msoup2.noharm(ic2)) goto 45 89 : if (mlmot2.mots(im).eq.msoup2.nocomp(ic2)) goto 50 90 : 45 continue 91 : goto 30 92 : 50 continue 93 : nbo=nbop(isoupo,izocou)+1 94 : nbop(isoupo,izocou)=nbo 95 : icpos1(nbo,isoupo,izocou)=ic1 96 : icpos2(nbo,isoupo,izocou)=ic2 97 : 30 continue 98 : 31 continue 99 : if (nbo.eq.0) nbop(isoupo,izocou)=-1 100 : endif 101 : do 60 ielcou=ieldeb+1,ipt1.num(/2) 102 : ipt=ipt1.num(1,ielcou) 103 : izon2=izon(ipt) 104 : if (izon2.ne.izocou) goto 70 105 : 60 continue 106 : ielcou=ipt1.num(/2)+1 107 : 70 continue 108 : mpova2=msoup2.ipoval 109 : do 80 ic=1,nbop(isoupo,izocou) 110 : ic1=icpos1(ic,isoupo,izocou) 111 : ic2=icpos2(ic,isoupo,izocou) 112 : do 90 iel=ieldeb,ielcou-1 113 : xret=xret+mpova1.vpocha(iel,ic1)* 114 : > mpova2.vpocha(ipos(ipt1.num(1,iel)),ic2) 115 : 90 continue 116 : 80 continue 117 : ieldin=ielcou 118 : if (ieldin.le.ipt1.num(/2)) goto 100 119 : segdes msoup1,mpova1,ipt1 120 : 20 continue 121 : * c'est fini on nettoie 122 : segsup itrav 123 : if (mchpo1.ne.mchpo2) then 124 : do 150 isoupo=1,nbz2 125 : msoup2=mchpo2.ipchp(isoupo) 126 : mpova2=msoup2.ipoval 127 : segdes mpova2 128 : ipt2=msoup2.igeoc 129 : segdes ipt2 130 : segdes msoup2 131 : 150 continue 132 : endif 133 : segdes mchpo1,mchpo2,mlmot1,mlmot2 134 : return 135 : end 136 :
© Cast3M 2003 - All rights reserved.
Disclaimer