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

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