Télécharger xtmx.eso

Retour à la liste

Numérotation des lignes :

  1. C XTMX SOURCE PV 20/03/30 21:26:00 10567
  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*4 NI,INCOM
  33. SEGMENT,IHAR(0)
  34. SEGMENT,SIINC
  35. CHARACTER*4 IINC(0)
  36. ENDSEGMENT
  37. SEGMENT/ICCPR/(ICPR(NNGOT))
  38. SEGMENT ITRAV
  39. CHARACTER*4 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.  

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