Télécharger operad.eso

Retour à la liste

Numérotation des lignes :

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

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