Télécharger assem1.eso

Retour à la liste

Numérotation des lignes :

  1. C ASSEM1 SOURCE PV 17/11/20 21:15:01 9628
  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. IAAR=IRIGEL(5,1)
  372. IF(IAAR.EQ.NOHA) IAAR = IARDEF
  373. IMIK(**)=LISINC(1)
  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).OR.IDUA(J).NE.LISDUA(I).OR.
  386. > IHAR(J).NE.IHARIR) GO TO 24
  387. GO TO 26
  388. 24 CONTINUE
  389. MAXINC=MAXINC+1
  390. IHAR(**)=IHARIR
  391. IMIK(**)=LISINC(I)
  392. IDUA(**)=LISDUA(I)
  393. 26 CONTINUE
  394. SEGDES,DESCR
  395. 23 CONTINUE
  396. NDUA=IDUA(/2)
  397. C
  398. C **** INITIALISATION DE INCPOS ET DE INCTRA.
  399. C
  400. MAXI=MAXINC
  401. SEGINI,MINCPO
  402. DO 29 IRI=1,NNVA
  403. DESCR=IRIGEL(3,IRI)
  404. IHARIR=IRIGEL(5,1)
  405. IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF
  406. SEGACT,DESCR
  407. MELEME=IRIGEL(1,IRI)
  408. SEGACT,MELEME
  409. NLIGRE=LISINC(/2)
  410. SEGINI,INCTRA
  411. INCTRR(IRI)=INCTRA
  412. N2=NUM(/2)
  413. IADS=XCOOR(/1)/(IDIM+1)
  414. DO 34 J=1,NLIGRE
  415. DO 33 K=1,MAXINC
  416. IF(IMIK(K).NE.LISINC(J).OR.IHAR(K).NE.IHARIR) GO TO 33
  417. IF(IDUA(K).NE.LISDUA(J)) THEN
  418. MOTERR(1:4)=IMIK(K)
  419. MOTERR(5:8)=IDUA(K)
  420. MOTERR(9:12)=LISDUA(J)
  421. CALL ERREUR(1026)
  422. RETURN
  423. ENDIF
  424. GOTO 32
  425. 33 CONTINUE
  426. CALL ERREUR(5)
  427. 32 CONTINUE
  428. INCTRA(J)=K
  429. DO 31 I=1,N2
  430. IJ=INUINV(NUM(NOELEP(J),I))
  431. 31 INCPO(K,IJ)=1
  432. 34 CONTINUE
  433. SEGDES,DESCR
  434. SEGDES,INCTRA
  435. SEGDES,MELEME
  436. 29 CONTINUE
  437. C
  438. C **** INITIALISATION DE IPOS
  439. C
  440. IPOS(1)=0
  441. NA=0
  442. DO 37 I=1,NNOE
  443. DO 35 K=1,MAXINC
  444. IF(INCPO(K,I).EQ.0) GO TO 35
  445. NA=NA+1
  446. INCPO(K,I)=NA
  447. 35 CONTINUE
  448. IPOS(I+1)=NA
  449. 37 CONTINUE
  450. SEGDES,MIDUA,MIMIK,MHARK
  451. C
  452. C **** INITIALISATION DE IMINI
  453. C
  454. INC=NA
  455. SEGINI,IMINI
  456. INC1=INC+1
  457. DO 38 I=1,INC
  458. IMINI(I)=INC1
  459. 38 CONTINUE
  460. DO 40 IRI=1,NNVA
  461. MELEME=IRIGEL(1,IRI)
  462. SEGACT,MELEME
  463. DESCR=IRIGEL(3,IRI)
  464. SEGACT,DESCR
  465. INCTRA=INCTRR(IRI)
  466. SEGACT,INCTRA
  467. N1=NOELEP(/1)
  468. N2=NUM(/2)
  469. N3=NUM(/1)
  470. DO 41 I=1,N2
  471. IJ=NNOE+1
  472. DO 42 J=1,N3
  473. IJ1=INUINV(NUM(J,I))
  474. IJ=MIN(IJ1,IJ)
  475. 42 CONTINUE
  476. IPR=IPOS(IJ)+1
  477. DO 43 JJ=1,N1
  478. IJA=INUINV(NUM(NOELEP(JJ),I))
  479. IJB=INCTRA(JJ)
  480. IK=INCPO(IJB,IJA)
  481. IMINI(IK)=MIN(IMINI(IK),IPR)
  482. 43 CONTINUE
  483. 41 CONTINUE
  484. SEGDES,DESCR
  485. SEGDES,INCTRA
  486. SEGDES,MELEME
  487. 40 CONTINUE
  488. SEGDES,MRIGID
  489. SEGDES,IPOS
  490. SEGDES,IMINI
  491. SEGDES,ITOPO
  492. SEGDES,IITOP
  493. SEGDES,INUINV
  494. SEGDES,IPT1
  495. SEGDES,MINCPO
  496. SEGSUP,IMIN
  497. SEGDES,INCTRR
  498. INCTRY=INCTRR
  499. SEGINI,MMATRI
  500. NENS=0
  501. IGEOMA=IPT1
  502. IIDUA=MIDUA
  503. IINCPO=MINCPO
  504. IIMIK=MIMIK
  505. IHARK=MHARK
  506. INUINY=INUINV
  507. ITOPOY=ITOPO
  508. IITOPY=IITOP
  509. MMATRX=MMATRI
  510. IMINIY=IMINI
  511. IPOY=IPOS
  512. SEGDES,MMATRI
  513. RETURN
  514. END
  515.  
  516.  
  517.  
  518.  
  519.  
  520.  
  521.  
  522.  
  523.  
  524.  
  525.  
  526.  
  527.  
  528.  
  529.  
  530.  
  531.  
  532.  
  533.  
  534.  
  535.  

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