Télécharger fiss.eso

Retour à la liste

Numérotation des lignes :

  1. C FISS SOURCE CB215821 19/08/01 21:15:56 10279
  2. SUBROUTINE FISS
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C__________________________________________________________________
  6. C operateur FUITE:
  7. C Calcul du debit air-vapeur dans une fissure plane
  8. C
  9. C
  10. C__________________________________________________________________
  11. -INC CCOPTIO
  12. -INC SMELEME
  13. -INC SMCHAML
  14. -INC SMCOORD
  15. -INC SMCHPOI
  16. -INC SMLENTI
  17. -INC SMMODEL
  18. -INC SMTABLE
  19. C
  20. SEGMENT MAVAL
  21. REAL*8 VAL(NVAL)
  22. ENDSEGMENT
  23. C
  24. SEGMENT PTRAV1
  25. INTEGER KASN(NNPT),KG(NNPT)
  26. REAL*8 XNC(NNPT),TP(NNPT),EP(NNPT),BP(NNPT)
  27. ENDSEGMENT
  28. SEGMENT PTRAV2
  29. REAL*8 XX(NMX)
  30. REAL*8 XP(NMX),XPV(NMX),XT(NMX),XY(NMX),XU(NMX)
  31. REAL*8 XQ(NMX),XQA(NMX),XQW(NMX),XHF(NMX),XRE(NMX),XDH(NMX)
  32. REAL*8 ZP(NNPT),ZPV(NNPT),ZT(NNPT),ZY(NNPT),ZU(NNPT)
  33. REAL*8 ZQ(NNPT),ZQA(NNPT),ZQW(NNPT),ZHF(NNPT),ZRE(NNPT),ZDH(NMX)
  34. REAL*8 ZTRA(NNPT)
  35. ENDSEGMENT
  36. C
  37. INTEGER GPARF
  38. CHARACTER*8 CMATE
  39. CHARACTER*12 CMAT1,CMAT2,CMAT3
  40. CHARACTER*(NCONCH) CONM
  41. CHARACTER*8 MOTCLE,MCO1,MCO2,MCO3,MCO4,NOM
  42. CHARACTER*8 MOT
  43. REAL*8 VALCL(5)
  44. POINTEUR MCHMAT.MCHELM
  45. POINTEUR PCHMAT.MCHAML
  46. POINTEUR DCHMAT.MELVAL
  47. POINTEUR PCOMP.MAVAL
  48. C
  49. CHARACTER*10 MOALIR
  50. CHARACTER*8 TYPOBJ
  51. CHARACTER*28 MOTTAB
  52. CHARACTER*72 CHARRE
  53. LOGICAL LOGIN,LOGRE
  54. REAL*8 XVALIN,XVALRE
  55. C
  56. TYPOBJ=' '
  57. KIMP=IIMPI
  58. QINI = -1.
  59. C***********************************************************************
  60. C lecture obligatoire de l objet modele
  61. C
  62. IPMODL=0
  63. CALL LIROBJ('MMODEL ',IPMODL,1,IRET)
  64. CALL ACTOBJ('MMODEL ',IPMODL,1)
  65. IF (IERR.NE.0) RETURN
  66. C
  67. C***********************************************************************
  68. C lecture obligatoire du champ de proprietes materielles
  69. C
  70. IPCHA1 = 0
  71. CALL LIROBJ('MCHAML ',IPIN,1,IRET1)
  72. CALL ACTOBJ('MCHAML ',IPIN,1)
  73. IF (IERR.NE.0) RETURN
  74. CALL REDUAF(IPIN,IPMODL,IPCHA1,0,IR,KER)
  75. IF(IR .NE. 1) CALL ERREUR(KER)
  76. IF(IERR .NE. 0) RETURN
  77.  
  78. C verification de l egalite des supports du modele et du ch prop mat
  79. call rayn1(IPMODL,IPCHA1)
  80. C
  81. C***********************************************************************
  82. C lecture obligatoire de la table des conditions aux limites
  83. C
  84. IPCHE3 = 0
  85. IPCHA2 = 0
  86. IPCHA3 = 0
  87. IPCHA4 = 0
  88. CALL LIROBJ('TABLE ',IPTAB,1,IRETOU)
  89. IF(IERR.NE.0) RETURN
  90. MTABLE = IPTAB
  91. SEGACT MTABLE
  92. NDIMTAB = MLOTAB
  93. C
  94. MOTTAB='PRESSION_TOTALE_AMONT'
  95. CALL ACCTAB(IPTAB,'MOT ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  96. . TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  97. PE = XVALRE
  98. MOTTAB='PRESSION_VAPEUR_AMONT'
  99. CALL ACCTAB(IPTAB,'MOT ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  100. . TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  101. PVE = XVALRE
  102. MOTTAB='TEMPERATURE_AMONT'
  103. CALL ACCTAB(IPTAB,'MOT ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  104. . TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  105. TE = XVALRE
  106. MOTTAB='PRESSION_TOTALE_AVAL'
  107. CALL ACCTAB(IPTAB,'MOT ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  108. . TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  109. PS = XVALRE
  110. MOTTAB='TEMPERATURE_PAROI'
  111. TYPOBJ=' '
  112. CALL ACCTAB(IPTAB,'MOT ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  113. . TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHA2)
  114. MOTTAB='OUVERTURE'
  115. TYPOBJ=' '
  116. CALL ACCTAB(IPTAB,'MOT ',IVALIN,XVALIN,MOTTAB,LOGIN,IOBIN,
  117. . TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHA3)
  118. *
  119. IF(NDIMTAB.EQ.7) THEN
  120. MOTTAB='DEBIT_INITIAL'
  121. TYPOBJ=' '
  122. CALL ACCTAB(IPTAB,'MOT ',IVALIN,XVALIN,MOTTAB,LOGIN,
  123. . IOBIN,TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  124. IF(TYPOBJ.EQ.'FLOTTANT') THEN
  125. QINI = XVALRE
  126. ELSE
  127. MOTTAB='ETENDUE'
  128. TYPOBJ=' '
  129. CALL ACCTAB(IPTAB,'MOT ',IVALIN,XVALIN,MOTTAB,LOGIN,
  130. . IOBIN,TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHA4)
  131. ENDIF
  132. ENDIF
  133. *
  134. IF(NDIMTAB.EQ.8) THEN
  135. MOTTAB='DEBIT_INITIAL'
  136. TYPOBJ=' '
  137. CALL ACCTAB(IPTAB,'MOT ',IVALIN,XVALIN,MOTTAB,LOGIN,
  138. . IOBIN,TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHE3)
  139. QINI = XVALRE
  140. MOTTAB='ETENDUE'
  141. TYPOBJ=' '
  142. CALL ACCTAB(IPTAB,'MOT ',IVALIN,XVALIN,MOTTAB,LOGIN,
  143. . IOBIN,TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPCHA4)
  144. ENDIF
  145. SEGDES MTABLE
  146. C***********************************************************************
  147. C ACTIVATION DU MODELE
  148. C --------------------
  149. MMODEL = IPMODL
  150. SEGACT MMODEL
  151. C NSOUS = KMODEL(/1)
  152.  
  153. IMODEL=KMODEL(1)
  154. SEGACT IMODEL
  155. C
  156. C initialisations
  157. IPMAIL= IMAMOD
  158. NFOR = FORMOD(/2)
  159. NMAT = MATMOD(/2)
  160. C
  161. C verification de la formulation
  162. CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  163. IF (CMATE.EQ.' ')THEN
  164. CALL ERREUR(251)
  165. IRET=0
  166. RETURN
  167. ENDIF
  168. C lecture de la formulation
  169. CMAT1 = CMATE(1:2)
  170. CMAT2 = CMATE(3:4)
  171. CMAT3 = CMATE(5:8)
  172. IF (CMAT1.EQ.'MA')THEN
  173. XW = 0.D0
  174. ELSE
  175. XW = 1.D0
  176. ENDIF
  177. IF (CMAT2.EQ.'PA')THEN
  178. GPARF = 1
  179. ELSE
  180. GPARF = 0
  181. ENDIF
  182. C
  183. C***********************************************************************
  184. C ACTIVATION DU MCHELM ch prop mat
  185. C --------------------
  186. MCHMAT = IPCHA1
  187. SEGACT MCHMAT
  188. C NBS = MCHMAT.IMACHE(/1)
  189. C pas de boucle sur les modeles elementaires car NSOUS=1
  190. C pas de boucle sur les maillages elementaires car NBS=1
  191. C initialilsations
  192. RUG = 0.
  193. C lecture des prop materielles
  194. PCHMAT = MCHMAT.ICHAML(1)
  195. SEGACT PCHMAT
  196. NBS2 = PCHMAT.IELVAL(/1)
  197. NVAL = NBS2
  198. SEGINI PCOMP
  199. C boucle sur le nb de composantes du ch prop mat
  200. DO 10 I =1,NBS2
  201. MOT = PCHMAT.NOMCHE(I)
  202. DCHMAT = PCHMAT.IELVAL(I)
  203. SEGACT DCHMAT
  204. C N1PTEL = DCHMAT.VELCHE(/1)
  205. C N1EL = DCHMAT.VELCHE(/2)
  206. PCOMP.VAL(I) = DCHMAT.VELCHE(1,1)
  207. IF(MOT.EQ.'RUGO') RUG = PCOMP.VAL(I)
  208. IF(MOT.EQ.'REC') RECU = PCOMP.VAL(I)
  209. IF(MOT.EQ.'FK') XKUL = PCOMP.VAL(I)
  210. IF(MOT.EQ.'FA') XKUT1 = PCOMP.VAL(I)
  211. IF(MOT.EQ.'FB') XKUT2 = PCOMP.VAL(I)
  212. IF(MOT.EQ.'FC') XKUT3 = PCOMP.VAL(I)
  213. IF(MOT.EQ.'FD') XKUT4 = PCOMP.VAL(I)
  214. 10 CONTINUE
  215.  
  216. IF (CMAT3.EQ.'BLAS') THEN
  217. RECU = -1D5
  218. XKUL = 0.
  219. XKUT1 = 0.
  220. XKUT2 = 0.
  221. XKUT3 = 0.
  222. XKUT4 = 0.
  223. ELSE IF (CMAT3.EQ.'COLE')THEN
  224. RECU = -1D5
  225. XKUL = 0.
  226. XKUT1 = 0.
  227. XKUT2 = 0.
  228. XKUT3 = 0.
  229. XKUT4 = 0.
  230. * ELSE IF (CMAT3.EQ.'ENT1')THEN
  231. * RECU = PCOMP.VAL(2)
  232. ELSE IF (CMAT3.EQ.'ENT2')THEN
  233. RECU =-1D0*RECU
  234. ELSE IF (CMAT3.EQ.'ENT3')THEN
  235. RECU = -1D6
  236. XKUT1 = 0.
  237. XKUT2 = 0.
  238. XKUT3 = 0.
  239. XKUT4 = 0.
  240. ELSE IF (CMAT3.EQ.'ENT4')THEN
  241. RECU = -1D7
  242. XKUT1 = 0.
  243. XKUT2 = 0.
  244. XKUT3 = 0.
  245. XKUT4 = 0.
  246. ENDIF
  247. SEGSUP PCOMP
  248. C
  249. C*********************************************************************
  250. C TRAITEMENT des 2 champs ep et tp
  251. C --------------------------------
  252. IPT2=IPMAIL
  253.  
  254. SEGACT IPT2
  255. NBSO = IPT2.LISOUS(/1)
  256. IF (NBSO.NE.0) THEN
  257. CALL ERREUR(25)
  258. RETURN
  259. ENDIF
  260. NEL = IPT2.NUM(/2)
  261.  
  262. NPT2 = IPT2.NUM(/1)
  263. IF (NPT2.NE.2) THEN
  264. CALL ERREUR(16)
  265. RETURN
  266. ENDIF
  267.  
  268. C segment de travail 1
  269.  
  270. NNPT = NEL + 1
  271. SEGINI PTRAV1
  272.  
  273. XNC(1)=0.D0
  274. KG(1)= IPT2.NUM(1,1)
  275.  
  276. C calcul des abscisses curvilignes
  277.  
  278. IF (IDIM.EQ.1) THEN
  279. DO I =1,NEL
  280. KG(I+1) = IPT2.NUM(2,I)
  281. IREF1 = (IDIM+1)*(IPT2.NUM(1,I)-1)
  282. IREF2 = (IDIM+1)*(IPT2.NUM(2,I)-1)
  283. DX1 = XCOOR(IREF2+1)-XCOOR(IREF1+1)
  284. XNC(I+1) = XNC(I) + DX1
  285. ENDDO
  286. ENDIF
  287. IF (IDIM.EQ.2) THEN
  288. DO I =1,NEL
  289. KG(I+1) = IPT2.NUM(2,I)
  290. IREF1 = (IDIM+1)*(IPT2.NUM(1,I)-1)
  291. IREF2 = (IDIM+1)*(IPT2.NUM(2,I)-1)
  292. DX1 = XCOOR(IREF2+1)-XCOOR(IREF1+1)
  293. DX2 = XCOOR(IREF2+2)-XCOOR(IREF1+2)
  294. DXC = SQRT(DX1*DX1+DX2*DX2)
  295. XNC(I+1) = XNC(I) + DXC
  296. ENDDO
  297. ENDIF
  298. IF (IDIM.EQ.3) THEN
  299. DO I =1,NEL
  300. KG(I+1) = IPT2.NUM(2,I)
  301. IREF1 = (IDIM+1)*(IPT2.NUM(1,I)-1)
  302. IREF2 = (IDIM+1)*(IPT2.NUM(2,I)-1)
  303. DX1 = XCOOR(IREF2+1)-XCOOR(IREF1+1)
  304. DX2 = XCOOR(IREF2+2)-XCOOR(IREF1+2)
  305. DX3 = XCOOR(IREF2+3)-XCOOR(IREF1+3)
  306. DXC = SQRT(DX1*DX1+DX2*DX2+DX3*DX3)
  307. XNC(I+1) = XNC(I) + DXC
  308. ENDDO
  309. ENDIF
  310. XL = XNC(NNPT)
  311. DO I =1,NNPT
  312. XNC(I)=XNC(I)/XL
  313. ENDDO
  314. * recherche du plus petit DX
  315. DXMINAV = 0.01
  316. DO I =1,NNPT-1
  317. DXNC = XNC(I+1)-XNC(I)
  318. DXMIN = MIN(DXNC,DXMINAV)
  319. DXMINAV = DXMIN
  320. ENDDO
  321. DX = DXMIN/5.D0
  322. IF(KIMP.GE.1) THEN
  323. WRITE(6,*) 'fiss : taille relative de maille fluide= ',DX
  324. ENDIF
  325.  
  326. * segment de travail 2
  327. NMX=3*INT(1.D0/DX)
  328. SEGINI PTRAV2
  329.  
  330. IF (KIMP.EQ.2) THEN
  331. WRITE(6,*) 'fiss : XL ',XL
  332. WRITE(6,*) (XNC(I),I=1,NNPT)
  333. WRITE(6,*) 'fiss : KG(I) = ',(KG(I),I=1,NNPT)
  334. ENDIF
  335.  
  336. C activation segment MCHPO1 (chpoint Temperature et ouverture)
  337. CALL FUCHPO(IPCHA2,IPCHA3,IRETOU)
  338. MCHPO1=IRETOU
  339. SEGACT MCHPO1
  340. NSOUPO = MCHPO1.IPCHP(/1)
  341.  
  342. IF(NSOUPO.NE.1) THEN
  343. CALL ERREUR(25)
  344. RETURN
  345. ENDIF
  346.  
  347. MSOUP1 = MCHPO1.IPCHP(1)
  348. SEGACT MSOUP1
  349. NC = MSOUP1.NOHARM(/1)
  350.  
  351. IF(NC.NE.2) THEN
  352. CALL ERREUR(21)
  353. RETURN
  354. ENDIF
  355.  
  356. IPT1 = MSOUP1.IGEOC
  357. CALL KRIPAD(IPT1,MLENT1)
  358. SEGACT IPT1, MLENT1
  359. C NTOT = MLENT1.LECT(/1)
  360.  
  361. MPOVA1 = MSOUP1.IPOVAL
  362.  
  363. SEGACT MPOVA1
  364. NNPT1 = MPOVA1.VPOCHA(/1)
  365. C
  366. IF (NNPT1.NE.NNPT) THEN
  367. CALL ERREUR(21)
  368. RETURN
  369. ENDIF
  370.  
  371. DO I = 1,NNPT
  372. KASN(I) = MLENT1.LECT(KG(I))
  373. ENDDO
  374.  
  375. C remplissage des tableaux classes
  376.  
  377. MCO1=MSOUP1.NOCOMP(1)
  378. MCO2=MSOUP1.NOCOMP(2)
  379. IF (MCO1.EQ.'T ') THEN
  380. IF (MCO2.EQ.'OUV ') THEN
  381. DO I=1,NNPT
  382. TP(I) = MPOVA1.VPOCHA(KASN(I),1)
  383. EP(I) = MPOVA1.VPOCHA(KASN(I),2)
  384. ENDDO
  385. ELSE
  386. MOTERR(1:4)= MCO2
  387. CALL ERREUR(197)
  388. RETURN
  389. ENDIF
  390. ELSEIF (MCO1.EQ.'OUV ') THEN
  391. IF (MCO2.EQ.'T ') THEN
  392. DO I=1,NNPT
  393. TP(I) = MPOVA1.VPOCHA(KASN(I),2)
  394. EP(I) = MPOVA1.VPOCHA(KASN(I),1)
  395. ENDDO
  396. ELSE
  397. MOTERR(1:4)= MCO2
  398. CALL ERREUR(197)
  399. RETURN
  400. ENDIF
  401. ELSE
  402. MOTERR(1:4)= MCO1
  403. CALL ERREUR(197)
  404. RETURN
  405. ENDIF
  406. IF (IIMPI.EQ.2) THEN
  407. write(6,*) 'fiss : TP= ',(TP(I),I=1,NNPT)
  408. write(6,*) 'fiss : EP= ',(EP(I),I=1,NNPT)
  409. ENDIF
  410. C cas etendue unite (champ d etendue non defini par utilisateur)
  411. IF (IPCHA4.EQ.0) THEN
  412. DO I=1,NNPT
  413. BP(I) = 1.
  414. ENDDO
  415. ENDIF
  416. C activation segment MCHPO2 (chpoint Temperature et etendue)
  417. IF (IPCHA4.GT.0) THEN
  418. CALL FUCHPO(IPCHA2,IPCHA4,IRETOU)
  419. MCHPO2=IRETOU
  420. SEGACT MCHPO2
  421. NSOUPO = MCHPO2.IPCHP(/1)
  422.  
  423. IF(NSOUPO.NE.1) THEN
  424. CALL ERREUR(25)
  425. RETURN
  426. ENDIF
  427.  
  428. MSOUP2 = MCHPO2.IPCHP(1)
  429. SEGACT MSOUP2
  430. NC = MSOUP2.NOHARM(/1)
  431.  
  432. IF(NC.NE.2) THEN
  433. CALL ERREUR(21)
  434. RETURN
  435. ENDIF
  436.  
  437. IPT2 = MSOUP2.IGEOC
  438. CALL KRIPAD(IPT2,MLENT1)
  439. SEGACT IPT2, MLENT1
  440. C NTOT = MLENT1.LECT(/1)
  441.  
  442. MPOVA2 = MSOUP2.IPOVAL
  443.  
  444. SEGACT MPOVA2
  445. NNPT1 = MPOVA2.VPOCHA(/1)
  446. C
  447. IF (NNPT1.NE.NNPT) THEN
  448. CALL ERREUR(21)
  449. RETURN
  450. ENDIF
  451.  
  452. DO I = 1,NNPT
  453. KASN(I) = MLENT1.LECT(KG(I))
  454. ENDDO
  455.  
  456. C remplissage des tableaux classes
  457.  
  458. MCO1=MSOUP2.NOCOMP(1)
  459. MCO2=MSOUP2.NOCOMP(2)
  460. IF (MCO1.EQ.'T ') THEN
  461. IF (MCO2.EQ.'ETEN') THEN
  462. DO I=1,NNPT
  463. TP(I) = MPOVA2.VPOCHA(KASN(I),1)
  464. BP(I) = MPOVA2.VPOCHA(KASN(I),2)
  465. ENDDO
  466. ELSE
  467. MOTERR(1:4)= MCO2
  468. CALL ERREUR(197)
  469. RETURN
  470. ENDIF
  471. ELSEIF (MCO1.EQ.'ETEN') THEN
  472. IF (MCO2.EQ.'T ') THEN
  473. DO I=1,NNPT
  474. TP(I) = MPOVA2.VPOCHA(KASN(I),2)
  475. BP(I) = MPOVA2.VPOCHA(KASN(I),1)
  476. ENDDO
  477. ELSE
  478. MOTERR(1:4)= MCO2
  479. CALL ERREUR(197)
  480. RETURN
  481. ENDIF
  482. ELSE
  483. MOTERR(1:4)= MCO1
  484. CALL ERREUR(197)
  485. RETURN
  486. ENDIF
  487. IF (IIMPI.EQ.2) THEN
  488. write(6,*) 'fiss : BP= ',(BP(I),I=1,NNPT)
  489. ENDIF
  490. ENDIF
  491.  
  492. C compatibilite de la loi de frottement avec la valeur de rugosite
  493. DO I=1,NNPT
  494. RUGD = RUG/(2.*EP(I))
  495. IF (RUGD.GE.1e-4.AND.MATMOD(3).EQ.'POISEU_BLASIUS') THEN
  496. MOTERR(1:12)= 'RUGO/2e'
  497. REAERR(1) = RUGD
  498. REAERR(2) = 0.0001
  499. C %m1:18 = %r1 superieur a %r2
  500. CALL ERREUR(43)
  501. RETURN
  502. ENDIF
  503. IF (RUGD.LT.1e-4.AND.MATMOD(3).EQ.'POISEU_COLEBROOK') THEN
  504. MOTERR(1:18)= 'RUGO/2e'
  505. REAERR(1) = RUGD
  506. REAERR(2) = 0.0001
  507. C %m1:18 = %r1 inferieur a %r2
  508. CALL ERREUR(41)
  509. RETURN
  510. ENDIF
  511. ENDDO
  512. C
  513. C***********************************************************************
  514. C CALCUL
  515. C ------
  516.  
  517. IF (GPARF.EQ.1) THEN
  518.  
  519. CALL BECALC(PE,PVE,TE,PS,XL,DX,RUG,QINI,XW,NNPT,XNC,TP,EP,BP,
  520. $ KIMP,NMX,NX,XX,XP,XPV,XT,XY,XU,XHF,XQ,XQW,XQA,XRE,XDH,RECU,
  521. $ XKUL,XKUT1,XKUT2,XKUT3,XKUT4)
  522. IF (IERR.NE.0) RETURN
  523.  
  524. ELSE
  525. CALL BECALC2(PE,PVE,TE,PS,XL,DX,RUG,QINI,XW,NNPT,XNC,TP,EP,BP,
  526. $ KIMP,NMX,NX,XX,XP,XPV,XT,XY,XU,XHF,XQ,XQW,XQA,XRE,XDH,RECU,
  527. $ XKUL,XKUT1,XKUT2,XKUT3,XKUT4)
  528. IF (IERR.NE.0) RETURN
  529.  
  530. ENDIF
  531.  
  532. C creation des champs nodaux resultats
  533.  
  534. CALL BYRETO(XX,XP,NX,ZP,XNC,NNPT,KASN,ZTRA)
  535. CALL BYRETO(XX,XPV,NX,ZPV,XNC,NNPT,KASN,ZTRA)
  536. CALL BYRETO(XX,XT,NX,ZT,XNC,NNPT,KASN,ZTRA)
  537. CALL BYRETO(XX,XY,NX,ZY,XNC,NNPT,KASN,ZTRA)
  538. CALL BYRETO(XX,XU,NX,ZU,XNC,NNPT,KASN,ZTRA)
  539. CALL BYRETO(XX,XHF,NX,ZHF,XNC,NNPT,KASN,ZTRA)
  540. CALL BYRETO(XX,XQ,NX,ZQ,XNC,NNPT,KASN,ZTRA)
  541. CALL BYRETO(XX,XQA,NX,ZQA,XNC,NNPT,KASN,ZTRA)
  542. CALL BYRETO(XX,XQW,NX,ZQW,XNC,NNPT,KASN,ZTRA)
  543. CALL BYRETO(XX,XRE,NX,ZRE,XNC,NNPT,KASN,ZTRA)
  544. CALL BYRETO(XX,XDH,NX,ZDH,XNC,NNPT,KASN,ZTRA)
  545.  
  546. C ecriture du champoint multicomposante
  547.  
  548. NC = 11
  549. N = NNPT
  550. SEGINI MPOVAL
  551. DO I=1,NNPT
  552. VPOCHA(I,1) = ZP(I)
  553. VPOCHA(I,2) = ZPV(I)
  554. VPOCHA(I,3) = ZT(I)
  555. VPOCHA(I,4) = ZY(I)
  556. VPOCHA(I,5) = ZU(I)
  557. VPOCHA(I,6) = ZHF(I)
  558. VPOCHA(I,7) = ZQ(I)
  559. VPOCHA(I,8) = ZQA(I)
  560. VPOCHA(I,9) = ZQW(I)
  561. VPOCHA(I,10) = ZRE(I)
  562. VPOCHA(I,11) = ZDH(I)
  563. ENDDO
  564.  
  565. SEGSUP PTRAV1
  566. SEGSUP PTRAV2
  567. SEGINI MSOUPO
  568.  
  569. NOCOMP(1) = 'P '
  570. NOCOMP(2) = 'PV '
  571. NOCOMP(3) = 'TF '
  572. NOCOMP(4) = 'X '
  573. NOCOMP(5) = 'U '
  574. NOCOMP(6) = 'H '
  575. NOCOMP(7) = 'Q '
  576. NOCOMP(8) = 'QA '
  577. NOCOMP(9) = 'QE '
  578. NOCOMP(10) = 'RE '
  579. NOCOMP(11) = 'F '
  580.  
  581. IGEOC = IPT1
  582. IPOVAL = MPOVAL
  583.  
  584. DO I=1,NC
  585. NOHARM(I) = MSOUP1.NOHARM(1)
  586. ENDDO
  587.  
  588. NSOUPO = 1
  589. NAT = MCHPO1.JATTRI(/1)
  590. SEGINI MCHPOI
  591.  
  592. MTYPOI = MCHPO1.MTYPOI
  593. MOCHDE = MCHPO1.MOCHDE
  594. DO I=1,NAT
  595. JATTRI(I) = MCHPO1.JATTRI(1)
  596. ENDDO
  597. IPCHP(1) = MSOUPO
  598. IFOPOI = MCHPO1.IFOPOI
  599.  
  600. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  601. CALL ECROBJ('CHPOINT ',MCHPOI)
  602.  
  603. END
  604.  
  605.  
  606.  

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