1 : C CHSP SOURCE CHAT 07/10/29 21:16:17 5940 2 : SUBROUTINE CHSP 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : CHARACTER*72 TI 6 : C 7 : C ================================================================== 8 : C 9 : C CONVERSION DE SPECTRE D'OSCILLATEUR EN DEPLACEMENT,VITESSE OU 10 : C 11 : C ACCELERATION. 12 : C 13 : C SYNTAXE : EVOL2 = CHSP EVOL1 ENTR ENTREE SORT SORTIE COUL COOL 14 : C 15 : C CREATION : 22/06/87 16 : C PROGRAMMEUR : MALAVAL 17 : C 18 : C ================================================================== 19 : C 20 : -INC CCOPTIO 21 : -INC SMEVOLL 22 : -INC CCREEL 23 : -INC CCGEOME 24 : -INC SMLREEL 25 : 26 : CHARACTER*4 MODOM(3),MODON(3) 27 : CHARACTER*4 ITITY(3) 28 : DATA MODOM/'ENTR','SORT','COUL'/ 29 : DATA MODON/'DEPL','VITE','ACCE'/ 30 : DATA ITITY/'DEPL','VITE','ACCE'/ 31 : LMOT=3 32 : ICOUL1=IDCOUL 33 : C 34 : C LECTURE DES MOTS 35 : C 36 : DO 10 I=1,3 36 : CALL LIRMOT (MODOM,LMOT,IPLAC,0) 37 : IF (IPLAC.EQ.0) GOTO 10 38 : GOTO (1,2,3),IPLAC 39 : C 40 : 1 CONTINUE 41 : C 42 : C SPECTRE EN ENTREE 43 : C 43 : CALL LIRMOT (MODON,3,IVAE,1) 44 : GOTO 10 45 : C 46 : 2 CONTINUE 47 : C 48 : C SPECTRE DE SORTIE 49 : C 49 : CALL LIRMOT (MODON,3,IVAS,1) 50 : GOTO 10 51 : C 52 : 3 CONTINUE 53 : C 54 : C COULEURS 54 : CALL LIRMOT (NCOUL,NBCOUL,ICOUL1,0) 55 : IF (ICOUL1.EQ.0) ICOUL1=IDCOUL+1 56 : ICOUL1=ICOUL1-1 57 : GOTO 10 58 : C 59 : 10 CONTINUE 59 : IF (IVAE.EQ.IVAS) CALL ERREUR (202) 59 : IF (IVAE*IVAS.EQ.0) CALL ERREUR (26) 60 : C 61 : C LECTURE DE L'OBJET EVOLUTION 62 : C 62 : CALL LIROBJ ('EVOLUTIO',IPOEVO,1,IRET) 63 : MEVOL1=IPOEVO 64 : SEGACT MEVOL1 65 : NEVO=MEVOL1.IEVOLL(/1) 66 : N=NEVO 67 : SEGINI MEVOLL 68 : IPOEVO=MEVOLL 69 : DO 88 K=1,NEVO 70 : KEVOL1=MEVOL1.IEVOLL(K) 71 : SEGACT KEVOL1 72 : IPFREQ=KEVOL1.IPROGX 73 : IPSPO=KEVOL1.IPROGY 74 : SEGDES KEVOL1 75 : C 76 : MLREEL=IPFREQ 77 : SEGACT MLREEL 78 : NN=MLREEL.PROG(/1) 79 : MLREE1=IPSPO 80 : SEGACT MLREE1 81 : JG=NN 82 : SEGINI MLREE2 83 : IPRES=MLREE2 84 : DO 15 I=1,NN 85 : W=2*XPI*PROG(I) 86 : C 87 : C EXAMEN DES DIFFERENTS CAS POSSIBLES 88 : C 89 : IF (IVAE.EQ.1) THEN 90 : IF (IVAS.EQ.2) THEN 91 : N0=2 92 : MLREE2.PROG(I)=W*MLREE1.PROG(I) 93 : ELSE 94 : N0=3 95 : W2=W*W 96 : MLREE2.PROG(I)=W2*MLREE1.PROG(I) 97 : ENDIF 98 : ENDIF 99 : C 100 : IF (IVAE.EQ.2) THEN 101 : IF (IVAS.EQ.1) THEN 102 : N0=1 103 : MLREE2.PROG(I)=MLREE1.PROG(I)/W 104 : ELSE 105 : N0=3 106 : MLREE2.PROG(I)=W*MLREE1.PROG(I) 107 : ENDIF 108 : ENDIF 109 : IF (IVAE.EQ.3) THEN 110 : IF (IVAS.EQ.2) THEN 111 : N0=2 112 : MLREE2.PROG(I)=MLREE1.PROG(I)/W 113 : ELSE 114 : N0=1 115 : W2=W*W 116 : MLREE2.PROG(I)=MLREE1.PROG(I)/W2 117 : ENDIF 118 : ENDIF 119 : 15 CONTINUE 120 : C 121 : SEGINI KEVOLL 122 : IEVOLL(K)=KEVOLL 123 : IPROGX=IPFREQ 124 : IPROGY=IPRES 125 : NOMEVX='FREQUENCE' 126 : NOMEVY=ITITY(N0) 127 : NUMEVX=ICOUL1 128 : NUMEVY='REEL' 129 : TYPX='LISTREEL' 130 : TYPY='LISTREEL' 131 : TI(1:72)=TITREE 132 : IEVTEX=TI 133 : KEVTEX=TI 134 : 25 CONTINUE 135 : SEGDES KEVOLL 136 : SEGDES MLREE2 137 : SEGDES MLREEL 138 : SEGDES MLREE1 139 : 88 CONTINUE 140 : SEGDES MEVOLL 141 : SEGDES MEVOL1 142 : 142 : CALL ECROBJ ('EVOLUTIO',IPOEVO) 143 : RETURN 144 : END 145 : 146 : 147 : 148 : 149 : 150 : 151 : 152 : 153 : 154 :
© Cast3M 2003 - All rights reserved.
Disclaimer