Télécharger operpu.eso

Retour à la liste

Numérotation des lignes :

  1. C OPERPU SOURCE CB215821 16/11/28 21:15:14 9202
  2. SUBROUTINE OPERPU
  3. C_______________________________________________________________________
  4. C
  5. C ELEVE UN NOMBRE A UNE PUISSANCE
  6. C
  7. C
  8. C PASCAL MANIGOT (12/03/85) :
  9. C REPRISE DE LA PROGRAMMATION POUR PERMETTRE LE CALCUL DE
  10. C "REEL ** ENTIER" (NOTAMMENT QUAND "REEL" EST NEGATIF).
  11. C
  12. C EBERSOLT (2 MAI 85) : REPRISE POUR PERMETTRE LE CALCUL DE
  13. C CHPO ** I2 OU DE CHEL ** I2
  14. C CHPO ** X2 OU DE CHEL ** X2
  15. C rem : DANS LE CAS OU UNE DES COMPOSANTES DU CHAMP EST
  16. C EST NEGATIVE ET SI L EXPOSANT EST REEL
  17. C ON MET LE RESULTAT A ZERO (au lieu de NAN ou erreur)
  18. C
  19. C BEAUFILS (20 MAI 87) : REPRISE POUR PERMETTRE LE CALCUL DE
  20. C LISTREEL ** I2 OU LISTREEL ** X2
  21. C
  22. C JM CAMPENON (12/90) : PASSAGE AUX NOUVEAUX CHAMELEM
  23. C
  24. C S PASCAL (06/2006) :
  25. C -Puissance d'un MCHAML de composante de type EVOLUTION
  26. C -Puissance d'un objet EVOLUTION
  27. C
  28. C BP (12/2010) concernant les LISTREELs et les EVOLUTIONs :
  29. C -reprise pour permettre la puissance entiere des EVOLUTIONs
  30. C -moins de mise a zero intempestives et + de valeurs "justes"
  31. C -avertissement si présence d'INF
  32. C
  33. C CB (02/2015)
  34. C - ajout de toutes les operations valides sur les LISTENTI
  35. C - ajout de la possibilité de faire CHPOINT ** CHPOINT
  36. C - ajout d'une erreur pour I1 ** -I2 avec 2 INTEGER comme arguments
  37. C
  38. C_______________________________________________________________________
  39. C
  40. IMPLICIT INTEGER(I-N)
  41. IMPLICIT REAL*8 (A-H,O-Z)
  42. -INC CCOPTIO
  43. -INC CCREEL
  44. -INC SMLENTI
  45. -INC SMLREEL
  46.  
  47.  
  48. CHARACTER*8 CTYP
  49.  
  50.  
  51. C_______________________________________________________________________
  52. C
  53. C RECHERCHE DU TYPE DU PREMIER ARGUMENT
  54. C_______________________________________________________________________
  55. CALL QUETYP(CTYP,0,IRETOU)
  56.  
  57. C_______________________________________________________________________
  58. C
  59. C ENTIER ** ENTIER
  60. C_______________________________________________________________________
  61. CALL LIRENT(I1,0,IRETOU)
  62. IF (IRETOU.EQ.0) GOTO 2
  63. CALL LIRENT(I2,0,IRETOU)
  64. IF (IRETOU.EQ.0) THEN
  65. CALL REFUS
  66. GOTO 2
  67. ENDIF
  68. C Cas de la puissance de 2 ENTIERS
  69. IF ((I1 .EQ. 0) .AND. (I2 .LT. 0)) THEN
  70. INTERR(1)=I1
  71. INTERR(2)=I2
  72. MOTERR(1:4)=' ** '
  73. CALL ERREUR(1059)
  74. ELSE
  75. CALL ECRENT(I1**I2)
  76. ENDIF
  77. RETURN
  78. C
  79. 2 CONTINUE
  80. C_______________________________________________________________________
  81. C
  82. C FLOTTANT ** ENTIER
  83. C_______________________________________________________________________
  84. CALL LIRENT(I1,0,IRETOU)
  85. IF (IRETOU.EQ.0) GOTO 3
  86. CALL LIRREE(FLO1,0,IRETOU)
  87. IF (IRETOU.EQ.0) THEN
  88. CALL REFUS
  89. GOTO 3
  90. ENDIF
  91. IF ( CTYP .EQ. 'ENTIER') THEN
  92. C Cas ENTIER ** FLOTTANT
  93. C Verification si puissance ENTIERE possible
  94. I2 = NINT(FLO1)
  95. XFLOT = ABS(FLO1 - REAL(I2))
  96. IF ( XFLOT .LE. (XZPREC*ABS(FLO1)*REAL(2.D0))) THEN
  97. XFLOT=REAL(I1)**I2
  98. CALL ECRREE(XFLOT)
  99.  
  100. ELSEIF (I1 .LT. 0 ) THEN
  101. INTERR(1)=I1
  102. REAERR(1)=FLO1
  103. MOTERR(1:4)=' ** '
  104. CALL ERREUR(1061)
  105. ELSE
  106. XFLOT=REAL(I1)**FLO1
  107. CALL ECRREE(XFLOT)
  108. ENDIF
  109.  
  110. ELSE
  111. C Cas FLOTTANT ** ENTIER
  112. IF(ABS(FLO1).LT.XPETIT .AND. I1.LT.0)THEN
  113. REAERR(1)=FLO1
  114. INTERR(1)=I1
  115. MOTERR(1:4)=' ** '
  116. CALL ERREUR(1060)
  117. ELSE
  118. XFLOT=FLO1**I1
  119. CALL ECRREE(XFLOT)
  120. ENDIF
  121. ENDIF
  122. RETURN
  123. C
  124. 3 CONTINUE
  125. C_______________________________________________________________________
  126. C
  127. C FLOTTANT ** FLOTTANT
  128. C_______________________________________________________________________
  129. CALL LIRREE(FLO1,0,IRETOU)
  130. IF (IRETOU.EQ.0) GOTO 4
  131. CALL LIRREE(FLO2,0,IRETOU)
  132. IF (IRETOU.EQ.0) THEN
  133. CALL REFUS
  134. GOTO 4
  135. ENDIF
  136.  
  137. IF ((ABS(FLO1).LT.XPETIT .AND. FLO2.LT.REAL(0.D0))) THEN
  138. REAERR(1)=FLO1
  139. REAERR(2)=FLO2
  140. MOTERR(1:4)=' ** '
  141. CALL ERREUR(1062)
  142. ELSE
  143. C Verification si puissance ENTIERE possible
  144. I2 = NINT(FLO2)
  145. XFLOT = ABS(FLO2 - REAL(I2))
  146. IF ( XFLOT .LE. (XZPREC*ABS(FLO2)*REAL(2.D0))) THEN
  147. XFLOT=FLO1**I2
  148. CALL ECRREE(XFLOT)
  149. ELSEIF(FLO1 .LT. REAL(0.D0))THEN
  150. REAERR(1)=FLO1
  151. REAERR(2)=FLO2
  152. MOTERR(1:4)=' ** '
  153. CALL ERREUR(1062)
  154. ELSE
  155. XFLOT=FLO1**FLO2
  156. CALL ECRREE(XFLOT)
  157. ENDIF
  158. ENDIF
  159. RETURN
  160. C
  161. 4 CONTINUE
  162. C_______________________________________________________________________
  163. C
  164. C MCHAML ** ENTIER
  165. C_______________________________________________________________________
  166. CALL LIRENT(I1,0,IRETOU)
  167. IF (IRETOU.EQ.0) GOTO 5
  168. CALL LIROBJ('MCHAML',ICH1,0,IRETOU)
  169. IF (IRETOU.EQ.0) THEN
  170. CALL REFUS
  171. GOTO 5
  172. ENDIF
  173. C IOPERA= 1 pour l'operation PUISSANCE
  174. IOPERA= 1
  175. IF (CTYP .EQ. 'MCHAML') THEN
  176. C IARGU = 1 pour MCHAML ** ENTIER
  177. IARGU = 1
  178. ELSE
  179. C IARGU = 11 pour ENTIER ** MCHAML (terme a terme)
  180. IARGU = 11
  181. ENDIF
  182. FLO = REAL(0.D0)
  183. CALL OPCHE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  184. IF(IRET.NE.0) THEN
  185. CALL ECROBJ('MCHAML',ICHR)
  186. ELSE
  187. CALL ERREUR(26)
  188. ENDIF
  189. RETURN
  190.  
  191. 5 CONTINUE
  192. C_______________________________________________________________________
  193. C
  194. C CHPOINT ** ENTIER
  195. C_______________________________________________________________________
  196. CALL LIRENT(I1,0,IRETOU)
  197. IF (IRETOU.EQ.0) GOTO 6
  198. CALL LIROBJ('CHPOINT',ICH1,0,IRETOU)
  199. IF (IRETOU.EQ.0) THEN
  200. CALL REFUS
  201. GOTO 6
  202. ENDIF
  203. C IOPERA= 1 pour l'operation PUISSANCE
  204. IOPERA= 1
  205. IF (CTYP .EQ. 'CHPOINT') THEN
  206. C IARGU = 1 pour CHPOINT ** ENTIER
  207. IARGU = 1
  208. ELSE
  209. C IARGU = 11 pour ENTIER ** CHPOINT (terme a terme)
  210. IARGU = 11
  211. ENDIF
  212. FLO = REAL(0.D0)
  213. CALL OPCHP1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  214. IF(IRET.NE.0) THEN
  215. CALL ECROBJ('CHPOINT',ICHR)
  216. ELSE
  217. CALL ERREUR(26)
  218. ENDIF
  219. RETURN
  220. C
  221. 6 CONTINUE
  222. C_______________________________________________________________________
  223. C
  224. C MCHAML ** FLOTTANT
  225. C_______________________________________________________________________
  226. CALL LIRREE(FLO,0,IRETOU)
  227. IF (IRETOU.EQ.0) GOTO 7
  228. CALL LIROBJ('MCHAML',ICH1,0,IRETOU)
  229. IF (IRETOU.EQ.0) THEN
  230. CALL REFUS
  231. GOTO 7
  232. ENDIF
  233. C IOPERA= 1 pour l'operation PUISSANCE
  234. IOPERA= 1
  235. IF (CTYP .EQ. 'MCHAML') THEN
  236. C IARGU = 2 pour MCHAML ** FLOTTANT
  237. IARGU = 2
  238. ELSE
  239. C IARGU = 21 pour FLOTTANT ** MCHAML (terme a terme)
  240. IARGU = 21
  241. ENDIF
  242. I1 = 0
  243. CALL OPCHE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  244. IF(IRET.NE.0) THEN
  245. CALL ECROBJ('MCHAML',ICHR)
  246. ELSE
  247. CALL ERREUR(26)
  248. ENDIF
  249. RETURN
  250. C
  251. 7 CONTINUE
  252. C_______________________________________________________________________
  253. C
  254. C CHPOINT**FLOTTANT
  255. C_______________________________________________________________________
  256. CALL LIRREE(FLO,0,IRETOU)
  257. IF (IRETOU.EQ.0) GOTO 8
  258. CALL LIROBJ('CHPOINT',ICH1,0,IRETOU)
  259. IF (IRETOU.EQ.0) THEN
  260. CALL REFUS
  261. GOTO 8
  262. ENDIF
  263. C IOPERA= 1 pour l'operation PUISSANCE
  264. IOPERA= 1
  265. IF (CTYP .EQ. 'CHPOINT') THEN
  266. C IARGU = 2 pour CHPOINT ** FLOTTANT
  267. IARGU = 2
  268. ELSE
  269. C IARGU = 21 pour FLOTTANT ** CHPOINT (terme a terme)
  270. IARGU = 21
  271. ENDIF
  272. I1 = 0
  273. CALL OPCHP1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  274. IF(IRET.NE.0) THEN
  275. CALL ECROBJ('CHPOINT',ICHR)
  276. ELSE
  277. CALL ERREUR(26)
  278. ENDIF
  279. RETURN
  280. C
  281. 8 CONTINUE
  282. C_______________________________________________________________________
  283. C
  284. C LISTREEL**ENTIER
  285. C_______________________________________________________________________
  286. CALL LIRENT(I1,0,IRETOU)
  287. IF (IRETOU.EQ.0) GOTO 9
  288. CALL LIROBJ('LISTREEL',ICH,0,IRETOU)
  289. IF (IRETOU.EQ.0) THEN
  290. CALL REFUS
  291. GOTO 9
  292. ENDIF
  293. C Puissance entre LISTREEL et ENTIER
  294. C IOPERA= 1 pour l'operation PUISSANCE
  295. IOPERA= 1
  296. IF (CTYP .EQ. 'LISTREEL') THEN
  297. C IARGU = 1 pour LISTREEL ** ENTIER
  298. IARGU = 1
  299. ELSE
  300. C IARGU = 11 pour ENTIER ** LISTREEL (terme a terme)
  301. IARGU = 11
  302. ENDIF
  303. FLO = REAL(0.D0)
  304. ICHR = 0
  305. CALL OPLRE1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  306. IF(IRET.NE.0) THEN
  307. CALL ECROBJ('LISTREEL',ICHR)
  308. ELSE
  309. CALL ERREUR(26)
  310. ENDIF
  311. RETURN
  312. C
  313. 9 CONTINUE
  314. C_______________________________________________________________________
  315. C
  316. C LISTREEL**FLOTTANT
  317. C_______________________________________________________________________
  318. CALL LIRREE(FLO,0,IRETOU)
  319. IF (IRETOU.EQ.0) GOTO 10
  320. CALL LIROBJ('LISTREEL',ICH,0,IRETOU)
  321. IF (IRETOU.EQ.0) THEN
  322. CALL REFUS
  323. GOTO 10
  324. ENDIF
  325. C Puissance entre LISTREEL et FLOTTANT
  326. C IOPERA= 1 pour l'operation PUISSANCE
  327. IOPERA= 1
  328. IF (CTYP .EQ. 'LISTREEL') THEN
  329. C IARGU = 2 pour LISTREEL ** FLOTTANT
  330. IARGU = 2
  331. ELSE
  332. C IARGU = 21 pour FLOTTANT ** LISTREEL (terme a terme)
  333. IARGU = 21
  334. ENDIF
  335. I1 = 0
  336. ICHR = 0
  337. CALL OPLRE1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  338. IF(IRET.NE.0) THEN
  339. CALL ECROBJ('LISTREEL',ICHR)
  340. ELSE
  341. CALL ERREUR(26)
  342. ENDIF
  343. RETURN
  344. C
  345. 10 CONTINUE
  346. C_______________________________________________________________________
  347. C
  348. C EVOLUTION**ENTIER
  349. C_______________________________________________________________________
  350. CALL LIRENT(I1,0,IRETOU)
  351. IF (IRETOU.EQ.0) GOTO 11
  352. CALL LIROBJ('EVOLUTIO',ICH,0,IRETOU)
  353. IF (IRETOU.EQ.0) THEN
  354. CALL REFUS
  355. GOTO 11
  356. ENDIF
  357. C IOPERA= 1 pour l'operation PUISSANCE
  358. IOPERA= 1
  359. IF (CTYP .EQ. 'EVOLUTIO') THEN
  360. C IARGU = 1 pour EVOLUTIO ** ENTIER
  361. IARGU = 1
  362. ELSE
  363. C IARGU = 11 pour ENTIER ** EVOLUTIO
  364. IARGU = 11
  365. ENDIF
  366. FLO = REAL(0.D0)
  367. CALL OPEVO1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  368. IF(IRET.NE.0) THEN
  369. CALL ECROBJ('EVOLUTIO',ICHR)
  370. ELSE
  371. CALL ERREUR(26)
  372. ENDIF
  373. RETURN
  374. C
  375. 11 CONTINUE
  376. C_______________________________________________________________________
  377. C
  378. C EVOLUTION**FLOTTANT
  379. C_______________________________________________________________________
  380. CALL LIRREE(FLO,0,IRETOU)
  381. IF (IRETOU.EQ.0) GOTO 12
  382. CALL LIROBJ('EVOLUTIO',ICH,0,IRETOU)
  383. IF (IRETOU.EQ.0) THEN
  384. CALL REFUS
  385. GOTO 12
  386. ENDIF
  387. C IOPERA= 1 pour l'operation PUISSANCE
  388. IOPERA= 1
  389. IF (CTYP .EQ. 'EVOLUTIO') THEN
  390. C IARGU = 2 pour EVOLUTIO ** FLOTTANT
  391. IARGU = 2
  392. ELSE
  393. C IARGU = 21 pour FLOTTANT ** EVOLUTIO
  394. IARGU = 21
  395. ENDIF
  396. I1 = 0
  397. CALL OPEVO1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  398. IF(IRET.NE.0) THEN
  399. CALL ECROBJ('EVOLUTIO',ICHR)
  400. ELSE
  401. CALL ERREUR(26)
  402. ENDIF
  403. RETURN
  404. C
  405. 12 CONTINUE
  406. C_______________________________________________________________________
  407. C
  408. C LISTENTI**ENTIER
  409. C_______________________________________________________________________
  410. CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  411. IF(IRETOU.EQ.0) GOTO 13
  412. CALL LIRENT(IVA,0,IRETOU)
  413. IF (IRETOU.EQ.0) THEN
  414. CALL REFUS
  415. GOTO 13
  416. ENDIF
  417. SEGACT MLENT1
  418. JG=MLENT1.LECT(/1)
  419. SEGINI MLENTI
  420. DO 120 I=1,JG
  421. ITRA=MLENT1.LECT(I)
  422. IF ((ITRA .EQ. 0) .AND. (IVA .LT. 0)) THEN
  423. INTERR(1)=ITRA
  424. INTERR(2)=IVA
  425. MOTERR(1:4)=' ** '
  426. CALL ERREUR(1059)
  427. RETURN
  428. ELSE
  429. LECT(I)=ITRA**IVA
  430. ENDIF
  431. 120 CONTINUE
  432. SEGDES MLENTI,MLENT1
  433. CALL ECROBJ('LISTENTI',MLENTI)
  434. RETURN
  435. C
  436. 13 CONTINUE
  437. C_______________________________________________________________________
  438. C
  439. C LISTENTI**FLOTTANT
  440. C_______________________________________________________________________
  441. CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  442. IF(IRETOU.EQ.0) GOTO 14
  443. CALL LIRREE(XVA,0,IRETOU)
  444. IF (IRETOU.EQ.0) THEN
  445. CALL REFUS
  446. GOTO 14
  447. ENDIF
  448. SEGACT MLENT1
  449. JG=MLENT1.LECT(/1)
  450. SEGINI MLREEL
  451. DO 130 I=1,JG
  452. I1=MLENT1.LECT(I)
  453. C Verification si puissance ENTIERE possible
  454. I2 = NINT(XVA)
  455. XFLOT = ABS(XVA - REAL(I2))
  456. IF ( XFLOT .LE. (XZPREC*ABS(XVA)*REAL(2.D0))) THEN
  457. PROG(I)=REAL(I1)**I2
  458.  
  459. ELSEIF (I1 .LT. 0 ) THEN
  460. INTERR(1)=I1
  461. REAERR(1)=XVA
  462. MOTERR(1:4)=' ** '
  463. CALL ERREUR(1061)
  464. RETURN
  465. ELSE
  466. PROG(I)=REAL(I1)**XVA
  467. ENDIF
  468. 130 CONTINUE
  469. SEGDES MLREEL,MLENT1
  470. CALL ECROBJ('LISTREEL',MLREEL)
  471. RETURN
  472.  
  473. C_______________________________________________________________________
  474. C
  475. C LISTREEL**LISTREEL
  476. C_______________________________________________________________________
  477. 14 CALL LIROBJ('LISTREEL',ICH,0,IRETOU)
  478. IF(IRETOU.EQ.0) GOTO 15
  479. CALL LIROBJ('LISTREEL',ICHR,0,IRETOU)
  480. IF(IRETOU.EQ.0) THEN
  481. CALL REFUS
  482. GO TO 15
  483. ENDIF
  484.  
  485. C Puissance entre LISTREEL et LISTREEL terme a terme
  486. C IOPERA= 1 pour l'operation PUISSANCE
  487. C IARGU = 0 pour ne pas utiliser I1 et FLO
  488. IOPERA= 1
  489. IARGU = 0
  490. I1 = 0
  491. FLO = REAL(0.D0)
  492. CALL OPLRE1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  493. IF(IRET.NE.0) THEN
  494. CALL ECROBJ('LISTREEL',ICHR)
  495. ELSE
  496. CALL ERREUR(26)
  497. ENDIF
  498. RETURN
  499.  
  500. 15 CONTINUE
  501. C_______________________________________________________________________
  502. C
  503. C ON A DONC RIEN TROUVE POUR FAIRE L OPERATION
  504. C_______________________________________________________________________
  505. CALL QUETYP(MOTERR(1:8),0,IRETOU)
  506. IF(IRETOU.NE.0) THEN
  507. CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU)
  508. CALL QUETYP(MOTERR(9:16),0,IRETOU)
  509. IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? '
  510. CALL ERREUR(532)
  511. ELSE
  512. CALL ERREUR(533)
  513. ENDIF
  514. RETURN
  515. END
  516.  
  517.  

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