Télécharger ytmx.eso

Retour à la liste

Numérotation des lignes :

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

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