Télécharger la plaquette Cast3M


fr en

Télécharger supmas.eso

Retour à la liste

Numérotation des lignes : 

supmas

  1. C SUPMAS    SOURCE    PV090527  24/10/22    21:15:04     12043          
  2.       SUBROUTINE SUPMAS
  3. c
  4. c   sous routine pour calculer la masse
  5. c   sur les ddl maitres d'un super element
  6. c   option MASS de SUPE
  7. c
  8. c   Pierre Pegon (CCR d'Ispra), Juin 1997
  9. c
  10. c   l'option LCHP permet d'avoir les vecteurs de MSUPCH dans un LCHPO
  11. c
  12. c
  13.       IMPLICIT INTEGER(I-N)
  14.       IMPLICIT REAL*8(A-H,O-Z)
  15. c
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC SMELEME
  20. -INC SMRIGID
  21. -INC SMSUPER
  22. -INC SMMATRI
  23. -INC SMVECTD
  24. -INC SMCHPOI
  25. -INC TMTRAV
  26. c
  27.       CHARACTER*4 INCL
  28. c
  29.       SEGMENT MSUPCH(NBINMA)
  30.       SEGMENT ISECO(LL)
  31.       SEGMENT VSE(LL)*D
  32. c
  33. -INC SMLCHPO
  34.       PARAMETER(NOLIS=1)
  35.       CHARACTER*4 MOLIS(NOLIS)
  36.       DATA MOLIS/'LCHP'/
  37. c
  38. c *** lecture des objets en entre
  39. c
  40.       CALL LIROBJ ('SUPERELE',MSUPER,1,IRETOU)
  41.       IF(IERR.NE.0) RETURN
  42.       CALL LIROBJ ('RIGIDITE',RI2,1,IRETOU)
  43.       IF(IERR.NE.0) RETURN
  44. c
  45. c *** option LCHP
  46. c
  47.       CALL LIRMOT(MOLIS,NOLIS,LCHP,0)
  48.       SEGACT MSUPER*MOD
  49.  
  50. *  cas degenere
  51.         IF (MSURAI.EQ.MRIGTO) THEN
  52.         CALL ECROBJ('RIGIDITE',RI2)
  53.         RETURN
  54.       ENDIF
  55.  
  56.  
  57. c
  58. c *** mcrout contient la decomposition modifiee de la rigidite
  59. c
  60.       MMATRI=MCROUT
  61.  
  62.  
  63.  
  64.  
  65. c
  66. c *** dimension de la matrice condensee
  67. c
  68.       MRIGID=MSURAI
  69.       SEGACT MRIGID
  70.       xMATRI=IRIGEL(4,1)
  71.       MOHAR=IRIGEL(5,1)
  72.       SEGACT xMATRI
  73. *      XMATRI=IMATTT(1)
  74. *      SEGACT XMATRI
  75.       NLIGRA=RE(/1)
  76.       SEGDES XMATRI*NOMOD
  77. *      SEGDES IMATRI*NOMOD
  78.       SEGDES MRIGID*NOMOD
  79. c
  80. c *** autres dimensions
  81. c
  82.       SEGACT MMATRI
  83.       MILIGN=IILIGN
  84.       SEGACT MILIGN
  85.       NBNNMA=IPNO(/1)-NLIGRA
  86.       NNOEU=ILIGN(/1)
  87.       MINCPO=IINCPO
  88.       SEGACT MINCPO
  89.       MDNOR=IDNORM
  90.       SEGACT MDNOR
  91. c
  92. c *** lecture de la geometrie et du descripteur lies a
  93. c     la matrice de rigidite complete
  94. c
  95.       IPT1=IGEOMA
  96.       SEGACT IPT1
  97.       MIDUA=IIDUA
  98.       MIMIK=IIMIK
  99.       SEGACT MIDUA,MIMIK
  100. c
  101. c *** on cherche a partir de ou commence les ligne au dela de NBNNMA
  102. c     et on en profite pour activer TOUTES les lignes
  103. c
  104.       I1=0
  105.       ILA=0
  106.       DO I=1,NNOEU
  107.         LIGN=ILIGN(I)
  108.         SEGACT LIGN
  109.         NA=IMMM(/1)
  110.         ILA=ILA+NA
  111.         IF(ILA.GT.NBNNMA.AND.I1.EQ.0) THEN
  112.           I1=I
  113.           ILA1=ILA-NA
  114.         ENDIF
  115.       ENDDO
  116. c
  117. c *** creation du segment de travail et debut de son remplissage
  118. c
  119.       NNNOE=IPT1.NUM(/2)
  120.       NNIN=IMIK(/2)
  121.       SEGINI MTRAV
  122.       DO I=1,NNNOE
  123.         IGEO (I)=IPT1.NUM(1,I)
  124.       ENDDO
  125.       DO I=1,NNIN
  126.         INCO(I)=IMIK(I)
  127.         NHAR(I)=MOHAR
  128.       ENDDO
  129.       DO I=1,NNNOE
  130.         DO J=1,NNIN
  131.           NUM1=INCPO(J,I)
  132.           IF (NUM1.NE.0) IBIN(J,I)=1
  133.         ENDDO
  134.       ENDDO
  135. c
  136. c *** on initialise le segment des chpo "intermediaires de calcul"
  137. c     que l'on va remplir successivement avec le vecteur formant les
  138. c     ligne de la matrice rectangulaire [ -R*(L**-1) I ]
  139. c
  140.       NBINMA=NLIGRA
  141.       SEGINI MSUPCH
  142. c
  143. c *** on loop sur les lignes qui represente R ...
  144. c
  145.       INC=IPNO(/1)
  146.       SEGINI,MVECTD
  147. c
  148.       DO INOEUD=I1,NNOEU
  149.         LIG1=ILIGN(INOEUD)
  150.         NA1=LIG1.IMMM(/1)
  151.         IDEB1=1
  152.         LPREC1=0
  153.         DO IDDL=1,NA1
  154.           ILA1=ILA1+1
  155.           IF(ILA1.LE.NBNNMA)GOTO 50
  156. c
  157. c *** ... et on remplie VECTBB avec EN CHANGEANT LE SIGNE
  158. c
  159.           CALL ZERO(VECTBB,1,INC)
  160.           IFIN1=LIG1.IPPVV(IDDL+1)-1
  161.           IDEB21=LIG1.IVPO(2*IDEB1)
  162.           LONG1=LIG1.IVPO(2*(IFIN1+1)-1)-LIG1.IVPO(2*IDEB1-1)
  163.           IPRECOL1=ILA1-LONG1
  164.           DO INDIC1=IDEB1,IFIN1
  165.             IFIN21=LIG1.IVPO(2*(INDIC1+1))-1
  166.             ICOL1=LIG1.IVPO(2*INDIC1-1)+IPRECOL1-LPREC1
  167.             IF (ICOL1.GT.NBNNMA) GOTO 1
  168.             DO K1=IDEB21,IFIN21
  169.               VECTBB(ICOL1)=-LIG1.VAL(K1)
  170.               ICOL1=ICOL1+1
  171.               IF(ICOL1.GT.NBNNMA) GOTO 1
  172.             ENDDO
  173.             IDEB21=IFIN21+1
  174.           ENDDO
  175.  1        CONTINUE
  176. c
  177. c *** on de-normalise la ligne
  178. c
  179.           XNORM1=DNOR(ILA1)
  180.           DO I=1,NBNNMA
  181.             VECTBB(I)=VECTBB(I)/XNORM1
  182.           ENDDO
  183. c
  184. c *** on resout avec L transpose sur ce vecteur ("MOND1")
  185. c
  186.           ILA=NBNNMA+NLIGRA+1
  187. c
  188.           DO I=NNOEU,1,-1
  189.             LIGN=ILIGN(I)
  190.             NA=IMMM(/1)
  191.             IFIB=IVPO(/1)
  192.             IF(ILA-NA.GT.NBNNMA)THEN
  193.               ILA=ILA-NA
  194.               GOTO 5
  195.             ENDIF
  196.             IMOI1=IVPO(2*IPPVV(NA+1)-1)
  197.             DO J=NA,1,-1
  198.               ILA=ILA-1
  199.               IDEB2=IPPVV(J)*2
  200.               IMOI2=IVPO(IDEB2-1)
  201.               LLOM=IMOI1-IMOI2-1
  202.               IF (LLOM.LE.0)GOTO 3
  203.               IF (ILA.GT.NBNNMA)GOTO 3
  204.               IPOSM=IMOI2-1
  205.               VKON=VECTBB(ILA)
  206.               IPLAC=IVPO(IDEB2)-1
  207.               IDEBZ=1
  208.               IPLAC2=ILA-LLOM-1
  209.               DO IDEB3=IDEB2,IFIB-1,2
  210.                 IMOI = IVPO ( IDEB3+2 )
  211.                 ILONZ=IMOI -IPLAC-IDEBZ
  212.                 IPLAC=IPLAC-IPLAC2
  213.                 IDEBZC=IDEBZ+IPLAC2
  214.                 DO K=IDEBZC,MIN(IDEBZC+ILONZ,ILA)-1
  215.                   VECTBB(K)=VECTBB(K)-VKON*VAL(IPLAC+K)
  216.                 ENDDO
  217.                 IF (IDEBZ.GE.LLOM) GOTO 3
  218.                 IDEBZ=IVPO(IDEB3+1)-IPOSM
  219.                 IPLAC=IMOI-IDEBZ
  220.               ENDDO
  221.  3            CONTINUE
  222.               IMOI1=IMOI2
  223.             ENDDO
  224.  5          CONTINUE
  225.           ENDDO
  226. c
  227. c *** on normalise la colonne resultat
  228. c
  229.           XNORM1=DNOR(ILA1)
  230.           DO I=1,NBNNMA
  231.             VECTBB(I)=VECTBB(I)*DNOR(I)
  232.           ENDDO
  233. c
  234. c *** on met 1 en position ILA1
  235. c
  236.           VECTBB(ILA1)=1.D0
  237. c
  238. c *** on cree le chpoint resultat
  239. c
  240.           DO I=1,NNNOE
  241.             DO J=1,NNIN
  242.               NUM1=INCPO(J,I)
  243.               IF (NUM1.NE.0) BB(J,I)=VECTBB(NUM1)
  244.             ENDDO
  245.           ENDDO
  246.           CALL CRECHP(MTRAV,ISOLU)
  247.           SEGACT MTRAV*MOD
  248. c
  249. c *** ce champ de nature discrete est stocke dans MSUPCH
  250. c
  251.           MCHPOI = ISOLU
  252.           SEGACT,MCHPOI*MOD
  253.           JATTRI(1)=2
  254.           SEGDES MCHPOI
  255.           MSUPCH(ILA1-NBNNMA)=MCHPOI
  256. c
  257. c *** fin de la boucle sur les lignes representant R
  258. c
  259.  50       CONTINUE
  260.           IDEB1=IFIN1+1
  261.           LPREC1=LPREC1+LONG1
  262.         ENDDO
  263.       ENDDO
  264. c
  265. c *** desactivations diverses et variees
  266. c
  267.       DO I=1,NNOEU
  268.         LIGN=ILIGN(I)
  269.         SEGDES LIGN*NOMOD
  270.       ENDDO
  271.       SEGDES MIDUA*NOMOD,MIMIK*NOMOD
  272.       SEGDES MDNOR*NOMOD
  273.       SEGDES MINCPO*NOMOD
  274.       SEGDES MILIGN*NOMOD
  275.       SEGDES IPT1
  276.       SEGDES MMATRI*NOMOD
  277.       SEGSUP MVECTD,MTRAV
  278. c
  279. c *** on attaque la condensation de la masse que l'on trouve
  280. c     en effectuant les produits scalaires entre V et M*W ou
  281. c     V et W sont des vecteurs de MSUPCH
  282. c
  283.       RI1=MSURAI
  284.       SEGACT RI1
  285.       SEGINI,MRIGID=RI1
  286.       SEGDES RI1
  287.       MTYMAT='MASSE'
  288.       NELRIG=1
  289.       LL=MSUPCH(/1)
  290.       SEGINI ISECO,VSE
  291.       DO IH=1,LL
  292.         ISECO(IH)=MSUPCH(IH)
  293.       ENDDO
  294.       NLIGRP=LL
  295.       NLIGRD=LL
  296.       SEGINI XMATRI
  297. *      SEGINI IMATRI
  298. *      IMATTT(1)=XMATRI
  299.       DO J=1,LL
  300.         SEGACT ISECO
  301.         MCH1= ISECO(J)
  302.         SEGDES ISECO,VSE
  303.         CALL YTMXMU(MCH1,ISECO,J,RI2,VSE)
  304.         SEGACT VSE
  305.         DO  K=1,J
  306.           RE(J,K,1)=VSE(K)
  307.           RE(K,J,1)=VSE(K)
  308.         ENDDO
  309.       ENDDO
  310.       SEGDES XMATRI
  311. *      SEGDES IMATRI
  312.       IRIGEL(4,1)=xMATRI
  313.       ICHOLE=0
  314.       SEGDES MRIGID
  315.       MSUMAS=MRIGID
  316.       CALL ECROBJ('RIGIDITE',MSUMAS)
  317. c
  318. c *** on fait le menage
  319. c
  320.       SEGDES MSUPER
  321.       SEGSUP ISECO,VSE
  322. c
  323. c *** option LCHP ou non
  324. c
  325.       IF(LCHP.EQ.1)THEN
  326.         N1=NBINMA
  327.         SEGINI MLCHPO
  328.         DO I=1,NBINMA
  329.           MCHPOI=MSUPCH(I)
  330.           ICHPOI(I)=MCHPOI
  331.           SEGDES MCHPOI
  332.         ENDDO
  333.         SEGDES MLCHPO
  334.         CALL ECROBJ('LISTCHPO',MLCHPO)
  335.       ELSE
  336.         DO I=1,NBINMA
  337.           MCHPOI=MSUPCH(I)
  338.           CALL DTCHPO(MCHPOI)
  339.         ENDDO
  340.       ENDIF
  341.       SEGSUP MSUPCH
  342. c
  343. c *** au revoir
  344. c
  345.       RETURN
  346.       END
  347.  
  348.  
  349.  
  350.  
  351.  
  352.  
  353.  
  354.  
  355.  
  356.  

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