Télécharger la plaquette Cast3M


fr en

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