Télécharger cvol.eso

Retour à la liste

cvol
C CVOL      SOURCE    CHAT      05/01/12    22:33:27     5004
*$$$$ CVOL
C     CVOL      SOURCE    ISPRA      90/07/25
      SUBROUTINE CVOL
      IMPLICIT INTEGER(I-N)
      IMPLICIT  REAL*8(A-H,O-Z)
      LOGICAL LSYM,LRSYM,LOK
C
C=======================================================================
C  =  CALCUL DE CONVOLUTION                                           =
C  =                                                                  =
C  =  SYNTAXE :                                                       =
C  =                                                                  =
C  =    SRLIST  = CVOL SLIST RLIST (('NPNE' MM) TYPE) ;               =
C  =                                                                  =
C  =                                                                  =
C  =    SLIST   : OBJET DE TYPE LISTREEL CONTENANT LE SIGNAL A TRAITER=
C  =    RLIST   : OBJET DE TYPE LISTREEL CONTENANT LE SIGNAL REPONSE  =
C  =    SRLIST  : OBJET DE TYPE LISTREEL CONTENANT LE SIGNAL RESULTAT =
C  =                                                                  =
C  =    MM      : OBJET DE TYPE ENTIER DONNANT LA LONGUEUR DE LA      =
C  =              PARTIE NEGATIVE DU SIGNAL DE REPONSE SI NON SYMETRIE=
C  =    TYPE    : 'SYME' OU 'PADD' (DEFAUT 'SYME')                    =
C  =                                                                  =
C  =                                                                  =
C  =  CREATION    : 90/08/02                                          =
C  =  PROGRAMMEUR : PEG                                               =
C=======================================================================
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC SMLREEL
-INC CCREEL
C
      POINTEUR IPSIG.MLREEL,IPREP.MLREEL
      POINTEUR IPRESU.MLREEL
      SEGMENT MTRAV
          IMPLIED SIG(KNPM),REP(KM),RESU(KN)
      ENDSEGMENT
C
      PARAMETER (NMOCLE=3)
      CHARACTER*4 MOTCLE(NMOCLE)
      DATA MOTCLE/'SYME','PADD','NPNE'/
      LOK=.TRUE.
C
C     DEFAUT (REPONSE SYMETRIQUE,SIGNAL SYMETRIQUE)
C
      LRSYM=.TRUE.
      LSYM=.TRUE.
C
C     LECTURE DE L'OBJET LISTREEL CONTENANT LE SIGNAL
C
      CALL LIROBJ('LISTREEL',IPSIG,1,IRET1)
      IF(IRET1.EQ.0) RETURN
C
C     LECTURE DE L'OBJET LISTREEL CONTENANT LA REPONSE
C
      CALL LIROBJ('LISTREEL',IPREP,1,IRET1)
      IF(IRET1.EQ.0) RETURN
C
C     LECTURE DES OPTIONS
C
 1    CALL LIRMOT(MOTCLE,NMOCLE,IVAL,0)
      IF(IVAL.EQ.0)GOTO 9
      GOTO(2,3,4),IVAL
C     ---> "TYPE"
 2    LSYM=.TRUE.
      GOTO 1
 3    LSYM=.FALSE.
      GOTO 1
C     ---> "NPNE"
 4    LRSYM=.FALSE.
      CALL LIRENT(MM,1,IRET1)
      IF(IRET1.EQ.0) RETURN
      GOTO 1
 9    CONTINUE
C
      IF(IERR.NE.0) RETURN
C
C     DIMENSION DES TABLEAUX DE TRAVAIL ET TESTS
C
      SEGACT IPSIG
      KN=IPSIG.PROG(/1)
C
      SEGACT IPREP
      KKM=IPREP.PROG(/1)
      IF (LRSYM)THEN
        MM=KKM-1
        KM=2*KKM-1
      ELSE
        KM=KKM
      ENDIF
C
      IF(KM.EQ.MM)THEN
        MP=0
      ELSE
        MP=KM-MM-1
      ENDIF
C
      IF(MM.GT.KM)THEN
          LOK=.FALSE.
          CALL ERREUR(569)
      ENDIF
C
      IF(LSYM)THEN
        IF(MM+1.GT.KN)THEN
            LOK=.FALSE.
            MOTERR='gauche'
            CALL ERREUR(570)
        ENDIF
        IF(MP+1.GT.KN)THEN
            LOK=.FALSE.
            MOTERR='droite'
            CALL ERREUR(570)
        ENDIF
      ENDIF
C
      IF(.NOT.LOK)THEN
          SEGDES IPSIG,IPREP
          RETURN
C         LSYM=.FALSE.
C         WRITE(IOIMP,*)'CVOL:-----> ZERO PADDING'
      ENDIF
C
      KNPM=KN+MM+MP
C
      SEGINI MTRAV
C
C     REMPLISSAGE DES TABLEAUX DE TRAVAIL
C
      IF(LRSYM)THEN
        DO 10 IE1=1,KKM
          XXXX         =IPREP.PROG(IE1)
          REP(MM+IE1)  =XXXX
          REP(MM+2-IE1)=XXXX
 10     CONTINUE
      ELSE
        DO 11 IE1=1,KKM
          XXXX         =IPREP.PROG(IE1)
          REP(IE1)     =XXXX
 11     CONTINUE
      ENDIF
      SEGDES IPREP
C
      DO 15 IE1=1,KN
        SIG(MM+IE1)=IPSIG.PROG(IE1)
 15   CONTINUE
C
      SEGDES IPSIG
C
      IF(MM.NE.0)THEN
        IF (LSYM)THEN
          DO 16 IE1=1,MM
            SIG(IE1)=SIG(2*MM+2-IE1)
 16       CONTINUE
        ELSE
          DO 18 IE1=1,MM
            SIG(IE1)=0.D0
 18       CONTINUE
        ENDIF
      ENDIF
      IF(MP.NE.0)THEN
        IF (LSYM)THEN
          DO 17 IE1=1,MP
            SIG(MM+KN+IE1)=SIG(MM+KN-IE1)
 17       CONTINUE
        ELSE
          DO 19 IE1=1,MP
            SIG(MM+KN+IE1)=0.D0
 19       CONTINUE
        ENDIF
      ENDIF
C
      CALL CNVOLU(SIG,REP,RESU,KN,KM)
C
C     CREATION DE L'OBJET RESULTAT
C
      JG=KN
      SEGINI IPRESU
C
      DO 25 IE1=1,KN
        IPRESU.PROG(IE1)=RESU(IE1)
 25   CONTINUE
C
      SEGDES IPRESU
      SEGSUP MTRAV
C
      CALL ECROBJ('LISTREEL',IPRESU)
      RETURN
      END
 
 
 
 
 
 
 

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