Télécharger onde.eso

Retour à la liste

Numérotation des lignes :

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

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