Télécharger assem1.eso

Retour à la liste

Numérotation des lignes :

  1. C ASSEM1 SOURCE PV 18/11/16 22:49:07 9993
  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. * deplacer les multiplicateur present dans les super elements
  221. do 50 ir=1,nnva
  222. ipt5= IRIGEL(1,ir)
  223. segact ipt5
  224. if (ipt5.itypel.ne.28) goto 50
  225. descr=irigel(3,ir)
  226. segact descr
  227. * recherche du plus haut noeud non mult
  228. do 51 iel=1,ipt5.num(/2)
  229. ihaut=0
  230. do 55 il=1,lisinc(/2)
  231. * write (6,*) ' lisinc ',il,lisinc(il)
  232. if (lisinc(il).eq.'LX ') goto 55
  233. ihaut=max(ihaut,inuinv(ipt5.num(noelep(il),iel)))
  234. 55 continue
  235. do 60 il=1,lisinc(/2)
  236. if (lisinc(il).eq.'LX ') then
  237. * un mult ! on le deplace en ihaut
  238. ipmult=inuinv(ipt5.num(noelep(il),iel))
  239. * write (6,*) ' assem1 ipmult ihaut ',ipmult,ihaut
  240. if (ipmult.gt.ihaut) goto 60
  241. do j=1,inuinv(/1)
  242. if (inuinv(j).gt.ipmult.and.inuinv(j).le.ihaut)
  243. > inuinv(j)=inuinv(j)-1
  244. enddo
  245. inuinv(ipt5.num(noelep(il),iel))=ihaut
  246. endif
  247. 60 continue
  248. 51 continue
  249. 50 continue
  250. *
  251. segact meleme
  252. do i=1,lisous(/1)
  253. ipt8=lisous(i)
  254. segact ipt8
  255. if (ipt8.itypel.eq.-22) then
  256. segact ipt8*mod
  257. ipt8.itypel=22
  258. endif
  259. segdes ipt8
  260. enddo
  261. segdes meleme
  262. SEGACT INUINV
  263. SEGSUP,MELEME
  264. * MELEME=IMELP
  265. * SEGSUP,MELEME
  266. C
  267. C **** CREATION D'UN OBJET GEOMETRIE QU'IL FAUDRA CHANGER EN CAS DE
  268. C **** RENUMEROTATION GENERALE.ON PROFITE DE LA BOUCLE POUR CREE LE
  269. C **** TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I(NU-
  270. C **** MEROTATION LOCALE).
  271. C
  272. 800 CONTINUE
  273. NNOE=ICDOUR
  274. SEGINI,IMIN
  275. NNOE1=NNOE+1
  276. SEGINI,IPOS
  277. NBSOUS=0
  278. NBREF=0
  279. NBNN=1
  280. NBELEM=ICDOUR
  281. SEGINI,IPT1
  282. IPT1.ITYPEL=IPOIN
  283. DO 16 IRI=1,NNVA
  284. * DO 170 I=1,NNOE
  285. * 170 IPOS(I)=0
  286. MELEME=IRIGEL(1,IRI)
  287. SEGACT,MELEME
  288. N1=NUM(/1)
  289. N2=NUM(/2)
  290. DO 17 I=1,N2
  291. DO 17 J=1,N1
  292. K=NUM(J,I)
  293. M=INUINV(K)
  294. IF(IPOS(M).NE.I) THEN
  295. IMIN(M)=IMIN(M)+1
  296. IPT1.NUM(1,M)=K
  297. IPOS(M)=I
  298. ENDIF
  299. 17 CONTINUE
  300. DO 171 I=1,N2
  301. DO 171 J=1,N1
  302. K=NUM(J,I)
  303. M=INUINV(K)
  304. ipos(m)=0
  305. 171 continue
  306. SEGDES,MELEME
  307. 16 CONTINUE
  308. C
  309. C **** INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER
  310. C **** DANS ITOPO .
  311. C
  312. SEGINI,IITOP
  313. IITOP(1)=1
  314. DO 18 I=1,NNOE
  315. IITOP(I+1)=IMIN(I)* 2 + IITOP(I)
  316. 18 CONTINUE
  317. DO 19 I=1,NNOE
  318. 19 IMIN(I)=0
  319. IENNO=IITOP(NNOE+1)
  320. SEGINI,ITOPO
  321. DO 21 IRI=1,NNVA
  322. * DO 220 I=1,NNOE
  323. * 220 IPOS(I)=0
  324. C DESCR=IRIGEL(3,IRI)
  325. C SEGACT,DESCR
  326. C N3=LISINC(/2)
  327. C SEGDES,DESCR
  328. MELEME=IRIGEL(1,IRI)
  329. SEGACT,MELEME
  330. N1=NUM(/1)
  331. N2=NUM(/2)
  332. DO 22 I=1,N2
  333. DO 22 J=1,N1
  334. M=INUINV(NUM(J,I))
  335. IF(IPOS(M).NE.I) THEN
  336. IMIN(M)=IMIN(M)+1
  337. IUY= 2* ( IMIN(M)-1 ) + IITOP(M)
  338. ITOPO(IUY)=I
  339. ITOPO(IUY+1)=IRI
  340. IPOS(M)=I
  341. ENDIF
  342. 22 CONTINUE
  343. DO 221 I=1,N2
  344. DO 221 J=1,N1
  345. M=INUINV(NUM(J,I))
  346. IPOS(M)=0
  347. 221 CONTINUE
  348. SEGDES,MELEME
  349. 21 CONTINUE
  350. C
  351. C RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS
  352. C DE L'UTILISATION DE " OPTION MODE FOUR NOHAR "
  353. C
  354. DO 230 IRI=1,NNVA
  355. IHARIR=IRIGEL(5,IRI)
  356. IF( IHARIR . NE. NOHA) THEN
  357. IARDEF = IHARIR
  358. GO TO 231
  359. ENDIF
  360. 230 CONTINUE
  361. CALL ERREUR ( 21)
  362. RETURN
  363. 231 CONTINUE
  364. DO 232 IRI=1,NNVA
  365. IF( IRIGEL(5,IRI) .EQ.NOHA) GO TO 232
  366. IF( IRIGEL(5,IRI).EQ.IARDEF ) GO TO 232
  367. CALL ERREUR (21)
  368. RETURN
  369. 232 CONTINUE
  370. C
  371. C **** RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS
  372. C
  373. SEGINI,MIDUA
  374. SEGINI,MIMIK
  375. SEGINI,MHARK
  376. DESCR=IRIGEL(3,1)
  377. SEGACT,DESCR
  378. IAAR=IRIGEL(5,1)
  379. IF(IAAR.EQ.NOHA) IAAR = IARDEF
  380. IMIK(**)=LISINC(1)
  381. IHAR(**)= IAAR
  382. IDUA(**)=LISDUA(1)
  383. MAXINC=1
  384. DO 23 IRI=1,NNVA
  385. DESCR=IRIGEL(3,IRI)
  386. IHARIR=IRIGEL(5,IRI)
  387. IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
  388. SEGACT,DESCR
  389. NLIGRE=LISINC(/2)
  390. DO 26 I=1,NLIGRE
  391. DO 24 J=1,MAXINC
  392. IF(IMIK(J).NE.LISINC(I).OR.IDUA(J).NE.LISDUA(I).OR.
  393. > IHAR(J).NE.IHARIR) GO TO 24
  394. GO TO 26
  395. 24 CONTINUE
  396. MAXINC=MAXINC+1
  397. IHAR(**)=IHARIR
  398. IMIK(**)=LISINC(I)
  399. IDUA(**)=LISDUA(I)
  400. 26 CONTINUE
  401. SEGDES,DESCR
  402. 23 CONTINUE
  403. NDUA=IDUA(/2)
  404. C
  405. C **** INITIALISATION DE INCPOS ET DE INCTRA.
  406. C
  407. MAXI=MAXINC
  408. SEGINI DIATMP,strv
  409. SEGINI,MINCPO
  410. DO 29 IRI=1,NNVA
  411. DESCR=IRIGEL(3,IRI)
  412. IHARIR=IRIGEL(5,1)
  413. IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF
  414. SEGACT,DESCR
  415. MELEME=IRIGEL(1,IRI)
  416. SEGACT,MELEME
  417. NLIGRE=LISINC(/2)
  418. SEGINI,INCTRA
  419. INCTRR(IRI)=INCTRA
  420. N2=NUM(/2)
  421. IADS=XCOOR(/1)/(IDIM+1)
  422. xmatri=irigel(4,iri)
  423. segact xmatri
  424. DO 34 J=1,NLIGRE
  425. DO 33 K=1,MAXINC
  426. IF(IMIK(K).NE.LISINC(J).OR.IHAR(K).NE.IHARIR) GO TO 33
  427. IF(IDUA(K).NE.LISDUA(J)) THEN
  428. MOTERR(1:4)=IMIK(K)
  429. MOTERR(5:8)=IDUA(K)
  430. MOTERR(9:12)=LISDUA(J)
  431. CALL ERREUR(1026)
  432. RETURN
  433. ENDIF
  434. GOTO 32
  435. 33 CONTINUE
  436. CALL ERREUR(5)
  437. 32 CONTINUE
  438. INCTRA(J)=K
  439. DO 31 I=1,N2
  440. IJ=INUINV(NUM(NOELEP(J),I))
  441. INCPO(K,IJ)=1
  442. * terme diagonal
  443. diatmp(K,IJ)=diatmp(k,ij)+re(j,j,i)*coerig(iri)
  444. 31 continue
  445. 34 CONTINUE
  446. SEGDES,DESCR
  447. SEGDES,INCTRA
  448. SEGDES,MELEME
  449. 29 CONTINUE
  450. C
  451. C **** INITIALISATION DE IPOS
  452. C
  453. IPOS(1)=0
  454. NA=0
  455. DO 37 I=1,NNOE
  456. nad=na
  457. DO 35 K=1,MAXINC
  458. IF(INCPO(K,I).EQ.0) GO TO 35
  459. NA=NA+1
  460. INCPO(K,I)=NA
  461. itrv1(na-nad)=k
  462. dtrv1(na-nad)= -abs(diatmp(k,i))
  463. 35 CONTINUE
  464. ** write(6,*) ' avant ',(incpo(k,i),k=1,maxinc)
  465. * trier incpo suivant les val de diatmp
  466. call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
  467. do 351 k=1,na-nad
  468. incpo(itrv1(k),i)=k+nad
  469. 351 continue
  470. ** write(6,*) ' apres ',(incpo(k,i),k=1,maxinc)
  471. IPOS(I+1)=NA
  472. 37 CONTINUE
  473. SEGDES,MIDUA,MIMIK,MHARK
  474. C
  475. C **** INITIALISATION DE IMINI
  476. C
  477. INC=NA
  478. SEGINI,IMINI
  479. INC1=INC+1
  480. DO 38 I=1,INC
  481. IMINI(I)=INC1
  482. 38 CONTINUE
  483. DO 40 IRI=1,NNVA
  484. MELEME=IRIGEL(1,IRI)
  485. SEGACT,MELEME
  486. DESCR=IRIGEL(3,IRI)
  487. SEGACT,DESCR
  488. INCTRA=INCTRR(IRI)
  489. SEGACT,INCTRA
  490. N1=NOELEP(/1)
  491. N2=NUM(/2)
  492. N3=NUM(/1)
  493. DO 41 I=1,N2
  494. IJ=NNOE+1
  495. DO 42 J=1,N3
  496. IJ1=INUINV(NUM(J,I))
  497. IJ=MIN(IJ1,IJ)
  498. 42 CONTINUE
  499. IPR=IPOS(IJ)+1
  500. DO 43 JJ=1,N1
  501. IJA=INUINV(NUM(NOELEP(JJ),I))
  502. IJB=INCTRA(JJ)
  503. IK=INCPO(IJB,IJA)
  504. IMINI(IK)=MIN(IMINI(IK),IPR)
  505. 43 CONTINUE
  506. 41 CONTINUE
  507. SEGDES,DESCR
  508. SEGDES,INCTRA
  509. SEGDES,MELEME
  510. 40 CONTINUE
  511. segsup diatmp,strv
  512. SEGDES,MRIGID
  513. SEGDES,IPOS
  514. SEGDES,IMINI
  515. SEGDES,ITOPO
  516. SEGDES,IITOP
  517. SEGDES,INUINV
  518. SEGDES,IPT1
  519. SEGDES,MINCPO
  520. SEGSUP,IMIN
  521. SEGDES,INCTRR
  522. INCTRY=INCTRR
  523. SEGINI,MMATRI
  524. NENS=0
  525. IGEOMA=IPT1
  526. IIDUA=MIDUA
  527. IINCPO=MINCPO
  528. IIMIK=MIMIK
  529. IHARK=MHARK
  530. INUINY=INUINV
  531. ITOPOY=ITOPO
  532. IITOPY=IITOP
  533. MMATRX=MMATRI
  534. IMINIY=IMINI
  535. IPOY=IPOS
  536. SEGDES,MMATRI
  537. RETURN
  538. END
  539.  
  540.  
  541.  
  542.  
  543.  
  544.  
  545.  
  546.  
  547.  
  548.  
  549.  
  550.  
  551.  
  552.  
  553.  
  554.  
  555.  
  556.  
  557.  
  558.  
  559.  
  560.  
  561.  

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