Télécharger opermu.eso

Retour à la liste

Numérotation des lignes :

  1. C OPERMU SOURCE CB215821 16/11/28 21:15:13 9202
  2. SUBROUTINE OPERMU
  3. C_______________________________________________________________________
  4. C
  5. C multiplie un champ par point par un objet rigidite.
  6. C multiplie un listreel par un flottant (ou un entier)
  7. C multiplie un listreel par un listreel terme a terme.
  8. C multiplie un objet rigidite par un flottant (ou 1 entier)
  9. C multiplie un champs par elemt par un flottant (ou 1 entier)
  10. C multiplie un champ par element par un autre champ par element
  11. C multiplie un champ par element par une evolution
  12. C multiplie un champ par point par un autre champ par point
  13. C multiplie un champ par point par un flottant (ou 1 entier)
  14. C multiplie un champ par point par une evolution
  15. C multiplie 2 nombres (flottant ou entier)
  16. C multiplie un point par un nombre
  17. C multiplie un objet evolutio (ordonnees) par un flottant
  18. C (ou un entier)
  19. C multiplie un objet evolutio par un objet evolutio
  20. C multiplie une table soustype vecteur par un reel
  21. C multiplie une table soustype LIAISONS_STATIQUES ou
  22. C BASE_DE_MODES par une rigidite
  23. C
  24. C passage aux nouveaux MCHAML par jm campenon le 29 10 90
  25. C
  26. C_______________________________________________________________________
  27. C
  28. IMPLICIT INTEGER(I-N)
  29. IMPLICIT REAL*8 (A-H,O-Z)
  30. -INC CCOPTIO
  31. -INC SMCOORD
  32. -INC SMLENTI
  33. -INC SMLREEL
  34. -INC SMTABLE
  35.  
  36. C_______________________________________________________________________
  37. C
  38. C produit de deux CHPOINT
  39. C_______________________________________________________________________
  40. C
  41. CALL LIROBJ('CHPOINT',ICHP1,0,IRETOU)
  42. IF (IRETOU.EQ.0) GOTO 1
  43. CALL LIROBJ('CHPOINT',ICHP2,0,IRETOU)
  44. IF (IRETOU.EQ.0) THEN
  45. CALL REFUS
  46. GOTO 1
  47. ENDIF
  48.  
  49. CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU)
  50. IF ( IRETOU .EQ. 1) THEN
  51. CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU)
  52. IF (IERR .NE. 0) RETURN
  53.  
  54. CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU)
  55. IF (IERR .NE. 0) RETURN
  56. CALL MUCHP1(ICHP1,ICHP2,LMOT1,LMOT2,LMOT3,1,IRET)
  57. ELSE
  58.  
  59. CALL MUPOSC(ICHP1,ICHP2,1,IRET)
  60. ENDIF
  61.  
  62. IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET)
  63.  
  64. RETURN
  65. C
  66. 1 CONTINUE
  67. IF (IERR .NE. 0) RETURN
  68. C_______________________________________________________________________
  69. C
  70. C multiplication de deux ENTIER
  71. C_______________________________________________________________________
  72. C
  73. CALL LIRENT(IRE1,0,IRETOU)
  74. IF (IRETOU.EQ.0) GOTO 2
  75. CALL LIRENT(IRE2,0,IRETOU)
  76. IF (IRETOU.EQ.0) THEN
  77. CALL REFUS
  78. GOTO 2
  79. ENDIF
  80.  
  81. C Cas du produit de 2 ENTIERS
  82. CALL ECRENT(IRE1*IRE2)
  83. RETURN
  84. C
  85. 2 CONTINUE
  86. IF (IERR .NE. 0) RETURN
  87. C_______________________________________________________________________
  88. C
  89. C multiplication de deux FLOTTANT
  90. C_______________________________________________________________________
  91. C
  92. CALL LIRREE(FLO1,0,IRETOU)
  93. IF (IRETOU.EQ.0) GOTO 3
  94. CALL LIRREE(FLO2,0,IRETOU)
  95. IF (IRETOU.EQ.0) THEN
  96. CALL REFUS
  97. GOTO 3
  98. ENDIF
  99. CALL ECRREE(FLO1*FLO2)
  100. RETURN
  101. C
  102. 3 CONTINUE
  103. IF (IERR .NE. 0) RETURN
  104. C_______________________________________________________________________
  105. C
  106. C produit d'un FLOTTANT par un POINT
  107. C_______________________________________________________________________
  108. C
  109. CALL LIRREE(FLO1,0,IRETOU)
  110. IF (IRETOU.EQ.0) GOTO 4
  111. CALL LIROBJ('POINT',IPT,0,IRETOU)
  112. IF (IRETOU.EQ.0) THEN
  113. CALL REFUS
  114. GOTO 4
  115. ENDIF
  116. SEGACT MCOORD*MOD
  117. DO ILDIM=1,IDIM+1
  118. XCOOR(**)=XCOOR((IPT-1)*(IDIM+1)+ILDIM)*FLO1
  119. ENDDO
  120. IRET=XCOOR(/1)/(IDIM+1)
  121. CALL ECROBJ('POINT',IRET)
  122. RETURN
  123. C
  124. 4 CONTINUE
  125. IF (IERR .NE. 0) RETURN
  126. C_______________________________________________________________________
  127. C
  128. C produit d'un CHPOINT par un FLOTTANT
  129. C_______________________________________________________________________
  130. C
  131. CALL LIRREE(FLO,0,IRETOU)
  132. IF (IRETOU.EQ.0) GOTO 5
  133. CALL LIROBJ('CHPOINT',ICH1,0,IRETOU)
  134. IF (IRETOU.EQ.0) THEN
  135. CALL REFUS
  136. GOTO 5
  137. ENDIF
  138. C IOPERA= 2 pour l'operation PRODUIT
  139. C IARGU = 2 pour FLOTTANT
  140. IOPERA= 2
  141. IARGU = 2
  142. I1 = 0
  143. CALL OPCHP1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  144. IF(IRET.NE.0) THEN
  145. CALL ECROBJ('CHPOINT',ICHR)
  146. ELSE
  147. CALL ERREUR(26)
  148. ENDIF
  149. RETURN
  150. C
  151. 5 CONTINUE
  152. IF (IERR .NE. 0) RETURN
  153. C_______________________________________________________________________
  154. C
  155. C produit d'un MCHAML par un FLOTTANT
  156. C_______________________________________________________________________
  157. C
  158. CALL LIRREE(FLO,0,IRETOU)
  159. IF (IRETOU.EQ.0) GOTO 6
  160. CALL LIROBJ('MCHAML',ICH1,0,IRETOU)
  161. IF (IRETOU.EQ.0) THEN
  162. CALL REFUS
  163. GOTO 6
  164. ENDIF
  165. C IOPERA= 2 pour l'operation PRODUIT
  166. C IARGU = 2 pour FLOTTANT
  167. IOPERA= 2
  168. IARGU = 2
  169. I1 = 0
  170. CALL OPCHE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  171. IF(IRET.NE.0) THEN
  172. CALL ECROBJ('MCHAML',ICHR)
  173. ELSE
  174. CALL ERREUR(26)
  175. ENDIF
  176. RETURN
  177. C
  178. 6 CONTINUE
  179. IF (IERR .NE. 0) RETURN
  180. C_______________________________________________________________________
  181. C
  182. C produit d'une RIGIDITE par un FLOTTANT
  183. C_______________________________________________________________________
  184. C
  185. CALL LIRREE(FLO,0,IRETOU)
  186. IF (IRETOU.EQ.0) GOTO 7
  187. CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU)
  188. IF (IRETOU.EQ.0) THEN
  189. CALL REFUS
  190. GOTO 7
  191. ENDIF
  192. CALL MUFLRI(IRIG,FLO,IRET,1)
  193. IF (IRET.NE.0) CALL ECROBJ('RIGIDITE',IRET)
  194. RETURN
  195. C
  196. 7 CONTINUE
  197. IF (IERR .NE. 0) RETURN
  198. C_______________________________________________________________________
  199. C
  200. C produit d'un MATRIK par un FLOTTANT
  201. C_______________________________________________________________________
  202. C
  203. CALL LIRREE(FLO,0,IRETOU)
  204. IF (IRETOU.EQ.0) GOTO 71
  205. CALL LIROBJ('MATRIK ',IRIG,0,IRETOU)
  206. IF (IRETOU.EQ.0) THEN
  207. CALL REFUS
  208. GOTO 71
  209. ENDIF
  210. CALL PRDMF(FLO,IRIG,IRET)
  211. IF (IRET.NE.0) CALL ECROBJ('MATRIK ',IRET)
  212. RETURN
  213. C
  214. 71 CONTINUE
  215. IF (IERR .NE. 0) RETURN
  216. C_______________________________________________________________________
  217. C
  218. C produit d'une RIGIDITE par un CHPOINT
  219. C_______________________________________________________________________
  220. C
  221. CALL LIROBJ('CHPOINT',ICHP,0,IRETOU)
  222. IF (IRETOU.EQ.0) GOTO 8
  223. CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU)
  224. IF (IRETOU.EQ.0) THEN
  225. CALL REFUS
  226. GOTO 8
  227. ENDIF
  228. CALL MUCPRI(ICHP,IRIG,IRET)
  229. CALL ECROBJ('CHPOINT',IRET)
  230. RETURN
  231. C
  232. 8 CONTINUE
  233. IF (IERR .NE. 0) RETURN
  234. C_______________________________________________________________________
  235. C
  236. C produit d'un MATRIK par un CHPOINT
  237. C_______________________________________________________________________
  238. C
  239. CALL LIROBJ('CHPOINT',ICHP,0,IRETOU)
  240. IF (IRETOU.EQ.0) GOTO 9
  241. CALL LIROBJ('MATRIK ',IRIG,0,IRETOU)
  242. IF (IRETOU.EQ.0) THEN
  243. CALL REFUS
  244. GOTO 9
  245. ENDIF
  246. CALL PRDMCP(IRIG,ICHP,IRET)
  247. CALL ECROBJ('CHPOINT',IRET)
  248. RETURN
  249. C
  250. 9 CONTINUE
  251. IF (IERR .NE. 0) RETURN
  252.  
  253. C_______________________________________________________________________
  254. C
  255. C produit de deux MCHAML
  256. C_______________________________________________________________________
  257. C
  258. CALL LIROBJ('MMODEL',IPMODL,0,IRETOU)
  259. IF (IRETOU.EQ.0) IPMODL=0
  260. CALL LIROBJ('MCHAML',ICHP1,0,IRETOU)
  261. IF (IRETOU.EQ.0) GOTO 10
  262. CALL LIROBJ('MCHAML',ICHP2,0,IRETOU)
  263. IF (IRETOU.EQ.0) THEN
  264. CALL REFUS
  265. GOTO 10
  266. ENDIF
  267. C
  268. LMOT1 = -1
  269. LMOT2 = -1
  270. LMOT3 = -1
  271. ILREE = -1
  272. CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU)
  273. IF ( IRETOU .EQ. 1) THEN
  274. CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU)
  275. IF (IERR .NE. 0) RETURN
  276. CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU)
  277. IF (IERR .NE. 0) RETURN
  278. CALL LIROBJ('LISTREEL',ILREE,0,IRETOU)
  279. IF (IERR .NE. 0) RETURN
  280. ENDIF
  281. C
  282. CALL MUCHSC(IPMODL,ICHP1,ICHP2,IPCHMU,LMOT1,LMOT2,LMOT3,ILREE,1)
  283. IF(IERR.NE.0) RETURN
  284. C
  285. IF (IPCHMU.NE.0) THEN
  286. CALL ECROBJ('MCHAML',IPCHMU)
  287. ELSE
  288. CALL ERREUR(26)
  289. ENDIF
  290. RETURN
  291.  
  292. 10 CONTINUE
  293. IF (IERR .NE. 0) RETURN
  294. C_______________________________________________________________________
  295. C
  296. C produit ENTIER EVOLUTION
  297. C_______________________________________________________________________
  298. C
  299. CALL LIRENT(I1,0,IRETOU)
  300. IF (IRETOU.EQ.0) GOTO 101
  301. CALL LIROBJ('EVOLUTIO',ICH1,0,IRETOU)
  302. IF (IRETOU.EQ.0) THEN
  303. CALL REFUS
  304. GOTO 101
  305. ENDIF
  306. C IOPERA= 2 pour l'operation PRODUIT
  307. C IARGU = 1 pour ENTIER
  308. IOPERA= 2
  309. IARGU = 1
  310. FLO = REAL(0.D0)
  311. CALL OPEVO1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  312. IF(IRET.NE.0) THEN
  313. CALL ECROBJ('EVOLUTIO',ICHR)
  314. ELSE
  315. CALL ERREUR(26)
  316. ENDIF
  317. RETURN
  318. C
  319. 101 CONTINUE
  320. IF (IERR .NE. 0) RETURN
  321. C_______________________________________________________________________
  322. C
  323. C produit FLOTTANT EVOLUTION
  324. C_______________________________________________________________________
  325. C
  326. CALL LIRREE(FLO,0,IRETOU)
  327. IF (IRETOU.EQ.0) GOTO 11
  328. CALL LIROBJ('EVOLUTIO',ICH1,0,IRETOU)
  329. IF (IRETOU.EQ.0) THEN
  330. CALL REFUS
  331. GOTO 11
  332. ENDIF
  333. C IOPERA= 2 pour l'operation PRODUIT
  334. C IARGU = 2 pour FLOTTANT
  335. IOPERA= 2
  336. IARGU = 2
  337. I1 = 0
  338. CALL OPEVO1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  339. IF(IRET.NE.0) THEN
  340. CALL ECROBJ('EVOLUTIO',ICHR)
  341. ELSE
  342. CALL ERREUR(26)
  343. ENDIF
  344. RETURN
  345. C
  346. 11 CONTINUE
  347. IF (IERR .NE. 0) RETURN
  348. C_______________________________________________________________________
  349. C
  350. C produit de deux EVOLUTIO
  351. C_______________________________________________________________________
  352. C
  353. CALL LIROBJ('EVOLUTIO',IEVOL1,0,IRETOU)
  354. IF (IRETOU.EQ.0) GOTO 12
  355. CALL LIROBJ('EVOLUTIO',IEVOL2,0,IRETOU)
  356. IF (IRETOU.EQ.0) THEN
  357. CALL REFUS
  358. GOTO 12
  359. ENDIF
  360. CALL PUIS(IEVOL1,IEVOL2,IRET,1)
  361. CALL ECROBJ('EVOLUTIO',IRET)
  362. RETURN
  363. C
  364. 12 CONTINUE
  365. IF (IERR .NE. 0) RETURN
  366. C_______________________________________________________________________
  367. C
  368. C produit FLOTTANT LISTREEL
  369. C_______________________________________________________________________
  370. C
  371. CALL LIRREE(FLO,0,IRETOU)
  372. IF (IRETOU.EQ.0) GOTO 13
  373. CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
  374. IF (IRETOU.EQ.0) THEN
  375. CALL REFUS
  376. GOTO 13
  377. ENDIF
  378. C IOPERA= 2 pour l'operation PRODUIT
  379. C IARGU = 2 pour FLOTTANT
  380. IOPERA= 2
  381. IARGU = 2
  382. I1 = 0
  383. CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  384. IF(IRET.NE.0) THEN
  385. CALL ECROBJ('LISTREEL',ICHR)
  386. ELSE
  387. CALL ERREUR(26)
  388. ENDIF
  389. RETURN
  390. C
  391. 13 CONTINUE
  392. IF (IERR .NE. 0) RETURN
  393. C_______________________________________________________________________
  394. C
  395. C produit CHPOINT EVOLUTION
  396. C_______________________________________________________________________
  397. C
  398. CALL LIROBJ('CHPOINT',ICHP,0,IRETOU)
  399. IF (IRETOU.EQ.0) GOTO 14
  400. CALL LIROBJ('EVOLUTIO',IEVOL,0,IRETOU)
  401. IF (IRETOU.EQ.0) THEN
  402. CALL REFUS
  403. GOTO 14
  404. ENDIF
  405. CALL VARCHP(ICHP,IEVOL,IRET,IRETOU)
  406. IF (IRETOU.NE.0) CALL ECROBJ('CHPOINT',IRET)
  407. RETURN
  408. C
  409. 14 CONTINUE
  410. IF (IERR .NE. 0) RETURN
  411. C_______________________________________________________________________
  412. C
  413. C produit MCHAML EVOLUTION
  414. C_______________________________________________________________________
  415. C
  416. CALL LIROBJ('MCHAML',IPCHP,0,IRETOU)
  417. IF (IRETOU.EQ.0) GOTO 15
  418. CALL LIROBJ('EVOLUTIO',IEVOL,0,IRETOU)
  419. IF (IRETOU.EQ.0) THEN
  420. CALL REFUS
  421. GOTO 15
  422. ENDIF
  423. C
  424. CALL VARCHE(IPCHP,IEVOL,IPCHMU,IRETOU)
  425. C
  426. IF (IRETOU.NE.0) CALL ECROBJ('MCHAML',IPCHMU)
  427. C
  428. RETURN
  429. C
  430. 15 CONTINUE
  431. IF (IERR .NE. 0) RETURN
  432. C_______________________________________________________________________
  433. C
  434. C produit LISTREEL LISTREEL
  435. C_______________________________________________________________________
  436. C
  437. CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
  438. IF(IRETOU.EQ.0) GOTO 16
  439. CALL LIROBJ('LISTREEL',ICHR,0,IRETOU)
  440. IF (IRETOU.EQ.0) THEN
  441. CALL REFUS
  442. GOTO 16
  443. ENDIF
  444. C IOPERA= 2 pour l'operation PRODUIT
  445. C IARGU = 0
  446. IOPERA= 2
  447. IARGU = 0
  448. I1 = 0
  449. FLO = REAL(0.D0)
  450. CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  451. IF(IRET.NE.0) THEN
  452. CALL ECROBJ('LISTREEL',ICHR)
  453. ELSE
  454. CALL ERREUR(26)
  455. ENDIF
  456. RETURN
  457. C
  458. 16 CONTINUE
  459. IF (IERR .NE. 0) RETURN
  460. C_______________________________________________________________________
  461. C
  462. C produit LISTENTI ENTIER
  463. C_______________________________________________________________________
  464. C
  465. CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  466. IF(IRETOU.EQ.0) GOTO 17
  467. CALL LIRENT(IVA,0,IRETOU)
  468. IF (IRETOU.EQ.0) THEN
  469. CALL REFUS
  470. GOTO 17
  471. ENDIF
  472. SEGACT MLENT1
  473. JG=MLENT1.LECT(/1)
  474. SEGINI MLENTI
  475. DO 160 I=1,JG
  476. LECT(I)=MLENT1.LECT(I)*IVA
  477. 160 CONTINUE
  478. SEGDES MLENTI,MLENT1
  479. CALL ECROBJ('LISTENTI',MLENTI)
  480. RETURN
  481. C
  482. 17 CONTINUE
  483. IF (IERR .NE. 0) RETURN
  484. C_______________________________________________________________________
  485. C
  486. C produit LISTENTI FLOTTANT
  487. C_______________________________________________________________________
  488. C
  489. CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  490. IF(IRETOU.EQ.0) GOTO 18
  491. CALL LIRREE(XVA,0,IRETOU)
  492. IF (IRETOU.EQ.0) THEN
  493. CALL REFUS
  494. GOTO 18
  495. ENDIF
  496. SEGACT MLENT1
  497. JG=MLENT1.LECT(/1)
  498. SEGINI MLREEL
  499. DO 170 I=1,JG
  500. PROG(I)=REAL(MLENT1.LECT(I))*XVA
  501. 170 CONTINUE
  502. SEGDES MLREEL,MLENT1
  503. CALL ECROBJ('LISTREEL',MLREEL)
  504. RETURN
  505. C
  506. 18 CONTINUE
  507. IF (IERR .NE. 0) RETURN
  508. C_______________________________________________________________________
  509. C
  510. C produit LISTENTI LISTENTI
  511. C_______________________________________________________________________
  512. C
  513. CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  514. IF(IRETOU.EQ.0) GOTO 19
  515. CALL LIROBJ('LISTENTI',MLENT2,0,IRETOU)
  516. IF (IRETOU.EQ.0) THEN
  517. CALL REFUS
  518. GOTO 19
  519. ENDIF
  520. SEGACT MLENT1,MLENT2
  521. JG=MLENT2.LECT(/1)
  522. IF(MLENT1.LECT(/1).NE.JG) THEN
  523. CALL ERREUR (217)
  524. RETURN
  525. ENDIF
  526. SEGINI MLENTI
  527. DO 180 I=1,JG
  528. LECT(I)=MLENT1.LECT(I)*MLENT2.LECT(I)
  529. 180 CONTINUE
  530. SEGDES MLENTI,MLENT1,MLENT2
  531. CALL ECROBJ('LISTENTI',MLENTI)
  532. RETURN
  533. C
  534. 19 CONTINUE
  535. IF (IERR .NE. 0) RETURN
  536. C_______________________________________________________________________
  537. C
  538. C produit TABLE-VECTEUR FLOTTANT
  539. C_______________________________________________________________________
  540. C
  541. CALL LIRREE(FLO1,0,IRETOU)
  542. IF(IRETOU.EQ.0) GOTO 20
  543. CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
  544. IF (IRETOU.EQ.0) THEN
  545. CALL REFUS
  546. GOTO 20
  547. ENDIF
  548. SEGINI,MTABLE=MTAB1
  549. DO 200 I=1,MLOTAB
  550. IF (MTABTV(I).EQ.'FLOTTANT') THEN
  551. RMTABV(I)=RMTABV(I)*FLO1
  552. ELSE IF (MTABTV(I).EQ.'ENTIER ') THEN
  553. RMTABV(I)=REAL(MTABIV(I))*FLO1
  554. MTABTV(I)='FLOTTANT'
  555. ENDIF
  556. 200 CONTINUE
  557. SEGDES MTABLE,MTAB1
  558. CALL ECROBJ('TABLE',MTABLE)
  559. RETURN
  560. C
  561. 20 CONTINUE
  562. IF (IERR .NE. 0) RETURN
  563. C_______________________________________________________________________
  564. C
  565. C produit d'une RIGIDITE par un CHPOINT
  566. C_______________________________________________________________________
  567. C
  568. CALL LIROBJ('LISTCHPO',ILCHP,0,IRETOU)
  569. IF (IRETOU.EQ.0) GOTO 21
  570. CALL LIROBJ('RIGIDITE',IRIG,0,IRETOU)
  571. IF (IRETOU.EQ.0) THEN
  572. CALL REFUS
  573. GOTO 21
  574. ENDIF
  575. CALL MUCPLI(ILCHP,IRIG,IRET)
  576. CALL ECROBJ('LISTCHPO',IRET)
  577. RETURN
  578. C
  579. 21 CONTINUE
  580. IF (IERR .NE. 0) RETURN
  581.  
  582. C_______________________________________________________________________
  583. C
  584. C produit table-liaisons_statiques RIGIDITE
  585. C_______________________________________________________________________
  586. C
  587. CALL LIRTAB('LIAISONS_STATIQUES',ITBST,0,IRETOU)
  588. IF(IRETOU.EQ.0) CALL LIRTAB('BASE_DE_MODES',ITBST,0,IRETOU)
  589. IF(IRETOU.EQ.0) GOTO 22
  590. call lirobj('RIGIDITE',ir1,1,iretou)
  591. IF (IRETOU.EQ.0) THEN
  592. CALL REFUS
  593. GOTO 22
  594. ENDIF
  595. call prmu(ir1,itbst)
  596. RETURN
  597. C
  598.  
  599. 22 CONTINUE
  600. IF (IERR .NE. 0) RETURN
  601. C_______________________________________________________________________
  602. C
  603. C produit LISTREEL LISTENTI
  604. C_______________________________________________________________________
  605. C
  606. CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU)
  607. IF(IRETOU.EQ.0) GOTO 30
  608. CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  609. IF (IRETOU.EQ.0) THEN
  610. CALL REFUS
  611. GOTO 30
  612. ENDIF
  613. SEGACT MLREE1,MLENT1
  614. JG=MLENT1.LECT(/1)
  615. IF(MLREE1.PROG(/1).NE.JG) THEN
  616. CALL ERREUR (217)
  617. RETURN
  618. ENDIF
  619. SEGINI MLREEL
  620. DO 220 I=1,JG
  621. PROG(I)=MLREE1.PROG(I)*REAL(MLENT1.LECT(I))
  622. 220 CONTINUE
  623. SEGDES MLREEL,MLREE1,MLENT1
  624. CALL ECROBJ('LISTREEL',MLREEL)
  625. RETURN
  626. C_______________________________________________________________________
  627. C
  628. C ON A DONC RIEN TROUVE POUR FAIRE L OPERATION
  629. C_______________________________________________________________________
  630. C
  631. 30 CONTINUE
  632. IF (IERR .NE. 0) RETURN
  633. CALL QUETYP(MOTERR(1:8),0,IRETOU)
  634. IF(IRETOU.NE.0) THEN
  635. CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU)
  636. CALL QUETYP(MOTERR(9:16),0,IRETOU)
  637. IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? '
  638. CALL ERREUR(532)
  639. ELSE
  640. CALL ERREUR(533)
  641. ENDIF
  642.  
  643. RETURN
  644. END
  645.  
  646.  

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