Télécharger la plaquette Cast3M


fr en

Télécharger supri.eso

Retour à la liste

Numérotation des lignes : 

supri

  1. C SUPRI     SOURCE    PV090527  26/09/12    21:15:05     12625          
  2.       SUBROUTINE SUPRI
  3. c====================================================================
  4. c       sous routine utilisee par l'operateur super option 'rigidite'
  5. c
  6. c       on lit une rigiditee des noeuds maitres(geo ou rigi ou chpoi)
  7. c       il sort un objet de type superelement
  8. c
  9. c       appelee par super
  10. c====================================================================
  11.  
  12.       IMPLICIT INTEGER(I-N)
  13.       IMPLICIT REAL*8(A-H,O-Z)
  14.  
  15. -INC SMSUPER
  16. -INC SMCHPOI
  17. -INC SMRIGID
  18. -INC SMELEME
  19. -INC SMCOORD
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC CCGEOME
  23. -INC CCREEL 
  24.  
  25.       SEGMENT ICPR(nbpts)
  26.       SEGMENT JCPR(nbpts)
  27.       SEGMENT NOINC(NNIN,ITA)
  28.       SEGMENT NNOEU(NNIN)
  29.  
  30.       SEGMENT SNOMIN
  31.       CHARACTER*(LOCOMP) NOMIN(0)
  32.       ENDSEGMENT
  33.  
  34.       SEGMENT SNOMDU
  35.       CHARACTER*(LOCOMP) NOMDU(0)
  36.       ENDSEGMENT
  37.  
  38.       SEGMENT ITRANS(LISINC(/2))      
  39.       SEGMENT INOE(ITA)
  40. c     segment/xvl/(xva(nligra)*d)
  41. c     segment ipass(nligra)
  42.       SEGMENT ISIM(ISIMU)
  43.  
  44.       character*4 mcle(1)
  45.       data mcle/'NOMU'/
  46.       logical symetr
  47. c
  48. *  option NOMUltiplicateur
  49.       nomu=0
  50.       call lirmot(mcle,1,nomu,0)
  51.  
  52.       CALL LIROBJ ('RIGIDITE',MRIGID,1,IRETOU)
  53.       segact mrigid
  54.  
  55.  
  56.  
  57.       IF(IERR.NE.0) RETURN
  58.  
  59.       NEWKEQ=1
  60. c
  61. c *** recuperation des noeuds maitres
  62. c
  63. c_______________________________cas du chpo___________________________________
  64. c
  65. c
  66.       CALL LIROBJ ('CHPOINT ',MCHPOI,0,IRETOU)
  67.       IF(IRETOU.EQ.0) GO TO 1000
  68. c
  69. c     on vient de lirobj un chpoint on travaille a partir de lui
  70. c
  71. c          creation des inconnues  dans nomin
  72. c          creation de icpr
  73. c          creation de noinc(i,j)=1 si inconnues i existe pour le jeme noeud
  74. c
  75.       SEGACT MCHPOI
  76.       SEGINI SNOMIN,ICPR
  77.       ITA=0
  78.       NOMIN(**)='LX  '
  79.       NNIN=2
  80.       DO 1001 I=1,IPCHP(/1)
  81.           MSOUPO=IPCHP(I)
  82.           SEGACT MSOUPO
  83.           MELEME=IGEOC
  84.           SEGACT MELEME
  85.           IF(I.EQ.1) THEN
  86.               NOMIN(**)=NOCOMP(1)
  87.           ENDIF
  88.           DO 1002 J=1,NOCOMP(/2)
  89.               DO 1003 K=1,NOMIN(/2)
  90.                   IF(NOMIN(K).EQ.NOCOMP(J)) GO TO 1002
  91.  1003         CONTINUE
  92.               NNIN=NNIN+1
  93.               NOMIN(**)=NOCOMP(J)
  94.  1002     CONTINUE
  95.           DO 1004 J=1,NUM(/2)
  96.               ICPR(NUM(1,J))=ITA+J
  97.  1004     CONTINUE
  98.           ITA =ITA + NUM(/2)
  99.  1001 CONTINUE
  100.       SEGINI NOINC
  101.       NTPMAI=ITA
  102.       ITA=0
  103.       DO 1006 I=1,IPCHP(/1)
  104.           MSOUPO=IPCHP(I)
  105.           MELEME=IGEOC
  106.           DO 1007 J=1,NOCOMP(/2)
  107.               DO 1008 K=1,NNIN
  108.                   IF(NOMIN(K).EQ.NOCOMP(J)) GO TO 1009
  109.  1008         CONTINUE
  110.  1009         CONTINUE
  111.               KK=K
  112.               DO 1010 K=1,NUM(/2)
  113.                   NOINC(KK,K+ITA)=1
  114.  1010         CONTINUE
  115.  1007     CONTINUE
  116.           ITA =ITA+NUM(/2)
  117.           SEGDES MELEME,MSOUPO
  118.  1006 CONTINUE
  119.       SEGDES MCHPOI
  120.       SEGACT MRIGID
  121. c
  122. c  ** initialisation de nomdu et verifi que chaque noeud et chaque inco
  123. c     existe
  124.       DO 1013 I=1,ICPR(/1)
  125.           ICPR(I)=-ICPR(I)
  126. 1013  CONTINUE
  127.       SEGINI SNOMDU
  128.       nomdu(**)='FLX '
  129.       DO 1014 I=2,NOMIN(/2)
  130.           NOMDU(**)=' '
  131. 1014  CONTINUE
  132.       DO 1015 I=1,IRIGEL(/2)
  133.           MELEME=IRIGEL(1,I)
  134.           DESCR=IRIGEL(3,I)
  135.           SEGACT MELEME
  136.           DO      J=1,NUM(/2)
  137.               DO      K=1,NUM(/1)
  138.                   IP=NUM(K,J)
  139.                   ICPR(IP)=ABS(ICPR(IP))
  140.               ENDDO     
  141.           ENDDO     
  142.           SEGDES MELEME
  143.           SEGACT DESCR
  144.           DO 1017 K=1,NOMIN(/2)
  145.               DO 1018 J=1,LISINC(/2)
  146.                   IF(NOMIN(K).NE.LISINC(J)) GO TO 1018
  147.                   NOMDU(K)=LISDUA(J)
  148.                   GO TO 1017
  149.  1018         CONTINUE
  150.  1017     CONTINUE
  151.           SEGDES DESCR
  152.  1015 CONTINUE
  153.       DO 1019 I=1,ICPR(/1)
  154.           IF(ICPR(I).GE.0) GO TO 1019
  155.           CALL ERREUR (293)
  156.           RETURN
  157.  1019 CONTINUE
  158.       DO 1020 I=1,NOMDU(/2)
  159.           IF(NOMDU(I).NE.'    ') GO TO 1020
  160.           CALL ERREUR (293)
  161.           RETURN
  162.  1020 CONTINUE
  163.       NBNN=ITA
  164.       NBSOUS=0
  165.       NBREF=0
  166.       NBELEM=1
  167.       SEGINI MELEME
  168.       ITYPEL=1
  169.       IMELE=MELEME
  170.       DO 1021 I=1,ICPR(/1)
  171.           IF(ICPR(I).EQ.0) GO TO 1021
  172.           NUM(ICPR(I),1)=I
  173.  1021 CONTINUE
  174.       SEGDES MELEME
  175.       GO TO 1011
  176. c
  177. c_____________________________cas de rigi___________________________________
  178. c
  179.  1000 CONTINUE
  180.       CALL LIROBJ ('RIGIDITE',MRIG,0,IRETOU)
  181.       IF(IRETOU.EQ.0) GO TO 1500
  182.       ITA=0
  183.       NNIN=0
  184. c
  185.       RI1=MRIG
  186.       SEGACT RI1
  187.       do ir=1,ri1.irigel(/2)
  188.       enddo
  189. c
  190.       SEGINI SNOMIN,SNOMDU,ICPR
  191.       nomin(**)='LX  '
  192.       nomdu(**)='FLX '
  193. c
  194.       DO 1501 I=1,RI1.IRIGEL(/2)
  195.           MELEME=RI1.IRIGEL(1,I)
  196.           SEGACT MELEME
  197.           DESCR=RI1.IRIGEL(3,I)
  198.           SEGACT DESCR
  199.           DO 1502 J=1,LISINC(/2)
  200.               IF(LISINC(J).EQ.'LX  '.AND.J.LE.1) GO TO 1502
  201.               DO 1503 K=1,NUM(/2)
  202.                   IP=NUM(NOELEP(J),K)
  203.                   IF(ICPR(IP).NE.0) GO TO 1503
  204.                   ITA=ITA+1
  205.                   ICPR(IP)=ITA
  206.  1503         CONTINUE
  207.               IF(NOMIN(/2).EQ.0) THEN
  208.                   NOMIN(**)=LISINC(J)
  209.                   NOMDU(**)=LISDUA(J)
  210.               ELSE
  211.                   DO 1504 K=1,NOMIN(/2)
  212.                       IF(LISINC(J).EQ.NOMIN(K)) GO TO 1505
  213.  1504             CONTINUE
  214.                   NOMIN(**)=LISINC(J)
  215.                   NOMDU(**)=LISDUA(J)
  216.  1505             CONTINUE
  217.               ENDIF
  218.  1502     CONTINUE
  219.           SEGDES MELEME,DESCR
  220.  1501 CONTINUE
  221. c
  222.       NNIN=NOMIN(/2)
  223.       NTPMAI=ITA
  224. c
  225.       SEGINI NOINC
  226. c
  227.       DO 1506 I=1,RI1.IRIGEL(/2)
  228.           MELEME=RI1.IRIGEL(1,I)
  229.           DESCR=RI1.IRIGEL(3,I)
  230. c
  231.           SEGACT MELEME,DESCR
  232.           DO 1507 J=1,LISINC(/2)
  233.               IF(LISINC(J).EQ.'LX  '.AND.J.LE.1)  GO TO 1507
  234.               IP=NOELEP(J)
  235.               DO 1509 KK=1,NOMIN(/2)
  236.                   IF(NOMIN(KK).EQ.LISINC(J)) GO TO 1510
  237.  1509         CONTINUE
  238.  1510         CONTINUE
  239.               DO 1508 K=1,NUM(/2)
  240.                   IPP=ICPR(NUM(IP,K))
  241.                   NOINC(KK,IPP)=1
  242.  1508         CONTINUE
  243.  1507     CONTINUE
  244.           SEGDES MELEME,DESCR
  245.  1506 CONTINUE
  246.       SEGDES RI1
  247. c
  248.       NBNN=ITA
  249.       NBSOUS=0
  250.       NBREF=0
  251.       NBELEM=1
  252.       SEGINI MELEME
  253. c
  254.       ITYPEL=1
  255.       IMELE=MELEME
  256. c
  257.       DO 1511 I=1,ICPR(/1)
  258.           IF(ICPR(I).EQ.0) GO TO 1511
  259.           NUM(ICPR(I),1)=I
  260.  1511 CONTINUE
  261.  1512 CONTINUE
  262. c
  263.       SEGDES MELEME
  264.       GO TO 1011
  265. c
  266. c____________________________cas de geo_______________________________
  267. c
  268.  1500 CONTINUE
  269. c
  270.       CALL LIROBJ ('POINT   ',MELEME,0,IRETOU)
  271.       IF(IRETOU.NE.0) CALL CRELEM(MELEME)
  272.       IF(IRETOU.EQ.0) CALL LIROBJ ('MAILLAGE',MELEME,1,IRETOU)
  273.       IF(IERR.NE.0) RETURN
  274.       CALL CHANGE(MELEME,1)
  275.       SEGINI,IPT1=MELEME
  276.       SEGDES,IPT1
  277. c
  278. c   **  on fabrique une numerotation interne uniquement les noeuds
  279. c   **  maitres.
  280. c
  281.       SEGINI ICPR
  282.       ITE=0
  283.       DO 1 I = 1,NUM(/2)
  284.           IP= NUM(1,I)
  285.           IF(ICPR(IP).NE.0) GO TO 1
  286.           ITE=ITE+1
  287.           ICPR(IP)=ITE
  288.    1  CONTINUE
  289.       NTPMAI=ITE
  290.       ITA=ITE
  291. c
  292. c___________on cherche la liste des inconnues pour chaque noeuds___________
  293. c
  294.       SEGDES MELEME
  295.       SEGACT MRIGID
  296.       DESCR=IRIGEL(3,1)
  297.       SEGACT DESCR
  298.       SEGINI SNOMIN
  299.       SEGINI SNOMDU
  300.       nomin(**)='LX  '
  301.       nomdu(**)='FLX '
  302.       DO 2 I=1,IRIGEL(/2)
  303.           DESCR=IRIGEL(3,I)
  304.           SEGACT DESCR
  305.           DO 4 J=1,LISINC(/2)
  306.               NO=NOMIN(/2)
  307.               DO 5 K=1,NO
  308.                   IF(NOMIN(K).EQ.LISINC(J)) GO TO 4
  309.     5         CONTINUE
  310.               NOMIN(**)=LISINC(J)
  311.               NOMDU(**)=LISDUA(J)
  312.     4     CONTINUE
  313.           SEGDES DESCR
  314.     2 CONTINUE
  315.       NNIN=NOMIN(/2)
  316. c
  317. c  **  on cree le tableau noinc(i,j)=1 si la ieme inconnue existe pour
  318. c  ** le jeme noeud
  319. c  ** itrans donne pour chaque descr la correspondance entre lisinc et
  320. c  *** la liste des inconnues
  321. c
  322.       SEGINI NOINC
  323.       KN=NOMIN(/2)
  324.       DO 6 I=1,IRIGEL(/2)
  325.           DESCR=IRIGEL(3,I)
  326.           SEGACT DESCR
  327.           SEGINI ITRANS
  328.           DO 10 L=1,LISINC(/2)
  329.               DO 11 M=1,NNIN
  330.                   IF( LISINC(L).NE.NOMIN(M)) GO TO 11
  331. *     itrans relie lisinc � nomin
  332.                   ITRANS(L)=M
  333.                   GO TO 10
  334.    11         CONTINUE
  335.    10     CONTINUE
  336.           MELEME=IRIGEL(1,I)
  337.           SEGACT MELEME
  338.           DO   J=1,NUM(/2)
  339.               DO   K = 1,NUM(/1)
  340.                   IP=NUM(K,J)
  341.                   IF(ICPR(IP).NE.0) THEN
  342.                   IT=ICPR(IP)
  343.                   DO 8 L=1,LISINC(/2)
  344.                       IF(NOELEP(L).EQ.K) NOINC(ITRANS(L),IT)=1
  345.     8             CONTINUE
  346.                   ENDIF   
  347.               ENDDO
  348.           ENDDO
  349.           SEGDES MELEME
  350.           SEGDES DESCR
  351.           SEGSUP ITRANS
  352.     6 CONTINUE
  353. *
  354.       SEGACT IPT1
  355.       NBELEM=1
  356.       NBNN=IPT1.NUM(/2)
  357.       NBREF=0
  358.       NBSOUS=0
  359.       SEGINI MELEME
  360. c      do 51 i=1,nbnn
  361. c      num(i,1)=ipt1.num(1,i)
  362. c   51 continue
  363.       ICOLOR(1)=IDCOUL
  364.       ITYPEL=28
  365.       SEGDES IPT1
  366.       DO 52 I=1,ICPR(/1)
  367.           IF(ICPR(I).EQ.0) GO TO 52
  368.           NUM(ICPR(I),1)=I
  369.  52   CONTINUE
  370.       SEGDES MELEME
  371. c
  372. c  ** verification tous les points maitres
  373. c
  374.       DO 16 I=1,ITA
  375.           DO 17 J=1,NNIN
  376.               IF(NOINC(J,I).NE.0) GO TO 16
  377.   17      CONTINUE
  378.           WRITE(*,*) 'CAS DE GEO'
  379.           CALL ERREUR(293)
  380.           RETURN
  381.   16  CONTINUE
  382. c
  383.  1011 CONTINUE
  384. c
  385. c     ______________________partie commune___________________________
  386. c
  387. c
  388. *  en l'absence du mot cle NOMU, on va rajouter dans les noeuds maitres
  389. *  les multiplicateurs de lagrange des relations portant sur ceux-ci
  390. *  ca permet ulterieurement d'utiliser un chargement sur ces
  391. *  multiplicateurs
  392. *
  393. *  En presence du mot cle NOMU, on ne modifie pas la liste des noeuds
  394. *  maitres.
  395. *
  396. c
  397. c  **   on trie la rigidite initiale pour mettre de cote les bloquages
  398. c  **   et relations qui concernent uniquement les noeuds maitres.
  399. c  **   ri4 contiendra la rigidite sans ces bloquages, ri5 contiendra
  400. c  **   uniquement ces bloquages. on fait deux passages pour pouvoir
  401. c  **   dimensionner irigel
  402. c  **   on effectue un traitement particulier pour les ddls de lagrange
  403. c  **   maitres
  404. c
  405.       segact mrigid
  406.       segini,ri4=mrigid
  407.       segini,ri5=mrigid
  408.       nrig=irigel(/2)
  409.        symetr=.true.
  410.       do 800 ir=1,nrig
  411.        if (irigel(7,ir).ne.0) symetr=.false.
  412.        ipt3=irigel(1,ir)
  413.        segact ipt3
  414.        if (ipt3.itypel.ne.22) then
  415.         ri5.irigel(1,ir)=0
  416.         goto 800
  417.        endif
  418.        segini,ipt4=ipt3
  419.        ri4.irigel(1,ir)=ipt4
  420.        segini,ipt5=ipt3
  421.        ri5.irigel(1,ir)=ipt5
  422.        descr=irigel(3,ir)
  423.        segact descr
  424.        xmatri=irigel(4,ir)
  425.        segact xmatri
  426.        segini,xmatr4=xmatri
  427.        ri4.irigel(4,ir)=xmatr4
  428.        segini,xmatr5=xmatri
  429.        ri5.irigel(4,ir)=xmatr5
  430.        iel4=0
  431.        iel5=0
  432.        do 810 iel=1,ipt3.num(/2)
  433.        iaf=0
  434.        ir5=1
  435.        do 820 ipt=2,noelep(/1)
  436.         if (icpr(ipt3.num(noelep(ipt),iel)).ne.0) then
  437.          do k=1,nomin(/2)
  438.           if (nomin(k).eq.lisinc(ipt)) goto 821
  439.          enddo
  440.          ir5=0
  441.          goto 820
  442.  821     continue
  443.          if (noinc(k,icpr(ipt3.num(noelep(ipt),iel))).eq.1) iaf=1
  444.          if (noinc(k,icpr(ipt3.num(noelep(ipt),iel))).eq.0) ir5=0
  445.         else
  446.          ir5=0
  447.         endif
  448.  820   continue
  449.       if (iaf.eq.1.and.nomu.eq.0.and.ir5.eq.0) then
  450. *  il faut rajouter le mult de lagrange dans les noeuds maitres
  451.        if (icpr(ipt3.num(noelep(1),iel)).eq.0) then
  452.            ita=ita+1
  453.            icpr(ipt3.num(noelep(1),iel))=ita
  454.            segadj noinc
  455.        endif
  456.  
  457. *       write (6,*) ' mult transforme maitre ',
  458. *    >  icpr(ipt3.num(noelep(1),iel))
  459.        noinc(1,icpr(ipt3.num(noelep(1),iel)))=1
  460.       endif
  461. ***   ir5=0
  462.       if (ir5.eq.1) then
  463.        iel5=iel5+1
  464.        do ip=1,ipt3.num(/1)
  465.         ipt5.num(ip,iel5)=ipt3.num(ip,iel)
  466.        enddo
  467.         do io=1,re(/2)
  468.             do iu=1,re(/1)
  469.              xmatr5.re(iu,io,iel5)=re(iu,io,iel)
  470.             enddo
  471.         enddo
  472. *       imatr5.imattt(iel5)=imattt(iel)
  473.       else
  474.        iel4=iel4+1
  475.        do ip=1,ipt3.num(/1)
  476.         ipt4.num(ip,iel4)=ipt3.num(ip,iel)
  477.        enddo
  478.          do io=1,re(/2)
  479.              do iu=1,re(/1)
  480.                 xmatr4.re(iu,io,iel4)=re(iu,io,iel)
  481.              enddo
  482.          enddo
  483. *       imatr4.imattt(iel4)=imattt(iel)
  484.       endif
  485.  810  continue
  486.       nbnn=ipt3.num(/1)
  487.       nbsous=0
  488.       nbref=0
  489.       nbelem=iel5
  490.       segadj ipt5
  491.       nbelem=iel4
  492.       segadj ipt4
  493.       nelrig=iel5
  494.       segact xmatr5*mod
  495.       nligrp=xmatr5.re(/2)
  496.       nligrd=xmatr5.re(/1)
  497.       rigrel=0
  498.       segadj xmatr5
  499.       segact xmatr4*mod
  500.       nligrp=xmatr4.re(/2)
  501.       nligrd=xmatr4.re(/1)
  502.       nelrig=iel4
  503.       rigrel=0
  504.       segadj xmatr4
  505.       segdes xmatri,xmatr4,xmatr5
  506.  800  continue
  507.  
  508. c
  509. c     calcul de la rigidite equivalente
  510. c
  511. *      write (6,*) ' ri4 avant dbblx '
  512. *      call prrigi(ri4,0)
  513.        call dbblx(ri4,igrand)
  514.        lagdua=ri4.imlag
  515. *      write (6,*) ' ri4 avant calkeq '
  516. *      call prrigi(ri4,0)
  517. *      write (6,*) ' ri5 avant calkeq '
  518. *      call prrigi(ri5,1)
  519. *      segdes xmatri
  520. * decompte du nombre total de noeuds
  521.       nbelem=0
  522.       segini jcpr 
  523.       segact mrigid
  524.       do iel=1,irigel(/2)
  525.        ipt8=irigel(1,iel)
  526.        segact ipt8
  527.        do j=1,ipt8.num(/2)
  528.        do i=1,ipt8.num(/1)
  529.         ipt=ipt8.num(i,j)  
  530.         if (jcpr(ipt).eq.0) then
  531.           nbelem=nbelem+1   
  532.           jcpr(ipt)=nbelem
  533.         endif
  534.        enddo
  535.        enddo
  536.       enddo
  537.       itb=nbelem
  538. **    call dbblx(ri4,itb)
  539. **    lagdua=ri4.imlag
  540. *  ita nombre de noeuds maitre itb nombre de noeuds total
  541. *     write(6,*) 'ita itb  avant calkeq',ita,itb  
  542.       iok=1
  543.       if (ita**2. .gt.(50.*itb)**1.3333333333) iok=-1
  544.       if(.not.symetr) iok=-2
  545.       if(iok.eq.1) 
  546.      >  CALL CALKEQ(ri4,NOINC,SNOMIN,ICPR,XMATR1,DES1,ICROUT,iok)
  547. c
  548.       if (ierr.ne.0) return
  549.       if (iok.le.0) then
  550. *  pas interessant de calculer le super element 
  551. *     write(6,*) ' pas de super element iok:',iok
  552.       SEGINI MSUPER
  553.       MSURAI= MRIGID                                                                     
  554.       MRIGTO= MRIGID                                                           
  555.       MCROUT=0
  556.       nbnn=1
  557.       nbsous=0
  558.       nbref=0
  559.       segini ipt7
  560.       do i=1,nbpts        
  561.        if (jcpr(i).ne.0)   ipt7.num(1,jcpr(i))=i
  562.       enddo
  563.       segsup jcpr
  564.       MSUPEL=IPT7
  565.       CALL ECROBJ ('SUPERELE',MSUPER)
  566.       RETURN
  567.       ENDIF
  568.  
  569.       segsup jcpr
  570.       SEGACT,NOINC,icpr
  571.       NLIGRA=0
  572.       DO    I=1,ITA
  573.           DO    J=1,NNIN
  574.               NLIGRA=NLIGRA+NOINC(J,I)
  575.           ENDDO
  576.       ENDDO
  577. c
  578. c    creation de la raideur
  579. c
  580. c
  581. c    creation des blocages a ajouter a mrigto
  582. c
  583.       nligrp=1
  584.       nligrd=1
  585.       nelrig=1
  586.       rigrel=0
  587.       segini xmatr2
  588.       segdes xmatr2
  589. *      segini imatr2
  590. *      imatr2.imattt(1)=xmatr2
  591. *      segdes imatr2
  592.       SEGACT RI4
  593.       SEGACT DES1
  594.       IP=RI4.IRIGEL(/2)
  595.       NRIGEL=IP+NLIGRA
  596.       NRIGE=MAX(8,IRIGEL(/1))
  597.       SEGINI RI2
  598.       ri2.MTYMAT='RIGIDITE'
  599.       ri2.IFORIG=IFOUR
  600. *     write (6,*) ' ita ',ita
  601.       NBNN=ITA
  602.       NBSOUS=0
  603.       NBREF=0
  604.       NBELEM=1
  605.       SEGINI MELEME
  606. c
  607.       ITYPEL=28
  608. c
  609.       DO 1611 I=1,ICPR(/1)
  610.           IF(ICPR(I).EQ.0) GO TO 1611
  611.           NUM(ICPR(I),1)=I
  612.  1611 CONTINUE
  613. *        call ecmail(meleme,0)
  614.          segact meleme
  615.          imele=meleme
  616.          NBREF=0
  617.          NBSOUS=0
  618.          NBNN=1
  619.          NBELEM=1
  620.       DO 15 I=1,NLIGRA
  621.           SEGINI IPT1
  622.           IPT1.ITYPEL=1
  623. *         write (6,*) ' des1.noelep ',des1.noelep(i)
  624.           IPT1.NUM(1,1)=NUM(DES1.NOELEP(I),1)
  625.           ri2.irigel(1,i)=ipt1
  626.           segdes ipt1
  627.           segini des2
  628.           des2.lisinc(1)=DES1.LISINC(I)
  629.           des2.lisdua(1)=DES1.LISdua(I)
  630.           des2.noelep(1)=1
  631.           des2.noeled(1)=1
  632.           segdes des2
  633.           ri2.irigel(3,i)=des2
  634.           ri2.irigel(4,i)=xmatr2
  635.           ri2.irigel(5,i)=nifour
  636.  15   CONTINUE
  637.       iplus=0
  638.       DO 25 I=1,IP
  639.       ipt4=ri4.irigel(1,i)
  640.       segact ipt4
  641.       if (ipt4.num(/2).ne.0) then
  642.         iplus=iplus+1
  643.           DO 26 J=1,ri4.irigel(/1)
  644.               RI2.IRIGEL(J,Iplus+NLIGRA)=ri4.IRIGEL(J,I)
  645.  26       CONTINUE
  646.           RI2.COERIG(Iplus+NLIGRA)=ri4.COERIG(I)
  647.       endif
  648.  25   CONTINUE
  649.       nrigel=iplus+nligra
  650.       segadj ri2
  651. c
  652. *      write (6,*) ' ri4  modifie '
  653. *      call prrigi(ri4,1)
  654.       SEGINI MSUPER
  655.       MBLOQU=NLIGRA
  656.       MRIGTO=ri2
  657.       SEGDES ri2
  658.       NRIGE=8
  659.       NELRIG=1
  660.       NRIGEL=1
  661.       SEGINI MRIGID
  662.       COERIG(1)=1.D0
  663. *      SEGINI IMATRI
  664. *      IMATTT(1)=XMATR1
  665.       MTYMAT='RIGIDITE'
  666.       IFORIG=IFOUR
  667.       IRIGEL(1,1)=MELEME
  668.       IRIGEL(2,1)=0
  669.       IRIGEL(3,1)=DES1
  670.       IRIGEL(4,1)=xMATR1
  671.       IRIGEL(5,1)=NIFOUR
  672.       IRIGEL(6,1)=0
  673.  
  674.       segact ri5
  675.       nrigel5=ri5.irigel(/2)
  676.       nrigel=1+nrigel5
  677.       segadj mrigid
  678.       iplus=0
  679.       do ir=1,ri5.irigel(/2)
  680.       meleme=ri5.irigel(1,ir)
  681.       if (meleme.ne.0) then
  682.       segact meleme
  683.       if (num(/2).ne.0) then
  684.        iplus=iplus+1
  685.        do id=1,ri5.irigel(/1)
  686.         irigel(id,1+iplus)=ri5.irigel(id,ir)
  687.        enddo
  688.        coerig(1+iplus)=ri5.coerig(ir)
  689.       endif
  690.       segdes meleme
  691.       endif
  692.       enddo
  693.       nrigel=1+iplus
  694.       segadj mrigid
  695. c     si des inconnues maitres ont ete normalis�e il faut modifier la
  696. c     la matrice condens�e
  697.       if (ierr.ne.0) return
  698. *      segdes xmatri
  699.       CALL SUPNRM(ICROUT,MRIGID,norr)
  700.        mdnorr=norr
  701. *      segdes xmatri
  702.       segact mrigid*mod
  703. c
  704.       MCROUT=ICROUT
  705.       msuper.islag=lagdua
  706.       mrigid.imlag=lagdua
  707. *     write (6,*) ' msurai lagdua dans supri ',mrigid,lagdua
  708. *  ici on rajoute
  709.       meleme=imele
  710.       SEGDES MELEME
  711. *      SEGDES xMATRI
  712.       SEGDES MRIGID
  713.       SEGSUP ICPR,SNOMIN,SNOMDU,NOINC
  714.       SEGDES DES1
  715.       MSURAI=MRIGID
  716. *     write (6,*) ' mrigto *************************'
  717. *     call prrigi(mrigto,0)
  718. *     write (6,*) ' msurai *************************'
  719. *     call prrigi(msurai,0)
  720.       MSUPEL=imele
  721.       SEGDES MSUPER
  722. *
  723.       CALL ECROBJ ('SUPERELE',MSUPER)
  724. *
  725.       RETURN
  726.       END
  727.  
  728.  
  729.  
  730.  
  731.  
  732.  
  733.  
  734.  
  735.  
  736.  
  737.  
  738.  
  739.  
  740.  
  741.  
  742.  
  743.  

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