Télécharger nor4d3.eso

Retour à la liste

Numérotation des lignes :

  1. C NOR4D3 SOURCE KK2000 14/04/10 21:15:20 8032
  2. SUBROUTINE NOR4D3(
  3. & MELEFA,MELEFL,MLECEN,MELEFP,MLESOM,MPONOR,
  4. & MPOSUR,MELTFA,MLEFA,MLEFA2,MPOTEN,MPOCHP,MLENCL,
  5. & MPOVCL,ICHTE,ICHCL,ICHCO,MPOVCO,IOP,
  6. & IPO2,SCMB,INDLI,VAL1,VAL2,IND22,IND2,IND,
  7. & IPO3,TAB,MPOGRA,MELVA1,MELVA2,
  8. & NSOMM,NBMAX,NBFAC,NBCOT,MCHEL2,MCHAM2)
  9. C
  10. C PROJET : CASTEM 2000
  11. C
  12. C NOM : NORV4
  13. C
  14. C DESCRIPTION : Appelle par NORV1
  15. C
  16. C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
  17. C
  18. C AUTEUR : C. LE POTIER, DM2S/SFME/MTMS
  19. C
  20. C************************************************************************
  21. C
  22. IMPLICIT INTEGER(I-N)
  23. IMPLICIT REAL*8(A-H,O-Z)
  24.  
  25. -INC CCOPTIO
  26. -INC SMLENTI
  27. -INC SMELEME
  28. -INC SMCHPOI
  29. -INC SMCOORD
  30. -INC SMLREEL
  31. -INC SMCHAML
  32.  
  33. POINTEUR MELEFL.MELEME, MELEFP.MELEME, MELEFA.MELEME,
  34. & MELTFA.MELEME,MELEP2.MELEME
  35. POINTEUR MPOSUR.MPOVAL, MPONOR.MPOVAL,
  36. & MPOCHP.MPOVAL, MPOVCL.MPOVAL, MPGSOM.MPOVAL, MPVOSO.MPOVAL,
  37. & MPOGRA.MPOVAL,MPOTEN.MPOVAL,MPOVCO.MPOVAL
  38. POINTEUR MLENCL.MLENTI, MLECEN.MLENTI, MLESOM.MLENTI,
  39. & MLEFA.MLENTI,MLEFA2.MLENTI
  40. INTEGER NBNN,NBREF,NBMAX
  41.  
  42. C**** Variable de SMLENTI, SMCHPOI
  43. C
  44. INTEGER JG, N, NC, NSOUPO, NAT, NBSOUS, NBNO,NBELEM
  45. C
  46. C**** Les includes
  47. C
  48. INTEGER I1,ICOMP,ICOMGR,IGEOM
  49. & ,IOP1,ICEN,ISOMM,IFAC,IFACEL,IFACEP,INORM
  50. & ,ISURF,IMAIL,ICHPO,ICHCL,ICHGRA,ICOEFF
  51. & ,NTOT,NSOMM,NCOMP,NFAC,NCEN
  52. & ,NLCF,NGCF,NGCF1,NGCF2,NGCG,NGCD,NLCG,NLCD,NGS1,NGS2
  53. & ,NLS1,NLS2,NLFCL
  54. & ,ISOUS,IELEM,INOEUD,ICELL,NCON,NFIN,INDGA,INDDR
  55. INTEGER ICEN2
  56. REAL*8 SCNX,SCNY,SCNZ,SURF,VOL,VAL,VALX,VALY,VALZ,XG,XD,XF,XS1,XS2
  57. & ,YG,YD,YF,YS1,YS2,ZG,ZD,ZF,ZS1,ZS2,
  58. & PSCA,XNORM,VECX,VECY,PSCAGX,PSCAGY,PSCAGZ,
  59. & PSCADX,PSCADY,PSCADZ,K11G,K22G,K21G,K31G,K32G,K33G,
  60. & K11D,K22D,K21D,K31D,K32D,K33D,VXG1,VXG2,
  61. & VXAU,VYAU,VZAU,VXD1,VXD2,VYG1,VYG2,VYD1,VYD2,VZG1,VZG2,VZD1,VZD2,
  62. & TRG1,TRG2,TRG3,
  63. & TRD1,TRD2,TRD3,TRG,TRD,AUX,AUY,AUZ,AUXMA,THETA,COEFDD
  64. REAL*8 XLONG,AG1,AG2,AD1,AD2,PSCAG1,PSCAG2,PSCAD1,PSCAD2,
  65. & COEF1,COEF2,COEF3,COEF4,SCN1X,SCN1Y,SCN1Z,VX,VY,VZ,COEF1X,COEF2X,
  66. & COEF1Y,COEF2Y,COEF1Z,COEF2Z,CX,CY,CZ,ANCX,ANCY,ANCZ,
  67. & DIFFX,DIFFY,DIFFZ,XLONGG,XLONGD
  68. & VALD,VALG,COEF,GX,GY,GZ,UN,EXPR1,EXPR2
  69.  
  70. c REAL*8 VECXG1(2),VECYG1(2)
  71. c REAL*8 VECXG2(2),VECYG2(2)
  72. c REAL*8 VECXD1(2),VECYD1(2)
  73. c REAL*8 VECXD2(2),VECYD2(2)
  74.  
  75. REAL*8 VECXG(4,4),VECYG(4,4),VECZG(4,4)
  76. REAL*8 VECXD(4,4),VECYD(4,4),VECZD(4,4)
  77. REAL*8 VOLUG(4),SURFAGX(4),SURFAGY(4),SURFAGZ(4),COEFG(4)
  78. REAL*8 VOLUD(4),SURFADX(4),SURFADY(4),SURFADZ(4),COEFD(4)
  79. REAL*8 PX(3,4),PY(3,4),PZ(3,4),TRGAUX(4)
  80. REAL*8 XPRO,TRACE
  81. INTEGER NGS(4),NLS(4),XS(4),YS(4),ZS(4)
  82. INTEGER NLOCFG(4,4),NLOCFD(4,4)
  83. INTEGER IGNS(4)
  84. REAL*8 EPS
  85. INTEGER ICRIT
  86. CHARACTER*(4) NOMCOM(3)
  87. CHARACTER*8 TYPE
  88. C
  89. DATA NOMCOM /'P1DX','P1DY','P1DZ'/
  90.  
  91. INTEGER NDIM
  92. SEGMENT MMAT1
  93. REAL*8 PM(NDIM,NDIM),PM1(NDIM,NDIM),XSOL(NDIM)
  94. INTEGER IC(NDIM)
  95. ENDSEGMENT
  96.  
  97. INTEGER K1,K2
  98. SEGMENT INDICE
  99. INTEGER NUME(K1,K2)
  100. ENDSEGMENT
  101. POINTEUR IND.INDICE,IND2.INDICE,IND22.INDICE
  102.  
  103. SEGMENT MATRICE
  104. REAL*8 MAT(K1,K2)
  105. ENDSEGMENT
  106. POINTEUR VAL1.MATRICE,VAL2.MATRICE,SCMB.MATRICE
  107.  
  108. INTEGER K3
  109. SEGMENT POINT2
  110. INTEGER POINT(K3)
  111. ENDSEGMENT
  112. POINTEUR IPO2.POINT2
  113.  
  114. SEGMENT MATRICE2
  115. REAL*8 MAT2(K1,K2)
  116. ENDSEGMENT
  117. POINTEUR MATR1.MATRICE2,MATR2.MATRICE2
  118.  
  119. SEGMENT POINT3
  120. INTEGER POINT33(K3)
  121. ENDSEGMENT
  122. POINTEUR IPO3.POINT3
  123.  
  124. SEGMENT INDICE3
  125. INTEGER NU(K1,K2)
  126. ENDSEGMENT
  127. POINTEUR INDIC.INDICE3
  128.  
  129. SEGMENT REP
  130. INTEGER ID(K3)
  131. ENDSEGMENT
  132. POINTEUR TAB.REP,INDLI.REP
  133.  
  134. INTEGER K5
  135. SEGMENT NBFAC
  136. INTEGER NBFACEL(K5)
  137. INTEGER IMELEM(K5)
  138. ENDSEGMENT
  139.  
  140. INTEGER K6
  141. SEGMENT NBCOT
  142. INTEGER NBCOTE(K6)
  143. INTEGER IMECOTE(K6)
  144. ENDSEGMENT
  145.  
  146. INTEGER K7,K8
  147. SEGMENT MISZERO
  148. INTEGER TABL(K7)
  149. INTEGER TABL2(K7)
  150. INTEGER TABL1(K8),IPOS(K8),ICOURANT(K8)
  151. REAL*8 XMAX(K7)
  152. ENDSEGMENT
  153. POINTEUR ITAB.MISZERO
  154.  
  155.  
  156. c WRITE(6,*) 'COUCOU NORV4'
  157.  
  158.  
  159. NMAI1 = 0
  160. NMAI2 = 0
  161. NMAI3 = 0
  162. NMAI4 = 0
  163. NBSO = MAX(1,MELTFA.LISOUS(/1))
  164. c WRITE(6,*) 'NBSO MAILLE= ',NBSO
  165. c WRITE(6,*) 'MELTFA= ',MELTFA
  166. IELTFA = MELTFA
  167. IF (NBSO.EQ.1) THEN
  168. K5 = MELTFA.NUM(/2)
  169. ELSEIF (NBSO.EQ.2) THEN
  170. IPT1 = MELTFA.LISOUS(1)
  171. SEGACT IPT1
  172. N1 = IPT1.NUM(/2)
  173. NMAI1 = N1
  174. SEGDES IPT1
  175. IPT2 = MELTFA.LISOUS(2)
  176. SEGACT IPT2
  177. N2 = IPT2.NUM(/2)
  178. NMAI2 = N2
  179. SEGDES IPT2
  180. K5 = N1 + N2
  181. ELSEIF (NBSO.EQ.3) THEN
  182. IPT1 = MELTFA.LISOUS(1)
  183. SEGACT IPT1
  184. N1 = IPT1.NUM(/2)
  185. NMAI1 = N1
  186. SEGDES IPT1
  187. c WRITE(6,*) 'N1= ',N1
  188. IPT2 = MELTFA.LISOUS(2)
  189. SEGACT IPT2
  190. N2 = IPT2.NUM(/2)
  191. NMAI2 = N2
  192. SEGDES IPT2
  193. c WRITE(6,*) 'N2= ',N2
  194. IPT3 = MELTFA.LISOUS(3)
  195. SEGACT IPT3
  196. N3 = IPT3.NUM(/2)
  197. NMAI3 = N3
  198. c WRITE(6,*) 'N3= ',N3
  199. SEGDES IPT3
  200. K5 = N1 + N2 + N3
  201. ELSEIF (NBSO.EQ.4) THEN
  202. IPT1 = MELTFA.LISOUS(1)
  203. SEGACT IPT1
  204. N1 = IPT1.NUM(/2)
  205. NMAI1 = N1
  206. SEGDES IPT1
  207. IPT2 = MELTFA.LISOUS(2)
  208. SEGACT IPT2
  209. N2 = IPT2.NUM(/2)
  210. NMAI2 = N2
  211. SEGDES IPT2
  212. IPT3 = MELTFA.LISOUS(3)
  213. SEGACT IPT3
  214. N3 = IPT3.NUM(/2)
  215. NMAI3 = N3
  216. SEGDES IPT3
  217. IPT4 = MELTFA.LISOUS(4)
  218. SEGACT IPT4
  219. N4 = IPT4.NUM(/2)
  220. NMAI4 = N4
  221. SEGDES IPT4
  222. K5 = N1 + N2 + N3 + N4
  223. ENDIF
  224. c WRITE(6,*) 'K5= ',K5
  225.  
  226.  
  227.  
  228. IF (NBSO.EQ.1) THEN
  229. DO I = 1,K5
  230. NTYPE = MELTFA.ITYPEL
  231. c WRITE(6,*) 'NTYPE= ',NTYPE
  232. IF (NTYPE .EQ. 16) THEN
  233. NBFACEL(I) = 6
  234. IMELEM(I) = MELTFA
  235. ELSEIF (NTYPE .EQ. 25) THEN
  236. NBFACEL(I) = 5
  237. IMELEM(I) = MELTFA
  238. ELSEIF (NTYPE .EQ. 23) THEN
  239. NBFACEL(I) = 4
  240. IMELEM(I) = MELTFA
  241. ELSEIF (NTYPE .EQ. 9) THEN
  242. NBFACEL(I) = 5
  243. IMELEM(I) = MELTFA
  244. ENDIF
  245. c SEGDES MELTFA
  246. ENDDO
  247. ELSEIF (NBSO.EQ.2) THEN
  248. IPT1 = MELTFA.LISOUS(1)
  249. SEGACT IPT1
  250. IPT2 = MELTFA.LISOUS(2)
  251. SEGACT IPT2
  252. DO I = 1,K5
  253. N1 = IPT1.NUM(/2)
  254. IF (I.LE.N1) THEN
  255. NTYPE = IPT1.ITYPEL
  256. IF (NTYPE .EQ. 16) THEN
  257. NBFACEL(I) = 6
  258. IMELEM(I) = IPT1
  259. ELSEIF (NTYPE .EQ. 25) THEN
  260. NBFACEL(I) = 5
  261. IMELEM(I) = IPT1
  262. ELSEIF (NTYPE .EQ. 23) THEN
  263. NBFACEL(I) = 4
  264. IMELEM(I) = IPT1
  265. ELSEIF (NTYPE .EQ. 9) THEN
  266. NBFACEL(I) = 5
  267. IMELEM(I) = IPT1
  268. ENDIF
  269. ELSE
  270. NTYPE = IPT2.ITYPEL
  271. IF (NTYPE .EQ. 16) THEN
  272. NBFACEL(I) = 6
  273. IMELEM(I) = IPT2
  274. ELSEIF (NTYPE .EQ. 25) THEN
  275. NBFACEL(I) = 5
  276. IMELEM(I) = IPT2
  277. ELSEIF (NTYPE .EQ. 23) THEN
  278. NBFACEL(I) = 4
  279. IMELEM(I) = IPT2
  280. ELSEIF (NTYPE .EQ. 9) THEN
  281. NBFACEL(I) = 5
  282. IMELEM(I) = IPT2
  283. ENDIF
  284. ENDIF
  285. ENDDO
  286. ELSEIF (NBSO.EQ.3) THEN
  287. c WRITE(6,*) 'COUCOU'
  288. IPT1 = MELTFA.LISOUS(1)
  289. SEGACT IPT1
  290. NTYPE = IPT1.ITYPEL
  291. c WRITE(6,*) 'NTYPE= ',IPT1.ITYPEL
  292. IPT2 = MELTFA.LISOUS(2)
  293. SEGACT IPT2
  294. NTYPE = IPT2.ITYPEL
  295. c WRITE(6,*) 'NTYPE= ',IPT2.ITYPEL
  296. IPT3 = MELTFA.LISOUS(3)
  297. SEGACT IPT3
  298. NTYPE = IPT3.ITYPEL
  299. c WRITE(6,*) 'NTYPE= ',IPT3.ITYPEL
  300. N1 = IPT1.NUM(/2)
  301. N2 = IPT2.NUM(/2)
  302. N3 = IPT3.NUM(/2)
  303. DO I = 1,K5
  304. IF (I.LE.N1) THEN
  305. NTYPE = IPT1.ITYPEL
  306. IF (NTYPE .EQ. 16) THEN
  307. NBFACEL(I) = 6
  308. IMELEM(I) = IPT1
  309. ELSEIF (NTYPE .EQ. 25) THEN
  310. NBFACEL(I) = 5
  311. IMELEM(I) = IPT1
  312. ELSEIF (NTYPE .EQ. 23) THEN
  313. NBFACEL(I) = 4
  314. IMELEM(I) = IPT1
  315. ELSEIF (NTYPE .EQ. 9) THEN
  316. NBFACEL(I) = 5
  317. IMELEM(I) = IPT1
  318. ENDIF
  319. ELSEIF (I.LE.(N1+N2)) THEN
  320. NTYPE = IPT2.ITYPEL
  321. IF (NTYPE .EQ. 16) THEN
  322. NBFACEL(I) = 6
  323. IMELEM(I) = IPT2
  324. ELSEIF (NTYPE .EQ. 25) THEN
  325. NBFACEL(I) = 5
  326. IMELEM(I) = IPT2
  327. ELSEIF (NTYPE .EQ. 23) THEN
  328. NBFACEL(I) = 4
  329. IMELEM(I) = IPT2
  330. ELSEIF (NTYPE .EQ. 9) THEN
  331. NBFACEL(I) = 5
  332. IMELEM(I) = IPT2
  333. ENDIF
  334. ELSE
  335. NTYPE = IPT3.ITYPEL
  336. IF (NTYPE .EQ. 16) THEN
  337. NBFACEL(I) = 6
  338. IMELEM(I) = IPT3
  339. ELSEIF (NTYPE .EQ. 25) THEN
  340. NBFACEL(I) = 5
  341. IMELEM(I) = IPT3
  342. ELSEIF (NTYPE .EQ. 23) THEN
  343. NBFACEL(I) = 4
  344. IMELEM(I) = IPT3
  345. ELSEIF (NTYPE .EQ. 9) THEN
  346. NBFACEL(I) = 5
  347. IMELEM(I) = IPT3
  348. ENDIF
  349. ENDIF
  350. ENDDO
  351. ELSEIF (NBSO.EQ.4) THEN
  352. IPT1 = MELTFA.LISOUS(1)
  353. SEGACT IPT1
  354. NTYPE = IPT1.ITYPEL
  355. c WRITE(6,*) 'NTYPE= ',IPT1.ITYPEL
  356. IPT2 = MELTFA.LISOUS(2)
  357. SEGACT IPT2
  358. NTYPE = IPT2.ITYPEL
  359. c WRITE(6,*) 'NTYPE= ',IPT2.ITYPEL
  360. IPT3 = MELTFA.LISOUS(3)
  361. SEGACT IPT3
  362. NTYPE = IPT3.ITYPEL
  363. c WRITE(6,*) 'NTYPE= ',IPT3.ITYPEL
  364. IPT4 = MELTFA.LISOUS(4)
  365. SEGACT IPT4
  366. NTYPE = IPT4.ITYPEL
  367. c WRITE(6,*) 'NTYPE= ',IPT4.ITYPEL
  368. N1 = IPT1.NUM(/2)
  369. N2 = IPT2.NUM(/2)
  370. N3 = IPT3.NUM(/2)
  371. N4 = IPT4.NUM(/2)
  372. DO I = 1,K5
  373. IF (I.LE.N1) THEN
  374. NTYPE = IPT1.ITYPEL
  375. IF (NTYPE .EQ. 16) THEN
  376. NBFACEL(I) = 6
  377. IMELEM(I) = IPT1
  378. ELSEIF (NTYPE .EQ. 25) THEN
  379. NBFACEL(I) = 5
  380. IMELEM(I) = IPT1
  381. ELSEIF (NTYPE .EQ. 23) THEN
  382. NBFACEL(I) = 4
  383. IMELEM(I) = IPT1
  384. ELSEIF (NTYPE .EQ. 9) THEN
  385. NBFACEL(I) = 5
  386. IMELEM(I) = IPT1
  387. ENDIF
  388. ELSEIF (I.LE.(N1+N2)) THEN
  389. NTYPE = IPT2.ITYPEL
  390. IF (NTYPE .EQ. 16) THEN
  391. NBFACEL(I) = 6
  392. IMELEM(I) = IPT2
  393. ELSEIF (NTYPE .EQ. 25) THEN
  394. NBFACEL(I) = 5
  395. IMELEM(I) = IPT2
  396. ELSEIF (NTYPE .EQ. 23) THEN
  397. NBFACEL(I) = 4
  398. IMELEM(I) = IPT2
  399. ELSEIF (NTYPE .EQ. 9) THEN
  400. NBFACEL(I) = 5
  401. IMELEM(I) = IPT2
  402. ENDIF
  403. ELSEIF (I.LE.(N1+N2+N3)) THEN
  404. NTYPE = IPT3.ITYPEL
  405. IF (NTYPE .EQ. 16) THEN
  406. NBFACEL(I) = 6
  407. IMELEM(I) = IPT3
  408. ELSEIF (NTYPE .EQ. 25) THEN
  409. NBFACEL(I) = 5
  410. IMELEM(I) = IPT3
  411. ELSEIF (NTYPE .EQ. 23) THEN
  412. NBFACEL(I) = 4
  413. IMELEM(I) = IPT3
  414. ELSEIF (NTYPE .EQ. 9) THEN
  415. NBFACEL(I) = 5
  416. IMELEM(I) = IPT3
  417. ENDIF
  418. ELSE
  419. NTYPE = IPT4.ITYPEL
  420. IF (NTYPE .EQ. 16) THEN
  421. NBFACEL(I) = 6
  422. IMELEM(I) = IPT4
  423. ELSEIF (NTYPE .EQ. 25) THEN
  424. NBFACEL(I) = 5
  425. IMELEM(I) = IPT4
  426. ELSEIF (NTYPE .EQ. 23) THEN
  427. NBFACEL(I) = 4
  428. IMELEM(I) = IPT4
  429. ELSEIF (NTYPE .EQ. 9) THEN
  430. NBFACEL(I) = 5
  431. IMELEM(I) = IPT4
  432. ENDIF
  433. ENDIF
  434. ENDDO
  435. ENDIF
  436.  
  437. c CAS OU LES FACES SONT DES TRIANGLES OU DES FACES
  438. MAUX = MELEFP
  439. NFAI1 = 0
  440. NBSOF = MAX(1,MELEFP.LISOUS(/1))
  441. c WRITE(6,*) 'NBSOF FACE= ',NBSOF
  442. IELTFA = MELTFA
  443. IF (NBSOF.EQ.1) THEN
  444. K6 = MELEFP.NUM(/2)
  445. ELSEIF (NBSOF.EQ.2) THEN
  446. IPT5 = MELEFP.LISOUS(1)
  447. SEGACT IPT5
  448. N1 = IPT5.NUM(/2)
  449. NFAI1 = N1
  450. SEGDES IPT5
  451. IPT6 = MELEFP.LISOUS(2)
  452. SEGACT IPT6
  453. N2 = IPT6.NUM(/2)
  454. NFAI2 = N2
  455. SEGDES IPT6
  456. K6 = N1 + N2
  457. ENDIF
  458.  
  459. C ON EST ICI
  460. IF (NBSOF.EQ.1) THEN
  461. DO I = 1,K6
  462. NTYPE = MELEFP.ITYPEL
  463. c WRITE(6,*) 'NTYPE= ',NTYPE
  464. IF (NTYPE .EQ. 5) THEN
  465. NBCOTE(I) = 3
  466. IMECOTE(I) = MELEFP
  467. ELSE
  468. NBCOTE(I) = 4
  469. IMECOTE(I) = MELEFP
  470. ENDIF
  471. c SEGDES MELTFA
  472. ENDDO
  473. ELSEIF (NBSOF.EQ.2) THEN
  474. c WRITE(6,*) 'POINT2'
  475. IPT5 = MELEFP.LISOUS(1)
  476. SEGACT IPT5
  477. IPT6 = MELEFP.LISOUS(2)
  478. SEGACT IPT6
  479. c WRITE(6,*) 'IPT5= ',IPT5.ITYPEL
  480. c WRITE(6,*) 'IPT6= ',IPT6.ITYPEL
  481. DO I = 1,K6
  482. N1 = IPT5.NUM(/2)
  483. C MISE A JOUR DE MLEFA.LECT
  484. IF (I.LE.N1) THEN
  485. N0 = IPT5.NUM(/1)
  486. NGFAUX = IPT5.NUM(N0,I)
  487. MLEFA2.LECT(NGFAUX) = I
  488. c WRITE(6,*) 'NGFAUX = ',NGFAUX,
  489. c & 'MLEFA2=',MLEFA2.LECT(NGFAUX)
  490. IF (IPT5.ITYPEL .EQ. 5) THEN
  491. NBCOTE(I) = 3
  492. IMECOTE(I) = IPT5
  493. ELSE
  494. NBCOTE(I) = 4
  495. IMECOTE(I) = IPT5
  496. ENDIF
  497. c SEGDES IPT5
  498. ELSE
  499. N0 = IPT6.NUM(/1)
  500. NGFAUX = IPT6.NUM(N0,I-NFAI1)
  501. MLEFA2.LECT(NGFAUX) = I
  502. IF (IPT6.ITYPEL .EQ. 5) THEN
  503. NBCOTE(I) = 3
  504. IMECOTE(I) = IPT6
  505. ELSE
  506. NBCOTE(I) = 4
  507. IMECOTE(I) = IPT6
  508. ENDIF
  509. c SEGDES IPT6
  510. ENDIF
  511.  
  512. ENDDO
  513. ENDIF
  514.  
  515.  
  516.  
  517. NFAC=MELEFL.NUM(/2)
  518.  
  519.  
  520. c ON MAJORE SUPERIEUREMENT NBNN : ON LE REAJUSTERA PAR LA SUITE
  521. NCON = ((2*NBMAX)) + 1
  522. c NCON = ((3*NBMAX)/2) + 1
  523. NBNN = NCON
  524. NESSAI = NCON
  525. NBNN = NESSAI
  526. c WRITE(6,*) 'NBMAX= ',NBMAX
  527. c WRITE(6,*) 'NBNN= ',NBNN
  528. c WRITE(6,*) 'NFAC= ',NFAC
  529.  
  530.  
  531.  
  532. C DEFINITION DES PARAMETRES DU CHAMELEM DES COEFFICIENTS
  533.  
  534. c INITIALISATION DU CHAMELEM
  535. N1=1
  536. N2=1
  537. c WRITE(6,*) 'N2= ',N2
  538. N3=6
  539. L1=8
  540. SEGINI MCHELM
  541. ICOEFF = MCHELM
  542. MCHELM.TITCHE='Gradient'
  543. MCHELM.IFOCHE=IFOUR
  544. C
  545. ISOUS=0
  546. NBSOUS=0
  547. NBREF=0
  548. NBELEM = NFAC
  549. ISOUS=ISOUS+1
  550. SEGINI MELEME
  551. C ITYPEL=32 -> 'POLY'
  552. ITYPEL=32
  553. MCHELM.IMACHE(ISOUS)=MELEME
  554. SEGINI MCHAML
  555. MCHELM.ICHAML(ISOUS)=MCHAML
  556. MCHAML.NOMCHE(1)='SCAL'
  557. MCHAML.TYPCHE(1)='REAL*8 '
  558. N1PTEL=NESSAI
  559. N1EL=NBELEM
  560. N2PTEL=0
  561. N2EL=0
  562. SEGINI MELVA1
  563. MCHAML.IELVAL(1)=MELVA1
  564.  
  565.  
  566.  
  567.  
  568. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  569. C CALCUL DE LA VITESSE EN CHAQUE FACE
  570. AA = 0.0
  571. BB = 0.0
  572. C INDICE QUI COMPTE LES COEFFICIENTS POUR CHAQUE FACE
  573. NAUX2 = 0
  574. NMOY = 0
  575. DO NLCF= 1, NFAC, 1
  576. NCON = 1
  577.  
  578. NGCF=MELEFL.NUM(2,NLCF)
  579. NGCG=MELEFL.NUM(1,NLCF)
  580. NGCD=MELEFL.NUM(3,NLCF)
  581. NLCG=MLECEN.LECT(NGCG)
  582. NLCD=MLECEN.LECT(NGCD)
  583.  
  584. SCNX=MPONOR.VPOCHA(NLCF,1)
  585. SCNY=MPONOR.VPOCHA(NLCF,2)
  586. SCNZ=MPONOR.VPOCHA(NLCF,3)
  587. SCN1X = SCNX
  588. SCN1Y = SCNY
  589. SCN1Z = SCNZ
  590. SURF=0.5D0*MPOSUR.VPOCHA(NLCF,1)
  591. SCNX=SCNX*SURF
  592. SCNY=SCNY*SURF
  593. SCNZ=SCNZ*SURF
  594.  
  595. C 4=IDIM+1
  596. ICELL=(4*(NGCG -1))+1
  597. XG=MCOORD.XCOOR(ICELL)
  598. YG=MCOORD.XCOOR(ICELL+1)
  599. ZG=MCOORD.XCOOR(ICELL+2)
  600. ICELL=(4*(NGCD -1))+1
  601. XD=MCOORD.XCOOR(ICELL)
  602. YD=MCOORD.XCOOR(ICELL+1)
  603. ZD=MCOORD.XCOOR(ICELL+2)
  604. ICELL=(4*(NGCF -1))+1
  605. XF=MCOORD.XCOOR(ICELL)
  606. YF=MCOORD.XCOOR(ICELL+1)
  607. ZF=MCOORD.XCOOR(ICELL+2)
  608.  
  609.  
  610. MELEME.NUM(1,NLCF)=NGCF
  611. MELVA1.VELCHE(1,NLCF)=0.0D0
  612.  
  613. DO J= 1,NBNN
  614. MELVA1.VELCHE(J,NLCF) = 0.0D0
  615. ENDDO
  616.  
  617. C MISE A ZERO DE NLOC
  618. DO JA=1,4
  619. DO IA=1,3
  620. NLOCFG(IA,JA) = 0
  621. NLOCFD(IA,JA) = 0
  622. ENDDO
  623. ENDDO
  624.  
  625.  
  626. MELTFA = IMELEM(NLCG)
  627. NBF = NBFACEL(NLCG)
  628. IF (NLCG.LE.NMAI1) THEN
  629. NGAUX = NLCG
  630. ELSEIF ((NLCG.GT.NMAI1).AND.(NLCG.LE.(NMAI1+NMAI2))) THEN
  631. NGAUX = NLCG - NMAI1
  632. ELSEIF ((NLCG.GT.(NMAI1+NMAI2)).AND.
  633. & (NLCG.LE.(NMAI1+NMAI2+NMAI3))) THEN
  634. NGAUX = NLCG - (NMAI1+NMAI2)
  635. ELSEIF (NLCG.GT.(NMAI1+NMAI2+NMAI3)) THEN
  636. NGAUX = NLCG - (NMAI1+NMAI2+NMAI3)
  637. ENDIF
  638.  
  639.  
  640.  
  641. c ON TIENT COMPTE DU CHANGEMENT DE NUMEROTATION
  642.  
  643.  
  644.  
  645. NLCF1 = MLEFA2.LECT(NGCF)
  646. NBNO = NBCOTE(NLCF1)
  647. MELEFP = IMECOTE(NLCF1)
  648. IF (NLCF1.GT.NFAI1) THEN
  649. NLCF1AUX = NLCF1 - NFAI1
  650. ELSE
  651. NLCF1AUX = NLCF1
  652. ENDIF
  653.  
  654.  
  655. DO IA=1,NBNO
  656. NGS(IA) = MELEFP.NUM(IA,NLCF1AUX)
  657. NLS(IA) = MLESOM.LECT(NGS(IA))
  658. ICELL=(4*(NGS(IA) -1))+1
  659. XS(IA)=nint(MCOORD.XCOOR(ICELL))
  660. YS(IA)=nint(MCOORD.XCOOR(ICELL+1))
  661. ZS(IA)=nint(MCOORD.XCOOR(ICELL+2))
  662. ENDDO
  663.  
  664.  
  665.  
  666.  
  667. C ON REPERE LES VECTEURS PRINCIPAUX DE LA BASE
  668.  
  669. DO JA = 1,NBNO
  670. NGS(JA) = MELEFP.NUM(JA,NLCF1AUX)
  671. c WRITE(6,*) 'NGAUX= ',NGAUX,'JA= ',JA,'NGS= ',NGS(JA)
  672. c WRITE(6,*) 'NGCF= ',NGCF,'NLCF= ',NLCF
  673.  
  674. ICOUR = 0
  675. DO J = 1,NBF
  676. N1 = MELTFA.NUM(J,NGAUX)
  677. NL1 = MLEFA2.LECT(N1)
  678. NBNO2 = NBCOTE(NL1)
  679. MELEP2 = IMECOTE(NL1)
  680. IF (NL1.GT.NFAI1) THEN
  681. NL1AUX = NL1 - NFAI1
  682. ELSE
  683. NL1AUX = NL1
  684. ENDIF
  685. c WRITE(6,*) 'N1= ',N1,'NL1= ',NL1,'NL1AUX= ',NL1AUX
  686.  
  687.  
  688. DO IA =1,NBNO2
  689. NSOM1 = MELEP2.NUM(IA,NL1AUX)
  690. c WRITE(6,*) 'NBNO2= ',NBNO2,'IA= ',IA,'NSOM1= ',NSOM1
  691. IF (NSOM1.EQ.NGS(JA)) THEN
  692.  
  693. ICELL=(4*(N1 -1))+1
  694. XF=MCOORD.XCOOR(ICELL)
  695. YF=MCOORD.XCOOR(ICELL+1)
  696. ZF=MCOORD.XCOOR(ICELL+2)
  697.  
  698. ICOUR = ICOUR + 1
  699. VECXG(ICOUR,JA) = (XF - XG)
  700. VECYG(ICOUR,JA) = (YF - YG)
  701. VECZG(ICOUR,JA) = (ZF - ZG)
  702. NLOCFG(ICOUR,JA) = N1
  703. C ON PERMUTE
  704. IF (N1.EQ.NGCF) THEN
  705. NAUX = NLOCFG(1,JA)
  706. VXAU = VECXG(1,JA)
  707. VYAU = VECYG(1,JA)
  708. VZAU = VECZG(1,JA)
  709. VECXG(1,JA) = (XF - XG)
  710. VECYG(1,JA) = (YF - YG)
  711. VECZG(1,JA) = (ZF - ZG)
  712. NLOCFG(1,JA) = N1
  713. VECXG(ICOUR,JA) = VXAU
  714. VECYG(ICOUR,JA) = VYAU
  715. VECZG(ICOUR,JA) = VZAU
  716. NLOCFG(ICOUR,JA) = NAUX
  717. ENDIF
  718. ENDIF
  719. ENDDO
  720. ENDDO
  721. ENDDO
  722.  
  723. MELTFA = IMELEM(NLCD)
  724. NBF = NBFACEL(NLCD)
  725. IF (NLCD.LE.NMAI1) THEN
  726. NDAUX = NLCD
  727. ELSEIF ((NLCD.GT.NMAI1).AND.(NLCD.LE.(NMAI1+NMAI2))) THEN
  728. NDAUX = NLCD - NMAI1
  729. ELSEIF ((NLCD.GT.(NMAI1+NMAI2)).AND.
  730. & (NLCD.LE.(NMAI1+NMAI2+NMAI3))) THEN
  731. NDAUX = NLCD - (NMAI1+NMAI2)
  732. ELSEIF (NLCD.GT.(NMAI1+NMAI2+NMAI3)) THEN
  733. NDAUX = NLCD - (NMAI1+NMAI2+NMAI3)
  734. ENDIF
  735.  
  736.  
  737. C ON REPERE LES VECTEURS PRINCIPAUX DE LA BASE
  738. DO JA = 1,NBNO
  739. NGS(JA) = MELEFP.NUM(JA,NLCF1AUX)
  740. c WRITE(6,*) 'NDAUX= ',NDAUX,'JA= ',JA,'NGS= ',NGS(JA)
  741. c WRITE(6,*) 'NGCF= ',NGCF,'NLCF= ',NLCF
  742. ICOUR = 0
  743. DO J = 1,NBF
  744. N1 = MELTFA.NUM(J,NDAUX)
  745. NL1 = MLEFA2.LECT(N1)
  746. c WRITE(6,*) 'N1= ',N1,'NL1= ',NL1
  747.  
  748. NBNO2 = NBCOTE(NL1)
  749. MELEP2 = IMECOTE(NL1)
  750. IF (NL1.GT.NFAI1) THEN
  751. NL1AUX = NL1 - NFAI1
  752. ELSE
  753. NL1AUX = NL1
  754. ENDIF
  755.  
  756.  
  757. DO IA =1,NBNO2
  758. NSOM1 = MELEP2.NUM(IA,NL1AUX)
  759. c WRITE(6,*) 'NBNO2= ',NBNO2,'IA= ',IA,'NSOM1= ',NSOM1
  760. IF (NSOM1.EQ.NGS(JA)) THEN
  761.  
  762. ICELL=(4*(N1 -1))+1
  763. XF=MCOORD.XCOOR(ICELL)
  764. YF=MCOORD.XCOOR(ICELL+1)
  765. ZF=MCOORD.XCOOR(ICELL+2)
  766.  
  767. ICOUR = ICOUR + 1
  768. VECXD(ICOUR,JA) = (XF - XD)
  769. VECYD(ICOUR,JA) = (YF - YD)
  770. VECZD(ICOUR,JA) = (ZF - ZD)
  771. NLOCFD(ICOUR,JA) = N1
  772. C ON PERMUTE
  773. IF (N1.EQ.NGCF) THEN
  774. NAUX = NLOCFD(1,JA)
  775. VXAU = VECXD(1,JA)
  776. VYAU = VECYD(1,JA)
  777. VZAU = VECZD(1,JA)
  778. VECXD(1,JA) = (XF - XD)
  779. VECYD(1,JA) = (YF - YD)
  780. VECZD(1,JA) = (ZF - ZD)
  781. NLOCFD(1,JA) = N1
  782. VECXD(ICOUR,JA) = VXAU
  783. VECYD(ICOUR,JA) = VYAU
  784. VECZD(ICOUR,JA) = VZAU
  785. NLOCFD(ICOUR,JA) = NAUX
  786. ENDIF
  787. ENDIF
  788. ENDDO
  789. ENDDO
  790. c WRITE(6,*) 'JA= ',JA
  791. c WRITE(6,*) 'ICOUR= ',ICOUR
  792. ENDDO
  793.  
  794. MPOGRA.VPOCHA(NLCF,1) = 0.D0
  795. DO JA = 1,NBNO
  796. c WRITE(6,*) 'XPRO= ',XPRO
  797.  
  798.  
  799. DO KA = 1,ICOUR
  800. C PRODUIT MIXTES
  801. C PRODUIT VECTORIEL
  802. IF (KA.EQ.1) THEN
  803. PSCAGX = (VECYG(2,JA)*VECZG(3,JA)) -
  804. & (VECZG(2,JA)*VECYG(3,JA))
  805. PSCAGY = (VECZG(2,JA)*VECXG(3,JA)) -
  806. & (VECXG(2,JA)*VECZG(3,JA))
  807. PSCAGZ = (VECXG(2,JA)*VECYG(3,JA)) -
  808. & (VECYG(2,JA)*VECXG(3,JA))
  809. VOLUG(JA) = (VECXG(1,JA)* PSCAGX) +
  810. & (VECYG(1,JA)* PSCAGY) +
  811. & (VECZG(1,JA)* PSCAGZ)
  812. SURFAGX(KA) = 0.5D0* PSCAGX
  813. SURFAGY(KA) = 0.5D0* PSCAGY
  814. SURFAGZ(KA) = 0.5D0* PSCAGZ
  815. IF ( VOLUG(JA).GT.0) THEN
  816. SURFAGX(KA) = - SURFAGX(KA)
  817. SURFAGY(KA) = - SURFAGY(KA)
  818. SURFAGZ(KA) = - SURFAGZ(KA)
  819. ENDIF
  820. VOLUG(JA) = 1.D0/6.D0*ABS(VOLUG(JA))
  821. ENDIF
  822.  
  823. IF (KA.EQ.2) THEN
  824. PSCAGX = (VECYG(3,JA)*VECZG(1,JA)) -
  825. & (VECZG(3,JA)*VECYG(1,JA))
  826. PSCAGY = (VECZG(3,JA)*VECXG(1,JA)) -
  827. & (VECXG(3,JA)*VECZG(1,JA))
  828. PSCAGZ = (VECXG(3,JA)*VECYG(1,JA)) -
  829. & (VECYG(3,JA)*VECXG(1,JA))
  830. SURFAGX(KA) = 0.5D0* PSCAGX
  831. SURFAGY(KA) = 0.5D0* PSCAGY
  832. SURFAGZ(KA) = 0.5D0* PSCAGZ
  833. PSCA = (VECXG(2,JA)* PSCAGX) + (VECYG(2,JA)* PSCAGY) +
  834. & (VECZG(2,JA)* PSCAGZ)
  835. IF ( PSCA.GT.0) THEN
  836. SURFAGX(KA) = - SURFAGX(KA)
  837. SURFAGY(KA) = - SURFAGY(KA)
  838. SURFAGZ(KA) = - SURFAGZ(KA)
  839. ENDIF
  840. ENDIF
  841.  
  842.  
  843. IF (KA.EQ.3) THEN
  844. PSCAGX = (VECYG(1,JA)*VECZG(2,JA)) -
  845. & (VECZG(1,JA)*VECYG(2,JA))
  846. PSCAGY = (VECZG(1,JA)*VECXG(2,JA)) -
  847. & (VECXG(1,JA)*VECZG(2,JA))
  848. PSCAGZ = (VECXG(1,JA)*VECYG(2,JA)) -
  849. & (VECYG(1,JA)*VECXG(2,JA))
  850.  
  851. SURFAGX(KA) = 0.5D0* PSCAGX
  852. SURFAGY(KA) = 0.5D0* PSCAGY
  853. SURFAGZ(KA) = 0.5D0* PSCAGZ
  854. PSCA = (VECXG(3,JA)* PSCAGX) + (VECYG(3,JA)* PSCAGY) +
  855. & (VECZG(3,JA)* PSCAGZ)
  856. IF ( PSCA.GT.0) THEN
  857. SURFAGX(KA) = - SURFAGX(KA)
  858. SURFAGY(KA) = - SURFAGY(KA)
  859. SURFAGZ(KA) = - SURFAGZ(KA)
  860. ENDIF
  861. ENDIF
  862.  
  863. c CALCUL DE MATRICE POUR LE NOEUD D INDICE NS1
  864. IF (ICHTE.EQ.0) THEN
  865. PX(KA,JA) = SURFAGX(KA)/(3.D0*VOLUG(JA))
  866. PY(KA,JA) = SURFAGY(KA)/(3.D0*VOLUG(JA))
  867. PZ(KA,JA) = SURFAGZ(KA)/(3.D0*VOLUG(JA))
  868.  
  869. ELSE
  870. IF (MPOTEN.VPOCHA(/2) .EQ.6) THEN
  871. C TENSEUR ANISOTROPE
  872. K11G = MPOTEN.VPOCHA(NLCG,1)
  873. K22G = MPOTEN.VPOCHA(NLCG,2)
  874. K33G = MPOTEN.VPOCHA(NLCG,3)
  875. K21G = MPOTEN.VPOCHA(NLCG,4)
  876. K31G = MPOTEN.VPOCHA(NLCG,5)
  877. K32G = MPOTEN.VPOCHA(NLCG,6)
  878. ELSEIF (MPOTEN.VPOCHA(/2) .EQ.1) THEN
  879. C TENSEUR DIAGONAL
  880. K11G = MPOTEN.VPOCHA(NLCG,1)
  881. K22G = K11G
  882. K33G = K11G
  883. K21G = 0.0D0
  884. K31G = 0.0D0
  885. K32G = 0.0D0
  886. ELSE
  887. WRITE(6,*) 'TENSEUR NON PREVU'
  888. STOP
  889. ENDIF
  890.  
  891. PSCAGX = (K11G*SURFAGX(KA)) + (K21G*SURFAGY(KA)) +
  892. & (K31G*SURFAGZ(KA))
  893. PSCAGY = (K21G*SURFAGX(KA)) + (K22G*SURFAGY(KA)) +
  894. & (K32G*SURFAGZ(KA))
  895. PSCAGZ = (K31G*SURFAGX(KA)) + (K32G*SURFAGY(KA)) +
  896. & (K33G*SURFAGZ(KA))
  897. PX(KA,JA) = PSCAGX/(3.D0*VOLUG(JA))
  898. PY(KA,JA) = PSCAGY/(3.D0*VOLUG(JA))
  899. PZ(KA,JA) = PSCAGZ/(3.D0*VOLUG(JA))
  900. ENDIF
  901. ENDDO
  902. ENDDO
  903.  
  904. XPRO = 1.D0/NBNO
  905. DO JA = 1,NBNO
  906.  
  907. MARQ = 0
  908. DO I5 = 1,INDLI.ID(NLS(JA))
  909. INDAUX = IND2.NUME(I5,NLS(JA))
  910. IF (INDAUX.EQ.NLOCFG(2,JA)) THEN
  911. IAFF = I5
  912. IG2 = IAFF
  913. GOTO 62
  914. ENDIF
  915. ENDDO
  916. 62 CONTINUE
  917.  
  918. TRG2 = SCMB.MAT(IAFF,NLS(JA))
  919. c WRITE(6,*) 'TR ','IAFF= ',IAFF,TRG2
  920.  
  921. DO I5 = 1,INDLI.ID(NLS(JA))
  922. INDAUX = IND2.NUME(I5,NLS(JA))
  923. IF (INDAUX.EQ.NLOCFG(3,JA)) THEN
  924. IAFF = I5
  925. IG3 = IAFF
  926. GOTO 629
  927. ENDIF
  928. ENDDO
  929. 629 CONTINUE
  930. TRG3 = SCMB.MAT(IAFF,NLS(JA))
  931. c WRITE(6,*) 'TR ','IAFF= ',IAFF,TRG3
  932.  
  933. MARQ = 0
  934. DO I5 = 1,INDLI.ID(NLS(JA))
  935. INDAUX = IND2.NUME(I5,NLS(JA))
  936. IF (INDAUX.EQ.NGCF) THEN
  937. IAFF = I5
  938. IG = IAFF
  939. GOTO 63
  940. ENDIF
  941. ENDDO
  942. 63 CONTINUE
  943. TRG = SCMB.MAT(IAFF,NLS(JA))
  944. TRGAUX(JA) = TRG
  945. IGNS(JA) = IAFF
  946.  
  947. c WRITE(6,*) 'TR ','IAFF= ',IAFF,TRG
  948.  
  949. VAL = MPOCHP.VPOCHA(NLCG,1)
  950. VALD = MPOCHP.VPOCHA(NLCD,1)
  951. c ICI
  952.  
  953. AUX = (XPRO*(
  954. & (PX(1,JA) * (VAL - TRG))
  955. & + (PX(2,JA) * (VAL - TRG2))
  956. & + (PX(3,JA) * (VAL - TRG3))))
  957. AUY = (XPRO*(
  958. & (PY(1,JA) * (VAL - TRG))
  959. & + (PY(2,JA) * (VAL - TRG2))
  960. & + (PY(3,JA) * (VAL - TRG3))))
  961. AUZ = (XPRO*(
  962. & (PZ(1,JA) * (VAL - TRG))
  963. & + (PZ(2,JA) * (VAL - TRG2))
  964. & + (PZ(3,JA) * (VAL - TRG3))))
  965. MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) +
  966. & (AUX*SCN1X) + (AUY*SCN1Y) +
  967. & (AUZ*SCN1Z)
  968.  
  969. c IF (NLCF.EQ.791) THEN
  970. c WRITE(6,*) 'NLCF= ',NLCF,'GR1= ',MPOGRA.VPOCHA(NLCF,1)
  971. c WRITE(6,*) 'NLCF= ',NLCF,'GR2= ',MPOGRA.VPOCHA(NLCF,2)
  972. c WRITE(6,*) 'NLCF= ',NLCF,'GR3= ',MPOGRA.VPOCHA(NLCF,3)
  973. c WRITE(6,*) 'PX= ',PX(1,JA),PX(2,JA),PX(3,JA)
  974. c WRITE(6,*) 'PY= ',PY(1,JA),PY(2,JA),PY(3,JA)
  975. c WRITE(6,*) 'PZ= ',PZ(1,JA),PZ(2,JA),PZ(3,JA)
  976. c WRITE(6,*) 'TR ',TRG,TRG2,TRG3,'VAL',VAL
  977. c WRITE(6,*) 'NLS= ',NLS(JA),
  978. c & 'IG= ',IG,'IG2= ',IG2,'IG3= ',IG3
  979. c WRITE(6,*) 'NGCF= ',NGCF
  980. c ENDIF
  981.  
  982.  
  983. ITROUVE = 0
  984. INDIC = IPO3.POINT33(NLS(JA))
  985. SEGACT INDIC *MOD
  986. MATR1 = IPO2.POINT(NLS(JA))
  987. SEGACT MATR1 *MOD
  988. c NLS1 = NLS(JA)
  989. c DO IAUX = 1,INDLI.ID(NLS1)
  990. c DO IAUX2 = 1,TAB.ID(NLS1)
  991. c WRITE(6,*) 'NLS1= ',NLS1,'IAUX= ',IAUX ,'IAUX2= ',
  992. c & IAUX2,'VAUX',MATR1.MAT2(IAUX,IAUX2)
  993. c & ,'IND3= ',INDIC.NU(IAUX,IAUX2)
  994. c ENDDO
  995. c ENDDO
  996.  
  997. DO ICOUR = 1,TAB.ID(NLS(JA))
  998. IA = ICOUR
  999. J1 = INDIC.NU(IG,IA)
  1000. DO IAUX2 = 2,NCON
  1001. J2 = MELEME.NUM(IAUX2,NLCF)
  1002. IF (J1.EQ.J2) THEN
  1003. IAUX = IAUX2
  1004. ITROUVE = 1
  1005. GOTO 5119
  1006. ENDIF
  1007. ENDDO
  1008. C ON A RIEN TROUVE : ON INCREMENTE LE COMPTEUR
  1009. NCON = NCON + 1
  1010. IAUX = NCON
  1011. 5119 CONTINUE
  1012.  
  1013.  
  1014. CX = MATR1.MAT2(IG,IA)
  1015. CY = MATR1.MAT2(IG,IA)
  1016. CZ = MATR1.MAT2(IG,IA)
  1017. IF (J1.EQ.NGCG) THEN
  1018. CX = CX - 1.D0
  1019. CY = CY - 1.D0
  1020. CZ = CZ - 1.D0
  1021. INDGA = IAUX
  1022. ENDIF
  1023. IF (J1.EQ.NGCD) THEN
  1024. INDDR = IAUX
  1025. ENDIF
  1026. c MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1027. c & (XPRO*PX(1,JA)*CX)
  1028. c MELVA2.VELCHE(IAUX,NLCF) = MELVA2.VELCHE(IAUX,NLCF) -
  1029. c & (XPRO*PY(1,JA)*CY)
  1030. c MELVA3.VELCHE(IAUX,NLCF) = MELVA3.VELCHE(IAUX,NLCF) -
  1031. c & (XPRO*PZ(1,JA)*CZ)
  1032. AUX = (XPRO*PX(1,JA)*CX*SCN1X) +
  1033. & (XPRO*PY(1,JA)*CY*SCN1Y) +
  1034. & (XPRO*PZ(1,JA)*CZ*SCN1Z)
  1035. MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1036. & AUX
  1037.  
  1038. INDAUX = INDIC.NU(IG,IA)
  1039. MELEME.NUM(IAUX,NLCF) = INDAUX
  1040. ENDDO
  1041.  
  1042.  
  1043. ITROUVE = 0
  1044. DO ICOUR = 1,TAB.ID(NLS(JA))
  1045. IA = ICOUR
  1046. J1 = INDIC.NU(IG2,IA)
  1047. DO IAUX2 = 2,NCON
  1048. J2 = MELEME.NUM(IAUX2,NLCF)
  1049. IF (J1.EQ.J2) THEN
  1050. IAUX = IAUX2
  1051. ITROUVE = 1
  1052. GOTO 511
  1053. ENDIF
  1054. ENDDO
  1055. C ON A RIEN TROUVE : ON INCREMENTE LE COMPTEUR
  1056. NCON = NCON + 1
  1057. IAUX = NCON
  1058. 511 CONTINUE
  1059.  
  1060. CX = MATR1.MAT2(IG2,IA)
  1061. CY = MATR1.MAT2(IG2,IA)
  1062. CZ = MATR1.MAT2(IG2,IA)
  1063. IF (J1.EQ.NGCG) THEN
  1064. CX = CX - 1.D0
  1065. CY = CY - 1.D0
  1066. CZ = CZ - 1.D0
  1067. ENDIF
  1068. c MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1069. c & (XPRO*PX(2,JA)*CX)
  1070. c MELVA2.VELCHE(IAUX,NLCF) = MELVA2.VELCHE(IAUX,NLCF) -
  1071. c & (XPRO*PY(2,JA)*CY)
  1072. c MELVA3.VELCHE(IAUX,NLCF) = MELVA3.VELCHE(IAUX,NLCF) -
  1073. c & (XPRO*PZ(2,JA)*CZ)
  1074. AUX = (XPRO*PX(2,JA)*CX*SCN1X) +
  1075. & (XPRO*PY(2,JA)*CY*SCN1Y) +
  1076. & (XPRO*PZ(2,JA)*CZ*SCN1Z)
  1077. MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1078. & AUX
  1079. INDAUX = INDIC.NU(IG2,IA)
  1080. MELEME.NUM(IAUX,NLCF) = INDAUX
  1081. ENDDO
  1082.  
  1083. ITROUVE = 0
  1084. DO ICOUR = 1,TAB.ID(NLS(JA))
  1085. IA = ICOUR
  1086. J1 = INDIC.NU(IG3,IA)
  1087. DO IAUX2 = 2,NCON
  1088. J2 = MELEME.NUM(IAUX2,NLCF)
  1089. IF (J1.EQ.J2) THEN
  1090. IAUX = IAUX2
  1091. ITROUVE = 1
  1092. GOTO 5118
  1093. ENDIF
  1094. ENDDO
  1095. C ON A RIEN TROUVE : ON INCREMENTE LE COMPTEUR
  1096. NCON = NCON + 1
  1097. IAUX = NCON
  1098. 5118 CONTINUE
  1099.  
  1100. CX = MATR1.MAT2(IG3,IA)
  1101. CY = MATR1.MAT2(IG3,IA)
  1102. CZ = MATR1.MAT2(IG3,IA)
  1103. IF (J1.EQ.NGCG) THEN
  1104. CX = CX - 1.D0
  1105. CY = CY - 1.D0
  1106. CZ = CZ - 1.D0
  1107. ENDIF
  1108. c MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1109. c & (XPRO*PX(3,JA)*CX)
  1110. c MELVA2.VELCHE(IAUX,NLCF) = MELVA2.VELCHE(IAUX,NLCF) -
  1111. c & (XPRO*PY(3,JA)*CY)
  1112. c MELVA3.VELCHE(IAUX,NLCF) = MELVA3.VELCHE(IAUX,NLCF) -
  1113. c & (XPRO*PZ(3,JA)*CZ)
  1114. AUX = (XPRO*PX(3,JA)*CX*SCN1X) +
  1115. & (XPRO*PY(3,JA)*CY*SCN1Y) +
  1116. & (XPRO*PZ(3,JA)*CZ*SCN1Z)
  1117. MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1118. & AUX
  1119. INDAUX = INDIC.NU(IG3,IA)
  1120. MELEME.NUM(IAUX,NLCF) = INDAUX
  1121. ENDDO
  1122.  
  1123. c WRITE(6,*) 'NLCF= ',NLCF,'JA= ',JA,'VOLUG(JA) = ',VOLUG(JA),
  1124. c & 'XPRO= ',XPRO
  1125.  
  1126. c FIN DE LA BOUCLE SUR LES NOEUDS
  1127. SEGDES MATR1
  1128. SEGDES INDIC
  1129. ENDDO
  1130.  
  1131. c MPOGRA.VPOCHA(NLCF,1) = 0.0D0
  1132. c ISUP = NCON
  1133. c DO J= ISUP+1,NBNN
  1134. c DO J= 2,NBNN
  1135. c MELVA1.VELCHE(J,NLCF) = 0.0D0
  1136. c MELEME.NUM(J,NLCF) = MELEME.NUM(ISUP,NLCF)
  1137. c ENDDO
  1138. ISUP = NCON
  1139. DO J= ISUP+1,NBNN
  1140. MELVA1.VELCHE(J,NLCF) = 0.0D0
  1141. MELEME.NUM(J,NLCF) = MELEME.NUM(ISUP,NLCF)
  1142. ENDDO
  1143.  
  1144. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  1145. C ON RAJOUTE LE CONVECTIF
  1146.  
  1147. C CALCUL PLUS PRECIS
  1148.  
  1149.  
  1150. c IF (NLCD.NE.NLCG) THEN
  1151. c MELVA1.VELCHE(INDDR,NLCF) = - MELVA1.VELCHE(INDGA,NLCF)
  1152. c ELSE
  1153. c DO J= 1,ISUP
  1154. c ICENT = MELEME.NUM(J,NLCF)
  1155. c ICEN = MLECEN.LECT(ICENT)
  1156. c DIFF = MELVA1.VELCHE(J,NLCF) + MELVA1.VELCHE(INDGA,NLCF)
  1157. c DIFF = ABS(DIFF)
  1158. c XX = ABS(MELVA1.VELCHE(INDGA,NLCF))
  1159. c IF ((ICEN.EQ.0).AND.(DIFF.LT.(1e-5*XX))) THEN
  1160. c MELVA1.VELCHE(J,NLCF) = - MELVA1.VELCHE(INDGA,NLCF)
  1161. c ENDIF
  1162. c ENDDO
  1163. c ENDIF
  1164.  
  1165.  
  1166. IF (ICHCO.GT.0) THEN
  1167. C BOUCLE POUR CALCUER INDGA,INDDR
  1168. INDFR = 0
  1169. DO J= 1,ISUP
  1170. IF (MELEME.NUM(J,NLCF).EQ.NGCG) INDGA = J
  1171. IF (MELEME.NUM(J,NLCF).EQ.NGCD) INDDR = J
  1172. IF (MELEME.NUM(J,NLCF).EQ.NGCF) INDFR = J
  1173. ENDDO
  1174.  
  1175.  
  1176.  
  1177. c WRITE(6,*) 'NGCF= ',NGCF
  1178. UN = MPOVCO.VPOCHA(NLCF,1)
  1179. c WRITE(6,*) 'UN= ',UN
  1180. C OPTION CENTRE
  1181. IF (IOP.EQ.2) THEN
  1182. IF (NLCD.NE.NLCG) THEN
  1183. VAL = 0.5D0*(MPOCHP.VPOCHA(NLCG,1) +
  1184. & MPOCHP.VPOCHA(NLCD,1))*UN
  1185. MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL
  1186. ELSE
  1187. C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION
  1188.  
  1189. XPRO = 1.D0/NBNO
  1190. TRACE = 0.0D0
  1191. DO JA = 1,NBNO
  1192. TRACE =TRACE + (XPRO*TRGAUX(JA))
  1193. ENDDO
  1194. c WRITE(6,*) 'NLCF= ',NLCF,'TRACE= ',TRACE
  1195. VAL = TRACE*UN
  1196. MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL
  1197. ENDIF
  1198.  
  1199. C ON COMPLETE MELVA1 POUR LE CONVECTIF
  1200. IF (NLCD.NE.NLCG) THEN
  1201. MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1202. & (0.5D0*UN)
  1203. MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) -
  1204. & (0.5D0*UN)
  1205. C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDENCES DES TRACES
  1206. c POUR LES CONDITIONS MIXTES OU DE NEUMAN
  1207.  
  1208.  
  1209. ELSE
  1210.  
  1211. NLFCL = MLENCL.LECT(NGCF)
  1212.  
  1213. C ON RAJOUTE CECI POUR L OPTION GRADGEO
  1214. IF (NLFCL.NE.0) THEN
  1215. MELVA1.VELCHE(NCON+1,NLCF) = - UN
  1216. MELEME.NUM(NCON+1,NLCF) = NGCF
  1217. ENDIF
  1218.  
  1219. IF (NLFCL.EQ.0) THEN
  1220. XPRO = 1.D0/NBNO
  1221. DO JA = 1,NBNO
  1222. INDIC = IPO3.POINT33(NLS(JA))
  1223. SEGACT INDIC *MOD
  1224. MATR1 = IPO2.POINT(NLS(JA))
  1225. SEGACT MATR1 *MOD
  1226.  
  1227. DO ICOUR = 1,TAB.ID(NLS(JA))
  1228. IA = ICOUR
  1229. J1 = INDIC.NU(IGNS(JA),IA)
  1230. DO IAUX2 = 2,NCON
  1231. J2 = MELEME.NUM(IAUX2,NLCF)
  1232. IF (J1.EQ.J2) THEN
  1233. IAUX = IAUX2
  1234. GOTO 5169
  1235. ENDIF
  1236. ENDDO
  1237. 5169 CONTINUE
  1238.  
  1239.  
  1240. CX = MATR1.MAT2(IGNS(JA),IA)
  1241. MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1242. & (UN*CX*XPRO)
  1243. ENDDO
  1244. SEGDES INDIC *MOD
  1245. SEGDES MATR1 *MOD
  1246. ENDDO
  1247. ENDIF
  1248. ENDIF
  1249.  
  1250. C OPTION UPWIND
  1251. ELSEIF (IOP.EQ.1) THEN
  1252. IF (NLCD.NE.NLCG) THEN
  1253. IF (UN.GT.0.0D0) THEN
  1254. VAL = (MPOCHP.VPOCHA(NLCG,1)*UN)
  1255. ELSE
  1256. VAL = (MPOCHP.VPOCHA(NLCD,1)*UN)
  1257. ENDIF
  1258. c WRITE(6,*) 'VAL= ',VAL
  1259. MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL
  1260. ELSE
  1261. C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION
  1262. c ANCIENNE VERRUE
  1263. IF (UN.GT.0.0D0) THEN
  1264. VAL = (MPOCHP.VPOCHA(NLCG,1)*UN)
  1265. ELSE
  1266. XPRO = 1.D0/NBNO
  1267. TRACE = 0.0D0
  1268. DO JA = 1,NBNO
  1269. TRACE =TRACE + (XPRO*TRGAUX(JA))
  1270. ENDDO
  1271.  
  1272. c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF
  1273. c WRITE(6,*) 'UN= ',UN,'TRACE=',TRACE
  1274.  
  1275.  
  1276. VAL = TRACE*UN
  1277. ENDIF
  1278.  
  1279.  
  1280. MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL
  1281. ENDIF
  1282.  
  1283. C ON COMPLETE MELVA1 POUR LE CONVECTIF
  1284. IF (NLCD.NE.NLCG) THEN
  1285. c WRITE(6,*) 'UN= ',UN
  1286. IF (UN.GT.0.0D0) THEN
  1287. MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1288. & (UN)
  1289. ELSE
  1290. MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) -
  1291. & (UN)
  1292. ENDIF
  1293. C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDENCES DES TRACES
  1294. c POUR LES CONDITIONS MIXTES OU DE NEUMAN
  1295.  
  1296. ELSE
  1297. c ANCIENNE VERRUE
  1298. IF (UN.GT.0.0D0) THEN
  1299. MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1300. & (UN)
  1301. ELSE
  1302.  
  1303. NLFCL = MLENCL.LECT(NGCF)
  1304.  
  1305. C ON RAJOUTE CECI POUR L OPTION GRADGEO
  1306. C IL Y A PROBABLEMENT REDONDANCE
  1307. IF (NLFCL.NE.0) THEN
  1308. MELVA1.VELCHE(NCON+1,NLCF) = - UN
  1309. MELEME.NUM(NCON+1,NLCF) = NGCF
  1310. ENDIF
  1311. * ENDIF
  1312.  
  1313. IF (NLFCL.EQ.0) THEN
  1314. XPRO = 1.D0/NBNO
  1315. DO JA = 1,NBNO
  1316. INDIC = IPO3.POINT33(NLS(JA))
  1317. SEGACT INDIC *MOD
  1318. MATR1 = IPO2.POINT(NLS(JA))
  1319. SEGACT MATR1 *MOD
  1320.  
  1321. DO ICOUR = 1,TAB.ID(NLS(JA))
  1322. IA = ICOUR
  1323. J1 = INDIC.NU(IGNS(JA),IA)
  1324. DO IAUX2 = 2,NCON
  1325. J2 = MELEME.NUM(IAUX2,NLCF)
  1326. IF (J1.EQ.J2) THEN
  1327. IAUX = IAUX2
  1328. GOTO 5129
  1329. ENDIF
  1330. ENDDO
  1331. 5129 CONTINUE
  1332.  
  1333.  
  1334. CX = MATR1.MAT2(IGNS(JA),IA)
  1335. MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1336. & (UN*CX*XPRO)
  1337. ENDDO
  1338.  
  1339. SEGDES INDIC *MOD
  1340. SEGDES MATR1 *MOD
  1341. ENDDO
  1342. ENDIF
  1343. ENDIF
  1344.  
  1345.  
  1346. ENDIF
  1347.  
  1348.  
  1349. C OPTION UPWICENT
  1350. ELSEIF (IOP.EQ.3) THEN
  1351. IF (NLCD.NE.NLCG) THEN
  1352. c CALCUL DE THETA
  1353. c DANS MELVA1 : INDDR EST LA NUM de NLCD
  1354. C COEFD = MELVA1(INDDR,NLCF)
  1355. COEFDD = MELVA1.VELCHE(INDDR,NLCF)
  1356.  
  1357.  
  1358. THETA = 0.5D0
  1359. EXPR1 = - (THETA*UN) - COEFDD
  1360. EXPR2 = - ((1.D0 - THETA)*UN) + COEFDD
  1361. c WRITE(6,*) 'EXPR1',EXPR1
  1362. c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1363. c & 'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN
  1364. c WRITE(6,*) 'EXPR2',EXPR2
  1365. c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1366. c & 'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN
  1367. IF (EXPR1.GT.0.0D0) THEN
  1368. IF (ABS(UN) .GT. 1e-20) THEN
  1369. THETA = - (0.5D0*COEFDD / UN)
  1370. ENDIF
  1371. ENDIF
  1372. IF (EXPR2.LT.0.0D0) THEN
  1373. IF (ABS(UN) .GT. 1e-20) THEN
  1374. THETA = 1.D0 - (0.5D0*COEFDD / UN)
  1375. ENDIF
  1376. ENDIF
  1377. THETA = MIN(1.D0,THETA)
  1378. THETA = MAX(0.D0,THETA)
  1379.  
  1380. EXPR1 = (THETA*UN) + COEFDD
  1381. EXPR2 = ((1.D0 - THETA)*UN) - COEFDD
  1382. c IF (EXPR1.LT.0.0D0) THEN
  1383. c WRITE(6,*) 'EXPR1',EXPR1
  1384. c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1385. c & 'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN
  1386. c ENDIF
  1387. c IF (EXPR2.GT.0.0D0) THEN
  1388. c WRITE(6,*) 'EXPR2',EXPR2
  1389. c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1390. c & 'COEFDD=',COEFDD,'THETA= ',THETA,'UN= ',UN
  1391. c ENDIF
  1392. c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1393. c & 'EXPR1= ',EXPR1,'EXPR2= ',EXPR2
  1394.  
  1395.  
  1396. VAL = (MPOCHP.VPOCHA(NLCG,1)*UN*THETA) +
  1397. & (MPOCHP.VPOCHA(NLCD,1)*(1.D0-THETA)*UN)
  1398. MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL
  1399. ELSE
  1400. C CONDITIONS AUX LIMITES : TRACE CALCULEE PAR LA DIFFUSION
  1401. IF (INDFR.NE.0) THEN
  1402. COEFDD = MELVA1.VELCHE(INDFR,NLCF)
  1403. ELSE
  1404. COEFDD = 0.0D0
  1405. ENDIF
  1406. C C'EST LE THETA LE MIEUX ADPATE POUR LES CONDITIONS AUX LIMITES
  1407. THETA = 0.0D0
  1408. EXPR1 = - (THETA*UN) - COEFDD
  1409. EXPR2 = - ((1.D0 - THETA)*UN) + COEFDD
  1410.  
  1411. IF (EXPR1.GT.0.0D0) THEN
  1412. IF (ABS(UN) .GT. 1e-20) THEN
  1413. THETA = - (0.5D0*COEFDD / UN)
  1414. ENDIF
  1415. ENDIF
  1416. IF (EXPR2.LT.0.0D0) THEN
  1417. IF (ABS(UN) .GT. 1e-20) THEN
  1418. THETA = 1.D0 - (0.5D0*COEFDD / UN)
  1419. ENDIF
  1420. ENDIF
  1421. THETA = MIN(1.D0,THETA)
  1422. THETA = MAX(0.D0,THETA)
  1423. C ANCIENNE VERRUE
  1424. c THETA = 0.0D0
  1425.  
  1426. XPRO = 1.D0/NBNO
  1427. TRACE = 0.0D0
  1428. DO JA = 1,NBNO
  1429. TRACE =TRACE + (XPRO*TRGAUX(JA))
  1430. ENDDO
  1431. VAL = TRACE*UN
  1432. VAL = (MPOCHP.VPOCHA(NLCG,1)*UN*THETA) +
  1433. & (TRACE*(1.D0-THETA)*UN)
  1434. MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL
  1435.  
  1436. c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1437. c & 'GR1= ',MPOGRA.VPOCHA(NLCF,1),'VAL = ',VAL,
  1438. c & 'TRACE = ',TRACE,'UN= ',UN
  1439. c MPOGRA.VPOCHA(NLCF,1) = MPOGRA.VPOCHA(NLCF,1) - VAL
  1440. c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF,
  1441. c & 'GR1= ',MPOGRA.VPOCHA(NLCF,1)
  1442. ENDIF
  1443.  
  1444. C ON COMPLETE MELVA1 POUR LE CONVECTIF
  1445. IF (NLCD.NE.NLCG) THEN
  1446. MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1447. & (THETA*UN)
  1448. MELVA1.VELCHE(INDDR,NLCF) = MELVA1.VELCHE(INDDR,NLCF) -
  1449. & ((1.D0-THETA)*UN)
  1450. C CONDITION AUX LIMITES : ON RAJOUTE LES DEPENDANCES DES TRACES
  1451. c POUR LES CONDITIONS MIXTES OU DE NEUMAN
  1452.  
  1453. ELSE
  1454.  
  1455. MELVA1.VELCHE(INDGA,NLCF) = MELVA1.VELCHE(INDGA,NLCF) -
  1456. & (THETA*UN)
  1457. NLFCL = MLENCL.LECT(NGCF)
  1458. C ON EST ICI : CORRIGER
  1459. C ON RAJOUTE CECI POUR L OPTION GRADGEO
  1460. c IF (NLFCL.NE.0) THEN
  1461. c MELVA1.VELCHE(NCON+1,NLCF) = - UN
  1462. c MELEME.NUM(NCON+1,NLCF) = NGCF
  1463. c ENDIF
  1464.  
  1465. c IF (NLFCL.EQ.0) THEN
  1466. XPRO = 1.D0/NBNO
  1467. DO JA = 1,NBNO
  1468. INDIC = IPO3.POINT33(NLS(JA))
  1469. SEGACT INDIC *MOD
  1470. MATR1 = IPO2.POINT(NLS(JA))
  1471. SEGACT MATR1 *MOD
  1472.  
  1473. DO ICOUR = 1,TAB.ID(NLS(JA))
  1474. IA = ICOUR
  1475. J1 = INDIC.NU(IGNS(JA),IA)
  1476. DO IAUX2 = 2,NCON
  1477. J2 = MELEME.NUM(IAUX2,NLCF)
  1478. IF (J1.EQ.J2) THEN
  1479. IAUX = IAUX2
  1480. GOTO 5159
  1481. ENDIF
  1482. ENDDO
  1483. 5159 CONTINUE
  1484.  
  1485.  
  1486. CX = MATR1.MAT2(IGNS(JA),IA)
  1487. MELVA1.VELCHE(IAUX,NLCF) = MELVA1.VELCHE(IAUX,NLCF) -
  1488. & ((1.D0-THETA)*UN*CX*XPRO)
  1489. ENDDO
  1490.  
  1491. SEGDES INDIC *MOD
  1492. SEGDES MATR1 *MOD
  1493. ENDDO
  1494. c ENDIF
  1495. ENDIF
  1496.  
  1497. ENDIF
  1498. ENDIF
  1499.  
  1500. c DO J= 1,NBNN
  1501. c PSCA = (MPOGRA.VPOCHA(NLCF,1)*SCN1X) +
  1502. c & (MPOGRA.VPOCHA(NLCF,2)*SCN1Y) +
  1503. c & (MPOGRA.VPOCHA(NLCF,3)*SCN1Z)
  1504. c MPOGRA.VPOCHA(NLCF,1) = PSCA*SCN1X
  1505. c MPOGRA.VPOCHA(NLCF,2) = PSCA*SCN1Y
  1506. c MPOGRA.VPOCHA(NLCF,3) = PSCA*SCN1Z
  1507. c ENDDO
  1508. c IF (NLCF.EQ.791) THEN
  1509. c WRITE(6,*) 'NLCF= ',NLCF,'GR1= ',MPOGRA.VPOCHA(NLCF,1)
  1510. c ENDIF
  1511. c WRITE(6,*) 'NLCF= ',NLCF,'GR2= ',MPOGRA.VPOCHA(NLCF,2)
  1512. c WRITE(6,*) 'NLCF= ',NLCF,'GR3= ',MPOGRA.VPOCHA(NLCF,3)
  1513.  
  1514.  
  1515. c DO J= 1,NBNN
  1516. c PSCA = (MELVA1.VELCHE(J,NLCF)*SCN1X) +
  1517. c & (MELVA2.VELCHE(J,NLCF)*SCN1Y) +
  1518. c & (MELVA3.VELCHE(J,NLCF)*SCN1Z)
  1519. c MELVA1.VELCHE(J,NLCF) = PSCA*SCN1X
  1520. c MELVA2.VELCHE(J,NLCF) = PSCA*SCN1Y
  1521. c MELVA3.VELCHE(J,NLCF) = PSCA*SCN1Z
  1522. c ENDDO
  1523. c DO J= 1,NBNN
  1524. c WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA1= ',
  1525. c & MELVA1.VELCHE(J,NLCF)
  1526. c WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA2= ',
  1527. c & MELVA2.VELCHE(J,NLCF)
  1528. c WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA3= ',
  1529. c & MELVA3.VELCHE(J,NLCF)
  1530. c WRITE(6,*) 'MELEME=',MELEME.NUM(J,NLCF)
  1531. c ENDDO
  1532. C IF (1.EQ.0) THEN
  1533. C WRITE(6,*) 'NGCF= ',NGCF
  1534. C WRITE(6,*) 'NLCF= ',NLCF,'GR1= ',MPOGRA.VPOCHA(NLCF,1)
  1535. C WRITE(6,*) 'NLCF= ',NLCF,'GR2= ',MPOGRA.VPOCHA(NLCF,2)
  1536. C WRITE(6,*) 'NLCF= ',NLCF,'GR3= ',MPOGRA.VPOCHA(NLCF,3)
  1537. C VALD = MPOCHP.VPOCHA(NLCD,1)
  1538. C WRITE(6,*) 'NLCF= ',NLCF,'VALD= ',VALD
  1539. C WRITE(6,*) 'NLCF= ',NLCF,'VAL= ',VAL
  1540. C WRITE(6,*) 'NLCF= ',NLCF,'TRG= ',TRG
  1541. C WRITE(6,*) 'NLCF= ',NLCF,'TRG2= ',TRG2
  1542. C WRITE(6,*) 'NLCF= ',NLCF,'TRG3= ',TRG3
  1543. C WRITE(6,*) 'NLCF= ',NLCF,'TRG= ',TRGAUX
  1544. C WRite(6,*) 'AG1=',AG1
  1545. C WRite(6,*) 'AG2=',AG2
  1546. C WRite(6,*) 'AD1=',AD1
  1547. C WRite(6,*) 'AD2=',AD2
  1548. C ENDIF
  1549. NAUX2 = MAX(NAUX2,NCON)
  1550. NMOY = NMOY + NCON
  1551.  
  1552. c WRITE(6,*) 'INDGA= ',INDGA
  1553. c WRITE(6,*) 'INDDR= ',INDDR
  1554. c DO J= 1,NBNN
  1555. c WRITE(6,*) 'NLCF= ',NLCF,'J=',J,'MELVA1= ',
  1556. c & MELVA1.VELCHE(J,NLCF)
  1557. c ENDDO
  1558.  
  1559.  
  1560. ENDDO
  1561. NMOY = NMOY/(NFAC*1.D0)
  1562.  
  1563. IF (1.EQ.0) THEN
  1564. DO NLCF = 1, NFAC, 1
  1565. MPOGRA.VPOCHA(NLCF,1) = 0.D0
  1566. SCNX=MPONOR.VPOCHA(NLCF,1)
  1567. SCNY=MPONOR.VPOCHA(NLCF,2)
  1568. SCNZ=MPONOR.VPOCHA(NLCF,3)
  1569. SCN1X = SCNX
  1570. SCN1Y = SCNY
  1571. SCN1Z = SCNZ
  1572. NGCF=MELEFL.NUM(2,NLCF)
  1573. DO IVOI=2,MELEME.NUM(/1)
  1574. ICENT = MELEME.NUM(IVOI,NLCF)
  1575. ICEN = MLECEN.LECT(ICENT)
  1576. VAL = 0.0D0
  1577. IF (ICEN.NE.0) THEN
  1578. c WRITE(6,*) 'INTERIEUR'
  1579. VAL = MPOCHP.VPOCHA(ICEN,1)
  1580. ELSE
  1581. ICENL = MLENCL.LECT(ICENT)
  1582. IF (ICENL.GT.0) THEN
  1583. c WRITE(6,*) 'DIRICHLET'
  1584. VAL = MPOVCL.VPOCHA(ICENL,1)
  1585. ENDIF
  1586. ENDIF
  1587.  
  1588. COEF1 = MELVA1.VELCHE(IVOI,NLCF)
  1589. MPOGRA.VPOCHA(NLCF,1)= MPOGRA.VPOCHA(NLCF,1) +
  1590. & (COEF1 * VAL)
  1591.  
  1592. c WRITE(6,*) 'NLCF= ',NLCF,'VAL= ',VAL
  1593. c WRITE(6,*) 'IVOI= ',IVOI,'MELEME= ', MELEME.NUM(IVOI,NLCF),
  1594. c & 'COEF1 = ',COEF1,'COEF2= ',COEF2,'COEF3= ',COEF3
  1595. ENDDO
  1596. c DO J= 1,NBNN
  1597. c PSCA = (MPOGRA.VPOCHA(NLCF,1)*SCN1X) +
  1598. c & (MPOGRA.VPOCHA(NLCF,2)*SCN1Y) +
  1599. c & (MPOGRA.VPOCHA(NLCF,3)*SCN1Z)
  1600. c MPOGRA.VPOCHA(NLCF,1) = PSCA*SCN1X
  1601. c MPOGRA.VPOCHA(NLCF,2) = PSCA*SCN1Y
  1602. c MPOGRA.VPOCHA(NLCF,3) = PSCA*SCN1Z
  1603. c ENDDO
  1604. c NGCF=MELEFL.NUM(2,NLCF)
  1605. c WRITE(6,*) 'NLCF= ',NLCF,'NGCF= ',NGCF
  1606. c WRITE(6,*) 'MPOGRA1= ', MPOGRA.VPOCHA(NLCF,1)
  1607. c WRITE(6,*) 'MPOGRA2= ', MPOGRA.VPOCHA(NLCF,2)
  1608. c WRITE(6,*) 'MPOGRA3= ', MPOGRA.VPOCHA(NLCF,3)
  1609. ENDDO
  1610. ENDIF
  1611.  
  1612. IF (NBSO.EQ.2) THEN
  1613. SEGDES IPT1
  1614. SEGDES IPT2
  1615. ELSEIF (NBSO.EQ.3) THEN
  1616. SEGDES IPT1
  1617. SEGDES IPT2
  1618. SEGDES IPT3
  1619. ELSEIF (NBSO.EQ.4) THEN
  1620. SEGDES IPT1
  1621. SEGDES IPT2
  1622. SEGDES IPT3
  1623. SEGDES IPT4
  1624. ENDIF
  1625. IF (NBSOF.EQ.2) THEN
  1626. SEGDES IPT5
  1627. SEGDES IPT6
  1628. ENDIF
  1629.  
  1630. C ON REJUSTE LE CHAMELEM
  1631.  
  1632.  
  1633. c WRITE(6,*) 'NAUX2= ',NAUX2
  1634. c WRITE(6,*) 'NMOY2= ',NMOY
  1635. c IF (NAUX2.GT.NESSAI) THEN
  1636. c WRITE(6,*) 'NAUX2 = ',NAUX2,'NESSAI = ',NESSAI
  1637. c WRITE(6,*) 'NESSAI TROP PETIT'
  1638. c STOP
  1639. c ENDIF
  1640. N1PTEL=NAUX2
  1641. N1EL=NBELEM
  1642. N2PTEL=0
  1643. N2EL=0
  1644. SEGADJ MELVA1
  1645.  
  1646. NBNN = NAUX2
  1647. SEGADJ MELEME
  1648.  
  1649. K7 = NFAC
  1650. K8 = NAUX2
  1651. SEGINI ITAB
  1652.  
  1653. c ON SUPPRIME LES ZEROS INTERIEURS
  1654. IND = 2
  1655. DO NLCF = 1,NFAC
  1656. IND = 2
  1657. NFIN = NAUX2
  1658. C ON CALCULE D4ABORD LE MAXIMUM DE LA LIGNE
  1659. AUXMA = 0
  1660. DO J=2,NFIN
  1661. ICEN = MLECEN.LECT(MELEME.NUM(J,NLCF))
  1662.  
  1663. IF (ICEN.NE.0) THEN
  1664. AUXMA = MAX(ABS(MELVA1.VELCHE(J,NLCF)),AUXMA)
  1665. ENDIF
  1666. ENDDO
  1667. ITAB.XMAX(NLCF) = AUXMA
  1668.  
  1669. DO J=IND, NFIN
  1670. ICEN = MLECEN.LECT(MELEME.NUM(J,NLCF))
  1671. IF (ABS(MELVA1.VELCHE(J,NLCF)).Le.(1e-14*AUXMA)
  1672. & .AND.(ICEN.NE.0) ) THEN
  1673.  
  1674.  
  1675. DO K=1,NFIN-J
  1676. AUX = MELVA1.VELCHE(J+K,NLCF)
  1677. ICEN = MLECEN.LECT(MELEME.NUM(J+K,NLCF))
  1678. C ON DECALE DE K CRAN
  1679. IF (ABS(AUX).gt.(1e-14*AUXMA).OR.(ICEN.EQ.0)) THEN
  1680. DO I=J,NFIN - K
  1681. MELVA1.VELCHE(I,NLCF) = MELVA1.VELCHE(I+K,NLCF)
  1682. MELEME.NUM(I,NLCF) = MELEME.NUM(I+K,NLCF)
  1683. ENDDO
  1684. C MISE A ZERO DES TERMES DU BOUT
  1685. DO I=NFIN-K+1,NFIN
  1686. MELVA1.VELCHE(I,NLCF) = 0.0
  1687. ENDDO
  1688. GOTO 2000
  1689. ENDIF
  1690. ENDDO
  1691. 2000 CONTINUE
  1692. ENDIF
  1693. ENDDO
  1694. ENDDO
  1695.  
  1696. c IF (1.EQ.0) THEN
  1697. c ON RECONSTUIT UN CHAMELEM EN SUPPRIMANT LES 0
  1698.  
  1699.  
  1700.  
  1701.  
  1702.  
  1703. c TABLEAU CALCULANT LE NOMBRE DE VOISIN NON NUL POUR CHAQUE FACE
  1704. NMOY = 0
  1705. INF = NAUX2
  1706. DO NLCF = 1,NFAC
  1707. IREC = 3
  1708. DO J=NAUX2,1,-1
  1709. IF (ABS(MELVA1.VELCHE(J,NLCF)).gt.
  1710. & (1e-14*ITAB.XMAX(NLCF))) THEN
  1711. IREC = J
  1712. GOTO 1111
  1713. ENDIF
  1714. ENDDO
  1715. 1111 CONTINUE
  1716. ITAB.TABL(NLCF) = IREC
  1717. NMOY = NMOY + IREC
  1718. ENDDO
  1719. NMOY = NMOY/(NFAC*1.D0)
  1720. c WRITE(6,*) 'NEWMOY2= ',NMOY
  1721.  
  1722.  
  1723. C TAB1(U) TABLEAU QUI CONTIENT LE NOMBRE DE FACE AYANT U VOISIN
  1724. NMAX = 0
  1725. DO ICOUR = 1,NAUX2
  1726. ITAB.TABL1(ICOUR) = 0
  1727. ENDDO
  1728.  
  1729. DO NLCF = 1,NFAC
  1730. ICOUR = ITAB.TABL(NLCF)
  1731. ITAB.TABL1(ICOUR)=ITAB.TABL1(ICOUR) + 1
  1732. ENDDO
  1733.  
  1734. C ON COMPTE LE NOMVRE DE SOUS DOMAINE
  1735. NTSOUS = 0
  1736. DO ICOUR = 1,NAUX2
  1737. IF (ITAB.TABL1(ICOUR) .NE.0) NTSOUS = NTSOUS +1
  1738. ENDDO
  1739. C IPOS INDICE DE LA PREMIERE FACE AYANT I VOISIN
  1740. C ICOUR INDICE COURANT INITIALISE A IPOS
  1741.  
  1742.  
  1743. ITAB.IPOS(1) = 1
  1744. DO I = 2,NAUX2
  1745. ITAB.IPOS(I) = ITAB.IPOS(I-1) + ITAB.TABL1(I-1)
  1746. ITAB.ICOURANT(I) = ITAB.IPOS(I)
  1747. ENDDO
  1748.  
  1749.  
  1750. c TABL2 TABLEAU QUI RANGE DANS L4ODRES DES SOUS DOMAINES LES FACES NLCF
  1751.  
  1752. DO I =1,NFAC
  1753. IHELP = ITAB.TABL(I)
  1754. IAUX = ITAB.ICOURANT(IHELP)
  1755. ITAB.TABL2(IAUX) = I
  1756. IAUX2 = ITAB.TABL(I)
  1757. ITAB.ICOURANT(IAUX2) = ITAB.ICOURANT(IAUX2) + 1
  1758. ENDDO
  1759.  
  1760.  
  1761. C**** Initialisation du MCHELM
  1762. C
  1763. N1=NTSOUS
  1764. N2=1
  1765. N3=6
  1766. L1=8
  1767. SEGINI MCHEL2
  1768. MCHEL2.TITCHE='Gradient'
  1769. MCHEL2.IFOCHE=IFOUR
  1770. C
  1771. ISOUS=0
  1772. NBSOUS=0
  1773. NBREF=0
  1774. DO I1 = 1, NAUX2, 1
  1775. NBELEM=ITAB.TABL1(I1)
  1776. IF(NBELEM .GT. 0)THEN
  1777. ISOUS=ISOUS+1
  1778. NBNN=I1
  1779. SEGINI IPT8
  1780. C ITYPEL=32 -> 'POLY'
  1781. ITYPEL=32
  1782. MCHEL2.IMACHE(ISOUS)=IPT8
  1783. SEGINI MCHAM2
  1784. MCHEL2.ICHAML(ISOUS)=MCHAM2
  1785. MCHAM2.NOMCHE(1)='SCAL'
  1786. MCHAM2.TYPCHE(1)='REAL*8 '
  1787. N1PTEL=NBNN
  1788. N1EL=NBELEM
  1789. N2PTEL=0
  1790. N2EL=0
  1791. SEGINI MELVA2
  1792. MCHAM2.IELVAL(1)=MELVA2
  1793.  
  1794. DO I2=1,NBELEM,1
  1795. DO I3=1,NBNN,1
  1796. IAUX = ITAB.IPOS(I1)
  1797. IP= ITAB.TABL2(I2 + IAUX - 1)
  1798. c WRITE(6,*) 'IP= ',IP,'I1= ',I1,'I2=',I2,'I3=',I3
  1799. IPT8.NUM(I3,I2)= MELEME.NUM(I3,IP)
  1800. MELVA2.VELCHE(I3,I2)=MELVA1.VELCHE(I3,IP)
  1801. ENDDO
  1802. ENDDO
  1803. C
  1804. SEGDES MCHAM2
  1805. SEGDES IPT8
  1806. SEGDES MELVA2
  1807. ENDIF
  1808. ENDDO
  1809. SEGDES MCHEL2
  1810. SEGDES ITAB
  1811. c ENDIF
  1812.  
  1813.  
  1814. c SEGDES MCHAML
  1815. c SEGDES MELEME
  1816. c SEGDES MELVA1
  1817. c SEGDES MCHELM
  1818.  
  1819. C 3009
  1820. SEGSUP MCHAML
  1821. SEGSUP MELEME
  1822. SEGSUP MELVA1
  1823. SEGSUP MCHELM
  1824.  
  1825.  
  1826. C SUPRESSION DES SEGMENTS
  1827. K3 = NSOMM
  1828. DO I = 1,K3
  1829. MATR1 = IPO2.POINT(I)
  1830. SEGACT MATR1
  1831. SEGSUP MATR1
  1832. ENDDO
  1833.  
  1834. SEGSUP IPO3
  1835. SEGSUP IPO2
  1836. SEGSUP INDLI
  1837. SEGSUP TAB
  1838. SEGSUP IND2
  1839. c SEGSUP IND
  1840. c SEGSUP IND22
  1841. c SEGSUP VAL1
  1842. c SEGSUP VAL2
  1843. SEGSUP SCMB
  1844. C 3009
  1845. SEGSUP NBCOT
  1846.  
  1847.  
  1848. RETURN
  1849. END
  1850.  
  1851.  
  1852.  
  1853.  
  1854.  
  1855.  
  1856.  
  1857.  
  1858.  
  1859.  
  1860.  
  1861.  
  1862.  
  1863.  
  1864.  
  1865.  
  1866.  

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