Télécharger assem1.eso

Retour à la liste

Numérotation des lignes :

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

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