Télécharger onde.eso

Retour à la liste

Numérotation des lignes :

onde
  1. C ONDE SOURCE FANDEUR 22/01/03 21:15:34 11136
  2. C
  3. SUBROUTINE ONDE
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-V)
  6. IMPLICIT COMPLEX*16 (W-Z)
  7. CHARACTER *72 TI
  8. CHARACTER *4 NSORT(4),MCLE(5)
  9. LOGICAL INV
  10. C
  11. C=======================================================================
  12. C = CALCUL DE LA TRANSFORMEE EN ONDELETTE CONTINUE D'UN SIGNAL =
  13. C = =
  14. C = SYNTAXE : =
  15. C = =
  16. C = TRANSFORMEE DE FOURIER DIRECTE =
  17. C = =
  18. C = EVO = 'ONDE' EVO1 EXP2 SORT 'FMIN' V1 'FMAX' V2 ( 'NFRQ' V3 ) =
  19. C = ( 'PULS' V4 ) ( 'EPSI' V5 ) =
  20. C = OU =
  21. C = CHP1 MAIL1 = 'ONDE' EVO1 EXP2 SORT 'FMIN' V1 'FMAX' V2 =
  22. C = ( 'NFRQ' V3 ) ( 'PULS' V4 ) =
  23. C = =
  24. C = EXP2 : EXPOSANT DANS NPOINT=2^EXP2, NPOINT ETANT =
  25. C = LE NOMBRE DE REELS DANS LISTREEL =
  26. C = EVO1 : OBJET DE TYPE EVOLUTIO CONTENANT LE SIGNAL A TRAITER=
  27. C = SORT : TYPE DE SORTIE ; =
  28. C = = 'CRMO' EXTRACTION CRETE SUR CRITERE MODULE =
  29. C = ( PAR DEFAUT ) =
  30. C = = 'CRPH' EXTRACTION CRETE SUR CRITERE PHASE =
  31. C = = 'REIM' PART REEL & PART IMAG =
  32. C = = 'MOPH' MODULE & PHASE =
  33. C = V1 : FREQUENCE MINI A VISUALISER =
  34. C = V2 : FREQUENCE MAXI A VISUALISER =
  35. C = V3 : NOMBRE DE PAS EN FREQUENCE =
  36. C = V4 : PULSATION ONDELETTE MERE =
  37. C = V5 : CRITERE DE NULLITE =
  38. C = COU1 : COULEUR ATTRIBUEE A LA PREMIERE COURBE (FACULTATIF) =
  39. C = COU2 : COULEUR ATTRIBUEE A LA DEUXIEME COURBE (FACULTATIF) =
  40. C = =
  41. C = =
  42. C=======================================================================
  43. C
  44. -INC CCREEL
  45. -INC CCGEOME
  46.  
  47. -INC PPARAM
  48. -INC CCOPTIO
  49. -INC SMEVOLL
  50. -INC SMLREEL
  51. -INC SMCHPOI
  52. -INC SMELEME
  53. -INC SMCOORD
  54. C
  55. SEGMENT MTRAV1
  56. IMPLIED XX(NCOU),YY(NCOU),WOND(NCOU),WONC(NCOU)
  57. IMPLIED YY1(NCOU),YY2(NCOU),VM(NCOU),VP(NCOU)
  58. IMPLIED VDP(NCOU),VPL(NCOU)
  59. ENDSEGMENT
  60. C
  61. SEGMENT MTRAV2
  62. IMPLIED W(NEXP)
  63. ENDSEGMENT
  64.  
  65. SEGMENT MTRAV3
  66. IMPLIED VML((NA+1)*NCOU),VML2((NA+1)*NCOU)
  67. IMPLIED ICP1((NA+1)*NCOU)
  68. ENDSEGMENT
  69. C
  70. DATA NSORT(1),NSORT(2),NSORT(3)/'CRMO','CRPH','REIM'/
  71. DATA NSORT(4)/'MOPH'/
  72. DATA MCLE(1),MCLE(2),MCLE(3),MCLE(4)/'FMIN','FMAX','NFRQ','EPSI'/
  73. DATA MCLE(5)/'PULS'/
  74. C
  75. C LECTURE DE EXP2
  76. C
  77.  
  78. CALL LIRENT(N2,1,IRET1)
  79. IF(IRET1.EQ.0)GOTO 666
  80. C
  81. C LECTURE DE L'OBJET EVOLUTIO CONTENANT LE SIGNAL
  82. C
  83. CALL LIROBJ('EVOLUTIO',IPSIG,1,IRET2)
  84. IF(IRET2.EQ.0)GOTO 666
  85. C
  86. C LECTURE DU TYPE DE SORTIE
  87. C
  88. CALL LIRMOT(NSORT,4,ISORT,0)
  89. IF(ISORT.EQ.0) ISORT=1
  90. C
  91. C LECTURE DE LA FREQUENCE MINIE
  92. C
  93. CALL LIRMOT(MCLE(1),1,IRET,0)
  94. IF(IRET.EQ.1) THEN
  95. CALL LIRREE(FRMI,0,IRET1)
  96. IF(IRET1.EQ.0) THEN
  97. MOTERR(1:4)=MCLE(1)(1:4)
  98. CALL ERREUR(166)
  99. GOTO 666
  100. ENDIF
  101. IF(FRMI.LT.(-1.D-20)) FRMI=-FRMI
  102. IF(ABS(FRMI).LT.1.D-20) FRMA=-1.D0
  103. ELSE
  104. FRMI=-1.D0
  105. ENDIF
  106. C
  107. C LECTURE DE LA FREQUENCE MAXIE
  108. C
  109. CALL LIRMOT(MCLE(2),1,IRET,0)
  110. IF(IRET.EQ.1) THEN
  111. CALL LIRREE(FRMA,0,IRET1)
  112. IF(IRET1.EQ.0) THEN
  113. MOTERR(1:4)=MCLE(2)(1:4)
  114. CALL ERREUR(166)
  115. GOTO 666
  116. ENDIF
  117. IF(FRMA.LT.(-1.D-20)) FRMA=-FRMA
  118. IF(ABS(FRMA).LT.1.D-20) FRMA=-1.D0
  119. ELSE
  120. FRMA=-1.D0
  121. ENDIF
  122. C
  123. C LECTURE DU NOMBRE DE DIVISION EN FREQUENCE
  124. C
  125. CALL LIRMOT(MCLE(3),1,IRET,0)
  126. IF(IRET.EQ.1) THEN
  127. CALL LIRENT(NA,0,IRET1)
  128. IF(IRET1.EQ.0) THEN
  129. MOTERR(1:4)=MCLE(3)(1:4)
  130. CALL ERREUR(166)
  131. GOTO 666
  132. ENDIF
  133. ELSE
  134. NA=100
  135. ENDIF
  136. C
  137. C LECTURE DU CRITERE
  138. C
  139. CALL LIRMOT(MCLE(4),1,IRET,0)
  140. IF(IRET.EQ.1) THEN
  141. CALL LIRREE(EPSI,0,IRET1)
  142. IF(IRET1.EQ.0) THEN
  143. MOTERR(1:4)=MCLE(4)(1:4)
  144. CALL ERREUR(166)
  145. GOTO 666
  146. ENDIF
  147. ELSE
  148. EPSI=1.D-4
  149. ENDIF
  150. C
  151. C LECTURE DE LA FREQUENCE ONDELETTE
  152. C
  153. CALL LIRMOT(MCLE(5),1,IRET,0)
  154. IF(IRET.EQ.1) THEN
  155. CALL LIRREE(V0,0,IRET1)
  156. IF(IRET1.EQ.0) THEN
  157. MOTERR(1:4)=MCLE(5)(1:4)
  158. CALL ERREUR(166)
  159. GOTO 666
  160. ENDIF
  161. ELSE
  162. V0=5.D0
  163. ENDIF
  164. C
  165. C LECTURE DE LA COULEUR
  166. C
  167. CALL LIRMOT(NCOUL,NBCOUL,ICOU1,0)
  168. IF(ICOU1.EQ.0) ICOU1=IDCOUL+1
  169. ICOU1=ICOU1-1
  170. CALL LIRMOT(NCOUL,NBCOUL,ICOU2,0)
  171. IF(ICOU2.EQ.0) ICOU2=IDCOUL+1
  172. ICOU2=ICOU2-1
  173. C
  174. IF(IERR.NE.0) GOTO 666
  175. C
  176. MEVOL1=IPSIG
  177. SEGACT MEVOL1
  178. KEVOL1=MEVOL1.IEVOLL(1)
  179. SEGACT KEVOL1
  180. MLREE1=KEVOL1.IPROGX
  181. MLREE2=KEVOL1.IPROGY
  182. C
  183. SEGACT MLREE1,MLREE2
  184. L1=MLREE1.PROG(/1)
  185. DT=MLREE1.PROG(2)-MLREE1.PROG(1)
  186. TDEB=MLREE1.PROG(1)
  187. SEGDES MLREE1
  188. C
  189. NPOINT=2**N2
  190. IF(NPOINT.GT.L1) THEN
  191. IF(IIMPI.EQ.1) WRITE(IOIMP,1000) L1,N2,NPOINT
  192. 1000 FORMAT(1H ,'LE NOMBRE DE POINTS DANS LISTEMPS ',I6, ' EST ',
  193. & 'INFERIEURE @ 2**',I5,
  194. & /' ON PRENDRA UNE LONGUEUR DE LISTEMPS DE ',I6
  195. $ ,' MOTS ',/' ET ON COMPLETERA PAR DES ZEROS')
  196. ELSE
  197. IF(NPOINT.LT.L1) THEN
  198. IF(IIMPI.EQ.1) WRITE(IOIMP,1010) N2
  199. 1010 FORMAT(1H ,'ON TRONQUE LE SIGNAL A 2**',I5,' MOTS',/)
  200. ELSE
  201. IF(IIMPI.EQ.1) WRITE(IOIMP,1030)N2,NPOINT
  202. 1030 FORMAT(1H ,'LA LONGUEUR DU LISTEMP EST EGALE A 2**',I5,
  203. & ' = ',I6,/)
  204. ENDIF
  205. ENDIF
  206. TFIN=TDEB+(NPOINT*DT)
  207. C
  208. NCOU=NPOINT
  209. SEGINI MTRAV1
  210. C
  211. NEXP=NPOINT/2
  212. SEGINI MTRAV2
  213.  
  214. SEGINI MTRAV3
  215. C
  216. C CHARGEMENT DES TABLEAUX DE TRAVAIL
  217. C
  218. IND1=L1
  219. IF(NPOINT.LT.L1)IND1 = NPOINT
  220. DO 1100 I=1,IND1
  221. XX(I)=MLREE2.PROG(I)
  222. C IF(IIMPI.EQ.1)WRITE(IOIMP,*) ' XX(',I,') = ',XX(I)
  223. 1100 CONTINUE
  224. IF(NPOINT.GT.L1) THEN
  225. L2=L1+1
  226. DO 1110 I=L2,NPOINT
  227. XX(I)=0.D0
  228. 1110 CONTINUE
  229. ENDIF
  230.  
  231. DUREE=DT*DBLE(NPOINT)
  232. DFREQ=1.D0/DUREE
  233. KHALF=INT(NPOINT/2)+1
  234. KDEBU=1
  235. NNN=KHALF-KDEBU+1
  236. JG=NNN
  237. C
  238. C CALCUL DE LA FFT
  239. C
  240. IF(IIMPI.EQ.1) WRITE(IOIMP,*)' CALCUL DE LA FFT DU SIGNAL '
  241. C
  242. C================= CALCUL TFR FONCTION F(T) =============
  243. C
  244. C
  245. INV=.FALSE.
  246. CALL WEXP(INV,NPOINT,W(1))
  247. CALL FFTL(XX(1),YY(1),W(1),NPOINT)
  248. SEGDES MLREE2
  249.  
  250. C
  251. C========================================================
  252. C
  253.  
  254. AMIN=V0/2.D0/XPI/FRMA
  255. AMAX=V0/2.D0/XPI/FRMI
  256. NPO=NPOINT*(NA+1)
  257.  
  258. GOTO(1999,2999,4199,4199),ISORT
  259. RETURN
  260.  
  261. C
  262. C CRITERE SUR LE MODULE
  263. C
  264. 1999 SEGINI MLREE1
  265. SEGINI MLREE2
  266. SEGINI MLREE3
  267. JG=0
  268. SEGADJ MLREE1
  269. K=1
  270.  
  271.  
  272. C================ BOUCLE SUR LES FREQUENCES =================
  273. C
  274. DO 2000 I=0,NA
  275. A=AMIN+((AMAX-AMIN)*I/NA)
  276. V=V0/A
  277.  
  278. C PRODUIT ONDELETTE TFR SIGNAL
  279.  
  280. DO 1200 J=1,KHALF
  281. VJ=DBLE(J-1)*DFREQ*2.D0*XPI*A
  282. V2=(VJ-V0)**2.D0
  283. PM=EXP(-0.5D0*V2)*((2.D0*XPI)**0.5D0)
  284. WOND(J)=PM*XX(J)
  285. 1200 CONTINUE
  286.  
  287. J=NPOINT+1
  288. KK=1
  289. L11=KHALF-1
  290. DO 1205 II=2,L11
  291. KK=KK+1
  292. J=J-1
  293. VJ=DBLE(J-1-NPOINT)*DFREQ*2.D0*XPI*A
  294. V2=(VJ-V0)**2.D0
  295. PM=EXP(-0.5D0*V2)*((2.D0*XPI)**0.5D0)
  296. WOND(J)=CONJG(XX(KK))*PM
  297.  
  298. 1205 CONTINUE
  299.  
  300.  
  301. C
  302. C================= CALCUL TFR INVERSE =============
  303. C
  304. C
  305. INV=.TRUE.
  306. CALL WEXP(INV,NPOINT,W(1))
  307. CALL FFTL(WOND(1),YY1(1),W(1),NPOINT)
  308. C
  309. C========================================================
  310. DO 1210 J=1,NPOINT
  311. R1=WOND(J)
  312. R2=CXTOIM(WOND(J))*(-1.D0)
  313. RT=SQRT(R1*R1+R2*R2)
  314. VML((I*NPOINT)+J)=RT/(DBLE(NPOINT))
  315. 1210 CONTINUE
  316.  
  317. 2000 CONTINUE
  318.  
  319.  
  320. C RECHERCHE CRETE
  321.  
  322. JN=INT(((2.D0*AMAX)-TDEB)/DT-1.D0)
  323. JX=INT((TFIN-(2.D0*AMAX)-TDEB)/DT-1.D0)
  324. DO 2500 J=JN,JX
  325. VP=-1.D0
  326. DO 2100 I=0,NA
  327. A=AMIN+((AMAX-AMIN)*I/NA)
  328. V=V0/A
  329. TCOU=TDEB+(DT*DBLE(J-1))
  330. VMIJ=VML((I*NPOINT)+J)/((XPI/2.D0)**0.5D0)
  331. IF(VMIJ.GT.VP) THEN
  332. VP=VMIJ
  333. VF=V/2.D0/XPI
  334. ENDIF
  335. 2100 CONTINUE
  336. IF(VP.GT.0) THEN
  337. JG=K
  338. SEGADJ MLREE1
  339. SEGADJ MLREE2
  340. SEGADJ MLREE3
  341. MLREE3.PROG(K)=VP
  342. MLREE2.PROG(K)=VF
  343. MLREE1.PROG(K)=TCOU
  344. K=K+1
  345. ENDIF
  346. 2500 CONTINUE
  347. GOTO 4001
  348.  
  349. C
  350. C CRITERE SUR LA PHASE
  351. C
  352.  
  353. 2999 SEGINI MLREE1
  354. SEGINI MLREE2
  355. SEGINI MLREE3
  356. JG=0
  357. SEGADJ MLREE1
  358. K=1
  359.  
  360. C
  361. C================ BOUCLE SUR LES FREQUENCES =================
  362. C
  363. DO 4000 I=0,NA
  364. A=AMIN+((AMAX-AMIN)*I/NA)
  365. V=V0/A
  366.  
  367. C PRODUIT ONDELETTE TFR SIGNAL
  368.  
  369. DO 3200 J=1,KHALF
  370. VJ=DBLE(J-1)*DFREQ*2.D0*XPI*A
  371. V2=(VJ-V0)**2.D0
  372. PM=EXP(-0.5D0*V2)*((2.D0*XPI)**0.5D0)
  373. WOND(J)=PM*XX(J)
  374. 3200 CONTINUE
  375.  
  376. J=NPOINT+1
  377. KK=1
  378. L11=KHALF-1
  379. DO 3205 II=2,L11
  380. KK=KK+1
  381. J=J-1
  382. VJ=DBLE(J-1-NPOINT)*DFREQ*2.D0*XPI*A
  383. V2=(VJ-V0)**2.D0
  384. PM=EXP(-0.5D0*V2)*((2.D0*XPI)**0.5D0)
  385. WOND(J)=CONJG(XX(KK))*PM
  386.  
  387. 3205 CONTINUE
  388.  
  389.  
  390. C
  391. C================= CALCUL TFR INVERSE =============
  392. C
  393. C
  394. INV=.TRUE.
  395. CALL WEXP(INV,NPOINT,W(1))
  396. CALL FFTL(WOND(1),YY1(1),W(1),NPOINT)
  397. C
  398. C========================================================
  399. DO 3210 J=1,NPOINT
  400. R1=WOND(J)
  401. R2=CXTOIM(WOND(J))*(-1.D0)
  402. RT=SQRT(R1*R1+R2*R2)
  403. VM(J)=RT/(DBLE(NPOINT))
  404. CALL FACOMP(R1,R2,RT)
  405. VP(J)=ATAN2(R2,R1)
  406. VPL(J)=VP(J)+0.D0
  407. 3210 CONTINUE
  408.  
  409.  
  410.  
  411. C================= CALCUL DERIVEE PHASE =============
  412.  
  413. VDP(1)=(VPL(2)-VPL(1))/DT
  414. DO 3220 J=2,(NPOINT-1)
  415. VDP(J)=(VPL(J+1)-VPL(J-1))/2.D0/DT
  416. 3220 CONTINUE
  417. VDP(NPOINT)=(VPL(NPOINT)-VPL(NPOINT-1))/DT
  418.  
  419. C CORRECTION
  420.  
  421. DO 3230 J=1,NPOINT
  422. DPI=XPI*0.5D0/DT
  423. SPI=DPI*(-1.D0)
  424. IF(VDP(J).GT.DPI) VDP(J)=VDP(J)-(XPI/DT)
  425. IF(VDP(J).LT.SPI) VDP(J)=VDP(J)+(XPI/DT)
  426. VDP(J)=VDP(J)+(V0/A)
  427.  
  428. C RECHERCHE CRETE
  429.  
  430. AVDP=ABS(VDP(J))-(EPSI*V0/A)
  431. IF(AVDP.LT.0) THEN
  432. FCOU=0.5D0/A
  433. TCOU=TDEB+(DT*DBLE(J-1))
  434. TFCO=TFIN-(1.D0/FCOU)
  435. TDCO=TDEB+(1.D0/FCOU)
  436. IF(TCOU.GT.TDCO) THEN
  437. IF(TCOU.LT.TFCO) THEN
  438. VMJ=VM(J)/((XPI/2.D0)**0.5D0)
  439. JG=K
  440. SEGADJ MLREE1
  441. SEGADJ MLREE2
  442. SEGADJ MLREE3
  443. MLREE3.PROG(K)=VMJ
  444. MLREE2.PROG(K)=V/2.D0/XPI
  445. MLREE1.PROG(K)=TCOU
  446. K=K+1
  447. ENDIF
  448. ENDIF
  449. ENDIF
  450. 3230 CONTINUE
  451.  
  452.  
  453. 4000 CONTINUE
  454.  
  455. C----------- SORTIES ------------
  456.  
  457. 4001 SEGDES MLREE1,MLREE2,MLREE3
  458.  
  459. C
  460. C CREATION DE L'OBJET EVOLUTIO CRETE
  461. C
  462. N=2
  463. SEGINI MEVOLL
  464. IPVO=MEVOLL
  465. TI(1:72)=TITREE
  466. IEVTEX=TI
  467. C
  468. C PREMIERE COURBE
  469. C
  470. SEGINI KEVOLL
  471. TYPX='LISTREEL'
  472. TYPY='LISTREEL'
  473. c KEVTEX=TI
  474. KEVTEX='Freq (Hz)'
  475. IEVOLL(1)=KEVOLL
  476. C
  477. IPROGX=MLREE1
  478. NOMEVX='TEMPS S'
  479. C
  480. IPROGY=MLREE2
  481. NOMEVY='FREQ HZ'
  482. C
  483. NUMEVX=ICOU1
  484. NUMEVY=' '
  485.  
  486. SEGDES KEVOLL
  487. C
  488. C DEUXIEME COURBE
  489. C
  490. SEGINI KEVOLL
  491. TYPX='LISTREEL'
  492. TYPY='LISTREEL'
  493. c KEVTEX=TI
  494. KEVTEX='Amp'
  495. IEVOLL(2)=KEVOLL
  496. C
  497. IPROGX=MLREE1
  498. NOMEVX='TEMPS S'
  499. C
  500. IPROGY=MLREE3
  501. NOMEVY='MODULE '
  502. C
  503. NUMEVX=ICOU2
  504. NUMEVY=' '
  505.  
  506. C
  507. SEGDES KEVOLL
  508. C
  509. SEGSUP MTRAV1,MTRAV2,MTRAV3
  510. SEGDES KEVOL1,MEVOL1
  511. C
  512. SEGDES MEVOLL
  513. CALL ECROBJ('EVOLUTIO',IPVO)
  514.  
  515. RETURN
  516.  
  517. C=============== CHAMPOINT ===========================
  518.  
  519.  
  520.  
  521. 4199 IF (IDIM.EQ.0) RETURN
  522. NBSOUS=0
  523. NBREF=0
  524. NBELEM=NA*(NPOINT-1)
  525. NBNN=4
  526. SEGINI MELEME
  527. ITYPEL=8
  528. segact mcoord*mod
  529. IDEB=NBPTS
  530.  
  531.  
  532. C
  533. C================ BOUCLE SUR LES FREQUENCES =================
  534. C
  535. DO 5000 I=0,NA
  536. A=AMIN+((AMAX-AMIN)*I/NA)
  537. V=V0/A
  538.  
  539. C PRODUIT ONDELETTE TFR SIGNAL
  540.  
  541. DO 4200 J=1,KHALF
  542. VJ=DBLE(J-1)*DFREQ*2.D0*XPI*A
  543. V2=(VJ-V0)**2.D0
  544. PM=EXP(-0.5D0*V2)*((2.D0*XPI)**0.5D0)
  545. WOND(J)=PM*XX(J)
  546. 4200 CONTINUE
  547.  
  548. J=NPOINT+1
  549. KK=1
  550. L11=KHALF-1
  551. DO 4205 II=2,L11
  552. KK=KK+1
  553. J=J-1
  554. VJ=DBLE(J-1-NPOINT)*DFREQ*2.D0*XPI*A
  555. V2=(VJ-V0)**2.D0
  556. PM=EXP(-0.5D0*V2)*((2.D0*XPI)**0.5D0)
  557. WOND(J)=CONJG(XX(KK))*PM
  558.  
  559. 4205 CONTINUE
  560.  
  561.  
  562. C
  563. C================= CALCUL TFR INVERSE =============
  564. C
  565. C
  566. INV=.TRUE.
  567. CALL WEXP(INV,NPOINT,W(1))
  568. CALL FFTL(WOND(1),YY1(1),W(1),NPOINT)
  569. C
  570. C========================================================
  571.  
  572. DO 4210 J=1,NPOINT
  573. II=(I*NPOINT)+J
  574. IF(ISORT.EQ.3) THEN
  575. VML(II)=WOND(J)/(CMPLX(NPOINT))/((XPI/CMPLX(2.D0))**
  576. & CMPLX(0.5D0))
  577. VML2(II)=CXTOIM(WOND(J))/(DBLE(NPOINT))/((XPI/2.D0)**
  578. & 0.5D0)
  579. ENDIF
  580. IF(ISORT.EQ.4) THEN
  581. R1=WOND(J)
  582. R2=CXTOIM(WOND(J))
  583. VML(II)=SQRT(R1*R1+R2*R2)/(DBLE(NPOINT))/((XPI/2.D0)**
  584. & 0.5D0)
  585. VML2(II)=ATAN2(R2,R1)*360.D0/XPI
  586. ENDIF
  587. FCOU=0.5D0/A
  588. TCOU=TDEB+(DT*DBLE(J-1))
  589. TFCO=TFIN-(1.D0/FCOU)
  590. TDCO=TDEB+(1.D0/FCOU)
  591. IF ((TCOU.LT.TDCO).OR.(TCOU.GT.TFCO)) THEN
  592. VML(II)=0.D0
  593. VML2(II)=0.D0
  594. ENDIF
  595. NBPTS=NBPTS+1
  596. SEGADJ MCOORD
  597. XCOOR((NBPTS-1)*(IDIM+1)+1)=DBLE(J-1)/(NPOINT-1)
  598. XCOOR((NBPTS-1)*(IDIM+1)+2)=1.D0-(DBLE(I)/NA)
  599. IF(IDIM.NE.2) THEN
  600. XCOOR((NBPTS-1)*(IDIM+1)+3)=0.D0
  601. ENDIF
  602. XCOOR(NBPTS*(IDIM+1))=0.D0
  603.  
  604.  
  605. 4210 CONTINUE
  606.  
  607.  
  608. 5000 CONTINUE
  609.  
  610.  
  611. DO 5150 I=0,(NA-1)
  612. DO 5100 J=1,(NPOINT-1)
  613. INE=I*(NPOINT-1)+J
  614. ICOLOR(INE)=IDCOUL
  615. NUM(1,INE)=IDEB+J+(I*NPOINT)
  616. NUM(2,INE)=IDEB+(J+1)+(I*NPOINT)
  617. NUM(3,INE)=IDEB+(J+1)+((I+1)*NPOINT)
  618. NUM(4,INE)=IDEB+J+((I+1)*NPOINT)
  619. 5100 CONTINUE
  620. 5150 CONTINUE
  621.  
  622. C--- TABLEAU CONVERSION QUA4->POI1 ----
  623.  
  624. DO 5151 I=1,NPO
  625. ICP1(I)=0
  626. 5151 CONTINUE
  627. ICON=0
  628. DO 5155 I=1,4
  629. DO 51551 J=1,NBELEM
  630. IKI=NUM(I,J)-IDEB
  631. IF (ICP1(IKI).NE.0) GOTO 51551
  632. ICON=ICON+1
  633. ICP1(IKI)=ICON
  634. 51551 CONTINUE
  635. 5155 CONTINUE
  636.  
  637.  
  638. C GOTO 4310
  639. SEGDES MELEME
  640. CALL ECROBJ('MAILLAGE',MELEME)
  641. SEGACT MELEME
  642. CALL CHANGE (MELEME,1)
  643. NBPOIN=NUM(/2)
  644. NSOUPO=1
  645. NC=2
  646. N=NBPOIN
  647. NAT=1
  648. SEGINI MCHPOI
  649. MOCHDE=' chpoint de coordonnees '
  650. MTYPOI=' '
  651. JATTRI(1) = 1
  652. IPPOI=MCHPOI
  653. SEGINI MSOUPO
  654. SEGINI MPOVAL
  655. IPCHP(1)=MSOUPO
  656. IFOPOI = IFOUR
  657. SEGDES MCHPOI
  658. IF(ISORT.EQ.3) THEN
  659. NOCOMP(1)='PREE'
  660. NOCOMP(2)='PIMA'
  661. ENDIF
  662. IF(ISORT.EQ.4) THEN
  663. NOCOMP(1)='MODU'
  664. NOCOMP(2)='PHAS'
  665. ENDIF
  666. NOHARM(1)=NIFOUR
  667. NOHARM(2)=NIFOUR
  668. IGEOC=MELEME
  669. IPOVAL=MPOVAL
  670. SEGDES MSOUPO
  671. DO 5160 I= 1 ,NPO
  672. II=ICP1(I)
  673. VPOCHA(II,1)=VML(I)
  674. VPOCHA(II,2)=VML2(I)
  675. 5160 CONTINUE
  676. SEGDES MPOVAL
  677. SEGDES MELEME
  678. CALL ECROBJ('CHPOINT ',IPPOI)
  679. SEGSUP MTRAV1,MTRAV2,MTRAV3
  680.  
  681.  
  682. 666 CONTINUE
  683. RETURN
  684. END
  685.  
  686.  
  687.  

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