Télécharger assem1.eso

Retour à la liste

Numérotation des lignes :

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

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