1 : C PUIS SOURCE PASCAL 10/01/08 21:15:10 6604 2 : SUBROUTINE PUIS(IPEV1,IPEV2,IRET,INV) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : CHARACTER *72 TI 6 : CHARACTER*4 ITYP1 7 : CHARACTER*12 MOTX 8 : CHARACTER*4 MOTY(8),MOTY1,MOTY2,MOTY3,MOTY4 9 : C 10 : C======================================================================= 11 : C = = 12 : C = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LE PRODUIT OU LE = 13 : C = RAPPORT TERME A TERME DE DEUX OBJETS EVOLUTIO = 14 : C = = 15 : C = SYNTAXE : PROD = EVOLF * EVOLV (COUL) = 16 : C = = 17 : C = ON EXECUTE LE PRODUIT TERME A TERME DES ORDONNEES DES DEUX = 18 : C = OBJETS DE TYPE EVOLUTIO EVOLF ET EVOLV. LES ABSCISSES DE PROD, = 19 : C = L'OBJET AINSI CREE, RESTENT CELLES DE EVOLF ET EVOLV. = 20 : C = = 21 : C = = 22 : C = = 23 : C = MEVOL1 : POINTEUR SUR MEVOLF (OBJET EVOLUTION) = 24 : C = MEVOL2 : POINTEUR SUR MEVOLV " " = 25 : C = KEVOL1 : POINTEUR SUR KEVOLF = 26 : C = KEVOL2 : POINTEUR SUR KEVOLV = 27 : C = MLREE1 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLF = 28 : C = MLREE2 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLV = 29 : C = = 30 : C = = 31 : C = ADAPTE AUX OBJETS "EVOLUTION" DE TYPE SOUS-TYPE "COMPLEXE" = 32 : C = PAR APPEL A PUISCP PAR F.ROULLIER 33 : C======================================================================= 34 : C 35 : -INC CCGEOME 36 : -INC CCOPTIO 37 : -INC SMEVOLL 38 : -INC SMLREEL 39 : -INC SMLMOTS 40 : POINTEUR MLREE4.MLREEL,MLREE5.MLREEL 41 : C 42 : DATA MOTY2,MOTY4/' * ',' / '/ 43 : DATA MOTY(1),MOTY(2),MOTY(3),MOTY(4)/'DEPL','VITE','ACCE','FORC'/ 44 : DATA MOTY(5),MOTY(6),MOTY(7),MOTY(8)/'BRUI','REEL','IMAG','LIAI'/ 45 : C 45 : CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0) 46 : IF(ICOUL.EQ.0) ICOUL=IDCOUL+1 47 : ICOUL=ICOUL-1 48 : C 49 : C LES 2 OBJETS EVOLUTION DOIVENT ETRE DE MEME LONGUEUR 50 : C L'UN EST UNE FORCE, L'AUTRE UNE VITESSE 51 : C 52 : MEVOL1=IPEV1 53 : SEGACT MEVOL1 54 : MEVOL2=IPEV2 55 : SEGACT MEVOL2 56 : C 57 : C TEST SUR LE SOUS-TYPE 58 : C 59 : ITYP1=MEVOL1.ITYEVO 60 : IF (ITYP1.NE.'COMP') GO TO 199 61 : SEGDES MEVOL1,MEVOL2 61 : CALL PUISCP(IPEV1,IPEV2,IRET,INV,ICOUL) 62 : RETURN 63 : 199 CONTINUE 64 : C 65 : C BOUCLE SUR LES COURBES, SI LES 2 EVOL EN ONT AUTANT 66 : C 67 : NC1=MEVOL1.IEVOLL(/1) 68 : NC2=MEVOL2.IEVOLL(/1) 69 : IF(NC1.EQ.NC2) GOTO 200 69 : CALL ERREUR(111) 70 : RETURN 71 : C 72 : 200 CONTINUE 73 : N=NC1 74 : SEGINI MEVOLL 75 : IRET=MEVOLL 76 : TI(1:72)=TITREE 77 : IEVTEX=TI 78 : ITYEVO='REEL' 79 : DO 201 IC=1,NC1 80 : C 81 : KEVOL1=MEVOL1.IEVOLL(IC) 82 : SEGACT KEVOL1 83 : DO 50 I=1,3 84 : DO 50 J=1,8 85 : IF(KEVOL1.NOMEVY(I*4-3:I*4).EQ.MOTY(J)) THEN 86 : MOTY1=KEVOL1.NOMEVY(I*4-3:I*4) 87 : GOTO 51 88 : ENDIF 89 : 50 CONTINUE 90 : MOTY1=KEVOL1.NOMEVY(1:4) 91 : C 92 : C 93 : 51 MLREE1=KEVOL1.IPROGY 94 : IF (KEVOL1.NUMEVY.NE.'REEL'.AND.KEVOL1.NUMEVY.NE.'HIST') GOTO 1000 95 : SEGACT MLREE1 96 : IF(KEVOL1.TYPY.NE.'LISTMOTS')THEN 97 : L1=MLREE1.PROG(/1) 98 : ELSE 99 : MLMOT1=KEVOL1.IPROGY 100 : SEGACT MLMOT1 101 : L1=MLMOT1.MOTS(/2) 102 : SEGDES MLMOT1 103 : ENDIF 104 : C 105 : KEVOL2=MEVOL2.IEVOLL(IC) 106 : SEGACT KEVOL2 107 : MOTX=KEVOL2.NOMEVX 108 : DO 52 I=1,3 109 : DO 52 J=1,8 110 : IF(KEVOL2.NOMEVY(I*4-3:I*4).EQ.MOTY(J)) THEN 111 : MOTY3=KEVOL2.NOMEVY(I*4-3:I*4) 112 : GOTO 53 113 : ENDIF 114 : 52 CONTINUE 115 : MOTY3=KEVOL2.NOMEVY(1:4) 116 : C 117 : C 118 : 53 MLREE2=KEVOL2.IPROGY 119 : IF (KEVOL2.NUMEVY.NE.'REEL'.AND.KEVOL2.NUMEVY.NE.'HIST') GOTO 1001 120 : SEGACT MLREE2 121 : IF(KEVOL2.TYPY.NE.'LISTMOTS')THEN 122 : L2=MLREE2.PROG(/1) 123 : ELSE 124 : MLMOT2=KEVOL2.IPROGY 125 : SEGACT MLMOT2 126 : L2=MLMOT2.MOTS(/2) 127 : SEGDES MLMOT2 128 : ENDIF 129 : C 130 : C LES LISTREEL ONT-ILS MEME LONGUEUR ? 131 : IF(L1.EQ.L2)GOTO 10 131 : CALL ERREUR(337) 132 : GOTO 100 133 : C 134 : C CREATION DE L'OBJET PROD DE TYPE EVOLUTIO 135 : C 136 : 10 CONTINUE 137 : SEGDES MLREE1 138 : SEGDES MLREE2 139 : C 140 : C LES LISTREEL DES ABSCISSES SONT ILS IDENTIQUES ? 141 : MLREE1=KEVOL1.IPROGX 142 : MLREE3=KEVOL2.IPROGX 143 : SEGACT MLREE1,MLREE3 143 : CALL VERIPR(MLREE1.PROG,MLREE3.PROG,L1,IRETOU,1.D-2) 144 : IF(IRETOU.EQ.0) THEN 144 : CALL ERREUR(394) 145 : RETURN 146 : ENDIF 147 : SEGDES MLREE1 148 : C 149 : MLREE1=KEVOL1.IPROGY 150 : MLREE2=KEVOL2.IPROGY 151 : SEGACT MLREE1,MLREE2,MLREE3 152 : SEGINI KEVOLL 153 : IEVOLL(IC)=KEVOLL 154 : TYPX='LISTREEL' 155 : TYPY='LISTREEL' 156 : KEVTEX=TI 157 : C 158 : NOMEVX=MOTX 159 : IF (INV.EQ.1) THEN 160 : NOMEVY=MOTY1//MOTY2//MOTY3 161 : ELSE 162 : NOMEVY=MOTY1//MOTY4//MOTY3 163 : ENDIF 164 : NUMEVX=ICOUL 165 : NUMEVY='REEL' 166 : C 167 : JG=L1 168 : SEGINI MLREE4 169 : IPROGX=MLREE4 170 : SEGINI MLREE5 171 : IPROGY=MLREE5 172 : C 173 : C 174 : C 175 : C 176 : IF(INV.EQ.1) THEN 177 : DO 20 I=1,L1 178 : FORC=MLREE1.PROG(I) 179 : VITE=MLREE2.PROG(I) 180 : TIM=MLREE3.PROG(I) 181 : C 182 : C TIM ET FORC*VITE FORMENT UN POINT DE L'OBJET EVOL CREE PAR * 183 : C 184 : MLREE4.PROG(I)=TIM 185 : MLREE5.PROG(I)=VITE*FORC 186 : C 187 : 20 CONTINUE 188 : ELSE 189 : DO 21 I=1,L1 190 : FORC=MLREE1.PROG(I) 191 : VITE=MLREE2.PROG(I) 192 : TIM=MLREE3.PROG(I) 193 : C 194 : C TIM ET FORC/VITE FORMENT UN POINT DE L'OBJET EVOL CREE PAR * 195 : C 196 : MLREE4.PROG(I)=TIM 197 : IF(ABS(VITE).GT.1.E-20) THEN 198 : MLREE5.PROG(I)=FORC/VITE 199 : ELSE 200 : WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION', 201 : & 'DIVISEUR : RESULTAT MIS A 0' 202 : MLREE5.PROG(I)=0.D0 203 : GOTO 21 204 : ENDIF 205 : C 206 : 21 CONTINUE 207 : ENDIF 208 : C 209 : C DESACTIVE LES LISTREEL 210 : C 211 : SEGDES MLREE4,MLREE5 212 : SEGDES MLREE3,MLREE1,MLREE2 213 : C 214 : C DESACTIVE LES KEVOL 215 : C 216 : SEGDES KEVOLL 217 : SEGDES KEVOL1,KEVOL2 218 : C 219 : 201 CONTINUE 220 : C 221 : C DESACTIVE LES MEVOL 222 : C 223 : SEGDES MEVOLL 224 : SEGDES MEVOL1,MEVOL2 225 : C 226 : 100 CONTINUE 227 : RETURN 228 : 1000 CONTINUE 229 : moterr(1:8 )='EVOLUTIO' 230 : moterr(9:13)=KEVOL1.NUMEVY 230 : call erreur(131) 231 : return 232 : 1001 CONTINUE 233 : moterr(1:8 )='EVOLUTIO' 234 : moterr(9:13)=KEVOL2.NUMEVY 234 : call erreur(131) 235 : RETURN 236 : 237 : 238 : END 239 : 240 : 241 : 242 : 243 : 244 : 245 : 246 : 247 : 248 :
© Cast3M 2003 - All rights reserved.
Disclaimer