Télécharger asns1.eso

Retour à la liste

Numérotation des lignes :

  1. C ASNS1 SOURCE PV 18/11/16 22:49:04 9993
  2. SUBROUTINE ASNS1 ( IPOIRI,MMATRX,INUINY,ITOPOY,IMINIY,IPOY,
  3. & INCTRY,INCTRZ,IITOPY,ITOPOD,IITOPD,IPODD)
  4.  
  5. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  6. C CE SUBROUTINE SERT A L'ASSEMBLAGE DE MATRICES SYMETRIQUES
  7. C EN VUE D'UNE INVERSION PAR UNE METHODE DE CROUT
  8. C
  9. C EN ENTREE:
  10. C **** IPOIRI: POINTEUR SUR OBJET MRIGIDITE,NON MODIFIE
  11. C EN SORTIE:
  12. C **** INUINV IMINI ITOPO IPOY INCTRY SONT DES POINTEURS DES SEGMENTS
  13. C DE TRAVAIL SERVANT A L'ASSEMBLAGE ILS SONT DETRUITS EN FIN
  14. C D'ASSEMBLAGE OU DE TRIANGULARISATION
  15. C **** MMATRI EST LE POINTEUR DE L'OBJET FUTUR MATRICE TRIANGULARISEE.
  16. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  17.  
  18. IMPLICIT INTEGER(I-N)
  19. -INC CCOPTIO
  20. -INC SMELEME
  21. -INC SMCOORD
  22.  
  23. SEGMENT,IMIN(NNOE)
  24. SEGMENT,IMINB(NNOE)
  25. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  26. C
  27. -INC SMRIGID
  28. -INC SMMATRI
  29. C
  30. SEGMENT,INUINV(NNGLOB)
  31. SEGMENT,ITOPO(IENNO)
  32. SEGMENT,IITOP(NNOE+1)
  33. SEGMENT,ITOPOB(IENNO)
  34. SEGMENT,IITOPB(NNOE+1)
  35. SEGMENT,IMINI(INC)
  36. SEGMENT,IPOS(NNOE1)
  37. SEGMENT,IPOD(NNOE1)
  38. SEGMENT,INCTRR(NIRI)
  39. SEGMENT,INCTRD(NIRI)
  40. SEGMENT,INCTRA(NLIGRE)
  41. SEGMENT DIATMP(maxt,NNOE)
  42. segment strv
  43. integer itrv1(maxt)
  44. integer itrv2(maxt)
  45. real*8 dtrv1(maxt)
  46. real*8 dtrv2(maxt)
  47. endsegment
  48. segment mondu
  49. character*4 mondua(nnn)
  50. integer ipris(nnn),inosel(nnn)
  51. endsegment
  52.  
  53. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  54. C **** CES TABLEAUX SERVENT AU REPERAGE DE LA MATRICE POUR L'ASSEMBLAG
  55. C **** IL SERONT TOUS SUPPRIMES EN FIN D'ASSEMBLAGE.
  56. C
  57. C
  58. C **** MAXINC= MAXIMUM DE COMPOSANTES CONCERNANT UN NOEUD
  59. C
  60. C
  61. C **** IITOP(K)=I LE 1ER ELEMENT TOUCHANT LE NOEUD K SE TROUVE EN
  62. C IEME POSITION DANS ITOPO
  63. C **** ITOPO(I)=L: LE 1ER ELEMENT TOUCHANT LE K EME NOEUD DE LA
  64. C ITOPO(I+1)=M MATRICE EST LE LIEME DE L'OBJET GEOMETRIE
  65. C DEFINI PAR LE POINTEUR M
  66. C **** IPOS(I)=J : LA 1 ERE INCONNUE DU NOEUD I EST EN J+1 EME
  67. C POSITION
  68. C **** IMINI(I)=J LA PLUS PETITE INCONNUE QUI EST RELIEE A LA IEME
  69. C EST L'INCONNUE J.
  70. C **** INUINV(I)=J J EST LE NOUVEAU NUMERO DU NOEUD I
  71. C
  72. C **** INCTRR(NIRI) - NIRI=NRIGEL du IPOIRI (objet MRIGID passé en argument)
  73. C pointeurs sur INCTRA
  74. C
  75. C Variables locales :
  76. C --------------------
  77. C * NNVA = NRIGEL (nombre d'objets MRIGID élémentaires) dans IPOIRI (objet
  78. C MRIGID) passé en argument)
  79. C * NLIGRE = NLIGRP - nombre de variables primales (dans un segment DESCR)
  80. C * IMELP = pointeur d'un MELEME contenant un noeud "normal"
  81. C * ICDOUR = ???
  82. C
  83. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  84.  
  85. CHARACTER*4 CNOHA,lisi
  86. integer*4 noha
  87. equivalence (cnoha,noha)
  88. DATA CNOHA/'NOHA'/
  89. DATA IPOIN/1/
  90.  
  91. NNGLOB=XCOOR(/1)/(IDIM+1)
  92.  
  93. MRIGID=IPOIRI
  94. SEGACT,MRIGID
  95.  
  96. NNVA=IRIGEL(/2)
  97. NIRI=NNVA
  98. SEGINI,INCTRR
  99. SEGINI,INCTRD
  100.  
  101. MELEME=IRIGEL(1,1)
  102. SEGACT MELEME
  103. C ... ITYPEL = 27 correspond aux éléments 'ATTA' ...
  104. IF(ITYPEL.NE.27) GO TO 801
  105. SEGDES MELEME
  106. C
  107. C **** ASSEMBLAGE DANS LE CAS DE L'ANALYSE MODALE. ON COMPTE LES POINTS
  108. C **** DANS ICPR
  109. C
  110. SEGINI INUINV,ICPR
  111. IKI=0
  112. DO 700 I=1,NNVA
  113. MELEME=IRIGEL(1,I)
  114. SEGACT MELEME
  115. NBNN=NUM(/1)
  116. NBELEM=NUM(/2)
  117. DO 701 I1=1,NBELEM
  118. DO 701 I2=1,NBNN
  119. IP1=NUM(I2,I1)
  120. IF(ICPR(IP1).NE.0) GO TO 701
  121. IKI=IKI+1
  122. ICPR(IP1)=IKI
  123. 701 CONTINUE
  124. SEGDES MELEME
  125. 700 CONTINUE
  126. C
  127. C **** FABRICATION DU TABLEAU INUINV
  128. C **** ON MET LES POINTS QUI ONT POUR INCONNUE ALFA EN TETE
  129. C
  130. NNOE=IKI
  131. NBETA=0
  132. DO 710 I=1,NNVA
  133. MELEME=IRIGEL(1,I)
  134. DESCR =IRIGEL(3,I)
  135. SEGACT MELEME,DESCR
  136. NBNN=NUM(/1)
  137. NBELEM=NUM(/2)
  138. NLIGRE=LISINC(/2)
  139. DO 711 I1=1,NBELEM
  140. DO 711 I2=1,NBNN
  141. IP1=NUM(I2,I1)
  142. IF(ICPR(IP1).EQ.0) GO TO 711
  143. 715 CONTINUE
  144. NBETA=NBETA+1
  145. IKI=NNOE-NBETA+1
  146. 716 CONTINUE
  147. INUINV(IP1)=IKI
  148. ICPR(IP1)=0
  149. 711 CONTINUE
  150. SEGDES MELEME,DESCR
  151. * SEGSUP IPB
  152. 710 CONTINUE
  153. SEGSUP ICPR
  154. ICDOUR=NNOE
  155. GO TO 800
  156. C
  157. C **** ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES
  158. C **** GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA OBJETS
  159. C **** GEOMETRIQUES ELEMENTAIRES. PUIS ON ENVOIE DANS NUMOPT QUI
  160. C **** FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU
  161. C **** NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR.
  162. C **** LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD
  163. C **** DE LA MATRICE, ETC...
  164. C
  165. 801 CONTINUE
  166. IKK=1
  167. 722 CONTINUE
  168. MELEME=IRIGEL(1,IKK)
  169. SEGACT,MELEME
  170.  
  171. DESCR=IRIGEL(3,IKK)
  172. SEGACT,DESCR
  173.  
  174. NLIGRE=LISINC(/2)
  175. DO 720 K=1,NLIGRE
  176. IF(LISINC(K).NE.'LX ') GO TO 721
  177. 720 CONTINUE
  178. SEGDES,MELEME
  179. SEGDES,DESCR
  180. IKK=IKK+1
  181. IF(IKK.LE.NNVA) GO TO 722
  182. DO 4862 I=1,NNVA
  183. MELEME= IRIGEL(1,I)
  184. SEGACT MELEME
  185. IF(ITYPEL.EQ.22) THEN
  186. DESCR=IRIGEL(3,I )
  187. SEGACT,DESCR
  188. K = 3
  189. GO TO 721
  190. ELSE
  191. SEGDES MELEME
  192. ENDIF
  193. 4862 CONTINUE
  194. K=1
  195. MELEME= IRIGEL(1,1)
  196. DESCR= IRIGEL(3,1)
  197. SEGACT MELEME,DESCR
  198.  
  199. C ... On arrive ici si :
  200. C * LISINC(K) != 'LX ' => K est le premier parmi K tels que LISINC(K) != 'LX '
  201. C * ITYPEL d'un des maillages = 22 (élément 'MULT') => K = 3
  202. C * tous les autres cas => K = 1
  203.  
  204. C ... IA = numéro (dans l'élément) du noeud concerné par le DDL No K ...
  205. C ... I1 = numéro (absolu) du noeud concerné par le DDL No K,
  206. C Ce noeud sera mis dans un MELEME dont le pointeur est stocké dans IMELP ...
  207.  
  208. 721 IA=NOELEP(K)
  209. I1=NUM(IA,1)
  210. SEGDES,MELEME,DESCR
  211.  
  212. NBSOUS=0
  213. NBNN=1
  214. NBREF=0
  215. NBELEM=1
  216. SEGINI,MELEME
  217. ITYPEL=1
  218. NUM(1,1)=I1
  219. SEGDES,MELEME
  220. IMELP=MELEME
  221.  
  222. C ... Le MELEME créé ici est un MELEME composé qui contiendra le MELEME
  223. C pointé par IMELP et tous les MELEME pointés par IRIGEL(1,*) ...
  224. NBSOUS=NNVA+1
  225. NBREF=0
  226. NBNN=0
  227. NBELEM=0
  228. SEGINI,MELEME
  229. LISOUS(1)=IMELP
  230. DO 12 I=1,NNVA
  231. LISOUS(I+1)=IRIGEL(1,I)
  232. 12 CONTINUE
  233. SEGDES,MELEME
  234.  
  235. ICDOUR=0
  236. SEGINI,INUINV
  237. SEGDES,INUINV
  238. CALL NUMOPT(MELEME,INUINV,ICDOUR)
  239. C ... A la sortie INUINV contient l'ordre des noeuds et ICDOUR le nombre de noeuds présents dans MELEME ...
  240. SEGACT INUINV
  241. SEGSUP,MELEME
  242. MELEME=IMELP
  243. SEGDES,MELEME
  244. C
  245. C **** CREATION D'UN OBJET GEOMETRIE QU'IL FAUDRA CHANGER EN CAS DE
  246. C **** RENUMEROTATION GENERALE.ON PROFITE DE LA BOUCLE POUR CREE LE
  247. C **** TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I(NU-
  248. C **** MEROTATION LOCALE).
  249. C
  250. 800 CONTINUE
  251. NNOE=ICDOUR
  252. SEGINI,IMIN,IMINB
  253. NNOE1=NNOE+1
  254. SEGINI,IPOS,IPOD
  255. NBSOUS=0
  256. NBREF=0
  257. NBNN=1
  258. NBELEM=ICDOUR
  259. SEGINI,IPT1
  260. IPT1.ITYPEL=IPOIN
  261. DO 16 IRI=1,NNVA
  262. DO 170 I=1,NNOE
  263. ipod(I)=0
  264. 170 IPOS(I)=0
  265. MELEME=IRIGEL(1,IRI)
  266. SEGACT,MELEME
  267. DESCR=IRIGEL(3,IRI)
  268. segact descr
  269. N1=NUM(/1)
  270. N2=NUM(/2)
  271. * write(6,*) 'noelep', ( noelep(iu),iu=1,noelep(/1))
  272. * write(6,*) 'noeled', ( noeled(iu),iu=1,noeled(/1))
  273. DO 17 I=1,N2
  274. DO 171 J=1,NOELEP(/1)
  275. K = NUM( NOELEP(J),I)
  276. M=INUINV(K)
  277. IF(IPOS(M).NE.I) THEN
  278. IMIN(M)=IMIN(M)+1
  279. IPT1.NUM(1,M)=K
  280. IPOS(M)=I
  281. ENDIF
  282. 171 CONTINUE
  283. DO 172 J=1,NOELED(/1)
  284. K = NUM( NOELED(J),I)
  285. M=INUINV(K)
  286. IF(IPOD(M).NE.I) THEN
  287. IMINB(M)=IMINB(M)+1
  288. IPOD(M)=I
  289. ENDIF
  290. 172 CONTINUE
  291. 17 CONTINUE
  292. SEGDES,MELEME
  293. 16 CONTINUE
  294. C
  295. C **** INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER
  296. C **** DANS ITOPO .
  297. C ... ITOPO contiendra pour chaque noeud et chaque élément contenant
  298. C ce noeud 2 nombres :
  299. C 1. numéro de l'élément dans son maillage
  300. C 2. numéro du maillage (dans IRIGEL) de cet élément
  301. C
  302. C ... IITOP servira pour déterminer la taille de ITOPO ainsi que pour
  303. C se retrouver dedans ...
  304. C
  305. SEGINI,IITOP,IITOPB
  306. IITOP(1)=1
  307. IITOPB(1)=1
  308. * write(6,*) ' imin', ( imin(iu),iu=1,imin(/1))
  309. * write(6,*) ' iminb', ( iminb(iu),iu=1,iminb(/1))
  310. DO 18 I=1,NNOE
  311. IITOP(I+1)=IMIN(I)* 2 + IITOP(I)
  312. IITOPB(I+1)=IMINB(I)* 2 + IITOPB(I)
  313. 18 CONTINUE
  314. DO 19 I=1,NNOE
  315. IMINB(I)=0
  316. 19 IMIN(I)=0
  317. C ... IENNO = taille d'ITOPO ...
  318. IENNO=IITOP(NNOE+1)
  319. SEGINI,ITOPO
  320. IENNO=IITOPB(NNOE+1)
  321. SEGINI ITOPOB
  322. DO 21 IRI=1,NNVA
  323. DO 220 I=1,NNOE
  324. IPOD(I)=0
  325. 220 IPOS(I)=0
  326. MELEME=IRIGEL(1,IRI)
  327. SEGACT,MELEME
  328. DESCR = IRIGEL(3,IRI)
  329. N2=NUM(/2)
  330. DO 22 I=1,N2
  331. DO 221 J=1,NOELEP(/1)
  332. M=INUINV(NUM(NOELEP(J),I))
  333. IF(IPOS(M).NE.I) THEN
  334. IMIN(M)=IMIN(M)+1
  335. IUY= 2* ( IMIN(M)-1 ) + IITOP(M)
  336. C ... Remplissage d'ITOPO ...
  337. ITOPO(IUY)=I
  338. ITOPO(IUY+1)=IRI
  339. IPOS(M)=I
  340. ENDIF
  341. 221 CONTINUE
  342. DO 222 J=1,NOELED(/1)
  343. M=INUINV(NUM(NOELED(J),I))
  344. IF(IPOD(M).NE.I) THEN
  345. IMINB(M)=IMINB(M)+1
  346. IUY= 2* ( IMINB(M)-1 ) + IITOPB(M)
  347. C ... Remplissage d'ITOPO ...
  348. ITOPOB(IUY)=I
  349. ITOPOB(IUY+1)=IRI
  350. IPOD(M)=I
  351. ENDIF
  352. 222 CONTINUE
  353. 22 CONTINUE
  354. SEGDES,MELEME
  355. 21 CONTINUE
  356. C
  357. C RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS
  358. C DE L'UTILISATION DE " OPTION MODE FOUR NOHAR "
  359. C
  360. C ... On passe cette boucle sans erreur si tous les IRIGEL(5,*) sont égaux
  361. C soit à NOHA soit à une autre valeur fixe (IARDEF) ...
  362. C
  363. DO 230 IRI=1,NNVA
  364. IHARIR=IRIGEL(5,IRI)
  365. IF( IHARIR . NE. NOHA) THEN
  366. IARDEF = IHARIR
  367. GO TO 231
  368. ENDIF
  369. 230 CONTINUE
  370. CALL ERREUR ( 21)
  371. RETURN
  372.  
  373. 231 CONTINUE
  374. DO 232 IRI=1,NNVA
  375. IF( IRIGEL(5,IRI) .EQ.NOHA) GO TO 232
  376. IF( IRIGEL(5,IRI).EQ.IARDEF ) GO TO 232
  377. CALL ERREUR (21)
  378. RETURN
  379. 232 CONTINUE
  380. C
  381. C **** RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS
  382. C
  383. C ... Les quatre segments sont à l'origine de longueur nulle ...
  384. SEGINI,MIDUA
  385. SEGINI,MIMIK
  386. SEGINI,MHARK
  387. SEGINI,MHAR1
  388.  
  389. DESCR=IRIGEL(3,1)
  390. SEGACT,DESCR
  391.  
  392. IMIK(**)=LISINC(1)
  393. IAAR=IRIGEL(5,1)
  394. IF(IAAR.EQ.NOHA) IAAR = IARDEF
  395. IHAR(**)= IAAR
  396. IDUA(**)=LISDUA(1)
  397. MHAR1.IHAR(**)= IAAR
  398.  
  399. MAXINC=1
  400. DO 23 IRI=1,NNVA
  401. DESCR=IRIGEL(3,IRI)
  402. IHARIR=IRIGEL(5,IRI)
  403. IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
  404. SEGACT,DESCR
  405. NLIGRE=LISINC(/2)
  406. DO 26 I=1,NLIGRE
  407. DO 24 J=1,MAXINC
  408. IF(IMIK(J).NE.LISINC(I)) GO TO 24
  409. IF(IHAR(J).EQ.IHARIR) GO TO 26
  410. 24 CONTINUE
  411. C ... On empile les valeurs d'IHARIR et LISINC dans
  412. C leurs segments si le couple (IHARIR,LISINC) n'y est pas
  413. C encore représenté ...
  414. MAXINC=MAXINC+1
  415. IHAR(**)=IHARIR
  416. IMIK(**)=LISINC(I)
  417. 26 CONTINUE
  418. 23 CONTINUE
  419.  
  420. MAXDUA=1
  421. DO 2322 IRI=1,NNVA
  422. DESCR=IRIGEL(3,IRI)
  423. IHARIR=IRIGEL(5,IRI)
  424. IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
  425. SEGACT,DESCR
  426. NLIGRE=LISDUA(/2)
  427. DO 262 I=1,NLIGRE
  428. DO 242 J=1,MAXDUA
  429. IF(IDUA(J).NE.LISDUA(I)) GO TO 242
  430. IF(MHAR1.IHAR(J).EQ.IHARIR) GO TO 262
  431. 242 CONTINUE
  432. C ... On empile les valeurs d'IHARIR et LISDUA dans
  433. C leurs segments si le couple (IHARIR,LISDUA) n'y est pas
  434. C encore représenté ...
  435. MAXDUA=MAXDUA+1
  436. MHAR1.IHAR(**)=IHARIR
  437. IDUA(**)=LISDUA(I)
  438. 262 CONTINUE
  439. SEGDES,DESCR
  440. 2322 CONTINUE
  441. * write(6,*) ' imik'
  442. * write(6,*) ( imik(iu),iu=1,imik(/2))
  443. * write(6,*) ' idua avant'
  444. * write(6,*) ( idua(iu),iu=1,idua(/2))
  445. nnn = idua(/2)
  446. nqq = imik(/2)
  447. if(nnn.ne.nqq) then
  448. * on verra plus tard
  449. call erreur(5)
  450. stop
  451. endif
  452. * petit travail pour mettre dans le meme ordre les inconnues
  453. segini mondu
  454. do 476 iu=1,imik(/2)
  455. lisi=imik(iu)
  456. do 477 io=1,idua(/2)
  457. if( idua(io).eq.lisi) go to 478
  458. 477 continue
  459. inosel(iu)=1
  460. go to 476
  461. 478 mondua(iu)= idua(io)
  462. ipris(io)=1
  463. 476 continue
  464. do 472 iu=1,inosel(/1)
  465. if( inosel(iu).eq.0) go to 472
  466. do 473 io=1,ipris(/1)
  467. if( ipris(io).eq.1) go to 473
  468. ipris(io)=1
  469. mondua(iu)=idua(io)
  470. go to 472
  471. 473 continue
  472. 472 continue
  473. do 479 iu=1,idua(/2)
  474. idua(iu)=mondua(iu)
  475. 479 continue
  476. segsup mondu
  477. * write(6,*) ' idua apres'
  478. * write(6,*) ( idua(iu),iu=1,idua(/2))
  479. C
  480. C **** INITIALISATION DE INCPOS ET DE INCTRA.
  481. C
  482. C ... Les dimensions des segments MINCPO initialisés ci-dessous sont les
  483. C suivantes : MAXI = nombre de différentes variables primales (ou duales)
  484. C NNOE = nombre de noeuds effectivement présents
  485. MAXI=MAXINC
  486. SEGINI,MINCPO
  487.  
  488. MAXI=MAXDUA
  489. SEGINI,MIPO1
  490. maxt=max(maxinc,maxdua)
  491. SEGINI DIATMP,strv
  492.  
  493. DO 29 IRI=1,NNVA
  494. IHARIR=IRIGEL(5,1)
  495. IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF
  496.  
  497. DESCR=IRIGEL(3,IRI)
  498. SEGACT,DESCR
  499.  
  500. NLIGRE=LISINC(/2)
  501. NLIGRF=LISDUA(/2)
  502. SEGINI,INCTRA
  503.  
  504. INCTRR(IRI)=INCTRA
  505.  
  506. MELEME=IRIGEL(1,IRI)
  507. SEGACT,MELEME
  508. N2=NUM(/2)
  509.  
  510. xmatri = irigel(4,iri)
  511. segact xmatri
  512.  
  513. DO 34 J=1,NLIGRE
  514. DO 33 K=1,MAXINC
  515. IF(LISINC(J).NE.IMIK(K)) GO TO 33
  516. IF(IHAR(K).EQ.IHARIR) GO TO 32
  517. 33 CONTINUE
  518. 32 CONTINUE
  519. C ... K est tel que LISINC(J)=IMIK(K) et IHARIR=IHAR(K),
  520. C on le met dans INCTRA(J) (J numérote les variables) correspondant ...
  521. INCTRA(J)=K
  522. C ... Dans la boucle ci-dessous on met à 1 les INCPO correspondants à la
  523. C variable K pour les noeuds des éléments du maillage ...
  524. DO 31 I=1,N2
  525. IJ=INUINV(NUM(NOELEP(J),I))
  526. INCPO(K,IJ)=1
  527. * terme diagonal
  528. if (j.le.nligrf) diatmp(K,IJ)=diatmp(k,ij)+
  529. > re(j,j,i)*coerig(iri)
  530. 31 continue
  531. 34 CONTINUE
  532.  
  533. SEGDES,INCTRA
  534.  
  535. NLIGRE=LISDUA(/2)
  536. SEGINI,INCTRA
  537. INCTRD(IRI)=INCTRA
  538.  
  539. DO 342 J=1,NLIGRE
  540. DO 332 K=1,MAXDUA
  541. IF(LISDUA(J).NE.IDUA(K)) GO TO 332
  542. IF(MHAR1.IHAR(K).EQ.IHARIR) GO TO 322
  543. 332 CONTINUE
  544. 322 CONTINUE
  545. C ... K est tel que LISDUA(J)=IDUA(K) et IHARIR=IHAR(K),
  546. C on le met dans INCTRA(J) (J numérote les variables) correspondant ...
  547. INCTRA(J)=K
  548. C ... Dans la boucle ci-dessous on met à 1 les INCPO correspondants à la
  549. C variable K pour les noeuds des éléments du maillage ...
  550. DO 312 I=1,N2
  551. IJ=INUINV(NUM(NOELED(J),I))
  552. 312 MIPO1.INCPO(K,IJ)=1
  553. 342 CONTINUE
  554.  
  555. SEGDES,DESCR
  556. SEGDES,INCTRA
  557. SEGDES,MELEME
  558. 29 CONTINUE
  559. C
  560. C **** INITIALISATION DE IPOS
  561. C
  562. C ... IPOS(I+1)-IPOS(I) = nombre de colonnes liées au noeud I ...
  563. C ... IPOS(I)+1 = numéro de la première colonne concernant le noeud I ...
  564. IPOS(1)=0
  565. IPOD(1)=0
  566. C ... NA = nombre de 1 dans INCPO => nombre de colonnes de la matrice ...
  567. NA=0
  568. ND=0
  569. DO 37 I=1,NNOE
  570. nad=na
  571. ndd=nd
  572. DO 35 K=1,MAXINC
  573. IF(INCPO(K,I).EQ.0) GO TO 35
  574. NA=NA+1
  575. INCPO(K,I)=NA
  576. itrv1(na-nad)=k
  577. dtrv1(na-nad)= -abs(diatmp(k,i))
  578. 35 CONTINUE
  579. * write(6,*) ' avant ',(incpo(k,i),k=1,maxinc)
  580. * write(6,*) ' avant ',(diatmp(k,i),k=1,maxinc)
  581. * trier incpo suivant les val de diatmp
  582. * write(6,*) 'dtrv1',(dtrv1(k),k=1,na-nad)
  583. * write(6,*) 'itrv1',(itrv1(k),k=1,na-nad)
  584. call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
  585. do k=1,na-nad
  586. incpo(itrv1(k),i)=k+nad
  587. enddo
  588. * write(6,*) ' apres ',(incpo(k,i),k=1,maxinc)
  589. * write(6,*) 'dtrv1',(dtrv1(k),k=1,na-nad)
  590. * write(6,*) 'itrv1',(itrv1(k),k=1,na-nad)
  591. IPOS(I+1)=NA
  592. C ... ND = nombre de 1 dans MIPO1.INCPO => nombre de lignes de la matrice ...
  593. DO 352 K=1,MAXDUA
  594. IF(MIPO1.INCPO(K,I).NE.0) THEN
  595. ND=ND+1
  596. C ... MIPO1.INCPO(K,I) = numéro de l'équation ...
  597. MIPO1.INCPO(K,I)=ND
  598. itrv1(nd-ndd)=k
  599. dtrv1(nd-ndd)= -abs(diatmp(k,i))
  600. ENDIF
  601. 352 CONTINUE
  602. call triflo(dtrv1,dtrv2,itrv1,itrv2,nd-ndd)
  603. do k=1,nd-ndd
  604. mipo1.incpo(itrv1(k),i)=k+ndd
  605. enddo
  606. IPOD(I+1)=ND
  607. 37 CONTINUE
  608. * write(*,*) 'Nb de colonnes de la matrice : ',NA,maxinc
  609. * write(*,*) 'Nb de lignes de la matrice : ',ND,maxdua
  610.  
  611.  
  612. SEGDES,MIDUA,MIMIK,MHARK,MHAR1
  613.  
  614. C ... On va tester que tout est OK pour la suite ...
  615.  
  616. IF(NA.NE.ND) THEN
  617. * write(6,*) ' ipos'
  618. * write(6,*) ( ipos(IU),IU=1,ipos(/1))
  619. * write(6,*) ' ipod '
  620. * write(6,*) ( ipod(IU),IU=1,ipod(/1))
  621. CALL ERREUR(756)
  622. RETURN
  623. ENDIF
  624.  
  625. DO 567 IINO=1,NNOE1
  626. IF(IPOS(IINO).NE.IPOD(IINO)) THEN
  627. WRITE(*,*) 'ERREUR dans ASNS1 !!! IPOS != IPOD !!!'
  628. RETURN
  629. ENDIF
  630. 567 CONTINUE
  631. C
  632. C **** INITIALISATION DE IMINI a été supprimée car ce segment
  633. C ne servait à rien ...
  634. * write(6,*) ' ipos', ( ipos(iu),iu=1,ipos(/1))
  635. * write(6,*) ' ipod', ( ipod(iu),iu=1,ipod(/1))
  636. * write(6,*) ' itopo', ( itopo(iu),iu=1,itopo(/1))
  637. * write(6,*) ' itopob', ( itopob(iu),iu=1,itopob(/1))
  638. * write(6,*) ' iitop', ( iitop(iu),iu=1,iitop(/1))
  639. * write(6,*) ' iitopb', ( iitopb(iu),iu=1,iitopb(/1))
  640. SEGsup DIATMP,strv
  641. SEGDES,MRIGID
  642. SEGDES,IPOS,IPOD
  643. SEGDES,ITOPO,ITOPOB
  644. SEGDES,IITOP,IITOPB
  645. SEGDES,INUINV
  646. SEGDES,IPT1
  647. SEGDES,MINCPO
  648. SEGDES,MIPO1
  649. SEGSUP,IMIN,IMINB
  650. SEGDES,INCTRR
  651. INCTRY=INCTRR
  652. SEGDES,INCTRD
  653. INCTRZ=INCTRD
  654. SEGINI,MMATRI
  655. NENS=0
  656. IGEOMA=IPT1
  657. IIDUA=MIDUA
  658. IINCPO=MINCPO
  659. IDUAPO=MIPO1
  660. IIMIK=MIMIK
  661. IHARK=MHARK
  662. IHARDU=MHAR1
  663. INUINY=INUINV
  664. ITOPOY=ITOPO
  665. ITOPOD=ITOPOB
  666. IITOPD=IITOPB
  667. IITOPY=IITOP
  668. MMATRX=MMATRI
  669. ccc IMINIY=IMINI
  670. iminiy=0
  671. IPOY=IPOS
  672. IPODD=IPOD
  673. SEGDES,MMATRI
  674. RETURN
  675. END
  676.  
  677.  
  678.  
  679.  
  680.  
  681.  
  682.  
  683.  
  684.  
  685.  
  686.  
  687.  
  688.  
  689.  
  690.  
  691.  
  692.  
  693.  
  694.  
  695.  

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