Télécharger chsp.eso

Retour à la liste

chsp
C CHSP      SOURCE    BP208322  16/11/18    21:15:34     9177           
      SUBROUTINE CHSP
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      CHARACTER*72 TI
C
C     ==================================================================
C
C     CONVERSION DE SPECTRE D'OSCILLATEUR EN DEPLACEMENT,VITESSE OU
C
C     ACCELERATION.
C
C     SYNTAXE : EVOL2 = CHSP EVOL1  ENTR ENTREE  SORT SORTIE  COUL COOL
C
C     CREATION : 22/06/87
C     PROGRAMMEUR : MALAVAL
C
C     ==================================================================
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMEVOLL
-INC CCREEL
-INC CCGEOME
-INC SMLREEL
 
      CHARACTER*4 MODOM(3),MODON(3)
      CHARACTER*4 ITITY(3)
      DATA MODOM/'ENTR','SORT','COUL'/
      DATA MODON/'DEPL','VITE','ACCE'/
      DATA ITITY/'DEPL','VITE','ACCE'/
      LMOT=3
      ICOUL1=IDCOUL
C
C     LECTURE DES MOTS
C
      DO 10 I=1,3
      CALL LIRMOT (MODOM,LMOT,IPLAC,0)
      IF (IPLAC.EQ.0) GOTO 10
      GOTO (1,2,3),IPLAC
C
  1   CONTINUE
C
C     SPECTRE EN ENTREE
C
      CALL LIRMOT (MODON,3,IVAE,1)
      GOTO 10
C
   2  CONTINUE
C
C     SPECTRE DE SORTIE
C
      CALL LIRMOT (MODON,3,IVAS,1)
      GOTO 10
C
   3  CONTINUE
C
C     COULEURS
      CALL LIRMOT (NCOUL,NBCOUL,ICOUL1,0)
      IF (ICOUL1.EQ.0) ICOUL1=IDCOUL+1
      ICOUL1=ICOUL1-1
      GOTO 10
C
  10  CONTINUE
      IF (IVAE.EQ.IVAS) CALL ERREUR (202)
      IF (IVAE*IVAS.EQ.0) CALL ERREUR (26)
C
C     LECTURE DE L'OBJET EVOLUTION
C
      CALL LIROBJ ('EVOLUTIO',IPOEVO,1,IRET)
      MEVOL1=IPOEVO
      SEGACT MEVOL1
      NEVO=MEVOL1.IEVOLL(/1)
      N=NEVO
      SEGINI MEVOLL
      IPOEVO=MEVOLL
      DO 88 K=1,NEVO
      KEVOL1=MEVOL1.IEVOLL(K)
      SEGACT KEVOL1
      IPFREQ=KEVOL1.IPROGX
      IPSPO=KEVOL1.IPROGY
      SEGDES KEVOL1
C
      MLREEL=IPFREQ
      SEGACT MLREEL
      NN=MLREEL.PROG(/1)
      MLREE1=IPSPO
      SEGACT MLREE1
      JG=NN
      SEGINI MLREE2
      IPRES=MLREE2
      DO 15 I=1,NN
      W=2*XPI*PROG(I)
C
C     EXAMEN DES DIFFERENTS CAS POSSIBLES
C
      IF (IVAE.EQ.1) THEN
         IF (IVAS.EQ.2) THEN
            N0=2
            MLREE2.PROG(I)=W*MLREE1.PROG(I)
         ELSE
            N0=3
            W2=W*W
            MLREE2.PROG(I)=W2*MLREE1.PROG(I)
         ENDIF
       ENDIF
C
      IF (IVAE.EQ.2) THEN
         IF (IVAS.EQ.1) THEN
            N0=1
            MLREE2.PROG(I)=MLREE1.PROG(I)/W
         ELSE
            N0=3
            MLREE2.PROG(I)=W*MLREE1.PROG(I)
         ENDIF
       ENDIF
      IF (IVAE.EQ.3) THEN
         IF (IVAS.EQ.2) THEN
            N0=2
            MLREE2.PROG(I)=MLREE1.PROG(I)/W
         ELSE
            N0=1
            W2=W*W
            MLREE2.PROG(I)=MLREE1.PROG(I)/W2
         ENDIF
      ENDIF
  15  CONTINUE
C
      SEGINI KEVOLL
      IEVOLL(K)=KEVOLL
      IPROGX=IPFREQ
      IPROGY=IPRES
      NOMEVX='FREQUENCE'
      NOMEVY=ITITY(N0)
      NUMEVX=ICOUL1
      NUMEVY='REEL'
      TYPX='LISTREEL'
      TYPY='LISTREEL'
      TI(1:72)=TITREE
      IEVTEX=TI
      KEVTEX=TI
  25  CONTINUE
      SEGDES KEVOLL
      SEGDES MLREE2
      SEGDES MLREEL
      SEGDES MLREE1
  88  CONTINUE
      SEGDES MEVOLL
      SEGDES MEVOL1
 
      CALL ECROBJ ('EVOLUTIO',IPOEVO)
      RETURN
      END
 
 
 
 
 
 
 
 
 
 
 
 
 

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