Télécharger assem1.eso

Retour à la liste

Numérotation des lignes :

  1. C ASSEM1 SOURCE PV 17/06/16 14:33:40 9460
  2. SUBROUTINE ASSEM1 ( IPOIRI,MMATRX,INUINY,ITOPOY,IMINIY,IPOY,
  3. 1 INCTRY,IITOPY)
  4. C
  5. C CE SUBROUTINE SERT A L'ASSEMBLAGE DE MATRICES SYMETRIQUES
  6. C EN VUE D'UNE INVERSION PAR UNE METHODE DE KROUT
  7. C
  8. C EN ENTREE:
  9. C **** IPOIRI: POINTEUR SUR OBJET MRIGIDITE,NON MODIFIE
  10. C EN SORTIE:
  11. C **** INUINV IMINI ITOPO IPOY INCTRY SONT DES POINTEURS DES SEGMENTS
  12. C DE TRAVAIL SERVANT A L'ASSEMBLAGE ILS SONT DETRUITS EN FIN
  13. C D'ASSEMBLAGE OU DE TRIANGULARISATION
  14. C **** MMATRI EST LE POINTEUR DE L'OBJET FUTUR MATRICE TRIANGULARISEE.
  15. IMPLICIT INTEGER(I-N)
  16. -INC CCOPTIO
  17. -INC SMELEME
  18. -INC SMCOORD
  19. SEGMENT,IMIN(NNOE)
  20. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  21. C SEGMENT IPB(NLIGRE)
  22. C
  23. -INC SMRIGID
  24. C
  25. -INC SMMATRI
  26. C
  27. SEGMENT,INUINV(NNGLOB)
  28. SEGMENT,ITOPO(IENNO)
  29. SEGMENT,IITOP(NNOE+1)
  30. SEGMENT,IMINI(INC)
  31. SEGMENT,IPOS(NNOE1)
  32. SEGMENT,INCTRR(NIRI)
  33. SEGMENT,INCTRA(NLIGRE)
  34. C
  35. C **** CES TABLEAUX SERVENT AU REPERAGE DE LA MATRICE POUR L'ASSEMBLAG
  36. C **** IL SERONT TOUS SUPPRIMES EN FIN D'ASSEMBLAGE.
  37. C
  38. C
  39. C **** MAXINC= MAXIMUM DE COMPOSANTES CONCERNANT UN NOEUD
  40. C
  41. C
  42. C **** IITOP(K)=I LE 1ER ELEMENT TOUCHANT LE NOEUD K SE TROUVE EN
  43. C IEME POSITION DANS ITOPO
  44. C **** ITOPO(I)=L: LE 1ER ELEMENT TOUCHANT LE K EME NOEUD DE LA
  45. C ITOPO(I+1)=M MATRICE EST LE LIEME DE L'OBJET GEOMETRIE
  46. C DEFINI PAR LE POINTEUR M
  47. C **** IPOS(I)=J : LA 1 ERE INCONNUE DU NOEUD I EST EN J+1 EME
  48. C POSITION
  49. C **** IMINI(I)=J LA PLUS PETITE INCONNUE QUI EST RELIEE A LA IEME
  50. C EST L'INCONNUE J.
  51. C **** INUINV(I)=J J EST LE NOUVEAU NUMERO DU NOEUD I
  52. C
  53. * DATA MOALFA/'ALFA'/
  54. CHARACTER*4 CNOHA
  55. integer*4 noha
  56. equivalence (cnoha,noha)
  57. DATA CNOHA/'NOHA'/
  58. DATA IPOIN/1/
  59. NNGLOB=XCOOR(/1)/(IDIM+1)
  60. MRIGID=IPOIRI
  61. SEGACT,MRIGID
  62. NNVA=IRIGEL(/2)
  63. NIRI=NNVA
  64. SEGINI,INCTRR
  65. MVA=IRIGEL(/1)
  66. MELEME=IRIGEL(1,1)
  67. SEGACT MELEME
  68. IF(ITYPEL.NE.27) GO TO 801
  69. SEGDES MELEME
  70. C
  71. C **** ASSEMBLAGE DANS LE CAS DE L'ANALYSE MODALE. ON COMPTE LES POINTS
  72. C **** DANS ICPR
  73. C
  74. SEGINI INUINV,ICPR
  75. IKI=0
  76. DO 700 I=1,NNVA
  77. MELEME=IRIGEL(1,I)
  78. SEGACT MELEME
  79. NBNN=NUM(/1)
  80. NBELEM=NUM(/2)
  81. DO 701 I1=1,NBELEM
  82. DO 701 I2=1,NBNN
  83. IP1=NUM(I2,I1)
  84. IF(ICPR(IP1).NE.0) GO TO 701
  85. IKI=IKI+1
  86. ICPR(IP1)=IKI
  87. 701 CONTINUE
  88. SEGDES MELEME
  89. 700 CONTINUE
  90. C
  91. C **** FABRICATION DU TABLEAU INUINV
  92. C **** ON MET LES POINTS QUI ONT POUR INCONNUE ALFA EN TETE
  93. C
  94. NNOE=IKI
  95. NALFA=0
  96. NBETA=0
  97. DO 710 I=1,NNVA
  98. MELEME=IRIGEL(1,I)
  99. DESCR =IRIGEL(3,I)
  100. SEGACT MELEME,DESCR
  101. NBNN=NUM(/1)
  102. NBELEM=NUM(/2)
  103. NLIGRE=LISINC(/2)
  104. * SEGINI IPB A QUOI CA SERT PV
  105. * DO 703 K=1,NLIGRE
  106. * IPB(NOELEP(K))=K
  107. *703 CONTINUE
  108. DO 711 I1=1,NBELEM
  109. DO 711 I2=1,NBNN
  110. IP1=NUM(I2,I1)
  111. IF(ICPR(IP1).EQ.0) GO TO 711
  112. * IJA=IPB(I2)
  113. * IF(IJA.NE.MOALFA) GO TO 715
  114. * NALFA=NALFA+1
  115. * IKI=NALFA
  116. * GO TO 716
  117. 715 CONTINUE
  118. NBETA=NBETA+1
  119. IKI=NNOE-NBETA+1
  120. 716 CONTINUE
  121. INUINV(IP1)=IKI
  122. ICPR(IP1)=0
  123. 711 CONTINUE
  124. SEGDES MELEME,DESCR
  125. * SEGSUP IPB
  126. 710 CONTINUE
  127. SEGSUP ICPR
  128. ICDOUR=NNOE
  129. GO TO 800
  130. C
  131. C **** ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES
  132. C **** GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA OBJETS
  133. C **** GEOMETRIQUES ELEMENTAIRES. PUIS ON ENVOIE DANS NUMOPT QUI
  134. C **** FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU
  135. C **** NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR.
  136. C **** LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD
  137. C **** DE LA MATRICE, ETC...
  138. C
  139. 801 CONTINUE
  140. IKK=1
  141. 722 CONTINUE
  142. MELEME=IRIGEL(1,IKK)
  143. SEGACT,MELEME
  144. DESCR=IRIGEL(3,IKK)
  145. SEGACT,DESCR
  146. NLIGRE=LISINC(/2)
  147. DO 720 K=1,NLIGRE
  148. IF(LISINC(K).NE.'LX ') GO TO 721
  149. 720 CONTINUE
  150. SEGDES,MELEME
  151. SEGDES,DESCR
  152. IKK=IKK+1
  153. IF(IKK.LE.NNVA) GO TO 722
  154. DO 4862 I=1,NNVA
  155. MELEME= IRIGEL(1,I)
  156. SEGACT MELEME
  157. if (num(/2).eq.0) goto 4862
  158. IF(ITYPEL.EQ.22) THEN
  159. DESCR=IRIGEL(3,I )
  160. SEGACT,DESCR
  161. K = 3
  162. if (num(/2).le.2) k=num(/2)
  163. GO TO 4863
  164. ELSE
  165. SEGDES MELEME
  166. ENDIF
  167. 4862 CONTINUE
  168. K=1
  169. do ir=1,nnva
  170. MELEME= IRIGEL(1,ir)
  171. segact meleme
  172. if (num(/2).ne.0.and.itypel.ne.22) goto 4864
  173. enddo
  174. call erreur(5)
  175. 4864 continue
  176. DESCR= IRIGEL(3,ir)
  177. SEGACT MELEME,DESCR
  178. 4863 CONTINUE
  179. 721 IA=NOELEP(K)
  180. I1=NUM(IA,1)
  181. NBSOUS=0
  182. NBNN=1
  183. NBREF=0
  184. NBELEM=1
  185. SEGDES,MELEME,DESCR
  186. SEGINI,MELEME
  187. ITYPEL=1
  188. NUM(1,1)=I1
  189. SEGDES,MELEME
  190. IMELP=MELEME
  191. NBSOUS=NNVA+1
  192. NBREF=0
  193. NBNN=0
  194. NBELEM=0
  195. SEGINI,MELEME
  196. LISOUS(1)=IMELP
  197. DO 12 I=1,NNVA
  198. * write (6,*) ' dans assem1 ',irigel(6,i)
  199. LISOUS(I+1)=IRIGEL(1,I)
  200. * cas du frottement, on met -22 dans itypel pour le savoir dans numopt
  201. IF (IRIGEL(6,i).eq.2) then
  202. IPT8=LISOUS(I+1)
  203. segact IPT8*mod
  204. ipt8.itypel=-22
  205. endif
  206. 12 CONTINUE
  207. SEGDES,MELEME
  208. ICDOUR=0
  209. SEGINI,INUINV
  210. SEGDES,INUINV
  211. CALL NUMOPT(MELEME,INUINV,ICDOUR)
  212. *
  213. * deplacer les multiplicateur present dans les super elements
  214. do 50 ir=1,nnva
  215. ipt5= IRIGEL(1,ir)
  216. segact ipt5
  217. if (ipt5.itypel.ne.28) goto 50
  218. descr=irigel(3,ir)
  219. segact descr
  220. * recherche du plus haut noeud non mult
  221. do 51 iel=1,ipt5.num(/2)
  222. ihaut=0
  223. do 55 il=1,lisinc(/2)
  224. * write (6,*) ' lisinc ',il,lisinc(il)
  225. if (lisinc(il).eq.'LX ') goto 55
  226. ihaut=max(ihaut,inuinv(ipt5.num(noelep(il),iel)))
  227. 55 continue
  228. do 60 il=1,lisinc(/2)
  229. if (lisinc(il).eq.'LX ') then
  230. * un mult ! on le deplace en ihaut
  231. ipmult=inuinv(ipt5.num(noelep(il),iel))
  232. * write (6,*) ' assem1 ipmult ihaut ',ipmult,ihaut
  233. if (ipmult.gt.ihaut) goto 60
  234. do j=1,inuinv(/1)
  235. if (inuinv(j).gt.ipmult.and.inuinv(j).le.ihaut)
  236. > inuinv(j)=inuinv(j)-1
  237. enddo
  238. inuinv(ipt5.num(noelep(il),iel))=ihaut
  239. endif
  240. 60 continue
  241. 51 continue
  242. 50 continue
  243. *
  244. segact meleme
  245. do i=1,lisous(/1)
  246. ipt8=lisous(i)
  247. segact ipt8
  248. if (ipt8.itypel.eq.-22) then
  249. segact ipt8*mod
  250. ipt8.itypel=22
  251. endif
  252. segdes ipt8
  253. enddo
  254. segdes meleme
  255. SEGACT INUINV
  256. SEGSUP,MELEME
  257. * MELEME=IMELP
  258. * SEGSUP,MELEME
  259. C
  260. C **** CREATION D'UN OBJET GEOMETRIE QU'IL FAUDRA CHANGER EN CAS DE
  261. C **** RENUMEROTATION GENERALE.ON PROFITE DE LA BOUCLE POUR CREE LE
  262. C **** TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I(NU-
  263. C **** MEROTATION LOCALE).
  264. C
  265. 800 CONTINUE
  266. NNOE=ICDOUR
  267. SEGINI,IMIN
  268. NNOE1=NNOE+1
  269. SEGINI,IPOS
  270. NBSOUS=0
  271. NBREF=0
  272. NBNN=1
  273. NBELEM=ICDOUR
  274. SEGINI,IPT1
  275. IPT1.ITYPEL=IPOIN
  276. DO 16 IRI=1,NNVA
  277. * DO 170 I=1,NNOE
  278. * 170 IPOS(I)=0
  279. MELEME=IRIGEL(1,IRI)
  280. SEGACT,MELEME
  281. N1=NUM(/1)
  282. N2=NUM(/2)
  283. DO 17 I=1,N2
  284. DO 17 J=1,N1
  285. K=NUM(J,I)
  286. M=INUINV(K)
  287. IF(IPOS(M).NE.I) THEN
  288. IMIN(M)=IMIN(M)+1
  289. IPT1.NUM(1,M)=K
  290. IPOS(M)=I
  291. ENDIF
  292. 17 CONTINUE
  293. DO 171 I=1,N2
  294. DO 171 J=1,N1
  295. K=NUM(J,I)
  296. M=INUINV(K)
  297. ipos(m)=0
  298. 171 continue
  299. SEGDES,MELEME
  300. 16 CONTINUE
  301. C
  302. C **** INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER
  303. C **** DANS ITOPO .
  304. C
  305. SEGINI,IITOP
  306. IITOP(1)=1
  307. DO 18 I=1,NNOE
  308. IITOP(I+1)=IMIN(I)* 2 + IITOP(I)
  309. 18 CONTINUE
  310. DO 19 I=1,NNOE
  311. 19 IMIN(I)=0
  312. IENNO=IITOP(NNOE+1)
  313. SEGINI,ITOPO
  314. DO 21 IRI=1,NNVA
  315. * DO 220 I=1,NNOE
  316. * 220 IPOS(I)=0
  317. C DESCR=IRIGEL(3,IRI)
  318. C SEGACT,DESCR
  319. C N3=LISINC(/2)
  320. C SEGDES,DESCR
  321. MELEME=IRIGEL(1,IRI)
  322. SEGACT,MELEME
  323. N1=NUM(/1)
  324. N2=NUM(/2)
  325. DO 22 I=1,N2
  326. DO 22 J=1,N1
  327. M=INUINV(NUM(J,I))
  328. IF(IPOS(M).NE.I) THEN
  329. IMIN(M)=IMIN(M)+1
  330. IUY= 2* ( IMIN(M)-1 ) + IITOP(M)
  331. ITOPO(IUY)=I
  332. ITOPO(IUY+1)=IRI
  333. IPOS(M)=I
  334. ENDIF
  335. 22 CONTINUE
  336. DO 221 I=1,N2
  337. DO 221 J=1,N1
  338. M=INUINV(NUM(J,I))
  339. IPOS(M)=0
  340. 221 CONTINUE
  341. SEGDES,MELEME
  342. 21 CONTINUE
  343. C
  344. C RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS
  345. C DE L'UTILISATION DE " OPTION MODE FOUR NOHAR "
  346. C
  347. DO 230 IRI=1,NNVA
  348. IHARIR=IRIGEL(5,IRI)
  349. IF( IHARIR . NE. NOHA) THEN
  350. IARDEF = IHARIR
  351. GO TO 231
  352. ENDIF
  353. 230 CONTINUE
  354. CALL ERREUR ( 21)
  355. RETURN
  356. 231 CONTINUE
  357. DO 232 IRI=1,NNVA
  358. IF( IRIGEL(5,IRI) .EQ.NOHA) GO TO 232
  359. IF( IRIGEL(5,IRI).EQ.IARDEF ) GO TO 232
  360. CALL ERREUR (21)
  361. RETURN
  362. 232 CONTINUE
  363. C
  364. C **** RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS
  365. C
  366. SEGINI,MIDUA
  367. SEGINI,MIMIK
  368. SEGINI,MHARK
  369. DESCR=IRIGEL(3,1)
  370. SEGACT,DESCR
  371. IMIK(**)=LISINC(1)
  372. IAAR=IRIGEL(5,1)
  373. IF(IAAR.EQ.NOHA) IAAR = IARDEF
  374. IHAR(**)= IAAR
  375. IDUA(**)=LISDUA(1)
  376. MAXINC=1
  377. DO 23 IRI=1,NNVA
  378. DESCR=IRIGEL(3,IRI)
  379. IHARIR=IRIGEL(5,IRI)
  380. IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
  381. SEGACT,DESCR
  382. NLIGRE=LISINC(/2)
  383. DO 26 I=1,NLIGRE
  384. DO 24 J=1,MAXINC
  385. IF(IMIK(J).NE.LISINC(I)) GO TO 24
  386. IF(IHAR(J).EQ.IHARIR) GO TO 26
  387. 24 CONTINUE
  388. MAXINC=MAXINC+1
  389. IHAR(**)=IHARIR
  390. IMIK(**)=LISINC(I)
  391. IDUA(**)=LISDUA(I)
  392. 26 CONTINUE
  393. SEGDES,DESCR
  394. 23 CONTINUE
  395. NDUA=IDUA(/2)
  396. C
  397. C **** INITIALISATION DE INCPOS ET DE INCTRA.
  398. C
  399. MAXI=MAXINC
  400. SEGINI,MINCPO
  401. DO 29 IRI=1,NNVA
  402. DESCR=IRIGEL(3,IRI)
  403. IHARIR=IRIGEL(5,1)
  404. IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF
  405. SEGACT,DESCR
  406. MELEME=IRIGEL(1,IRI)
  407. SEGACT,MELEME
  408. NLIGRE=LISINC(/2)
  409. SEGINI,INCTRA
  410. INCTRR(IRI)=INCTRA
  411. N2=NUM(/2)
  412. IADS=XCOOR(/1)/(IDIM+1)
  413. DO 34 J=1,NLIGRE
  414. DO 33 K=1,MAXINC
  415. IF(LISINC(J).NE.IMIK(K)) GO TO 33
  416. IF(IHAR(K).EQ.IHARIR) GO TO 32
  417. 33 CONTINUE
  418. 32 CONTINUE
  419. INCTRA(J)=K
  420. DO 31 I=1,N2
  421. IJ=INUINV(NUM(NOELEP(J),I))
  422. 31 INCPO(K,IJ)=1
  423. 34 CONTINUE
  424. SEGDES,DESCR
  425. SEGDES,INCTRA
  426. SEGDES,MELEME
  427. 29 CONTINUE
  428. C
  429. C **** INITIALISATION DE IPOS
  430. C
  431. IPOS(1)=0
  432. NA=0
  433. DO 37 I=1,NNOE
  434. DO 35 K=1,MAXINC
  435. IF(INCPO(K,I).EQ.0) GO TO 35
  436. NA=NA+1
  437. INCPO(K,I)=NA
  438. 35 CONTINUE
  439. IPOS(I+1)=NA
  440. 37 CONTINUE
  441. SEGDES,MIDUA,MIMIK,MHARK
  442. C
  443. C **** INITIALISATION DE IMINI
  444. C
  445. INC=NA
  446. SEGINI,IMINI
  447. INC1=INC+1
  448. DO 38 I=1,INC
  449. IMINI(I)=INC1
  450. 38 CONTINUE
  451. DO 40 IRI=1,NNVA
  452. MELEME=IRIGEL(1,IRI)
  453. SEGACT,MELEME
  454. DESCR=IRIGEL(3,IRI)
  455. SEGACT,DESCR
  456. INCTRA=INCTRR(IRI)
  457. SEGACT,INCTRA
  458. N1=NOELEP(/1)
  459. N2=NUM(/2)
  460. N3=NUM(/1)
  461. DO 41 I=1,N2
  462. IJ=NNOE+1
  463. DO 42 J=1,N3
  464. IJ1=INUINV(NUM(J,I))
  465. IJ=MIN(IJ1,IJ)
  466. 42 CONTINUE
  467. IPR=IPOS(IJ)+1
  468. DO 43 JJ=1,N1
  469. IJA=INUINV(NUM(NOELEP(JJ),I))
  470. IJB=INCTRA(JJ)
  471. IK=INCPO(IJB,IJA)
  472. IMINI(IK)=MIN(IMINI(IK),IPR)
  473. 43 CONTINUE
  474. 41 CONTINUE
  475. SEGDES,DESCR
  476. SEGDES,INCTRA
  477. SEGDES,MELEME
  478. 40 CONTINUE
  479. SEGDES,MRIGID
  480. SEGDES,IPOS
  481. SEGDES,IMINI
  482. SEGDES,ITOPO
  483. SEGDES,IITOP
  484. SEGDES,INUINV
  485. SEGDES,IPT1
  486. SEGDES,MINCPO
  487. SEGSUP,IMIN
  488. SEGDES,INCTRR
  489. INCTRY=INCTRR
  490. SEGINI,MMATRI
  491. NENS=0
  492. IGEOMA=IPT1
  493. IIDUA=MIDUA
  494. IINCPO=MINCPO
  495. IIMIK=MIMIK
  496. IHARK=MHARK
  497. INUINY=INUINV
  498. ITOPOY=ITOPO
  499. IITOPY=IITOP
  500. MMATRX=MMATRI
  501. IMINIY=IMINI
  502. IPOY=IPOS
  503. SEGDES,MMATRI
  504. RETURN
  505. END
  506.  
  507.  
  508.  
  509.  
  510.  
  511.  
  512.  
  513.  
  514.  
  515.  
  516.  
  517.  
  518.  
  519.  
  520.  
  521.  
  522.  
  523.  
  524.  
  525.  

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