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

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