Télécharger operso.eso

Retour à la liste

Numérotation des lignes :

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

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