Télécharger echi2.eso

Retour à la liste

Numérotation des lignes :

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

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