Télécharger xtmx.eso

Retour à la liste

Numérotation des lignes :

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

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