Télécharger la plaquette Cast3M


fr en

Télécharger verlag.eso

Retour à la liste

Numérotation des lignes : 

verlag

  1. C VERLAG    SOURCE    MB234859  25/07/21    21:15:04     12330          
  2.         subroutine verlag(mrigid)
  3. *  verification que les noeuds supports des LX n'aparaissent
  4. *  qu'une seule fois
  5. *  si ce n'est pas le cas et si c'est le meme descr, fusion des raideurs elementaires
  6.       IMPLICIT INTEGER(I-N)
  7.         IMPLICIT REAL*8(A-H,O-Z)
  8. -INC SMRIGID
  9. -INC PPARAM
  10. -INC CCOPTIO
  11. -INC SMCHPOI
  12. -INC SMCOORD
  13. -INC SMELEME
  14. *  tableau de compression general
  15.       segment ncpr(nbpts)
  16. *  tableau ir par lx
  17.       segment lxir(nbpt)
  18. *  tableau elem par lx
  19.       segment lxel(nbpt)
  20. *  tableau descripteur par lx
  21.       segment lxde(nbpt)
  22. *
  23.       segini ncpr
  24.       nbpt=0
  25.       segact mrigid
  26.       do irig=1,irigel(/2)
  27.         meleme=irigel(1,irig)
  28.         segact meleme
  29.         if (itypel.eq.22) then
  30.           do iel=1,num(/2)
  31.             ipt=num(1,iel)
  32.             if (ncpr(ipt).eq.0) then
  33.               nbpt=nbpt+1
  34.               ncpr(num(1,iel))=nbpt
  35.             endif
  36.           enddo
  37.         endif
  38.       enddo
  39. *
  40.       segini lxir,lxel,lxde
  41.       nrigel=0
  42.       segini ri1
  43.       ri1.mtymat = 'VERLAG'
  44.       ri1.iforig = mrigid.iforig
  45.       do ir=1,irigel(/2)
  46.         meleme=irigel(1,ir)
  47.         descr =irigel(3,ir)
  48.         xmatri=irigel(4,ir)
  49. **      write(6,*) ' verlag ir meleme xmatri',ir,meleme,xmatri
  50.         segact,descr,xmatri
  51.         if(itypel.eq.22) then
  52.           do iel=1,num(/2)
  53.             lx=ncpr(num(1,iel))
  54.             if (lxir(lx).eq.0) then
  55.               lxir(lx)=ir
  56.               lxel(lx)=iel
  57.               lxde(lx)=descr
  58. *             write(6,*) 'premier passage ',iel,lx,lxir(lx),lxel(lx)
  59.             else
  60. C             LX deja rencontre, faut-il fusionner?
  61. C
  62. C             Les matrices a fusionner doivent avoir des types differents
  63.               xmatr1=irigel(4,lxir(lx))
  64.               if (xmatri.symre.eq.xmatr1.symre) goto 14
  65. C
  66. C             S'agit-il des memes descripteurs
  67.               des3=lxde(lx)
  68.               if (des3.eq.descr) goto 13
  69.               nligrd0=descr.noeled(/1)
  70.               if (nligrd0.ne.des3.noeled(/1)) goto 14
  71.               nligrp0=descr.noelep(/1)
  72.               if (nligrp0.ne.des3.noelep(/1)) goto 14
  73.               do id1=1,nligrd0
  74.                 if (descr.noeled(id1).ne.des3.noeled(id1)) goto 14
  75.                 if (descr.lisdua(id1).ne.des3.lisdua(id1)) goto 14
  76.               enddo
  77.               do id1=1,nligrp0
  78.                 if (descr.noelep(id1).ne.des3.noelep(id1)) goto 14
  79.                 if (descr.lisinc(id1).ne.des3.lisinc(id1)) goto 14
  80.               enddo
  81.               goto 13
  82.  
  83.  14          continue
  84.           write(6,*) 'lxde lxel lxir',ir,lx,lxde(lx),lxel(lx),lxir(lx)
  85.               interr(1)=num(2,iel)
  86.               interr(2)=num(1,iel)
  87.               call erreur(919)
  88.               return
  89. C
  90.  13           continue
  91. **            write(6,*) 'fusion avec ',iel,lx,lxir(lx),lxel(lx)
  92. *  ok on fusionne
  93.               nrigel=nrigel+1
  94.               segadj ri1
  95.               nbsous=0
  96.               nbref=0
  97.               nbelem=1
  98.               nbnn=num(/1)
  99.               segini ipt1
  100.               ipt1.itypel=22
  101.               ipt2=irigel(1,lxir(lx))
  102.               segact ipt2
  103.               do ip=1,nbnn
  104.                 ipt1.num(ip,1)=num(ip,iel)
  105.              if(ipt2.num(ip,lxel(lx)).ne.num(ip,iel))call erreur(919)
  106.               enddo
  107.               ri1.irigel(1,nrigel)=ipt1
  108.               ri1.irigel(3,nrigel)=descr
  109.               xmatr1=irigel(4,lxir(lx))
  110.               segact xmatr1
  111.               ielo=lxel(lx)
  112.               nelrig=1
  113.               nligrd=re(/1)
  114.               nligrp=re(/2)
  115.           if(nligrd.ne.xmatr1.re(/1).or.nligrp.ne.xmatr1.re(/2)) then
  116.                  call erreur(919)
  117.           endif
  118. **              write(6,*) 'xmatr2 nligrd,nligrp,nelrig ',
  119. **   >             nligrd,nligrp,nelrig
  120.               segini xmatr2
  121.               xmatr2.symre=max(symre,xmatr1.symre)
  122.               do ip=1,re(/2)
  123.                 do id=1,re(/1)
  124.          xmatr2.re(id,ip,1)=re(id,ip,iel)*coerig(ir)+
  125.      >   xmatr1.re(id,ip,ielo)*coerig(lxir(lx))
  126.                 enddo
  127.               enddo
  128.               ri1.irigel(4,nrigel)=xmatr2
  129.               ri1.coerig(nrigel)=1.d0
  130.               ri1.irigel(6,nrigel)=irigel(6,ir)
  131.               ri1.irigel(7,nrigel)=max(irigel(7,ir),
  132.      >                                 irigel(7,lxir(lx)))
  133.               ri1.irigel(8,nrigel)=max(irigel(8,ir),
  134.      >                                  irigel(8,lxir(lx)))
  135. *  flag raideur a supprimer
  136.               lxir(lx)=-nrigel
  137.             endif
  138.           enddo
  139.         endif
  140.       enddo
  141. *  ri1 contient les matrices fusionnees
  142. *  il ne reste plus qu'a comprimer mrigid
  143.        if(nrigel.eq.0) then
  144.          segsup ncpr,lxir,lxel,lxde
  145.          segsup ri1
  146.          return
  147.        endif
  148.        nrigcr=nrigel
  149.        nrigel=nrigcr+irigel(/2)
  150.        segadj ri1
  151.        ir2=nrigcr
  152.        do ir=1,irigel(/2)
  153.          meleme=irigel(1,ir)
  154.          xmatri=irigel(4,ir)
  155.          iel2=0
  156. *  si pas de lx, on ne fait rien
  157.          if(itypel.ne.22) then
  158.            iel2=num(/2)
  159.          else
  160.            do iel=1,num(/2)
  161.              if(lxir(ncpr(num(1,iel))).gt.0) iel2=iel2+1
  162.            enddo
  163.          endif
  164.          if (iel2.ne.num(/2)) then
  165.            nbsous=0
  166.            nbref=0
  167.            nbnn=num(/1)
  168.            nbelem=iel2
  169.            segini ipt1
  170.            ipt1.itypel=itypel
  171.            nligrd=re(/1)
  172.            nligrp=re(/2)
  173.            nelrig=iel2
  174. **            write(6,*) 'verlag ipt1 nbnn nbelem ',ipt1,nbnn,nbelem
  175.            segini xmatr1
  176.            xmatr1.symre=symre
  177.            iel2=0
  178.            do iel=1,num(/2)
  179.              if(lxir(ncpr(num(1,iel))).gt.0) then
  180.                iel2=iel2+1
  181.                do ip=1,num(/1)
  182.                  ipt1.num(ip,iel2)=num(ip,iel)
  183.                enddo
  184. **             write(6,*) (ipt1.num(ii,iel2),ii=1,nbnn)
  185.                do ip=1,nligrp
  186.                  do id=1,nligrd
  187.                    xmatr1.re(id,ip,iel2)=re(id,ip,iel)
  188.                  enddo
  189.                enddo
  190.              endif
  191.            enddo
  192.            if(nbelem.ne.0) then
  193.              ir2=ir2+1
  194.              ri1.irigel(1,ir2)=ipt1
  195.              ri1.irigel(4,ir2)=xmatr1
  196.              ri1.irigel(7,ir2)=xmatr1.symre
  197.            endif
  198.          else
  199.            ir2=ir2+1
  200.            nbelem=num(/2)
  201.            ri1.irigel(1,ir2)=meleme
  202.            ri1.irigel(4,ir2)=xmatri
  203.            ri1.irigel(7,ir2)=symre
  204.          endif
  205.          if(nbelem.ne.0) then
  206.            ri1.coerig(ir2)=coerig(ir)
  207.            ri1.irigel(3,ir2)=irigel(3,ir)
  208.            ri1.irigel(5,ir2)=irigel(5,ir)
  209.            ri1.irigel(6,ir2)=irigel(6,ir)
  210.            ri1.irigel(8,ir2)=irigel(8,ir)
  211.          endif
  212.          xmatri=ri1.irigel(4,ir2)
  213. **      write(6,*) 'ir2 xmatr1 irigel ',ir2,xmatri.symre,
  214. **   >         ri1.irigel(7,ir2)
  215.        enddo
  216.        nrigel=ir2
  217.        segadj ri1
  218.        mrigid=ri1
  219. *      call prrigi(mrigid,0)
  220.        segsup ncpr,lxir,lxel,lxde
  221.        end
  222.  
  223.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales