Télécharger divc.eso

Retour à la liste

Numérotation des lignes :

divc
  1. C DIVC SOURCE CB215821 20/11/25 13:25:36 10792
  2. SUBROUTINE DIVC(IKAS,MTABX)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C************************************************************************
  6. C Operateur KMAC
  7. C
  8. C OBJET : Cree un objet de type MATRIK
  9. C
  10. C
  11. C IKAS=1 KMAB calcul de B (DIV U)
  12. C IKAS=2 KMBT calcul de Bt uniquement (GRAD P)
  13. C IKAS=3 KBBT calcul de B assemblage pour B et Bt
  14. C
  15. C***********************************************************************
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC CCGEOME
  20. -INC CCREEL
  21. -INC SMCOORD
  22. -INC SIZFFB
  23. -INC SMCHPOI
  24. POINTEUR IZCH2.MCHPOI,IZCCH2.MPOVAL
  25. POINTEUR IZDV.MCHPOI,IZDDV.MPOVAL,IZTU1.MPOVAL,TETAN.MPOVAL
  26. POINTEUR IZTG1.MCHPOI,IZTGG1.MPOVAL,IZBETA.MPOVAL,VISCO.MPOVAL
  27. POINTEUR IPM.IZAFM
  28. SEGMENT IMATRS
  29. ENDSEGMENT
  30. POINTEUR IPMS.IZAFM,IPS1.IZAFM,IPS2.IZAFM,IPS3.IZAFM
  31.  
  32. PARAMETER (LRV=64)
  33. DIMENSION VISC(3)
  34.  
  35. -INC SMLENTI
  36. POINTEUR IZIPAD.MLENTI,MLENTI1.MLENTI,MLENTI2.MLENTI
  37. -INC SMLMOTS
  38. POINTEUR LINCO.MLMOTS
  39. -INC SMELEME
  40. POINTEUR MELEMZ.MELEME,MELEMB.MELEME,MELSTB.MELEME
  41. POINTEUR MELEM1.MELEME,MELES1.MELEME,MCTREI.MELEME
  42. POINTEUR IGEOM.MELEME,MELEMA.MELEME
  43. POINTEUR IZLEMC.MELEME,MELEMS.MELEME,MELEMC.MELEME
  44. POINTEUR MELEMI.MELEME,MELEMP.MELEME
  45. POINTEUR MACRO1.MELEME
  46.  
  47. CHARACTER*8 TYPE,TYPC,NOMZ,NOMP,NOMD,NOM0
  48. CHARACTER*8 NOMPP,NOMDD
  49. CHARACTER*4 NOM
  50. INTEGER IPAD,IPAD2,IK
  51. REAL*8 KAUX,TETA1
  52. DIMENSION IXV(5)
  53. C
  54. C*************************************************************************
  55. CKMIC
  56. C write(6,*)' Operateur KMIC MTABX=',MTABX
  57. C
  58. C- Récupération de la table EQEX (pointeur MTAB1)
  59. C
  60. CALL LEKTAB(MTABX,'EQEX',MTAB1)
  61. IF(MTAB1.EQ.0)THEN
  62. C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
  63. MOTERR( 1: 8) = ' EQEX '
  64. MOTERR( 9:16) = ' EQEX '
  65. MOTERR(17:24) = ' KIZX '
  66. CALL ERREUR(786)
  67. RETURN
  68. ENDIF
  69.  
  70. CALL ACME(MTAB1,'DISCPRES',IDISCP)
  71.  
  72. CALL ACME(MTAB1,'NAVISTOK',NASTOK)
  73. IF(NASTOK.EQ.0)THEN
  74. CALL ZKMIC(IKAS,MTABX,MTAB1)
  75. RETURN
  76. ENDIF
  77. C
  78. C- Récupération de la table INCO (pointeur KINC)
  79. C
  80. CALL LEKTAB(MTAB1,'INCO',KINC)
  81. IF(KINC.EQ.0)THEN
  82. C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
  83. MOTERR( 1: 8) = ' INCO '
  84. MOTERR( 9:16) = ' INCO '
  85. MOTERR(17:24) = ' EQEX '
  86. CALL ERREUR(786)
  87. RETURN
  88. ENDIF
  89.  
  90. C*************************************************************************
  91. C OPTIONS
  92. C KIMPL = 0 -> EXPL 1 -> IMPL 2 -> CN
  93. C KFORM = 0 -> EFSI 1 -> EF 2 -> VF 3 -> EFMC
  94. C KPRE=3 pression P0 KPRE=4 pression P1 KPRE=2 cas macro 1ère génération
  95. C KPRE=5 pression MSOMMET
  96.  
  97. IAXI=0
  98. IK=0
  99. IF(IFOMOD.EQ.0)IAXI=2
  100. C
  101. C- Récupération de la table des options KOPT (pointeur KOPTI)
  102. C
  103. CALL LEKTAB(MTABX,'KOPT',KOPTI)
  104. IF (KOPTI.EQ.0) THEN
  105. C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
  106. MOTERR( 1: 8) = ' KOPT '
  107. MOTERR( 9:16) = ' KOPT '
  108. MOTERR(17:24) = ' KIZX '
  109. CALL ERREUR(786)
  110. RETURN
  111. ENDIF
  112.  
  113. CALL ACME(KOPTI,'KIMPL',KIMPL)
  114. CALL ACME(KOPTI,'KPOIN',KPRE)
  115. C write(6,*)'KBBT KPRE=',KPRE
  116. CALL ACMF(KOPTI,'AIMPL',TETA1)
  117. CALL ACME(KOPTI,'KFORM',KFORM)
  118. C CALL ACME(KOPTI,'IKOMP',IKOMP)
  119.  
  120. IF (IERR.NE.0) RETURN
  121. C write(6,*)' Apres les options '
  122. C*************************************************************************
  123. C
  124. C- Récupération de la table DOMAINE associée au domaine local
  125. C
  126. CALL ACMM(MTABX,'NOMZONE',NOMZ)
  127. TYPE=' '
  128. CALL ACMO(MTABX,'DOMZ',TYPE,MMODEL)
  129. IF(TYPE.NE.'MMODEL')THEN
  130. C On attend un des objets : %m1:8 %m9:16 %m17:24 %m25:32 %m33:40
  131. MOTERR( 1: 8) = ' MMODEL '
  132. MOTERR( 8:16) = ' MMODEL '
  133. MOTERR(17:24) = ' MMODEL '
  134. MOTERR(25:32) = ' MMODEL '
  135. MOTERR(33:40) = ' MMODEL '
  136. CALL ERREUR(471)
  137. RETURN
  138. ENDIF
  139.  
  140. CALL LEKMOD(MMODEL,MTABZ,INEFMD)
  141.  
  142. CALL LEKTAB(MTABZ,'MAILLAGE',MELEME)
  143. CALL LEKTAB(MTABZ,'SOMMET',MELEMS)
  144. CALL LEKTAB(MTABZ,'CENTRE',MELEMC)
  145. C?? CALL LEKTAB(MTABZ,'MACRO',MACRO)
  146. MACRO1=0
  147. IF(INEFMD.EQ.2)CALL LEKTAB(MTABZ,'MACRO1',MACRO1)
  148. C?? IF(INEFMD.EQ.3)CALL LEKTAB(MTABZ,'QUADRATI',MQUAD)
  149. IF (IERR.NE.0) RETURN
  150. IF(INEFMD.EQ.4.AND.KPRE.NE.5)THEN
  151. C% Données incompatibles
  152. CALL ERREUR(21)
  153. RETURN
  154. ENDIF
  155.  
  156. MELEMI=MELEME
  157. IF(MACRO1.NE.0.AND.KPRE.NE.2)THEN
  158. MELEMI=MACRO1
  159. ENDIF
  160.  
  161. IF(KPRE.EQ.2.AND.INEFMD.EQ.3)KPRE=3
  162. IF(INEFMD.EQ.1.AND.KPRE.NE.5)KPRE=2
  163.  
  164. IF(KPRE.EQ.3)THEN
  165. CALL LEKTAB(MTABZ,'CENTREP0',MELEMC)
  166. MELEMP=MELEMC
  167. ELSEIF(KPRE.EQ.4)THEN
  168. CALL LEKTAB(MTABZ,'CENTREP1',MELEMC)
  169. CALL LEKTAB(MTABZ,'ELTP1NC ',MELEMP)
  170. ELSEIF(KPRE.EQ.2)THEN
  171. CALL LEKTAB(MTABZ,'CENTRE',MELEMC)
  172. MELEMP=MELEMC
  173. ELSEIF(KPRE.EQ.5)THEN
  174. CALL LEKTAB(MTABZ,'MSOMMET',MELEMC)
  175. CALL LEKTAB(MTABZ,'MMAIL ',MELEMP)
  176. ENDIF
  177. C write(6,*)' KMIC KPRE=',kpre
  178.  
  179. IF(IDISCP.EQ.0)THEN
  180. CALL ECME(MTAB1,'DISCPRES',KPRE)
  181. ELSEIF(IDISCP.NE.KPRE)THEN
  182. C% Données incompatibles
  183. CALL ERREUR(21)
  184. RETURN
  185. ENDIF
  186.  
  187. IKOMP=1
  188. IF(KPRE.EQ.5)IKOMP=0
  189.  
  190. C*************************************************************************
  191. C VERIFICATIONS SUR LES INCONNUES
  192.  
  193. C write(6,*)' Verification sur les inconnues '
  194. TYPE='LISTMOTS'
  195. CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO)
  196. IF (IERR.NE.0) RETURN
  197. SEGACT LINCO
  198. NBINC=LINCO.MOTS(/2)
  199. IF(NBINC.NE.2)THEN
  200. WRITE(6,*)'Operateur KMAB '
  201. WRITE(6,*)'Nombre d''inconnues incorrecte : ',NBINC,' On attend 2'
  202. C Indice %m1:8 : contient plus de %i1 %m9:16
  203. MOTERR( 1:8) = 'LISTINCO'
  204. INTERR(1) = 2
  205. MOTERR(9:16) = ' MOTS '
  206. CALL ERREUR(799)
  207. RETURN
  208. ENDIF
  209.  
  210. C On recupere PHI n et TETA n pour Cranck-Nicholson
  211. NOMP=LINCO.MOTS(1)
  212. TYPE=' '
  213. CALL ACMO(KINC,NOMP,TYPE,MCHPOI)
  214. IF(TYPE.NE.'CHPOINT ')THEN
  215. WRITE(6,*)' Opérateur KMAB :'
  216. WRITE(6,*)' L objet CHPOINT ',NOMP,
  217. & ' n existe pas dans la table'
  218. C Indice %m1:8 : ne contient pas un objet de type %m9:16
  219. MOTERR( 1: 8) = 'INC '//NOMP
  220. MOTERR( 9:16) = 'CHPOINT '
  221. CALL ERREUR(800)
  222. RETURN
  223. ELSE
  224. CALL LICHT(MCHPOI,IZTU1,TYPC,IGEOM0)
  225. ENDIF
  226. C*************************************************************************
  227. C Le domaine de definition est donne par le SPG de la premiere inconnue
  228. C Les inconnues suivantes devront posseder ce meme pointeur
  229. C On verifie que les points de la zone sont tous inclus dans ce SPG
  230. C Inconnue Primale
  231.  
  232. C write(6,*)' Verification inconnue primale '
  233. CALL KRIPAD(IGEOM0,MLENTI)
  234. IF(IKAS.EQ.1.OR.IKAS.EQ.3)THEN
  235. MELEMK=MELEMS
  236. ELSE
  237. MELEMK=MELEMC
  238. ENDIF
  239.  
  240. C write(6,*)' MELEMK=',melemk
  241. CALL VERPAD(MLENTI,MELEMK,IRET)
  242. IF(IRET.NE.0)THEN
  243. WRITE(6,*)' Opérateur KMAB '
  244. WRITE(6,*)' La zone ',NOMZ,' n''est pas incluse dans le domaine'
  245. & , ' de définition de l''inconnue ',NOMP
  246. WRITE(6,*)' MELEMK=',melemk,' IGEOM0=',IGEOM0
  247. C Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique
  248. MOTERR(1: 8) = 'INC '//NOMP
  249. MOTERR(9:16) = 'CHPOINT '
  250. CALL ERREUR(788)
  251. IPAS=0
  252. RETURN
  253. ENDIF
  254.  
  255. SEGSUP MLENTI
  256.  
  257. C*************************************************************************
  258.  
  259. NOMD=LINCO.MOTS(2)
  260. TYPE=' '
  261. CALL ACMO(KINC,NOMD,TYPE,MCHPOI)
  262. IF(TYPE.NE.'CHPOINT ')THEN
  263. WRITE(6,*)' Opérateur KMAB :'
  264. WRITE(6,*)' L objet CHPOINT ',NOMD,
  265. & ' n existe pas dans la table'
  266. C Indice %m1:8 : ne contient pas un objet de type %m9:16
  267. MOTERR( 1: 8) = 'INC '//NOMD
  268. MOTERR( 9:16) = 'CHPOINT '
  269. CALL ERREUR(800)
  270. RETURN
  271. ELSE
  272. CALL LICHT(MCHPOI,TETAN,TYPC,IGEOM0)
  273. ENDIF
  274.  
  275. NC=TETAN.VPOCHA(/2)
  276. C*************************************************************************
  277. C Le domaine de definition est donne par le SPG de la premiere inconnue
  278. C Les inconnues suivantes devront posseder ce meme pointeur
  279. C On verifie que les points de la zone sont tous inclus dans ce SPG
  280. C Inconnue Duale
  281.  
  282. C write(6,*)' IGEOM0=',igeom0
  283. CALL KRIPAD(IGEOM0,MLENTI)
  284. IF(IKAS.EQ.1.OR.IKAS.EQ.3)THEN
  285. MELEMK=MELEMC
  286. ELSE
  287. MELEMK=MELEMS
  288. ENDIF
  289.  
  290. C write(6,*)' Verification inconnue duale ',MELEMK
  291. CALL VERPAD(MLENTI,MELEMK,IRET)
  292. IF(IRET.NE.0)THEN
  293. WRITE(6,*)' Opérateur KMAB '
  294. WRITE(6,*)' La zone ',NOMZ,' n''est pas incluse dans le domaine'
  295. & ,' de définition de l''inconnue ',NOMD
  296. WRITE(6,*)' MELEMK=',melemk,' IGEOM0=',IGEOM0
  297. C Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique
  298. MOTERR(1: 8) = 'INC '//NOMD
  299. MOTERR(9:16) = 'CHPOINT '
  300. CALL ERREUR(788)
  301. IPAS=0
  302. RETURN
  303. ENDIF
  304.  
  305. SEGSUP MLENTI
  306.  
  307. C*************************************************************************
  308. C Lecture du ou des coefficients
  309. C Type du coefficient :
  310. C IK1=0 CHPOINT IK1=1 scalaire IK1=2 vecteur
  311.  
  312. C write(6,*)' Verification sur les coefficients '
  313. CALL ACME(MTABX,'IARG',IARG)
  314. C write(6,*)' IARG=',iarg
  315.  
  316. IF(MACRO1.NE.0.AND.IKAS.NE.2.AND.KPRE.EQ.2)THEN
  317. TYPE=' '
  318. CALL ACMO(MTABZ,'MELSTB',TYPE,MELSTB)
  319. SEGACT MELSTB
  320. IF(IDIM.EQ.2)NBELEM=MELSTB.NUM(/2)/4
  321. IF(IDIM.EQ.3)NBELEM=MELSTB.NUM(/2)/8
  322. NBNN=MELSTB.NUM(/1)
  323. NBSOUS=0
  324. NBREF=0
  325. SEGINI MELEMA
  326. MELEMA.ITYPEL=MELSTB.ITYPEL
  327.  
  328. NKPE=4
  329. IF(IDIM.EQ.3)NKPE=8
  330. do 4878 k=1,nbelem
  331. mi=(k-1)*NKPE+1
  332. do 4879 i=1,nbnn
  333. MELEMA.num(i,k)=melstb.num(i,mi)
  334. 4879 continue
  335. C write(6,*)k,(MELEMA.num(i,k),i=1,nbnn)
  336. 4878 continue
  337.  
  338. TYPE=' '
  339. CALL ACMO(MTABZ,'MCHPOC',TYPE,MCHPOC)
  340. TYPE=' '
  341. CALL ACMO(MTABZ,'CENTRE',TYPE,MCTREI)
  342. ENDIF
  343.  
  344.  
  345. C 1er COEF
  346.  
  347. IXV(1)=MELEMC
  348. IXV(2)=1
  349. IXV(3)=0
  350. IXV(4)=MELEMS
  351. IXV(5)=-MELEMS
  352. IRET=5
  353. CALL LEKCOF('Opérateur KMAB :',
  354. & MTABX,KINC,1,IXV,IZTG1,IZTGG1,NPT1,NC1,IK1,IRET)
  355. IF(IRET.EQ.0)RETURN
  356. IF(IK1.GE.4)CALL KRIPAD(MELEMS,MLENTI)
  357.  
  358.  
  359. BETA0=1.D-1
  360. IF(IARG.EQ.2)THEN
  361. C 2ème COEF
  362. IXV(1)=0
  363. IXV(2)=1
  364. IXV(3)=0
  365. CALL LEKCOF('Opérateur KMAB :',
  366. & MTABX,KINC,2,IXV,IZTG2,IZBETA,NPT2,NC2,IK2,IRET)
  367. IF(IRET.EQ.0)RETURN
  368. BETA0=IZBETA.VPOCHA(1,1)
  369. C? IF(IZBETA.VPOCHA(1,1).LT.0.D0)THEN
  370. C% Données incompatibles
  371. C? CALL ERREUR(21)
  372. C? RETURN
  373. C? ENDIF
  374. ENDIF
  375.  
  376.  
  377. NOMP=LINCO.MOTS(1)
  378. NOMD=LINCO.MOTS(2)(1:4)
  379.  
  380. NRIGE=7
  381. NKID =9
  382. NKMT =7
  383. NMATRI=1
  384. IF(MACRO1.NE.0.AND.IKAS.NE.2.AND.KPRE.EQ.2)NMATRI=2
  385. IF(MACRO1.NE.0.AND.IKAS.NE.2.AND.KPRE.EQ.4.AND.IDIM.EQ.2)NMATRI=2
  386. IF(KPRE.EQ.5)NMATRI=NMATRI+1
  387. C write(6,*)' NMATRI=',nmatri,' KPRE=',kpre
  388. SEGINI MATRIK
  389.  
  390. C CAS Stabilisation via MACRO CENTRE
  391. IF(MACRO1.NE.0.AND.IKAS.NE.2.AND.KPRE.EQ.2)THEN
  392. IF(IKAS.EQ.3)BETA0=-BETA0
  393. C write(6,*)' CAS Stabilisation via MACRO CENTRE ',BETA0,IKAS
  394. NK=0
  395. I2=2
  396. NBME=1
  397. NBSOUS=1
  398. SEGINI IMATRI
  399. IRIGEL(4,i2)=IMATRI
  400. KSPGP=MCTREI
  401. KSPGD=MCTREI
  402. IRIGEL(1,i2)=MELEMA
  403. IRIGEL(2,i2)=MELEMA
  404. IRIGEL(7,i2)=0
  405. CALL LICHT(MCHPOC,MPOVAL,TYPC,IGEOM)
  406.  
  407. C write(6,*)' MELSTB=',melstb,' MCTREI=',MCTREI
  408.  
  409. SEGACT MELSTB
  410.  
  411. NBSOUS=MELSTB.LISOUS(/1)
  412. IF(NBSOUS.NE.0)THEN
  413. CALL ERREUR(5)
  414. ENDIF
  415.  
  416. NBEL=MELEMA.NUM(/2)
  417. NBCI=MELSTB.NUM(/2)
  418. NP =MELSTB.NUM(/1)
  419. MP =NP
  420.  
  421. C write(6,*)' nbel,nbci,np,mp=',nbel,nbci,np,mp
  422. SEGINI IZAFM
  423. LIZAFM(1,1)=IZAFM
  424. LISPRI(1)=NOMD
  425. LISDUA(1)=NOMD
  426.  
  427. CALL KRIPAD(MCTREI,MLENT1)
  428.  
  429. C write(6,*)' IK1=',ik1
  430. IF(IK1.LT.4)THEN
  431. DO 33 K=1,NBEL
  432.  
  433. NK=NK+1
  434. KC=1+(1-IK1)*(NK-1)
  435. C write(6,*)' K=',K,' NK=',nk,np,kc
  436.  
  437. DO 32 J=1,NP
  438. K1=MLENT1.LECT(MELEMA.NUM(J,K))
  439. II=J
  440. DO 321 I=1,NP
  441. U=VPOCHA(K1,I)*BETA0*IZTGG1.VPOCHA(KC,1)
  442. IF(I.EQ.1)U=ABS(VPOCHA(K1,I))*BETA0*IZTGG1.VPOCHA(KC,1)
  443. IF(II.LE.NP)THEN
  444. AM(K,II,J)=U
  445. ELSE
  446. AM(K,II-NP,J)=U
  447. ENDIF
  448. II=II+1
  449. 321 CONTINUE
  450. 32 CONTINUE
  451. 33 CONTINUE
  452. C write(6,*)' FIN BCL 33 '
  453. ELSE
  454.  
  455. DO 34 K=1,NBEL
  456.  
  457. NK=NK+1
  458. UA=1.D0
  459.  
  460. DO 35 J=1,NP
  461. K1=MLENT1.LECT(MELEMA.NUM(J,K))
  462. II=J
  463. DO 351 I=1,NP
  464. U=VPOCHA(K1,I)*BETA0*UA
  465. IF(I.EQ.1)U=ABS(VPOCHA(K1,I))*BETA0*UA
  466. IF(II.LE.NP)THEN
  467. AM(K,II,J)=U
  468. ELSE
  469. AM(K,II-NP,J)=U
  470. ENDIF
  471. II=II+1
  472. 351 CONTINUE
  473. 35 CONTINUE
  474. 34 CONTINUE
  475.  
  476.  
  477. ENDIF
  478. SEGSUP MLENT1
  479. ENDIF
  480. C write(6,*)' Apres 34 '
  481.  
  482. C CAS Stabilisation via MACRO CENTREP1
  483. DEUPI=1.D0
  484. IF(IAXI.NE.0)DEUPI=2.D0*XPI
  485. IF(IKAS.EQ.3)DEUPI=-DEUPI
  486.  
  487. IF(MACRO1.NE.0.AND.IKAS.NE.2.AND.KPRE.EQ.4.AND.IDIM.EQ.2)THEN
  488. I2=2
  489. NBME=1
  490. NBSOUS=1
  491. SEGINI IMATRI
  492. IRIGEL(4,i2)=IMATRI
  493. KSPGP=MELEMC
  494. KSPGD=MELEMC
  495. IRIGEL(1,i2)=MELEMP
  496. IRIGEL(2,i2)=MELEMP
  497. IRIGEL(7,i2)=0
  498.  
  499. SEGACT MELEMP
  500. NBSOUS=MELEMP.LISOUS(/1)
  501. IF(NBSOUS.NE.0)THEN
  502. CALL ERREUR(5)
  503. ENDIF
  504.  
  505. SEGACT MELEMI
  506. NBSOUM=MELEMI.LISOUS(/1)
  507. IF(NBSOUM.EQ.0)NBSOUM=1
  508.  
  509. NBEL=MELEMP.NUM(/2)
  510. NP =MELEMP.NUM(/1)
  511. MP =NP
  512. NOM0=NOMS(MELEMP.ITYPEL)//' '
  513.  
  514. SEGINI IZAFM
  515. LIZAFM(1,1)=IZAFM
  516. LISPRI(1)=NOMD
  517. LISDUA(1)=NOMD
  518.  
  519. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  520.  
  521. SEGACT IZFFM*MOD
  522. IZHR=KZHR(1)
  523. SEGACT IZHR*MOD
  524. NES=GR(/1)
  525. NPG=GR(/3)
  526.  
  527. NK=0
  528. DO 430 LM=1,NBSOUM
  529. IPT1=MELEMI
  530. IF(NBSOUM.NE.1)IPT1=MELEMI.LISOUS(LM)
  531. SEGACT IPT1
  532. ITYP=IPT1.ITYPEL
  533. BETA=0.D0
  534. IF(NOMS(ITYP).EQ.'TRI6')BETA=BETA0
  535. C write(6,*)' NOMS(ITYP)=',NOMS(ITYP),BETA
  536. NBEL=IPT1.NUM(/2)
  537.  
  538. C Cas coefficient FLOTTANT ou CENTRE
  539. IF(IK1.LT.4)THEN
  540. DO 43 KK=1,NBEL
  541. NK=NK+1
  542. DO I=1,NP
  543. J=MELEMP.NUM(I,NK)
  544. DO N=1,IDIM
  545. XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N)
  546. ENDDO
  547. ENDDO
  548.  
  549. CALL CALJBR
  550. &(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  551. KC=1+(1-IK1)*(NK-1)
  552.  
  553. DO I=1,NP
  554. DO J=1,NP
  555. U=0.D0
  556. DO 433 L=1,NPG
  557. UH=0.D0
  558. DO 4333 KH=1,IDIM
  559. UH=UH+HR(KH,J,L)*HR(KH,I,L)
  560. 4333 CONTINUE
  561. U=U-UH*PGSQ(L)*DEUPI*BETA*IZTGG1.VPOCHA(KC,1)
  562. 433 CONTINUE
  563. AM(NK,I,J)=U
  564. ENDDO
  565. ENDDO
  566.  
  567. 43 CONTINUE
  568.  
  569. ELSEIF(IK1.EQ.4.OR.IK1.EQ.5)THEN
  570. C Cas coefficient SOMMET
  571.  
  572. DO 45 KK=1,NBEL
  573. NK=NK+1
  574. DO I=1,NP
  575. J=MELEMP.NUM(I,NK)
  576. DO N=1,IDIM
  577. XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N)
  578. ENDDO
  579. ENDDO
  580.  
  581. CALL CALJBR
  582. &(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE,AJ,SGN)
  583.  
  584. DO I=1,NP
  585. DO J=1,NP
  586. U=0.D0
  587. DO 453 L=1,NPG
  588. UH=0.D0
  589. DO 4533 KH=1,IDIM
  590. UH=UH+HR(KH,J,L)*HR(KH,I,L)
  591. 4533 CONTINUE
  592.  
  593. UA=0.D0
  594. DO JJ=1,NP
  595. J1=LECT(IPT1.NUM(JJ,NK))
  596. DO KH=1,IDIM
  597. KG=(IK1-4)*(KH-1)+1
  598. UA=UA+FN(JJ,L)*IZTGG1.VPOCHA(J1,KG)
  599. ENDDO
  600. ENDDO
  601. UA=UA/KG
  602.  
  603. U=U-UH*PGSQ(L)*DEUPI*BETA*UA
  604. 453 CONTINUE
  605. AM(NK,I,J)=U
  606. ENDDO
  607. ENDDO
  608.  
  609. 45 CONTINUE
  610. ENDIF
  611.  
  612. SEGDES IPT1
  613. 430 CONTINUE
  614.  
  615. ENDIF
  616. C Fin Stabilisation de toutes sortes
  617. C write(6,*)'C Fin Stabilisation de toutes sortes'
  618.  
  619. NBME=IDIM
  620. CALL KRIPAD(MELEMI,MLENTI1)
  621. SEGACT MELEMI
  622. NBSOUS=MELEMI.LISOUS(/1)
  623. IF(NBSOUS.EQ.0)NBSOUS=1
  624. SEGINI IMATRI
  625.  
  626. IF(IKAS.EQ.2)THEN
  627. KSPGD=MELEMS
  628. KSPGP=MELEMC
  629. IRIGEL(2,1)=MELEMI
  630. IRIGEL(1,1)=MELEMP
  631. ELSE
  632. KSPGP=MELEMS
  633. KSPGD=MELEMC
  634. IRIGEL(1,1)=MELEMI
  635. IRIGEL(2,1)=MELEMP
  636. ENDIF
  637. SEGACT MELEMP
  638.  
  639. C write(6,*)' ds kmac melemp=',IRIGEL(1,1)
  640. C write(6,*)' ds kmac melemd=',IRIGEL(2,1)
  641.  
  642. IRIGEL(4,1)=IMATRI
  643. * GBM modifie le 22 nov 99 pour pas de multipl de lagrange
  644. IF(IKAS.EQ.1)IRIGEL(7,1)=3
  645. IF(IKAS.EQ.2)IRIGEL(7,1)=3
  646. IF(IKAS.EQ.3)IRIGEL(7,1)=4
  647.  
  648. SEGACT MELEMP
  649. NBSOUC=MELEMP.LISOUS(/1)
  650. IF(NBSOUC.EQ.0)NBSOUC=1
  651. C write(6,*)'NBSOUS,NBSOUC=',NBSOUS,NBSOUC
  652.  
  653. K0=0
  654. DO 11 L=1,NBSOUS
  655. IPT1=MELEMI
  656. IPT2=MELEMP
  657. IF(NBSOUS.NE.1)IPT1=MELEMI.LISOUS(L)
  658. IF(NBSOUC.NE.1)IPT2=MELEMP.LISOUS(L)
  659. SEGACT IPT1,IPT2
  660. NBEL=IPT1.NUM(/2)
  661.  
  662. IF(IKAS.EQ.2)THEN
  663. MP=IPT1.NUM(/1)
  664. C avt NP=MELEMP.NUM(/1)
  665. NP=IPT2.NUM(/1)
  666. ELSE
  667. NP=IPT1.NUM(/1)
  668. C avt MP=MELEMP.NUM(/1)
  669. MP=IPT2.NUM(/1)
  670. ENDIF
  671.  
  672. DO 12 I=1,NBME
  673. SEGINI IZAFM
  674. LIZAFM(L,I)=IZAFM
  675. IF(IKAS.EQ.2)THEN
  676. WRITE(NOM,FMT='(I1,A3)')I,NOMD(1:3)
  677. LISDUA(I)=NOM//' '
  678. LISPRI(I)=NOMP
  679. ELSE
  680. WRITE(NOM,FMT='(I1,A3)')I,NOMP(1:3)
  681. LISPRI(I)=NOM//' '
  682. LISDUA(I)=NOMD
  683. ENDIF
  684. 12 CONTINUE
  685. IPM1=LIZAFM(L,1)
  686. IPM2=LIZAFM(L,2)
  687. IPM3=LIZAFM(L,2)
  688. IF(IDIM.EQ.3)IPM3=LIZAFM(L,3)
  689.  
  690. IF(IK1.LT.4)THEN
  691. C write(6,*)' Appel KPRUSS'
  692. CALL KPRUSS(IPT1,IPT2,
  693. &IPM1,IPM2,IPM3,IAXI,IKAS,INEFMD,KPRE,IZTGG1,IK1,K0,IKOMP)
  694. C write(6,*)'Retour KPRUSS'
  695. ELSE
  696. C write(6,*)' Appel KPRJSS'
  697. CALL KPRJSS(IPT1,IPT2,IPM1,IPM2,IPM3,
  698. & IAXI,IKAS,INEFMD,KPRE,IZTGG1,MLENTI,IK1,IKOMP)
  699. ENDIF
  700.  
  701. K0=K0+NBEL
  702. SEGDES IPM1,IPM2,IPM3
  703. SEGDES IPT1
  704. 11 CONTINUE
  705. SEGDES MELEMI
  706. IF(IK1.EQ.4)SEGSUP MLENTI
  707.  
  708.  
  709. C%%%%%%%%%%%%%%%%% CAS DES PRESSIONS CONTINUES %%%%%%%%%%%%%%%%%%%%%%%
  710.  
  711.  
  712. IF(KPRE.EQ.5)THEN
  713. CALL LEKTAB(MTABZ,'MMAIL',MELEME)
  714. CALL LEKTAB(MTABZ,'MSOMMET',MELEMS)
  715.  
  716. SEGACT MELEME
  717. NBSOU1=LISOUS(/1)
  718. IF(NBSOU1.EQ.0)NBSOU1=1
  719.  
  720. IRIGEL(1,2)=MELEME
  721. IRIGEL(2,2)=MELEME
  722. IRIGEL(7,2)=0
  723.  
  724. c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  725.  
  726. IHV=0
  727. AIMPL=1.D0
  728.  
  729. C --- CALCUL DU NOMBRE DE PAQUETS DE LRV ELEMENTS ---
  730. CALL KPLRVM(MELEME,LRV,NBSOUS)
  731. NBME=1
  732.  
  733. SEGINI IMATRI
  734. IRIGEL(4,2)=IMATRI
  735. KSPGP=MELEMS
  736. KSPGD=MELEMS
  737. LISPRI(1)=NOMD//' '
  738. LISDUA(1)=NOMD//' '
  739.  
  740. LL=0
  741. NUTOEL=0
  742. DO 101 L=1,NBSOU1
  743. IPT1=MELEME
  744. IF(NBSOU1.NE.1)IPT1=LISOUS(L)
  745. SEGACT IPT1
  746. NOM0=NOMS(IPT1.ITYPEL)//' '
  747. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  748. SEGACT IZFFM*MOD
  749. IZHR=KZHR(1)
  750. SEGACT IZHR*MOD
  751. NES=GR(/1)
  752. NPG=GR(/3)
  753.  
  754. NP = IPT1.NUM(/1)
  755. MP = NP
  756. NBELEM=IPT1.NUM(/2)
  757.  
  758. NNN=MOD(NBELEM,LRV)
  759. IF(NNN.EQ.0) NPACK=NBELEM/LRV
  760. IF(NNN.NE.0) NPACK=1+(NBELEM-NNN)/LRV
  761.  
  762. DO 701 KPACK=1,NPACK
  763.  
  764. C --- POUR CHAQUE PAQUET DE LRV ELEMENTS ou moins
  765. KDEB=1+(KPACK-1)*LRV
  766. KFIN=MIN(NBELEM,KDEB+LRV-1)
  767.  
  768. NBEL=KFIN-KDEB+1
  769. LL=LL+1
  770.  
  771. SEGINI IPM1,IPS1
  772. C write(6,*)' IPM1,LL=',IPM1,LL
  773. LIZAFM(LL,1)=IPM1
  774.  
  775. IPM2=IPM1
  776. IPM3=IPM1
  777. IPS2=IPS1
  778. IPS3=IPS1
  779.  
  780. KITT=2
  781. KJTT=IK1
  782. VISCO=IZTGG1
  783. CALL INITD(VISC,3,1.D0)
  784.  
  785. CALL XLAPL(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,
  786. & VISC,VISC,VISC,KITT,KJTT,IK1,
  787. & IPT1.NUM(1,KDEB),NBEL,NUTOEL,XCOOR,AIMPL,IKOMP,
  788. & IPM1.AM,IPM2.AM,IPM3.AM,
  789. & IPS1.AM,IPS2.AM,IPS3.AM,
  790. & NINKO,IHV,IARG,VISC)
  791.  
  792. NUTOEL=NUTOEL+NBEL
  793. SEGDES IPM1
  794.  
  795. 701 CONTINUE
  796. SEGDES IPT1
  797. 101 CONTINUE
  798.  
  799.  
  800.  
  801.  
  802.  
  803.  
  804. c%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  805.  
  806. ENDIF
  807.  
  808. CALL ECROBJ('MATRIK',MATRIK)
  809.  
  810. NAT=2
  811. NSOUPO=0
  812. SEGINI MCHPOI
  813. JATTRI(1)=2
  814. CALL ECROBJ('CHPOINT',MCHPOI)
  815.  
  816. C write(6,*)' Fin operateur KMIC'
  817. SEGDES IMATRI,MATRIK
  818. RETURN
  819. 1001 FORMAT(20(1X,I5))
  820. 1002 FORMAT(10(1X,1PE11.4))
  821. END
  822.  
  823.  
  824.  
  825.  
  826.  
  827.  
  828.  
  829.  
  830.  
  831.  
  832.  
  833.  
  834.  
  835.  
  836.  
  837.  
  838.  
  839.  
  840.  

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