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

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