Sources Esope | Cast3M

xty1
C XTY1      SOURCE    CB215821  20/11/25    13:43:35     10792          
      subroutine xty1(mchpot,ich2,mlmotx,mlmoty,xret)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      INTEGER NBO
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMLMOTS
-INC SMELEME
-INC SMCOORD
      segment itrav
*  izon : num de zone dans 2 chp d'un point
*  ipos : num de pt   dans zone  d'un point
*
       integer izon(nbpts),ipos(nbpts)
*
*  nbop : nb de terme dans produit 1-zonei 2-zonej
*
       integer nbop(nbz1,nbz2)
*
*  icpos1 icpos2 : num composante zone   a traiter
*
       integer icpos1(nbopma,nbz1,nbz2),icpos2(nbopma,nbz1,nbz2)
*
      endsegment
*
      NBO=0
      xret=0.d0
*
*  creation de itrav
*
      mlmot1=mlmotx
      segact mlmot1
      nbopma=mlmot1.mots(/2)
      mlmot2=mlmoty
      segact mlmot2
      if (nbopma.ne.mlmot2.mots(/2)) call erreur(217)
      if (ierr.ne.0) return
      mchpo1=mchpot
      segact mchpo1
      nbz1=mchpo1.ipchp(/1)
      mchpo2=ich2
      segact mchpo2
      nbz2=mchpo2.ipchp(/1)
      segini itrav
*
*  remplissage de itrav a partir du deuxieme champ
*
      do 10 isoupo=1,nbz2
       msoup2=mchpo2.ipchp(isoupo)
       segact msoup2
       mpova2=msoup2.ipoval
       segact mpova2
       ipt2=msoup2.igeoc
       segact ipt2
       do 15 iel=1,ipt2.num(/2)
        ip=ipt2.num(1,iel)
        izon(ip)=isoupo
        ipos(ip)=iel
  15   continue
  10  continue
*
*  travail effectif : boucle su r le premier chpoint
*  on fabriquera au vol les nbop icpos1 et icpos2 si necessaire
*
      do 20 isoupo=1,nbz1
       msoup1=mchpo1.ipchp(isoupo)
       segact msoup1
       mpova1=msoup1.ipoval
       segact mpova1
       ipt1=msoup1.igeoc
       segact ipt1
       ieldin=1
 100   continue
       do 110 ieldeb=ieldin,ipt1.num(/2)
         izocou=izon(ipt1.num(1,ieldeb))
         if(izocou.ne.0) goto 115
 110   continue
       goto 20
 115   continue
       msoup2=mchpo2.ipchp(izocou)
       if (nbop(isoupo,izocou).eq.0) then
         do 30 im=1,nbopma
           do 35 ic1=1,msoup1.nocomp(/2)
              if (mlmot1.mots(im).eq.msoup1.nocomp(ic1)) goto 40
  35       continue
           goto 30
  40       continue
           do 45 ic2=1,msoup2.nocomp(/2)
             if (msoup1.noharm(ic1).ne.msoup2.noharm(ic2)) goto 45
             if (mlmot2.mots(im).eq.msoup2.nocomp(ic2)) goto 50
  45       continue
           goto 30
  50       continue
           nbo=nbop(isoupo,izocou)+1
           nbop(isoupo,izocou)=nbo
           icpos1(nbo,isoupo,izocou)=ic1
           icpos2(nbo,isoupo,izocou)=ic2
  30     continue
         if (nbo.eq.0) nbop(isoupo,izocou)=-1
       endif
       do 60 ielcou=ieldeb+1,ipt1.num(/2)
         ipt=ipt1.num(1,ielcou)
         izon2=izon(ipt)
         if (izon2.ne.izocou) goto 70
  60   continue
       ielcou=ipt1.num(/2)+1
  70   continue
       mpova2=msoup2.ipoval
       do 80 ic=1,nbop(isoupo,izocou)
         ic1=icpos1(ic,isoupo,izocou)
         ic2=icpos2(ic,isoupo,izocou)
         do 90 iel=ieldeb,ielcou-1
           xret=xret+mpova1.vpocha(iel,ic1)*
     >               mpova2.vpocha(ipos(ipt1.num(1,iel)),ic2)
  90     continue
  80   continue
       ieldin=ielcou
       if (ieldin.le.ipt1.num(/2)) goto 100
  20  continue
*  c'est fini on nettoie
      segsup itrav
      if (mchpo1.ne.mchpo2) then
      do 150 isoupo=1,nbz2
        msoup2=mchpo2.ipchp(isoupo)
        mpova2=msoup2.ipoval
        ipt2=msoup2.igeoc
 150  continue
      endif
      end