Télécharger operso.eso

Retour à la liste

Numérotation des lignes :

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

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