Télécharger operpu.eso

Retour à la liste

Numérotation des lignes :

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

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