Télécharger echi2.eso

Retour à la liste

Numérotation des lignes :

echi2
  1. C ECHI2 SOURCE FANDEUR 22/01/03 21:15:13 11136
  2. SUBROUTINE ECHI2(IKAS,IVOL1,MTAB1,MTAB2,MTAB3,MPOVA1,MPOVA2,
  3. & IKH,IKT,IKP,MELEVF,MLENT1,NOMP,NOMD)
  4. C-----------------------------------------------------------------------
  5. C Discrétisation de l'opérateur ECHIMP en implicite EF et VF, le
  6. C coeff d'échange étant un SCAL ou CHPO CENTRE, le champ exterieur
  7. C un SCAL, un CHPO CENTRE ou un CHPO SOMMET.
  8. C-----------------------------------------------------------------------
  9. C
  10. C--------------------
  11. C Paramètres Entrée :
  12. C--------------------
  13. C
  14. C E/ IKAS : Type de situation à traiter (1=EF, 2 ou 3=VF)
  15. C E/ IVOL1 : Type d'échange (0=surfacique, 1=volumique)
  16. C E/ MTAB1 : Pointeur de la table EQEX
  17. C E/ MTAB2 : Pointeur de la table DOMAINE locale
  18. C E/ MTAB3 : Pointeur de la table KIZX
  19. C E/ MPOVA1 : MPOVAL des valeurs du coefficient d'échange
  20. C E/ MPOVA2 : MPOVAL des valeurs du champ exterieur
  21. C E/ IKH : Forme originel du coefficient d'échange
  22. C (0=CHPO CENTRE, 1=FLOTTANT, 4=CHPO SOMMET)
  23. C E/ IKT : Forme originel du champ exterieur
  24. C (0=CHPO CENTRE, 1=FLOTTANT, 4=CHPO SOMMET)
  25. C E/ IKP : Support de l'inconnue primale
  26. C (0=CHPO CENTRE, 4=CHPO SOMMET)
  27. C E/ MELEVF : Pointeur vers les points CENTRE du maillage volumique
  28. C en correspondance avec les points CENTRE surfacique
  29. C (Utilisé en Formulation VF et échange surfacique)
  30. C E/ MLENT1 : Correspondance de numérotations pour le champ exterieur
  31. C MLENT1.LECT(I)=J : point I en Jième position du spg
  32. C (Utilisé lorsque le champ exterieur est au SOMMET)
  33. C E/ NOMP : Nom de l'inconnue primale
  34. C E/ NOMD : Nom de l'inconnue duale
  35. C
  36. C------------------
  37. C Champs calculés :
  38. C------------------
  39. C
  40. C MTAB3.'MATELM' : Matrice associé à l'opérateur ECHIMP
  41. C MTAB1.'SMBR' : Second membre du système matriciel issu de la
  42. C discrétisation, la contribution de ECHIMP y est
  43. C assemblée.
  44. C
  45. C-----------------------------------------------------------------------
  46. IMPLICIT INTEGER(I-N)
  47. IMPLICIT REAL*8 (A-H,O-Z)
  48. C
  49. -INC CCGEOME
  50. -INC PPARAM
  51. -INC CCOPTIO
  52. -INC SIZFFB
  53. -INC SMCHPOI
  54. -INC SMCHAML
  55. -INC SMCOORD
  56. -INC SMELEME
  57. -INC SMLENTI
  58. C
  59. CHARACTER*(*) NOMP,NOMD
  60. CHARACTER*(LOCOMP)NOM0
  61. CHARACTER*8 TYPE,TYPC,TYPS
  62. INTEGER SPGP,SPGD
  63. C
  64. C- Initialisations
  65. C
  66. CALL ACME(MTAB1,'NAVISTOK',NASTOK)
  67. MLENT2 = 0
  68. MCHPO1 = 0
  69. MCHELM = 0
  70. NBCOMP = 1
  71. IAXI = 0
  72. IF (IFOMOD.EQ.0) IAXI=2
  73. SEGACT MPOVA1
  74. SEGACT MPOVA2
  75. C
  76. C- Récupération des informations géométriques locales
  77. C
  78. CALL LEKTAB(MTAB2,'CENTRE ',MELEMC)
  79. CALL LEKTAB(MTAB2,'SOMMET ',MELEMS)
  80. CALL LEKTAB(MTAB2,'MAILLAGE ',MELEME)
  81. CALL KRIPAD(MELEMS,MLENTI)
  82. C
  83. C- En echange surfacique et option VF création du spg du second-membre
  84. C- différent de MELEVF à cause des coins (dans le spg chaque point
  85. C- n'est présent qu'une fois meme si il est connecté plusieurs fois)
  86. C
  87. IF (IKAS.NE.1 .AND. IVOL1.EQ.0) THEN
  88. IPT1 = MELEVF
  89. SEGACT IPT1
  90. SEGINI, IPT2=IPT1
  91. IOK1 = 1
  92. NUMPD = IPT2.NUM(/2)
  93. DO 10 I=2,NUMPD
  94. ITEST = IPT1.NUM(1,I)
  95. DO 5 J=1,IOK1
  96. JTEST = IPT2.NUM(1,J)
  97. IF (JTEST.EQ.ITEST) GOTO 10
  98. 5 CONTINUE
  99. IOK1 = IOK1 + 1
  100. IPT2.NUM(1,IOK1) = ITEST
  101. 10 CONTINUE
  102. IF (IOK1.NE.NUMPD) THEN
  103. NBSOUS = 0
  104. NBELEM = IOK1
  105. NBREF = 0
  106. NBNN = 1
  107. SEGADJ IPT2
  108. ENDIF
  109. SEGDES IPT2
  110. ENDIF
  111. C
  112. C- Maillage de connectivités et supports géométriques des inconnues
  113. C
  114. C SPGP : Support géométrique local de l'inconnue primale
  115. C SPGD : Idem pour la duale
  116. C MLOCP : Connectivité local pour l'inconnue primale
  117. C MLOCD : Idem pour la duale
  118. C
  119. IF (IKAS.EQ.1) THEN
  120. TYPS = 'SOMMET '
  121. SPGD = MELEMS
  122. IF (IKP.EQ.0) THEN
  123. SPGP = MELEMC
  124. MLOCD = MELEME
  125. MLOCP = MELEMC
  126. ELSE
  127. SPGP = MELEMS
  128. MLOCD = MELEME
  129. MLOCP = MELEME
  130. ENDIF
  131. ELSE
  132. TYPS = 'CENTRE '
  133. IF (IVOL1.EQ.0) THEN
  134. SPGD = IPT2
  135. MLOCD = MELEVF
  136. ELSE
  137. SPGD = MELEMC
  138. MLOCD = MELEMC
  139. ENDIF
  140. IF (IKP.EQ.0) THEN
  141. SPGP = MELEMC
  142. MLOCP = MELEMC
  143. ELSE
  144. SPGP = MELEMS
  145. MLOCP = MELEME
  146. ENDIF
  147. CALL KRIPAD(SPGD,MLENT2)
  148. ENDIF
  149. C
  150. C- Création du CHPO contenant la contribution au second membre de ECHIMP
  151. C
  152. NAT = 1
  153. NSOUPO = 1
  154. SEGINI MCHPOI
  155. MTYPOI = TYPS
  156. JATTRI(1) = 2
  157. IFOPOI = IFOUR
  158. NC = 1
  159. SEGINI MSOUPO
  160. IPCHP(1) = MSOUPO
  161. SEGDES MCHPOI
  162. NOCOMP(1)= NOMD
  163. IGEOC = SPGD
  164. IPT3 = SPGD
  165. SEGACT IPT3
  166. N = IPT3.NUM(/2)
  167. SEGDES IPT3
  168. SEGINI MPOVAL
  169. IPOVAL = MPOVAL
  170. SEGDES MSOUPO
  171. C
  172. C-------------------
  173. C- Cas EF Implicite
  174. C-------------------
  175. C
  176. IF (IKAS.EQ.1) THEN
  177. C
  178. C- Matrice EF dans le cas ou l'inconnue primale est au CENTRE
  179. C- (matrice colonne : h fois diagonale de la matrice MASSE condensée)
  180. C
  181. IF (IKP.EQ.0) THEN
  182. CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
  183. IF (IERR.NE.0) RETURN
  184. SEGACT MCHELM
  185. NRIGE = 7
  186. NKID = 9
  187. NKMT = 7
  188. NMATRI = 1
  189. SEGINI MATRIK
  190. IRIGEL(1,1) = MLOCP
  191. IRIGEL(2,1) = MLOCD
  192. IRIGEL(7,1) = 3
  193. NBME = 1
  194. SEGACT MELEME
  195. NBSOUS = LISOUS(/1)
  196. IF (NBSOUS.EQ.0) NBSOUS=1
  197. SEGINI IMATRI
  198. IRIGEL(4,1) = IMATRI
  199. SEGDES MATRIK
  200. KSPGP = SPGP
  201. KSPGD = SPGD
  202. LISPRI(1) = NOMP
  203. LISDUA(1) = NOMD
  204. NUTOEL = 0
  205. DO 30 L=1,NBSOUS
  206. IPT1 = MELEME
  207. IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  208. SEGACT IPT1
  209. NP = 1
  210. MP = IPT1.NUM(/1)
  211. NBEL = IPT1.NUM(/2)
  212. SEGINI IZAFM
  213. LIZAFM(L,1) = IZAFM
  214. MCHAML = ICHAML(L)
  215. SEGACT MCHAML
  216. MELVAL = IELVAL(1)
  217. SEGACT MELVAL
  218. DO 20 K=1,NBEL
  219. NK = NUTOEL + K
  220. KPOS = 1 + (1-IKH)*(NK-1)
  221. DO 15 I=1,MP
  222. VAL1 = MPOVA1.VPOCHA(KPOS,1)*VELCHE(I,K)
  223. AM(K,1,I) = AM(K,1,I) + VAL1
  224. C write(6,*) 'EF CENTRE AM K I',K,I,AM(K,1,I)
  225. 15 CONTINUE
  226. 20 CONTINUE
  227. SEGDES IZAFM
  228. SEGDES IPT1
  229. SEGDES MCHAML,MELVAL
  230. NUTOEL = NUTOEL + NBEL
  231. 30 CONTINUE
  232. IF (NBSOUS.NE.1) SEGDES MELEME
  233. SEGDES MCHELM
  234. SEGDES IMATRI
  235. C
  236. C- Matrice EF dans le cas ou l'inconnue primale est au SOMMET
  237. C- (matrice carrée : h fois matrice MASSE consistante)
  238. C
  239. ELSE
  240. NRIGE = 7
  241. NKID = 9
  242. NKMT = 7
  243. NMATRI = 1
  244. SEGINI MATRIK
  245. IRIGEL(1,1) = MLOCP
  246. IRIGEL(2,1) = MLOCD
  247. IRIGEL(7,1) = 2
  248. NBME = 1
  249. SEGACT MELEME
  250. NBSOUS = LISOUS(/1)
  251. IF (NBSOUS.EQ.0) NBSOUS=1
  252. SEGINI IMATRI
  253. IRIGEL(4,1) = IMATRI
  254. SEGDES MATRIK
  255. KSPGP = SPGP
  256. KSPGD = SPGD
  257. LISPRI(1) = NOMP
  258. LISDUA(1) = NOMD
  259. NUTOEL = 0
  260. DO 100 L=1,NBSOUS
  261. IPT1 = MELEME
  262. IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  263. SEGACT IPT1
  264. NP = IPT1.NUM(/1)
  265. NBEL = IPT1.NUM(/2)
  266. MP = NP
  267. SEGINI IZAFM
  268. LIZAFM(L,1) = IZAFM
  269. NOM0 = NOMS(IPT1.ITYPEL)
  270. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  271. IF (IZFFM.EQ.0) THEN
  272. C Echec lors de la lecture des fonctions de forme d'un élément.
  273. CALL ERREUR(662)
  274. RETURN
  275. ENDIF
  276. SEGACT IZFFM*MOD
  277. IZHR = KZHR(1)
  278. SEGACT IZHR*MOD
  279. NPG = GR(/3)
  280. NES = GR(/1)
  281. DO 90 K=1,NBEL
  282. NK = NUTOEL + K
  283. KPOS = 1 + (1-IKH)*(NK-1)
  284. DO 50 I=1,NP
  285. II = IPT1.NUM(I,K)
  286. DO 40 N=1,IDIM
  287. XYZ(N,I) = XCOOR((II-1)*(IDIM+1)+N)
  288. 40 CONTINUE
  289. 50 CONTINUE
  290. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,
  291. & NPG,IAXI,AIRE)
  292. DO 80 I=1,NP
  293. DO 70 J=1,NP
  294. UU = 0.D0
  295. DO 60 LG=1,NPG
  296. UU = UU + FN(I,LG)*FN(J,LG)*PGSQ(LG)
  297. 60 CONTINUE
  298. CCC modif alex
  299. IF(IKH.EQ.4)THEN
  300. JPOS = MLENT1.LECT(IPT1.NUM(J,K))
  301. AM(K,I,J) = MPOVA1.VPOCHA(JPOS,1) * UU
  302. ELSE
  303. AM(K,I,J) = MPOVA1.VPOCHA(KPOS,1) * UU
  304. C write(6,*) 'EF SOMMET AM K I J',K,I,J,AM(K,I,J)
  305. ENDIF
  306. 70 CONTINUE
  307. 80 CONTINUE
  308. 90 CONTINUE
  309. SEGDES IPT1
  310. SEGDES IZAFM
  311. SEGDES IZFFM*MOD
  312. SEGDES IZHR
  313. NUTOEL = NUTOEL + NBEL
  314. 100 CONTINUE
  315. IF (NBSOUS.NE.1) SEGDES MELEME
  316. SEGDES IMATRI
  317. ENDIF
  318. C
  319. C- Second membre EF, champ exterieur FLOTTANT ou CHPO CENTRE
  320. C- (matrice MASSE condensée saturé par h*champ exterieur)
  321. C
  322. IF (IKT.EQ.0.OR.IKT.EQ.1) THEN
  323. IF (MCHELM.EQ.0) CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
  324. IF (IERR.NE.0) RETURN
  325. SEGACT MCHELM
  326. SEGACT MELEME
  327. NBSOUS = LISOUS(/1)
  328. IF (NBSOUS.EQ.0) NBSOUS=1
  329. NUTOEL = 0
  330. DO 130 L=1,NBSOUS
  331. IPT1 = MELEME
  332. IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  333. SEGACT IPT1
  334. NP = IPT1.NUM(/1)
  335. NBEL = IPT1.NUM(/2)
  336. MCHAML = ICHAML(L)
  337. SEGACT MCHAML
  338. MELVAL = IELVAL(1)
  339. SEGACT MELVAL
  340. DO 120 K=1,NBEL
  341. NK = NUTOEL + K
  342. KPOS = 1 + (1-IKH)*(NK-1)
  343. KTEX = 1 + (1-IKT)*(NK-1)
  344. DO 110 I=1,NP
  345. II = IPT1.NUM(I,K)
  346. IPOS = LECT(II)
  347. VAL1 = MPOVA1.VPOCHA(KPOS,1)*VELCHE(I,K)
  348. & * MPOVA2.VPOCHA(KTEX,1)
  349. VPOCHA(IPOS,1) = VPOCHA(IPOS,1) + VAL1
  350. C write(6,*) 'EF CENTRE VPOCHA IPOS',IPOS,VPOCHA(IPOS,1)
  351. 110 CONTINUE
  352. 120 CONTINUE
  353. SEGDES IPT1
  354. SEGDES MCHAML,MELVAL
  355. NUTOEL = NUTOEL + NBEL
  356. 130 CONTINUE
  357. IF (NBSOUS.NE.1) SEGDES MELEME
  358. SEGDES MCHELM
  359. C
  360. C- Second membre EF, champ exterieur CHPO SOMMET
  361. C- (matrice MASSE consistante saturée par h*champ exterieur)
  362. C
  363. ELSE
  364. SEGACT MELEME
  365. NBSOUS = LISOUS(/1)
  366. IF (NBSOUS.EQ.0) NBSOUS=1
  367. NUTOEL = 0
  368. DO 200 L=1,NBSOUS
  369. IPT1 = MELEME
  370. IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  371. SEGACT IPT1
  372. NP = IPT1.NUM(/1)
  373. NBEL = IPT1.NUM(/2)
  374. NOM0 = NOMS(IPT1.ITYPEL)
  375. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  376. IF (IZFFM.EQ.0) THEN
  377. C Echec lors de la lecture des fonctions de forme d'un élément.
  378. CALL ERREUR(662)
  379. RETURN
  380. ENDIF
  381. SEGACT IZFFM*MOD
  382. IZHR = KZHR(1)
  383. SEGACT IZHR*MOD
  384. NPG = GR(/3)
  385. NES = GR(/1)
  386. DO 190 K=1,NBEL
  387. NK = NUTOEL + K
  388. KPOS = 1 + (1-IKH)*(NK-1)
  389. DO 150 I=1,NP
  390. II = IPT1.NUM(I,K)
  391. DO 140 N=1,IDIM
  392. XYZ(N,I) = XCOOR((II-1)*(IDIM+1)+N)
  393. 140 CONTINUE
  394. 150 CONTINUE
  395. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,
  396. & NPG,IAXI,AIRE)
  397. DO 180 I=1,NP
  398. II = IPT1.NUM(I,K)
  399. IPOS = LECT(II)
  400. SOM1 = 0.D0
  401. DO 170 J=1,NP
  402. JPOS = MLENT1.LECT(IPT1.NUM(J,K))
  403. UU = 0.D0
  404. DO 160 LG=1,NPG
  405. UU = UU + FN(I,LG)*FN(J,LG)*PGSQ(LG)
  406. 160 CONTINUE
  407. CCC modif alex
  408. IF(IKH.EQ.4)THEN
  409. SOM1 = SOM1 + MPOVA1.VPOCHA(IPOS,1)
  410. & * MPOVA2.VPOCHA(JPOS,1) * UU
  411. ELSE
  412. SOM1 = SOM1 + MPOVA1.VPOCHA(KPOS,1)
  413. & * MPOVA2.VPOCHA(JPOS,1) * UU
  414. ENDIF
  415. 170 CONTINUE
  416. VPOCHA(IPOS,1) = VPOCHA(IPOS,1) + SOM1
  417. C write(6,*) 'EF SOMMET VPOCHA IPOS',IPOS,VPOCHA(IPOS,1)
  418. 180 CONTINUE
  419. 190 CONTINUE
  420. SEGDES IPT1
  421. SEGDES IZFFM*MOD
  422. SEGDES IZHR
  423. NUTOEL = NUTOEL + NBEL
  424. 200 CONTINUE
  425. IF (NBSOUS.NE.1) SEGDES MELEME
  426. ENDIF
  427. C
  428. C-------------------
  429. C- Cas VF Implicite
  430. C-------------------
  431. C
  432. ELSE
  433. C
  434. C- Matrice VF dans le cas ou l'inconnue primale est au CENTRE
  435. C- (matrice IDENTITE multipliée par h*VOLUME)
  436. C
  437. IF (IKP.EQ.0) THEN
  438. CALL LEKTAB(MTAB2,'XXVOLUM ',MCHPO3)
  439. IF (IERR.NE.0) RETURN
  440. CALL LICHT(MCHPO3,MPOVA3,TYPC,IGEOM)
  441. NRIGE = 7
  442. NKID = 9
  443. NKMT = 7
  444. NMATRI = 1
  445. SEGINI MATRIK
  446. IRIGEL(1,1) = MLOCP
  447. IRIGEL(2,1) = MLOCD
  448. IF (MLOCP.EQ.MLOCD) THEN
  449. IF (NOMP.EQ.NOMD) THEN
  450. IRIGEL(7,1) = 5
  451. ELSE
  452. IRIGEL(7,1) = 2
  453. ENDIF
  454. ELSE
  455. IRIGEL(7,1) = 3
  456. ENDIF
  457. NBME = 1
  458. NBSOUS = 1
  459. SEGINI IMATRI
  460. IRIGEL(4,1) = IMATRI
  461. SEGDES MATRIK
  462. KSPGP = SPGP
  463. KSPGD = SPGD
  464. LISPRI(1) = NOMP
  465. LISDUA(1) = NOMD
  466. NBEL = MPOVA3.VPOCHA(/1)
  467. NP = 1
  468. MP = 1
  469. SEGINI IZAFM
  470. LIZAFM(1,1) = IZAFM
  471. SEGDES IMATRI
  472. DO 210 NK=1,NBEL
  473. KPOS = 1 + (1-IKH)*(NK-1)
  474. AM(NK,1,1) = AM(NK,1,1) +
  475. & MPOVA1.VPOCHA(KPOS,1) * MPOVA3.VPOCHA(NK,1)
  476. C write(6,*) 'VF CENTRE AM NK',NK,AM(NK,1,1)
  477. 210 CONTINUE
  478. SEGDES IZAFM
  479. C
  480. C- Matrice VF dans le cas ou l'inconnue primale est au SOMMET
  481. C- (matrice ligne : h fois diagonale matrice MASSE condensée)
  482. C
  483. ELSE
  484. CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
  485. IF (IERR.NE.0) RETURN
  486. SEGACT MCHELM
  487. NRIGE = 7
  488. NKID = 9
  489. NKMT = 7
  490. NMATRI = 1
  491. SEGINI MATRIK
  492. IRIGEL(1,1) = MLOCP
  493. IRIGEL(2,1) = MLOCD
  494. IRIGEL(7,1) = 3
  495. NBME = 1
  496. SEGACT MELEME
  497. NBSOUS = LISOUS(/1)
  498. IF (NBSOUS.EQ.0) NBSOUS=1
  499. SEGINI IMATRI
  500. IRIGEL(4,1) = IMATRI
  501. SEGDES MATRIK
  502. KSPGP = SPGP
  503. KSPGD = SPGD
  504. LISPRI(1) = NOMP
  505. LISDUA(1) = NOMD
  506. NUTOEL = 0
  507. DO 240 L=1,NBSOUS
  508. IPT1 = MELEME
  509. IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  510. SEGACT IPT1
  511. NP = IPT1.NUM(/1)
  512. MP = 1
  513. NBEL = IPT1.NUM(/2)
  514. SEGINI IZAFM
  515. LIZAFM(L,1) = IZAFM
  516. MCHAML = ICHAML(L)
  517. SEGACT MCHAML
  518. MELVAL = IELVAL(1)
  519. SEGACT MELVAL
  520. DO 230 K=1,NBEL
  521. NK = NUTOEL + K
  522. KPOS = 1 + (1-IKH)*(NK-1)
  523. DO 220 I=1,NP
  524. VAL1 = MPOVA1.VPOCHA(KPOS,1)*VELCHE(I,K)
  525. AM(K,I,1) = AM(K,I,1) + VAL1
  526. C write(6,*) 'VF SOMMET AM K I',K,I,AM(K,I,1)
  527. 220 CONTINUE
  528. 230 CONTINUE
  529. SEGDES IPT1
  530. SEGDES MCHAML,MELVAL
  531. SEGDES IZAFM
  532. NUTOEL = NUTOEL + NBEL
  533. 240 CONTINUE
  534. IF (NBSOUS.NE.1) SEGDES MELEME
  535. SEGDES MCHELM
  536. SEGDES IMATRI
  537. ENDIF
  538. C
  539. C- Second membre VF dans le cas ou le champ exterieur est au CENTRE
  540. C- (matrice diagonale h*VOLUME saturée par le champ exterieur)
  541. C
  542. IF (IKT.EQ.0.OR.IKT.EQ.1) THEN
  543. IF (MCHPO1.EQ.0) CALL LEKTAB(MTAB2,'XXVOLUM ',MCHPO1)
  544. IF (IERR.NE.0) RETURN
  545. CALL LICHT(MCHPO1,MPOVA3,TYPC,IGEOM)
  546. NBEL = MPOVA3.VPOCHA(/1)
  547. IPT2 = MLOCD
  548. SEGACT IPT2
  549. DO 250 NK=1,NBEL
  550. IPOS = MLENT2.LECT(IPT2.NUM(1,NK))
  551. KPOS = 1 + (1-IKH)*(NK-1)
  552. KTEX = 1 + (1-IKT)*(NK-1)
  553. VAL1 = MPOVA1.VPOCHA(KPOS,1) * MPOVA2.VPOCHA(KTEX,1)
  554. & * MPOVA3.VPOCHA(NK,1)
  555. VPOCHA(IPOS,1) = VPOCHA(IPOS,1) + VAL1
  556. C write(6,*) 'VF CENTRE VPOCHA IPOS',IPOS,VPOCHA(IPOS,1)
  557. 250 CONTINUE
  558. SEGDES IPT2
  559. SEGDES MPOVA3
  560. C
  561. C- Second membre VF dans le cas ou l'inconnue primale est au SOMMET
  562. C- (matrice MASSE condensée saturée par h*champ exterieur)
  563. C
  564. ELSE
  565. IF (MCHELM.EQ.0) CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
  566. IF (IERR.NE.0) RETURN
  567. SEGACT MCHELM
  568. SEGACT MELEME
  569. NBSOUS = LISOUS(/1)
  570. IF (NBSOUS.EQ.0) NBSOUS=1
  571. NUTOEL = 0
  572. IPT2 = MLOCD
  573. SEGACT IPT2
  574. DO 280 L=1,NBSOUS
  575. IPT1 = MELEME
  576. IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  577. SEGACT IPT1
  578. NP = IPT1.NUM(/1)
  579. NBEL = IPT1.NUM(/2)
  580. MCHAML = ICHAML(L)
  581. SEGACT MCHAML
  582. MELVAL = IELVAL(1)
  583. SEGACT MELVAL
  584. DO 270 K=1,NBEL
  585. NK = NUTOEL + K
  586. IPOS = MLENT2.LECT(IPT2.NUM(1,NK))
  587. KPOS = 1 + (1-IKH)*(NK-1)
  588. SOM1 = 0.D0
  589. DO 260 J=1,NP
  590. JPOS = MLENT1.LECT(IPT1.NUM(J,K))
  591. SOM1 = SOM1 + MPOVA2.VPOCHA(JPOS,1)*VELCHE(J,K)
  592. 260 CONTINUE
  593. VAL1 = SOM1 * MPOVA1.VPOCHA(KPOS,1)
  594. VPOCHA(IPOS,1) = VPOCHA(IPOS,1) + VAL1
  595. C write(6,*) 'VF SOMMET VPOCHA IPOS',IPOS,VPOCHA(IPOS,1)
  596. 270 CONTINUE
  597. SEGDES IPT1
  598. SEGDES MCHAML,MELVAL
  599. NUTOEL = NUTOEL + NBEL
  600. 280 CONTINUE
  601. IF (NBSOUS.NE.1) SEGDES MELEME
  602. SEGDES MCHELM
  603. SEGDES IPT2
  604. ENDIF
  605. ENDIF
  606. C
  607. C- Désactivation
  608. C
  609. SEGDES MPOVA2
  610. SEGDES MPOVA1
  611. SEGDES MPOVAL
  612. SEGSUP MLENTI
  613. IF (MLENT2.NE.0) SEGSUP MLENT2
  614. C
  615. C- Ecriture de la matrice et du second-membre
  616. C
  617. IF(NASTOK.EQ.0)THEN
  618. CALL ECMO(MTAB3,'MATELM','MATRIK',MATRIK)
  619. TYPE = ' '
  620. CALL ACMO(MTAB1,'SMBR',TYPE,MCHPO4)
  621. IF (TYPE.NE.'CHPOINT ') THEN
  622. CALL ECMO(MTAB1,'SMBR','CHPOINT ',MCHPOI)
  623. ELSE
  624. CALL ECROBJ('CHPOINT ',MCHPO4)
  625. CALL ECROBJ('CHPOINT ',MCHPOI)
  626. CALL PRFUSE
  627. CALL LIROBJ('CHPOINT ',MCHPOI,1,IRET)
  628. IF (IERR.NE.0) RETURN
  629. CALL ECMO(MTAB1,'SMBR','CHPOINT ',MCHPOI)
  630. ENDIF
  631. ELSE
  632. CALL ECROBJ('MATRIK',MATRIK)
  633. CALL ECROBJ('CHPOINT',MCHPOI)
  634. ENDIF
  635. C write(6,*) 'IKAS IVOL IKH IKT IKP',IKAS,IVOL1,IKH,IKT,IKP
  636. RETURN
  637. END
  638.  
  639.  
  640.  
  641.  
  642.  

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