Télécharger assem4.eso

Retour à la liste

Numérotation des lignes :

assem4
  1. C ASSEM4 SOURCE PV 21/01/29 21:15:10 10866
  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. IPT3.ITYPEL=0
  389. DO 200 I=1,NTOTMA(/1)
  390. DO 201 J=1,ILOCAL(/1)
  391. IF (ILOCAL(J).EQ.NTOTMA(I)) GOTO 202
  392. 201 CONTINUE
  393. CALL ERREUR(5)
  394. RETURN
  395. 202 CONTINUE
  396. IPT3.NUM(1,I)=J
  397. 200 CONTINUE
  398.  
  399. ELSE
  400.  
  401. IKK=1
  402. 722 CONTINUE
  403. MELEME=IRIGEL(1,IKK)
  404. SEGACT,MELEME
  405. DESCR=IRIGEL(3,IKK)
  406. SEGACT,DESCR
  407. NLIGRE=LISINC(/2)
  408. DO 720 K=1,NLIGRE
  409. IF(LISINC(K).NE.'LX ') GO TO 721
  410. 720 CONTINUE
  411. SEGDES,MELEME
  412. SEGDES,DESCR
  413. IKK=IKK+1
  414. IF(IKK.LE.NNVA) GO TO 722
  415. DO 4862 I=1,NNVA
  416. MELEME= IRIGEL(1,I)
  417. SEGACT MELEME
  418. IF(ITYPEL.EQ.49) THEN
  419. DESCR=IRIGEL(3,I )
  420. SEGACT,DESCR
  421. K = 3
  422. GO TO 4863
  423. ELSE
  424. SEGDES MELEME
  425. ENDIF
  426. 4862 CONTINUE
  427. K=1
  428. MELEME= IRIGEL(1,1)
  429. DESCR= IRIGEL(3,1)
  430. SEGACT MELEME,DESCR
  431. 4863 CONTINUE
  432. 721 IA=NOELEP(K)
  433. I1=NUM(IA,1)
  434. NBSOUS=0
  435. NBNN=1
  436. NBREF=0
  437. NBELEM=1
  438. SEGDES,MELEME,DESCR
  439. SEGINI,IPT3
  440. IPT3.ITYPEL=1
  441. IPT3.NUM(1,1)=I1
  442. ipt5=ipt3
  443. ENDIF
  444. SEGDES IPT3
  445. NBSOUS=NNVA+2
  446. NBREF=0
  447. NBNN=0
  448. NBELEM=0
  449. SEGINI,IPT2
  450. IPT2.LISOUS(1)=IPT5
  451. IPT2.LISOUS(2)=IPT3
  452. NOSOUS=3
  453. DO 210 I=1,NNVA
  454. IPT2.LISOUS(NOSOUS)=IRIGEL(1,I)
  455. NOSOUS=NOSOUS+1
  456. 210 CONTINUE
  457. SEGDES IPT2
  458.  
  459. NNGLOB=ILOCAL(/1)
  460. SEGINI,INUINV
  461. DO 450 I=1,NNGLOB
  462. INUINV(I)=ILOCAL(I)
  463. 450 CONTINUE
  464.  
  465. CALL NUMOPT(IPT2,INUINV,NNOE)
  466. segact inuinv*mod
  467. IF(NTOTMA(/1).NE.0) THEN
  468. * on remet les noeuds totalement maitre a la fin, ce que numopt ne fait
  469. * pas
  470. nbtmai=ntotma(/1)
  471. segact ipt3
  472. do i=1,nbtmai
  473. ** write(6,*) ' assem4 nnglob ',nnoe-ntotma(/1),
  474. ** > inuinv(ipt3.num(1,i))
  475. inuinv(ipt3.num(1,i))= inuinv(ipt3.num(1,i))+nnoe
  476. enddo
  477. segini inuin2
  478. do i=1,nnglob
  479. if (inuinv(i).ne.0) inuin2(inuinv(i))=i
  480. enddo
  481. icour=0
  482. do 803 i=1,2*nnoe
  483. if (inuin2(i).eq.0) goto 803
  484. icour=icour+1
  485. inuin2(icour)=inuin2(i)
  486. 803 continue
  487. do i=1,nnglob
  488. inuinv(i)=0
  489. enddo
  490. do i=1,nnoe
  491. if (inuin2(i).ne.0) inuinv(inuin2(i))=i
  492. enddo
  493. segsup inuin2
  494. ENDIF
  495.  
  496.  
  497. 800 CONTINUE
  498.  
  499. ** ON APPLIQUE LA NOUVELLE NUMEROTATION A INCPO ET A NTTMAI
  500.  
  501. SEGINI,MIPO1=MINCPO
  502. DO 600 I=1,NNGLOB
  503. IF (INUINV(I).EQ.0) GOTO 600
  504. DO 610 II=1,MAXINC
  505. INCPO(II,INUINV(I))=MIPO1.INCPO(II,ILOCAL(I))
  506. 610 CONTINUE
  507. 600 CONTINUE
  508.  
  509. SEGSUP,MIPO1
  510. DO 615 I=1,NTTMAI(/1)
  511. DO 616 II=1,ILOCAL(/1)
  512. IF (NTTMAI(I).EQ.ILOCAL(II)) THEN
  513. NTTMAI(I)=INUINV(II)
  514. GOTO 615
  515. ENDIF
  516. 616 CONTINUE
  517. 615 CONTINUE
  518.  
  519. DO 617 I=1,NTOTMA(/1)
  520. DO 618 II=1,ILOCAL(/1)
  521. IF (NTOTMA(I).EQ.ILOCAL(II)) THEN
  522. NTOTMA(I)=INUINV(II)
  523. GOTO 617
  524. ENDIF
  525. 618 CONTINUE
  526. 617 CONTINUE
  527. C
  528. C **** CREATION D'UN OBJET GEOMETRIE (IPT1) QU'IL FAUDRA CHANGER EN CAS DE
  529. C **** RENUMEROTATION GENERALE. ON PROFITE DE LA BOUCLE POUR CREER LE
  530. C **** TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I (NU-
  531. C **** MEROTATION LOCALE).
  532. C
  533. SEGINI,IMIN
  534. NBSOUS=0
  535. NBREF=0
  536. NBNN=1
  537. NBELEM=NNOE
  538. SEGINI,IPT1
  539. IPT1.ITYPEL=IPOIN
  540. DO 316 IRI=1,NNVA
  541. MELEME=IRIGEL(1,IRI)
  542. SEGACT,MELEME
  543. N1=NUM(/1)
  544. N2=NUM(/2)
  545. DO I=1,N2
  546. DO J=1,N1
  547. K=NUM(J,I)
  548. M=INUINV(K)
  549. IMIN(M)=IMIN(M)+1
  550. IPT1.NUM(1,M)=K
  551. enddo
  552. enddo
  553. SEGDES,MELEME
  554. 316 CONTINUE
  555. DO 3161 I=1,NOMAI(/1)
  556. IF(NOMAI(I).EQ.0) GO TO 3161
  557. IPT1.NUM(1,INUINV(I))=I
  558. 3161 CONTINUE
  559.  
  560.  
  561. C **** INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER
  562. C **** DANS ITOPO .
  563. C
  564. SEGINI,IITOP
  565. IITOP(1)=1
  566. DO 318 I=1,NNOE
  567. IITOP(I+1)=IMIN(I)* 2 + IITOP(I)
  568. 318 CONTINUE
  569. DO I=1,NNOE
  570. IMIN(I)=0
  571. enddo
  572. IENNO=IITOP(NNOE+1)
  573. SEGINI,ITOPO
  574. DO 321 IRI=1,NNVA
  575. MELEME=IRIGEL(1,IRI)
  576. SEGACT,MELEME
  577. N1=NUM(/1)
  578. N2=NUM(/2)
  579. DO I=1,N2
  580. DO J=1,N1
  581. K=NUM(J,I)
  582. M=INUINV(K)
  583. IMIN(M)=IMIN(M)+1
  584. IUY= 2* ( IMIN(M)-1 ) + IITOP(M)
  585. ITOPO(IUY)=I
  586. ITOPO(IUY+1)=IRI
  587. enddo
  588. enddo
  589. SEGDES,MELEME
  590. 321 CONTINUE
  591. C
  592. C *** NUMEROTATION DES INCONNUES DE INCPO
  593. C
  594. NA=0
  595.  
  596. DO 337 I=1,NNOE
  597. nad=na
  598. diamax=0.d0
  599. DO 335 K=1,MAXINC
  600. IF(INCPO(K,I).EQ.0) GO TO 335
  601. IF (INCPO(K,I).LT.MAXPOD) THEN
  602. NA=NA+1
  603. INCPO(K,I)=NA
  604. itrv1(na-nad)=k
  605. dtrv1(na-nad)= -diatmp(k,i)
  606. diamax=max(diamax,abs(dtrv1(na-nad)))
  607. ENDIF
  608. 335 CONTINUE
  609. diaref = diamax * xszpre
  610. * pour les multiplicateurs de lagrange?
  611. do k=1,na-nad
  612. if (abs(dtrv1(k)).lt.diaref) then
  613. ** write (6,*) ' terme diag petit ',dtrv1(k)
  614. dtrv1(k)=dtrv1(k)+diamax
  615. endif
  616. enddo
  617. * trier incpo suivant les val de diatmp
  618. ** call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
  619. do k=1,na-nad
  620. incpo(itrv1(k),i)=k+nad
  621. enddo
  622. 337 CONTINUE
  623. DO 339 I=1,NTTMAI(/1)
  624. NAD=NA
  625. diamax=0.d0
  626. N1=NTTMAI(I)
  627. DO 338 K=1,MAXINC
  628. IF(INCPO(K,N1).EQ.0) GO TO 338
  629. IF (INCPO(K,N1).EQ.MAXPOD) THEN
  630. NA=NA+1
  631. INCPO(K,N1)=NA
  632. itrv1(na-nad)=k
  633. dtrv1(na-nad)= -diatmp(k,n1)
  634. diamax=max(diamax,abs(dtrv1(na-nad)))
  635. ENDIF
  636. 338 CONTINUE
  637. diaref = diamax * xszpre
  638. * pour les multiplicateurs de lagrange?
  639. do k=1,na-nad
  640. if (abs(dtrv1(k)).lt.diaref) then
  641. ** write (6,*) ' terme diag petit ',dtrv1(na-nad)
  642. dtrv1(k)=dtrv1(k)+diamax
  643. endif
  644. enddo
  645. * trier incpo suivant les val de diatmp
  646. ** call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
  647. do k=1,na-nad
  648. incpo(itrv1(k),n1)=k+nad
  649. enddo
  650. 339 CONTINUE
  651. C
  652. C CREATION DU DESCRIPTEUR DE LA RIGIDITE EQUIVALENTE
  653. C
  654. NLIGRD=NLIGRA
  655. NLIGRP=NLIGRA
  656. SEGINI,DES1
  657. DO 341 IGLOB=1,NOMAI(/1)
  658. IF(NOMAI(IGLOB).EQ.0) GOTO 341
  659. ILOC=INUINV(IGLOB)
  660. DO 342 I=1,INCPO(/1)
  661. IF(INCPO(I,ILOC).GT.NBNNMA) THEN
  662. ICOL=INCPO(I,ILOC)-NBNNMA
  663. DES1.NOELEP(ICOL)=NOMAI(IGLOB)
  664. DES1.NOELED(ICOL)=NOMAI(IGLOB)
  665. DES1.LISINC(ICOL)=IMIK(I)
  666. DES1.LISDUA(ICOL)=IDUA(I)
  667. ENDIF
  668. 342 CONTINUE
  669. 341 CONTINUE
  670. segsup diatmp,strv
  671. SEGDES DES1
  672.  
  673. SEGDES,MIDUA,MIMIK,MHARK
  674.  
  675. SEGDES,MRIGID
  676.  
  677. SEGDES,ITOPO
  678. SEGDES,IITOP
  679. SEGDES,INUINV
  680. SEGDES,IPT1
  681. SEGDES,MINCPO
  682. SEGSUP,IMIN
  683. SEGDES,INCTRR
  684. INCTRY=INCTRR
  685. SEGINI,MMATRI
  686. NENS=0
  687. IGEOMA=IPT1
  688. IIDUA=MIDUA
  689. IINCPO=MINCPO
  690. IIMIK=MIMIK
  691. IHARK=MHARK
  692. INUINY=INUINV
  693. ITOPOY=ITOPO
  694. IITOPY=IITOP
  695. MMATRX=MMATRI
  696. SEGDES,MMATRI
  697. SEGDES,ILOCAL
  698. SEGDES,MELEME
  699. SEGDES,DESCR
  700. SEGDES,SNTT
  701. SEGDES,SNTO
  702. SEGDES NOMAI
  703. SEGDES SNOMIN
  704. RETURN
  705. END
  706.  
  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.  

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