Télécharger la plaquette Cast3M


fr en

Télécharger xtmx.eso

Retour à la liste

Numérotation des lignes : 

xtmx

  1. C XTMX      SOURCE    CB215821  20/11/25    13:43:32     10792          
  2.       SUBROUTINE XTMX(IRE1,IRE2,VA)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.       REAL*8 VA,COER,VB,XTMXMU
  6. C
  7. C  ****  MULTIPLICATION D'UNE MATRICE(IRE2) PAR UN CHAMPPOINT (IRE1) A
  8. C  ****  DROITE ET A GAUCHE.LE RESULTAT EST UN FLOTTANT.
  9. C  ****  VA=    IRE1 *IRE2 *IRE1
  10. C  ****  POUR EFFECTUER L OPERATION ON ELIMINE LES COMPOSANTES LX
  11. C  ****  DU CHPOINT ET DE LA MATRICE. ON TESTE QUE LES AUTRES INCONNUES
  12. C  ****  DU CHPOINT SONT INCLUSES DANS CELLES DE L OBJET RIGIDITE.
  13. C  ON SUPPOSE QUE :
  14. C   1. YT ET X SONT DE MEME TYPE
  15. C   2. LA MATRICE EST CARREE
  16. C   3. LA MATRICE POSSEDE DES CORRESPONDANCES SUR LES INCONNUES
  17. C      (C'EST A DIRE QUE LA IEME LIGNE EST LA DUALE DE LA IEME COLONNE)
  18. C
  19. C   BP , avril 2010 : on supprime l hypothese 3.
  20. C  (pour permettre l utilisation de matrices crees par imped par ex.)
  21. C
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. -INC CCREEL
  26. -INC SMELEME
  27. -INC SMCHPOI
  28. -INC SMRIGID
  29. -INC SMCOORD
  30. -INC CCHAMP
  31. c
  32.       CHARACTER*(LOCOMP) NI,INCOM
  33.       SEGMENT,IHAR(0)
  34.       SEGMENT,SIINC
  35.        CHARACTER*(LOCOMP) IINC(0)
  36.       ENDSEGMENT
  37.       SEGMENT/ICCPR/(ICPR(NNGOT))
  38.       SEGMENT ITRAV
  39.        CHARACTER*(LOCOMP) IINCO(NNIN)
  40.        REAL*8 CC(NLIGMA),VAA(NNIN,ITES),DD(NLIGMA)
  41.        INTEGER IPOS(NLIGMA)
  42.        INTEGER IPOS2(NLIGMA)
  43.       ENDSEGMENT
  44.       LOGICAL   NEEDDD
  45.  
  46. C ITES = NONBRE DE NOEUD DU CHPOINT
  47. C NLIGMA = TAILLE MAX D'UNE LIGNE DE MATRICE DE RIGIDITE ELEMENTAIRE
  48.  
  49. C **** INITIALISATION DU RESULTAT
  50.       VA=0.D0
  51.       MRIGID=IRE2
  52.       MCHPOI=IRE1
  53.       NNGOT=nbpts
  54. C
  55. C  ****  ON CREE LES TABLEAUX :
  56. C
  57. C  ****  ICPR(I)=J VEUT DIRE QUE LE NOEUD I A LE NUMERO LOCAL J.
  58. C
  59.       SEGINI,ICCPR
  60.       SEGACT,MCHPOI
  61.       NSOUPO=IPCHP(/1)
  62.       IK=0
  63.       DO 1 ISOU=1,NSOUPO
  64.       MSOUPO=IPCHP(ISOU)
  65.       SEGACT,MSOUPO
  66.       MELEME=IGEOC
  67.       SEGACT,MELEME
  68.       N1=NUM(/1)
  69.       N2=NUM(/2)
  70.       DO 2 I2=1,N2
  71.       K=NUM(1,I2)
  72. *     on ajoute le noeud K a ICPR(K) si pas deja vu
  73.       IF(ICPR(K).NE.0)  GO TO 2
  74.       IK=IK+1
  75.       ICPR(K)=IK
  76.    2  CONTINUE
  77. C     SEGDES,MELEME
  78. C     SEGDES,MSOUPO
  79.    1  CONTINUE
  80. C     SEGDES,MCHPOI
  81.  
  82.       ITES=IK
  83.       NLIGMA=0
  84.  
  85. C  **** REMPLISSAGE DE IINC et IHAR
  86. C       = couple(inconnue primale + harmonique) de la matrice MRIGID
  87.       SEGINI,SIINC
  88.       SEGINI,IHAR
  89. *
  90.       SEGACT,MRIGID
  91.       NRIGE=IRIGEL(/1)
  92.       NRIGEL=IRIGEL(/2)
  93.       DESCR=IRIGEL(3,1)
  94.       SEGACT,DESCR
  95. *     Initialisation de la 1ere valeur
  96.       IINC(**)=LISINC(1)
  97.       IHAR(**)=IRIGEL(5,1)
  98.       ININC=1
  99. *     boucle sur les rigidites elementaires
  100.       DO 3 IRI=1,NRIGEL
  101.         MELEME=IRIGEL(1,IRI)
  102.         SEGACT,MELEME
  103.         DESCR=IRIGEL(3,IRI)
  104.         NOHAR=IRIGEL(5,IRI)
  105.         SEGACT,DESCR
  106.         NLIGRE=LISINC(/2)
  107.         IF(NLIGRE.GT.NLIGMA) NLIGMA=NLIGRE
  108.         DO 7 I2=1,NLIGRE
  109.         DO 8 I1=1,ININC
  110.         IF(LISINC(I2).NE.IINC(I1)) GO TO 8
  111.         IF(NOHAR.EQ.IHAR(I1)) GO TO 7
  112.    8    CONTINUE
  113.         IINC(**)=LISINC(I2)
  114.         IHAR(**)=NOHAR
  115.         ININC=ININC+1
  116.    7    CONTINUE
  117. C     SEGDES,DESCR
  118. C     SEGDES,MELEME
  119.    3  CONTINUE
  120. C     SEGDES,MRIGID
  121. C
  122. C  ****  ON INITIALISE LE SEGMENT ITRAV
  123. C
  124.       NNIN=ININC
  125.       SEGINI,ITRAV
  126.       DO 10 I=1,NNIN
  127.         IINCO(I)=IINC(I)
  128.    10 CONTINUE
  129. C
  130. C  ****  ON INITIALISE VAA (= chpoint)
  131. C     SEGACT,MCHPOI
  132.       NSOUPO=IPCHP(/1)
  133. c --- boucle sur les zones ---
  134.       DO 15 ISOU=1,NSOUPO
  135.         MSOUPO=IPCHP(ISOU)
  136. C       SEGACT,MSOUPO
  137.         MELEME=IGEOC
  138. C       SEGACT,MELEME
  139.         N2=NUM(/2)
  140.         NC=NOCOMP(/2)
  141.         MPOVAL=IPOVAL
  142.         SEGACT,MPOVAL
  143. c    -- boucle sur les composantes --
  144.         DO 16 INC=1,NC
  145.           INCOM=NOCOMP(INC)
  146.           NOHA=NOHARM(INC)
  147.           DO 17 IH=1,NNIN
  148.             IF(INCOM.NE.IINCO(IH)) GO TO 17
  149.             IF(IHAR(IH).EQ.NOHA)  GO TO 18
  150.    17     CONTINUE
  151.           GO TO 16
  152. c         on a trouvé le bon couple inconnue primale+harmonique : IH
  153.    18   CONTINUE
  154.         DO 19 I2=1,N2
  155.           IK=ICPR(NUM(1,I2))
  156.           VAA(IH,IK)= VPOCHA(I2,INC)
  157.    19   CONTINUE
  158.    16   CONTINUE
  159.    15 CONTINUE
  160. C
  161. C  ****  BOUCLE 20 SUR LES OBJETS RIGIDITES ELEMENTAIRES
  162. C
  163. C     SEGACT,MRIGID
  164.       DO 20 IRI=1,NRIGEL
  165.          IANTI=0
  166.          IF (NRIGE.GE.7) THEN
  167.             IANTI=IRIGEL(7,IRI)
  168.          ENDIF
  169.          MELEME=IRIGEL(1,IRI)
  170.          NOHA=IRIGEL(5,IRI)
  171.          SEGACT,MELEME
  172.          DESCR=IRIGEL(3,IRI)
  173.          SEGACT,DESCR
  174. C
  175. C    ** ON VERIFIE QUE:
  176. C      -LA MATRICE EST CARREE
  177.         LISI=LISINC(/2)
  178.         LISD=LISDUA(/2)
  179.         IF ( LISI.NE.LISD) THEN
  180.           CALL ERREUR(21)
  181.           RETURN
  182.         ENDIF
  183. C      -NOELED ET NOELEP SONT LES MEMES
  184.         DO ITEFR=1,LISI
  185.           IF( NOELED(ITEFR).NE.NOELEP(ITEFR) ) THEN
  186.             CALL ERREUR(21)
  187.             RETURN
  188.           ENDIF
  189.         ENDDO
  190. C
  191. C    ** ON REMPLIT IPOS(I)=J QUI DIT QUE LA IEME INCONNUE PRIMALE
  192. C       DE LA MATRICE ELEMENTAIRE EST LA JEME DE IINC
  193.          DO 21 IN=1,LISI
  194.             NI=LISINC(IN)
  195.             DO 22 IJ=1,ININC
  196.                IF(NI.NE.IINC(IJ))  GO TO 22
  197.                IF(NOHA.EQ.IHAR(IJ))  GO TO 23
  198.  22         CONTINUE
  199.  23         CONTINUE
  200.             IPOS(IN)=IJ
  201.  21      CONTINUE
  202. C
  203. C    ** ON ETABLIT LA CORRESPONDANCE INCONNUES PRIMALES ET DUALES
  204. C       (important si hypothèse 3 non vérifiée)
  205. C    ** ON REMPLIT IPOS2(I)=J QUI DIT QUE LA IEME INCONNUE DUALE
  206. C       DE LA MATRICE ELEMENTAIRE EST "NATURELLEMENT" ASSOCIEE A LA
  207. C       JEME INCONNUE PRIMALE DE IINC
  208. C    ** NEEDD nous dit si on a besoin de DD et de IPOS2
  209.         NEEDDD=.false.
  210.         if(IIMPI.ge.5) write(6,*) 'Pour la rigidite elementaire ',IRI
  211.         DO IN=1,LISI
  212.            NI=LISDUA(IN)
  213.            if(IIMPI.ge.5)
  214.      &     write(6,*) 'l inconnue primale ',LISINC(IN),
  215.      &                ' produit le dual ',NI
  216.            do idu=1,LNOMDU
  217.               if(NOMDU(idu).eq.NI) goto 25
  218.            enddo
  219.            write(6,*) 'ERREUR : NOM D INCONNUE DUALE INCONNUE',NI
  220.            CALL ERREUR(21)
  221.            return
  222.  25        continue
  223. c          on a trouve le numero du dual -> on en deduit le primal
  224. C          "naturellement" associé pour le produit scalaire
  225. c          il faut le chercher dans le chpoint VBB cad dans IINC
  226.            NI=NOMDD(idu)
  227.            DO 26 IJ=1,ININC
  228.               IF(NI.NE.IINC(IJ))  GO TO 26
  229.               IF(NOHA.EQ.IHAR(IJ))  GO TO 27
  230.  26        CONTINUE
  231.            write(6,*) 'ERREUR : NOM D INCONNUE PRIMALE INCONNUE',NI
  232.            CALL ERREUR(21)
  233.            return
  234.  27        CONTINUE
  235.            IPOS2(IN)=IJ
  236.            if(IJ.ne.IPOS(IN)) NEEDDD=.true.
  237.         ENDDO
  238.  
  239. C
  240. C  ****  BOUCLE 30 SUR LES PETITES MATRICES D'UNE RIGIDITE ELEMENTAIRE
  241. C
  242.          N1=NUM(/1)
  243.          N2=NUM(/2)
  244.          xMATRI=IRIGEL(4,IRI)
  245.          COER=COERIG(IRI)
  246.          SEGACT,xMATRI
  247.          DO 30 I2=1,N2
  248. C
  249. C       **  AVANT D'EFFECTUER LE PRODUIT ON VERIFIE QU'IL EST A FAIRE
  250.             DO 31 I1=1,N1
  251.                IF(ICPR(NUM(I1,I2)).NE.0) GO TO 32
  252.  31         CONTINUE
  253.             GO TO 30
  254.  32         CONTINUE
  255. C
  256. C       **  FABRICATION D'UN (ou de 2) VECTEUR(s) ISSU(s) DU CHPOINT
  257.             CALL XTMXMP(LISI,CC,ICPR,NUM,I2,NOELEP,IPOS,VAA,NNIN,N1)
  258.             if(NEEDDD)
  259.      &      CALL XTMXMP(LISI,DD,ICPR,NUM,I2,NOELEP,IPOS2,VAA,NNIN,N1)
  260. C     DO 34 IN=1,LISI
  261. C 34  CC(IN)=0.D0
  262. C     DO 33 IN=1,LISI
  263. C     J2=ICPR(NUM(NOELEP(IN),I2))
  264. C     IF(J2.EQ.0) GO TO 33
  265. C     J1=IPOS(IN)
  266. C     CC(IN)=VAA(J1,J2)
  267. C  33 CONTINUE
  268. C
  269. C  **** BOUCLE 35 SUR LES LIGNES D'UNE MATRICE ELEMENTAIRE
  270. *            XMATRI=IMATTT(I2)
  271. *            SEGACT,XMATRI
  272.             if (NEEDDD) then
  273.               DO 35 IN=1,LISI
  274. *               IF (ABS(DD(IN)).GT.1.D-10) THEN
  275.                 IF (ABS(DD(IN)).GT.XPETIT) THEN
  276.                      VB=0.D0
  277. C                 ** BOUCLE 38 SUR LES COLONNES D'UNE MATRICE ELEMENTAIRE
  278.                      DO 38 JN=1,LISI
  279.                            VB=VB+CC(JN)*RE(IN,JN,i2)
  280.  38                  CONTINUE
  281.                      VA=VA+ DD(IN)*VB*COER
  282.                 ENDIF
  283.  35           CONTINUE
  284.             else
  285.               VA = VA + XTMXMU(CC,RE(1,1,i2),LISI,IANTI)*COER
  286.             endif
  287. *           SEGDES,XMATRI
  288.  30      CONTINUE
  289.          SEGDES,xMATRI
  290.          SEGDES,DESCR
  291.          SEGDES MELEME
  292.  20   CONTINUE
  293.       SEGDES,MRIGID
  294.       SEGSUP,ITRAV
  295.       SEGSUP,SIINC
  296.       SEGSUP,IHAR
  297.       SEGSUP,ICCPR
  298. *
  299.       END
  300.  
  301.  
  302.  
  303.  
  304.  

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