Télécharger operad.eso

Retour à la liste

Numérotation des lignes :

  1. C OPERAD SOURCE GF238795 18/02/05 21:15:38 9726
  2. SUBROUTINE OPERAD
  3. C_______________________________________________________________________
  4. C
  5. C ADDITIONNE 2 NOMBRES (ENTIER OU FLOTTANT)
  6. C 2 CHPS/ELMTS
  7. C 2 CHPS/POINT
  8. C 2 EVOLUTIONS
  9. C 2 LISTES REELLES
  10. C 2 LISTES ENTIERES
  11. C 2 TABLES SOUS-TYPE VECTEUR
  12. C
  13. C PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 29 10 90
  14. C
  15. C_______________________________________________________________________
  16. C
  17. IMPLICIT INTEGER(I-N)
  18. IMPLICIT real*8 (a-h,o-z)
  19. C
  20. -INC CCOPTIO
  21. -INC SMTABLE
  22. -INC SMLENTI
  23. -INC SMLREEL
  24.  
  25. C
  26. LOGICAL ir1
  27. CHARACTER*8 CHA1,CHA2,CTYP
  28. REAL*8 FLOT1
  29. REAL*8 FLOTTO
  30. REAL*8 X1,X2
  31. INTEGER ENTI1
  32. INTEGER ENTITO
  33.  
  34. INTEGER ICH1
  35. INTEGER IOPERA
  36. INTEGER IARGU
  37. INTEGER I1
  38. REAL*8 FLO
  39. INTEGER ICHR
  40. INTEGER IR2
  41. INTEGER IRET
  42. INTEGER IRETOU
  43. INTEGER IREFLO
  44.  
  45. ICH1 = 0
  46. IOPERA = 0
  47. IARGU = 0
  48. I1 = 0
  49. FLO = 0.D0
  50. ICHR = 0
  51. IRET = 0
  52.  
  53.  
  54. CHA1 = ' '
  55. CHA2 = ' '
  56. CTYP = ' '
  57. C_______________________________________________________________________
  58. C
  59. C RECHERCHE DU TYPE DU PREMIER ARGUMENT
  60. C_______________________________________________________________________
  61. CALL QUETYP(CTYP,0,IRETOU)
  62. IRETOU = 0
  63.  
  64. C_______________________________________________________________________
  65. C
  66. C CHERCHE A LIRE DEUX MCHAML OU MCHAML ET FLOTTANT
  67. C_______________________________________________________________________
  68. CALL LIROBJ('MCHAML',ICH1,0,IRETOU)
  69. IF (IRETOU.EQ.0) GOTO 102
  70. CALL QUENOM(CHA1)
  71. CALL LIROBJ('MCHAML',ICH2,0,IRETOU)
  72.  
  73. IF (IRETOU .EQ. 0) THEN
  74. CALL LIRREE(FLO,0,IRETOU)
  75. IF(IRETOU.EQ.0) THEN
  76. CALL REFUS
  77. GOTO 102
  78. ENDIF
  79. C IOPERA= 3 pour l'operation ADDITION
  80. IOPERA= 3
  81. C IARGU = 2 pour MCHAML + FLOTTANT
  82. IARGU = 2
  83. I1 = 0
  84. ICHR = 0
  85. IRET = 0
  86. CALL OPCHE1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  87. IF(IRET.NE.0) THEN
  88. CALL ECROBJ('MCHAML',ICHR)
  89. ELSE
  90. CALL ERREUR(26)
  91. ENDIF
  92.  
  93. ELSE
  94. CALL ADCHEL(ICH1,ICH2,IPCHAD,1)
  95. IF (IPCHAD .EQ. 0) RETURN
  96. CALL ECROBJ('MCHAML',IPCHAD)
  97. ENDIF
  98. RETURN
  99. C_______________________________________________________________________
  100. C
  101. C CHERCHE A LIRE DES CHPOINT
  102. C_______________________________________________________________________
  103. 102 CALL LIROBJ('CHPOINT ',IPO1,0,IRETOU)
  104. IF (IRETOU.EQ.0) GOTO 103
  105. CALL LIROBJ('CHPOINT ',IPO2,0,IRETOU)
  106. IF(IRETOU.EQ.0) THEN
  107. CALL REFUS
  108. GO TO 103
  109. ENDIF
  110. CALL ADCHPO(IPO1,IPO2,IRET,1D0,1D0)
  111. IF(IRET.EQ.0) RETURN
  112. CALL ECROBJ('CHPOINT ',IRET)
  113. RETURN
  114. C_______________________________________________________________________
  115. C
  116. C CHERCHE A LIRE UN CHPOINT ET UN FLOTTANT
  117. C_______________________________________________________________________
  118. 103 CALL LIROBJ('CHPOINT ',ICH1,0,IRETOU)
  119. IF (IRETOU.EQ.0) GOTO 104
  120. CALL LIRREE(FLO,0,IRETOU)
  121. IF (IRETOU.EQ.0) THEN
  122. CALL REFUS
  123. GO TO 104
  124. ENDIF
  125. C IOPERA= 3 pour l'operation ADDITION
  126. C IARGU = 2 pour FLOTTANT
  127. IOPERA= 3
  128. IARGU = 2
  129. I1 = 0
  130. CALL OPCHP1(ICH1,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  131. IF(IRET.NE.0) THEN
  132. CALL ECROBJ('CHPOINT',ICHR)
  133. ELSE
  134. CALL ERREUR(26)
  135. ENDIF
  136. RETURN
  137. C_______________________________________________________________________
  138. C
  139. C CHERCHE A LIROBJ DES EVOLUTIO
  140. C_______________________________________________________________________
  141. 104 CALL LIROBJ('EVOLUTIO',IPO1,0,IRETOU)
  142. IF(IRETOU.EQ.0) GOTO 105
  143. CALL LIROBJ('EVOLUTIO',IPO2,0,IRETOU)
  144. IF(IRETOU.EQ.0) THEN
  145. CALL REFUS
  146. GO TO 105
  147. ENDIF
  148. CALL ADEVOL(IPO1,IPO2,IRET,1)
  149. IF(IRET.EQ.0) RETURN
  150. CALL ECROBJ('EVOLUTIO',IRET)
  151. RETURN
  152. C_______________________________________________________________________
  153. C
  154. C CHERCHE A LIROBJ DES LISTREEL
  155. C_______________________________________________________________________
  156. 105 CALL LIROBJ('LISTREEL',ICH,0,IRETOU)
  157. IF(IRETOU.EQ.0) GOTO 106
  158. CALL LIROBJ('LISTREEL',ICHR,0,IRETOU)
  159. IF(IRETOU.EQ.0) THEN
  160. CALL REFUS
  161. GO TO 106
  162. ENDIF
  163. C Addition entre LISTREEL et LISTREEL terme a terme
  164. C IOPERA= 3 pour l'operation ADDITION
  165. C IARGU = 0 pour ne pas utiliser I1 et FLO
  166. IOPERA= 3
  167. IARGU = 0
  168. I1 = 0
  169. FLO = REAL(0.D0)
  170. CALL OPLRE1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  171. IF(IRET.NE.0) THEN
  172. CALL ECROBJ('LISTREEL',ICHR)
  173. ELSE
  174. CALL ERREUR(26)
  175. ENDIF
  176. RETURN
  177. C_______________________________________________________________________
  178. C
  179. C CHERCHE A LIROBJ DES LISTENTI
  180. C_______________________________________________________________________
  181. 106 CALL LIROBJ('LISTENTI',IPO1,0,IRETOU)
  182. IF(IRETOU.EQ.0) GOTO 1061
  183. CALL LIROBJ('LISTENTI',IPO2,0,IRETOU)
  184. IF(IRETOU.EQ.0) THEN
  185. CALL REFUS
  186. GO TO 1061
  187. ENDIF
  188. CALL ADLISE(IPO1,IPO2,IRET,1)
  189. IF(IRET.EQ.0) RETURN
  190. CALL ECROBJ('LISTENTI',IRET)
  191. RETURN
  192. C_______________________________________________________________________
  193. C
  194. C CHERCHE A LIROBJ 1 LISTREEL ET 1 LISTE ENTIER
  195. C_______________________________________________________________________
  196. 1061 CALL LIROBJ('LISTREEL',IPO1,0,IRETOU)
  197. IF(IRETOU.EQ.0) GOTO 1062
  198. CALL LIROBJ('LISTENTI',MLENTI,0,IRETOU)
  199. IF(IRETOU.EQ.0) THEN
  200. CALL REFUS
  201. GO TO 1062
  202. ELSE
  203. C Conversion du LISTENTI en LISTREEL
  204. SEGACT MLENTI
  205. JG=LECT(/1)
  206. SEGINI MLREEL
  207. DO IG=1,JG
  208. FLOT1 = REAL(LECT(IG))
  209. PROG(IG)= FLOT1
  210. ENDDO
  211. SEGDES MLREEL
  212. SEGDES MLENTI
  213. ENDIF
  214.  
  215. CALL ADLISR(IPO1,MLREEL,IRET,1)
  216. IF(IRET.EQ.0) RETURN
  217. CALL ECROBJ('LISTREEL',IRET)
  218. RETURN
  219. C_______________________________________________________________________
  220. C
  221. C CHERCHE A LIROBJ 1 LISTREEL ET 1 ENTIER / FLOTTANT
  222. C_______________________________________________________________________
  223. 1062 CALL LIROBJ('LISTREEL',ICH,0,IRETOU)
  224. IF(IRETOU.EQ.0) GOTO 1063
  225. CALL LIRREE(FLO,0,IRETOU)
  226. IF(IRETOU.EQ.0) THEN
  227. CALL REFUS
  228. GO TO 1063
  229. ENDIF
  230. C Addition entre l'ENTIER/FLOTTANT et tous les indices du LISTREEL
  231. C IOPERA= 3 pour l'operation ADDITION
  232. C IARGU = 2 pour FLOTTANT
  233. IOPERA= 3
  234. IARGU = 2
  235. I1 = 0
  236. CALL OPLRE1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  237. IF(IRET.NE.0) THEN
  238. CALL ECROBJ('LISTREEL',ICHR)
  239. ELSE
  240. CALL ERREUR(26)
  241. ENDIF
  242. RETURN
  243. C_______________________________________________________________________
  244. C
  245. C CHERCHE A LIROBJ 1 LISTENTI ET 1 ENTIER / FLOTTANT
  246. C_______________________________________________________________________
  247. 1063 CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  248. IF(IRETOU.EQ.0) GOTO 107
  249.  
  250. CALL LIRENT(I1,0,IRET1)
  251. CALL LIRREE(X1,0,IR2)
  252.  
  253. IF( (IRET1.EQ.0) .AND. (IR2.EQ.0)) THEN
  254. CALL REFUS
  255. GO TO 107
  256. ELSE
  257. C Addition entre l''ENTIER/FLOTTANT et tous les indices du LISTENTIER
  258. SEGACT MLENT1
  259. JG=MLENT1.LECT(/1)
  260. IF (IRET1 .NE. 0) THEN
  261. C Cas de la Addition avec un ENTIER
  262. SEGINI MLENT2
  263. DO IG=1,JG
  264. IENT1 = I1 + MLENT1.LECT(IG)
  265. MLENT2.LECT(IG)= IENT1
  266. ENDDO
  267. SEGDES MLENT2
  268. CALL ECROBJ('LISTENTI',MLENT2)
  269. ELSEIF (IR2 .NE. 0) THEN
  270. C Cas de l''Addition avec un FLOTTANT
  271. SEGINI MLREE2
  272. DO IG=1,JG
  273. FLOT1 = X1 + REAL(MLENT1.LECT(IG))
  274. MLREE2.PROG(IG)= FLOT1
  275. ENDDO
  276. SEGDES MLREE2
  277. CALL ECROBJ('LISTREEL',MLREE2)
  278. ENDIF
  279. SEGDES MLENT1
  280. ENDIF
  281. RETURN
  282. C_______________________________________________________________________
  283. C
  284. C CHERCHE A LIRE 2 NOMBRES ENTIERS
  285. C_______________________________________________________________________
  286. 107 CALL LIRENT(I1,0,IRETOU)
  287. IF (IRETOU.EQ.0) GOTO 108
  288. CALL LIRENT(I2,0,IRETOU)
  289. IF (IRETOU.EQ.0) THEN
  290. CALL REFUS
  291. GO TO 108
  292. ENDIF
  293. CALL ECRENT(I1+I2)
  294. RETURN
  295. C_______________________________________________________________________
  296. C
  297. C CHERCHE A LIRE 2 NOMBRES FLOTTANTS
  298. C_______________________________________________________________________
  299. 108 CALL LIRREE(X1,0,IRETOU)
  300. IF (IRETOU.EQ.0) GOTO 109
  301. CALL LIRREE(X2,0,IRETOU)
  302. IF (IRETOU.EQ.0) THEN
  303. CALL REFUS
  304. GO TO 109
  305. ENDIF
  306. CALL ECRREE(X1+X2)
  307. RETURN
  308. C_______________________________________________________________________
  309. C
  310. C CHERCHE A LIROBJ 2 TABLES SOUS-TYPE VECTEUR
  311. C_______________________________________________________________________
  312. 109 CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
  313. IF(IRETOU.EQ.0) GO TO 110
  314. CALL QUENOM(MOTERR(1:8))
  315. CALL LIRTAB('VECTEUR',MTAB2,0,IRETOU)
  316. IF (IRETOU.EQ.0) THEN
  317. CALL REFUS
  318. GO TO 110
  319. ENDIF
  320. CALL QUENOM(MOTERR(9:16))
  321. SEGINI,MTABLE=MTAB1
  322. SEGACT MTAB2
  323. DO 71 J=1,MTAB2.MLOTAB
  324. CHA1=MTAB2.MTABTI(J)
  325. X1=MTAB2.RMTABI(J)
  326. IVA1=MTAB2.MTABII(J)
  327. DO 72 I=1,MLOTAB
  328. IF (CHA1.NE.MTABTI(I)) GOTO 72
  329. IF (CHA1.EQ.'FLOTTANT') THEN
  330. IF (X1.NE.RMTABI(I)) GOTO 72
  331. ELSE
  332. IF (IVA1.NE.MTABII(I)) GOTO 72
  333. ENDIF
  334. C ON A UN INDICE COMMUN ON REGARDE SI LE TYPE DE LA DONNEE EST SOMMABLE
  335. CHA2=MTAB2.MTABTV(J)
  336. IF (CHA2.EQ.'FLOTTANT') THEN
  337. IF (MTABTV(I).EQ.'FLOTTANT') THEN
  338. RMTABV(I)=RMTABV(I)+MTAB2.RMTABV(J)
  339. ELSEIF (MTABTV(I).EQ.'ENTIER ') THEN
  340. MTABTV(I)='FLOTTANT'
  341. RMTABV(I)=MTABIV(I)+MTAB2.RMTABV(J)
  342. ELSE
  343. CALL ERREUR(135)
  344. ENDIF
  345. ELSEIF (CHA2.EQ.'ENTIER ') THEN
  346. IF (MTABTV(I).EQ.'ENTIER ') THEN
  347. MTABIV(I)=MTABIV(I)+MTAB2.MTABIV(J)
  348. ELSEIF (MTABTV(I).EQ.'FLOTTANT') THEN
  349. RMTABV(I)=RMTABV(I)+MTAB2.MTABIV(J)
  350. ELSE
  351. CALL ERREUR(135)
  352. ENDIF
  353. ELSE
  354. IF (MTABTV(I).NE.CHA2.OR.MTABTV(I).NE.MTAB2.MTABTV(J))
  355. # CALL ERREUR(135)
  356. ENDIF
  357. C C'EST PASSE OU CA A CASSE ON SORT
  358. IF (IERR.NE.0) RETURN
  359. GOTO 71
  360. 72 CONTINUE
  361. C ON RAJOUTE LE MTAB2(J) A MTABL
  362. MLOTAB=MLOTAB+1
  363. M=MTABII(/1)
  364. IF (M.LT.MLOTAB) THEN
  365. M=M+100
  366. SEGADJ MTABLE
  367. ENDIF
  368. MTABII(MLOTAB)=MTAB2.MTABII(J)
  369. MTABTI(MLOTAB)=MTAB2.MTABTI(J)
  370. RMTABI(MLOTAB)=MTAB2.RMTABI(J)
  371. MTABIV(MLOTAB)=MTAB2.MTABIV(J)
  372. MTABTV(MLOTAB)=MTAB2.MTABTV(J)
  373. RMTABV(MLOTAB)=MTAB2.RMTABV(J)
  374. 71 CONTINUE
  375. SEGDES MTABLE,MTAB1,MTAB2
  376. CALL ECROBJ('TABLE',MTABLE)
  377. RETURN
  378. C_______________________________________________________________________
  379. C
  380. C EST CE UNE TABLE ESCLAVE DE MCHAML
  381. C_______________________________________________________________________
  382. 110 CONTINUE
  383. CALL LIRTAB('ESCLAVE',MTABle,0,IRETOU)
  384. if (iretou.eq.0) goto 111
  385. segact mtable
  386. ml=mlotab
  387. C l'indice 1 est le sous type
  388. ind=mtabii(3)
  389. ctyp=' '
  390. call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  391. > CTYP,enti1,flot1,' ',ir1,id1)
  392. iretou=id1
  393. if (CTYP.eq.'MCHAML') then
  394. do i=4,ml
  395. ind=mtabii(i)
  396. call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  397. > CTYP,id3,rr1,' ',ir1,id2)
  398. if (ierr.ne.0) return
  399. call ADCHEL(ID1,ID2,IRETOU,1)
  400. id1=iretou
  401. enddo
  402. elseif (CTYP.eq.'CHPOINT ') then
  403. do i=4,ml
  404. ind=mtabii(i)
  405. call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  406. > CTYP,id3,rr1,' ',ir1,id2)
  407. if (ierr.ne.0) return
  408. call ADCHPO(ID1,ID2,IRETOU,1D0,1D0)
  409. id1=iretou
  410. enddo
  411. elseif (CTYP.eq.'LISTREEL') then
  412. IOPERA= 3
  413. IARGU = 0
  414. iretou=id1
  415. I1 = 0
  416. FLO = REAL(0.D0)
  417. iret=0
  418. do i=4,ml
  419. ind=mtabii(i)
  420. call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  421. > CTYP,id3,rr1,' ',ir1,id2)
  422. if (ierr.ne.0) return
  423. CALL OPLRE1(ID2,IOPERA,IARGU,I1,FLO,IRETOU,IRET)
  424. enddo
  425. elseif (CTYP.eq.'LISTENTI') then
  426. do i=4,ml
  427. ind=mtabii(i)
  428. call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  429. > CTYP,id3,rr1,' ',ir1,id2)
  430. if (ierr.ne.0) return
  431. CALL ADLISE(ID1,ID2,IRETOU,1)
  432. id1=iretou
  433. enddo
  434. elseif (CTYP.eq.'EVOLUTIO') then
  435. do i=4,ml
  436. ind=mtabii(i)
  437. call acctab(mtable,'ENTIER',ind,0.d0,' ',.true.,0,
  438. > CTYP,id3,rr1,' ',ir1,id2)
  439. if (ierr.ne.0) return
  440. CALL ADEVOL(ID1,ID2,IRETOU,1)
  441. id1=iretou
  442. enddo
  443. elseif (CTYP.eq.'ENTIER') then
  444. ENTITO=MTABLE.MTABIV(3)
  445. do i=4,ml
  446. ENTITO=ENTITO+MTABLE.MTABIV(I)
  447. enddo
  448. CALL ECRENT(ENTITO)
  449. return
  450. elseif (CTYP.eq.'FLOTTANT') then
  451. FLOTTO=RMTABV(3)
  452. do i=4,ml
  453. FLOTTO=FLOTTO+MTABLE.RMTABV(I)
  454. enddo
  455. CALL ECRREE(FLOTTO)
  456. return
  457. else
  458. moterr(1:8)='MCHAML '
  459. call erreur(-173)
  460. call erreur(648)
  461. return
  462. endif
  463. segdes mtable
  464. 100 continue
  465. if (ierr.ne.0) return
  466. call ecrobj(ctyp,iretou)
  467. return
  468. C_______________________________________________________________________
  469. C
  470. C CHERCHE A LIROBJ 1 EVOLUTIO ET 1 ENTIER / FLOTTANT
  471. C_______________________________________________________________________
  472. 111 CALL LIROBJ('EVOLUTIO',ICH,0,IRETOU)
  473. IF(IRETOU.EQ.0) GOTO 120
  474. CALL LIRENT(I1,0,IREENT)
  475. IF(IREENT.EQ.0) THEN
  476. CALL LIRREE(FLO,0,IREFLO)
  477. IF(IREFLO.EQ.0) THEN
  478. CALL REFUS
  479. GOTO 120
  480. ELSE
  481. C IARGU = 2 pour FLOTTANT
  482. IARGU = 2
  483. ENDIF
  484. ELSE
  485. C IARGU = 1 pour ENTIER
  486. IARGU = 1
  487. ENDIF
  488. C Addition entre l'ENTIER/FLOTTANT et tous les indices du EVOLUTIO
  489. C IOPERA= 3 pour l'operation ADDITION
  490. IOPERA= 3
  491. CALL OPEVO1(ICH,IOPERA,IARGU,I1,FLO,ICHR,IRET)
  492. IF(IRET.NE.0) THEN
  493. CALL ECROBJ('EVOLUTIO',ICHR)
  494. ELSE
  495. CALL ERREUR(26)
  496. ENDIF
  497. RETURN
  498. C_______________________________________________________________________
  499. C
  500. C ON A DONC RIEN TROUVE POUR FAIRE L OPERATION
  501. C_______________________________________________________________________
  502. 120 CONTINUE
  503. CALL QUETYP(MOTERR(1:8),0,IRETOU)
  504. IF(IRETOU.NE.0) THEN
  505. CALL LIROBJ(MOTERR(1:8),IRET,1,IRETOU)
  506. CALL QUETYP(MOTERR(9:16),0,IRETOU)
  507. IF (IRETOU.EQ.0) MOTERR(9:16) = ' ???? '
  508. CALL ERREUR(532)
  509. ELSE
  510. CALL ERREUR(533)
  511. ENDIF
  512.  
  513. RETURN
  514. END
  515.  
  516.  
  517.  
  518.  
  519.  
  520.  

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