Télécharger onde.eso

Retour à la liste

Numérotation des lignes :

  1. C ONDE SOURCE PV 20/03/24 21:19:50 10554
  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 = IFOMOD
  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.  
  688.  
  689.  
  690.  
  691.  
  692.  
  693.  
  694.  
  695.  
  696.  
  697.  
  698.  
  699.  
  700.  
  701.  
  702.  
  703.  

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