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  25/09/20    21:15:04     12365          
  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.               segini xmatr2
  123.               xmatr2.symre=max(symre,xmatr1.symre)
  124.               do ip=1,re(/2)
  125.                 do id=1,re(/1)
  126.          xmatr2.re(id,ip,1)=re(id,ip,iel)*coerig(ir)+
  127.      >   xmatr1.re(id,ip,ielo)*coerig(lxir(lx))
  128.                 enddo
  129.               enddo
  130.               ri1.irigel(4,nrigel)=xmatr2
  131.               ri1.coerig(nrigel)=1.d0
  132.               ri1.irigel(6,nrigel)=irigel(6,ir)
  133.               ri1.irigel(7,nrigel)=max(irigel(7,ir),
  134.      >                                 irigel(7,lxir(lx)))
  135.               ri1.irigel(8,nrigel)=max(irigel(8,ir),
  136.      >                                  irigel(8,lxir(lx)))
  137. *  flag raideur a supprimer
  138.               lxir(lx)=-nrigel
  139.               segdes xmatr1
  140.             endif
  141.           enddo
  142.         endif
  143.         segdes xmatri
  144.       enddo
  145. *  ri1 contient les matrices fusionnees
  146. *  il ne reste plus qu'a comprimer mrigid
  147.        if(nrigel.eq.0) then
  148.          segsup ncpr,lxir,lxel,lxde
  149.          segsup ri1
  150.          return
  151.        endif
  152.        nrigcr=nrigel
  153.        nrigel=nrigcr+irigel(/2)
  154.        segadj ri1
  155.        ir2=nrigcr
  156.        do ir=1,irigel(/2)
  157.          meleme=irigel(1,ir)
  158.          xmatri=irigel(4,ir)
  159.          segact xmatri
  160.          iel2=0
  161. *  si pas de lx, on ne fait rien
  162.          if(itypel.ne.22) then
  163.            iel2=num(/2)
  164.          else
  165.            do iel=1,num(/2)
  166.              if(lxir(ncpr(num(1,iel))).gt.0) iel2=iel2+1
  167.            enddo
  168.          endif
  169.          if (iel2.ne.num(/2)) then
  170.            nbsous=0
  171.            nbref=0
  172.            nbnn=num(/1)
  173.            nbelem=iel2
  174.            segini ipt1
  175.            ipt1.itypel=itypel
  176.            nligrd=re(/1)
  177.            nligrp=re(/2)
  178.            nelrig=iel2
  179. **            write(6,*) 'verlag ipt1 nbnn nbelem ',ipt1,nbnn,nbelem
  180.            segini xmatr1
  181.            xmatr1.symre=symre
  182.            iel2=0
  183.            do iel=1,num(/2)
  184.              if(lxir(ncpr(num(1,iel))).gt.0) then
  185.                iel2=iel2+1
  186.                do ip=1,num(/1)
  187.                  ipt1.num(ip,iel2)=num(ip,iel)
  188.                enddo
  189. **             write(6,*) (ipt1.num(ii,iel2),ii=1,nbnn)
  190.                do ip=1,nligrp
  191.                  do id=1,nligrd
  192.                    xmatr1.re(id,ip,iel2)=re(id,ip,iel)
  193.                  enddo
  194.                enddo
  195.              endif
  196.            enddo
  197.            if(nbelem.ne.0) then
  198.              ir2=ir2+1
  199.              ri1.irigel(1,ir2)=ipt1
  200.              ri1.irigel(4,ir2)=xmatr1
  201.              ri1.irigel(7,ir2)=xmatr1.symre
  202.            endif
  203.          else
  204.            ir2=ir2+1
  205.            nbelem=num(/2)
  206.            ri1.irigel(1,ir2)=meleme
  207.            ri1.irigel(4,ir2)=xmatri
  208.            ri1.irigel(7,ir2)=symre
  209.          endif
  210.          if(nbelem.ne.0) then
  211.            ri1.coerig(ir2)=coerig(ir)
  212.            ri1.irigel(3,ir2)=irigel(3,ir)
  213.            ri1.irigel(5,ir2)=irigel(5,ir)
  214.            ri1.irigel(6,ir2)=irigel(6,ir)
  215.            ri1.irigel(8,ir2)=irigel(8,ir)
  216.          endif
  217.          segdes xmatri
  218. **         xmatri=ri1.irigel(4,ir2)
  219. **      write(6,*) 'ir2 xmatr1 irigel ',ir2,xmatri.symre,
  220. **   >         ri1.irigel(7,ir2)
  221.        enddo
  222.        nrigel=ir2
  223.        segadj ri1
  224.        mrigid=ri1
  225. *      call prrigi(mrigid,0)
  226.        segsup ncpr,lxir,lxel,lxde
  227.        end
  228.  
  229.  
  230.  

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