Télécharger assem1.eso

Retour à la liste

Numérotation des lignes :

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

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