Télécharger la plaquette Cast3M


fr en

Télécharger cmct3.eso

Retour à la liste

Numérotation des lignes : 

cmct3

  1. C CMCT3     SOURCE    GOUNAND   25/06/11    21:15:03     12278          
  2.       SUBROUTINE CMCT3(ICHP,IRIGC,IRIGB,IRIG2)
  3. *_______________________________________________________________________
  4. c
  5. c      opérateur cmct
  6. c
  7. c entrée
  8. c   ICHP  : champ par point qui stocke la masse inversée M-1
  9. c   IRIGB : rigidité B
  10. c   IRIGC : rigidité C
  11. c
  12. c sortie
  13. c   IRIG2 : rigidité contenant la matrice condensée C M-1 Bt
  14. c
  15. *_______________________________________________________________________
  16.  
  17.       IMPLICIT INTEGER(I-N)
  18.       IMPLICIT REAL*8(A-H,O-Z)
  19. *
  20.  
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. -INC SMRIGID
  24.       POINTEUR IRIGC.MRIGID,IRIGB.MRIGID,IRIG2.MRIGID
  25. -INC SMELEME
  26. -INC CCHAMP
  27. -INC SMCOORD
  28. -INC SMCHPOI
  29.       POINTEUR ICHP.MCHPOI
  30. *
  31. * Description des objets à traiter
  32. * PNTOB : pointeur de l'objet
  33. * TYPOB : type de l'objet
  34. * PNTCOB : pointeur vers une version locale de l'objet
  35. *          pour la RIGIDITE IMAT
  36. *                                PNTCOB(1,IMAT) pointe vers un CORES1
  37. *                                PNTCOB(2,IMAT) pointe vers un LSINCO
  38. *                                PNTCOB(3,IMAT) pointe vers un MCOEF
  39.  
  40.       SEGMENT DESCOB
  41.         INTEGER PNTOB(NMAT)
  42.         INTEGER PNTCOB(3,NMAT)
  43.       ENDSEGMENT
  44.  
  45. *  stockage des noms de tous les composantes primales.
  46.       SEGMENT LSINCP
  47.         CHARACTER*(LOCOMP) LISINP(NLIGP)
  48.       ENDSEGMENT
  49. *  LPSINP(ILIGP,IOBJ) dit si la composante est présente dans l'objet
  50. *  IOBJ (Matrice IRIGB, IRIGC ou ICHP)
  51. **  LPSINP(ILIGP,NOBJ+1) dit si la composante est présente dans
  52. **  tous les objets
  53.       SEGMENT LLINCP
  54.         LOGICAL LLSINP(NLIGP,NOBJ)
  55.       ENDSEGMENT
  56.  
  57. *  stockage des noms des composantes duales.
  58.       SEGMENT LSINCD
  59.         CHARACTER*(LOCOMP) LISIND(NLIGD)
  60.       ENDSEGMENT
  61. *
  62. * correspondance entre les noms de composantes locale LISINC
  63. * et les noms de composantes dans LSINCP pour les RIGIDITES
  64.       SEGMENT CORES1
  65.         INTEGER IPCOR2(NRIGEL)
  66.       ENDSEGMENT
  67.       SEGMENT CORES2
  68.         INTEGER COR2P(NLIGRP)
  69.         INTEGER COR2D(NLIGRD)
  70.       ENDSEGMENT
  71. *
  72. * tableau pour dire en chaque point si la composante du tableau LISINP
  73. * est impliquée
  74. *
  75.       SEGMENT MTOPTS
  76. *               nombre d'occurence de la composante
  77.         INTEGER ITOPTS(NBPTS,NLIGP+1,NMAT)
  78.       ENDSEGMENT
  79.       SEGMENT NTOPTS
  80. *               valeur de l'inverse la masse en ce point
  81.         REAL*8  XTOPTS(NBPTS,NLIGP+1)
  82.       ENDSEGMENT
  83.       SEGMENT OTOPTS
  84. *               existence de l'inverse la masse en ce point
  85.         LOGICAL LTOPTS(NBPTS,NLIGP+1)
  86.       ENDSEGMENT
  87. *
  88. * tableau pour pointer vers MCOEF à partir du nombre d'inconnues
  89. *
  90.       SEGMENT LSINCO
  91.         INTEGER LESINC(NINC+1,2,NMAT)
  92.       ENDSEGMENT
  93.       SEGMENT LTINCO
  94.         REAL*8  XMAS(NINC)
  95.       ENDSEGMENT
  96. *
  97. *  tableau des coefficient de la matrice C
  98. *  ordonné dans l'ordre des inconnues
  99.       SEGMENT MCOEF
  100. *        numero du noeud support du multiplicateur ligne 1
  101.       INTEGER ICOEF(2,NCOEF)
  102. *         valeur des coefficients
  103.         REAL*8 XCOEF(NCOEF)
  104.       ENDSEGMENT
  105. *
  106.       LOGICAL LOK,LDBG,LTYP22,LFOUND
  107. *
  108.       LDBG=.FALSE.
  109.       NMAT=1
  110.       SEGACT IRIGC
  111.       IFOC=IRIGC.IFORIG
  112.       IFO2=IFOC
  113.       IF (IRIGB.NE.IRIGC) THEN
  114.          NMAT=2
  115.          SEGACT IRIGB
  116.          IFOB=IRIGB.IFORIG
  117.          IF (IFOB.NE.IFOC) THEN
  118.             moterr(1:8)='RIGIDITE'
  119.             interr(1)=IFOB
  120.             interr(2)=IFOC
  121.             interr(3)=IFOUR
  122.             call erreur(1132)
  123.             IFO2 = IFOUR
  124.          ENDIF
  125.       ENDIF
  126.       NOBJ=NMAT
  127.       IF (ICHP.NE.0) THEN
  128.          NOBJ=NMAT+1
  129.          SEGACT ICHP
  130.          IFOD=ICHP.IFOPOI
  131.          IF (IFOD.NE.IFOC) THEN
  132.             moterr(1:8)='CHPO-RIG'
  133.             interr(1)=IFOD
  134.             interr(2)=IFOC
  135.             interr(3)=IFOUR
  136.             call erreur(1132)
  137.             IFO2 = IFOUR
  138.          ENDIF
  139.       ENDIF
  140.  
  141.       IF (LDBG) THEN
  142.          WRITE(IOIMP,*) 'NMAT=',NMAT
  143.          WRITE(IOIMP,*) 'NOBJ=',NOBJ
  144.       ENDIF
  145.       SEGINI DESCOB
  146.       PNTOB(1)=IRIGC
  147.       IF (IRIGB.NE.IRIGC) THEN
  148.          PNTOB(2)=IRIGB
  149.       ENDIF
  150. *_______________________________________________________________________
  151. *
  152. *   la première etape consiste à établir la liste de tous les noms
  153. *   d'inconnue primale communes à la (aux) rigidités et à l'éventuel
  154. *   CHPOINT de masse. Cette liste est stockée dans LSINCP.
  155. *   On fait aussi la liste des duales par la même occasion
  156. *   On regarde aussi s'il n'y a que des MELEME de type 22, auquel cas
  157. *   on peut éviter le compactage du MCOEF (on est sûr que tous les ddls
  158. *   duaux sont distincts)
  159. *
  160. *     Calcul du nombre maxi
  161.       NLIGP = 1000
  162.       SEGINI LSINCP,LLINCP
  163.       NLIGD = 1000
  164.       SEGINI LSINCD
  165.       LTYP22=.TRUE.
  166. *
  167.       NLIGP1 = 0
  168.       NLIGD1 = 0
  169.       DO IMAT=1,NMAT
  170.          MRIGID=PNTOB(IMAT)
  171.          SEGACT MRIGID
  172.          NRIGEL=IRIGEL(/2)
  173.          DO I=1,NRIGEL
  174.             MELEME = IRIGEL(1,I)
  175.             SEGACT MELEME
  176.             LTYP22=LTYP22.AND.(ITYPEL.EQ.22)
  177.             DESCR = IRIGEL(3,I)
  178.             SEGACT  DESCR
  179.             NLIGRP=LISINC(/2)
  180.             IDEB=1
  181.             IF (ITYPEL.EQ.22) IDEB=2
  182.             DO 200 ILIGRP=IDEB,NLIGRP
  183.                DO ILIGP1=1,NLIGP1
  184.                   IF (LISINC(ILIGRP).EQ.LISINP(ILIGP1)) THEN
  185.                      LLSINP(ILIGP1,IMAT)=.TRUE.
  186.                      GOTO 200
  187.                   ENDIF
  188.                ENDDO
  189. * Petite astuce car on ne cherche que les composantes primales communes
  190. * à tous les objets donc pas besoin de concaténer celles au-delà
  191. * du premier objet
  192.                IF (IMAT.EQ.1) THEN
  193.                   NLIGP1 = NLIGP1 + 1
  194.                   IF (NLIGP1.GT.NLIGP) THEN
  195.                      NLIGP=NLIGP+1000
  196.                      SEGADJ LSINCP,LLINCP
  197.                   ENDIF
  198.                   LISINP(NLIGP1) = LISINC(ILIGRP)
  199.                   LLSINP(NLIGP1,IMAT)=.TRUE.
  200.                ENDIF
  201.  200        CONTINUE
  202.             NLIGRD=LISDUA(/2)
  203.             IF (ITYPEL.EQ.22) NLIGRD=1
  204.             DO 202 ILIGRD=1,NLIGRD
  205.                DO ILIGD1=1,NLIGD1
  206.                   IF (LISDUA(ILIGRD).EQ.LISIND(ILIGD1)) GOTO 202
  207.                ENDDO
  208.                NLIGD1 = NLIGD1 + 1
  209.                IF (NLIGD1.GT.NLIGD) THEN
  210.                   NLIGD=NLIGD+1000
  211.                   SEGADJ LSINCD
  212.                ENDIF
  213.                LISIND(NLIGD1) = LISDUA(ILIGRD)
  214.  202        CONTINUE
  215. *            SEGDES DESCR
  216. *            SEGDES MELEME
  217.          ENDDO
  218. *         SEGDES MRIGID
  219.       ENDDO
  220.       IF (ICHP.NE.0) THEN
  221.          MCHPOI=ICHP
  222.          SEGACT MCHPOI
  223.          NSOUPO=IPCHP(/1)
  224.          DO ISOUPO=1,NSOUPO
  225.             MSOUPO=IPCHP(ISOUPO)
  226.             SEGACT MSOUPO
  227.             NC=NOCOMP(/2)
  228.             DO 204 IC=1,NC
  229.                DO ILIGP1=1,NLIGP1
  230.                   IF (NOCOMP(IC).EQ.LISINP(ILIGP1)) THEN
  231.                      LLSINP(ILIGP1,NOBJ)=.TRUE.
  232.                      GOTO 204
  233.                   ENDIF
  234.                ENDDO
  235.  204        CONTINUE
  236. *            SEGDES MSOUPO
  237.          ENDDO
  238. *         SEGDES MCHPOI
  239.       ENDIF
  240. *
  241.       IF (LDBG) THEN
  242.          WRITE(IOIMP,*) 'LTYP22=',LTYP22
  243.          WRITE(IOIMP,*) 'Liste des inconnues avant compactage'
  244.          WRITE(IOIMP,*) '  1) Duales'
  245.          WRITE (IOIMP,2019) (LISIND(I),I=1,NLIGD1)
  246.          WRITE(IOIMP,*) '  2) Primales'
  247.          WRITE (IOIMP,2019) (LISINP(I),I=1,NLIGP1)
  248.          do j=1,nobj
  249.             WRITE(IOIMP,*) '  Presence de la composante primale dans ',
  250.      $           'l''objet ',j
  251.             WRITE (IOIMP,2021) (LLSINP(I,j),I=1,NLIGP1)
  252.          enddo
  253.       ENDIF
  254. * On compacte LSINCD
  255.       NLIGD = NLIGD1
  256.       SEGADJ LSINCD
  257. * On compacte LSINCP
  258.       NLIGP = 0
  259.       DO ILIGP1=1,NLIGP1
  260.          LOK=.TRUE.
  261.          DO IOBJ=1,NOBJ
  262.             LOK=LOK.AND.LLSINP(ILIGP1,IOBJ)
  263.          ENDDO
  264.          IF (LOK) THEN
  265.             NLIGP=NLIGP+1
  266.             IF (ILIGP1.NE.NLIGP) LISINP(NLIGP)=LISINP(ILIGP1)
  267.          ENDIF
  268.       ENDDO
  269.       SEGADJ LSINCP
  270.       SEGSUP LLINCP
  271.       IF (LDBG) THEN
  272.          WRITE(IOIMP,*) 'Primales apres compactage'
  273.          WRITE (IOIMP,2019) (LISINP(I),I=1,LISINP(/2))
  274.       ENDIF
  275. *     On sort de manière anticipée s'il n'y a pas d'inconnues primales
  276. *     communes
  277.       IF (NLIGP.EQ.0) THEN
  278.          SEGSUP DESCOB,LSINCP,LSINCD
  279.          GOTO 9999
  280.       ENDIF
  281. *
  282. *   Les correspondances locale -> globale dans CORES1 pour les RIGIDITES
  283. *
  284.       DO IMAT=1,NMAT
  285.          MRIGID=PNTOB(IMAT)
  286.          SEGACT MRIGID
  287.          NRIGEL=IRIGEL(/2)
  288.          SEGINI CORES1
  289.          DO I=1,NRIGEL
  290.             MELEME = IRIGEL(1,I)
  291.             SEGACT MELEME
  292.             DESCR = IRIGEL(3,I)
  293.             SEGACT DESCR
  294.             NLIGRP=LISINC(/2)
  295.             NLIGRD=LISDUA(/2)
  296.             IF (ITYPEL.EQ.22) NLIGRD=1
  297.             SEGINI CORES2
  298.             IDEB=1
  299.             IF (ITYPEL.EQ.22) IDEB=2
  300.             DO 300 ILIGRP=IDEB,NLIGRP
  301.                DO ILIGP=1,NLIGP
  302.                   IF (LISINC(ILIGRP).EQ.LISINP(ILIGP)) THEN
  303.                      COR2P(ILIGRP)=ILIGP
  304.                      GOTO 300
  305.                   ENDIF
  306.                ENDDO
  307.                COR2P(ILIGRP)=NLIGP+1
  308.  300        CONTINUE
  309.             DO 302 ILIGRD=1,NLIGRD
  310.                DO ILIGD=1,NLIGD
  311.                   IF (LISDUA(ILIGRD).EQ.LISIND(ILIGD)) THEN
  312.                      COR2D(ILIGRD)=ILIGD
  313.                      GOTO 302
  314.                   ENDIF
  315.                ENDDO
  316.  302        CONTINUE
  317.             IPCOR2(I)=CORES2
  318.             IF (LDBG) THEN
  319.                IF (I.EQ.1.OR.I.EQ.NRIGEL) THEN
  320.                   WRITE(IOIMP,*)
  321.      $                 'Correspondance locale-globale matrice ',imat
  322.      $                 ,' nrigel=',I
  323.                   WRITE(IOIMP,*) '  Primales'
  324.                   WRITE (IOIMP,2019) (LISINC(II),II=1,LISINC(/2))
  325.                   WRITE (IOIMP,2020) (COR2P(II),II=1,COR2P(/1))
  326.                   WRITE(IOIMP,*) '  Duales'
  327.                   WRITE (IOIMP,2019) (LISDUA(II),II=1,LISDUA(/2))
  328.                   WRITE (IOIMP,2020) (COR2D(II),II=1,COR2D(/1))
  329.                ENDIF
  330.             ENDIF
  331.          ENDDO
  332.          PNTCOB(1,IMAT)=CORES1
  333.       ENDDO
  334. *
  335. *_______________________________________________________________________
  336. *  on remplit maintenant le tableau itopts en bouclant sur les sous zones de
  337. *  la rigidité
  338. *
  339.       IF (LDBG) WRITE(IOIMP,*) 'NBPTS=',NBPTS
  340.       SEGINI MTOPTS
  341.       DO IMAT=1,NMAT
  342.          CORES1=PNTCOB(1,IMAT)
  343.          MRIGID=PNTOB(IMAT)
  344.          NRIGEL=IRIGEL(/2)
  345.          DO I=1,NRIGEL
  346.             MELEME = IRIGEL(1,I)
  347.             DESCR  = IRIGEL(3,I)
  348.             CORES2 = IPCOR2(I)
  349.             NLIGRD = NOELED(/1)
  350.             IF (ITYPEL.EQ.22) NLIGRD=1
  351.             IDEB=1
  352.             IF (ITYPEL.EQ.22) IDEB=2
  353.             DO  K=1,NUM(/2)
  354.                DO J=IDEB,NOELEP(/1)
  355.                   ITOPTS(NUM(NOELEP(J),K),COR2P(J),IMAT) =
  356.      &                 ITOPTS(NUM(NOELEP(J),K),COR2P(J),IMAT)
  357.      $                 + NLIGRD
  358.                ENDDO
  359.             ENDDO
  360.          ENDDO
  361.       ENDDO
  362.       NTOPTS=0
  363.       IF (ICHP.NE.0) THEN
  364.          SEGINI NTOPTS
  365.          SEGINI OTOPTS
  366.          MCHPOI=ICHP
  367.          SEGACT MCHPOI
  368.          NSOUPO=IPCHP(/1)
  369.          DO ISOUPO=1,NSOUPO
  370.             MSOUPO=IPCHP(ISOUPO)
  371.             SEGACT MSOUPO
  372.             MELEME=IGEOC
  373.             SEGACT MELEME
  374.             MPOVAL=IPOVAL
  375.             SEGACT MPOVAL
  376.             NC=NOCOMP(/2)
  377.             N=NUM(/2)
  378.             DO IC=1,NC
  379.                DO ILIGP=1,NLIGP
  380.                   IF (NOCOMP(IC).EQ.LISINP(ILIGP)) THEN
  381.                      IDK=ILIGP
  382.                      GOTO 304
  383.                   ENDIF
  384.                ENDDO
  385.                IDK=NLIGP+1
  386.  304           CONTINUE
  387.                DO 306 I=1,N
  388.                   IF (VPOCHA(I,IC).NE.0.D0) THEN
  389.                      LTOPTS(NUM(1,I),IDK)=.TRUE.
  390.                      XTOPTS(NUM(1,I),IDK)=VPOCHA(I,IC)
  391.                   ENDIF
  392.  306           CONTINUE
  393.             ENDDO
  394. *            SEGDES MPOVAL,MELEME,MSOUPO
  395.          ENDDO
  396. *         SEGDES MCHPOI
  397.       ELSE
  398.          SEGINI OTOPTS
  399.          DO ILIGP=1,NLIGP
  400.             DO IBPTS=1,NBPTS
  401.                LTOPTS(IBPTS,ILIGP)=.TRUE.
  402.             ENDDO
  403.          ENDDO
  404.       ENDIF
  405.       IF (LDBG) THEN
  406.          npo = MIN(nbpts,100)
  407.          WRITE(IOIMP,*) 'Point'
  408.          WRITE(IOIMP,2020) (II,II=1,npo)
  409.          do imat=1,nmat
  410.             do iligp=1,nligp
  411.                WRITE(IOIMP,*) ' Matrice ',imat,' inconnue ',LISINP(ILIGP
  412.      $              )
  413.                WRITE (IOIMP,2020) (ITOPTS(II,iligp,imat),II=1,npo)
  414.             enddo
  415.          enddo
  416.          if (ichp.ne.0) then
  417.             do iligp=1,nligp
  418.                WRITE(IOIMP,*) ' Chpoint  inconnue ',LISINP(ILIGP)
  419.                WRITE (IOIMP,2021) (LTOPTS(II,iligp),II=1,npo)
  420.                WRITE (IOIMP,2022) (XTOPTS(II,iligp),II=1,npo)
  421.             enddo
  422.          endif
  423.       ENDIF
  424. *
  425. *_______________________________________________________________________
  426. *
  427. *    calcul du nombre d'inconnues primales et creation de LESINC
  428. *    correspondance entre les inconnues et MCOEF
  429. *
  430. *
  431.       DO IMAT=1,NMAT
  432.          DO ILIGP=1,NLIGP
  433.             DO IBPTS=1,NBPTS
  434.                LTOPTS(IBPTS,ILIGP)=LTOPTS(IBPTS,ILIGP)
  435.      $              .AND.(ITOPTS(IBPTS,ILIGP,IMAT).NE.0)
  436.             ENDDO
  437.          ENDDO
  438.       ENDDO
  439.       NINC=0
  440.       DO ILIGP=1,NLIGP
  441.          DO IBPTS=1,NBPTS
  442.             IF (LTOPTS(IBPTS,ILIGP)) NINC=NINC+1
  443.          ENDDO
  444.       ENDDO
  445.       IF (LDBG) WRITE(IOIMP,*) 'NINC=',NINC
  446. *     On sort de manière anticipée s'il n'y a pas d'inconnues primales
  447. *     communes
  448.       IF (NINC.EQ.0) THEN
  449.          SEGSUP OTOPTS,MTOPTS
  450.          DO IMAT=1,NMAT
  451.             MRIGID=PNTOB(IMAT)
  452.             CORES1=PNTCOB(1,IMAT)
  453.             NRIGEL=IRIGEL(/2)
  454.             DO I=1,NRIGEL
  455.                MELEME = IRIGEL(1,I)
  456.                DESCR = IRIGEL(3,I)
  457. *               SEGDES MELEME,DESCR
  458.                CORES2=IPCOR2(I)
  459.                SEGSUP CORES2
  460.             ENDDO
  461.             SEGSUP CORES1
  462. *            SEGDES MRIGID
  463.          ENDDO
  464.          IF (NTOPTS.NE.0) SEGSUP NTOPTS
  465.          SEGSUP DESCOB,LSINCP,LSINCD
  466.          GOTO 9999
  467.       ENDIF
  468. *
  469.       DO IMAT=1,NMAT
  470.          DO ILIGP=1,NLIGP
  471.             DO IBPTS=1,NBPTS
  472.                IF (.NOT.LTOPTS(IBPTS,ILIGP)) THEN
  473.                   ITOPTS(IBPTS,ILIGP,IMAT)=0
  474.                ELSE
  475.                   ITOPTS(1,NLIGP+1,IMAT)=ITOPTS(1,NLIGP+1,IMAT)
  476.      $                 +ITOPTS(IBPTS,ILIGP,IMAT)
  477.                ENDIF
  478.             ENDDO
  479.          ENDDO
  480.       ENDDO
  481.       SEGSUP OTOPTS
  482.       IF (LDBG) THEN
  483.          do imat=1,nmat
  484.             do iligp=1,nligp
  485.                WRITE(IOIMP,*) ' Matrice ',imat,' inconnue ',LISINP(ILIGP
  486.      $              )
  487.                WRITE (IOIMP,2020) (ITOPTS(II,iligp,imat),II=1,npo)
  488.             enddo
  489.          enddo
  490.       ENDIF
  491. *
  492. *    on remplit LSINCO et LTINCO en numérotant les ddls dans l'ordre
  493. *    où ils sont rencontrés en parcourant la matrice la plus grosse.
  494. *    On pourrait les parcourir autrement (dans l'ordre de ITOPTS).
  495. *
  496.       IF (NMAT.EQ.2) THEN
  497.          NCOEF1=ITOPTS(1,NLIGP+1,1)
  498.          NCOEF2=ITOPTS(1,NLIGP+1,2)
  499.          IF (NCOEF1.GE.NCOEF2) THEN
  500.             IMAT1=1
  501.             IMAT2=2
  502.          ELSE
  503.             IMAT1=2
  504.             IMAT2=1
  505.          ENDIF
  506.       ELSE
  507.          NCOEF1=ITOPTS(1,NLIGP+1,1)
  508.          NCOEF2=0
  509.          IMAT1=1
  510.          IMAT2=0
  511.       ENDIF
  512.       IF (LDBG) THEN
  513.          WRITE(IOIMP,*) 'NCOEF1=',NCOEF1
  514.          WRITE(IOIMP,*) 'NCOEF2=',NCOEF2
  515.       ENDIF
  516.       MRIGID=PNTOB(IMAT1)
  517.       CORES1=PNTCOB(1,IMAT1)
  518.       NRIGEL=IRIGEL(/2)
  519.       SEGINI LSINCO
  520.       IF (ICHP.NE.0) THEN
  521.          SEGINI LTINCO
  522.       ELSE
  523.          LTINCO=0
  524.       ENDIF
  525.       IND1 = 1
  526.       IDUM1 = 1
  527.       IDUM2 = 1
  528.       DO 1600 I=1,NRIGEL
  529.          MELEME=IRIGEL(1,I)
  530.          DESCR=IRIGEL(3,I)
  531.          IDEB=1
  532.          IF (ITYPEL.EQ.22) IDEB=2
  533.          CORES2=IPCOR2(I)
  534.           DO 1500 K=1,NUM(/2)
  535.             DO 1400 J=IDEB,NOELEP(/1)
  536.                IF ( ITOPTS(NUM(NOELEP(J),K),COR2P(J),IMAT1).GT.0) THEN
  537.                   LESINC(IND1,1,IMAT1)=IDUM1
  538.                   IDUM1=IDUM1+ITOPTS(NUM(NOELEP(J),K),COR2P(J),IMAT1)
  539. *      ITOPTS va desormais contenir le numéro de l'inconnue dans LESINC
  540.                   ITOPTS(NUM(NOELEP(J),K),COR2P(J),IMAT1) = -1 * IND1
  541.                   IF(NMAT.EQ.2) THEN
  542.                      LESINC(IND1,1,IMAT2)=IDUM2
  543.                      IDUM2=IDUM2+ITOPTS(NUM(NOELEP(J),K),COR2P(J),IMAT2)
  544.                   ENDIF
  545.                   IF (ICHP.NE.0) THEN
  546.                      XMAS(IND1) = XTOPTS(NUM(NOELEP(J),K),COR2P(J))
  547.                   ENDIF
  548.                   IND1 = IND1 + 1
  549.                ENDIF
  550.  1400       CONTINUE
  551.  1500    CONTINUE
  552.  1600 CONTINUE
  553. *=====
  554.       if ( (IND1-1) .NE. NINC ) then
  555.          write(*,*) 'erreur dans boucle lsinco'
  556.       endif
  557. *======
  558.       LESINC(IND1,1,IMAT1)=IDUM1
  559.       IF (NMAT.EQ.2) LESINC(IND1,1,IMAT2)=IDUM2
  560.       IF (LDBG) THEN
  561.          WRITE(IOIMP,*) 'IDUM1=',IDUM1
  562.          WRITE(IOIMP,*) 'IDUM2=',IDUM2
  563.          naff=min(ninc,100)
  564.          do 2004 k=1,nmat
  565.             write(*,*) 'k=',k
  566.             do 2002 i=1,naff+1
  567.                write(*,2003) i,lesinc(i,1,k),lesinc(i,2,k)
  568.  2002       continue
  569.  2004    continue
  570.       ENDIF
  571. *
  572. *_______________________________________________________________________
  573. * remplissage de MCOEF
  574. *
  575. *
  576.       DO IMAT=1,NMAT
  577.          MRIGID=PNTOB(IMAT)
  578.          CORES1=PNTCOB(1,IMAT)
  579.          NRIGEL=IRIGEL(/2)
  580.          NCOEF=LESINC(NINC+1,1,IMAT)-1
  581.          SEGINI MCOEF
  582.          DO 1900 I=1,NRIGEL
  583.             MELEME = IRIGEL(1,I)
  584.             DESCR  = IRIGEL(3,I)
  585.             CORES2 = IPCOR2(I)
  586.             XMATRI = IRIGEL(4,I)
  587.             SEGACT XMATRI
  588.             IDEB=1
  589.             IF (ITYPEL.EQ.22) IDEB=2
  590.             NLIGRD=NOELED(/1)
  591.             IF (ITYPEL.EQ.22) NLIGRD=1
  592.             DO 1800 K=1,NUM(/2)
  593.                DO 1700 J=IDEB,NOELEP(/1)
  594.                   NNINC = -1 * ITOPTS(NUM(NOELEP(J),K),COR2P(J),IMAT1)
  595.                   IF (NNINC.NE.0) THEN
  596.                      DO 1650 L=1,NLIGRD
  597.                         IDMCOE = LESINC(NNINC,1,IMAT)
  598.      $                       +LESINC(NNINC,2,IMAT)
  599.                         LESINC(NNINC,2,IMAT) = LESINC(NNINC,2,IMAT) + 1
  600.                         ICOEF(1,IDMCOE)=NUM(NOELED(L),K)
  601.                         ICOEF(2,IDMCOE)=COR2D(L)
  602.                         XCOEF(IDMCOE)=RE(L,J,k)*COERIG(I)
  603.  1650                CONTINUE
  604.                   ENDIF
  605.  1700          CONTINUE
  606.  1800       CONTINUE
  607. *  on referme la boutique
  608. *            SEGDES XMATRI
  609.             SEGSUP CORES2
  610.  1900    CONTINUE
  611. *  on referme encore la boutique car meleme et descr
  612. *  peuvent être les mêmes pour plusieurs IRIGEL
  613.          DO 2000 I=1,NRIGEL
  614.             MELEME = IRIGEL(1,I)
  615.             DESCR = IRIGEL(3,I)
  616. *            SEGDES MELEME,DESCR
  617.  2000    CONTINUE
  618.          SEGSUP CORES1
  619. *         SEGDES MRIGID
  620. *
  621. *=====
  622.          IF (LDBG) THEN
  623.             naff = min(ncoef,100)
  624.             do 2005 i=1,naff
  625.                write(*,2003) i,icoef(1,i),icoef(2,i),xcoef(i)
  626.  2005       continue
  627.          ENDIF
  628. *=====
  629.          PNTCOB(3,IMAT)=MCOEF
  630.       ENDDO
  631.       SEGSUP MTOPTS
  632. *------------------------
  633. * Il faut maintenant compacter le MCOEF car le même ddl dual peut
  634. * apparaître plusieurs fois pour une même inconnue primale (ce n'était
  635. * pas le cas anciennement car les ddls duaux étaient des multiplicateurs
  636. * de lagrange supposés uniques (un par relation))
  637. *
  638.       IF (LTYP22) GOTO 755
  639.       DO IMAT=1,NMAT
  640.          MCOEF=PNTCOB(3,IMAT)
  641.          DO IINC=1,NINC
  642.             IDEB=LESINC(IINC,1,IMAT)
  643.             IFIN=IDEB+LESINC(IINC,2,IMAT)-1
  644.             DO I=IDEB,IFIN
  645.                IC1=ICOEF(1,I)
  646.                IC2=ICOEF(2,I)
  647.                IF (IC1.NE.0) THEN
  648.                   DO J=I+1,IFIN
  649.                      JC1=ICOEF(1,J)
  650.                      JC2=ICOEF(2,J)
  651.                      IF (JC1.EQ.IC1.AND.JC2.EQ.IC2) THEN
  652.                         XCOEF(I)=XCOEF(I)+XCOEF(J)
  653.                         ICOEF(1,J)=0
  654.                      ENDIF
  655.                   ENDDO
  656.                ENDIF
  657.             ENDDO
  658.          ENDDO
  659. *=====
  660.          IF (LDBG) THEN
  661.             WRITE(IOIMP,*) 'COMPACTAGE 1'
  662.             naff = min(ncoef,100)
  663.             do i=1,naff
  664.                write(*,2003) i,icoef(1,i),icoef(2,i),xcoef(i)
  665.             enddo
  666.          ENDIF
  667. *=====
  668.          IDECG=0
  669.          IDEB=LESINC(1,1,IMAT)
  670.          DO IINC=1,NINC
  671.             IFIN=IDEB+LESINC(IINC,2,IMAT)-1
  672.             IDECL=0
  673.             DO I=IDEB,IFIN
  674.                IF (ICOEF(1,I).EQ.0) THEN
  675.                   IDECL=IDECL+1
  676.                ELSE
  677.                   ICOEF(1,I-IDECG-IDECL)=ICOEF(1,I)
  678.                   ICOEF(2,I-IDECG-IDECL)=ICOEF(2,I)
  679.                   XCOEF(I-IDECG-IDECL)=XCOEF(I)
  680.                ENDIF
  681.             ENDDO
  682.             LESINC(IINC,2,IMAT)=LESINC(IINC,2,IMAT)-IDECL
  683.             IDEB=LESINC(IINC+1,1,IMAT)
  684.             IDECG=IDECG+IDECL
  685.             LESINC(IINC+1,1,IMAT)=LESINC(IINC+1,1,IMAT)-IDECG
  686.          ENDDO
  687.          NCOEF=LESINC(NINC+1,1,IMAT)-1
  688.          SEGADJ MCOEF
  689.          IF (LDBG) THEN
  690.             WRITE(IOIMP,*) 'NCOEF=',NCOEF
  691.             WRITE(IOIMP,*) 'COMPACTAGE 2'
  692.             naff=min(ninc,100)
  693.             do i=1,naff+1
  694.                k=imat
  695.                write(*,2003) i,lesinc(i,1,k),lesinc(i,2,k)
  696.             enddo
  697.             naff = min(ncoef,100)
  698.             do i=1,naff
  699.                write(*,2003) i,icoef(1,i),icoef(2,i),xcoef(i)
  700.             enddo
  701.          ENDIF
  702.       ENDDO
  703.  755  CONTINUE
  704. *_______________________________________________________________________
  705. *
  706. *   il ne reste plus qu' a creer les matrices élémentaires
  707. *
  708.       CALL CMCT3B(DESCOB,LSINCO,LTINCO,LSINCD,IRIG2)
  709.       IF (IERR.NE.0) RETURN
  710.       IRIG2.IFORIG=IFO2
  711. *
  712.       if (LDBG) THEN
  713.          write(ioimp,*) 'Matrice CMBT'
  714.          call prrigi(irig2,1)
  715.       endif
  716. *
  717. * Ménage
  718. *
  719.  
  720.       DO IMAT=1,NMAT
  721.          MCOEF=PNTCOB(3,IMAT)
  722.          SEGSUP MCOEF
  723.       ENDDO
  724.       SEGSUP LSINCO
  725.       IF (LTINCO.NE.0) SEGSUP LTINCO
  726.       SEGSUP LSINCP
  727.       SEGSUP LSINCD
  728.       SEGSUP DESCOB
  729.       RETURN
  730. *
  731. *   Rigidité vide si pas de ddls primaux communs entre les
  732. *   objets d'entrée
  733. *
  734.  9999 CONTINUE
  735.       NRIGEL=0
  736.       SEGINI MRIGID
  737.       MTYMAT='CMCT    '
  738.       IFORIG=IFOUR
  739.       IRIG2=MRIGID
  740. *
  741.  2003 format(I4,1X,I4,1X,I4,2X,E12.5)
  742.  2019 FORMAT (20(2X,A4) )
  743.  2020 FORMAT (20(2X,I4) )
  744.  2021 FORMAT (20(2X,L4) )
  745.  2022 FORMAT(10(1X,1PG12.5))
  746. *_______________________________________________________________________
  747.       RETURN
  748.       END
  749.  
  750.  

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