1 : C PUISCP SOURCE CHAT 05/01/13 02:39:13 5004 2 : SUBROUTINE PUISCP(IPEV1,IPEV2,IRET,INV,ICOUL) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C 6 : C======================================================================= 7 : C = = 8 : C = APPELE PAR PUIS = 9 : C = = 10 : C = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LE PRODUIT OU LE = 11 : C = RAPPORT TERME A TERME DE DEUX OBJETS EVOLUTION DE SOUS-TYPE = 12 : C = COMPLEXE = 13 : C = = 14 : C = SYNTAXE : PROD = EVOLF * EVOLV (COUL) = 15 : C = = 16 : C = ON EXECUTE LE PRODUIT TERME A TERME DES ORDONNEES DES DEUX = 17 : C = OBJETS EVOLUTION DE SOUS-TYPE COMPLEXE EVOLF ET EVOLV. = 18 : C = LES ABSCISSES DE PROD, L'OBJET AINSI CREE, SONT CELLES = 19 : C = DE EVOLF ET EVOLV. = 20 : C = = 21 : C = = 22 : C = CREATION : 4/12/87 = 23 : C = F.ROULLIER = 24 : C = = 25 : C======================================================================= 26 : C 27 : -INC CCOPTIO 28 : -INC SMEVOLL 29 : -INC SMLREEL 30 : SEGMENT TEMPP 31 : IMPLIED DR(NPT),DI(NPT),DM(NPT),DP(NPT) 32 : IMPLIED AA(NPT),AB(NPT),BA(NPT),BB(NPT),DENOM(NPT) 33 : ENDSEGMENT 34 : C 35 : CHARACTER*72 TI 36 : CHARACTER*4 ITYP1,ITYP2 37 : C 38 : C LES 2 OBJETS EVOLUTION DOIVENT ETRE DE SOUS-TYPE COMPLEXE 39 : C 40 : MEVOL1=IPEV1 41 : MEVOL2=IPEV2 42 : SEGACT MEVOL1,MEVOL2 43 : ITYP1=MEVOL1.ITYEVO 44 : ITYP2=MEVOL1.ITYEVO 45 : IF (ITYP1.EQ.'COMP') GO TO 198 46 : 197 MOTERR(1:8)='EVOLUTIO' 46 : CALL ERREUR(302) 47 : SEGDES MEVOL1,MEVOL2 48 : RETURN 49 : C 50 : C BOUCLE SUR LES COURBES 51 : C 52 : 198 NC1=MEVOL1.IEVOLL(/1) 53 : NC2=MEVOL2.IEVOLL(/1) 54 : IF(NC1.NE.NC2) THEN 54 : CALL ERREUR(111) 55 : RETURN 56 : ENDIF 57 : NC=NC1 58 : C 59 : C CREATION DE L'OBJET PRODUIT DE TYPE EVOLUTION (COMPLEXE) 60 : C 61 : N=NC1 62 : SEGINI MEVOLL 63 : IRET=MEVOLL 64 : TI(1:72)=TITREE 65 : IEVTEX=TI 66 : ITYEVO=MEVOL1.ITYEVO 67 : C 68 : DO 201 IC=1,NC,2 69 : KEVOL1=MEVOL1.IEVOLL(IC) 70 : KEVOL2=MEVOL2.IEVOLL(IC) 71 : SEGACT KEVOL1,KEVOL2 72 : C 73 : C TEST DES SOUS-TYPES 74 : C 75 : ITYP1=KEVOL1.NUMEVY 76 : ITYP2=KEVOL2.NUMEVY 77 : C 78 : MLREE1=KEVOL1.IPROGX 79 : MLREE2=KEVOL2.IPROGX 80 : C 81 : C TEST DES LONGUEURS DES 2 SOUS-OBJETS EVOLUTION 82 : C 83 : SEGACT MLREE1,MLREE2 84 : L1=MLREE1.PROG(/1) 85 : L2=MLREE2.PROG(/1) 86 : IF(L1.EQ.L2) GO TO 10 86 : CALL ERREUR(337) 87 : GOTO 400 88 : 10 CONTINUE 89 : C 90 : C LES ABSCISSES DOIVENT ETRE IDENTIQUES 91 : C 91 : CALL VERIPR(MLREE1.PROG,MLREE2.PROG,L1,IRETOU,1.D-2) 92 : IF(IRETOU.NE.0) GO TO 11 92 : CALL ERREUR(394) 93 : GO TO 400 94 : 11 CONTINUE 95 : SEGDES MLREE1,MLREE2 96 : C 97 : C DEFINITION DES PARAMETRES POUR IC 98 : C 99 : SEGINI KEVOLL 100 : IEVOLL(IC)=KEVOLL 101 : TYPX='LISTREEL' 102 : TYPY='LISTREEL' 103 : KEVTEX=TI 104 : C 105 : NOMEVX=KEVOL1.NOMEVX 106 : NOMEVY=KEVOL1.NOMEVY 107 : NUMEVX=ICOUL 108 : NUMEVY=KEVOL1.NUMEVY 109 : C 110 : C DEFINITION DE PROGX POUR IC 111 : C 112 : MLREE1=KEVOL1.IPROGX 113 : SEGACT MLREE1 114 : JG=L1 115 : SEGINI MLREEL 116 : IPROGX=MLREEL 117 : DO 20 I=1,L1 118 : PROG(I)=MLREE1.PROG(I) 119 : 20 CONTINUE 120 : SEGDES KEVOLL,MLREEL,MLREE1 121 : SEGDES KEVOL1 122 : C 123 : C DEFINITION DES PARAMETRES POUR IC+1 124 : C 125 : SEGINI KEVOLL 126 : TYPX='LISTREEL' 127 : TYPY='LISTREEL' 128 : IEVOLL(IC+1)=KEVOLL 129 : KEVOL1=MEVOL1.IEVOLL(IC+1) 130 : SEGACT KEVOL1 131 : MLREE1=KEVOL1.IPROGX 132 : SEGACT MLREE1 133 : KEVTEX=TI 134 : C 135 : NOMEVX=KEVOL1.NOMEVX 136 : NOMEVY=KEVOL1.NOMEVY 137 : NUMEVX=ICOUL 138 : NUMEVY=KEVOL1.NUMEVY 139 : C 140 : C DEFINITION DE PROGX POUR IC+1 141 : C 142 : JG=L1 143 : SEGINI MLREEL 144 : IPROGX=MLREEL 145 : DO 21 I=1,L1 146 : PROG(I)=MLREE1.PROG(I) 147 : 21 CONTINUE 148 : SEGDES KEVOLL,MLREEL,KEVOL1,KEVOL2 149 : C 150 : C 151 : NPT=L1 152 : C 153 : C 154 : IF (ITYP1.EQ.'MODU') GO TO 200 155 : C 156 : SEGINI TEMPP 157 : KEVOL1=MEVOL1.IEVOLL(IC) 158 : SEGACT KEVOL1 159 : MLREE1=KEVOL1.IPROGY 160 : SEGACT MLREE1 161 : DO 100 I=1,L1 162 : AB(I)=MLREE1.PROG(I) 163 : 100 CONTINUE 164 : SEGDES KEVOL1,MLREE1 165 : C 166 : KEVOL1=MEVOL1.IEVOLL(IC+1) 167 : SEGACT KEVOL1 168 : MLREE1=KEVOL1.IPROGY 169 : SEGACT MLREE1 170 : DO 120 I=1,L1 171 : BB(I)=MLREE1.PROG(I) 172 : 120 CONTINUE 173 : SEGDES KEVOL1,MLREE1 174 : C 175 : KEVOL1=MEVOL2.IEVOLL(IC) 176 : KEVOL2=MEVOL2.IEVOLL(IC+1) 177 : SEGACT KEVOL1,KEVOL2 178 : MLREE1=KEVOL1.IPROGY 179 : MLREE2=KEVOL2.IPROGY 180 : SEGACT MLREE1,MLREE2 181 : IF (ITYP2.EQ.'MODU') THEN 182 : DO 130 I=1,L1 183 : DM(I)=MLREE1.PROG(I) 184 : DP(I)=MLREE2.PROG(I) 185 : 130 CONTINUE 185 : CALL CONVCP(DR,DI,DM,DP,L1,-1) 186 : ELSE 187 : DO 131 I=1,L1 188 : DR(I)=MLREE1.PROG(I) 189 : DI(I)=MLREE2.PROG(I) 190 : 131 CONTINUE 191 : ENDIF 192 : DO 140 I=1,L1 193 : AA(I)=AB(I)*DR(I) 194 : AB(I)=AB(I)*DI(I) 195 : BA(I)=BB(I)*DR(I) 196 : BB(I)=BB(I)*DI(I) 197 : 140 CONTINUE 198 : IF (INV.EQ.1) GO TO 142 199 : DO 143 I=1,L1 200 : A=MLREE1.PROG(I) 201 : B=MLREE2.PROG(I) 202 : DENOM(I)=A*A+B*B 203 : 143 CONTINUE 204 : 142 CONTINUE 205 : SEGDES KEVOL1,KEVOL2,MLREE1,MLREE2 206 : C 207 : C 208 : KEVOLL=MEVOLL.IEVOLL(IC) 209 : SEGACT KEVOLL*MOD 210 : JG=L1 211 : SEGINI MLREEL 212 : IPROGY=MLREEL 213 : C 214 : IF(INV.EQ.1) THEN 215 : DO 30 I=1,L1 216 : PROG(I)=AA(I)-BB(I) 217 : 30 CONTINUE 218 : ELSE 219 : DO 31 I=1,L1 220 : IF(DENOM(I).GT.1.D-20) THEN 221 : PROG(I)=(AA(I)+BB(I))/DENOM(I) 222 : ELSE 223 : WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION', 224 : & 'DIVISEUR : RESULTAT MIS A 0' 225 : PROG(I)=0.D0 226 : GOTO 31 227 : ENDIF 228 : 31 CONTINUE 229 : ENDIF 230 : C 231 : SEGDES KEVOLL,MLREEL 232 : C 233 : KEVOLL=MEVOLL.IEVOLL(IC+1) 234 : SEGACT KEVOLL*MOD 235 : JG=L1 236 : SEGINI MLREEL 237 : IPROGY=MLREEL 238 : C 239 : C 240 : IF(INV.EQ.1) THEN 241 : DO 32 I=1,L1 242 : PROG(I)=AB(I)+BA(I) 243 : 32 CONTINUE 244 : ELSE 245 : DO 33 I=1,L1 246 : IF(DENOM(I).GT.1.D-20) THEN 247 : PROG(I)=(BA(I)-AB(I))/DENOM(I) 248 : ELSE 249 : WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION', 250 : & 'DIVISEUR : RESULTAT MIS A 0' 251 : PROG(I)=0.D0 252 : GOTO 33 253 : ENDIF 254 : 33 CONTINUE 255 : ENDIF 256 : C 257 : SEGSUP TEMPP 258 : SEGDES KEVOLL,KEVOL1,KEVOL2 259 : C 260 : GO TO 201 261 : 200 CONTINUE 262 : SEGINI TEMPP 263 : KEVOL1=MEVOL1.IEVOLL(IC) 264 : KEVOL2=MEVOL1.IEVOLL(IC+1) 265 : SEGACT KEVOL1,KEVOL2 266 : MLREE1=KEVOL1.IPROGY 267 : MLREE2=KEVOL2.IPROGY 268 : SEGACT MLREE1,MLREE2 269 : DO 210 I=1,L1 270 : AA(I)=MLREE1.PROG(I) 271 : BB(I)=MLREE2.PROG(I) 272 : 210 CONTINUE 273 : SEGDES KEVOL1,MLREE1 274 : SEGDES KEVOL2,MLREE2 275 : C 276 : KEVOL1=MEVOL2.IEVOLL(IC) 277 : KEVOL2=MEVOL2.IEVOLL(IC+1) 278 : SEGACT KEVOL1,KEVOL2 279 : MLREE1=KEVOL1.IPROGY 280 : MLREE2=KEVOL2.IPROGY 281 : SEGACT MLREE1,MLREE2 282 : IF (ITYP2.EQ.'PREE') THEN 283 : DO 230 I=1,L1 284 : DR(I)=MLREE1.PROG(I) 285 : DI(I)=MLREE2.PROG(I) 286 : 230 CONTINUE 286 : CALL CONVCP(DR,DI,DM,DP,L1,1) 287 : ELSE 288 : DO 231 I=1,L1 289 : DM(I)=MLREE1.PROG(I) 290 : DP(I)=MLREE2.PROG(I) 291 : 231 CONTINUE 292 : ENDIF 293 : IF (INV.EQ.1) THEN 294 : DO 240 I=1,L1 295 : AA(I)=AA(I)*DM(I) 296 : BB(I)=BB(I)+DP(I) 297 : 240 CONTINUE 298 : ELSE 299 : DO 243 I=1,L1 300 : IF(DM(I).GT.1.D-20) THEN 301 : AA(I)=AA(I)/DM(I) 302 : ELSE 303 : WRITE(IOIMP,*)' VALEURS NULLES DANS L OBJET EVOLUTION', 304 : & 'DIVISEUR : RESULTAT MIS A 0' 305 : AA(I)=0.D0 306 : ENDIF 307 : BB(I)=BB(I)-DP(I) 308 : 243 CONTINUE 309 : ENDIF 310 : DO 244 I=1,L1 311 : IF (BB(I).GT.180.D0) THEN 312 : BB(I)=BB(I)-360.D0 313 : ELSE IF(BB(I).LT.-180.D0) THEN 314 : BB(I)=BB(I)+360.D0 315 : ENDIF 316 : 244 CONTINUE 317 : SEGDES KEVOL1,KEVOL2,MLREE1,MLREE2 318 : C 319 : KEVOLL=MEVOLL.IEVOLL(IC) 320 : SEGACT KEVOLL*MOD 321 : JG=L1 322 : SEGINI MLREEL 323 : IPROGY=MLREEL 324 : C 325 : DO 330 I=1,L1 326 : PROG(I)=AA(I) 327 : 330 CONTINUE 328 : SEGDES KEVOLL,MLREEL 329 : C 330 : KEVOLL=MEVOLL.IEVOLL(IC+1) 331 : SEGACT KEVOLL*MOD 332 : SEGINI MLREEL 333 : IPROGY=MLREEL 334 : C 335 : DO 332 I=1,L1 336 : PROG(I)=BB(I) 337 : 332 CONTINUE 338 : SEGDES MLREEL 339 : C 340 : SEGSUP TEMPP 341 : SEGDES KEVOLL,KEVOL1,KEVOL2 342 : C 343 : SEGDES MEVOLL,MEVOL1,MEVOL2 344 : 201 CONTINUE 345 : C 346 : 400 CONTINUE 347 : RETURN 348 : END 349 : 350 : 351 : 352 : 353 :
© Cast3M 2003 - All rights reserved.
Disclaimer