Télécharger assem4.eso

Retour à la liste

Numérotation des lignes :

assem4
  1. C ASSEM4 SOURCE PV 22/12/14 12:37:35 11528
  2. SUBROUTINE ASSEM4(IPOIRI,NOINC,SNOMIN,NOMAI,MMATRX,
  3. # INUINY,ITOPOY,INCTRY,IITOPY,NBNNMA,NLIGRA,SNTT,SNTO,DES1)
  4.  
  5. ** CETTE SUBROUTINE EFFECTUE LA PREPARATION A L'ASSEMBLAGE DANS LE CAS DU CALCUL DU
  6. ** SUPER-ELEMENT
  7.  
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8(A-H,O-Z)
  10. CHARACTER*4 CMOT
  11.  
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC SMELEME
  16. -INC SMCOORD
  17. -INC SMRIGID
  18. -INC SMMATRI
  19. -INC CCREEL
  20.  
  21. SEGMENT,IMIN(NNOE)
  22. SEGMENT,ICPR(nbpts)
  23. SEGMENT,INUINV(NNGLOB)
  24. SEGMENT,INUIN2(2*NNOE)
  25. SEGMENT,ITOPO(IENNO)
  26. SEGMENT,IITOP(NNOE+1)
  27. SEGMENT,INCTRR(NIRI)
  28. SEGMENT,INCTRA(NLIGRE)
  29. SEGMENT DIATMP(maxinc,NNOE)
  30. segment strv
  31. integer itrv1(maxinc)
  32. integer itrv2(maxinc)
  33. real*8 dtrv1(maxinc)
  34. real*8 dtrv2(maxinc)
  35. endsegment
  36. C
  37. C **** CES TABLEAUX SERVENT AU REPERAGE DE LA MATRICE POUR L'ASSEMBLAG
  38. C **** IL SERONT TOUS SUPPRIMES EN FIN D'ASSEMBLAGE.
  39. C
  40. C
  41. C **** MAXINC= MAXIMUM DE COMPOSANTES CONCERNANT UN NOEUD
  42. C
  43. C **** IITOP(K)=I LE 1ER ELEMENT TOUCHANT LE NOEUD K SE TROUVE EN
  44. C IEME POSITION DANS ITOPO
  45. C **** ITOPO(I)=L: LE 1ER ELEMENT TOUCHANT LE K EME NOEUD DE LA
  46. C ITOPO(I+1)=M MATRICE EST LE LIEME DE L'OBJET GEOMETRIE
  47. C DEFINI PAR LE POINTEUR M
  48. C **** INUINV(I)=J J EST LE NOUVEAU NUMERO DU NOEUD I
  49. C
  50.  
  51. ** SEGMENTS DE TRAVAIL
  52.  
  53. SEGMENT NOMAI(nbpts)
  54. SEGMENT NOINC(NNIN,ITA)
  55. SEGMENT SNOMIN
  56. CHARACTER*(LOCOMP) NOMIN(M)
  57. ENDSEGMENT
  58. SEGMENT SNTO
  59. INTEGER NTOTMA(NN)
  60. ENDSEGMENT
  61. C
  62. SEGMENT SNTT
  63. INTEGER NTTMAI(NN)
  64. ENDSEGMENT
  65. C
  66. SEGMENT ILOCAL(NBNUM)
  67. C
  68. ** NOMAI(I)<>0 SI LE NOEUD I EST MAITRE (I=N° ABSOLU)
  69. C
  70. ** NOINC(I,J)=1 SI L'INCONNUE I EXISTE POUR LE NOEUD J (J=N° LOCAL)
  71. C
  72. ** NOMIN(I)= INCO : L'INCONNUE N°I EST L'INCONNUE DE NOM 'INCO'
  73. ** CE SEGMENT NE CONTIENT QUE LES INCONNUES MAITRESSES
  74. ** NTOTMA : SEGMENT DES NOEUDS MAITRES POUR LESQUELS TOUTES LES INCONNUES
  75. ** SONT MAITRESSES
  76. ** NTTMAI : SEGMENT DES NOEUDS MAITRES QUI N'ONT PAS TOUTES LEURS INCONNUES
  77. ** MAITRESSES
  78. ** ILOCAL : SEGMENT DES NUMEROS LOCAUX
  79.  
  80.  
  81. * DATA MOALFA/'ALFA'/
  82. CHARACTER*4 CNOHA
  83. integer*4 noha
  84. equivalence (cnoha,noha)
  85. DATA CNOHA/'NOHA'/
  86. DATA IPOIN/1/
  87.  
  88. NNGLOB=nbpts
  89.  
  90. MRIGID=IPOIRI
  91. SEGACT,MRIGID
  92.  
  93. NNVA=IRIGEL(/2)
  94. NIRI=NNVA
  95. SEGINI,INCTRR
  96. MVA=IRIGEL(/1)
  97. MELEME=IRIGEL(1,1)
  98. SEGACT,MELEME
  99. IF(ITYPEL.NE.27) GO TO 801
  100. SEGDES MELEME
  101. C
  102. C **** ASSEMBLAGE DANS LE CAS DE L'ANALYSE MODALE. ON COMPTE LES POINTS
  103. C **** DANS ICPR
  104. C
  105. SEGINI,INUINV,ICPR
  106. IKI=0
  107. DO 700 I=1,NNVA
  108. MELEME=IRIGEL(1,I)
  109. SEGACT,MELEME
  110. NBNN=NUM(/1)
  111. NBELEM=NUM(/2)
  112. DO I1=1,NBELEM
  113. DO 701 I2=1,NBNN
  114. IP1=NUM(I2,I1)
  115. IF(ICPR(IP1).NE.0) GO TO 701
  116. IKI=IKI+1
  117. ICPR(IP1)=IKI
  118. 701 CONTINUE
  119. enddo
  120. SEGDES MELEME
  121. 700 CONTINUE
  122. C
  123. C **** FABRICATION DU TABLEAU INUINV
  124. C **** ON MET LES POINTS QUI ONT POUR INCONNUE ALFA EN TETE
  125. C
  126. NNOE=IKI
  127. NALFA=0
  128. NBETA=0
  129. DO 710 I=1,NNVA
  130. MELEME=IRIGEL(1,I)
  131. DESCR =IRIGEL(3,I)
  132. SEGACT,MELEME,DESCR
  133. NBNN=NUM(/1)
  134. NBELEM=NUM(/2)
  135. NLIGRE=LISINC(/2)
  136. DO I1=1,NBELEM
  137. DO 711 I2=1,NBNN
  138. IP1=NUM(I2,I1)
  139. IF(ICPR(IP1).EQ.0) GO TO 711
  140. 715 CONTINUE
  141. NBETA=NBETA+1
  142. IKI=NNOE-NBETA+1
  143. 716 CONTINUE
  144. INUINV(IP1)=IKI
  145. ICPR(IP1)=0
  146. 711 CONTINUE
  147. enddo
  148. SEGDES MELEME,DESCR
  149. 710 CONTINUE
  150. SEGSUP,ICPR
  151. ICDOUR=NNOE
  152. GO TO 800
  153. C
  154. C **** ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES
  155. C **** GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA OBJETS
  156. C **** GEOMETRIQUES ELEMENTAIRES. PUIS ON ENVOIE DANS NUMOPT QUI
  157. C **** FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU
  158. C **** NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR.
  159. C **** LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD
  160. C **** DE LA MATRICE, ETC...
  161. C
  162.  
  163. 801 CONTINUE
  164.  
  165. NUMDEB=INT(nbpts)
  166. MAXNUM=NUMDEB
  167.  
  168. NBNUM=NUMDEB
  169. SEGINI,ILOCAL
  170.  
  171. ** NUMEROTATION LOCALE DE TOUS LES NOEUDS
  172. IKOU=0
  173. SEGACT NOMAI
  174. SEGADJ NOMAI
  175. *** write (6,*) ' dimension de nomai ',nomai(/1),nnglob
  176. DO 50 I0=1,NNVA
  177. MELEME=IRIGEL(1,I0)
  178. SEGACT,MELEME
  179. DO I2=1,NUM(/2)
  180. DO 51 I1=1,NUM(/1)
  181. IJ=NUM(I1,I2)
  182. IF (ILOCAL(IJ).NE.0.or.nomai(ij).ne.0) GOTO 51
  183. IKOU=IKOU+1
  184. ILOCAL(IJ)=IKOU
  185. 51 CONTINUE
  186. enddo
  187. SEGDES MELEME
  188. 50 CONTINUE
  189. NNOE=IKOU
  190. DO 52 I=1,NOMAI(/1)
  191. IF(NOMAI(I).NE.0.AND.ILOCAL(I).EQ.0) THEN
  192. NNOE=NNOE+1
  193. ILOCAL(I)=ikou+nomai(i)
  194. ENDIF
  195. 52 CONTINUE
  196. SEGDES NOMAI
  197. C
  198. C RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS
  199. C DE L'UTILISATION DE " OPTION MODE FOUR NOHAR "
  200. C
  201. DO 230 IRI=1,NNVA
  202. IHARIR=IRIGEL(5,IRI)
  203. IF(IHARIR.NE.NOHA) THEN
  204. IARDEF = IHARIR
  205. GO TO 231
  206. ENDIF
  207. 230 CONTINUE
  208. CALL ERREUR ( 21)
  209. RETURN
  210. 231 CONTINUE
  211. DO 232 IRI=1,NNVA
  212. IF( IRIGEL(5,IRI).EQ.NOHA) GO TO 232
  213. IF( IRIGEL(5,IRI).EQ.IARDEF ) GO TO 232
  214. CALL ERREUR (21)
  215. RETURN
  216. 232 CONTINUE
  217. C
  218. C **** RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS
  219. C
  220. SEGINI,MIDUA
  221. SEGINI,MIMIK
  222. SEGINI,MHARK
  223. DESCR=IRIGEL(3,1)
  224. SEGACT,DESCR
  225. IMIK(**)=LISINC(1)
  226. IAAR=IRIGEL(5,1)
  227. IF(IAAR.EQ.NOHA) IAAR = IARDEF
  228. IHAR(**)= IAAR
  229. IDUA(**)=LISDUA(1)
  230. MAXINC=1
  231. DO 323 IRI=1,NNVA
  232. DESCR=IRIGEL(3,IRI)
  233. IHARIR=IRIGEL(5,IRI)
  234. IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
  235. SEGACT,DESCR
  236. NLIGRE=LISINC(/2)
  237. DO 326 I=1,NLIGRE
  238. DO 324 J=1,MAXINC
  239. IF(IMIK(J).NE.LISINC(I)) GO TO 324
  240. IF(IHAR(J).EQ.IHARIR) GO TO 326
  241. 324 CONTINUE
  242. MAXINC=MAXINC+1
  243. IHAR(**)=IHARIR
  244. IMIK(**)=LISINC(I)
  245. IDUA(**)=LISDUA(I)
  246. 326 CONTINUE
  247. SEGDES,DESCR
  248. 323 CONTINUE
  249. NDUA=IDUA(/2)
  250.  
  251. C
  252. C **** INITIALISATION DE INCPOS ET DE INCTRA.
  253. C
  254. MAXI=MAXINC
  255. SEGINI DIATMP,strv
  256. SEGINI,MINCPO
  257. DO 329 IRI=1,NNVA
  258. DESCR=IRIGEL(3,IRI)
  259. IHARIR=IRIGEL(5,IRI)
  260. IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF
  261. SEGACT,DESCR
  262. MELEME=IRIGEL(1,IRI)
  263. SEGACT,MELEME
  264. NLIGRE=LISINC(/2)
  265. SEGINI,INCTRA
  266. INCTRR(IRI)=INCTRA
  267. N2=NUM(/2)
  268. IADS=nbpts
  269. xmatri=irigel(4,iri)
  270. segact xmatri
  271. DO 334 J=1,NLIGRE
  272. DO 333 K=1,MAXINC
  273. IF(LISINC(J).NE.IMIK(K)) GO TO 333
  274. IF(IHAR(K).EQ.IHARIR) GO TO 332
  275. 333 CONTINUE
  276. 332 CONTINUE
  277. INCTRA(J)=K
  278. DO 331 I=1,N2
  279. IJ=ILOCAL(NUM(NOELEP(J),I))
  280. INCPO(K,IJ)=1
  281. diatmp(k,ij)=diatmp(k,ij)+re(j,j,i)*coerig(iri)
  282. 331 continue
  283. 334 CONTINUE
  284. SEGDES,DESCR
  285. SEGDES,INCTRA
  286. 329 CONTINUE
  287. C
  288. SEGACT,SNOMIN
  289. SEGACT,NOMAI
  290. SEGACT,NOINC
  291. DO 3301 I=1,NOMAI(/1)
  292. IF(NOMAI(I).EQ.0) GOTO 3301
  293. N1=NOMAI(I)
  294. DO 3302 J=1,NOMIN(/2)
  295. IF(NOINC(J,N1).EQ.0) GOTO 3302
  296. DO 3303 K=1,IMIK(/2)
  297. IF(NOMIN(J).EQ.IMIK(K)) GO TO 3304
  298. 3303 CONTINUE
  299. 3304 CONTINUE
  300. INCPO(K,ILOCAL(I))=1
  301. 3302 CONTINUE
  302. 3301 CONTINUE
  303. C
  304. C
  305. MAXPOD=MAXINC*NNOE+1
  306. MAXPO=MAXPOD
  307. NBNNMA=0
  308. DO 299 I=1,INCPO(/1)
  309. DO 2991 J=1,INCPO(/2)
  310. NBNNMA=NBNNMA+INCPO(I,J)
  311. 2991 CONTINUE
  312. 299 CONTINUE
  313. C
  314. C ** ON EFFECTUE UN TRI DES NOEUDS MAITRES POUR DISTINGUER LES NOEUDS
  315. C ** "TOTALEMENT MAITRES" DES NOEUDS "NON TOTALEMENT MAITRES"
  316. C
  317. NLIGRA=0
  318. DO 30 I=1,NOMAI(/1)
  319. IF (NOMAI(I).EQ.0) GOTO 30
  320. 32 CONTINUE
  321. NINCMA=0
  322. NINC = 0
  323. DO 33 J=1,INCPO(/1)
  324. N2=J
  325. IF (INCPO(J,ILOCAL(I)).NE.1) GOTO 33
  326. NINC=NINC+1
  327. DO 34 JJ=1,NOMIN(/2)
  328. N3=JJ
  329. IF (IMIK(J).EQ.NOMIN(JJ)) GOTO 35
  330. ** IF (IMIK(J).EQ.NOMIN(JJ).AND.IHAR(J).EQ.IHARMA(JJ)) GOTO 35
  331. 34 CONTINUE
  332. GOTO 33
  333. 35 CONTINUE
  334. IF (NOINC(N3,NOMAI(I)).EQ.1) THEN
  335. INCPO(N2,ILOCAL(I))=MAXPOD
  336. NINCMA=NINCMA+1
  337. NLIGRA=NLIGRA+1
  338. NBNNMA=NBNNMA-1
  339. ENDIF
  340. 33 CONTINUE
  341. IF(NINCMA.GT.0) THEN
  342. IF(NINCMA.EQ.NINC) THEN
  343. NTOTMA(**)=ILOCAL(I)
  344. DO 3333 J=1,INCPO(/1)
  345. IF(INCPO(J,ILOCAL(I)).EQ.MAXPOD)
  346. & INCPO(J,ILOCAL(I))=1
  347. 3333 CONTINUE
  348. ELSE
  349. NTTMAI(**)=ILOCAL(I)
  350. ENDIF
  351. ENDIF
  352. 30 CONTINUE
  353. NODDEB=NNOE
  354. SEGDES NOINC
  355. C
  356. C **** ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES
  357. C **** GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA+1 OBJETS
  358. C **** GEOMETRIQUES ELEMENTAIRES. LE PREMIER SOUS-OBJET CONTIENT
  359. C **** LES NOEUDS TOTALEMENT MAITRES (S'IL Y EN A), QUI SERONT
  360. C **** PLACES EN FIN DE NUMEROTATION. ON APPELLE NUMOPT2 (OU NUMOPT)
  361. C **** QUI FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU
  362. C **** NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR.
  363. C **** LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD
  364. C **** DE LA MATRICE, ETC...
  365. C
  366. C on met d'abord en tete un point bidon pour etre coherent
  367. C avec le precontionnement dans numopt
  368. C
  369. ** write(6,*) ' ntotma ',ntotma(/1)
  370. ** write(6,*) ' nttmai ',nttmai(/1)
  371.  
  372.  
  373. IF(NTOTMA(/1).NE.0) THEN
  374. NBNN=1
  375. NBSOUS=0
  376. NBREF=0
  377. NBELEM=1
  378. SEGINI,IPT5
  379. IPT5.ITYPEL=28
  380. DO 221 J=1,ILOCAL(/1)
  381. IF (ILOCAL(J).EQ.NTOTMA(1)) GOTO 222
  382. 221 CONTINUE
  383. CALL ERREUR(5)
  384. 222 CONTINUE
  385. IPT5.NUM(1,1)=J
  386. NBELEM=NTOTMA(/1)
  387. SEGINI,IPT3
  388. * en fait on n'utilisera pas ipt3 dans numop2
  389. * contre performant + bug
  390. IPT3.ITYPEL=28
  391. DO 200 I=1,NTOTMA(/1)
  392. DO 201 J=1,ILOCAL(/1)
  393. IF (ILOCAL(J).EQ.NTOTMA(I)) GOTO 202
  394. 201 CONTINUE
  395. CALL ERREUR(5)
  396. RETURN
  397. 202 CONTINUE
  398. IPT3.NUM(1,I)=J
  399. 200 CONTINUE
  400.  
  401. ELSE
  402.  
  403. IKK=1
  404. 722 CONTINUE
  405. MELEME=IRIGEL(1,IKK)
  406. SEGACT,MELEME
  407. DESCR=IRIGEL(3,IKK)
  408. SEGACT,DESCR
  409. NLIGRE=LISINC(/2)
  410. DO 720 K=1,NLIGRE
  411. IF(LISINC(K).NE.'LX ') GO TO 721
  412. 720 CONTINUE
  413. SEGDES,MELEME
  414. SEGDES,DESCR
  415. IKK=IKK+1
  416. IF(IKK.LE.NNVA) GO TO 722
  417. DO 4862 I=1,NNVA
  418. MELEME= IRIGEL(1,I)
  419. SEGACT MELEME
  420. IF(ITYPEL.EQ.49) THEN
  421. DESCR=IRIGEL(3,I )
  422. SEGACT,DESCR
  423. K = 3
  424. GO TO 4863
  425. ELSE
  426. SEGDES MELEME
  427. ENDIF
  428. 4862 CONTINUE
  429. K=1
  430. MELEME= IRIGEL(1,1)
  431. DESCR= IRIGEL(3,1)
  432. SEGACT MELEME,DESCR
  433. 4863 CONTINUE
  434. 721 IA=NOELEP(K)
  435. I1=NUM(IA,1)
  436. NBSOUS=0
  437. NBNN=1
  438. NBREF=0
  439. NBELEM=1
  440. SEGDES,MELEME,DESCR
  441. SEGINI,IPT3
  442. IPT3.ITYPEL=1
  443. IPT3.NUM(1,1)=I1
  444. ipt5=ipt3
  445. ENDIF
  446. SEGDES IPT3
  447. NBSOUS=NNVA+2
  448. NBREF=0
  449. NBNN=0
  450. NBELEM=0
  451. SEGINI,IPT2
  452. IPT2.LISOUS(1)=IPT5
  453. IPT2.LISOUS(2)=IPT3
  454. NOSOUS=3
  455. DO 210 I=1,NNVA
  456. IPT2.LISOUS(NOSOUS)=IRIGEL(1,I)
  457. NOSOUS=NOSOUS+1
  458. 210 CONTINUE
  459.  
  460. NNGLOB=ILOCAL(/1)
  461. SEGINI,INUINV
  462. DO 450 I=1,NNGLOB
  463. INUINV(I)=ILOCAL(I)
  464. 450 CONTINUE
  465.  
  466. CALL NUMOPT(IPT2,INUINV,NNOE)
  467. segact inuinv*mod
  468. IF(NTOTMA(/1).NE.0) THEN
  469. * on remet les noeuds totalement maitre a la fin, ce que numopt ne fait
  470. * pas
  471. nbtmai=ntotma(/1)
  472. segact ipt3
  473. do i=1,nbtmai
  474. ** write(6,*) ' assem4 nnglob ',nnoe-ntotma(/1),
  475. ** > inuinv(ipt3.num(1,i))
  476. inuinv(ipt3.num(1,i))= inuinv(ipt3.num(1,i))+nnoe
  477. enddo
  478. segini inuin2
  479. do i=1,nnglob
  480. if (inuinv(i).ne.0) inuin2(inuinv(i))=i
  481. enddo
  482. icour=0
  483. do 803 i=1,2*nnoe
  484. if (inuin2(i).eq.0) goto 803
  485. icour=icour+1
  486. inuin2(icour)=inuin2(i)
  487. 803 continue
  488. do i=1,nnglob
  489. inuinv(i)=0
  490. enddo
  491. do i=1,nnoe
  492. if (inuin2(i).ne.0) inuinv(inuin2(i))=i
  493. enddo
  494. segsup inuin2
  495. ENDIF
  496.  
  497.  
  498. 800 CONTINUE
  499.  
  500. ** ON APPLIQUE LA NOUVELLE NUMEROTATION A INCPO ET A NTTMAI
  501.  
  502. SEGINI,MIPO1=MINCPO
  503. DO 600 I=1,NNGLOB
  504. IF (INUINV(I).EQ.0) GOTO 600
  505. DO 610 II=1,MAXINC
  506. INCPO(II,INUINV(I))=MIPO1.INCPO(II,ILOCAL(I))
  507. 610 CONTINUE
  508. 600 CONTINUE
  509.  
  510. SEGSUP,MIPO1
  511. DO 615 I=1,NTTMAI(/1)
  512. DO 616 II=1,ILOCAL(/1)
  513. IF (NTTMAI(I).EQ.ILOCAL(II)) THEN
  514. NTTMAI(I)=INUINV(II)
  515. GOTO 615
  516. ENDIF
  517. 616 CONTINUE
  518. 615 CONTINUE
  519.  
  520. DO 617 I=1,NTOTMA(/1)
  521. DO 618 II=1,ILOCAL(/1)
  522. IF (NTOTMA(I).EQ.ILOCAL(II)) THEN
  523. NTOTMA(I)=INUINV(II)
  524. GOTO 617
  525. ENDIF
  526. 618 CONTINUE
  527. 617 CONTINUE
  528. C
  529. C **** CREATION D'UN OBJET GEOMETRIE (IPT1) QU'IL FAUDRA CHANGER EN CAS DE
  530. C **** RENUMEROTATION GENERALE. ON PROFITE DE LA BOUCLE POUR CREER LE
  531. C **** TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I (NU-
  532. C **** MEROTATION LOCALE).
  533. C
  534. SEGINI,IMIN
  535. NBSOUS=0
  536. NBREF=0
  537. NBNN=1
  538. NBELEM=NNOE
  539. SEGINI,IPT1
  540. IPT1.ITYPEL=IPOIN
  541. DO 316 IRI=1,NNVA
  542. MELEME=IRIGEL(1,IRI)
  543. SEGACT,MELEME
  544. N1=NUM(/1)
  545. N2=NUM(/2)
  546. DO I=1,N2
  547. DO J=1,N1
  548. K=NUM(J,I)
  549. M=INUINV(K)
  550. IMIN(M)=IMIN(M)+1
  551. IPT1.NUM(1,M)=K
  552. enddo
  553. enddo
  554. SEGDES,MELEME
  555. 316 CONTINUE
  556. DO 3161 I=1,NOMAI(/1)
  557. IF(NOMAI(I).EQ.0) GO TO 3161
  558. IPT1.NUM(1,INUINV(I))=I
  559. 3161 CONTINUE
  560.  
  561.  
  562. C **** INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER
  563. C **** DANS ITOPO .
  564. C
  565. SEGINI,IITOP
  566. IITOP(1)=1
  567. DO 318 I=1,NNOE
  568. IITOP(I+1)=IMIN(I)* 2 + IITOP(I)
  569. 318 CONTINUE
  570. DO I=1,NNOE
  571. IMIN(I)=0
  572. enddo
  573. IENNO=IITOP(NNOE+1)
  574. SEGINI,ITOPO
  575. DO 321 IRI=1,NNVA
  576. MELEME=IRIGEL(1,IRI)
  577. SEGACT,MELEME
  578. N1=NUM(/1)
  579. N2=NUM(/2)
  580. DO I=1,N2
  581. DO J=1,N1
  582. K=NUM(J,I)
  583. M=INUINV(K)
  584. IMIN(M)=IMIN(M)+1
  585. IUY= 2* ( IMIN(M)-1 ) + IITOP(M)
  586. ITOPO(IUY)=I
  587. ITOPO(IUY+1)=IRI
  588. enddo
  589. enddo
  590. SEGDES,MELEME
  591. 321 CONTINUE
  592. C
  593. C *** NUMEROTATION DES INCONNUES DE INCPO
  594. C
  595. NA=0
  596.  
  597. DO 337 I=1,NNOE
  598. nad=na
  599. diamax=0.d0
  600. DO 335 K=1,MAXINC
  601. IF(INCPO(K,I).EQ.0) GO TO 335
  602. IF (INCPO(K,I).LT.MAXPOD) THEN
  603. NA=NA+1
  604. INCPO(K,I)=NA
  605. itrv1(na-nad)=k
  606. dtrv1(na-nad)= -diatmp(k,i)
  607. diamax=max(diamax,abs(dtrv1(na-nad)))
  608. ENDIF
  609. 335 CONTINUE
  610. diaref = diamax * xszpre
  611. * pour les multiplicateurs de lagrange?
  612. do k=1,na-nad
  613. if (abs(dtrv1(k)).lt.diaref) then
  614. ** write (6,*) ' terme diag petit ',dtrv1(k)
  615. dtrv1(k)=dtrv1(k)+diamax
  616. endif
  617. enddo
  618. * trier incpo suivant les val de diatmp
  619. call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
  620. do k=1,na-nad
  621. incpo(itrv1(k),i)=k+nad
  622. enddo
  623. 337 CONTINUE
  624. DO 339 I=1,NTTMAI(/1)
  625. NAD=NA
  626. diamax=0.d0
  627. N1=NTTMAI(I)
  628. DO 338 K=1,MAXINC
  629. IF(INCPO(K,N1).EQ.0) GO TO 338
  630. IF (INCPO(K,N1).EQ.MAXPOD) THEN
  631. NA=NA+1
  632. INCPO(K,N1)=NA
  633. itrv1(na-nad)=k
  634. dtrv1(na-nad)= -diatmp(k,n1)
  635. diamax=max(diamax,abs(dtrv1(na-nad)))
  636. ENDIF
  637. 338 CONTINUE
  638. diaref = diamax * xszpre
  639. * pour les multiplicateurs de lagrange?
  640. do k=1,na-nad
  641. if (abs(dtrv1(k)).lt.diaref) then
  642. ** write (6,*) ' terme diag petit ',dtrv1(na-nad)
  643. dtrv1(k)=dtrv1(k)+diamax
  644. endif
  645. enddo
  646. * trier incpo suivant les val de diatmp
  647. call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
  648. do k=1,na-nad
  649. incpo(itrv1(k),n1)=k+nad
  650. enddo
  651. 339 CONTINUE
  652. C
  653. C CREATION DU DESCRIPTEUR DE LA RIGIDITE EQUIVALENTE
  654. C
  655. NLIGRD=NLIGRA
  656. NLIGRP=NLIGRA
  657. SEGINI,DES1
  658. DO 341 IGLOB=1,NOMAI(/1)
  659. IF(NOMAI(IGLOB).EQ.0) GOTO 341
  660. ILOC=INUINV(IGLOB)
  661. DO 342 I=1,INCPO(/1)
  662. IF(INCPO(I,ILOC).GT.NBNNMA) THEN
  663. ICOL=INCPO(I,ILOC)-NBNNMA
  664. DES1.NOELEP(ICOL)=NOMAI(IGLOB)
  665. DES1.NOELED(ICOL)=NOMAI(IGLOB)
  666. DES1.LISINC(ICOL)=IMIK(I)
  667. DES1.LISDUA(ICOL)=IDUA(I)
  668. ENDIF
  669. 342 CONTINUE
  670. 341 CONTINUE
  671. segsup diatmp,strv
  672. SEGDES DES1
  673.  
  674. SEGDES,MIDUA,MIMIK,MHARK
  675.  
  676. SEGDES,MRIGID
  677.  
  678. SEGDES,ITOPO
  679. SEGDES,IITOP
  680. SEGDES,INUINV
  681. SEGDES,IPT1
  682. SEGDES,MINCPO
  683. SEGSUP,IMIN
  684. SEGDES,INCTRR
  685. INCTRY=INCTRR
  686. SEGINI,MMATRI
  687. NENS=0
  688. IGEOMA=IPT1
  689. IIDUA=MIDUA
  690. IINCPO=MINCPO
  691. IIMIK=MIMIK
  692. IHARK=MHARK
  693. INUINY=INUINV
  694. ITOPOY=ITOPO
  695. IITOPY=IITOP
  696. MMATRX=MMATRI
  697. SEGDES,MMATRI
  698. SEGDES,ILOCAL
  699. SEGDES,MELEME
  700. SEGDES,DESCR
  701. SEGDES,SNTT
  702. SEGDES,SNTO
  703. SEGDES NOMAI
  704. SEGDES SNOMIN
  705. RETURN
  706. END
  707.  
  708.  
  709.  
  710.  
  711.  
  712.  
  713.  
  714.  
  715.  
  716.  
  717.  
  718.  
  719.  
  720.  
  721.  
  722.  
  723.  
  724.  
  725.  
  726.  
  727.  
  728.  
  729.  
  730.  
  731.  
  732.  
  733.  
  734.  
  735.  
  736.  
  737.  
  738.  
  739.  
  740.  
  741.  
  742.  
  743.  
  744.  
  745.  

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