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