Télécharger operso.eso

Retour à la liste

Numérotation des lignes :

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

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