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    PV090527  26/04/28    21:16:51     12529          
  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.         if(itypel.eq.22) then
  51.           segact,descr,xmatri
  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.               segact xmatr1
  65.               if (xmatri.symre.eq.xmatr1.symre) goto 14
  66. C
  67. C             S'agit-il des memes descripteurs
  68.               des3=lxde(lx)
  69.               if (des3.eq.descr) goto 13
  70.               nligrd0=descr.noeled(/1)
  71.               if (nligrd0.ne.des3.noeled(/1)) goto 14
  72.               nligrp0=descr.noelep(/1)
  73.               if (nligrp0.ne.des3.noelep(/1)) goto 14
  74.               do id1=1,nligrd0
  75.                 if (descr.noeled(id1).ne.des3.noeled(id1)) goto 14
  76.                 if (descr.lisdua(id1).ne.des3.lisdua(id1)) goto 14
  77.               enddo
  78.               do id1=1,nligrp0
  79.                 if (descr.noelep(id1).ne.des3.noelep(id1)) goto 14
  80.                 if (descr.lisinc(id1).ne.des3.lisinc(id1)) goto 14
  81.               enddo
  82.               goto 13
  83.  
  84.  14          continue
  85.           write(6,*) 'lxde lxel lxir',ir,lx,lxde(lx),lxel(lx),lxir(lx)
  86.               interr(1)=num(2,iel)
  87.               interr(2)=num(1,iel)
  88.               call erreur(919)
  89.               return
  90. C
  91.  13           continue
  92.               segdes xmatr1
  93. **            write(6,*) 'fusion avec ',iel,lx,lxir(lx),lxel(lx)
  94. *  ok on fusionne
  95.               nrigel=nrigel+1
  96.               segadj ri1
  97.               nbsous=0
  98.               nbref=0
  99.               nbelem=1
  100.               nbnn=num(/1)
  101.               segini ipt1
  102.               ipt1.itypel=22
  103.               ipt2=irigel(1,lxir(lx))
  104.               segact ipt2
  105.               do ip=1,nbnn
  106.                 ipt1.num(ip,1)=num(ip,iel)
  107.              if(ipt2.num(ip,lxel(lx)).ne.num(ip,iel))call erreur(919)
  108.               enddo
  109.               ri1.irigel(1,nrigel)=ipt1
  110.               ri1.irigel(3,nrigel)=descr
  111.               xmatr1=irigel(4,lxir(lx))
  112.               segact xmatr1
  113.               ielo=lxel(lx)
  114.               nelrig=1
  115.               nligrd=re(/1)
  116.               nligrp=re(/2)
  117.           if(nligrd.ne.xmatr1.re(/1).or.nligrp.ne.xmatr1.re(/2)) then
  118.                  call erreur(919)
  119.           endif
  120. **              write(6,*) 'xmatr2 nligrd,nligrp,nelrig ',
  121. **   >             nligrd,nligrp,nelrig
  122.               rigrel=0
  123.               segini xmatr2
  124.               xmatr2.symre=max(symre,xmatr1.symre)
  125.               do ip=1,re(/2)
  126.                 do id=1,re(/1)
  127.          xmatr2.re(id,ip,1)=re(id,ip,iel)*coerig(ir)+
  128.      >   xmatr1.re(id,ip,ielo)*coerig(lxir(lx))
  129.                 enddo
  130.               enddo
  131.               ri1.irigel(4,nrigel)=xmatr2
  132.               ri1.coerig(nrigel)=1.d0
  133.               ri1.irigel(6,nrigel)=irigel(6,ir)
  134.               ri1.irigel(7,nrigel)=max(irigel(7,ir),
  135.      >                                 irigel(7,lxir(lx)))
  136.               ri1.irigel(8,nrigel)=max(irigel(8,ir),
  137.      >                                  irigel(8,lxir(lx)))
  138. *  flag raideur a supprimer
  139.               lxir(lx)=-nrigel
  140.               segdes xmatr1
  141.             endif
  142.           enddo
  143.         endif
  144.         segdes xmatri
  145.       enddo
  146. *  ri1 contient les matrices fusionnees
  147. *  il ne reste plus qu'a comprimer mrigid
  148.        if(nrigel.eq.0) then
  149.          segsup ncpr,lxir,lxel,lxde
  150.          segsup ri1
  151.          return
  152.        endif
  153.        nrigcr=nrigel
  154.        nrigel=nrigcr+irigel(/2)
  155.        segadj ri1
  156.        ir2=nrigcr
  157.        do ir=1,irigel(/2)
  158.          meleme=irigel(1,ir)
  159.          xmatri=irigel(4,ir)
  160.          segact xmatri
  161.          iel2=0
  162. *  si pas de lx, on ne fait rien
  163.          if(itypel.ne.22) then
  164.            iel2=num(/2)
  165.          else
  166.            do iel=1,num(/2)
  167.              if(lxir(ncpr(num(1,iel))).gt.0) iel2=iel2+1
  168.            enddo
  169.          endif
  170.          if (iel2.ne.num(/2)) then
  171.            nbsous=0
  172.            nbref=0
  173.            nbnn=num(/1)
  174.            nbelem=iel2
  175.            segini ipt1
  176.            ipt1.itypel=itypel
  177.            nligrd=re(/1)
  178.            nligrp=re(/2)
  179.            nelrig=iel2
  180. **            write(6,*) 'verlag ipt1 nbnn nbelem ',ipt1,nbnn,nbelem
  181.            rigrel=0
  182.            segini xmatr1
  183.            xmatr1.symre=symre
  184.            iel2=0
  185.            do iel=1,num(/2)
  186.              if(lxir(ncpr(num(1,iel))).gt.0) then
  187.                iel2=iel2+1
  188.                do ip=1,num(/1)
  189.                  ipt1.num(ip,iel2)=num(ip,iel)
  190.                enddo
  191. **             write(6,*) (ipt1.num(ii,iel2),ii=1,nbnn)
  192.                do ip=1,nligrp
  193.                  do id=1,nligrd
  194.                    xmatr1.re(id,ip,iel2)=re(id,ip,iel)
  195.                  enddo
  196.                enddo
  197.              endif
  198.            enddo
  199.            if(nbelem.ne.0) then
  200.              ir2=ir2+1
  201.              ri1.irigel(1,ir2)=ipt1
  202.              ri1.irigel(4,ir2)=xmatr1
  203.              ri1.irigel(7,ir2)=xmatr1.symre
  204.            endif
  205.          else
  206.            ir2=ir2+1
  207.            nbelem=num(/2)
  208.            ri1.irigel(1,ir2)=meleme
  209.            ri1.irigel(4,ir2)=xmatri
  210.            ri1.irigel(7,ir2)=symre
  211.          endif
  212.          if(nbelem.ne.0) then
  213.            ri1.coerig(ir2)=coerig(ir)
  214.            ri1.irigel(3,ir2)=irigel(3,ir)
  215.            ri1.irigel(5,ir2)=irigel(5,ir)
  216.            ri1.irigel(6,ir2)=irigel(6,ir)
  217.            ri1.irigel(8,ir2)=irigel(8,ir)
  218.          endif
  219.          segdes xmatri
  220. **         xmatri=ri1.irigel(4,ir2)
  221. **      write(6,*) 'ir2 xmatr1 irigel ',ir2,xmatri.symre,
  222. **   >         ri1.irigel(7,ir2)
  223.        enddo
  224.        nrigel=ir2
  225.        segadj ri1
  226.        mrigid=ri1
  227. *      call prrigi(mrigid,0)
  228.        segsup ncpr,lxir,lxel,lxde
  229.        end
  230.  
  231.  
  232.  
  233.  

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