Télécharger operad.eso

Retour à la liste

Numérotation des lignes :

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

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