Télécharger operdi.eso

Retour à la liste

Numérotation des lignes :

  1. C OPERDI SOURCE GF238795 18/02/01 21:16:07 9724
  2. SUBROUTINE OPERDI
  3. C_______________________________________________________________________
  4. C
  5. C DIVISE UN LISTREEL PAR UN FLOTTANT (OU UN ENTIER)
  6. C DIVISE UN LISTREEL PAR UN LISTREEL (OU UN LISTENTI) : Terme à terme
  7. C DIVISE UN CHAMPS PAR ELEMENT PAR UN FLOTTANT (OU 1 ENTIER)
  8. C DIVISE UN OBJET RIGIDITE PAR UN FLOTTANT (OU UN ENTIER)
  9. C DIVISE UN CHPOINT PAR UN CHPOINT
  10. C DIVISE UN CHPOINT PAR UN FLOTTANT (OU UN ENTIER)
  11. C DIVISE 2 NOMBRES (FLOTTANT OU ENTIER)
  12. C DIVISE UN POINT PAR UN NOMBRE
  13. C DIVISE UN OBJET EVOLUTIO PAR UN FLOTTANT (OU UN ENTIER) : Ordonnee
  14. C DIVISE UN OBJET EVOLUTIO PAR UN OBJET EVOLUTIO
  15. C DIVISE UNE TABLE SOUSTYPE VECTEUR PAR UN REEL
  16. C
  17. C PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 12/90
  18. C
  19. C_______________________________________________________________________
  20. C
  21. IMPLICIT INTEGER(I-N)
  22. IMPLICIT REAL*8(A-H,O-Z)
  23. C
  24. -INC CCREEL
  25. -INC CCOPTIO
  26. -INC SMCOORD
  27. -INC SMTABLE
  28. -INC SMLENTI
  29. -INC SMLREEL
  30. -INC SMLCHPO
  31.  
  32. CHARACTER*8 CTYP
  33.  
  34. INTEGER ICH1
  35. INTEGER IOPERA
  36. INTEGER IARGU
  37. INTEGER I1
  38. REAL *8 FLO
  39. INTEGER ICHR
  40. INTEGER IRET
  41. ICH1 = 0
  42. IOPERA = 0
  43. IARGU = 0
  44. I1 = 0
  45. FLO = 0.D0
  46. ICHR = 0
  47. IRET = 0
  48. C_______________________________________________________________________
  49. C
  50. C RECHERCHE DU TYPE DU PREMIER ARGUMENT
  51. C_______________________________________________________________________
  52. CALL QUETYP(CTYP,0,IRETOU)
  53.  
  54. C_______________________________________________________________________
  55. C
  56. C CHERCHE A LIROBJ DEUX MCHAML
  57. C_______________________________________________________________________
  58. C
  59. CALL LIROBJ('MMODEL',IPMODL,0,IRETOU)
  60. IF (IRETOU.EQ.0) IPMODL=0
  61. CALL LIROBJ('MCHAML',IPCHE1,0,IRETOU)
  62. IF(IRETOU.EQ.0) GOTO 101
  63. CALL LIROBJ('MCHAML',IPCHE2,0,IRETOU)
  64. IF(IRETOU.EQ.0) THEN
  65. CALL REFUS
  66. GOTO 101
  67. ENDIF
  68. C
  69. LMOT1 = -1
  70. LMOT2 = -1
  71. LMOT3 = -1
  72. ILREE = -1
  73. CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU)
  74. IF ( IRETOU .EQ. 1) THEN
  75. CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU)
  76. IF (IERR .NE. 0) RETURN
  77. CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU)
  78. IF (IERR .NE. 0) RETURN
  79. CALL LIROBJ('LISTREEL',ILREE,0,IRETOU)
  80. IF (IERR .NE. 0) RETURN
  81. ENDIF
  82. C
  83. CALL MUCHSC(IPMODL,IPCHE1,IPCHE2,IPCHDI,LMOT1,LMOT2,LMOT3,ILREE,
  84. $ -1)
  85. IF(IERR.NE.0) RETURN
  86. *
  87. C
  88. IF (IPCHDI.NE.0) THEN
  89. CALL ECROBJ('MCHAML',IPCHDI)
  90. ELSE
  91. CALL ERREUR(26)
  92. ENDIF
  93. RETURN
  94.  
  95. 101 CONTINUE
  96. IF (IERR.NE.0) RETURN
  97. C_______________________________________________________________________
  98. C
  99. C CHERCHE A LIROBJ UN MCHAML ET UN FLOTTANT
  100. C_______________________________________________________________________
  101. C
  102. CALL LIROBJ('MCHAML',ICH1,0,IRETOU)
  103. IF(IRETOU.EQ.0) GOTO 102
  104. CALL LIRREE(FLO,0,IRETOU)
  105. IF(IRETOU.EQ.0) THEN
  106. CALL REFUS
  107. GOTO 102
  108. ENDIF
  109. C IOPERA= 5 pour l'operation DIVISION
  110. IOPERA= 5
  111. IF (CTYP .EQ. 'MCHAML') THEN
  112. C IARGU = 2 pour MCHAML / FLOTTANT
  113. IARGU = 2
  114. ELSE
  115. C IARGU = 21 pour FLOTTANT / MCHAML
  116. IARGU = 21
  117. ENDIF
  118. I1 = 0
  119. ICHR = 0
  120. IRET = 0
  121. CALL OPCHE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  122. IF(IRET.NE.0) THEN
  123. CALL ECROBJ('MCHAML',ICHR)
  124. ELSE
  125. CALL ERREUR(26)
  126. ENDIF
  127. RETURN
  128. C_______________________________________________________________________
  129. C
  130. C CHERCHE A LIRE DEUX CHPOINT
  131. C_______________________________________________________________________
  132. C
  133. 102 CALL LIROBJ('CHPOINT ',ICHP1,0,IRETOU)
  134. IF(IRETOU.EQ.0) GOTO 103
  135. CALL LIROBJ('CHPOINT ',ICHP2,0,IRETOU)
  136. IF(IRETOU.EQ.0) THEN
  137. CALL REFUS
  138. GOTO 103
  139. ENDIF
  140. CALL LIROBJ('LISTMOTS',LMOT1,0,IRETOU)
  141. IF ( IRETOU .EQ. 1) THEN
  142. CALL LIROBJ('LISTMOTS',LMOT2,1,IRETOU)
  143. IF (IERR .NE. 0) RETURN
  144. CALL LIROBJ('LISTMOTS',LMOT3,1,IRETOU)
  145. IF (IERR .NE. 0) RETURN
  146. CALL MUCHP1(ICHP1,ICHP2,LMOT1,LMOT2,LMOT3,-1,IRET)
  147. IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET)
  148. ELSE
  149. CALL MUPOSC(ICHP1,ICHP2,-1,IRET)
  150. IF (IRET.NE.0) CALL ECROBJ('CHPOINT',IRET)
  151. ENDIF
  152. RETURN
  153. C_______________________________________________________________________
  154. C
  155. C CHERCHE A LIROBJ UN CHPOINT ET UN FLOTTANT
  156. C_______________________________________________________________________
  157. C
  158. 103 CALL LIROBJ('CHPOINT ',ICH,0,IRETOU)
  159. IF(IRETOU.EQ.0) GOTO 104
  160. CALL LIRREE(FLO,0,IRETOU)
  161. IF(IRETOU.EQ.0) THEN
  162. CALL REFUS
  163. GOTO 104
  164. ENDIF
  165. C IOPERA= 5 pour l'operation DIVISION
  166. IOPERA= 5
  167. IF (CTYP .EQ. 'CHPOINT') THEN
  168. C IARGU = 2 pour CHPOINT / FLOTTANT
  169. IARGU = 2
  170. ELSE
  171. C IARGU = 21 pour FLOTTANT / CHPOINT
  172. IARGU = 21
  173. ENDIF
  174. I1 = 0
  175. CALL OPCHP1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  176. IF(IRET.NE.0) THEN
  177. CALL ECROBJ('CHPOINT',ICHR)
  178. ELSE
  179. CALL ERREUR(26)
  180. ENDIF
  181. RETURN
  182. C_______________________________________________________________________
  183. C
  184. C CHERCHE A LIROBJ UN OBJET DE TYPE RIGIDITE ET UN FLOTTANT
  185. C_______________________________________________________________________
  186. C
  187. 104 CALL LIROBJ('RIGIDITE',IPO1,0,IRETOU)
  188. IF (IRETOU.EQ.0) GOTO 1041
  189. IF (CTYP .EQ. 'ENTIER') THEN
  190. CALL REFUS
  191. GOTO 1041
  192. ENDIF
  193. IF (CTYP .EQ. 'FLOTTANT') THEN
  194. CALL REFUS
  195. GOTO 1041
  196. ENDIF
  197. CALL LIRREE(FLO,0,IRETOU)
  198. IF (IRETOU.EQ.0) THEN
  199. CALL REFUS
  200. GOTO 1041
  201. ENDIF
  202. IF (FLO.EQ.0.) GOTO 5000
  203. CALL MUFLRI(IPO1,FLO,IRET,-1)
  204. CALL ECROBJ('RIGIDITE',IRET)
  205. RETURN
  206. C_______________________________________________________________________
  207. C
  208. C CHERCHE A LIROBJ UN OBJET DE TYPE MATRIK ET UN FLOTTANT
  209. C_______________________________________________________________________
  210. C
  211. 1041 CALL LIROBJ('MATRIK ',IPO1,0,IRETOU)
  212. IF (IRETOU.EQ.0) GOTO 105
  213. IF (CTYP .EQ. 'ENTIER') THEN
  214. CALL REFUS
  215. GOTO 105
  216. ENDIF
  217. IF (CTYP .EQ. 'FLOTTANT') THEN
  218. CALL REFUS
  219. GOTO 105
  220. ENDIF
  221. CALL LIRREE(FLO,0,IRETOU)
  222. IF (IRETOU.EQ.0) THEN
  223. CALL REFUS
  224. GOTO 105
  225. ENDIF
  226. IF (ABS(FLO).LT.XPETIT) GOTO 5000
  227. CALL PRDMF(1./FLO,IPO1,IRET)
  228. IF (IRET.NE.0) CALL ECROBJ('MATRIK ',IRET)
  229. RETURN
  230. C_______________________________________________________________________
  231. C
  232. C CHERCHE A LIROBJ UN OBJET DE TYPE EVOLUTIO ET UN FLOTTANT
  233. C_______________________________________________________________________
  234. C
  235. 105 CALL LIROBJ('EVOLUTIO',ICH,0,IRETOU)
  236. IF (IRETOU.EQ.0) GOTO 106
  237. CALL LIRENT(I1,0,IREENT)
  238. IF(IREENT.EQ.0) THEN
  239. I1 = 0
  240. CALL LIRREE(FLO,0,IREFLO)
  241. IF(IREFLO.EQ.0) THEN
  242. CALL REFUS
  243. GOTO 106
  244. ELSE
  245. IF (CTYP .EQ. 'EVOLUTIO') THEN
  246. C IARGU = 2 pour EVOLUTIO - FLOTTANT
  247. IARGU = 2
  248. ELSE
  249. C IARGU = 21 pour FLOTTANT - EVOLUTIO
  250. IARGU = 21
  251. ENDIF
  252. ENDIF
  253. ELSE
  254. FLO = REAL(0.D0)
  255. IF (CTYP .EQ. 'EVOLUTIO') THEN
  256. C IARGU = 1 pour EVOLUTIO - ENTIER
  257. IARGU = 1
  258. ELSE
  259. C IARGU = 11 pour ENTIER - EVOLUTIO
  260. IARGU = 11
  261. ENDIF
  262. ENDIF
  263. C IOPERA= 5 pour l'operation DIVISION
  264. IOPERA= 5
  265. CALL OPEVO1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  266. IF(IRET.NE.0) THEN
  267. CALL ECROBJ('EVOLUTIO',ICHR)
  268. ELSE
  269. CALL ERREUR(26)
  270. ENDIF
  271. RETURN
  272. C_______________________________________________________________________
  273. C
  274. C EVOLUTIO / EVOLUTIO
  275. C_______________________________________________________________________
  276. C
  277. 106 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
  278. IF (IRETOU.EQ.0) GOTO 107
  279. CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
  280. IF (IRETOU.EQ.0) THEN
  281. CALL REFUS
  282. GOTO 107
  283. ENDIF
  284. CALL PUIS(IPO1,IPO2,IRET,-1)
  285. CALL ECROBJ('EVOLUTIO',IRET)
  286. RETURN
  287. C_______________________________________________________________________
  288. C
  289. C CHERCHE A LIROBJ UN LISTREEL ET UN LISTREEL
  290. C_______________________________________________________________________
  291. C
  292. 107 CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
  293. IF(IRETOU.EQ.0) GOTO 1071
  294. CALL LIROBJ('LISTREEL',ICHR,0,IRETOU)
  295. IF (IRETOU.EQ.0) THEN
  296. CALL REFUS
  297. GOTO 1071
  298. ENDIF
  299. C IOPERA= 5 pour l'operation DIVISION
  300. IOPERA= 5
  301. IARGU = 0
  302. I1 = 0
  303. FLO = REAL(0.D0)
  304. CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  305. IF(IRET.NE.0) THEN
  306. CALL ECROBJ('LISTREEL',ICHR)
  307. ELSE
  308. CALL ERREUR(26)
  309. ENDIF
  310. RETURN
  311. C_______________________________________________________________________
  312. C
  313. C CHERCHE A LIROBJ UN LISTREEL ET UN LISTENTI
  314. C_______________________________________________________________________
  315. C
  316. 1071 CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU)
  317. IF(IRETOU.EQ.0) GOTO 1072
  318. CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  319. IF (IRETOU.EQ.0) THEN
  320. CALL REFUS
  321. GOTO 1072
  322. ENDIF
  323. SEGACT MLREE1,MLENT1
  324. JG=MLENT1.LECT(/1)
  325. IF(MLREE1.PROG(/1).NE.JG) THEN
  326. CALL ERREUR (217)
  327. RETURN
  328. ENDIF
  329.  
  330. SEGINI MLREE2
  331. DO I=1,JG
  332. IF(CTYP .EQ. 'LISTENTI') THEN
  333. X2 = MLREE1.PROG(I)
  334. IF(X2.EQ.0.) GOTO 5000
  335. MLREE2.PROG(I)=REAL(MLENT1.LECT(I))/X2
  336. ELSE
  337. X2 = REAL(MLENT1.LECT(I))
  338. IF(X2.EQ.0.) GOTO 5000
  339. MLREE2.PROG(I)=MLREE1.PROG(I)/X2
  340.  
  341. ENDIF
  342. ENDDO
  343. SEGDES MLREE2,MLREE1,MLENT1
  344. CALL ECROBJ('LISTREEL',MLREE2)
  345. RETURN
  346. C_______________________________________________________________________
  347. C
  348. C CHERCHE A LIROBJ UN LISTENTI ET UN LISTENTI
  349. C_______________________________________________________________________
  350. C
  351. 1072 CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  352. IF(IRETOU.EQ.0) GOTO 108
  353. CALL LIROBJ('LISTENTI',MLENT2,0,IRETOU)
  354. IF (IRETOU.EQ.0) THEN
  355. CALL REFUS
  356. GOTO 108
  357. ENDIF
  358. SEGACT,MLENT1,MLENT2
  359. JG=MLENT2.LECT(/1)
  360. IF(MLENT1.LECT(/1) .NE. JG) THEN
  361. CALL ERREUR (217)
  362. RETURN
  363. ENDIF
  364. SEGINI,MLENT3
  365. DO I=1,JG
  366. I1 = MLENT2.LECT(I)
  367. IF(I1 .EQ. 0 ) GOTO 5000
  368. MLENT3.LECT(I)=MLENT1.LECT(I)/I1
  369. ENDDO
  370. SEGDES,MLENT1,MLENT2,MLENT3
  371. CALL ECROBJ('LISTENTI',MLENT3)
  372. RETURN
  373. C_______________________________________________________________________
  374. C
  375. C LISTREEL / FLOTTANT OU ENTIER
  376. C_______________________________________________________________________
  377. C
  378. 108 CALL LIROBJ('LISTREEL',ICH1,0,IRETOU)
  379. IF(IRETOU.EQ.0) GOTO 1081
  380. CALL LIRREE(FLO,0,IRETOU)
  381. IF(IRETOU.EQ.0) THEN
  382. CALL REFUS
  383. GOTO 1081
  384. ENDIF
  385. C IOPERA= 5 pour l'operation DIVISION
  386. IOPERA= 5
  387. IF (CTYP .EQ. 'LISTREEL') THEN
  388. C IARGU = 2 pour LISTREEL / FLOTTANT
  389. IARGU = 2
  390. ELSE
  391. C IARGU = 21 pour FLOTTANT / LISTREEL (terme a terme)
  392. IARGU = 21
  393. ENDIF
  394. I1 = 0
  395. CALL OPLRE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  396. IF(IRET.NE.0) THEN
  397. CALL ECROBJ('LISTREEL',ICHR)
  398. ELSE
  399. CALL ERREUR(26)
  400. ENDIF
  401. RETURN
  402. C_______________________________________________________________________
  403. C
  404. C LISTENTI / FLOTTANT OU ENTIER
  405. C_______________________________________________________________________
  406. C
  407. 1081 CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  408. IF(IRETOU.EQ.0) GOTO 109
  409. IF (CTYP .EQ. 'ENTIER') THEN
  410. CALL REFUS
  411. GOTO 109
  412. ENDIF
  413. IF (CTYP .EQ. 'FLOTTANT') THEN
  414. CALL REFUS
  415. GOTO 109
  416. ENDIF
  417. CALL LIRENT(I1,0,IRETOU)
  418. IF(IRETOU.EQ.0) THEN
  419. GOTO 1082
  420. ELSE
  421. IF (CTYP .EQ. 'ENTIER') GOTO 109
  422. IF(I1.EQ.0) GOTO 5000
  423. SEGACT,MLENT1
  424. JG=MLENT1.LECT(/1)
  425.  
  426. SEGINI,MLENT2
  427. DO I=1, JG
  428. MLENT2.LECT(I)=MLENT1.LECT(I)/I1
  429. ENDDO
  430. SEGDES,MLENT1
  431. CALL ECROBJ('LISTENTI',MLENT2)
  432. RETURN
  433. ENDIF
  434.  
  435. 1082 CALL LIRREE(FLO,0,IRETOU)
  436. IF(IRETOU.EQ.0) THEN
  437. CALL REFUS
  438. GOTO 109
  439. ELSE
  440. IF(ABS(FLO).LT.XPETIT) GOTO 5000
  441. SEGACT,MLENT1
  442. JG=MLENT1.LECT(/1)
  443.  
  444. SEGINI,MLREE1
  445. DO I=1, JG
  446. MLREE1.PROG(I)=REAL(MLENT1.LECT(I))/FLO
  447. ENDDO
  448. SEGDES,MLREE1
  449. CALL ECROBJ('LISTREEL',MLREE1)
  450. RETURN
  451. ENDIF
  452. C_______________________________________________________________________
  453. C
  454. C CHERCHE A LIROBJ 2 ENTIERS
  455. C_______________________________________________________________________
  456. C
  457. 109 CALL LIRENT(I1,0,IRETOU)
  458. IF (IRETOU.EQ.0) GOTO 110
  459. CALL LIRENT(I2,0,IRETOU)
  460. IF (IRETOU.EQ.0) THEN
  461. CALL REFUS
  462. GOTO 110
  463. ENDIF
  464.  
  465. C Cas de la division de 2 ENTIERS
  466. IF(I2 .EQ. 0) GOTO 5000
  467. CALL ECRENT(I1/I2)
  468. RETURN
  469. C_______________________________________________________________________
  470. C
  471. C CHERCHE A LIRE DEUX FLOTTANTS
  472. C_______________________________________________________________________
  473.  
  474. 110 CALL LIRREE(X1,0,IRETOU)
  475. IF ( IRETOU.EQ.0) GOTO 111
  476. CALL LIRREE(X2,0,IRETOU)
  477. IF (IRETOU.EQ.0) THEN
  478. CALL REFUS
  479. GOTO 111
  480. ENDIF
  481.  
  482. C Cas de la division de 2 FLOTTANTS
  483. IF(ABS(X2) .LT. XPETIT) GOTO 5000
  484. IF(ABS(X2).LT.1.D0.AND.ABS(X1).GT.XGRAND*ABS(X2)) THEN
  485. XFLO = SIGN(1.D0,X1)*SIGN(1.D0,X2)*XGRAND
  486. ELSEIF(ABS(X1).LT.1.D0.AND.ABS(X2).GT.XGRAND*ABS(X1)) THEN
  487. XFLO = 0.D0
  488. ELSE
  489. XFLO = X1/X2
  490. ENDIF
  491. CALL ECRREE(XFLO)
  492. RETURN
  493. C_______________________________________________________________________
  494. C
  495. C CHERCHE A LIROBJ UN POINT ET UN FLOTTANT
  496. C_______________________________________________________________________
  497. C
  498. 111 CALL LIROBJ('POINT ',IP1,0,IRETOU)
  499. IF (IRETOU.EQ.0) GOTO 112
  500. IF (CTYP .EQ. 'ENTIER') THEN
  501. CALL REFUS
  502. GOTO 112
  503. ENDIF
  504. IF (CTYP .EQ. 'FLOTTANT') THEN
  505. CALL REFUS
  506. GOTO 112
  507. ENDIF
  508. CALL LIRREE(X2,0,IRETOU)
  509. IF (IRETOU.EQ.0) THEN
  510. CALL REFUS
  511. GOTO 112
  512. ENDIF
  513. IF(ABS(X2).LT.XPETIT) GOTO 5000
  514. SEGACT MCOORD*MOD
  515. ID=IDIM+1
  516. IREF=ID*(IP1-1)
  517. DO 11 I=1,ID
  518. XCOOR(**)=XCOOR(IREF+I)/X2
  519. 11 CONTINUE
  520. IR=XCOOR(/1)/ID
  521. CALL ECROBJ('POINT ',IR)
  522. RETURN
  523. C_______________________________________________________________________
  524. C
  525. C CHERCHE A LIRE UNE TABLE SOUSTYPE VECTEUR ET UN FLOTTANT
  526. C_______________________________________________________________________
  527. C
  528. 112 CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
  529. IF(IRETOU.EQ.0) GOTO 113
  530. IF (CTYP .EQ. 'ENTIER') THEN
  531. CALL REFUS
  532. GOTO 113
  533. ENDIF
  534. IF (CTYP .EQ. 'FLOTTANT') THEN
  535. CALL REFUS
  536. GOTO 113
  537. ENDIF
  538. CALL LIRREE(X2,0,IRETOU)
  539. IF (IRETOU.EQ.0) THEN
  540. CALL REFUS
  541. GOTO 113
  542. ENDIF
  543. IF(ABS(X2).LT.XPETIT) GOTO 5000
  544. SEGINI,MTABLE=MTAB1
  545. DO 701 I=1,MLOTAB
  546. IF (MTABTV(I).EQ.'FLOTTANT') THEN
  547. RMTABV(I)=RMTABV(I)/X2
  548. ELSEIF (MTABTV(I).EQ.'ENTIER ') THEN
  549. RMTABV(I)=MTABIV(I)/X2
  550. MTABTV(I)='FLOTTANT'
  551. ENDIF
  552. 701 CONTINUE
  553. SEGDES MTABLE,MTAB1
  554. CALL ECROBJ('TABLE',MTABLE)
  555. RETURN
  556. C
  557. 113 CALL LIROBJ('LISTCHPO',LIPO1,0,IRETOU)
  558. IF(IRETOU.EQ.0) GOTO 114
  559. CALL LIROBJ('LISTREEL',LREE1,0,IRETOU)
  560. IF(IRETOU.EQ.0) THEN
  561. CALL REFUS
  562. GOTO 114
  563. ENDIF
  564. mlreel = lree1
  565. mlchp1 = lipo1
  566. segact mlchp1,mlreel
  567. jg = prog(/1)
  568. n1 = mlchp1.ichpoi(/1)
  569. if (jg.ne.n1) call erreur(3)
  570. if (ierr.ne.0) return
  571. segini mlchpo
  572. do ic = 1,n1
  573. flo = prog(ic)
  574. ipo1 = mlchp1.ichpoi(ic)
  575. IF(ABS(FLO).LT.XPETIT) GOTO 5000
  576. FLD=FLO
  577. CALL MUCHPO(IPO1,FLD,IRET,-1)
  578. IF(IRET.EQ.0) RETURN
  579. ichpoi(ic) = iret
  580. enddo
  581. segdes mlchpo,mlchp1,mlreel
  582. CALL ECROBJ('LISTCHPO',mlchpo)
  583. RETURN
  584. C_______________________________________________________________________
  585. C
  586. C ON A DONC RIEN TROUVE POUR FAIRE L OPERATION
  587. C_______________________________________________________________________
  588. C
  589. 114 CONTINUE
  590. CALL QUETYP(MOTERR(1:8),0,IRETOU)
  591. IF(IRETOU.NE.0) THEN
  592. CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU)
  593. CALL QUETYP(MOTERR(9:16),0,IRETOU)
  594. IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? '
  595. CALL ERREUR(532)
  596. ELSE
  597. CALL ERREUR(533)
  598. ENDIF
  599. RETURN
  600. 5000 CONTINUE
  601. CALL ERREUR(835)
  602. RETURN
  603. END
  604.  
  605.  
  606.  
  607.  
  608.  
  609.  

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