Télécharger konv.eso

Retour à la liste

Numérotation des lignes :

  1. C KONV SOURCE MAGN 17/02/24 21:15:17 9323
  2. SUBROUTINE KONV
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C***********************************************************************
  6. C
  7. C CET OPERATEUR DISCRETISE LE TERME DE TRANSPORT
  8. C EN 2D SUR LES ELEMENTS QUA4 ET TRI3 PLAN OU AXI
  9. C EN 3D SUR LES ELEMENTS CUB8 ET PRI6
  10. C EN 0D SUR LES ELEMENTS POI1
  11. C
  12. C EN VOLUMES FINIS, DISCRETISATION DES EQUATIONS D'EULERS
  13. C
  14. C
  15. C SYNTAXE :
  16. C ---------
  17. C
  18. C KONV RO UN <MU> INCO TN :
  19. C
  20. C COEFFICIENTS :
  21. C --------------
  22. C
  23. C
  24. C ALF (SCAL DOMA) DIFFUSIVITE THERMIQUE
  25. C (SCAL ELEM)
  26. C
  27. C INCONNUES :
  28. C -----------
  29. C
  30. C TN CHAMP DE TEMPERATURE
  31. C
  32. C************************************************************************
  33.  
  34. -INC CCVQUA4
  35. -INC CCOPTIO
  36. -INC CCGEOME
  37. -INC SMCOORD
  38. -INC SMLENTI
  39. POINTEUR IZIPAD.MLENTI,IPADI.MLENTI,IPADS.MLENTI,IPADU.MLENTI
  40. -INC SMELEME
  41. POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEMI.MELEME
  42. POINTEUR MELEMA.MELEME,MELEMF.MELEME
  43. -INC SMCHAML
  44. -INC SMCHPOI
  45. POINTEUR MCHPIN.MCHPOI
  46. POINTEUR MZUN.MPOVAL,MZUN2.MPOVAL,MZMU.MPOVAL
  47. POINTEUR MZDT.MPOVAL,MZPHI.MPOVAL
  48. POINTEUR MRO.MCHPOI,MZRO.MPOVAL
  49. POINTEUR IZTG2.MCHPOI,IZTG3.MCHPOI
  50. POINTEUR IZTGG2.MPOVAL,IZTGG3.MPOVAL
  51. POINTEUR IZTU1.MPOVAL,IZTU2.MPOVAL,IZTU3.MPOVAL,IZTU4.MPOVAL
  52. POINTEUR IZTG5.MPOVAL
  53. POINTEUR IZVOL.MPOVAL,IZTCO.MPOVAL,IZDIAE.MPOVAL,IZTDI.MPOVAL
  54.  
  55. -INC SIZFFB
  56. PARAMETER (LRV=64)
  57. SEGMENT PETROV
  58. REAL*8 WT(LRV,NP,NPG,KDIM),WS(LRV,NP,NPG,KDIM),HK(LRV,IDIM,NP,NPG)
  59. REAL*8 UIL(LRV,IDIM,NPG),DUIL(LRV,IDIM,NPG)
  60. REAL*8 PGSK(LRV,NPG),RPGK(LRV,NPG),AIRE(LRV),ANUK(LRV),COEFK(LRV)
  61. REAL*8 AJK(LRV,IDIM,IDIM,NPG)
  62. ENDSEGMENT
  63.  
  64. POINTEUR IPM.IZAFM
  65.  
  66. SEGMENT IMATRS
  67. INTEGER LIZAFS(NBSOUS,NBME)
  68. ENDSEGMENT
  69. POINTEUR IPS1.IZAFM,IPS2.IZAFM,IPS3.IZAFM,IPMS.IZAFM
  70.  
  71. -INC SMTABLE
  72. POINTEUR KIZG.TABLE,MTABX.MTABLE,MTABT.MTABLE
  73. POINTEUR KINC.TABLE,RESU.MTABLE
  74. POINTEUR MTABZ.MTABLE
  75. -INC SMLMOTS
  76. POINTEUR LINCO.MLMOTS
  77. CHARACTER*8 NOMZ,NOMI,NOMA,TYPE,CHAI,TYPC,TYPCFI,NOM
  78. CHARACTER*8 NOM0,NOMII,MTYP,NMACO
  79. CHARACTER*4 NOM4(3), CELCAR
  80. REAL*8 XYZI(24)
  81. LOGICAL LOGI
  82. PARAMETER (NTB=2)
  83. CHARACTER*8 LTAB(NTB)
  84. DIMENSION KTAB(NTB),IXV(3)
  85. * save ipas
  86. * data ipas/1/
  87. C
  88. C**** EN VOLUMES FINIS, KONV est un operatéur normal,
  89. C (voir KONV1)
  90. C i.e.
  91. C
  92. C JACO RESI DELTAT = 'KONV' 'VF' ...
  93. C
  94. C*****************************************************************************
  95.  
  96. CKONV
  97. C WRITE(6,*)' Opérateur KONV'
  98. C
  99. C*****************************************************************************
  100. C
  101. C Deux traitements différents suivant la discrétisation 2D/3D ou 0D
  102. C (respectivement, table d'entrée de soustype KIZX
  103. C ou de soustype OPER_0D)
  104. C
  105.  
  106.  
  107. C Nouvelle directive EQUA de EQEX
  108. MTYP=' '
  109. CALL QUETYP(MTYP,0,IRET)
  110. IF(IRET.EQ.0)THEN
  111. C% On attend un des objets : %m1:8 %m9:16 %m17:24 %m25:32 %m33:40
  112. MOTERR( 1: 8) = 'CHAI '
  113. MOTERR( 9:16) = 'MMODEL '
  114. C MOTERR(17:24) = 'TABLE '
  115. CALL ERREUR(472)
  116. RETURN
  117. ENDIF
  118.  
  119. IF(MTYP.EQ.'MMODEL')THEN
  120. CALL LIRCHA(CHAI,1,IRET)
  121. IF(CHAI.EQ. 'VF ')THEN
  122. CALL KONV1
  123. GOTO 9999
  124. ENDIF
  125. CALL YTCLSF(' C ','KONV ')
  126. RETURN
  127. ELSEIF(MTYP.EQ.'MOT ')THEN
  128. CALL LIRCHA(CHAI,1,IRET)
  129. IF(CHAI.EQ. 'VF ')THEN
  130. CALL KONV1
  131. GOTO 9999
  132. ELSE
  133. CALL YTCLSF(CHAI,'KONV ')
  134. ENDIF
  135. RETURN
  136. ENDIF
  137. C Fin Nouvelle directive EQUA de EQEX
  138.  
  139.  
  140.  
  141. LTAB(1) = 'KIZX '
  142. LTAB(2) = 'OPER_0D '
  143. KTAB(1) = 0
  144. KTAB(2) = 0
  145. CALL LITABS(LTAB,KTAB,NTB,0,IRET)
  146. IF(IRET.EQ.0)THEN
  147. WRITE(6,*)' Opérateur KONV :'
  148. WRITE(6,*)' On attend un ensemble de table soustypes'
  149. RETURN
  150. ENDIF
  151. C
  152. C Bifurcation en cas de discrétisation 0D
  153. C
  154. IF (KTAB(1).NE.0) THEN
  155. MTABX = KTAB(1)
  156.  
  157. CALL LEKTAB(MTABX,'EQEX',MTAB1)
  158. IF(MTAB1.EQ.0)THEN
  159. WRITE(6,*)' Opérateur KONV :'
  160. WRITE(6,*)' On ne trouve pas l''indice EQEX ? '
  161. RETURN
  162. ENDIF
  163. CALL ACME(MTAB1,'NAVISTOK',NASTOK)
  164. IF(NASTOK.EQ.0)THEN
  165. CALL ZKONV(MTABX,MTAB1)
  166. RETURN
  167. ENDIF
  168. ELSEIF (KTAB(2).NE.0) THEN
  169. IPTAB1 = KTAB(2)
  170. CALL TOCONV (IPTAB1)
  171. RETURN
  172. ELSE
  173. WRITE(6,*)' Opérateur KONV :'
  174. WRITE(6,*)' On attend une table de soustype KIZX ou OPER_0D'
  175. RETURN
  176. ENDIF
  177.  
  178.  
  179. C*****************************************************************************
  180. C Traitement des options
  181. C KIMPL = 0 -> EXPL 1 -> IMPL 2 -> CN
  182. C KFORM = 0 -> SI 1 -> EF 2 -> VF 3 -> EFMC
  183. C IDCEN = 0 -> rien 1 -> CENTREE 2 -> HU.BR 3 -> SUPG 4 -> T VISQ
  184.  
  185. C
  186. C- Récupération de la table des options KOPT (pointeur KOPTI)
  187. C
  188. CALL LEKTAB(MTABX,'KOPT',KOPTI)
  189. IF (KOPTI.EQ.0) THEN
  190. C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
  191. MOTERR( 1: 8) = ' KOPT '
  192. MOTERR( 9:16) = ' KOPT '
  193. MOTERR(17:24) = ' KIZX '
  194. CALL ERREUR(786)
  195. RETURN
  196. ENDIF
  197.  
  198. IAXI=0
  199. IF(IFOMOD.EQ.0)IAXI=2
  200.  
  201. KDIM=1
  202. CALL ACME(KOPTI,'IDCEN',IDCEN)
  203. IF(IDCEN.EQ.2)KDIM=IDIM
  204. CALL ACME(KOPTI,'IKOMP',IKOMP)
  205. CALL ACME(KOPTI,'KIMPL',KIMPL)
  206. CALL ACME(KOPTI,'KFORM',KFORM)
  207. CALL ACME(KOPTI,'ISCHT',ISCHT)
  208. CALL ACME(KOPTI,'IDIV',IDIV)
  209. CALL ACMF(KOPTI,'CMD',CMD)
  210. CALL ACME(KOPTI,'KMACO',KMACO)
  211. CALL ACMF(KOPTI,'AIMPL',AIMPL)
  212. AG=AIMPL
  213. AD=AIMPL-1.D0
  214. IF(ISCHT.EQ.2)THEN
  215. AG=1.D0
  216. AD=-1.D0
  217. ENDIF
  218. IF (IERR.NE.0) RETURN
  219.  
  220. C*****************************************************************************
  221. C*****************************************************************************
  222. C
  223. C ----- Cas d'un schéma Explicite en Volume Fini :
  224. C ----------------------------------------
  225. if (KIMPL .EQ. 0 .and. KFORM . EQ. 2) then
  226. call ckon(MTABX)
  227. RETURN
  228. ENDIF
  229. C*****************************************************************************
  230. C
  231. C- Récupération de la table DOMAINE associée au domaine local
  232. C
  233. CALL ACMM(MTABX,'NOMZONE',NOMZ)
  234.  
  235. MTYP='MMODEL'
  236. CALL QUETYP(MTYP,0,IRET)
  237. IF(IRET.EQ.1)THEN
  238. CALL LIROBJ('MMODEL',MMDZ,1,IRET)
  239. ELSE
  240. TYPE=' '
  241. CALL ACMO(MTABX,'DOMZ',TYPE,MMDZ)
  242. IF(TYPE.NE.'MMODEL')THEN
  243. C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24
  244. MOTERR( 1: 8) = ' DOMZ '
  245. MOTERR( 9:16) = ' DOMZ '
  246. MOTERR(17:24) = ' KIZX '
  247. CALL ERREUR(786)
  248. RETURN
  249. ENDIF
  250. ENDIF
  251.  
  252. C*****************************************************************************
  253. C
  254. C- Récupération de la table DOMAINE associée au domaine local
  255. C
  256.  
  257. C E/ MMODEL : Pointeur de la table contenant l'information cherchée
  258. C /S IPOINT : Pointeur sur la table DOMAINE
  259. C /S INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE
  260. C INEFMD=4 LINB
  261.  
  262. CALL LEKMOD(MMDZ,MTABZ,INEFMD)
  263.  
  264. CALL LEKTAB(MTABZ,'MAILLAGE',MELEME)
  265. CALL LEKTAB(MTABZ,'SOMMET',MELEMS)
  266. CALL LEKTAB(MTABZ,'CENTRE',MELEMC)
  267. IF (IERR.NE.0) RETURN
  268.  
  269. C*************************************************************************
  270. C VERIFICATIONS SUR LES INCONNUES
  271. C write(6,*)' Verification des inconnues '
  272.  
  273. TYPE='LISTMOTS'
  274. CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO)
  275. SEGACT LINCO
  276.  
  277. NBINC=LINCO.MOTS(/2)
  278. IF((NBINC.NE.1).AND.(KFORM.NE.3))THEN
  279. WRITE(6,*)' Opérateur KONV :'
  280. WRITE(6,*)'Nombre d''inconnues incorrecte : ',NBINC,' On attend 1'
  281. RETURN
  282. ENDIF
  283.  
  284. IF((NBINC.NE.2).AND.(KFORM.EQ.3))THEN
  285. WRITE(6,*)' Opérateur KONV :'
  286. WRITE(6,*)'Nombre d''inconnues incorrecte : ',NBINC,' On attend 2'
  287. RETURN
  288. ENDIF
  289.  
  290. NOMI=LINCO.MOTS(1)
  291.  
  292. IF (KFORM.EQ.3) NOMII=LINCO.MOTS(2)
  293.  
  294. CALL LEKTAB(MTAB1,'INCO',KINC)
  295. IF(KINC.EQ.0)THEN
  296. WRITE(6,*)' Opérateur KONV :'
  297. WRITE(6,*)'Il n''y a pas de table INCO ? ?.'
  298. RETURN
  299. ENDIF
  300.  
  301. TYPE=' '
  302. CALL ACMO(KINC,NOMI,TYPE,MCHPOI)
  303. IF(TYPE.NE.'CHPOINT ')THEN
  304. WRITE(6,*)' Opérateur KONV :'
  305. WRITE(6,*)' L objet CHPOINT ',NOMI,' n existe pas dans la table'
  306. RETURN
  307. ELSE
  308. CALL LICHTL(MCHPOI,IZTU1,TYPC,MELEMI)
  309. MCHPIN=MCHPOI
  310. IKT=0
  311. ENDIF
  312.  
  313. NINKO=IZTU1.VPOCHA(/2)
  314. NPTI = IZTU1.VPOCHA(/1)
  315. IF(NINKO.EQ.1)THEN
  316. WRITE(NOM4(1),FMT='(A4)')NOMI(1:4)
  317. ELSE
  318. DO 15 I=1,NINKO
  319. WRITE(NOM4(I),FMT='(I1,A3)')I,NOMI(1:3)
  320. 15 CONTINUE
  321. ENDIF
  322.  
  323. IF (KFORM.EQ.3) THEN
  324. TYPE=' '
  325. CALL ACMO(KINC,NOMII,TYPE,MCHPOI)
  326. IF(TYPE.NE.'CHPOINT ')THEN
  327. WRITE(6,*)' Opérateur KONV :'
  328. WRITE(6,*)' L objet CHPOINT ',NOMII,
  329. & ' n existe pas dans la table'
  330. RETURN
  331. ELSE
  332. CALL LICHTL(MCHPOI,IZTU2,TYPCFI,IGEOM0)
  333. MZPHI=IZTU2
  334. IKT=0
  335. ENDIF
  336. END IF
  337. C*****************************************************************************
  338. C Le domaine de definition est donne par le SPG de la premiere inconnue
  339. C Les inconnues suivantes devront posseder ce meme pointeur
  340. C On verifie que les points de la zone sont tous inclus dans ce SPG
  341.  
  342. CALL KRIPAD(MELEMI,IPADI)
  343. IPADS=IPADI
  344. NPTS=NPTI
  345. IF(MELEMI.NE.MELEMS)THEN
  346. CALL KRIPAD(MELEMS,IPADS)
  347. NPTS=MELEMS.NUM(/2)
  348. ENDIF
  349. IPADU=IPADI
  350. NPTU=NPTI
  351. * TC mise en commentaired des lignes suivantes car ipasn'est jamais =0
  352. * IF(IPAS.EQ.0)THEN
  353. * IF (KFORM.EQ.3) CALL KRIPAD(MELEMC,MLENT1)
  354. * CALL VERPAD(IPADI,MELEME,IRET)
  355. * IF(IRET.NE.0)THEN
  356. * WRITE(6,*)' Opérateur KONV'
  357. * WRITE(6,*)' La zone ',NOMZ,' n''est pas incluse dans le domaine'
  358. * IPAS=0
  359. * RETURN
  360. * ENDIF
  361. * ENDIF
  362.  
  363. C*****************************************************************************
  364.  
  365. IF(KFORM.NE.1)THEN
  366. C*****************************************************************************
  367. C Lecture du ou des coefficients
  368. C Type du coefficient :
  369. C IK1=0 CHPOINT IK1=1 scalaire IK1=2 vecteur
  370.  
  371. c write(6,*)' Opérateur KONV lecture des coefficients'
  372. CALL ACME(MTABX,'IARG',IARG)
  373. ICD=0
  374. IF(ISCHT.EQ.2)ICD=1
  375. IF((IARG.LT.(2+ICD).AND.IDCEN.EQ.1)
  376. &.OR.(IARG.LT.(3+ICD).AND.IDCEN.LT.4)
  377. &.OR.(IARG.LT.(4+ICD).AND.IDCEN.GE.4))THEN
  378. WRITE(6,*)' Opérateur KONV : option incompréssible '
  379. WRITE(6,*)' Nombre d''arguments incorrect : ',IARG
  380. WRITE(6,*)' On attend 2 ou plus suivant l''option'
  381. RETURN
  382. ENDIF
  383.  
  384. c write(6,*)' KONV IARG=',iarg,melemc
  385. C 1er coefficient Densité
  386. IXV(1)=MELEMC
  387. IXV(2)=1
  388. IXV(3)=0
  389. CALL LEKCOF('Opérateur KONV :',
  390. & MTABX,KINC,1,IXV,MRO,MZRO,NPT1,NC1,IKR,IRET)
  391. IF(IRET.EQ.0)GO TO 90
  392. c write(6,*)' Apres LEKCOF'
  393.  
  394. IZTGG2=MZRO
  395. IZTGG3=MZRO
  396.  
  397. C 2ème coefficient UN , champ de vitesse transportant
  398. IXV(1)=-MELEMS
  399. IXV(2)=0
  400. IXV(3)=1
  401. CALL LEKCOF('Opérateur KONV :',
  402. & MTABX,KINC,2,IXV,MUN,MZUN,NPTU,NC2,IKU,IRET)
  403. IF(IRET.EQ.0)GO TO 90
  404. IF(IKU.EQ.2)IKU=1
  405. IF(IPADS.EQ.0.AND.IKU.EQ.0)CALL KRIPAD(MELEMS,IPADS)
  406. IPADU=IPADS
  407.  
  408. IF(ISCHT.EQ.2)THEN
  409. C si ISCHT=2 TN-2 ou UN-2 , champ transporte au temps n-2
  410. IXV(1)=-MELEMS
  411. IF(NINKO.EQ.1)IXV(1)=MELEMS
  412. IXV(2)=0
  413. IXV(3)=1
  414. CALL LEKCOF('Opérateur KONV :',
  415. & MTABX,KINC,(2+ICD),IXV,MUN,MZUN2,NPTU,NC2,IKU,IRET)
  416. IF(IRET.EQ.0)GO TO 90
  417. IF(IKU.EQ.2)IKU=1
  418. IF(IPADS.EQ.0.AND.IKU.EQ.0)CALL KRIPAD(MELEMS,IPADS)
  419. IPADU=IPADS
  420. ENDIF
  421.  
  422. IF(IARG.GE.(3+ICD))THEN
  423. C 3ème coefficient viscosité
  424. IXV(1)=MELEMC
  425. IXV(2)=1
  426. IXV(3)=0
  427. CALL LEKCOF('Opérateur KONV :',
  428. & MTABX,KINC,(3+ICD),IXV,MMU,MZMU,NPT3,NC3,IKM,IRET)
  429. IF(IRET.EQ.0)GO TO 90
  430. ELSE
  431. CALL LEKTAB(MTABX,'ARGS3',MMU)
  432. CALL LICHTL(MMU,MZMU,TYPC,IGEOM0)
  433. MZMU.VPOCHA(1,1)=1.D0
  434. IKM=1
  435.  
  436. ENDIF
  437.  
  438. IF(IARG.EQ.(4+ICD))THEN
  439. C 4ème coefficient Dt
  440. IXV(1)=0
  441. IXV(2)=1
  442. IXV(3)=0
  443. CALL LEKCOF('Opérateur KONV :',
  444. & MTABX,KINC,(4+ICD),IXV,MDT,MZDT,NPT4,NC4,IKT,IRET)
  445. IF(IRET.EQ.0)RETURN
  446. DT=MZDT.VPOCHA(1,1)
  447. ELSE
  448. DT=0.D0
  449.  
  450. ENDIF
  451.  
  452. c write(6,*)' Opérateur KONV : Fin lecture Arguments '
  453. C Fin lecture Arguments ************************************************
  454. ENDIF
  455.  
  456.  
  457. C*************************************************************************
  458. IF(KFORM.EQ.0)THEN
  459. C CAS FORMULATION EF SI (GRESHO)
  460.  
  461. WRITE(6,*)' Operateur KONV '
  462. WRITE(6,*)' Option invalide '
  463. GO TO 90
  464. C*************************************************************************
  465. ELSEIF(KFORM.EQ.1)THEN
  466. C CAS FORMULATION EF
  467.  
  468. c write(6,*)' On va appeler YCLS '
  469. NINKO=IZTU1.VPOCHA(/2)
  470. IHV=0
  471. IF(NINKO.EQ.IDIM)IHV=1
  472.  
  473. CALL YCLS('KONV ',MTABX,MTABZ,IHV,MCHPIN,NOMI,MATRIK,MCHPO1)
  474.  
  475. CALL ECROBJ('MATRIK',MATRIK)
  476. CALL ECROBJ('CHPOINT',MCHPO1)
  477.  
  478. RETURN
  479. C*************************************************************************
  480. ELSE IF(KFORM.EQ.2)THEN
  481. C CAS FORMULATION VF
  482.  
  483. C CALL LEKTAB(MTABZ,'FACE',MELEMF)
  484. C CALL LEKTAB(MTABZ,'CENTRE',MELEMC)
  485. CALL LEKTAB(MTABZ,'FACEL',MFACEL)
  486. CALL LEKTAB(MTABZ,'ELTFA',MELTFA)
  487. CALL LEKTAB(MTABZ,'ELKONV',MELEME)
  488. C CALL ELCONV(MELTFA,MFACEL,MELEMF,MELEMC,MELEME)
  489.  
  490. SEGACT MELEME
  491. NBSOUS=LISOUS(/1)
  492. IF(NBSOUS.EQ.0)NBSOUS=1
  493.  
  494. NRIGE=7
  495. NKID =9
  496. NKMT =7
  497. NMATRI=1
  498. SEGINI MATRIK
  499. IRIGEL(1,1)=MELEME
  500. IRIGEL(2,1)=MELEMC
  501. IRIGEL(7,1)=2
  502. NBOP=0
  503. NBME=NINKO
  504. SEGINI IMATRI,IMATRS
  505. IRIGEL(4,1)=IMATRI
  506. KSPGP=MELEMC
  507. KSPGD=MELEMC
  508.  
  509. IF(NBME.EQ.1)THEN
  510. LISPRI(1)=NOMI(1:4)//' '
  511. LISDUA(1)=NOMI(1:4)//' '
  512. ELSE
  513. DO 202 I=1,NBME
  514. WRITE(NOM,FMT='(I1,A7)')I,NOMI(1:7)
  515. LISPRI(I)=NOM(1:4)//' '
  516. LISDUA(I)=NOM(1:4)//' '
  517. 202 CONTINUE
  518. ENDIF
  519.  
  520. C* Lecture du tableau donnant le sens des normales par element
  521. CALL LEKTAB(MTABZ,'XXNORMAE',MCHELM)
  522. IF(MCHELM.EQ.0)GO TO 90
  523. SEGACT MCHELM
  524. CALL LEKTAB(MTABZ,'XXSURFAC',MCHPO1)
  525. CALL LICHTL(MCHPO1,MPOVA1,TYPE,IGEOM)
  526. C* Lecture des connectivites elements/faces
  527. CALL LEKTAB(MTABZ,'ELTFA',MELEMA)
  528. IF(MELEMA.EQ.0)GO TO 90
  529. SEGACT MELEMA
  530. CALL KRIPAD(MELEMF,IPADI)
  531. IF(IKR.EQ.0)CALL KRIPAD(MELEMC,MLENT1)
  532.  
  533. KK=0
  534. DO 201 L=1,NBSOUS
  535. IPT1=MELEME
  536. IPT2=MELEMA
  537. IF(NBSOUS.NE.1)IPT1=LISOUS(L)
  538. IF(NBSOUS.NE.1)IPT2=MELEMA.LISOUS(L)
  539. SEGACT IPT1,IPT2
  540.  
  541. NP = IPT1.NUM(/1)
  542. NBF=NP-1
  543. MP = 1
  544. C write(6,*)' np,nbf,mp=',np,nbf,mp
  545. NBEL=IPT1.NUM(/2)
  546. SEGINI IPM1,IPMS
  547. LIZAFM(L,1)=IPM1
  548. LIZAFS(L,1)=IPMS
  549. IPM2=IPM1
  550. IPM3=IPM1
  551. IF(NBME.GE.2)THEN
  552. LIZAFM(L,2)=IPM1
  553. ENDIF
  554. IF(NBME.GE.3)THEN
  555. LIZAFM(L,3)=IPM1
  556. ENDIF
  557.  
  558. MCHAML=ICHAML(L)
  559. SEGACT MCHAML
  560. MELVAL=IELVAL(1)
  561. SEGACT MELVAL
  562.  
  563. C write(6,*)' IKR=',ikr
  564.  
  565. IF(IKR.EQ.1)THEN
  566. C write(6,*)' NBEL=',NBEL,' NBF=',NBF
  567. DO 210 K=1,NBEL
  568. DO 211 I=1,NBF
  569. NF=IPT2.NUM(I,K)
  570. NF=IPADI.LECT(NF)
  571. C write(6,*)' NF=',NF,NP
  572. FI=IZTGG2.VPOCHA(NF,1)*MELVAL.VELCHE(I,K)*MPOVA1.VPOCHA(NF,1)
  573. &*MZRO.VPOCHA(1,1)
  574. IF(FI.LE.0.D0)THEN
  575. IPM1.AM(K,I,1)=FI
  576. ELSE
  577. IPM1.AM(K,NP,1)=IPM1.AM(K,NP,1)+FI
  578. ENDIF
  579. 211 CONTINUE
  580. 210 CONTINUE
  581.  
  582. ELSEIF(IKR.EQ.0)THEN
  583.  
  584. DO 212 K=1,NBEL
  585. KK=KK+1
  586. DO 213 I=1,NBF
  587. NF=IPT2.NUM(I,K)
  588. NF=IPADI.LECT(NF)
  589. NCR=MLENT1.LECT(KK)
  590. FI=IZTGG2.VPOCHA(NF,1)*MELVAL.VELCHE(I,K)*MPOVA1.VPOCHA(NF,1)
  591. &*MZRO.VPOCHA(NCR,1)
  592. IF(FI.LE.0.D0)THEN
  593. IPM1.AM(K,I,1)=FI
  594. ELSE
  595. IPM1.AM(K,NP,1)=IPM1.AM(K,NP,1)+FI
  596. ENDIF
  597. 213 CONTINUE
  598. 212 CONTINUE
  599.  
  600.  
  601. ENDIF
  602.  
  603.  
  604.  
  605. SEGDES IPT1,IPM1,IPT2
  606. SEGSUP IPMS
  607. C write(6,*)' Fin bcl 201 '
  608. 201 CONTINUE
  609. C write(6,*)' Apr bcl 201 '
  610. SEGSUP IPADI
  611. SEGDES IMATRI
  612. SEGSUP IMATRS
  613. SEGDES MELEME,MATRIK
  614.  
  615. IF(IKR.EQ.0)THEN
  616. SEGSUP MLENT1
  617. SEGDES MRO,MZRO
  618. ENDIF
  619.  
  620. CALL ECMO(MTABX,'MATELM','MATRIK',MATRIK)
  621.  
  622. RETURN
  623. C************************************************************************
  624. ENDIF
  625. C*************************************************************************
  626.  
  627. 90 CONTINUE
  628. WRITE(6,*)' Interuption anormale de KONV'
  629. 9999 RETURN
  630. END
  631.  
  632.  
  633.  
  634.  
  635.  
  636.  
  637.  
  638.  
  639.  
  640.  
  641.  
  642.  
  643.  
  644.  
  645.  
  646.  
  647.  
  648.  
  649.  
  650.  
  651.  
  652.  
  653.  
  654.  
  655.  
  656.  
  657.  
  658.  
  659.  
  660.  
  661.  
  662.  
  663.  

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