Télécharger echi2.eso

Retour à la liste

Numérotation des lignes :

  1. C ECHI2 SOURCE MAGN 18/04/18 21:15:05 9807
  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. SEGDES IZAFM
  476. C
  477. C- Matrice VF dans le cas ou l'inconnue primale est au SOMMET
  478. C- (matrice ligne : h fois diagonale matrice MASSE condensée)
  479. C
  480. ELSE
  481. CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
  482. IF (IERR.NE.0) RETURN
  483. SEGACT MCHELM
  484. NRIGE = 7
  485. NKID = 9
  486. NKMT = 7
  487. NMATRI = 1
  488. SEGINI MATRIK
  489. IRIGEL(1,1) = MLOCP
  490. IRIGEL(2,1) = MLOCD
  491. IRIGEL(7,1) = 3
  492. NBME = 1
  493. SEGACT MELEME
  494. NBSOUS = LISOUS(/1)
  495. IF (NBSOUS.EQ.0) NBSOUS=1
  496. SEGINI IMATRI
  497. IRIGEL(4,1) = IMATRI
  498. SEGDES MATRIK
  499. KSPGP = SPGP
  500. KSPGD = SPGD
  501. LISPRI(1) = NOMP(1:4)//' '
  502. LISDUA(1) = NOMD(1:4)//' '
  503. NUTOEL = 0
  504. DO 240 L=1,NBSOUS
  505. IPT1 = MELEME
  506. IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  507. SEGACT IPT1
  508. NP = IPT1.NUM(/1)
  509. MP = 1
  510. NBEL = IPT1.NUM(/2)
  511. SEGINI IZAFM
  512. LIZAFM(L,1) = IZAFM
  513. MCHAML = ICHAML(L)
  514. SEGACT MCHAML
  515. MELVAL = IELVAL(1)
  516. SEGACT MELVAL
  517. DO 230 K=1,NBEL
  518. NK = NUTOEL + K
  519. KPOS = 1 + (1-IKH)*(NK-1)
  520. DO 220 I=1,NP
  521. VAL1 = MPOVA1.VPOCHA(KPOS,1)*VELCHE(I,K)
  522. AM(K,I,1) = AM(K,I,1) + VAL1
  523. C write(6,*) 'VF SOMMET AM K I',K,I,AM(K,I,1)
  524. 220 CONTINUE
  525. 230 CONTINUE
  526. SEGDES IPT1
  527. SEGDES MCHAML,MELVAL
  528. SEGDES IZAFM
  529. NUTOEL = NUTOEL + NBEL
  530. 240 CONTINUE
  531. IF (NBSOUS.NE.1) SEGDES MELEME
  532. SEGDES MCHELM
  533. SEGDES IMATRI
  534. ENDIF
  535. C
  536. C- Second membre VF dans le cas ou le champ exterieur est au CENTRE
  537. C- (matrice diagonale h*VOLUME saturée par le champ exterieur)
  538. C
  539. IF (IKT.EQ.0.OR.IKT.EQ.1) THEN
  540. IF (MCHPO1.EQ.0) CALL LEKTAB(MTAB2,'XXVOLUM ',MCHPO1)
  541. IF (IERR.NE.0) RETURN
  542. CALL LICHT(MCHPO1,MPOVA3,TYPC,IGEOM)
  543. NBEL = MPOVA3.VPOCHA(/1)
  544. IPT2 = MLOCD
  545. SEGACT IPT2
  546. DO 250 NK=1,NBEL
  547. IPOS = MLENT2.LECT(IPT2.NUM(1,NK))
  548. KPOS = 1 + (1-IKH)*(NK-1)
  549. KTEX = 1 + (1-IKT)*(NK-1)
  550. VAL1 = MPOVA1.VPOCHA(KPOS,1) * MPOVA2.VPOCHA(KTEX,1)
  551. & * MPOVA3.VPOCHA(NK,1)
  552. VPOCHA(IPOS,1) = VPOCHA(IPOS,1) + VAL1
  553. C write(6,*) 'VF CENTRE VPOCHA IPOS',IPOS,VPOCHA(IPOS,1)
  554. 250 CONTINUE
  555. SEGDES IPT2
  556. SEGDES MPOVA3
  557. C
  558. C- Second membre VF dans le cas ou l'inconnue primale est au SOMMET
  559. C- (matrice MASSE condensée saturée par h*champ exterieur)
  560. C
  561. ELSE
  562. IF (MCHELM.EQ.0) CALL LEKTAB(MTAB2,'XXPSOML ',MCHELM)
  563. IF (IERR.NE.0) RETURN
  564. SEGACT MCHELM
  565. SEGACT MELEME
  566. NBSOUS = LISOUS(/1)
  567. IF (NBSOUS.EQ.0) NBSOUS=1
  568. NUTOEL = 0
  569. IPT2 = MLOCD
  570. SEGACT IPT2
  571. DO 280 L=1,NBSOUS
  572. IPT1 = MELEME
  573. IF (NBSOUS.NE.1) IPT1=LISOUS(L)
  574. SEGACT IPT1
  575. NP = IPT1.NUM(/1)
  576. NBEL = IPT1.NUM(/2)
  577. MCHAML = ICHAML(L)
  578. SEGACT MCHAML
  579. MELVAL = IELVAL(1)
  580. SEGACT MELVAL
  581. DO 270 K=1,NBEL
  582. NK = NUTOEL + K
  583. IPOS = MLENT2.LECT(IPT2.NUM(1,NK))
  584. KPOS = 1 + (1-IKH)*(NK-1)
  585. SOM1 = 0.D0
  586. DO 260 J=1,NP
  587. JPOS = MLENT1.LECT(IPT1.NUM(J,K))
  588. SOM1 = SOM1 + MPOVA2.VPOCHA(JPOS,1)*VELCHE(J,K)
  589. 260 CONTINUE
  590. VAL1 = SOM1 * MPOVA1.VPOCHA(KPOS,1)
  591. VPOCHA(IPOS,1) = VPOCHA(IPOS,1) + VAL1
  592. C write(6,*) 'VF SOMMET VPOCHA IPOS',IPOS,VPOCHA(IPOS,1)
  593. 270 CONTINUE
  594. SEGDES IPT1
  595. SEGDES MCHAML,MELVAL
  596. NUTOEL = NUTOEL + NBEL
  597. 280 CONTINUE
  598. IF (NBSOUS.NE.1) SEGDES MELEME
  599. SEGDES MCHELM
  600. SEGDES IPT2
  601. ENDIF
  602. ENDIF
  603. C
  604. C- Désactivation
  605. C
  606. SEGDES MPOVA2
  607. SEGDES MPOVA1
  608. SEGDES MPOVAL
  609. SEGSUP MLENTI
  610. IF (MLENT2.NE.0) SEGSUP MLENT2
  611. C
  612. C- Ecriture de la matrice et du second-membre
  613. C
  614. IF(NASTOK.EQ.0)THEN
  615. CALL ECMO(MTAB3,'MATELM','MATRIK',MATRIK)
  616. TYPE = ' '
  617. CALL ACMO(MTAB1,'SMBR',TYPE,MCHPO4)
  618. IF (TYPE.NE.'CHPOINT ') THEN
  619. CALL ECMO(MTAB1,'SMBR','CHPOINT ',MCHPOI)
  620. ELSE
  621. CALL ECROBJ('CHPOINT ',MCHPO4)
  622. CALL ECROBJ('CHPOINT ',MCHPOI)
  623. CALL PRFUSE
  624. CALL LIROBJ('CHPOINT ',MCHPOI,1,IRET)
  625. IF (IERR.NE.0) RETURN
  626. CALL ECMO(MTAB1,'SMBR','CHPOINT ',MCHPOI)
  627. ENDIF
  628. ELSE
  629. CALL ECROBJ('MATRIK',MATRIK)
  630. CALL ECROBJ('CHPOINT',MCHPOI)
  631. ENDIF
  632. C write(6,*) 'IKAS IVOL IKH IKT IKP',IKAS,IVOL1,IKH,IKT,IKP
  633. RETURN
  634. END
  635.  
  636.  

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