Télécharger nor4d3.eso

Retour à la liste

Numérotation des lignes :

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

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