Télécharger nlia.eso

Retour à la liste

Numérotation des lignes :

  1. C NLIA SOURCE BP208322 16/11/18 21:19:32 9177
  2. SUBROUTINE NLIA(CGEOME,FACTIV,TABGEO,TABVDC,TATRAV,
  3. $ METING,LAXI,LERF,LERJ,
  4. $ MYFALS,MYPGS,MYFPGS,MYQRFS,
  5. $ TABMAT,
  6. $ IMPR,IRET)
  7. IMPLICIT REAL*8 (A-H,O-Z)
  8. IMPLICIT INTEGER (I-N)
  9. C***********************************************************************
  10. C NOM : NLIA
  11. C DESCRIPTION : Création d'une matrice intégration des termes de surface
  12. C
  13. C LANGAGE : ESOPE
  14. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  15. C mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES :
  18. C APPELE PAR : PRLIN2
  19. C***********************************************************************
  20. C ENTREES :
  21. C ENTREES/SORTIES : -
  22. C SORTIES :
  23. C TRAVAIL : * SOUGEO (type MELEME) : maillage élémentaire.
  24. C * MLLRFS (type MLLRFS) : pointeurs sur les
  25. C éléments de référence associés aux 4 espaces de
  26. C discrétisation (géométrie, coefficient, primal,
  27. C dual) sur le maillage élémentaire.
  28. C * PGCOUR (type POGAU) : méthode d'intégration
  29. C courante.
  30. C * JCOOR (type MCHEVA) : valeurs du champ ICOOR
  31. C sur le maillage élémentaire.
  32. C Structure (cf.include SMCHAEL) :
  33. C (1, nb. ddl, 1, dim. esp. réel,
  34. C 1, nb. éléments)
  35. C * JCOEFF (type MCHEVA) : valeurs du champ ICOEFF
  36. C sur le maillage élémentaire.
  37. C Structure (cf.include SMCHAEL) :
  38. C (1, nb. ddl, nb. comp. duales,
  39. C nb. comp. primales, 1, nb. éléments)
  40. C * JMTLIA (type MCHEVA) : valeurs du champ IMTLIA
  41. C sur le maillage élémentaire.
  42. C Structure (cf.include SMCHAEL) :
  43. C (nb. ddl dual, nb. ddl primal,
  44. C nb. comp. duales, nb. comp. primales,
  45. C 1, nb. éléments)
  46. C nb. ddl primal=1 si la matrice est condensée.
  47. C * JMAJAC (type MCHEVA) : valeurs de la matrice
  48. C jacobienne aux points de Gauss sur le maillage
  49. C élémentaire.
  50. C Structure (cf.include SMCHAEL) :
  51. C (1, 1, dim. esp. réel, dim. esp. référence,
  52. C nb. poi. gauss, nb. éléments)
  53. C * JMIJAC (type MCHEVA) : valeurs de l'inverse de
  54. C la matrice jacobienne aux points de Gauss sur
  55. C le maillage élémentaire.
  56. C Structure (cf.include SMCHAEL) :
  57. C (1, 1, dim. esp. référence, dim. esp. réel,
  58. C nb. poi. gauss, nb. éléments)
  59. C JMIJAC n'existe que si dim.esp.réf=dim.esp.réel
  60. C * JDTJAC (type MCHEVA) : valeurs du déterminant
  61. C de la matrice jacobienne aux points de Gauss
  62. C sur le maillage élémentaire.
  63. C Structure (cf.include SMCHAEL) :
  64. C (1, 1, 1, 1, nb. poi. gauss, nb. éléments)
  65. C Si la matrice jacobienne n'est pas carrée, on
  66. C a calculé sqrt(det(trans(J).J))
  67. C * JCOEFG (type MCHEVA) : valeurs du coefficient
  68. C tensoriel aux points de Gauss sur le maillage
  69. C élémentaire.
  70. C Structure (cf.include SMCHAEL) :
  71. C (1, 1, nb. comp. duales, nb. comp. primales,
  72. C nb. poi. gauss, nb. éléments)
  73. C * FFPG (type MCHEVA) : valeurs des fonctions
  74. C d'interpolation aux points de gauss sur
  75. C l'élément de référence.
  76. C Structure (cf.include SMCHAEL) :
  77. C (1, nb. ddl, 1, 1, nb. poi. gauss, 1)
  78. C * DFFPG (type MCHEVA) : valeurs des dérivées
  79. C premières des fonctions d'interpolation aux
  80. C points de gauss sur l'élément de référence.
  81. C Structure (cf.include SMCHAEL) :
  82. C (1, nb. ddl, 1, dim.esp.réf, nb. poi. gauss, 1)
  83. C * JDFFPG (type MCHEVA) : valeurs des dérivées
  84. C premières des fonctions d'interpolation
  85. C primales aux points de gauss sur l'élément
  86. C réel.
  87. C Structure (cf.include SMCHAEL) :
  88. C (1, nb. ddl, 1, dim.esp.réel, nb. poi. gauss,
  89. C nb. élém.)
  90. C * JDFFDG (type MCHEVA) : valeurs des dérivées
  91. C premières des fonctions d'interpolation
  92. C duales aux points de gauss sur l'élément réel.
  93. C Structure (cf.include SMCHAEL) :
  94. C (1, nb. ddl, 1, dim.esp.réel, nb. poi. gauss,
  95. C nb. élém.)
  96. C***********************************************************************
  97. C VERSION : v4, 26/07/06, refonte sur le modele du nlin evolue
  98. C VERSION : v3, 11/05/04, refonte (ajout comportement)
  99. C VERSION : v2, 22/09/03, refonte complète (modif SMPOUET)
  100. C VERSION : v1, 22/08/2003, version initiale
  101. C HISTORIQUE : v1, 22/08/2003, création
  102. C HISTORIQUE :
  103. C HISTORIQUE :
  104. C HISTORIQUE :
  105. C***********************************************************************
  106. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  107. C en cas de modification de ce sous-programme afin de faciliter
  108. C la maintenance !
  109. C***********************************************************************
  110. -INC CCOPTIO
  111. -INC CCGEOME
  112. CBEGININCLUDE SELREF
  113. SEGMENT ELREF
  114. CHARACTER*(LNNOM) NOMLRF
  115. CHARACTER*(LNFORM) FORME
  116. CHARACTER*(LNTYPL) TYPEL
  117. CHARACTER*(LNESP) ESPACE
  118. INTEGER DEGRE
  119. REAL*8 XCONOD(NDIMEL,NBNOD)
  120. INTEGER NPQUAF(NBDDL)
  121. INTEGER NUMCMP(NBDDL)
  122. INTEGER QUENOD(NBDDL)
  123. INTEGER ORDDER(NDIMEL,NBDDL)
  124. POINTEUR MBPOLY.POLYNS
  125. ENDSEGMENT
  126. SEGMENT ELREFS
  127. POINTEUR LISEL(0).ELREF
  128. ENDSEGMENT
  129. CENDINCLUDE SELREF
  130. POINTEUR LRFVOL.ELREF
  131. CBEGININCLUDE SFALRF
  132. SEGMENT FALRF
  133. CHARACTER*(LNNFA) NOMFA
  134. INTEGER NUQUAF(NBLRF)
  135. POINTEUR ELEMF(NBLRF).ELREF
  136. ENDSEGMENT
  137. SEGMENT FALRFS
  138. POINTEUR LISFA(0).FALRF
  139. ENDSEGMENT
  140. CENDINCLUDE SFALRF
  141. POINTEUR MYFALS.FALRFS
  142. CBEGININCLUDE SPOGAU
  143. SEGMENT POGAU
  144. CHARACTER*(LNNPG) NOMPG
  145. CHARACTER*(LNTPG) TYPMPG
  146. CHARACTER*(LNFPG) FORLPG
  147. INTEGER NORDPG
  148. REAL*8 XCOPG(NDLPG,NBPG)
  149. REAL*8 XPOPG(NBPG)
  150. ENDSEGMENT
  151. SEGMENT POGAUS
  152. POINTEUR LISPG(0).POGAU
  153. ENDSEGMENT
  154. CENDINCLUDE SPOGAU
  155. POINTEUR MYPGS.POGAUS
  156. CBEGININCLUDE SFAPG
  157. SEGMENT FAPG
  158. CHARACTER*(LNNFAP) NOMFAP
  159. INTEGER NBQUAF(NBMPG)
  160. POINTEUR MPOGAU(NBMPG).POGAU
  161. ENDSEGMENT
  162. SEGMENT FAPGS
  163. POINTEUR LISFPG(0).FAPG
  164. ENDSEGMENT
  165. CENDINCLUDE SFAPG
  166. POINTEUR MYFPGS.FAPGS
  167. CBEGININCLUDE SLCOMP
  168. SEGMENT COMP
  169. CHARACTER*8 NOMCOM
  170. INTEGER DERCOF(NCOCOF)
  171. LOGICAL LTREF
  172. ENDSEGMENT
  173. SEGMENT COMPS
  174. POINTEUR LISCOM(NBCOMP).COMP
  175. ENDSEGMENT
  176. CENDINCLUDE SLCOMP
  177. POINTEUR MYCOM.COMP
  178. POINTEUR IVCOMP.COMP
  179. POINTEUR IVCOMD.COMP
  180. -INC SMLENTI
  181. POINTEUR IPOWCO.MLENTI
  182. -INC SMELEME
  183. POINTEUR CGEOME.MELEME
  184. POINTEUR SOUGEO.MELEME
  185. POINTEUR FACVOL.MELEME
  186. POINTEUR SFAVOL.MELEME
  187. *
  188. CBEGININCLUDE SMCHAEL
  189. SEGMENT MCHAEL
  190. POINTEUR IMACHE(N1).MELEME
  191. POINTEUR ICHEVA(N1).MCHEVA
  192. ENDSEGMENT
  193. SEGMENT MCHEVA
  194. REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
  195. ENDSEGMENT
  196. SEGMENT LCHEVA
  197. POINTEUR LISCHE(NBCHE).MCHEVA
  198. ENDSEGMENT
  199. CENDINCLUDE SMCHAEL
  200. INTEGER N1
  201. POINTEUR ICOOR.MCHAEL
  202. POINTEUR MYMCHA.MCHAEL
  203. POINTEUR JXCOPG.MCHEVA
  204. POINTEUR JXPOPG.MCHEVA
  205. POINTEUR JCOOR.MCHEVA,JCOEFF.MCHEVA,JCOEFG.MCHEVA
  206. POINTEUR JDCOFG.MCHEVA
  207. POINTEUR JMAJAC.MCHEVA,JMIJAC.MCHEVA,JDTJAC.MCHEVA
  208. POINTEUR JMAJA2.MCHEVA,JMIJA2.MCHEVA,JDTJA2.MCHEVA
  209. POINTEUR JDTJA3.MCHEVA
  210. POINTEUR IPROCO.MCHEVA
  211. POINTEUR FC.MCHEVA
  212. POINTEUR FFPG.MCHEVA,DFFPG.MCHEVA,JDFFPG.MCHEVA
  213. POINTEUR FVPR.MCHEVA,FVDU.MCHEVA
  214. POINTEUR FCPR.MCHEVA,FCDU.MCHEVA
  215. POINTEUR JMTLIA.MCHEVA
  216. CBEGININCLUDE SMPOUET
  217. SEGMENT TABGEO
  218. CHARACTER*4 DISGEO
  219. POINTEUR IGEO.MCHAEL
  220. ENDSEGMENT
  221. SEGMENT TABVDC
  222. INTEGER VVARPR(NUMVPR)
  223. INTEGER VVARDU(NUMVDU)
  224. INTEGER VDATPR(NUMDPR)
  225. INTEGER VDATDU(NUMDDU)
  226. INTEGER VCOFPR(NUMCPR)
  227. INTEGER VCOFDU(NUMCDU)
  228. INTEGER ILCPR(NUMDER+1,NUMOP,NUMVPR)
  229. INTEGER ILCDU(NUMDER+1,NUMOP,NUMVDU)
  230. POINTEUR VLCOF(JLCOF).MLENTI
  231. POINTEUR VCOMP(JGCOF).COMP
  232. POINTEUR VLDAT(JGCOF).MLENTI
  233. INTEGER DJSVD(JGVD)
  234. POINTEUR NOMVD(JGVD).MLMOTS
  235. POINTEUR MVD(JGVD).MCHPOI
  236. REAL*8 XVD(JGVD)
  237. CHARACTER*4 DISVD(KGVD)
  238. ENDSEGMENT
  239. SEGMENT TATRAV
  240. POINTEUR VVCOF(JLCOF).MCHEVA
  241. POINTEUR VCOF(JGCOF).MCHEVA
  242. POINTEUR IVD(JGVD).MCHAEL
  243. POINTEUR VD(JGVD).MCHEVA
  244. POINTEUR DVD(JGVD).MCHEVA
  245. POINTEUR FFVD(KGVD).MCHEVA
  246. POINTEUR DFFVD(KGVD).MCHEVA
  247. LOGICAL LVCOF(JGCOF)
  248. LOGICAL LVD(JGVD)
  249. LOGICAL LDVD(JGVD)
  250. LOGICAL LFFVD(KGVD)
  251. LOGICAL LDFFVD(KGVD)
  252. ENDSEGMENT
  253. SEGMENT TABMAT
  254. POINTEUR VMAT(NUMVDU,NUMVPR).MCHAEL
  255. ENDSEGMENT
  256. CENDINCLUDE SMPOUET
  257. INTEGER NUMVPR,NUMVDU,NUMDER,NUMOP
  258. INTEGER JGVC,KGVC
  259. CBEGININCLUDE SFACTIV
  260. SEGMENT FACTIV
  261. POINTEUR IFACTI(NBSOUV).SFACTI
  262. ENDSEGMENT
  263. SEGMENT SFACTI
  264. POINTEUR ISFACT(NBSOFV).SSFACT
  265. ENDSEGMENT
  266. SEGMENT SSFACT
  267. LOGICAL LFACTI(NBELFV,NBELEV)
  268. ENDSEGMENT
  269. CENDINCLUDE SFACTIV
  270. CBEGININCLUDE SIQUAF
  271. SEGMENT IQUAF
  272. INTEGER NUMQUF
  273. REAL*8 XCONQR(NDIMQR,NBNOQR)
  274. INTEGER NUCENT
  275. POINTEUR LFACE.MELEME
  276. ENDSEGMENT
  277. SEGMENT IQUAFS
  278. POINTEUR LISQRF(NBQRF).IQUAF
  279. ENDSEGMENT
  280. CENDINCLUDE SIQUAF
  281. POINTEUR MYQRFS.IQUAFS
  282. POINTEUR IQUVOL.IQUAF
  283. POINTEUR IQUFAC.IQUAF
  284. *
  285. CHARACTER*4 METING
  286. INTEGER LAXI
  287. INTEGER LERF
  288. LOGICAL LERJ,LERJ2
  289. INTEGER IMPR,IRET
  290. *
  291. CHARACTER*4 MYDISC
  292. *
  293. INTEGER NBELEF,NBELFV,NBELEV,NBSOFV,NBSOUV
  294. INTEGER IBELEF,IBELFV,IBELEV,IBSOFV,IBSOUV
  295. INTEGER IJVC,IKVC
  296. INTEGER IVARPR,IVARDU,KDERPR,KDERDU,IOP
  297. INTEGER ITYVOL,NBELEM
  298. LOGICAL LF,LDF,LC,LDC
  299. LOGICAL MVVPR,MVVDU,LVID
  300. *
  301. * Executable statements
  302. *
  303. * IMPR=0
  304. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans nlia'
  305. * Activation et intialisation des chapeaux
  306. SEGACT CGEOME
  307. SEGACT FACTIV
  308. SEGACT TABGEO
  309. SEGACT TABVDC
  310. SEGACT TATRAV*MOD
  311. NBSOUV=CGEOME.LISOUS(/1)
  312. NUMVPR=TABVDC.VVARPR(/1)
  313. NUMVDU=TABVDC.VVARDU(/1)
  314. JLCOF=TABVDC.VLCOF(/1)
  315. JGCOF=TABVDC.VCOMP(/1)
  316. JGVD=TABVDC.DJSVD(/1)
  317. KGVD=TABVDC.DISVD(/2)
  318. NUMDER=TABVDC.ILCPR(/1)-1
  319. NUMOP=TABVDC.ILCPR(/2)
  320. *
  321. N1=NBSOUV
  322. * NUMVPR et NUMVDU initialisés ci-dessus
  323. SEGINI TABMAT
  324. * Cette instruction n'a pas l'air de fonctionner
  325. * SEGINI TABMAT.VMAT(*)
  326. DO IVARPR=1,NUMVPR
  327. DO IVARDU=1,NUMVDU
  328. SEGINI,MYMCHA
  329. TABMAT.VMAT(IVARDU,IVARPR)=MYMCHA
  330. ENDDO
  331. ENDDO
  332. SEGACT MYPGS
  333. ICOOR=TABGEO.IGEO
  334. SEGACT ICOOR
  335. * SEGACT TABVC.NOMVC(*)
  336. DO IJVD=1,JGVD
  337. MYMCHA=TATRAV.IVD(IJVD)
  338. IF (MYMCHA.NE.0) THEN
  339. SEGACT MYMCHA
  340. ENDIF
  341. ENDDO
  342. *
  343. * On travaille sur chaque sous-domaine
  344. *
  345. DO 1 IBSOUV=1,NBSOUV
  346. SOUGEO=CGEOME.LISOUS(IBSOUV)
  347. SEGACT SOUGEO
  348. SFACTI=FACTIV.IFACTI(IBSOUV)
  349. SEGACT,SFACTI
  350. *
  351. NBELEV=SOUGEO.NUM(/2)
  352. ITYVOL=SOUGEO.ITYPEL
  353. * Détermination de la dimension de l'espace de référence
  354. CALL DIMELE(NOMS(ITYVOL),IESREF,IMPR,IRET)
  355. IF (IRET.NE.0) GOTO 9999
  356. *
  357. CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET)
  358. IF (IRET.NE.0) GOTO 9999
  359. *
  360. SEGACT IQUVOL
  361. FACVOL=IQUVOL.LFACE
  362. SEGDES IQUVOL
  363. SEGACT FACVOL
  364. NBSOFV=FACVOL.LISOUS(/1)
  365. *
  366. * On travaille sur chaque type de face pour chaque sous-domaine
  367. *
  368. DO 12 IBSOFV=1,NBSOFV
  369. SFAVOL=FACVOL.LISOUS(IBSOFV)
  370. SEGACT SFAVOL
  371. NBELFV=SFAVOL.NUM(/2)
  372. ITYFAC=SFAVOL.ITYPEL
  373. CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET)
  374. IF (IRET.NE.0) GOTO 9999
  375. SSFACT=SFACTI.ISFACT(IBSOFV)
  376. * On calcule le nb de face pour un type de face d'un sous-domaine
  377. SEGACT SSFACT
  378. IBELEF=0
  379. DO IBELEV=1,NBELEV
  380. DO IBELFV=1,NBELFV
  381. IF (SSFACT.LFACTI(IBELFV,IBELEV)) THEN
  382. IBELEF=IBELEF+1
  383. ENDIF
  384. ENDDO
  385. ENDDO
  386. SEGDES SSFACT
  387. NBELEF=IBELEF
  388. *
  389. * Celui-ci peut être nul : Cas des prismes où on ne calcule des intégrales
  390. * de surface que sur les triangles
  391. *
  392. IF (NBELEF.EQ.0) GOTO 12
  393.  
  394. * Création des segments contenant les poids et points de Gauss sur
  395. * toutes les faces de l'élément de référence.
  396. * In CREPG : SEGINI JXCOPG
  397. * In CREPG : SEGINI JXPOPG
  398. CALL CREPG(IQUVOL,SFAVOL,METING,MYFALS,MYFPGS,
  399. $ JXCOPG,JXPOPG,
  400. $ IMPR,IRET)
  401. IF (IRET.NE.0) GOTO 9999
  402. *
  403. * Géométrie
  404. *
  405. MYDISC=TABGEO.DISGEO
  406. CALL KEEF(ITYVOL,MYDISC,
  407. $ MYFALS,
  408. $ LRFVOL,
  409. $ IMPR,IRET)
  410. IF (IRET.NE.0) GOTO 9999
  411. * In KFNRFF : SEGINI FFPG
  412. * In KFNRFF : SEGINI DFFPG
  413. CALL KFNRFF(LRFVOL,JXCOPG,
  414. $ FFPG,DFFPG,
  415. $ IMPR,IRET)
  416. IF (IRET.NE.0) GOTO 9999
  417. *
  418. * Création des matrices jacobiennes et déterminants
  419. * pour la transformation : élément volumique de référence <->
  420. * élément volumique réel
  421. * Ici, on ne se servira que de l'inverse de la matrice
  422. * jacobienne.
  423. * In GEOLIF : SEGINI JMAJAC
  424. * In GEOLIF : SEGINI JMIJAC
  425. * In GEOLIF : SEGINI JDTJAC
  426. JCOOR=ICOOR.ICHEVA(IBSOUV)
  427. CALL GEOLIF(DFFPG,JCOOR,SSFACT,NBELEF,
  428. $ JMAJAC,JMIJAC,JDTJAC,LERJ,
  429. $ IMPR,IRET)
  430. IF (IRET.NE.0) THEN
  431. IF (LERJ) GOTO 9666
  432. GOTO 9999
  433. ENDIF
  434. SEGSUP DFFPG
  435. *! SEG SUP JMA JAC
  436. *! SEG SUP JDT JAC
  437. *
  438. * Création des matrices jacobiennes et déterminants
  439. * pour la transformation : élément surfacique de référence <->
  440. * élément surfacique réel
  441. * Ici, on ne se servira que du déterminant de la matrice jacobienne.
  442. * In GEOLF2 : SEGINI JMAJA2
  443. * In GEOLF2 : SEGINI JMIJA2
  444. * In GEOLF2 : SEGINI JDTJA2
  445. MYDISC=TABGEO.DISGEO
  446. CALL GEOLF2(LRFVOL,IQUVOL,SFAVOL,
  447. $ MYDISC,METING,MYFALS,MYFPGS,
  448. $ JCOOR,SSFACT,NBELEF,
  449. $ JMAJA2,JMIJA2,JDTJA2,LERJ2,
  450. $ IMPR,IRET)
  451. IF (IRET.NE.0) THEN
  452. IF (LERJ2) THEN
  453. LERJ=LERJ2
  454. GOTO 9666
  455. ENDIF
  456. GOTO 9999
  457. ENDIF
  458. IF (IRET.NE.0) GOTO 9999
  459. SEGSUP JMAJA2
  460. IF (JMIJA2.NE.0) THEN
  461. SEGSUP JMIJA2
  462. ENDIF
  463. SEGSUP FFPG
  464. C Inutile normalement, on peut se débrouiller avec les coeffs
  465. C* En axi, on multiplie le determinant de la matrice
  466. C* jacobienne par 2piR (ou R est la premiere coordonnee)
  467. C IF (LAXI.GT.0) THEN
  468. C* In GEOMFT : SEGINI JDTJA3
  469. C CALL GEOMFT(JCOOR,FFPG,SSFACT,NBELEF,
  470. C $ JDTJA2,LAXI,
  471. C $ JDTJA3,
  472. C $ IMPR,IRET)
  473. C IF (IRET.NE.0) GOTO 9999
  474. C SEGSUP JDTJA2
  475. C JDTJA2=JDTJA3
  476. C ENDIF
  477. *
  478. * Attention : modif par rapport à nlin !
  479. *
  480. JPC=0
  481. JMAREG=0
  482. JDIAMA=0
  483. METRIQ=0
  484. *
  485. * Calcul des fonctions de forme et de leurs dérivées
  486. *
  487. DO IKVD=1,KGVD
  488. LF=TATRAV.LFFVD(IKVD).EQV..TRUE.
  489. LDF=TATRAV.LDFFVD(IKVD).EQV..TRUE.
  490. IF (LF.OR.LDF) THEN
  491. MYDISC=TABVDC.DISVD(IKVD)
  492. CALL KEEF(ITYVOL,MYDISC,
  493. $ MYFALS,
  494. $ LRFVOL,
  495. $ IMPR,IRET)
  496. IF (IRET.NE.0) GOTO 9999
  497. * In KFNRFF : SEGINI FFPG
  498. * In KFNRFF : SEGINI DFFPG
  499. CALL KFNRFF(LRFVOL,JXCOPG,
  500. $ FFPG,DFFPG,
  501. $ IMPR,IRET)
  502. IF (IRET.NE.0) GOTO 9999
  503. IF (LF) THEN
  504. TATRAV.FFVD(IKVD)=FFPG
  505. ELSE
  506. * segini ffpg
  507. SEGSUP FFPG
  508. ENDIF
  509. IF (LDF) THEN
  510. IF (LERF.NE.0) THEN
  511. SEGINI,JDFFPG=DFFPG
  512. SEGDES JDFFPG
  513. ELSE
  514. * In DFNFRF : SEGINI JDFFPG
  515. CALL DFNFRF(DFFPG,JMIJAC,SSFACT,NBELEF,
  516. $ JDFFPG,
  517. $ IMPR,IRET)
  518. IF (IRET.NE.0) GOTO 9999
  519. ENDIF
  520. TATRAV.DFFVD(IKVD)=JDFFPG
  521. ENDIF
  522. SEGSUP DFFPG
  523. ENDIF
  524. ENDDO
  525. *
  526. * Calcul des champs et de leurs dérivées
  527. *
  528. DO IJVD=1,JGVD
  529. LC=TATRAV.LVD(IJVD).EQV..TRUE.
  530. LDC=TATRAV.LDVD(IJVD).EQV..TRUE.
  531. IF (LC.OR.LDC) THEN
  532. MYMCHA=TATRAV.IVD(IJVD)
  533. JCOEFF=MYMCHA.ICHEVA(IBSOUV)
  534. IF (LC) THEN
  535. FFPG=TATRAV.FFVD(TABVDC.DJSVD(IJVD))
  536. * In COGAUF : SEGINI JCOEFG
  537. CALL COGAUF(JCOEFF,FFPG,SSFACT,NBELEF,
  538. $ JCOEFG,
  539. $ IMPR,IRET)
  540. IF (IRET.NE.0) GOTO 9999
  541. TATRAV.VD(IJVD)=JCOEFG
  542. ENDIF
  543. IF (LDC) THEN
  544. JDFFPG=TATRAV.DFFVD(TABVDC.DJSVD(IJVD))
  545. * In DCOGAF : SEGINI JDCOFG
  546. CALL DCOGAF(JCOEFF,JDFFPG,SSFACT,NBELEF,
  547. $ JDCOFG,
  548. $ IMPR,IRET)
  549. IF (IRET.NE.0) GOTO 9999
  550. TATRAV.DVD(IJVD)=JDCOFG
  551. ENDIF
  552. ENDIF
  553. ENDDO
  554. *!!! SEG DES JMIJAC
  555. *
  556. * Calcul des coefficients
  557. *
  558. DO IJGCOF=1,JGCOF
  559. LC=TATRAV.LVCOF(IJGCOF).EQV..TRUE.
  560. IF (LC) THEN
  561. IVCOMP=TABVDC.VCOMP(IJGCOF)
  562. IICOMP=TABVDC.VLDAT(IJGCOF)
  563. * In CALCGA : SEGINI FC
  564. * In CALCGA : SEG INI METRIQ.MCHEVA
  565. CALL CALCGA(IVCOMP,IICOMP,JMAJAC,JMIJAC,JDTJAC,
  566. $ JMAREG,JDIAMA,JPC,METRIQ,
  567. $ TATRAV,
  568. $ FC,IMPR,IRET)
  569. IF (IRET.NE.0) GOTO 9999
  570. TATRAV.VCOF(IJGCOF)=FC
  571. ENDIF
  572. ENDDO
  573. *
  574. * Calcul des produits de coefficients
  575. *
  576. DO IJLCOF=1,JLCOF
  577. IPOWCO=TABVDC.VLCOF(IJLCOF)
  578. * In CALPCO : SEGINI IPROCO
  579. CALL CALPCO(IPOWCO,TATRAV,
  580. $ IPROCO,IMPR,IRET)
  581. IF (IRET.NE.0) GOTO 9999
  582. TATRAV.VVCOF(IJLCOF)=IPROCO
  583. ENDDO
  584. *
  585. * On peut faire le ménage dans les coefficients
  586. *
  587. DO IJGCOF=1,JGCOF
  588. FC=TATRAV.VCOF(IJGCOF)
  589. IF (FC.NE.0) THEN
  590. SEGSUP,FC
  591. TATRAV.VCOF(IJGCOF)=0
  592. ENDIF
  593. ENDDO
  594. *
  595. * On effectue le calcul de la matrice
  596. *
  597. DO IVARPR=1,NUMVPR
  598. DO IVARDU=1,NUMVDU
  599. *Bug mis en evidence par toimp_3d JMTLIA=0
  600. MYMCHA=TABMAT.VMAT(IVARDU,IVARPR)
  601. JMTLIA=MYMCHA.ICHEVA(IBSOUV)
  602. IJVARP=TABVDC.VVARPR(IVARPR)
  603. IJVARD=TABVDC.VVARDU(IVARDU)
  604. IKVARP=TABVDC.DJSVD(IJVARP)
  605. IKVARD=TABVDC.DJSVD(IJVARD)
  606. MVVPR=(TABVDC.MVD(IJVARP).NE.0)
  607. MVVDU=(TABVDC.MVD(IJVARD).NE.0)
  608. DO IOP=1,NUMOP
  609. DO KDERPR=0,NUMDER
  610. IJLCPR=TABVDC.ILCPR(KDERPR+1,IOP,IVARPR)
  611. IF (IJLCPR.NE.0) THEN
  612. FCPR=TATRAV.VVCOF(IJLCPR)
  613. * variable primale
  614. IF (KDERPR.EQ.0) THEN
  615. IF (MVVPR) THEN
  616. FVPR=TATRAV.VD(IJVARP)
  617. ELSE
  618. FVPR=TATRAV.FFVD(IKVARP)
  619. ENDIF
  620. ELSE
  621. IF (MVVPR) THEN
  622. FVPR=TATRAV.DVD(IJVARP)
  623. ELSE
  624. FVPR=TATRAV.DFFVD(IKVARP)
  625. ENDIF
  626. ENDIF
  627. DO KDERDU=0,NUMDER
  628. IJLCDU=TABVDC.ILCDU(KDERDU+1,IOP,IVARDU)
  629. IF (IJLCDU.NE.0) THEN
  630. FCDU=TATRAV.VVCOF(IJLCDU)
  631. * Variable duale
  632. IF (KDERDU.EQ.0) THEN
  633. IF (MVVDU) THEN
  634. FVDU=TATRAV.VD(IJVARD)
  635. ELSE
  636. FVDU=TATRAV.FFVD(IKVARD)
  637. ENDIF
  638. ELSE
  639. IF (MVVDU) THEN
  640. FVDU=TATRAV.DVD(IJVARD)
  641. ELSE
  642. FVDU=TATRAV.DFFVD(IKVARD)
  643. ENDIF
  644. ENDIF
  645. * WRITE(IOIMP,*) 'FVPR=',FVPR
  646. * WRITE(IOIMP,*) 'FVDU=',FVDU
  647. * WRITE(IOIMP,*) 'FCPR=',FCPR
  648. * WRITE(IOIMP,*) 'FCDU=',FCDU
  649. * WRITE(IOIMP,*) 'KDERPR=',KDERPR
  650. * WRITE(IOIMP,*) 'KDERDU=',KDERDU
  651. * WRITE(IOIMP,*) 'LDERPR=',LDERPR
  652. * WRITE(IOIMP,*) 'LDERDU=',LDERDU
  653. * SEGPRT,JXPOPG
  654. * SEGPRT,FVPR
  655. * SEGPRT,FVDU
  656. * SEGPRT,FCPR
  657. * SEGPRT,FCDU
  658. * SEGPRT,JDTJA2
  659. * WRITE(IOIMP,*) 'KDERPR=',KDERPR
  660. * WRITE(IOIMP,*) 'KDERDU=',KDERDU
  661. C WRITE(IOIMP,*) 'LDERPR=',LDERPR
  662. C WRITE(IOIMP,*) 'LDERDU=',LDERDU
  663. C SEGPRT,JDTJA2
  664. C WRITE(IOIMP,*) 'NBELEF=',NBELEF
  665. CALL LIALIN(JXPOPG,
  666. $ FVPR,FVDU,FCPR,FCDU,
  667. $ KDERPR,KDERDU,
  668. $ JDTJA2,SSFACT,NBELEF,LERF,IESREF,
  669. $ JMTLIA,
  670. $ IMPR,IRET)
  671. IF (IRET.NE.0) GOTO 9999
  672. C WRITE(IOIMP,*) 'JMTLIA=',JMTLIA
  673. C SEGPRT,JMTLIA
  674. C* STOP 16
  675. ENDIF
  676. ENDDO
  677. ENDIF
  678. ENDDO
  679. ENDDO
  680. MYMCHA=TABMAT.VMAT(IVARDU,IVARPR)
  681. MYMCHA.IMACHE(IBSOUV)=SOUGEO
  682. MYMCHA.ICHEVA(IBSOUV)=JMTLIA
  683. * IF (JMTLIA.NE.0) THEN
  684. * SEGPRT,JMTLIA
  685. * ENDIF
  686. C WRITE(IOIMP,*) 'IVARPR=',IVARPR
  687. C WRITE(IOIMP,*) 'IVARDU=',IVARDU
  688. C WRITE(IOIMP,*) 'JMTLIA=',JMTLIA
  689. ENDDO
  690. ENDDO
  691. * Suppression de tous les MCHEVA
  692. DO IJLCOF=1,JLCOF
  693. IPROCO=TATRAV.VVCOF(IJLCOF)
  694. SEGSUP IPROCO
  695. TATRAV.VVCOF(IJLCOF)=IPROCO
  696. ENDDO
  697. *
  698. DO IJVD=1,JGVD
  699. JCOEFG=TATRAV.VD(IJVD)
  700. IF (JCOEFG.NE.0) THEN
  701. SEGSUP JCOEFG
  702. TATRAV.VD(IJVD)=JCOEFG
  703. ENDIF
  704. JDCOFG=TATRAV.DVD(IJVD)
  705. IF (JDCOFG.NE.0) THEN
  706. SEGSUP JDCOFG
  707. TATRAV.DVD(IJVD)=JDCOFG
  708. ENDIF
  709. ENDDO
  710. *
  711. DO IKVD=1,KGVD
  712. FFPG=TATRAV.FFVD(IKVD)
  713. IF (FFPG.NE.0) THEN
  714. SEGSUP FFPG
  715. TATRAV.FFVD(IKVD)=FFPG
  716. ENDIF
  717. JDFFPG=TATRAV.DFFVD(IKVD)
  718. IF (JDFFPG.NE.0) THEN
  719. SEGSUP JDFFPG
  720. TATRAV.DFFVD(IKVD)=JDFFPG
  721. ENDIF
  722. ENDDO
  723. *
  724. SEGSUP JDTJA2
  725. SEGSUP JXPOPG
  726. SEGSUP JXCOPG
  727. SEGDES SFAVOL
  728. SEGSUP JDTJAC
  729. SEGSUP JMAJAC
  730. SEGSUP JMIJAC
  731. 12 CONTINUE
  732. * SEGPRT,JMTLIA
  733. SEGDES FACVOL
  734. SEGDES SFACTI
  735. SEGDES SOUGEO
  736. 1 CONTINUE
  737. *
  738. DO IJVD=1,JGVD
  739. MYMCHA=TATRAV.IVD(IJVD)
  740. IF (MYMCHA.NE.0) THEN
  741. SEGDES MYMCHA
  742. ENDIF
  743. ENDDO
  744. * SEGDES TABVC.NOMVC(*)
  745. SEGDES ICOOR
  746. SEGDES MYPGS
  747. * Cette instruction n'a pas l'air de fonctionner
  748. * Un peu de ménage là où il n'y a pas d'info
  749. * SEGDES TABMAT.VMAT(*)
  750. DO IVARPR=1,NUMVPR
  751. DO IVARDU=1,NUMVDU
  752. MYMCHA=TABMAT.VMAT(IVARDU,IVARPR)
  753. SEGACT MYMCHA
  754. LVID=.TRUE.
  755. DO ISOUS=1,NBSOUV
  756. MCHEVA=MYMCHA.ICHEVA(ISOUS)
  757. LVID=LVID.AND.(MCHEVA.EQ.0)
  758. ENDDO
  759. IF (LVID) THEN
  760. SEGSUP MYMCHA
  761. TABMAT.VMAT(IVARDU,IVARPR)=0
  762. ELSE
  763. SEGDES,MYMCHA
  764. ENDIF
  765. ENDDO
  766. ENDDO
  767. SEGDES TATRAV
  768. SEGDES TABMAT
  769. SEGDES TABVDC
  770. SEGDES TABGEO
  771. SEGDES FACTIV
  772. SEGDES CGEOME
  773. *
  774. * Normal termination
  775. *
  776. IRET=0
  777. RETURN
  778. *
  779. * Format handling
  780. *
  781. *
  782. * Error handling
  783. *
  784. 9666 CONTINUE
  785. IRET=666
  786. RETURN
  787. 9999 CONTINUE
  788. IRET=1
  789. WRITE(IOIMP,*) 'An error was detected in subroutine nlia'
  790. RETURN
  791. *
  792. * End of subroutine nlia
  793. *
  794. END
  795.  
  796.  
  797.  
  798.  
  799.  
  800.  
  801.  

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